diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 9147783c87..fb24a0b133 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -8,6 +8,53 @@ 2002-12-01 13:30 UTC+0100 Foo Bar */ +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( , , [] ) => + HB_BITOR( , , [] ) => + HB_BITXOR( , , [] ) => + HB_BITNOT( ) => + HB_BITTEST( , ) => + HB_BITSET( , ) => + HB_BITRESET( , ) => + HB_BITSHIFT( , ) => + + * 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 ([]) + 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 ;-) diff --git a/harbour/common.mak b/harbour/common.mak index 28c31c86c0..2cbd68aaff 100644 --- a/harbour/common.mak +++ b/harbour/common.mak @@ -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) \ diff --git a/harbour/contrib/tip/Changelog b/harbour/contrib/tip/Changelog index 9b5fcb0b0f..0b6b268fc9 100644 --- a/harbour/contrib/tip/Changelog +++ b/harbour/contrib/tip/Changelog @@ -8,6 +8,120 @@ 2002-12-01 23:12 UTC+0100 Foo Bar */ +2007-05-20 01:00 UTC+0100 Hannes Ziegler + * 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 + * 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 + * 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 + + + 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 + + * 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 * client.prg * smtpcln.prg diff --git a/harbour/contrib/tip/Makefile b/harbour/contrib/tip/Makefile index 07f9dd0ba9..396667d485 100644 --- a/harbour/contrib/tip/Makefile +++ b/harbour/contrib/tip/Makefile @@ -24,7 +24,7 @@ PRG_SOURCES= \ httpcln.prg \ mail.prg \ cgi.prg \ - cstr.prg \ + thtml.prg \ LIBNAME=tip diff --git a/harbour/contrib/tip/cgi.prg b/harbour/contrib/tip/cgi.prg index 3d62a06919..47b8a2914d 100644 --- a/harbour/contrib/tip/cgi.prg +++ b/harbour/contrib/tip/cgi.prg @@ -61,6 +61,7 @@ * */ +#include "hbcompat.ch" #include 'hbclass.ch' #include 'tip.ch' #include 'common.ch' diff --git a/harbour/contrib/tip/client.prg b/harbour/contrib/tip/client.prg index b867ae9a3a..548a3f346f 100644 --- a/harbour/contrib/tip/client.prg +++ b/harbour/contrib/tip/client.prg @@ -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 diff --git a/harbour/contrib/tip/cstr.prg b/harbour/contrib/tip/cstr.prg deleted file mode 100644 index 3e204ed82a..0000000000 --- a/harbour/contrib/tip/cstr.prg +++ /dev/null @@ -1,96 +0,0 @@ -/* - * $Id$ - */ - -/* - * xHarbour Project source code: - * CStr( xAnyType ) -> String - * - * Copyright 2001 Ron Pinkas - * 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 "" diff --git a/harbour/contrib/tip/encoder.prg b/harbour/contrib/tip/encoder.prg index e6d22781d1..1deb9ccd24 100644 --- a/harbour/contrib/tip/encoder.prg +++ b/harbour/contrib/tip/encoder.prg @@ -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 + 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 diff --git a/harbour/contrib/tip/ftpcln.prg b/harbour/contrib/tip/ftpcln.prg index ff298c86fb..2e57c69d14 100644 --- a/harbour/contrib/tip/ftpcln.prg +++ b/harbour/contrib/tip/ftpcln.prg @@ -51,6 +51,19 @@ * */ +/* 2007-04-19, Hannes Ziegler + 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 diff --git a/harbour/contrib/tip/httpcln.prg b/harbour/contrib/tip/httpcln.prg index 78a725b7a0..1102876471 100644 --- a/harbour/contrib/tip/httpcln.prg +++ b/harbour/contrib/tip/httpcln.prg @@ -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 diff --git a/harbour/contrib/tip/mail.prg b/harbour/contrib/tip/mail.prg index 5f3670d02d..097d545771 100644 --- a/harbour/contrib/tip/mail.prg +++ b/harbour/contrib/tip/mail.prg @@ -51,7 +51,15 @@ * */ -#include "common.ch" +/* 2007-04-11, Hannes Ziegler + 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 diff --git a/harbour/contrib/tip/popcln.prg b/harbour/contrib/tip/popcln.prg index e7eac59ebb..8892c94357 100644 --- a/harbour/contrib/tip/popcln.prg +++ b/harbour/contrib/tip/popcln.prg @@ -51,6 +51,11 @@ * */ +/* 2007-04-10, Hannes Ziegler + 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 \ No newline at end of file diff --git a/harbour/contrib/tip/smtpcln.prg b/harbour/contrib/tip/smtpcln.prg index 2eeedb268e..b4c5c0feb6 100644 --- a/harbour/contrib/tip/smtpcln.prg +++ b/harbour/contrib/tip/smtpcln.prg @@ -51,16 +51,20 @@ * */ +/* 2007-04-12, Hannes Ziegler + 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() ) + diff --git a/harbour/contrib/tip/thtml.ch b/harbour/contrib/tip/thtml.ch new file mode 100644 index 0000000000..77182654cc --- /dev/null +++ b/harbour/contrib/tip/thtml.ch @@ -0,0 +1,296 @@ +/* + * Harbour Project source code: + * Directives for HTML Classes + * + * Copyright 2007 Hannes Ziegler + * 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 + diff --git a/harbour/contrib/tip/thtml.prg b/harbour/contrib/tip/thtml.prg new file mode 100644 index 0000000000..ba0e5441e7 --- /dev/null +++ b/harbour/contrib/tip/thtml.prg @@ -0,0 +1,4510 @@ +/* + * Harbour Project source code: + * HTML Classes + * + * Copyright 2007 Hannes Ziegler + * 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. + * + */ + +#include "hbcompat.ch" +#include "common.ch" +#include "error.ch" +#include "hbclass.ch" +#include "thtml.ch" + +#xtranslate ( HAS ) => HB_REGEXHAS( , ) +#xtranslate ( LIKE ) => HB_REGEXLIKE( , ) +#xtranslate ( | [ | ] ) => HB_BITOR( , [, ] ) +#xtranslate ( & [ & ] ) => HB_BITAND( , [, ] ) +#xtranslate HB_BITOR( [,] | ) => HB_BITOR( [,] , ) +#xtranslate HB_BITAND( [,] & ) => HB_BITAND( [,] , ) + +// A Html document can have more than 16 nesting levels. +// The current implementation of FOR EACH is not suitable for the HTML classes + +#define FOR_EACH_NESTING_LIMIT_IS_ONLY_16_AND_FAR_TOO_SMALL + +// Directives for a light weight html parser +#xtrans P_PARSER( ) => {,0,Len(),0} +#define P_STR 1 // the string to parse +#define P_POS 2 // current parser position +#define P_LEN 3 // length of string +#define P_END 4 // last parser position + +#xtrans :p_str => \[P_STR] +#xtrans :p_pos => \[P_POS] +#xtrans :p_len => \[P_LEN] +#xtrans :p_end => \[P_END] + +#xtrans P_SEEK( , ) => (:p_end:=:p_pos, :p_pos:=AtI(,:p_str,:p_end+1)) +#xtrans P_PEEK( , ) => (:p_end:=:p_pos,PStrCompi( :p_str, :p_pos, )) +#xtrans P_NEXT( ) => (:p_end:=:p_pos, :p_str\[++:p_pos]) +#xtrans P_PREV( ) => (:p_end:=:p_pos, :p_str\[--:p_pos]) + +// Directives for a light weight stack +#define S_DATA 1 // array holding data elements +#define S_NUM 2 // number of occupied data elements +#define S_SIZE 3 // total size of data array +#define S_STEP 4 // number of elements for auto sizing + +#xtrans S_STACK() => S_STACK(64) +#xtrans S_STACK( ) => {Array(),0,,Max(32,Int(/2))} +#xtrans S_GROW( ) => (IIF(++\[S_NUM]>\[S_SIZE],ASize(\[S_DATA],(\[S_SIZE]+=\[S_STEP])),)) +#xtrans S_SHRINK( ) => (IIF(\[S_NUM]>0 .AND. --\[S_NUM]\<\[S_SIZE]-\[S_STEP],ASize(\[S_DATA],\[S_SIZE]-=\[S_STEP]),)) +#xtrans S_COMPRESS( ) => (ASize(\[S_DATA],\[S_SIZE]:=\[S_NUM])) +#xtrans S_PUSH(,) => (S_GROW(),\[S_DATA,\[S_NUM]]:=) +#xtrans S_POP(,@) => (:=\[S_DATA,\[S_NUM]],\[S_DATA,\[S_NUM]]:=NIL,S_SHRINK()) +#xtrans S_POP() => (\[S_DATA,\[S_NUM]]:=NIL,S_SHRINK()) +#xtrans S_TOP() => (\[S_DATA,\[S_NUM]]) + + +STATIC saHtmlAttr // data for HTML attributes +STATIC shTagTypes // data for HTML tags +STATIC saHtmlAnsiEntities // HTML character entities (ANSI character set) +STATIC slInit := .F. // initilization flag for HTML data + +* #define _DEBUG_ +#ifdef _DEBUG_ + #xtrans HIDDEN: => EXPORTED: // debugger can't see HIDDEN iVars +#endif + +/* + * Class for handling an entire HTML document + */ +CLASS THtmlDocument + HIDDEN: + DATA oIterator + DATA nodes + + EXPORTED: + DATA root READONLY + DATA head READONLY + DATA body READONLY + DATA changed INIT .T. + + METHOD new( cHtmlString ) + METHOD readFile( cFileName ) + METHOD writeFile( cFileName ) + + METHOD collect() + METHOD toString( nIndent ) + METHOD getNode( cTagName ) + METHOD getNodes( cTagName ) + METHOD findFirst( cName, cAttrib, cValue, cData ) + METHOD findFirstRegex( cName, cAttrib, cValue, cData ) + METHOD findNext() INLINE ::oIterator:Next() +ENDCLASS + + +// accepts a HTML formatted string +METHOD new( cHtmlString ) CLASS THtmlDocument + LOCAL cEmptyHtmlDoc, oNode, oSubNode, oErrNode, aHead, aBody, nMode := 0 + + TEXT INTO cEmptyHtmlDoc + + + + + + + + ENDTEXT + + IF Valtype( cHtmlString ) <> "C" + ::root := THtmlNode():new( cEmptyHtmlDoc ) + ELSE + IF .NOT. ", and tags + // Although they are optional, the THtmlDocument class enforces them + // so that the instance variables :head and :body are always available + aHead := {} + aBody := {} + FOR EACH oSubNode IN ::root:htmlContent + IF oSubNode:isType( CM_HEAD ) + AAdd( aHead, oSubNode ) + ELSE + AAdd( aBody, oSubNode ) + ENDIF + NEXT + + ::root := THtmlNode():new( cEmptyHtmlDoc ) + ::root:document := self + ::changed := .T. + ::head := ::getNode( "head" ) + ::body := ::getNode( "body" ) + + FOR EACH oSubNode IN aHead + IF oSubNode:isType( CM_HEAD ) + ::head:addNode( oSubNode ) + ELSE + ::body:addNode( oSubNode ) + ENDIF + NEXT + + FOR EACH oSubNode IN aBody + IF Lower( oSubNode:htmlTagName ) $ "html,head,body" + // This node is an error in the HTML string. + // We gracefully add its subnodes to the tag + FOR EACH oErrNode IN oSubNode:htmlContent + ::body:addNode( oErrNode ) + NEXT + ELSE + IF oSubNode:isType( CM_HEAD ) + oSubNode:delete() + ::head:addNode( oSubNode ) + ELSE + ::body:addNode( oSubNode ) + ENDIF + ENDIF + NEXT + + ELSEIF ::head == NIL + ::head := ::body:insertBefore( THtmlNode():new( ::body, "head" ) ) + + ELSEIF ::body == NIL + ::head := ::head:insertAfter( THtmlNode():new( ::head, "body" ) ) + + ENDIF + + IF nMode == 1 + oNode := THtmlNode():new( cHtmlString ) + + FOR EACH oSubNode IN oNode:htmlContent + IF oSubNode:isType( CM_HEAD ) + ::head:addNode( oSubNode ) + ELSE + ::body:addNode( oSubNode ) + ENDIF + NEXT + ENDIF +RETURN self + + +// Builds a HTML formatted string +METHOD toString() CLASS THtmlDocument +RETURN ::root:toString() + + +// reads HTML file and parses it into tree of objects +METHOD readFile( cFileName ) CLASS THtmlDocument + IF ! File( cFileName ) + RETURN .F. + ENDIF + ::changed := .T. + ::new( Memoread( cFileName ) ) +RETURN .T. + + +// writes the entire tree of HTML objects into a file +METHOD writeFile( cFileName ) CLASS THtmlDocument + LOCAL cHtml := ::toString() + LOCAL nFileHandle := FCreate( cFileName ) + + IF FError() <> 0 + RETURN .F. + ENDIF + + FWrite( nFileHandle, cHtml, Len(cHtml) ) + FClose( nFileHandle ) + ::changed := .F. +RETURN ( FError()==0 ) + + +// builds a one dimensional array of all nodes contained in the HTML document +METHOD collect() CLASS THtmlDocument + IF ::changed + ::nodes := ::root:collect() + ::changed := .F. + ENDIF +RETURN ::nodes + + +// returns the first tag matching the passed tag name +METHOD getNode( cTagName ) CLASS THtmlDocument + LOCAL oNode + + IF ::changed + ::collect() + ENDIF + + FOR EACH oNode IN ::nodes + IF Lower( oNode:htmlTagName ) == Lower( cTagName ) + RETURN oNode + ENDIF + NEXT +RETURN NIL + + +// returns all tags matching the passed tag name +METHOD getNodes( cTagName ) CLASS THtmlDocument + LOCAL oNode, stack := S_STACK() + + IF ::changed + ::collect() + ENDIF + + FOR EACH oNode IN ::nodes + IF Lower( oNode:htmlTagName ) == Lower( cTagName ) + S_PUSH( stack, oNode ) + ENDIF + NEXT + + S_COMPRESS( stack ) +RETURN stack[S_DATA] + + +// finds the first HTML tag matching the search criteria +METHOD findFirst( cName, cAttrib, cValue, cData ) CLASS THtmlDocument + ::oIterator := THtmlIteratorScan():New( self ) +RETURN ::oIterator:Find( cName, cAttrib, cValue, cData ) + + +// finds the first HTML tag matching the RegEx search criteria +METHOD findFirstRegex( cName, cAttrib, cValue, cData ) CLASS THtmlDocument + ::oIterator := THtmlIteratorRegex():New( self ) +RETURN ::oIterator:Find( cName, cAttrib, cValue, cData ) + + +/* + * Abstract super class for THtmlIteratorScan and THtmlIteratorScanRegEx + * + * (Adopted from TXMLIterator -> source\rtl\TXml.prg) + */ +CLASS THtmlIterator + METHOD New( oNodeTop ) CONSTRUCTOR + METHOD Next() + METHOD Rewind() + METHOD Find( cName, cAttribute, cValue, cData ) + + METHOD GetNode() INLINE ::oNode + METHOD SetContext() + METHOD Clone() + +HIDDEN: + DATA cName + DATA cAttribute + DATA cValue + DATA cData + DATA oNode + DATA oTop + DATA aNodes + DATA nCurrent + DATA nLast + METHOD MatchCriteria() +ENDCLASS + +// accepts a THtmlNode or THtmlDocument object +METHOD New( oHtml ) CLASS THtmlIterator + IF oHtml:isDerivedFrom ( "THtmlDocument" ) + ::oNode := oHtml:root + ::aNodes:= oHtml:nodes + ELSE + ::oNode := oHtml + ::aNodes := ::oNode:collect() + ENDIF + + ::oTop := ::oNode + ::nCurrent := 1 + ::nLast := Len( ::aNodes ) +RETURN Self + + +METHOD rewind CLASS THtmlIterator + ::oNode := ::oTop + ::nCurrent := 0 +RETURN self + + +METHOD Clone() CLASS THtmlIterator + LOCAL oRet + + oRet := THtmlIterator():New( ::oTop ) + oRet:cName := ::cName + oRet:cAttribute := ::cAttribute + oRet:cValue := ::cValue + oRet:cData := ::cData + oRet:nCurrent := 0 + oRet:nLast := Len( ::aNodes ) + oRet:aNodes := ::aNodes + +RETURN oRet + + +METHOD SetContext() CLASS THtmlIterator + ::oTop := ::oNode + ::aNodes := ::oNode:collect() + ::nCurrent := 0 + ::nLast := Len( ::aNodes ) +RETURN Self + + +METHOD Find( cName, cAttribute, cValue, cData ) CLASS THtmlIterator + ::cName := cName + ::cAttribute := cAttribute + ::cValue := cValue + ::cData := cData + + IF ::nLast == 0 + ::nCurrent := 0 + RETURN NIL + ENDIF + + IF ::MatchCriteria( ::oNode ) + RETURN ::oNode + ENDIF +RETURN ::Next() + + +METHOD Next() CLASS THtmlIterator + LOCAL oFound, lExit := .F. + + DO WHILE .NOT. lExit + TRY + oFound := ::aNodes[ ++::nCurrent ] + IF ::MatchCriteria( oFound ) + ::oNode := oFound + lExit := .T. + ENDIF + CATCH + lExit := .T. + oFound := NIL + ::nCurrent := 0 + END + ENDDO +RETURN oFound + + +METHOD MatchCriteria() CLASS THtmlIterator +RETURN .T. + + +/******************************************** + Iterator scan class +*********************************************/ + +CLASS THtmlIteratorScan FROM THtmlIterator + METHOD New( oNodeTop ) CONSTRUCTOR +HIDDEN: + METHOD MatchCriteria( oFound ) +ENDCLASS + +METHOD New( oNodeTop ) CLASS THtmlIteratorScan + ::Super:New( oNodeTop ) +RETURN Self + +METHOD MatchCriteria( oFound ) CLASS THtmlIteratorScan + LOCAL xData + + IF ::cName != NIL .and. ( Lower(::cName) != Lower(oFound:htmlTagName) ) + RETURN .F. + ENDIF + + IF ::cAttribute != NIL .and. .not. HHasKey( oFound:getAttributes(), ::cAttribute ) + RETURN .F. + ENDIF + + IF ::cValue != NIL + xData := oFound:getAttributes() + IF HScan( xData, {| xKey,cValue| HB_SYMBOL_UNUSED(xKey), Lower(::cValue) == Lower(cValue) }) == 0 + RETURN .F. + ENDIF + ENDIF + + IF ::cData != NIL + xData := oFound:getText(" ") + IF Empty(xData) .OR. ( Alltrim(::cData) <> Alltrim(xData) ) + RETURN .F. + ENDIF + ENDIF + +RETURN .T. + +/******************************************** + Iterator regex class +*********************************************/ + +CLASS THtmlIteratorRegex FROM THtmlIterator + METHOD New( oNodeTop ) CONSTRUCTOR +HIDDEN: + METHOD MatchCriteria( oFound ) +ENDCLASS + + +METHOD New( oNodeTop ) CLASS THtmlIteratorRegex + ::Super:New( oNodeTop ) +RETURN Self + + +METHOD MatchCriteria( oFound ) CLASS THtmlIteratorRegex + LOCAL xData + + IF ::cName != NIL .and. .not. ( Lower(::cName) LIKE Lower(oFound:htmlTagName) ) + RETURN .F. + ENDIF + + IF ::cAttribute != NIL .and. ; + hScan( oFound:getAttributes(), {|cKey| ( cKey LIKE lower(::cAttribute) ) } ) == 0 + RETURN .F. + ENDIF + + IF ::cValue != NIL .and.; + hScan( oFound:getAttributes(), {| xKey ,cValue| HB_SYMBOL_UNUSED(xKey), ( cValue LIKE ::cValue ) } ) == 0 + RETURN .F. + ENDIF + + IF ::cData != NIL + xData := oFound:getText(" ") + IF Empty(xData) .OR. .NOT. ( Alltrim(xData) HAS Alltrim(::cData) ) + RETURN .F. + ENDIF + ENDIF +RETURN .T. + +/* + * Class representing a HTML node tree. + * It parses a HTML formatted string + */ +CLASS THtmlNode + HIDDEN: + DATA root + DATA _document + DATA parent + DATA htmlContent + + METHOD parseHtml + METHOD parseHtmlFixed + + METHOD _getTextNode + METHOD _setTextNode + + METHOD keepFormatting + + EXPORTED: + + DATA htmlTagName READONLY + DATA htmlEndTagName READONLY + DATA htmlTagType READONLY + DATA htmlAttributes READONLY + + METHOD new( oParent, cTagName, cAttrib, cContent ) + + METHOD isType( nCM_TYPE ) + ACCESS isEmpty() + ACCESS isInline() + ACCESS isOptional() + ACCESS isNode() + ACCESS isBlock() + + METHOD addNode( oTHtmlNode ) + METHOD insertAfter( oTHtmlNode ) + METHOD insertBefore( oTHtmlNode ) + METHOD delete() + + // Messages from TXmlNode + MESSAGE insertBelow METHOD addNode + MESSAGE unlink METHOD delete + + METHOD firstNode() + METHOD lastNode() + + ACCESS nextNode() + ACCESS prevNode() + + ACCESS siblingNodes() INLINE IIf( ::parent==NIL, NIL, ::parent:htmlContent ) + ACCESS childNodes() INLINE IIf( ::isNode(), ::htmlContent, NIL ) + ACCESS parentNode() INLINE ::parent + ACCESS document() INLINE IIf( ::root==NIL, NIL, ::root:_document ) + + METHOD toString( nIndent ) + METHOD attrToString() + + METHOD collect() + METHOD getText( cCRLF ) + + METHOD getAttribute( cAttrName ) + METHOD getAttributes() + + METHOD setAttribute( cAttrName, cAttrValue ) + METHOD setAttributes( cHtmlAttr ) + + METHOD delAttribute( cAttrName ) + METHOD delAttributes() + + METHOD isAttribute() + + ACCESS text INLINE ::_getTextNode() + ASSIGN text(x) INLINE ::_setTextNode(x) + + ACCESS attr INLINE ::getAttributes() + ASSIGN attr(x) INLINE ::setAttributes(x) + + METHOD pushNode OPERATOR + + METHOD popNode OPERATOR - + + METHOD findNodeByTagName + METHOD findNodesByTagName + + ERROR HANDLER noMessage + METHOD noAttribute +ENDCLASS + + +METHOD new( oParent, cTagName, cAttrib, cContent ) CLASS THtmlNode + IF .NOT. slInit + THtmlInit(.T.) + ENDIF + + IF Valtype( oParent ) == "C" + // a HTML string is passed -> build new tree of objects + IF Chr(9) $ oParent + oParent := StrTran( oParent, Chr(9), Chr(32) ) + ENDIF + ::root := self + ::htmlTagName := "_root_" + ::htmlTagType := THtmlTagType( "_root_" ) + ::htmlContent := {} + ::parseHtml( P_PARSER( oParent ) ) + ELSEIF Valtype( oParent ) == "O" + // a HTML object is passed -> we are in the course of building an object tree + ::root := oParent:root + ::parent := oParent + IF Valtype( cAttrib ) == "C" + IF cAttrib[-1] == "/" + cAttrib[-1] := " " + ::htmlEndTagName := "/" + ::htmlAttributes := Trim( cAttrib ) + ELSE + ::htmlAttributes := cAttrib + ENDIF + ELSE + ::htmlAttributes := cAttrib + ENDIF + ::htmlTagName := cTagName + ::htmlTagType := THtmlTagType( cTagName ) + ::htmlContent := IIF( cContent == NIL, {}, cContent ) + ELSE + RETURN ::error( "Parameter error", ::className(), ":new()", EG_ARG, HB_AParams() ) + ENDIF + +RETURN self + + +METHOD isType( nType ) CLASS THtmlNode + LOCAL lRet + + TRY + lRet := ( ( ::htmlTagType[2] & nType ) > 0 ) + CATCH + lRet := .F. + END + +RETURN lRet + + +// checks if this is a node that is always empty and never has HTML text, e.g. ,, +METHOD isEmpty CLASS THtmlNode +RETURN ( ( ::htmlTagType[2] & CM_EMPTY ) > 0 ) + + +// checks if this is a node that may occur inline, eg. , +METHOD isInline CLASS THtmlNode +RETURN ( ( ::htmlTagType[2] & CM_INLINE ) > 0 ) + + +// checks if this is a node that may appear without a closing tag, eg.

,, +METHOD isOptional CLASS THtmlNode +RETURN ( ( ::htmlTagType[2] & CM_OPT ) > 0 ) + + +// checks if this is a node (leafs contain no further nodes, e.g.
,

,_text_) +METHOD isNode CLASS THtmlNode +RETURN ( Valtype( ::htmlContent ) == "A" .AND. Len( ::htmlContent ) > 0 ) + + +// checks if this is a block node that must be closed with an ending tag: eg:
,
    +METHOD isBlock CLASS THtmlNode +RETURN ( ( ::htmlTagType[2] & CM_BLOCK ) > 0 ) + + +// checks if this is a node whose text line formatting must be preserved: 
    ,