fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

2007-07-02 14:10 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)

Browse Source 
* harbour/include/hbcompat.ch
    + added hb_CStr() <=> CStr() translations

  * harbour/common.mak
  * harbour/source/rtl/Makefile
  + harbour/source/rtl/hbbit.c
    + added set of hb_bit*() functions for bit manipulations:
      HB_BITAND( <nVal1>, <nVal2>, [<nVal3,...>] ) => <nResult>
      HB_BITOR( <nVal1>, <nVal2>, [<nVal3,...>] ) => <nResult>
      HB_BITXOR( <nVal1>, <nVal2>, [<nVal3,...>] ) => <nResult>
      HB_BITNOT( <nVal> ) => <nResult>
      HB_BITTEST( <nVal>, <nBit> ) => <lResult>
      HB_BITSET( <nVal>, <nBit> ) => <nResult>
      HB_BITRESET( <nVal>, <nBit> ) => <nResult>
      HB_BITSHIFT( <nVal>, <nBits> ) => <nResult>

  * harbour/contrib/tip/Makefile
  * harbour/contrib/tip/utils.c
  * harbour/contrib/tip/popcln.prg
  * harbour/contrib/tip/Changelog
  * harbour/contrib/tip/cgi.prg
  * harbour/contrib/tip/url.prg
  * harbour/contrib/tip/httpcln.prg
  * harbour/contrib/tip/client.prg
  * harbour/contrib/tip/encoder.prg
  * harbour/contrib/tip/smtpcln.prg
  * harbour/contrib/tip/mail.prg
  * harbour/contrib/tip/ftpcln.prg
  + harbour/contrib/tip/thtml.prg
  + harbour/contrib/tip/thtml.ch
  - harbour/contrib/tip/cstr.prg
    * synced with recent xHarbour modifications - please test

  * harbour/source/vm/hvm.c
    * formatting

  * harbour/source/rdd/delim1.c
  * harbour/source/rdd/dbf1.c
  * harbour/source/rdd/sdf1.c
    % do not copy date value to separate memory buffer but decode dates
      directly from record buffer

  * harbour/source/compiler/hbopt.c
    * optimize PCODE generated for:
         return <somefunc>([<params,...>])
This commit is contained in:
Przemyslaw Czerpak
2007-07-02 12:10:38 +00:00
parent 2973f78e80
commit d03f0a3274
25 changed files with 6026 additions and 320 deletions
Download Patch File Download Diff File Expand all files Collapse all files

47
harbour/ChangeLog
View File

@@ -8,6 +8,53 @@
2002-12-01 13:30 UTC+0100 Foo Bar <foo.bar@foobar.org>
*/
2007-07-02 14:10 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)
* harbour/include/hbcompat.ch
+ added hb_CStr() <=> CStr() translations
* harbour/common.mak
* harbour/source/rtl/Makefile
+ harbour/source/rtl/hbbit.c
+ added set of hb_bit*() functions for bit manipulations:
HB_BITAND( <nVal1>, <nVal2>, [<nVal3,...>] ) => <nResult>
HB_BITOR( <nVal1>, <nVal2>, [<nVal3,...>] ) => <nResult>
HB_BITXOR( <nVal1>, <nVal2>, [<nVal3,...>] ) => <nResult>
HB_BITNOT( <nVal> ) => <nResult>
HB_BITTEST( <nVal>, <nBit> ) => <lResult>
HB_BITSET( <nVal>, <nBit> ) => <nResult>
HB_BITRESET( <nVal>, <nBit> ) => <nResult>
HB_BITSHIFT( <nVal>, <nBits> ) => <nResult>
* harbour/contrib/tip/Makefile
* harbour/contrib/tip/utils.c
* harbour/contrib/tip/popcln.prg
* harbour/contrib/tip/Changelog
* harbour/contrib/tip/cgi.prg
* harbour/contrib/tip/url.prg
* harbour/contrib/tip/httpcln.prg
* harbour/contrib/tip/client.prg
* harbour/contrib/tip/encoder.prg
* harbour/contrib/tip/smtpcln.prg
* harbour/contrib/tip/mail.prg
* harbour/contrib/tip/ftpcln.prg
+ harbour/contrib/tip/thtml.prg
+ harbour/contrib/tip/thtml.ch
- harbour/contrib/tip/cstr.prg
* synced with recent xHarbour modifications - please test
* harbour/source/vm/hvm.c
* formatting
* harbour/source/rdd/delim1.c
* harbour/source/rdd/dbf1.c
* harbour/source/rdd/sdf1.c
% do not copy date value to separate memory buffer but decode dates
directly from record buffer
* harbour/source/compiler/hbopt.c
* optimize PCODE generated for:
return <somefunc>([<params,...>])
2007-06-29 13:05 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)
* harbour/source/rdd/hbsix/sxcompr.c
! fixed bug in workaround for SIX3 bug ;-)

2
harbour/common.mak
View File

@@ -411,6 +411,8 @@ RTL_LIB_OBJS = \
$(OBJ_DIR)\gttone$(OBJEXT) \
$(OBJ_DIR)\gx$(OBJEXT) \
$(OBJ_DIR)\hardcr$(OBJEXT) \
$(OBJ_DIR)\hbadler$(OBJEXT) \
$(OBJ_DIR)\hbbit$(OBJEXT) \
$(OBJ_DIR)\hbcrc$(OBJEXT) \
$(OBJ_DIR)\hbmd5$(OBJEXT) \
$(OBJ_DIR)\hbffind$(OBJEXT) \

114
harbour/contrib/tip/Changelog
View File

@@ -8,6 +8,120 @@
2002-12-01 23:12 UTC+0100 Foo Bar <foo.bar@foobar.org>
*/
2007-05-20 01:00 UTC+0100 Hannes Ziegler <hz@knowleXbase.com>
* source\tip\thtml.prg
Changed code to avoid errors with VC8
--> error C2440: 'initializing' : cannot convert from 'void *' to 'char *'
--> error C3861: 'tolower': identifier not found
2007-05-19 00:15 UTC+0100 Hannes Ziegler <hz@knowleXbase.com>
* source\tip\thtml.prg
Changed code to avoid warnings
-> Warning W0001 Ambiguous reference
-> Warning w0027 Meaningless use of expression
2007-05-18 17:45 UTC+0100 Hannes Ziegler <hz@knowleXbase.com>
* source\tip\thtml.prg
Changed HTML parser to handle malformed HTML files more graciously.
Changed Attribute parser to detect hardcoded empty values ("").
2007-05-11 18:30 UTC+0100 Hannes Ziegler <hz@knowleXbase.com>
+ tests\tiptest\loadhtml.prg
+ tests\tiptest\dbtohtml.prg
+ source\tip\thtml.prg
New HTML classes
+ THtmlDocument()
+ THtmlIterator()
+ THtmlIteratorScan()
+ THtmlIteratorRegEx()
+ THtmlNode()
New HTML functions
+ AnsiToHtml()
+ HtmlToAnsi()
+ HtmlToOem()
+ OemToHtml()
+ THtmlCleanup()
+ THtmlInit()
+ THtmlIsValid()
+ include\thtml.ch
* source\tip\ftpcln.prg
+ added method :pwd()
As a short introduction:
1) THtmlDocument() objects read/write HTML files and streams
2) THtmlNode() objects know HTML and raise errors upon illegal HTML code
3) THtmlNode() objects know the "+" and "-" operator for opening/closing an HTML tag
4) THtmlNode() objects know the ":" operator for querying/creating a HTML node .OR. attribute
(sending an unknown message results in a query of lookup tables. If that query is successful,
a HTML node .OR. the value of an attribute is returned. Otherwise, a runtime error is raised)
2007-04-23 14:30 UTC+0100 Hannes Ziegler <hz@knowleXbase.com>
* changed TIP classes to comply with OOP rules
* source\tip\client.prg
Adapted all :new() method(s) so that tIPClient becomes the
abstract super class for TIpClientFtp, TIpClientHttp, TIpClientPop and TIpClientSmtp
+ Added Method :INetErrorDesc()
+ Added Method :lastErrorCode()
+ Added Method :lastErrorMessage()
- Removed method :data() since it calls an undeclared method :getOk()
:data() is used in TIpClientSmtp
* fixed bugs resulting in corrupted file downloads
* source\tip\ftpcln.prg
Added missing FTP functionalities
+ Added method :rmd()
+ Added method :listFiles()
+ Added method :mput()
Supports progress bars
* Changed method :downloadFile() to enable display of download progress
* Changed method :uploadFile() to enable display of upload progress
* source\tip\encoder.prg
+ Added FUNCTION TIp_GetEncoder( cModel )
* source\tip\mail.prg
Added "high level" methods to easily (de)compose an eMail (with file attachments)
+ Added method :setHeader()
+ Added method :attachFile()
+ Added method :detachFile()
+ Added method :getFileName()
+ Added method :isMultiPart()
+ Added method :getMultiParts()
* source\tip\popcln.prg
New methods for easy eMail retrieval
+ Added method :countMail()
+ Added method :retrieveAll()
* source\tip\smtpcln.prg
New method to work with TIpMail objects
+ Added method :sendMail()
2005-04-29 12:00 Luiz Rafael Culik <culikr@brturbo.com>
* client.prg
* smtpcln.prg

2
harbour/contrib/tip/Makefile
View File

@@ -24,7 +24,7 @@ PRG_SOURCES= \
httpcln.prg \
mail.prg \
cgi.prg \
cstr.prg \
thtml.prg \
LIBNAME=tip

1
harbour/contrib/tip/cgi.prg
View File

@@ -61,6 +61,7 @@
*
*/
#include "hbcompat.ch"
#include 'hbclass.ch'
#include 'tip.ch'
#include 'common.ch'

131
harbour/contrib/tip/client.prg
View File

@@ -55,7 +55,25 @@
Enhaced tip cliente to conenct to secure smtp servers by Luiz Rafael Culik
*/
/* 2007-03-29, Hannes Ziegler
Adapted all :new() method(s) so that tIPClient becomes the
abstract super class for TIpClientFtp, TIpClientHttp, TIpClientPop and TIpClientSmtp
Added Methods :INetErrorDesc(), :lastErrorCode() and :lastErrorMessage()
Removed method :data() since it calls an undeclared method :getOk()
:data() is used in TIpClientSmtp
Fixed bug in :readToFile()
*/
/* 2007-06-01, Toninho@fwi
Added data ::nWrite to work like ::nRead
*/
#include "hbcompat.ch"
#include "hbclass.ch"
#include "error.ch"
#include "fileio.ch"
#include "tip.ch"
#include "common.ch"
@@ -87,14 +105,18 @@ CLASS tIPClient
DATA cReply
DATA nAccessMode
DATA nWrite
DATA nLastWrite
DATA bEof
DATA isOpen INIT .F.
/** Gauge control; it can be a codeblock or a function pointer. */
DATA exGauge
METHOD New( oUrl, oCredentials, lTrace )
DATA Cargo
METHOD New( oUrl, lTrace, oCredentials )
METHOD Open()
METHOD Read( iLen )
@@ -104,9 +126,13 @@ CLASS tIPClient
METHOD WriteFromFile( cFile )
METHOD Reset()
METHOD Close()
METHOD Data( cData )
/* METHOD Data( cData ) */ // commented: calls undeclared METHOD :getOk
METHOD lastErrorCode() INLINE ::nLastError
METHOD lastErrorMessage(SocketCon) INLINE ::INetErrorDesc(SocketCon)
PROTECTED:
DATA nLastError INIT 0
/* Methods to log data if needed */
METHOD InetRecv( SocketCon, cStr1, len)
@@ -115,6 +141,7 @@ CLASS tIPClient
METHOD InetCount( SocketCon )
METHOD InetSendAll( SocketCon, cData, nLen )
METHOD InetErrorCode(SocketCon)
METHOD InetErrorDesc(SocketCon)
METHOD InetConnect( cServer, nPort, SocketCon )
METHOD Log()
@@ -122,41 +149,48 @@ CLASS tIPClient
ENDCLASS
METHOD New( oUrl, oCredentials, lTrace ) CLASS tIPClient
LOCAL oRet
METHOD New( oUrl, lTrace, oCredentials ) CLASS tIPClient
LOCAL oErr
Default lTrace to .F.
IF .not. ::bInitSocks
InetInit()
::bInitSocks := .T.
ENDIF
DO CASE
CASE oUrl:cProto == "http"
oRet := tIPClientHTTP():New( lTrace )
CASE oUrl:cProto == "pop"
oRet := tIPClientPOP():New( lTrace )
CASE oUrl:cProto == "smtp"
oRet := tIPClientSMTP():New( lTrace )
CASE oUrl:cProto == "ftp"
oRet := tIPClientFTP():New( lTrace )
ENDCASE
IF Empty( oRet )
RETURN NIL
IF HB_IsString( oUrl )
oUrl := tUrl():New( oUrl )
ENDIF
oRet:oUrl := oUrl
oRet:oCredentials := oCredentials
oRet:nStatus := 0
oRet:bInitialized := .F.
oRet:nLastWrite := 0
oRet:nLength := -1
oRet:nRead := 0
oRet:nLastRead := 0
oRet:bEof := .F.
oRet:lTRace := lTRace
IF .NOT. oURL:cProto $ "ftp,http,pop,smtp"
oErr := ErrorNew()
oErr:Args := { Self, oURL:cProto }
oErr:CanDefault := .F.
oErr:CanRetry := .F.
oErr:CanSubstitute := .T.
oErr:Description := "unsupported protocol"
oErr:GenCode := EG_UNSUPPORTED
oErr:Operation := ::className()+":new()"
oErr:Severity := ES_ERROR
oErr:SubCode := 1081
oErr:SubSystem := "BASE"
Eval( ErrorBlock(), oErr )
ENDIF
RETURN oRet
::oUrl := oUrl
::oCredentials := oCredentials
::nStatus := 0
::bInitialized := .F.
::nWrite := 0
::nLastWrite := 0
::nLength := -1
::nRead := 0
::nLastRead := 0
::bEof := .F.
::lTrace := lTrace
RETURN self
@@ -183,6 +217,7 @@ METHOD Open( cUrl ) CLASS tIPClient
RETURN .F.
ENDIF
::isOpen := .T.
RETURN .T.
@@ -196,7 +231,7 @@ METHOD Close() CLASS tIPClient
nRet := InetClose( ::SocketCon )
::SocketCon:=nil
::isOpen := .F.
ENDIF
RETURN(nRet)
@@ -266,10 +301,10 @@ RETURN cStr0
METHOD ReadToFile( cFile, nMode, nSize ) CLASS tIPClient
LOCAL nFout
LOCAL cData
LOCAL nSent
LOCAL nSent
IF Empty ( nMode )
nMode := FO_CREAT
nMode := FC_NORMAL
ENDIF
nSent := 0
@@ -278,7 +313,9 @@ METHOD ReadToFile( cFile, nMode, nSize ) CLASS tIPClient
HB_ExecFromArray( ::exGauge, { nSent, nSize, Self } )
ENDIF
::nRead := 0
::nStatus := 1
DO WHILE ::InetErrorCode( ::SocketCon ) == 0 .and. .not. ::bEof
cData := ::Read( 1024 )
IF cData == NIL
@@ -327,6 +364,7 @@ METHOD WriteFromFile( cFile ) CLASS tIPClient
LOCAL nLen
LOCAL nSize, nSent
::nWrite := 0
::nStatus := 0
nFin := Fopen( cFile, FO_READ )
IF nFin < 0
@@ -368,6 +406,8 @@ METHOD WriteFromFile( cFile ) CLASS tIPClient
RETURN .T.
/*
HZ: METHOD :getOk() is not declared in TIpClient
METHOD Data( cData ) CLASS tIPClient
::InetSendall( ::SocketCon, "DATA" + ::cCRLF )
@@ -376,7 +416,7 @@ METHOD Data( cData ) CLASS tIPClient
ENDIF
::InetSendall(::SocketCon, cData + ::cCRLF + "." + ::cCRLF )
RETURN ::GetOk()
*/
METHOD Write( cData, nLen, bCommit ) CLASS tIPClient
@@ -393,19 +433,25 @@ METHOD Write( cData, nLen, bCommit ) CLASS tIPClient
ENDIF
::nWrite += ::nLastWrite
RETURN ::nLastWrite
METHOD InetSendAll( SocketCon, nLen, size ) CLASS tIPClient
METHOD InetSendAll( SocketCon, cData, nLen ) CLASS tIPClient
Local nRet
nRet := InetSendAll( SocketCon, nLen, size )
IF Empty( nLen )
nLen := Len( cData )
ENDIF
nRet := InetSendAll( SocketCon, cData, nLen )
if ::lTrace
::Log( SocketCon, size, nlen, nRet )
::Log( SocketCon, nlen, cData, nRet )
endif
@@ -481,7 +527,7 @@ METHOD InetErrorCode( SocketCon ) CLASS tIPClient
Local nRet
nRet := InetErrorCode( SocketCon )
::nLastError := nRet := InetErrorCode( SocketCon )
if ::lTrace
@@ -492,6 +538,19 @@ METHOD InetErrorCode( SocketCon ) CLASS tIPClient
Return nRet
METHOD InetErrorDesc( SocketCon ) CLASS tIPClient
LOCAL cMsg := ""
DEFAULT SocketCon TO ::SocketCon
IF .not. Empty( SocketCon )
cMsg := InetErrorDesc( SocketCon )
ENDIF
RETURN cMsg
/* BROKEN, should test number of parameters and act accordingly, see doc\inet.txt */
METHOD InetConnect( cServer, nPort, SocketCon ) CLASS tIPClient

96
harbour/contrib/tip/cstr.prg
View File

@@ -1,96 +0,0 @@
/*
* $Id$
*/
/*
* xHarbour Project source code:
* CStr( xAnyType ) -> String
*
* Copyright 2001 Ron Pinkas <ron@@ronpinkas.com>
* www - http://www.xharbour.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, xHarbour license gives permission for
* additional uses of the text contained in its release of xHarbour.
*
* The exception is that, if you link the xHarbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the xHarbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released with this xHarbour
* explicit exception. If you add/copy code from other sources,
* as the General Public License permits, the above exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for xHarbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
FUNCTION CStr( xExp )
LOCAL cType
IF xExp == NIL
RETURN 'NIL'
ENDIF
cType := ValType( xExp )
SWITCH cType
CASE 'C'
RETURN xExp
CASE 'D'
RETURN dToS( xExp )
CASE 'L'
RETURN IIF( xExp, '.T.', '.F.' )
CASE 'N'
RETURN Str( xExp )
CASE 'M'
RETURN xExp
CASE 'A'
RETURN "{ Array of " + LTrim( Str( Len( xExp ) ) ) + " Items }"
CASE 'B'
RETURN '{|| Block }'
CASE 'O'
RETURN "{ " + xExp:ClassName() + " Object }"
CASE 'P'
RETURN NumToHex( xExp )
CASE 'H'
RETURN "{ Hash of " + LTrim( Str( Len( xExp ) ) ) + " Items }"
OTHERWISE
RETURN "Type: " + cType
END
RETURN ""

65
harbour/contrib/tip/encoder.prg
View File

@@ -50,15 +50,54 @@
* If you do not wish that, delete this exception notice.
*
*/
/*
/*
Internet Messaging: http://www.ietf.org/rfc/rfc2045.txt
*/
/* 2007-04-12, Hannes Ziegler <hz AT knowlexbase.com>
Added Function: TIp_GetEncoder()
*/
#include "hbclass.ch"
#include "fileio.ch"
#include "tip.ch"
FUNCTION TIp_GetEncoder( cModel )
LOCAL oEncoder
IF Valtype( cModel ) <> "C"
cModel := "as-is"
ENDIF
cModel := Lower( cModel )
DO CASE
CASE cModel == "base64"
oEncoder := TIPEncoderBase64():New()
CASE cModel == "quoted-printable"
oEncoder := TIPEncoderQP():New()
CASE cModel == "url" .or. cModel == "urlencoded"
oEncoder := TIPEncoderURL():New()
CASE cModel == "7bit" .or. cModel == "8bit"
oEncoder := TIPEncoder():New( cModel )
oEncoder:cName := cModel
OTHERWISE
oEncoder := TIPEncoder():New()
ENDCASE
RETURN oEncoder
CLASS TIPEncoder
DATA cName
@@ -69,28 +108,12 @@ ENDCLASS
METHOD New( cModel ) class TIPEncoder
cModel := Lower( cModel )
IF cModel == "base64"
RETURN TIPEncoderBase64():New()
ELSEIF cModel == "quoted-printable"
RETURN TIPEncoderQP():New()
ELSEIF cModel == "url" .or. cModel == "urlencoded"
RETURN TIPEncoderURL():New()
ELSEIF cModel == "7bit" .or. cModel == "8bit"
::cName := cModel
RETURN Self
ELSEIF cModel == "text" .or. cModel == "plain";
.or. cModel == "text/plain" .or. cModel == "as-is";
.or. cModel == "7-bit" .or. cModel == "8-bit"
::cName := "as-is"
RETURN Self
IF Valtype( cModel ) <> "C"
cModel := "as-is"
ENDIF
::cName := cModel
RETURN self
RETURN NIL
METHOD Encode( cData ) class TIPEncoder
RETURN cData

356
harbour/contrib/tip/ftpcln.prg
View File

@@ -51,6 +51,19 @@
*
*/
/* 2007-04-19, Hannes Ziegler <hz AT knowlexbase.com>
Added method :RMD()
Added method :listFiles()
Added method :MPut()
Changed method :downloadFile() to enable display of progress
Changed method :uploadFile() to enable display of progress
*/
/* 2007-06-01, Toninho@fwi
Added method UserCommand( cCommand, lPasv, lReadPort, lGetReply )
*/
#include "directry.ch"
#include "hbclass.ch"
#include "tip.ch"
#include "common.ch"
@@ -68,7 +81,7 @@ CLASS tIPClientFTP FROM tIPClient
// Socket opened in response to a port command
DATA SocketControl
METHOD New()
METHOD New( oUrl,lTrace, oCredentials)
METHOD Open()
METHOD Read( nLen )
METHOD Write( nLen )
@@ -81,6 +94,8 @@ CLASS tIPClientFTP FROM tIPClient
METHOD TypeI()
METHOD TypeA()
METHOD List()
METHOD UserCommand( cCommand, lPasv, lReadPort, lGetReply )
METHOD pwd()
METHOD Cwd()
METHOD Dele()
//METHOD Port()
@@ -90,29 +105,34 @@ CLASS tIPClientFTP FROM tIPClient
METHOD Quit()
METHOD ScanLength()
METHOD ReadAuxPort()
method mget()
// Method bellow contributed by Rafa Carmona
METHOD LS( cSpec )
method mget()
// Method bellow contributed by Rafa Carmona
METHOD LS( cSpec )
METHOD Rename( cFrom, cTo )
// new method for file upload
METHOD UpLoadFile( cLocalFile, cRemoteFile )
// new method to download file
METHOD DownLoadFile( cLocalFile, cRemoteFile )
METHOD DownLoadFile( cLocalFile, cRemoteFile )
// new method to create an directory on ftp server
METHOD MKD( cPath )
METHOD RMD( cPath )
METHOD listFiles( cList )
METHOD MPut
ENDCLASS
METHOD New(lTrace) CLASS tIPClientFTP
METHOD New( oUrl,lTrace, oCredentials) CLASS tIPClientFTP
local cFile :="ftp"
local n := 0
::super:new( oUrl, lTrace, oCredentials)
::nDefaultPort := 21
::nConnTimeout := 3000
::bUsePasv := .T.
::nAccessMode := TIP_RW // a read-write protocol
::lTrace :=lTrace
if ::ltrace
if !file("ftp.log")
::nHandle := fcreate("ftp.log")
@@ -121,7 +141,7 @@ METHOD New(lTrace) CLASS tIPClientFTP
n++
enddo
::nHandle := fcreate(cFile+alltrim(str(n,2))+".log")
endif
endif
endif
// precompilation of regex for better prestations
@@ -131,7 +151,11 @@ METHOD New(lTrace) CLASS tIPClientFTP
RETURN Self
METHOD Open() CLASS tIPClientFTP
METHOD Open( cUrl ) CLASS tIPClientFTP
IF HB_IsString( cUrl )
::oUrl := tUrl():New( cUrl )
ENDIF
IF Len( ::oUrl:cUserid ) == 0 .or. Len( ::oUrl:cPassword ) == 0
RETURN .F.
@@ -159,9 +183,9 @@ METHOD GetReply() CLASS tIPClientFTP
LOCAL cRep
::cReply := ::InetRecvLine( ::SocketCon, @nLen, 128 )
cRep := ::cReply
IF cRep == NIL
RETURN .F.
ENDIF
@@ -226,6 +250,15 @@ METHOD CWD( cPath ) CLASS tIPClientFTP
::InetSendall( ::SocketCon, "CWD " + cPath + ::cCRLF )
RETURN ::GetReply()
METHOD PWD() CLASS tIPClientFTP
::InetSendall( ::SocketCon, "PWD" + ::cCRLF )
IF .not. ::GetReply()
RETURN .F.
ENDIF
::cReply := SubStr( ::cReply, At('"', ::cReply) + 1, ;
Rat('"', ::cReply) - At('"', ::cReply) - 1 )
RETURN .T.
METHOD DELE( cPath ) CLASS tIPClientFTP
::InetSendall( ::SocketCon, "DELE " + cPath + ::cCRLF )
RETURN ::GetReply()
@@ -281,17 +314,17 @@ METHOD Commit() CLASS tIPClientFTP
IF ::GetReply() .and. ::cReply[1] != "5"
RETURN .T.
ENDIF*/
RETURN .F.
RETURN .T.
METHOD List(cSpec) CLASS tIPClientFTP
LOCAL cStr
IF cSpec=nil
cSpec:=''
else
cSpec:=' '+cSpec
ENDIF
IF cSpec=nil
cSpec:=''
else
cSpec:=' '+cSpec
ENDIF
IF ::bUsePasv
IF .not. ::Pasv()
//::bUsePasv := .F.
@@ -310,6 +343,30 @@ METHOD List(cSpec) CLASS tIPClientFTP
::bEof := .f.
RETURN cStr
METHOD UserCommand( cCommand, lPasv, lReadPort, lGetReply ) CLASS tIPClientFTP
DEFAULT cCommand TO ""
DEFAULT lPasv TO .t.
DEFAULT lReadPort TO .t.
DEFAULT lGetReply TO .f.
if ::bUsePasv .and. lPasv .and. !::Pasv()
return .f.
endif
::InetSendAll( ::SocketCon, cCommand )
if lReadPort
lReadPort = ::ReadAuxPort()
endif
if lGetReply
lGetReply = ::GetReply()
endif
return .t.
METHOD ReadAuxPort(cLocalFile) CLASS tIPClientFTP
LOCAL cRet, cList := "",nFile:=0
@@ -317,25 +374,25 @@ METHOD ReadAuxPort(cLocalFile) CLASS tIPClientFTP
RETURN NIL
END
IF !empty(cLocalFile)
nFile:=fcreate(cLocalFile)
nFile:=fcreate(cLocalFile)
ENDIF
cRet := ::super:Read( 512 )
WHILE cRet != NIL .and. len( cRet ) > 0
IF nFile>0
fwrite(nFile,cRet)
else
cList += cRet
ENDIF
IF nFile>0
fwrite(nFile,cRet)
else
cList += cRet
ENDIF
cRet := ::super:Read( 512 )
END
InetClose( ::SocketCon )
::SocketCon := ::SocketControl
IF ::GetReply()
IF nFile>0
fclose(nFile)
return(.t.)
ENDIF
IF nFile>0
fclose(nFile)
return(.t.)
ENDIF
RETURN cList
ENDIF
RETURN NIL
@@ -461,6 +518,10 @@ METHOD Write( cData, nLen ) CLASS tIPClientFTP
RETURN ::super:Write( cData, nLen, .F. )
/*
* HZ: What's cLocalFile good for? It's unused
*/
METHOD Retr( cFile ) CLASS tIPClientFTP
IF ::bUsePasv
@@ -473,6 +534,7 @@ METHOD Retr( cFile ) CLASS tIPClientFTP
::InetSendAll( ::SocketCon, "RETR " + cFile+ ::cCRLF )
IF ::TransferStart()
::ScanLength()
RETURN .T.
ENDIF
@@ -484,7 +546,7 @@ METHOD MGET( cSpec,cLocalPath ) CLASS tIPClientFTP
IF cSpec == nil
cSpec := ''
ENDIF
ENDIF
IF cLocalPath=nil
cLocalPath:=''
ENDIF
@@ -506,35 +568,69 @@ METHOD MGET( cSpec,cLocalPath ) CLASS tIPClientFTP
ENDIF
RETURN cStr
RETURN cStr
METHOD MPUT( cFileSpec, cAttr ) CLASS tIPClientFTP
LOCAL cPath,cFile, cExt, aFile, aFiles
LOCAL nCount := 0
LOCAL cStr := ""
IF Valtype( cFileSpec ) <> "C"
RETURN 0
ENDIF
HB_FNameSplit( cFileSpec, @cPath, @cFile, @cExt )
aFiles := Directory( cPath + cFile + cExt, cAttr )
FOR each aFile in aFiles
IF ::uploadFile( cPath + aFile[F_NAME], aFile[F_NAME] )
cStr += INetCrlf() + aFile[F_NAME]
ENDIF
NEXT
RETURN SubStr(cStr,3)
METHOD UpLoadFile( cLocalFile, cRemoteFile ) CLASS tIPClientFTP
LOCAL cFileData
LOCAL lRet,nRet
LOCAL cPath := ""
LOCAL cFile := ""
Local cExt := ""
HB_FNameSplit( cLocalFile, @cPath, @cFile,@cExt )
DEFAULT cRemoteFile to cFile+cExt
cFileData := MemoRead(cLocalFile)
::bEof := .F.
HB_FNameSplit( cLocalFile, @cPath, @cFile,@cExt )
DEFAULT cRemoteFile to cFile+cExt
::bEof := .F.
::oUrl:cFile := cRemoteFile
nRet := ::Write( cFileData )
IF nRet == -1
lRet := .F.
ELSE
lRet := .T.
IF .not. ::bInitialized
IF Empty( ::oUrl:cFile )
RETURN -1
ENDIF
IF .not. Empty( ::oUrl:cPath )
IF .not. ::CWD( ::oUrl:cPath )
RETURN -1
ENDIF
ENDIF
IF .not. ::Stor( ::oUrl:cFile )
RETURN -1
ENDIF
// now channel is open
::bInitialized := .T.
ENDIF
::Commit() // Close Passive conection of previus file
RETURN lRet
RETURN ::WriteFromFile( cLocalFile )
METHOD LS( cSpec ) CLASS tIPClientFTP
@@ -545,14 +641,14 @@ METHOD LS( cSpec ) CLASS tIPClientFTP
ENDIF
IF ::bUsePasv
IF .not. ::Pasv()
//::bUsePasv := .F.
RETURN .F.
ENDIF
ENDIF
::InetSendAll( ::SocketCon, "NLST "+cSpec + ::cCRLF )
@@ -566,64 +662,144 @@ METHOD Rename( cFrom, cTo ) CLASS tIPClientFTP
Local lResult := .F.
::InetSendAll( ::SocketCon, "RNFR "+ cFrom + ::cCRLF )
IF ::GetReply()
::InetSendAll( ::SocketCon, "RNTO "+ cTo + ::cCRLF )
lResult := ::GetReply()
ENDIF
Return lResult
METHOD DownLoadFile( cLocalFile, cRemoteFile ) CLASS tIPClientFTP
LOCAL lRet,xRet
Local nHandle
LOCAL cPath := ""
LOCAL cFile := ""
Local cPath := ""
Local cFile := ""
Local cExt := ""
HB_FNameSplit( cLocalFile, @cPath, @cFile,@cExt )
DEFAULT cRemoteFile to cFile+cExt
HB_FNameSplit( cLocalFile, @cPath, @cFile,@cExt )
::bEof := .F.
DEFAULT cRemoteFile to cFile+cExt
::bEof := .F.
::oUrl:cFile := cRemoteFile
xRet := ::Read()
IF ISLOGICAL( xRet )
IF !xRet
lRet := .F.
IF .not. ::bInitialized
IF .not. Empty( ::oUrl:cPath )
IF .not. ::CWD( ::oUrl:cPath )
::bEof = .T. // no data for this transaction
RETURN .F.
ENDIF
ENDIF
ELSEIF ISCHARACTER( xRet )
IF EMPTY( XRET )
lRet := .F.
ELSE
nHandle := FCREATE( cLocalFile )
FWRITE( nHandle, xRet )
FCLOSE( nHandle )
lRet := .T.
IF .not. ::Retr( ::oUrl:cFile )
::bEof = .T. // no data for this transaction
RETURN .F.
ENDIF
// now channel is open
::bInitialized := .T.
ENDIF
::Commit() // Close Passive conection of previus file
RETURN lRet
RETURN ::ReadToFile( cLocalFile, , ::nLength )
// Create a new folder
METHOD MKD( cPath ) CLASS tIPClientFTP
::InetSendall( ::SocketCon, "MKD " + cPath + ::cCRLF )
RETURN ::GetReply()
// Delete an existing folder
METHOD RMD( cPath ) CLASS tIPClientFTP
::InetSendall( ::SocketCon, "RMD " + cPath + ::cCRLF )
RETURN ::GetReply()
// Parse the :list() string into a Directory() compatible 2-dim array
METHOD listFiles( cFileSpec ) CLASS tIPClientFTP
LOCAL aMonth:= { "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" }
LOCAL cList, aList, aFile, cEntry, nStart, nEnd
LOCAL cYear, cMonth, cDay, cTime
cList := ::list( cFileSpec )
IF Empty( cList )
RETURN {}
ENDIf
aList := HB_ATokens( StrTran( cList, Chr(13),''), Chr(10) )
FOR EACH cEntry IN aList
aFile := Array( F_LEN+3 )
nStart := 1
nEnd := At( Chr(32), cEntry, nStart )
// file permissions (attributes)
aFile[F_ATTR] := SubStr( cEntry, nStart, nEnd-nStart )
nStart := nEnd
// # of links
DO WHILE cEntry[++nStart] == " " ; ENDDO
nEnd := At( Chr(32), cEntry, nStart )
aFile[F_LEN+1]:= Val( SubStr( cEntry, nStart, nEnd-nStart ) )
nStart := nEnd
// owner name
DO WHILE cEntry[++nStart] == " " ; ENDDO
nEnd := At( Chr(32), cEntry, nStart )
aFile[F_LEN+2]:= SubStr( cEntry, nStart, nEnd-nStart )
nStart := nEnd
// group name
DO WHILE cEntry[++nStart] == " " ; ENDDO
nEnd := At( Chr(32), cEntry, nStart )
aFile[F_LEN+3]:= SubStr( cEntry, nStart, nEnd-nStart )
nStart := nEnd
// file size
DO WHILE cEntry[++nStart] == " " ; ENDDO
nEnd := At( Chr(32), cEntry, nStart )
aFile[F_SIZE] := Val( SubStr( cEntry, nStart, nEnd-nStart ) )
nStart := nEnd
// Month
DO WHILE cEntry[++nStart] == " " ; ENDDO
nEnd := At( Chr(32), cEntry, nStart )
cMonth := SubStr( cEntry, nStart, nEnd-nStart )
cMonth := PadL( AScan( aMonth, cMonth ), 2, "0" )
nStart := nEnd
// Day
DO WHILE cEntry[++nStart] == " " ; ENDDO
nEnd := At( Chr(32), cEntry, nStart )
cDay := SubStr( cEntry, nStart, nEnd-nStart )
nStart := nEnd
// year
DO WHILE cEntry[++nStart] == " " ; ENDDO
nEnd := At( Chr(32), cEntry, nStart )
cYear := SubStr( cEntry, nStart, nEnd-nStart )
nStart := nEnd
IF ":" $ cYear
cTime := cYear
cYear := Str( Year(Date()), 4, 0 )
ELSE
cTime := ""
ENDIF
// file name
DO WHILE cEntry[++nStart] == " " ; ENDDO
aFile[F_NAME] := SubStr( cEntry, nStart )
aFile[F_DATE] := StoD( cYear+cMonth+cDay )
aFile[F_TIME] := cTime
aList[ HB_EnumIndex() ] := aFile
NEXT
RETURN aList

13
harbour/contrib/tip/httpcln.prg
View File

@@ -51,6 +51,7 @@
*
*/
#include "hbcompat.ch"
#include "common.ch"
#include "hbclass.ch"
#include "tip.ch"
@@ -69,12 +70,12 @@ CLASS tIPClientHTTP FROM tIPClient
DATA hHeaders INIT {=>}
DATA hCookies INIT {=>}
DATA hFields INIT {=>}
DATA cUserAgent INIT "Mozilla/3.0 (compatible XHarbour-Tip/1.0)"
DATA cUserAgent INIT "Mozilla/3.0 compatible"
DATA cAuthMode INIT ""
DATA cBoundary
DATA aAttachments init {}
METHOD New()
METHOD New( oUrl,lTrace, oCredentials)
METHOD Get( cQuery )
METHOD Post( cPostData, cQuery )
METHOD ReadHeaders()
@@ -93,13 +94,13 @@ HIDDEN:
ENDCLASS
METHOD New() CLASS tIPClientHTTP
METHOD New( oUrl,lTrace, oCredentials) CLASS tIPClientHTTP
::super:new( oUrl, lTrace, oCredentials )
::nDefaultPort := 80
::nConnTimeout := 5000
::bChunked := .F.
::lTrace := .f.
::bChunked := .F.
HSetCaseMatch( ::hHeaders, .F. )
hb_hCaseMatch( ::hHeaders, .F. )
RETURN Self

194
harbour/contrib/tip/mail.prg
View File

@@ -51,7 +51,15 @@
*
*/
#include "common.ch"
/* 2007-04-11, Hannes Ziegler <hz AT knowlexbase.com>
Added method :setHeader()
Added method :attachFile()
Added method :detachFile()
Added method :getFileName()
Added method :isMultiPart()
Added method :getMultiParts()
*/
#include "hbclass.ch"
CLASS TipMail
@@ -89,6 +97,14 @@ CLASS TipMail
METHOD ResetAttachment() INLINE ::nAttachPos := 1
METHOD MakeBoundary()
METHOD isMultiPart()
METHOD getMultiParts()
METHOD setHeader
METHOD attachFile( cFileName )
METHOD detachFile( cPath )
METHOD getFileName()
HIDDEN:
DATA cBody
Data lBodyEncoded init .f.
@@ -104,24 +120,18 @@ METHOD New( cBody, oEncoder ) CLASS TipMail
::hHeaders := HSetCaseMatch( {=>}, .F. )
::aAttachments := {}
IF HB_IsString( oEncoder )
::oEncoder := TIPEncoder():New( oEncoder )
IF ::oEncoder == NIL
Alert( "Invalid encoder " + oEncoder )
QUIT
ENDIF
ELSEIF HB_IsObject( oEncoder ) .and. At("TIPEncoder", oEncoder:ClassName() ) != 0
::oEncoder := oEncoder
::hHeaders[ "Content-transfer-encoding" ] := oEncoder:cName
IF Valtype( oEncoder ) $ "CO"
::setEncoder( oEncoder )
ENDIF
IF cBody != NIL
IF ::oEncoder != NIL
::cBody := ::oEncoder:Encode( cBody )
::hHeaders[ "Content-Transfer-Encoding" ] := ::oEncoder:cName
ELSE
::cBody := cBody
ENDIF
::hHeaders[ "Content-Length" ] := Ltrim( Str( Len( cBody ) ) )
::hHeaders[ "Content-Length" ] := Ltrim( Str( Len( ::cBody ) ) )
ENDIF
RETURN Self
@@ -129,7 +139,7 @@ RETURN Self
METHOD SetEncoder( cEnc ) CLASS TipMail
if HB_IsString( cEnc )
::oEncoder := TipEncoder():New( cEnc )
::oEncoder := TIp_GetEncoder( cEnc )
ELSE
::oEncoder := cEnc
ENDIF
@@ -424,7 +434,7 @@ METHOD FromString( cMail, cBoundary, nPos ) CLASS TipMail
// boundary.
IF "Content-Transfer-Encoding" $ ::hHeaders
::oEncoder := TipEncoder():New( ::hHeaders["Content-Transfer-Encoding"] )
::oEncoder := TIp_GetEncoder( ::hHeaders["Content-Transfer-Encoding"] )
ENDIF
// se if we have subparts:
@@ -514,3 +524,161 @@ METHOD MakeBoundary() CLASS TipMail
"_" + StrTran(Time(), ":", "" )
RETURN cBound
METHOD setHeader( cSubject, cFrom, cTo, cCC, cBCC ) CLASS TipMail
LOCAL aTo, aCC, aBCC, i, imax
IF Valtype( csubject ) <> "C"
cSubject := ""
ENDIF
IF Valtype( cFrom ) <> "C"
RETURN .F.
ENDIF
IF Valtype( cTo ) == "C"
aTo := { cTo }
ELSEIF Valtype( cTo ) == "A"
aTo := cTo
ENDIF
IF Valtype( cCC ) == "C"
aCC := { cCC }
ELSEIF Valtype( cCC ) == "A"
aCC := cCC
ENDIF
IF Valtype( cBCC ) == "C"
aBCC := { cBCC }
ELSEIF Valtype( cBCC ) == "A"
aBCC := cBCC
ENDIF
IF aTO == NIL
RETURN .F.
ENDIF
IF .NOT. ::setFieldPart( "Subject", cSubject )
RETURN .F.
ENDIF
IF .NOT. ::setFieldPart( "From" , cFrom )
RETURN .F.
ENDIF
cTo := aTO[1]
imax := Len( aTO )
FOR i:=2 TO imax
cTo += "," + InetCrlf() + Chr(9) + aTo[i]
NEXT
IF .NOT. ::setFieldPart( "To", cTo )
RETURN .F.
ENDIF
IF aCC <> NIL
cCC := aCC[1]
imax := Len( aCC )
FOR i:=2 TO imax
cCC += "," + InetCrlf() + Chr(9) + aCC[i]
NEXT
IF .NOT. ::setFieldPart( "Cc", cCC )
RETURN .F.
ENDIF
ENDIF
IF aBCC <> NIL
cBCC := aBCC[1]
imax := Len( aBCC )
FOR i:=2 TO imax
cBCC += "," + InetCrlf() + Chr(9) + aBCC[i]
NEXT
IF .NOT. ::setFieldPart( "Bcc", cBCC )
RETURN .F.
ENDIF
ENDIF
RETURN .T.
METHOD attachFile( cFileName ) CLASS TipMail
LOCAL cContent := MemoRead( cFileName )
LOCAL cMimeType:= TIP_FileMimetype( cFileName )
LOCAL cDelim := HB_OsPathSeparator()
LOCAL oAttach
IF Empty( cContent )
RETURN .F.
ENDIF
oAttach := TIPMail():new( cContent, "base64" )
cFileName := SubStr( cFileName, Rat( cFileName, cDelim ) + 1 )
oAttach:setFieldPart ( "Content-Type", cMimeType )
oAttach:setFieldOption( "Content-Type", "name", cFileName )
oAttach:setFieldPart ( "Content-Disposition", "attachment" )
oAttach:setFieldOption( "Content-Disposition", "filename", cFileName )
RETURN ::attach( oAttach )
METHOD detachFile( cPath ) CLASS TipMail
LOCAL cContent := ::getBody()
LOCAL cFileName := ::getFileName()
LOCAL cDelim := HB_OsPathSeparator()
LOCAL nFileHandle
IF EMpty( cFileName )
RETURN .F.
ENDIF
IF Valtype( cPath ) == "C"
cFileName := StrTran( cPath + cDelim + cFileName, cDelim+cDelim, cDelim )
ENDIF
nFileHandle := FCreate( cFileName )
IF FError() <> 0
RETURN .F.
ENDIF
FWrite( nFileHandle, cContent )
FClose( nFileHandle )
RETURN ( FError() == 0 )
METHOD getFileName() CLASS TipMail
RETURN StrTran( ::getFieldOption( "Content-Type", "name" ), '"', '' )
METHOD isMultiPart CLASS TipMail
RETURN ( "multipart/" $ Lower( ::GetFieldPart("Content-Type")) )
METHOD getMultiParts( aParts ) CLASS TipMail
LOCAL oSubPart, lReset := .F.
::resetAttachment()
IF aParts == NIL
aParts := {}
ENDIF
DO WHILE ( oSubPart := ::nextAttachment() ) <> NIL
lReset := .T.
AAdd( aParts, oSubPart )
IF oSubPart:countAttachments() > 0
oSubPart:getMultiparts( aParts )
ENDIF
ENDDO
IF lReset
::resetAttachment()
ENDIF
RETURN aParts

62
harbour/contrib/tip/popcln.prg
View File

@@ -51,6 +51,11 @@
*
*/
/* 2007-04-10, Hannes Ziegler <hz AT knowlexbase.com>
Added method :countMail()
Added method :retrieveAll()
*/
#include "hbclass.ch"
/**
@@ -59,32 +64,33 @@
CLASS tIPClientPOP FROM tIPClient
METHOD New( lTrace )
METHOD New( oUrl, lTrace, oCredentials )
METHOD Open()
METHOD Close()
METHOD Read( iLen )
METHOD Stat()
METHOD List()
METHOD Retreive( nId, nLen )
METHOD Retrieve( nId, nLen )
METHOD Delete()
METHOD Quit()
METHOD Noop() // Can be called repeatedly to keep-alive the connection
METHOD Top( nMsgId ) // Get Headers of mail (no body) to be able to quickly handle a message
METHOD UIDL( nMsgId ) // Returns Unique ID of message n or list of unique IDs of all message inside maildrop
METHOD GetOK()
METHOD countMail()
METHOD retrieveAll()
ENDCLASS
METHOD New( lTrace ) CLASS tIPClientPOP
METHOD New( oUrl, lTrace, oCredentials ) CLASS tIPClientPOP
local cFile :="pop3"
local n := 0
::super:New( oUrl, lTrace, oCredentials )
::nDefaultPort := 110
::nConnTimeout := 10000
::lTrace:= lTrace
if ::ltrace
if !file("pop3.log")
@@ -100,8 +106,8 @@ METHOD New( lTrace ) CLASS tIPClientPOP
RETURN Self
METHOD Open() CLASS tIPClientPOP
IF .not. ::super:Open()
METHOD Open( cUrl ) CLASS tIPClientPOP
IF .not. ::super:Open( cUrl )
RETURN .F.
ENDIF
@@ -115,6 +121,7 @@ METHOD Open() CLASS tIPClientPOP
IF ::GetOK()
::InetSendall( ::SocketCon, "PASS " + ::oUrl:cPassword + ::cCRLF )
IF ::GetOK()
::isOpen := .T.
RETURN .T.
ENDIF
ENDIF
@@ -275,7 +282,7 @@ RETURN cRet
METHOD Retreive( nId, nLen ) CLASS tIPClientPOP
METHOD Retrieve( nId, nLen ) CLASS tIPClientPOP
LOCAL nPos
LOCAL cRet, nRetLen, cBuffer, nRead
@@ -339,3 +346,42 @@ METHOD Delete( nId ) CLASS tIPClientPOP
::InetSendall( ::SocketCon, "DELE " + AllTrim( Str( nId ) ) + ::cCRLF )
RETURN ::GetOk()
METHOD countMail CLASS TIpClientPop
LOCAL aMails
IF ::isOpen
::reset()
aMails := HB_ATokens( StrTran( ::list(), Chr(13),''), Chr(10) )
RETURN Len( aMails )
ENDIF
RETURN -1
METHOD retrieveAll( lDelete )
LOCAL aMails, i, imax, cMail
IF Valtype( lDelete ) <> "L"
lDelete := .F.
ENDIF
IF .NOT. ::isOpen
RETURN NIL
ENDIF
imax := ::countMail()
aMails := Array( imax )
FOR i:=1 TO imax
::reset()
cMail := ::retrieve( i )
aMails[i] := TIpMail():new()
aMails[i]:fromString( cMail )
IF lDelete
::reset()
::delete(i)
ENDIF
NEXT
RETURN aMails

63
harbour/contrib/tip/smtpcln.prg
View File

@@ -51,16 +51,20 @@
*
*/
/* 2007-04-12, Hannes Ziegler <hz AT knowlexbase.com>
Added method :sendMail()
*/
#include "hbclass.ch"
#include "tip.ch"
/**
* Inet service manager: pop3
* Inet service manager: smtp
*/
CLASS tIPClientSMTP FROM tIPClient
METHOD New()
METHOD New( oUrl, lTrace, oCredentials )
METHOD Open()
METHOD Close()
METHOD Write( cData, nLen, bCommit )
@@ -76,15 +80,20 @@ CLASS tIPClientSMTP FROM tIPClient
METHOD AUTHplain( cUser, cPass) // Auth by plain method
METHOD ServerSuportSecure(lAuthp,lAuthl)
METHOD sendMail
HIDDEN:
DATA isAuth INIT .F.
ENDCLASS
METHOD New(lTrace) CLASS tIPClientSMTP
METHOD New( oUrl, lTrace, oCredentials ) CLASS tIPClientSMTP
local cFile :="sendmail"
local n:=1
::super:New( oUrl, lTrace, oCredentials )
::nDefaultPort := 25
::nConnTimeout := 5000
::nAccessMode := TIP_WO // a write only
::lTrace:= lTrace
if ::ltrace
if !file("sendmail.log")
::nHandle := fcreate("sendmail.log")
@@ -97,9 +106,9 @@ local n:=1
endif
RETURN Self
METHOD Open() CLASS tIPClientSMTP
METHOD Open( cUrl ) CLASS tIPClientSMTP
IF .not. ::super:Open()
IF .not. ::super:Open( cUrl )
RETURN .F.
ENDIF
@@ -138,6 +147,7 @@ RETURN ::GetOk()
METHOD Quit() CLASS tIPClientSMTP
::InetSendall( ::SocketCon, "QUIT" + ::cCRLF )
::isAuth := .F.
RETURN ::GetOk()
@@ -161,11 +171,11 @@ RETURN ::GetOk()
METHOD OpenSecure( ) CLASS tIPClientSMTP
METHOD OpenSecure( cUrl ) CLASS tIPClientSMTP
Local cUser
IF .not. ::super:Open()
IF .not. ::super:Open( cUrl )
RETURN .F.
ENDIF
@@ -202,7 +212,7 @@ METHOD AUTH( cUser, cPass) CLASS tIPClientSMTP
endif
endif
return ::GetOk()
return ( ::isAuth := ::GetOk() )
METHOD AuthPlain( cUser, cPass) CLASS tIPClientSMTP
@@ -210,7 +220,8 @@ METHOD AuthPlain( cUser, cPass) CLASS tIPClientSMTP
Local cen := HB_BASE64( cBase, 2 + Len( cUser ) + Len( cPass ) )
::InetSendall( ::SocketCon, "AUTH PLAIN" + cen + ::cCrlf)
return ::GetOk()
return ( ::isAuth := ::GetOk() )
METHOD Write( cData, nLen, bCommit ) CLASS tIPClientSMTP
Local aTo,cRecpt
@@ -262,3 +273,35 @@ METHOD ServerSuportSecure(lAuthp,lAuthl) CLASS tIPClientSMTP
lAuthl:=lAuthLogin
RETURN lAuthLogin .OR. lAuthPlain
METHOD sendMail( oTIpMail ) CLASS TIpClientSmtp
LOCAL cFrom, cTo, aTo
IF .NOT. ::isOpen
RETURN .F.
ENDIF
IF .NOT. ::isAuth
::auth( ::oUrl:cUserId, ::oUrl:cPassWord )
IF .NOT. ::isAuth
RETURN .F.
ENDIF
ENDIF
cFrom := oTIpMail:getFieldPart( "From" )
cTo := oTIpMail:getFieldPart( "To" )
cTo := StrTran( cTo, InetCRLF(), "" )
cTo := StrTran( cTo, Chr(9) , "" )
cTo := StrTran( cTo, Chr(32) , "" )
aTo := HB_RegExSplit( "," , cTo )
::mail( cFrom )
FOR EACH cTo IN aTo
::rcpt( cTo )
NEXT
RETURN ::data( oTIpMail:toString() )

296
harbour/contrib/tip/thtml.ch Normal file
View File

@@ -0,0 +1,296 @@
/*
* Harbour Project source code:
* Directives for HTML Classes
*
* Copyright 2007 Hannes Ziegler <hz/at/knowleXbase.com>
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#ifndef _HB_THTML
#define _HB_THTML
/*
content model shortcut encoding taken from Tidy library
(www.sourceforge.net/tidy)
*/
#define CM_UNKNOWN 0
#define CM_EMPTY 0x000001 /* Elements with no content. Map to HTML specification. */
#define CM_HTML 0x000002 /* Elements that appear outside of "BODY". */
#define CM_HEAD 0x000004 /* Elements that can appear within HEAD. */
#define CM_BLOCK 0x000008 /* HTML "block" elements. */
#define CM_INLINE 0x000010 /* HTML "inline" elements. */
#define CM_LIST 0x000020 /* Elements that mark list item ("LI"). */
#define CM_DEFLIST 0x000040 /* Elements that mark definition list item ("DL", "DT"). */
#define CM_TABLE 0x000080 /* Elements that can appear inside TABLE. */
#define CM_ROWGRP 0x000100 /* Used for "THEAD", "TFOOT" or "TBODY". */
#define CM_ROW 0x000200 /* Used for "TD", "TH" */
#define CM_FIELD 0x000400 /* Elements whose content must be protected against white space movement.
Includes some elements that can found in forms. */
#define CM_OBJECT 0x000800 /* Used to avoid propagating inline emphasis inside some elements
such as OBJECT or APPLET. */
#define CM_PARAM 0x001000 /* Elements that allows "PARAM". */
#define CM_FRAMES 0x002000 /* "FRAME", "FRAMESET", "NOFRAMES". Used in ParseFrameSet. */
#define CM_HEADING 0x004000 /* Heading elements (h1, h2, ...). */
#define CM_OPT 0x008000 /* Elements with an optional end tag. */
#define CM_IMG 0x010000 /* Elements that use "align" attribute for vertical position. */
#define CM_MIXED 0x020000 /* Elements with inline and block model. Used to avoid calling InlineDup. */
#define CM_NO_INDENT 0x040000 /* Elements whose content needs to be indented only if containing one
CM_BLOCK element. */
#define CM_OBSOLETE 0x080000 /* Elements that are obsolete (such as "dir", "menu"). */
#define CM_NEW 0x100000 /* User defined elements. Used to determine how attributes wihout value
should be printed. */
#define CM_OMITST 0x200000 /* Elements that cannot be omitted. */
/*
Constants for HTML attributes adopted from Tidy library (www.sourceforge.net/tidy)
*/
#define HTML_ATTR_ABBR 1
#define HTML_ATTR_ACCEPT 2
#define HTML_ATTR_ACCEPT_CHARSET 3
#define HTML_ATTR_ACCESSKEY 4
#define HTML_ATTR_ACTION 5
#define HTML_ATTR_ADD_DATE 6
#define HTML_ATTR_ALIGN 7
#define HTML_ATTR_ALINK 8
#define HTML_ATTR_ALT 9
#define HTML_ATTR_ARCHIVE 10
#define HTML_ATTR_AXIS 11
#define HTML_ATTR_BACKGROUND 12
#define HTML_ATTR_BGCOLOR 13
#define HTML_ATTR_BGPROPERTIES 14
#define HTML_ATTR_BORDER 15
#define HTML_ATTR_BORDERCOLOR 16
#define HTML_ATTR_BOTTOMMARGIN 17
#define HTML_ATTR_CELLPADDING 18
#define HTML_ATTR_CELLSPACING 19
#define HTML_ATTR_CHAR 20
#define HTML_ATTR_CHAROFF 21
#define HTML_ATTR_CHARSET 22
#define HTML_ATTR_CHECKED 23
#define HTML_ATTR_CITE 24
#define HTML_ATTR_CLASS 25
#define HTML_ATTR_CLASSID 26
#define HTML_ATTR_CLEAR 27
#define HTML_ATTR_CODE 28
#define HTML_ATTR_CODEBASE 29
#define HTML_ATTR_CODETYPE 30
#define HTML_ATTR_COLOR 31
#define HTML_ATTR_COLS 32
#define HTML_ATTR_COLSPAN 33
#define HTML_ATTR_COMPACT 34
#define HTML_ATTR_CONTENT 35
#define HTML_ATTR_COORDS 36
#define HTML_ATTR_DATA 37
#define HTML_ATTR_DATAFLD 38
#define HTML_ATTR_DATAFORMATAS 39
#define HTML_ATTR_DATAPAGESIZE 40
#define HTML_ATTR_DATASRC 41
#define HTML_ATTR_DATETIME 42
#define HTML_ATTR_DECLARE 43
#define HTML_ATTR_DEFER 44
#define HTML_ATTR_DIR 45
#define HTML_ATTR_DISABLED 46
#define HTML_ATTR_ENCODING 47
#define HTML_ATTR_ENCTYPE 48
#define HTML_ATTR_EVENT 49
#define HTML_ATTR_FACE 50
#define HTML_ATTR_FOR 51
#define HTML_ATTR_FRAME 52
#define HTML_ATTR_FRAMEBORDER 53
#define HTML_ATTR_FRAMESPACING 54
#define HTML_ATTR_GRIDX 55
#define HTML_ATTR_GRIDY 56
#define HTML_ATTR_HEADERS 57
#define HTML_ATTR_HEIGHT 58
#define HTML_ATTR_HREF 59
#define HTML_ATTR_HREFLANG 60
#define HTML_ATTR_HSPACE 61
#define HTML_ATTR_HTTP_EQUIV 62
#define HTML_ATTR_ID 63
#define HTML_ATTR_ISMAP 64
#define HTML_ATTR_LABEL 65
#define HTML_ATTR_LANG 66
#define HTML_ATTR_LANGUAGE 67
#define HTML_ATTR_LAST_MODIFIED 68
#define HTML_ATTR_LAST_VISIT 69
#define HTML_ATTR_LEFTMARGIN 70
#define HTML_ATTR_LINK 71
#define HTML_ATTR_LONGDESC 72
#define HTML_ATTR_LOWSRC 73
#define HTML_ATTR_MARGINHEIGHT 74
#define HTML_ATTR_MARGINWIDTH 75
#define HTML_ATTR_MAXLENGTH 76
#define HTML_ATTR_MEDIA 77
#define HTML_ATTR_METHOD 78
#define HTML_ATTR_METHODS 79
#define HTML_ATTR_MULTIPLE 80
#define HTML_ATTR_N 81
#define HTML_ATTR_NAME 82
#define HTML_ATTR_NOHREF 83
#define HTML_ATTR_NORESIZE 84
#define HTML_ATTR_NOSHADE 85
#define HTML_ATTR_NOWRAP 86
#define HTML_ATTR_OBJECT 87
#define HTML_ATTR_ONAFTERUPDATE 88
#define HTML_ATTR_ONBEFOREUNLOAD 89
#define HTML_ATTR_ONBEFOREUPDATE 90
#define HTML_ATTR_ONBLUR 91
#define HTML_ATTR_ONCHANGE 92
#define HTML_ATTR_ONCLICK 93
#define HTML_ATTR_ONDATAAVAILABLE 94
#define HTML_ATTR_ONDATASETCHANGED 95
#define HTML_ATTR_ONDATASETCOMPLETE 96
#define HTML_ATTR_ONDBLCLICK 97
#define HTML_ATTR_ONERRORUPDATE 98
#define HTML_ATTR_ONFOCUS 99
#define HTML_ATTR_ONKEYDOWN 100
#define HTML_ATTR_ONKEYPRESS 101
#define HTML_ATTR_ONKEYUP 102
#define HTML_ATTR_ONLOAD 103
#define HTML_ATTR_ONMOUSEDOWN 104
#define HTML_ATTR_ONMOUSEMOVE 105
#define HTML_ATTR_ONMOUSEOUT 106
#define HTML_ATTR_ONMOUSEOVER 107
#define HTML_ATTR_ONMOUSEUP 108
#define HTML_ATTR_ONRESET 109
#define HTML_ATTR_ONROWENTER 110
#define HTML_ATTR_ONROWEXIT 111
#define HTML_ATTR_ONSELECT 112
#define HTML_ATTR_ONSUBMIT 113
#define HTML_ATTR_ONUNLOAD 114
#define HTML_ATTR_PROFILE 115
#define HTML_ATTR_PROMPT 116
#define HTML_ATTR_RBSPAN 117
#define HTML_ATTR_READONLY 118
#define HTML_ATTR_REL 119
#define HTML_ATTR_REV 120
#define HTML_ATTR_RIGHTMARGIN 121
#define HTML_ATTR_ROWS 122
#define HTML_ATTR_ROWSPAN 123
#define HTML_ATTR_RULES 124
#define HTML_ATTR_SCHEME 125
#define HTML_ATTR_SCOPE 126
#define HTML_ATTR_SCROLLING 127
#define HTML_ATTR_SDAFORM 128
#define HTML_ATTR_SDAPREF 129
#define HTML_ATTR_SDASUFF 130
#define HTML_ATTR_SELECTED 131
#define HTML_ATTR_SHAPE 132
#define HTML_ATTR_SHOWGRID 133
#define HTML_ATTR_SHOWGRIDX 134
#define HTML_ATTR_SHOWGRIDY 135
#define HTML_ATTR_SIZE 136
#define HTML_ATTR_SPAN 137
#define HTML_ATTR_SRC 138
#define HTML_ATTR_STANDBY 139
#define HTML_ATTR_START 140
#define HTML_ATTR_STYLE 141
#define HTML_ATTR_SUMMARY 142
#define HTML_ATTR_TABINDEX 143
#define HTML_ATTR_TARGET 144
#define HTML_ATTR_TEXT 145
#define HTML_ATTR_TITLE 146
#define HTML_ATTR_TOPMARGIN 147
#define HTML_ATTR_TYPE 148
#define HTML_ATTR_UNKNOWN 149
#define HTML_ATTR_URN 150
#define HTML_ATTR_USEMAP 151
#define HTML_ATTR_VALIGN 152
#define HTML_ATTR_VALUE 153
#define HTML_ATTR_VALUETYPE 154
#define HTML_ATTR_VERSION 155
#define HTML_ATTR_VLINK 156
#define HTML_ATTR_VSPACE 157
#define HTML_ATTR_WIDTH 158
#define HTML_ATTR_WRAP 159
#define HTML_ATTR_XMLNS 160
#define HTML_ATTR_XML_LANG 161
#define HTML_ATTR_XML_SPACE 162
#define HTML_ATTR_COUNT 162
#define HTML_ATTR_TYPE_UNKNOWN 0
#define HTML_ATTR_TYPE_ACTION 1
#define HTML_ATTR_TYPE_ALIGN 2
#define HTML_ATTR_TYPE_BOOL 3
#define HTML_ATTR_TYPE_BORDER 4
#define HTML_ATTR_TYPE_CHARACTER 5
#define HTML_ATTR_TYPE_CHARSET 6
#define HTML_ATTR_TYPE_CLEAR 7
#define HTML_ATTR_TYPE_COLOR 8
#define HTML_ATTR_TYPE_COLS 9
#define HTML_ATTR_TYPE_COORDS 10
#define HTML_ATTR_TYPE_DATE 11
#define HTML_ATTR_TYPE_FBORDER 12
#define HTML_ATTR_TYPE_FSUBMIT 13
#define HTML_ATTR_TYPE_IDDEF 14
#define HTML_ATTR_TYPE_IDREF 15
#define HTML_ATTR_TYPE_IDREFS 16
#define HTML_ATTR_TYPE_LANG 17
#define HTML_ATTR_TYPE_LENGTH 18
#define HTML_ATTR_TYPE_LINKTYPES 19
#define HTML_ATTR_TYPE_MEDIA 20
#define HTML_ATTR_TYPE_NAME 21
#define HTML_ATTR_TYPE_NUMBER 22
#define HTML_ATTR_TYPE_PCDATA 23
#define HTML_ATTR_TYPE_SCOPE 24
#define HTML_ATTR_TYPE_SCRIPT 25
#define HTML_ATTR_TYPE_SCROLL 26
#define HTML_ATTR_TYPE_SHAPE 27
#define HTML_ATTR_TYPE_TARGET 28
#define HTML_ATTR_TYPE_TEXTDIR 29
#define HTML_ATTR_TYPE_TFRAME 30
#define HTML_ATTR_TYPE_TRULES 31
#define HTML_ATTR_TYPE_TYPE 32
#define HTML_ATTR_TYPE_URL 33
#define HTML_ATTR_TYPE_URLS 34
#define HTML_ATTR_TYPE_VALIGN 35
#define HTML_ATTR_TYPE_VTYPE 36
#define HTML_ATTR_TYPE_XTYPE 37
#define HTML_ATTR_TYPE_COUNT 37
#endif // _HB_THTML

4510
harbour/contrib/tip/thtml.prg Normal file
View File

File diff suppressed because it is too large Load Diff

1
harbour/contrib/tip/url.prg
View File

@@ -51,6 +51,7 @@
*
*/
#include "hbcompat.ch"
#include "hbclass.ch"
/*

164
harbour/contrib/tip/utils.c
View File

@@ -51,11 +51,13 @@
*
*/
#include <ctype.h>
#include "hbapi.h"
#include "hbapiitm.h"
#include "hbdate.h"
#include "hbapifs.h"
#include "hbapierr.h"
#include "hbapifs.h"
#include "hbvm.h"
#include "hbdate.h"
#ifndef HB_OS_WIN_32
#include <time.h>
@@ -379,7 +381,7 @@ static EXT_MIME_ENTRY s_extMimeTable[EXT_MIME_TABLE_SIZE] =
/* 13*/ { "hxx", "text/x-c++-header", MIME_FLAG_CASEINSENS },
/* Java */
/* 14*/ { "class", "application/java", 0 }, // case sensitive!
/* 14*/ { "class", "application/java", 0 }, /* case sensitive! */
/* 15*/ { "java", "text/java", 0 }
};
@@ -417,13 +419,13 @@ static char *s_findMimeStringInTree( char *cData, int iLen, int iElem )
int iPos = elem->pos;
int iDataLen = strlen( elem->pattern );
// allow \0 to be used for matches
/* allow \0 to be used for matches */
if ( iDataLen == 0 )
{
iDataLen = 1;
}
// trim spaces if required
/* trim spaces if required */
while ( iPos < iLen &&
( (( elem->flags & MIME_FLAG_TRIMSPACES ) == MIME_FLAG_TRIMSPACES && (
cData[iPos] == ' ' || cData[iPos] == '\r' || cData[iPos] == '\n') ) ||
@@ -438,7 +440,7 @@ static char *s_findMimeStringInTree( char *cData, int iLen, int iElem )
{
if ( (*elem->pattern == 0 && cData[iPos] == 0) || hb_strnicmp( cData + iPos, elem->pattern, iDataLen ) == 0)
{
// is this the begin of a match tree?
/* is this the begin of a match tree? */
if ( elem->next != 0 )
{
return s_findMimeStringInTree( cData, iLen, iElem + elem->next );
@@ -465,13 +467,13 @@ static char *s_findMimeStringInTree( char *cData, int iLen, int iElem )
}
}
// match failed!
/* match failed! */
if ( elem->alternate != 0 )
{
return s_findMimeStringInTree( cData, iLen, iElem + elem->alternate );
}
// total giveup
/* total giveup */
return NULL;
}
@@ -492,7 +494,7 @@ static char *s_findStringMimeType( char *cData, int iLen )
continue;
}
// trim spaces if required
/* trim spaces if required */
while ( iPos < iLen &&
( (( elem->flags & MIME_FLAG_TRIMSPACES ) == MIME_FLAG_TRIMSPACES && (
cData[iPos] == ' ' || cData[iPos] == '\r' || cData[iPos] == '\n') ) ||
@@ -515,7 +517,7 @@ static char *s_findStringMimeType( char *cData, int iLen )
{
if ( (*elem->pattern == 0 && cData[iPos] == 0) || hb_strnicmp( cData + iPos, elem->pattern, iDataLen ) == 0)
{
// is this the begin of a match tree?
/* is this the begin of a match tree? */
if ( elem->next != 0 )
{
return s_findMimeStringInTree( cData, iLen, iCount + elem->next );
@@ -542,17 +544,17 @@ static char *s_findStringMimeType( char *cData, int iLen )
}
}
// Failure; let's see if it's a text/plain.
/* Failure; let's see if it's a text/plain. */
bFormFeed = FALSE;
iCount = 0;
while ( iCount < iLen )
{
// form feed?
/* form feed? */
if ( cData[ iCount ] == '\x0C' )
{
bFormFeed = TRUE;
}
// esc sequence?
/* esc sequence? */
else if ( cData[iCount] == '\x1B' )
{
bFormFeed = TRUE;
@@ -570,7 +572,7 @@ static char *s_findStringMimeType( char *cData, int iLen )
(cData[iCount] < 27 && cData[iCount] != '\t' && cData[iCount] != '\n' && cData[iCount] == '\r') ||
cData[iCount] == '\xFF')
{
// not an ASCII file, we surrender
/* not an ASCII file, we surrender */
return NULL;
}
@@ -579,7 +581,7 @@ static char *s_findStringMimeType( char *cData, int iLen )
if ( bFormFeed )
{
// we have escape sequences, seems a PRN/terminal file
/* we have escape sequences, seems a PRN/terminal file */
return "application/remote-printing";
}
@@ -625,7 +627,7 @@ HB_FUNC( TIP_FILEMIMETYPE )
if ( HB_IS_STRING( pFile ) )
{
// decode the extension
/* decode the extension */
char *fname = hb_itemGetCPtr( pFile );
int iPos = strlen( fname )-1;
@@ -660,7 +662,7 @@ HB_FUNC( TIP_FILEMIMETYPE )
}
else
{
hb_retc( "unknown" ); // it's a valid MIME type
hb_retc( "unknown" ); /* it's a valid MIME type */
}
}
else
@@ -698,3 +700,131 @@ HB_FUNC( TIP_MIMETYPE )
hb_retc( magic_type );
}
}
/*
Case insensitive string comparison to optimize this expression:
IF Lower( <cSubStr> ) == Lower( SubStr( <cString>, <nStart>, Len(<cSubStr>) ) )
<cString> must be provided as a pointer to the character string containing a substring
<nStart> is the numeric position to start comparison in <cString>
<cSubStr> is the character string to compare with characters in <cString>, beginning at <nStart>
*/
HB_FUNC( PSTRCOMPI )
{
PHB_ITEM pString = hb_param( 1, HB_IT_STRING );
PHB_ITEM pStart = hb_param( 2, HB_IT_NUMERIC );
PHB_ITEM pSubstr = hb_param( 3, HB_IT_STRING );
if( pString && pStart && pSubstr )
{
char * pcBase = hb_itemGetCPtr( pString ) ;
char * pcSub = hb_itemGetCPtr( pSubstr ) ;
ULONG uSublen = hb_itemGetCLen( pSubstr ) ;
ULONG uStart = hb_itemGetNL( pStart ) ;
hb_retl( hb_strnicmp( pcBase + uStart - 1, pcSub, uSublen ) == 0 );
}
else
hb_errRT_BASE_SubstR( EG_ARG, 1099, NULL, &hb_errFuncName, HB_ERR_ARGS_BASEPARAMS );
}
/* Case insensitive hb_strAt() function */
static ULONG HB_EXPORT hb_strAtI( const char * szSub, ULONG ulSubLen, const char * szText, ULONG ulLen )
{
HB_TRACE(HB_TR_DEBUG, ("hb_strAtI(%s, %lu, %s, %lu)", szSub, ulSubLen, szText, ulLen));
if( ulSubLen > 0 && ulLen >= ulSubLen )
{
ULONG ulPos = 0;
ULONG ulSubPos = 0;
while( ulPos < ulLen && ulSubPos < ulSubLen )
{
if( tolower( (BYTE) szText[ ulPos ] ) == tolower( (BYTE) szSub[ ulSubPos ] ) )
{
ulSubPos++;
ulPos++;
}
else if( ulSubPos )
{
/* Go back to the first character after the first match,
or else tests like "22345" $ "012223456789" will fail. */
ulPos -= ( ulSubPos - 1 );
ulSubPos = 0;
}
else
ulPos++;
}
return ( ulSubPos < ulSubLen ) ? 0 : ( ulPos - ulSubLen + 1 );
}
else
return 0;
}
/* Case insensitive At() function */
HB_FUNC( ATI )
{
PHB_ITEM pSub = hb_param( 1, HB_IT_STRING );
PHB_ITEM pText = hb_param( 2, HB_IT_STRING );
PHB_ITEM pStart = hb_param( 3, HB_IT_NUMERIC );
PHB_ITEM pEnd = hb_param( 4, HB_IT_NUMERIC );
if( pText && pSub )
{
LONG lLen = hb_itemGetCLen( pText );
LONG lStart = pStart ? hb_itemGetNL( pStart ) : 1;
LONG lEnd = pEnd ? hb_itemGetNL( pEnd ) : lLen;
ULONG ulPos;
if( lStart < 0 )
{
lStart += lLen;
if( lStart < 0 )
lStart = 0;
}
else if( lStart )
lStart--;
if( lEnd < 0 )
lEnd += lLen + 1;
if( lEnd > lLen )
lEnd = lLen;
/* Stop searching if starting past beyond end. */
if( lStart >= lEnd )
hb_retnl( 0 );
else
{
ulPos = hb_strAtI( hb_itemGetCPtr( pSub ), hb_itemGetCLen( pSub ),
hb_itemGetCPtr( pText ) + lStart, lEnd - lStart );
hb_retnl( ulPos ? ulPos + lStart : 0 );
}
}
else
{
hb_errRT_BASE_SubstR( EG_ARG, 1108, NULL, &hb_errFuncName, HB_ERR_ARGS_BASEPARAMS );
}
}
HB_FUNC( HB_EXEC )
{
if( ISSYMBOL( 1 ) )
{
BOOL fSend = FALSE;
int iParams = hb_pcount() - 1;
if( iParams >= 1 )
{
fSend = iParams > 1 && ! HB_IS_NIL( hb_param( 2, HB_IT_ANY ) );
iParams--;
}
else
hb_vmPushNil();
if( fSend )
hb_vmSend( ( USHORT ) iParams );
else
hb_vmDo( ( USHORT ) iParams );
}
else
hb_errRT_BASE_SubstR( EG_ARG, 1099, NULL, &hb_errFuncName, HB_ERR_ARGS_BASEPARAMS );
}

4
harbour/include/hbcompat.ch
View File

@@ -73,6 +73,8 @@
#xtranslate hb_libLoad([<x,...>]) => libLoad(<x>)
#xtranslate hb_libFree([<x,...>]) => libFree(<x>)
#xtranslate hb_CStr([<x,...>]) => CStr(<x>)
#else
#xtranslate gtSys => hb_gtSys
@@ -93,6 +95,8 @@
#xtranslate libLoad([<x,...>]) => hb_libLoad(<x>)
#xtranslate libFree([<x,...>]) => hb_libFree(<x>)
#xtranslate CStr([<x,...>]) => hb_CStr(<x>)
#xtranslate HASH([<x,...>]) => HB_HASH(<x>)
#xtranslate HHASKEY([<x,...>]) => HB_HHASKEY(<x>)
#xtranslate HGETPOS([<x,...>]) => HB_HPOS(<x>)

39
harbour/source/compiler/hbopt.c
View File

@@ -539,6 +539,39 @@ static HB_OPT_FUNC( hb_p_jumptruefar )
return 4;
}
static HB_OPT_FUNC( hb_p_function )
{
if( pFunc->pCode[ lPCodePos + 3 ] == HB_P_RETVALUE &&
! hb_compIsJump( cargo->HB_COMP_PARAM, pFunc, lPCodePos + 3 ) )
{
pFunc->pCode[ lPCodePos ] = HB_P_DO;
hb_compNOOPfill( pFunc, lPCodePos + 3, 1, FALSE, FALSE );
}
return 3;
}
static HB_OPT_FUNC( hb_p_functionshort )
{
if( pFunc->pCode[ lPCodePos + 2 ] == HB_P_RETVALUE &&
! hb_compIsJump( cargo->HB_COMP_PARAM, pFunc, lPCodePos + 2 ) )
{
pFunc->pCode[ lPCodePos ] = HB_P_DOSHORT;
hb_compNOOPfill( pFunc, lPCodePos + 2, 1, FALSE, FALSE );
}
return 2;
}
static HB_OPT_FUNC( hb_p_macrofunc )
{
if( pFunc->pCode[ lPCodePos + 1 ] == HB_P_RETVALUE &&
! hb_compIsJump( cargo->HB_COMP_PARAM, pFunc, lPCodePos + 1 ) )
{
pFunc->pCode[ lPCodePos ] = HB_P_MACRODO;
hb_compNOOPfill( pFunc, lPCodePos + 1, 1, FALSE, FALSE );
}
return 1;
}
static HB_OPT_FUNC( hb_p_endblock )
{
HB_SYMBOL_UNUSED( cargo );
@@ -578,8 +611,8 @@ static const HB_OPT_FUNC_PTR s_opt_table[] =
NULL, /* HB_P_EXACTLYEQUAL, */
hb_p_false, /* HB_P_FALSE, */
NULL, /* HB_P_FORTEST, */
NULL, /* HB_P_FUNCTION, */
NULL, /* HB_P_FUNCTIONSHORT, */
hb_p_function, /* HB_P_FUNCTION, */
hb_p_functionshort, /* HB_P_FUNCTIONSHORT, */
NULL, /* HB_P_FRAME, */
NULL, /* HB_P_FUNCPTR, */
NULL, /* HB_P_GREATER, */
@@ -692,7 +725,7 @@ static const HB_OPT_FUNC_PTR s_opt_table[] =
hb_p_true, /* HB_P_TRUE, */
NULL, /* HB_P_ZERO, */
NULL, /* HB_P_ONE, */
NULL, /* HB_P_MACROFUNC, */
hb_p_macrofunc, /* HB_P_MACROFUNC, */
NULL, /* HB_P_MACRODO, */
NULL, /* HB_P_MPUSHSTR, */
NULL, /* HB_P_LOCALNEARADDINT, */

5
harbour/source/rdd/dbf1.c
View File

@@ -1470,10 +1470,7 @@ static ERRCODE hb_dbfGetValue( DBFAREAP pArea, USHORT uiIndex, PHB_ITEM pItem )
}
else
{
char szBuffer[ 9 ];
memcpy( szBuffer, pArea->pRecord + pArea->pFieldOffset[ uiIndex ], 8 );
szBuffer[ 8 ] = 0;
hb_itemPutDS( pItem, szBuffer );
hb_itemPutDS( pItem, pArea->pRecord + pArea->pFieldOffset[ uiIndex ] );
}
break;

7
harbour/source/rdd/delim1.c
View File

@@ -589,12 +589,7 @@ static ERRCODE hb_delimGetValue( DELIMAREAP pArea, USHORT uiIndex, PHB_ITEM pIte
break;
case HB_IT_DATE:
{
char szBuffer[ 9 ];
memcpy( szBuffer, pArea->pRecord + pArea->pFieldOffset[ uiIndex ], 8 );
szBuffer[ 8 ] = 0;
hb_itemPutDS( pItem, szBuffer );
}
hb_itemPutDS( pItem, pArea->pRecord + pArea->pFieldOffset[ uiIndex ] );
break;
case HB_IT_LONG:

7
harbour/source/rdd/sdf1.c
View File

@@ -414,12 +414,7 @@ static ERRCODE hb_sdfGetValue( SDFAREAP pArea, USHORT uiIndex, PHB_ITEM pItem )
break;
case HB_IT_DATE:
{
char szBuffer[ 9 ];
memcpy( szBuffer, pArea->pRecord + pArea->pFieldOffset[ uiIndex ], 8 );
szBuffer[ 8 ] = 0;
hb_itemPutDS( pItem, szBuffer );
}
hb_itemPutDS( pItem, pArea->pRecord + pArea->pFieldOffset[ uiIndex ] );
break;
case HB_IT_LONG:

1
harbour/source/rtl/Makefile
View File

@@ -50,6 +50,7 @@ C_SOURCES=\
gx.c \
hardcr.c \
hbadler.c \
hbbit.c \
hbcrc.c \
hbmd5.c \
hbffind.c \

160
harbour/source/rtl/hbbit.c Normal file
View File

@@ -0,0 +1,160 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* HB_BIT*() functions
*
* Copyright 2007 Przemyslaw Czerpak <druzus / at / priv.onet.pl>
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include "hbapi.h"
#include "hbapierr.h"
static BOOL hb_numParam( int iParam, HB_LONG * plNum )
{
if( ISNUM( iParam ) )
{
*plNum = hb_parnint( iParam );
return TRUE;
}
hb_errRT_BASE_SubstR( EG_ARG, 1089, NULL, &hb_errFuncName, HB_ERR_ARGS_BASEPARAMS );
*plNum = 0;
return FALSE;
}
HB_FUNC( HB_BITAND )
{
HB_LONG lValue;
if( hb_numParam( 1, &lValue ) )
{
int iPCount = hb_pcount() - 1, i = 1;
do
{
HB_LONG lNext;
if( !hb_numParam( ++i, &lNext ) )
return;
lValue &= lNext;
}
while( --iPCount > 0 );
hb_retnint( lValue );
}
}
HB_FUNC( HB_BITOR )
{
HB_LONG lValue;
if( hb_numParam( 1, &lValue ) )
{
int iPCount = hb_pcount() - 1, i = 1;
do
{
HB_LONG lNext;
if( !hb_numParam( ++i, &lNext ) )
return;
lValue |= lNext;
}
while( --iPCount > 0 );
hb_retnint( lValue );
}
}
HB_FUNC( HB_BITXOR )
{
HB_LONG lValue;
if( hb_numParam( 1, &lValue ) )
{
int iPCount = hb_pcount() - 1, i = 1;
do
{
HB_LONG lNext;
if( !hb_numParam( ++i, &lNext ) )
return;
lValue ^= lNext;
}
while( --iPCount > 0 );
hb_retnint( lValue );
}
}
HB_FUNC( HB_BITNOT )
{
HB_LONG lValue;
if( hb_numParam( 1, &lValue ) )
hb_retnint( ~lValue );
}
HB_FUNC( HB_BITTEST )
{
HB_LONG lValue, lBit;
if( hb_numParam( 1, &lValue ) && hb_numParam( 2, &lBit ) )
hb_retl( ( lValue & ( ( HB_LONG ) 1 << lBit ) ) != 0 );
}
HB_FUNC( HB_BITSET )
{
HB_LONG lValue, lBit;
if( hb_numParam( 1, &lValue ) && hb_numParam( 2, &lBit ) )
hb_retnint( lValue | ( ( HB_LONG ) 1 << lBit ) );
}
HB_FUNC( HB_BITRESET )
{
HB_LONG lValue, lBit;
if( hb_numParam( 1, &lValue ) && hb_numParam( 2, &lBit ) )
hb_retnint( lValue & ( ( ~ ( HB_LONG ) 1 ) << lBit ) );
}
HB_FUNC( HB_BITSHIFT )
{
HB_LONG lValue, lBits;
if( hb_numParam( 1, &lValue ) && hb_numParam( 2, &lBits ) )
{
if( lBits < 0 )
hb_retnint( lValue >> lBits );
else
hb_retnint( lValue << lBits );
}
}

6
harbour/source/vm/hvm.c
View File

@@ -1012,7 +1012,7 @@ HB_EXPORT void hb_vmExecute( const BYTE * pCode, PHB_SYMB pSymbols )
/* Object */
case HB_P_MESSAGE:
hb_vmPushSymbol( pSymbols + HB_PCODE_MKUSHORT( &( pCode[ w + 1 ] ) ) );
hb_vmPushSymbol( pSymbols + HB_PCODE_MKUSHORT( &pCode[ w + 1 ] ) );
w += 3;
break;
@@ -1594,7 +1594,7 @@ HB_EXPORT void hb_vmExecute( const BYTE * pCode, PHB_SYMB pSymbols )
break;
case HB_P_PUSHSYM:
hb_vmPushSymbol( pSymbols + HB_PCODE_MKUSHORT( &( pCode[ w + 1 ] ) ) );
hb_vmPushSymbol( pSymbols + HB_PCODE_MKUSHORT( &pCode[ w + 1 ] ) );
w += 3;
break;
@@ -1920,7 +1920,7 @@ HB_EXPORT void hb_vmExecute( const BYTE * pCode, PHB_SYMB pSymbols )
case HB_P_MMESSAGE:
{
HB_DYNS_PTR pDynSym = ( HB_DYNS_PTR) HB_GET_PTR( pCode + w + 1 );
HB_DYNS_PTR pDynSym = ( HB_DYNS_PTR ) HB_GET_PTR( pCode + w + 1 );
hb_vmPushSymbol( pDynSym->pSymbol );
w += sizeof( HB_DYNS_PTR ) + 1;
break;