From 1938dd0a7094ddf0cd3cdcb2ef9954afe99f969d Mon Sep 17 00:00:00 2001 From: Viktor Szakats Date: Fri, 14 Apr 2017 13:22:09 +0200 Subject: [PATCH] 2017-04-14 13:22 UTC+0200 Aleksander Czajczynski (hb fki.pl) * contrib/hbtip/ccgi.prg * contrib/hbtip/client.prg * contrib/hbtip/encb64.prg * contrib/hbtip/encoder.prg * contrib/hbtip/encqp.prg * contrib/hbtip/encurl.prg * contrib/hbtip/ftpcli.prg * contrib/hbtip/hbtip.hbp * contrib/hbtip/hbtip.hbx * contrib/hbtip/httpcli.prg * contrib/hbtip/log.prg * contrib/hbtip/mail.prg * contrib/hbtip/mime.c * contrib/hbtip/misc.c * contrib/hbtip/popcli.prg * contrib/hbtip/sessid.prg * contrib/hbtip/smtpcli.prg * contrib/hbtip/thtml.ch * contrib/hbtip/thtml.prg * contrib/hbtip/tip.ch * contrib/hbtip/url.prg + contrib/hbtip/base64u.prg + contrib/hbtip/mailassy.prg * contrib/hbtip/sendmail.prg -> [...]/mailsend.prg + contrib/hbtip/WARNING.txt * contrib/hbtip/tests/base64.prg * contrib/hbtip/tests/dbtohtml.prg * contrib/hbtip/tests/dnldftp.prg -> [...]/ftp_dl.prg * contrib/hbtip/tests/ftpadv.prg -> [...]/ftp_adv.prg + contrib/hbtip/tests/email.prg + contrib/hbtip/tests/ftp_ul.prg - contrib/hbtip/tests/gmail.hbp - contrib/hbtip/tests/gmail.prg * contrib/hbtip/tests/hbmk.hbm * contrib/hbtip/tests/httpadv.prg -> [...]/http_adv.prg * contrib/hbtip/tests/httpcli.prg -> [...]/http_cli.prg + contrib/hbtip/tests/http_qry.prg - contrib/hbtip/tests/loadhtml.prg + contrib/hbtip/tests/test.prg + contrib/hbtip/tests/url.prg * synced with 3.4 fork by Viktor Szakats ; the only difference is slightly edited WARNING.txt - contrib/hbtip/credent.prg % deleted TIPCredentials() class that was never implemented ; changes above come from vast number of commits in 3.4 repository - many thanks to Viktor Szakats for maintaining --- ChangeLog.txt | 50 + contrib/hbtip/WARNING.txt | 42 + contrib/hbtip/{credent.prg => base64u.prg} | 21 +- contrib/hbtip/cgi.prg | 50 +- contrib/hbtip/client.prg | 145 +- contrib/hbtip/encb64.prg | 2 +- contrib/hbtip/encoder.prg | 9 +- contrib/hbtip/encqp.prg | 8 +- contrib/hbtip/encurl.prg | 2 +- contrib/hbtip/ftpcli.prg | 894 ++- contrib/hbtip/hbtip.hbp | 7 +- contrib/hbtip/hbtip.hbx | 6 +- contrib/hbtip/httpcli.prg | 351 +- contrib/hbtip/log.prg | 20 +- contrib/hbtip/mail.prg | 510 +- contrib/hbtip/mailassy.prg | 229 + contrib/hbtip/{sendmail.prg => mailsend.prg} | 227 +- contrib/hbtip/mime.c | 78 +- contrib/hbtip/misc.c | 27 +- contrib/hbtip/popcli.prg | 261 +- contrib/hbtip/sessid.prg | 30 +- contrib/hbtip/smtpcli.prg | 18 +- contrib/hbtip/tests/base64.prg | 118 +- contrib/hbtip/tests/dbtohtml.prg | 55 +- contrib/hbtip/tests/dnldftp.prg | 79 - contrib/hbtip/tests/email.prg | 91 + contrib/hbtip/tests/ftp_adv.prg | 65 + contrib/hbtip/tests/ftp_dl.prg | 47 + contrib/hbtip/tests/ftp_ul.prg | 49 + contrib/hbtip/tests/ftpadv.prg | 58 - contrib/hbtip/tests/gmail.hbp | 3 - contrib/hbtip/tests/gmail.prg | 50 - contrib/hbtip/tests/hbmk.hbm | 2 + contrib/hbtip/tests/http_adv.prg | 61 + contrib/hbtip/tests/http_cli.prg | 33 + contrib/hbtip/tests/http_qry.prg | 46 + contrib/hbtip/tests/httpadv.prg | 57 - contrib/hbtip/tests/httpcli.prg | 24 - contrib/hbtip/tests/loadhtml.prg | 53 - contrib/hbtip/tests/mimetype.prg | 28 +- contrib/hbtip/tests/test.prg | 12 + contrib/hbtip/tests/timestmp.prg | 16 +- contrib/hbtip/tests/tipmail.prg | 39 +- contrib/hbtip/tests/tipmmail.prg | 126 +- contrib/hbtip/tests/tipwget.prg | 180 +- contrib/hbtip/tests/upld_ftp.prg | 82 - contrib/hbtip/tests/url.prg | 21 + contrib/hbtip/thtml.ch | 2 +- contrib/hbtip/thtml.prg | 5528 ++++++++---------- contrib/hbtip/tip.ch | 2 +- contrib/hbtip/url.prg | 66 +- 51 files changed, 4708 insertions(+), 5272 deletions(-) create mode 100644 contrib/hbtip/WARNING.txt rename contrib/hbtip/{credent.prg => base64u.prg} (87%) create mode 100644 contrib/hbtip/mailassy.prg rename contrib/hbtip/{sendmail.prg => mailsend.prg} (55%) delete mode 100644 contrib/hbtip/tests/dnldftp.prg create mode 100644 contrib/hbtip/tests/email.prg create mode 100644 contrib/hbtip/tests/ftp_adv.prg create mode 100644 contrib/hbtip/tests/ftp_dl.prg create mode 100644 contrib/hbtip/tests/ftp_ul.prg delete mode 100644 contrib/hbtip/tests/ftpadv.prg delete mode 100644 contrib/hbtip/tests/gmail.hbp delete mode 100644 contrib/hbtip/tests/gmail.prg create mode 100644 contrib/hbtip/tests/http_adv.prg create mode 100644 contrib/hbtip/tests/http_cli.prg create mode 100644 contrib/hbtip/tests/http_qry.prg delete mode 100644 contrib/hbtip/tests/httpadv.prg delete mode 100644 contrib/hbtip/tests/httpcli.prg delete mode 100644 contrib/hbtip/tests/loadhtml.prg create mode 100644 contrib/hbtip/tests/test.prg delete mode 100644 contrib/hbtip/tests/upld_ftp.prg create mode 100644 contrib/hbtip/tests/url.prg diff --git a/ChangeLog.txt b/ChangeLog.txt index 7e9df9b029..177ab04e60 100644 --- a/ChangeLog.txt +++ b/ChangeLog.txt @@ -10,6 +10,56 @@ * Change, ! Fix, % Optimization, + Addition, - Removal, ; Comment */ +2017-04-14 13:22 UTC+0200 Aleksander Czajczynski (hb fki.pl) + * contrib/hbtip/ccgi.prg + * contrib/hbtip/client.prg + * contrib/hbtip/encb64.prg + * contrib/hbtip/encoder.prg + * contrib/hbtip/encqp.prg + * contrib/hbtip/encurl.prg + * contrib/hbtip/ftpcli.prg + * contrib/hbtip/hbtip.hbp + * contrib/hbtip/hbtip.hbx + * contrib/hbtip/httpcli.prg + * contrib/hbtip/log.prg + * contrib/hbtip/mail.prg + * contrib/hbtip/mime.c + * contrib/hbtip/misc.c + * contrib/hbtip/popcli.prg + * contrib/hbtip/sessid.prg + * contrib/hbtip/smtpcli.prg + * contrib/hbtip/thtml.ch + * contrib/hbtip/thtml.prg + * contrib/hbtip/tip.ch + * contrib/hbtip/url.prg + + contrib/hbtip/base64u.prg + + contrib/hbtip/mailassy.prg + * contrib/hbtip/sendmail.prg -> [...]/mailsend.prg + + contrib/hbtip/WARNING.txt + * contrib/hbtip/tests/base64.prg + * contrib/hbtip/tests/dbtohtml.prg + * contrib/hbtip/tests/dnldftp.prg -> [...]/ftp_dl.prg + * contrib/hbtip/tests/ftpadv.prg -> [...]/ftp_adv.prg + + contrib/hbtip/tests/email.prg + + contrib/hbtip/tests/ftp_ul.prg + - contrib/hbtip/tests/gmail.hbp + - contrib/hbtip/tests/gmail.prg + * contrib/hbtip/tests/hbmk.hbm + * contrib/hbtip/tests/httpadv.prg -> [...]/http_adv.prg + * contrib/hbtip/tests/httpcli.prg -> [...]/http_cli.prg + + contrib/hbtip/tests/http_qry.prg + - contrib/hbtip/tests/loadhtml.prg + + contrib/hbtip/tests/test.prg + + contrib/hbtip/tests/url.prg + * synced with 3.4 fork by Viktor Szakats + ; the only difference is slightly edited WARNING.txt + + - contrib/hbtip/credent.prg + % deleted TIPCredentials() class that was never implemented + + ; changes above come from vast number of commits in 3.4 repository - many + thanks to Viktor Szakats for maintaining + 2017-04-06 12:05 UTC+0200 Aleksander Czajczynski (hb fki.pl) * contrib/hbtip/httpcli.prg ! fixed uploading binary files with TIPClientHTTP:PostMultiPart() diff --git a/contrib/hbtip/WARNING.txt b/contrib/hbtip/WARNING.txt new file mode 100644 index 0000000000..fdfa929fe8 --- /dev/null +++ b/contrib/hbtip/WARNING.txt @@ -0,0 +1,42 @@ +WARNING for HBTIP users +======================= + +Due to the excessive amount of problem reports and long known (and unfixed) +problems and due to the non-trivial nature of internet protocols, this document +_strongly recommends to avoid_ using this library in anything production or +in fact anything more serious than simple test code for educational purposes. +Please notice that even if something happens to work in some specific +scenario, it's highly likely it's not a stable solution, nor is it a secure +solution. + +The only reason hbtip hasn't been deleted altogether is compatibility +with 3.0, xHarbour and existing projects, plus the fact there are still some +low-level functions that do work fine (tip_MimeType()) or have no better +replacement yet (tip_MailAssemble()). + +For internet protocol related tasks, the recommended and supported library +is _hbcurl_, which is a thin wrapper over libcurl's 'easy' API. libcurl is +a highly ubiquitious, very stable, actively and professionally developed, +secure communications library: + + https://curl.haxx.se/libcurl/c/ + +hbcurl's functionality covers _all_ hbtip protocol classes, and it does offer +support for several protocols besides these. + +If you're looking for all required static and dynamic libraries to use hbcurl, +including OpenSSL and libssh2, both 32 and 64-bit. See this page about feature +support and other details: + + https://github.com/vszakats/harbour-deps/ + +Usage examples found on the internet for other languages are most of the time +directly usable with minor modifications in Harbour. You can find several +working examples under the hbcurl tests directory as well. Live curl +command-lines can also be converted into compilable/adaptable API code using +the `--libcurl ` curl option. + +If you opt to use hbtip anyway, and find any problem with it (like very common +SMTP or FTP incompatibilities with various live servers found on the internet), +your best bet is to address the problem yourself. Patches of sufficent quality +will be of course accepted. diff --git a/contrib/hbtip/credent.prg b/contrib/hbtip/base64u.prg similarity index 87% rename from contrib/hbtip/credent.prg rename to contrib/hbtip/base64u.prg index 083f4e5a7d..673b8c24e4 100644 --- a/contrib/hbtip/credent.prg +++ b/contrib/hbtip/base64u.prg @@ -1,7 +1,7 @@ /* - * TIP Class oriented Internet protocol library + * hb_base64EncodeUrl(), hb_base64DecodeUrl() * - * Copyright 2003 Giancarlo Niccolai + * Copyright 2014 Viktor Szakats (vszakats.net/harbour) * * 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 @@ -44,17 +44,8 @@ * */ -#include "hbclass.ch" +FUNCTION tip_base64EncodeUrl( ... ) + RETURN hb_StrReplace( hb_base64Encode( ... ), "+/=", "-_" ) -/* -* Credentials class -* A way to give basic credentials -*/ - -CREATE CLASS TIPCredentials - - VAR cMethod - VAR cUserid - VAR cPassword - -ENDCLASS +FUNCTION tip_base64DecodeUrl( cString ) + RETURN hb_base64Decode( hb_StrReplace( cString, "-_", "+/" ) ) diff --git a/contrib/hbtip/cgi.prg b/contrib/hbtip/cgi.prg index 87d3964353..48d5ab5d6a 100644 --- a/contrib/hbtip/cgi.prg +++ b/contrib/hbtip/cgi.prg @@ -2,14 +2,6 @@ * TIPCgi Class oriented cgi protocol * * Copyright 2006 Lorenzo Fiorini - * - * code from: - * TIP Class oriented Internet protocol library - * - * Copyright 2003 Giancarlo Niccolai - * - * CGI Session Manager Class - * * Copyright 2003-2006 Francesco Saverio Giudice * * This program is free software; you can redistribute it and/or modify @@ -163,7 +155,7 @@ METHOD Flush() CLASS TIPCgi LOCAL cStream LOCAL lRet - LOCAL nH + LOCAL hFile LOCAL cFile LOCAL cSession @@ -175,10 +167,10 @@ METHOD Flush() CLASS TIPCgi lRet := ( FWrite( hb_GetStdOut(), cStream ) == hb_BLen( cStream ) ) IF ::lDumpHtml - IF Empty( ::cDumpSavePath ) + IF ::cDumpSavePath == NIL ::cDumpSavePath := hb_DirTemp() ENDIF - hb_MemoWrit( ::cDumpSavePath + "dump.html", ::cHtmlPage ) + hb_MemoWrit( hb_DirSepAdd( ::cDumpSavePath ) + "dump.html", ::cHtmlPage ) ENDIF ::cCgiHeader := "" @@ -186,14 +178,14 @@ METHOD Flush() CLASS TIPCgi IF ! Empty( ::cSID ) - cFile := ::cSessionSavePath + "SESSIONID_" + ::cSID + cFile := hb_DirSepAdd( ::cSessionSavePath ) + "SESSIONID_" + ::cSID - IF ( nH := FCreate( cFile ) ) != F_ERROR + IF ( hFile := hb_vfOpen( cFile, FO_CREAT + FO_TRUNC + FO_WRITE + FO_EXCLUSIVE ) ) != NIL cSession := ::SessionEncode() - IF FWrite( nH, cSession ) != hb_BLen( cSession ) + IF hb_vfWrite( hFile, cSession ) != hb_BLen( cSession ) ::Write( "ERROR: On writing session file: " + cFile + ", File error: " + hb_CStr( FError() ) ) ENDIF - FClose( nH ) + hb_vfClose( hFile ) ELSE ::Write( "ERROR: On writing session file: " + cFile + ", File error: " + hb_CStr( FError() ) ) ENDIF @@ -206,7 +198,7 @@ METHOD SaveHtmlPage( cFile ) CLASS TIPCgi METHOD StartSession( cSID ) CLASS TIPCgi - LOCAL nH + LOCAL hFile LOCAL cFile LOCAL nFileSize LOCAL cBuffer @@ -219,7 +211,7 @@ METHOD StartSession( cSID ) CLASS TIPCgi ENDCASE ENDIF - IF Empty( ::cSessionSavePath ) + IF ::cSessionSavePath == NIL ::cSessionSavePath := hb_DirTemp() ENDIF @@ -227,19 +219,19 @@ METHOD StartSession( cSID ) CLASS TIPCgi ::cSID := cSID - cFile := ::cSessionSavePath + "SESSIONID_" + cSID + cFile := hb_DirSepAdd( ::cSessionSavePath ) + "SESSIONID_" + cSID - IF hb_FileExists( cFile ) - IF ( nH := FOpen( cFile ) ) != F_ERROR - nFileSize := FSeek( nH, 0, FS_END ) - FSeek( nH, 0, FS_SET ) + IF hb_vfExists( cFile ) + IF ( hFile := hb_vfOpen( cFile, FO_READ ) ) != NIL + nFileSize := hb_vfSize( hFile ) + hb_vfSeek( hFile, 0, FS_SET ) cBuffer := Space( nFileSize ) - IF FRead( nH, @cBuffer, nFileSize ) != nFileSize + IF hb_vfRead( hFile, @cBuffer, nFileSize ) != nFileSize ::ErrHandler( "ERROR: On reading session file: " + cFile + ", File error: " + hb_CStr( FError() ) ) ELSE ::SessionDecode( cBuffer ) ENDIF - FClose( nH ) + hb_vfClose( hFile ) ENDIF ELSE ::ErrHandler( "ERROR: On opening session file: " + cFile + ", file not exist." ) @@ -275,10 +267,10 @@ METHOD DestroySession( cID ) CLASS TIPCgi ::hSession := { => } - cFile := ::cSessionSavePath + "SESSIONID_" + cSID + cFile := hb_DirSepAdd( ::cSessionSavePath ) + "SESSIONID_" + cSID - IF ( lOk := ( FErase( cFile ) != F_ERROR ) ) - ::hCookies[ "SESSIONID" ] := cSID + "; expires= " + tip_DateToGMT( Date() - 1 ) + IF ( lOk := ( hb_vfErase( cFile ) != F_ERROR ) ) + ::hCookies[ "SESSIONID" ] := cSID + "; expires= " + tip_DateToGMT( hb_DateTime() - 1 ) ::CreateSID() ::hCookies[ "SESSIONID" ] := ::cSID ELSE @@ -288,7 +280,7 @@ METHOD DestroySession( cID ) CLASS TIPCgi RETURN lOk -METHOD ErrHandler( xError ) CLASS TIPCgi +METHOD PROCEDURE ErrHandler( xError ) CLASS TIPCgi LOCAL nCalls @@ -322,7 +314,7 @@ METHOD ErrHandler( xError ) CLASS TIPCgi QUIT - RETURN NIL + RETURN METHOD Write( cString ) CLASS TIPCgi diff --git a/contrib/hbtip/client.prg b/contrib/hbtip/client.prg index 826a0e2058..505e315451 100644 --- a/contrib/hbtip/client.prg +++ b/contrib/hbtip/client.prg @@ -2,8 +2,11 @@ * TIP Class oriented Internet protocol library * * Copyright 2003 Giancarlo Niccolai + * Copyright 2007 Hannes Ziegler (INetErrorDesc(), lastErrorCode(), lastErrorMessage()) + * Copyright 2007 Toninho@fwi (::nWrite to work like ::nRead) + * Copyright 2009 Luiz Rafael Culik (luiz at xharbour dot com dot br) (Proxy connection) * Copyright 2009 Viktor Szakats (vszakats.net/harbour) (SSL support) - * Copyright 2015 Jean Lefebvre (TLS support) + * Copyright 2015 Jean Lefebvre (STARTTLS support) * * 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 @@ -46,27 +49,6 @@ * */ -/* 2004-01-13 - Enhanced 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 - 2009-06-29, Luiz Rafael Culik (luiz at xharbour dot com dot br) - Added support for proxy connection - 2015-01-29, Jean Lefebvre - added FUNCTION ActivateSSL(Self) - to be used here and into smtpcli (needed to post activate SSL as request in TLS) - Also, changed all reference to TLS to SSL -*/ - #include "hbclass.ch" #include "error.ch" @@ -77,11 +59,10 @@ #endif #include "hbssl.ch" -#undef __HBEXTREQ__ #include "hbssl.hbx" -#define RCV_BUF_SIZE Int( ::InetRcvBufSize( ::SocketCon ) / 2 ) -#define SND_BUF_SIZE Int( ::InetSndBufSize( ::SocketCon ) / 2 ) +#define RCV_BUF_SIZE Int( ::InetRcvBufSize( ::SocketCon ) / 2 ) +#define SND_BUF_SIZE Int( ::InetSndBufSize( ::SocketCon ) / 2 ) /* Inet Client class */ CREATE CLASS TIPClient @@ -126,10 +107,13 @@ CREATE CLASS TIPClient VAR Cargo /* Data for proxy connection */ - VAR cProxyHost + VAR cProxyHost INIT "" VAR nProxyPort INIT 0 VAR cProxyUser VAR cProxyPassword + VAR lProxyXferSSL INIT .F. /* SSL should only be enabled after proxy connection + NOTE: I've only checked HTTP POST / GET, unsure if + there are other funtions with this issue. */ METHOD New( oUrl, xTrace, oCredentials ) METHOD Open( cUrl ) @@ -183,12 +167,13 @@ METHOD New( oUrl, xTrace, oCredentials ) CLASS TIPClient LOCAL oLog LOCAL lSSL - IF HB_ISSTRING( xTrace ) .OR. hb_defaultValue( xTrace, .F. ) + DO CASE + CASE HB_ISSTRING( xTrace ) .OR. hb_defaultValue( xTrace, .F. ) oLog := TIPLog():New( iif( HB_ISSTRING( xTrace ), xTrace, NIL ) ) ::bTrace := {| cMsg | iif( PCount() > 0, oLog:Add( cMsg ), oLog:Close() ) } - ELSEIF HB_ISEVALITEM( xTrace ) + CASE HB_ISEVALITEM( xTrace ) ::bTrace := xTrace - ENDIF + ENDCASE IF HB_ISSTRING( oUrl ) oUrl := TUrl():New( oUrl ) @@ -257,7 +242,7 @@ METHOD Open( cUrl ) CLASS TIPClient ::InetTimeOut( ::SocketCon ) - IF Empty( ::cProxyHost ) + IF ::cProxyHost == "" ::inetConnect( ::oUrl:cServer, nPort, ::SocketCon ) IF ::inetErrorCode( ::SocketCon ) != 0 RETURN .F. @@ -277,6 +262,8 @@ METHOD EnableSSL( lEnable ) CLASS TIPClient RETURN .T. ENDIF + ::lProxyXferSSL := .F. + IF lEnable IF ::lHasSSL ::ssl_ctx := SSL_CTX_new() @@ -309,10 +296,10 @@ METHOD OpenProxy( cServer, nPort, cProxy, nProxyPort, cResp, cUserName, cPasswor cRequest := ; "CONNECT " + cServer + ":" + hb_ntos( nPort ) + " HTTP/1.1" + Chr( 13 ) + Chr( 10 ) + ; "Proxy-Connection: Keep-Alive" + Chr( 13 ) + Chr( 10 ) - IF HB_ISSTRING( cUserAgent ) .AND. ! Empty( cUserAgent ) + IF HB_ISSTRING( cUserAgent ) .AND. ! cUserAgent == "" cRequest += "User-Agent: " + cUserAgent + Chr( 13 ) + Chr( 10 ) ENDIF - IF HB_ISSTRING( cUserName ) .AND. ! Empty( cUserName ) + IF HB_ISSTRING( cUserName ) .AND. ! cUserName == "" cRequest += "Proxy-Authorization: Basic " + hb_base64Encode( cUserName + ":" + hb_defaultValue( cPassword, "" ) ) + Chr( 13 ) + Chr( 10 ) ENDIF cRequest += Chr( 13 ) + Chr( 10 ) @@ -329,6 +316,14 @@ METHOD OpenProxy( cServer, nPort, cProxy, nProxyPort, cResp, cUserName, cPasswor cResp := hb_ntos( tmp ) ENDIF + /* Enable SSL after proxy connection is OK */ + IF lRet .AND. ::lSSL .AND. ::lHasSSL + __tip_SSLConnectFD( ::ssl, ::SocketCon ) + ::lProxyXferSSL := .T. + ELSE + ::lProxyXferSSL := .F. + ENDIF + RETURN lRet METHOD ReadHTTPProxyResponse( /* @ */ cResponse ) CLASS TIPClient @@ -365,6 +360,7 @@ METHOD Close() CLASS TIPClient ::SocketCon := NIL ::isOpen := .F. + ::lProxyXferSSL := .F. ENDIF IF HB_ISEVALITEM( ::bTrace ) @@ -439,7 +435,7 @@ METHOD Read( nLen ) CLASS TIPClient METHOD ReadToFile( /* @ */ cFile, nMode, nSize ) CLASS TIPClient - LOCAL nFOut + LOCAL hFile LOCAL cData LOCAL nSent := 0 @@ -451,8 +447,9 @@ METHOD ReadToFile( /* @ */ cFile, nMode, nSize ) CLASS TIPClient cFile := "" ENDIF - IF HB_ISEVALITEM( ::exGauge ) - Eval( ::exGauge, nSent, nSize, Self ) + IF HB_ISEVALITEM( ::exGauge ) .AND. ; + ! hb_defaultValue( Eval( ::exGauge, nSent, nSize, Self ), .T. ) + RETURN .F. ENDIF ::nRead := 0 @@ -460,13 +457,13 @@ METHOD ReadToFile( /* @ */ cFile, nMode, nSize ) CLASS TIPClient DO WHILE ::inetErrorCode( ::SocketCon ) == 0 .AND. ! ::bEof IF ( cData := ::Read( RCV_BUF_SIZE ) ) == NIL - IF nFOut != NIL - FClose( nFOut ) + IF hFile != NIL + hb_vfClose( hFile ) ENDIF RETURN ::inetErrorCode( ::SocketCon ) == 0 ENDIF - IF ! lToMemory .AND. nFOut == NIL - IF ( nFOut := FCreate( cFile, nMode ) ) == F_ERROR + IF ! lToMemory .AND. hFile == NIL + IF ( hFile := hb_vfOpen( cFile, hb_bitOr( FO_CREAT + FO_TRUNC + FO_WRITE, hb_defaultValue( nMode, 0 ) ) ) ) == NIL ::nStatus := 0 RETURN .F. ENDIF @@ -474,15 +471,19 @@ METHOD ReadToFile( /* @ */ cFile, nMode, nSize ) CLASS TIPClient IF lToMemory cFile += cData - ELSEIF FWrite( nFOut, cData ) != hb_BLen( cData ) - FClose( nFOut ) + ELSEIF hb_vfWrite( hFile, cData ) != hb_BLen( cData ) + hb_vfClose( hFile ) RETURN .F. ENDIF nSent += hb_BLen( cData ) - IF HB_ISEVALITEM( ::exGauge ) - Eval( ::exGauge, nSent, nSize, Self ) + IF HB_ISEVALITEM( ::exGauge ) .AND. ; + ! hb_defaultValue( Eval( ::exGauge, nSent, nSize, Self ), .T. ) + IF hFile != NIL + hb_vfClose( hFile ) + ENDIF + RETURN .F. ENDIF ENDDO @@ -491,8 +492,8 @@ METHOD ReadToFile( /* @ */ cFile, nMode, nSize ) CLASS TIPClient ENDIF ::nStatus := 2 - IF nFOut != NIL - FClose( nFOut ) + IF hFile != NIL + hb_vfClose( hFile ) ENDIF RETURN ::inetErrorCode( ::SocketCon ) == 0 @@ -506,31 +507,35 @@ METHOD WriteFromFile( cFile ) CLASS TIPClient ::nWrite := 0 ::nStatus := 0 - IF ( nFIn := FOpen( cFile ) ) == F_ERROR + IF ( nFIn := hb_vfOpen( cFile, FO_READ ) ) == NIL RETURN .F. ENDIF - nSize := FSeek( nFIn, 0, FS_END ) - FSeek( nFIn, 0 ) + nSize := hb_vfSize( nFIn ) + hb_vfSeek( nFIn, 0 ) nBufSize := SND_BUF_SIZE // allow initialization of the gauge nSent := 0 - IF HB_ISEVALITEM( ::exGauge ) - Eval( ::exGauge, nSent, nSize, Self ) + IF HB_ISEVALITEM( ::exGauge ) .AND. ; + ! hb_defaultValue( Eval( ::exGauge, nSent, nSize, Self ), .T. ) + hb_vfClose( nFIn ) + RETURN .F. ENDIF ::nStatus := 1 cData := Space( nBufSize ) - DO WHILE ( nLen := FRead( nFIn, @cData, nBufSize ) ) > 0 + DO WHILE ( nLen := hb_vfRead( nFIn, @cData, nBufSize ) ) > 0 IF ::Write( @cData, nLen ) != nLen - FClose( nFIn ) + hb_vfClose( nFIn ) RETURN .F. ENDIF nSent += nLen - IF HB_ISEVALITEM( ::exGauge ) - Eval( ::exGauge, nSent, nSize, Self ) + IF HB_ISEVALITEM( ::exGauge ) .AND. ; + ! hb_defaultValue( Eval( ::exGauge, nSent, nSize, Self ), .T. ) + hb_vfClose( nFIn ) + RETURN .F. ENDIF ENDDO @@ -540,7 +545,7 @@ METHOD WriteFromFile( cFile ) CLASS TIPClient ENDIF ::nStatus := 2 - FClose( nFIn ) + hb_vfClose( nFIn ) RETURN .T. @@ -568,7 +573,7 @@ METHOD inetSendAll( SocketCon, cData, nLen ) CLASS TIPClient nLen := hb_BLen( cData ) ENDIF - IF ::lSSL + IF ::lSSL .AND. ( ::cProxyHost == "" .OR. ::lProxyXferSSL ) IF ::lHasSSL #if defined( _SSL_DEBUG_TEMP ) ? "SSL_write()", cData @@ -602,7 +607,7 @@ METHOD inetRecv( SocketCon, cStr1, len ) CLASS TIPClient LOCAL nRet - IF ::lSSL + IF ::lSSL .AND. ( ::cProxyHost == "" .OR. ::lProxyXferSSL ) IF ::lHasSSL #if defined( _SSL_DEBUG_TEMP ) ? "SSL_read()" @@ -632,7 +637,7 @@ METHOD inetRecvLine( SocketCon, nRet, size ) CLASS TIPClient #if defined( _SSL_DEBUG_TEMP ) ? "hb_SSL_read_line()", cRet #endif - IF nRet == 0 .OR. Empty( cRet ) + IF nRet == 0 .OR. cRet == "" cRet := NIL ENDIF ::nSSLError := iif( nRet < 0, nRet, 0 ) @@ -660,7 +665,7 @@ METHOD inetRecvAll( SocketCon, cRet, size ) CLASS TIPClient #if defined( _SSL_DEBUG_TEMP ) ? "hb_SSL_read_all()", cRet #endif - IF nRet == 0 .OR. Empty( cRet ) + IF nRet == 0 .OR. cRet == "" cRet := NIL ENDIF ::nSSLError := iif( nRet < 0, nRet, 0 ) @@ -717,7 +722,7 @@ METHOD inetErrorDesc( SocketCon ) CLASS TIPClient RETURN "" /* BROKEN, should test number of parameters and act accordingly, see doc/inet.txt */ -METHOD inetConnect( cServer, nPort, SocketCon ) CLASS TIPClient +METHOD PROCEDURE inetConnect( cServer, nPort, SocketCon ) CLASS TIPClient hb_inetConnect( cServer, nPort, SocketCon ) @@ -725,7 +730,7 @@ METHOD inetConnect( cServer, nPort, SocketCon ) CLASS TIPClient resolved and it is SSL compliant, then RTE must be avoided [pritpal] */ IF hb_inetStatus( SocketCon ) == -1 - RETURN NIL + RETURN ENDIF IF hb_defaultValue( ::nDefaultSndBuffSize, 0 ) > 0 @@ -736,15 +741,18 @@ METHOD inetConnect( cServer, nPort, SocketCon ) CLASS TIPClient ::InetRcvBufSize( SocketCon, ::nDefaultRcvBuffSize ) ENDIF - IF ::lSSL .AND. ::lHasSSL - __tip_SSLConnectFD( ::ssl, SocketCon ) + IF ::lSSL .AND. ::lHasSSL .AND. ::cProxyHost == "" + __tip_SSLConnectFD( ::ssl, SocketCon ) /* Proxy will do this in OpenProxy() */ + ::lProxyXferSSL := .T. + ELSE + ::lProxyXferSSL := .F. ENDIF IF HB_ISEVALITEM( ::bTrace ) ::Log( cServer, nPort, SocketCon ) ENDIF - RETURN NIL + RETURN /* Methods to manage buffers */ METHOD InetRcvBufSize( SocketCon, nSizeBuff ) CLASS TIPClient @@ -798,13 +806,14 @@ METHOD Log( ... ) CLASS TIPClient cMsg += hb_StrReplace( AllTrim( hb_CStr( xVar ) ), Chr( 13 ) + Chr( 10 ), { "", "" } ) ENDIF - IF xVar:__enumIsLast() + DO CASE + CASE xVar:__enumIsLast() cMsg += " <<" + hb_eol() + hb_eol() - ELSEIF xVar:__enumIndex() == PCount() - 1 + CASE xVar:__enumIndex() == PCount() - 1 cMsg += " )" + hb_eol() + ">> " - ELSE + OTHERWISE cMsg += ", " - ENDIF + ENDCASE NEXT Eval( ::bTrace, cMsg ) diff --git a/contrib/hbtip/encb64.prg b/contrib/hbtip/encb64.prg index b724cd5fce..bcfb72f635 100644 --- a/contrib/hbtip/encb64.prg +++ b/contrib/hbtip/encb64.prg @@ -46,7 +46,7 @@ #include "hbclass.ch" -CREATE CLASS TIPEncoderBase64 FROM TIPEncoder +CREATE CLASS TIPEncoderBase64 INHERIT TIPEncoder /* Set this to .T. to enable RFC 2068 (HTTP/1.1) exception to RFC 2045 (MIME) base64 format. This exception consists in diff --git a/contrib/hbtip/encoder.prg b/contrib/hbtip/encoder.prg index 4d34d41846..16737ef33a 100644 --- a/contrib/hbtip/encoder.prg +++ b/contrib/hbtip/encoder.prg @@ -2,6 +2,7 @@ * TIP Class oriented Internet protocol library * * Copyright 2003 Giancarlo Niccolai + * Copyright 2007 Hannes Ziegler (tip_GetEncoder()) * * 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 @@ -44,13 +45,7 @@ * */ -/* - Internet Messaging: http://www.ietf.org/rfc/rfc2045.txt - */ - -/* 2007-04-12, Hannes Ziegler - Added Function: tip_GetEncoder() -*/ +/* Internet Messaging: https://www.ietf.org/rfc/rfc2045.txt */ #include "hbclass.ch" diff --git a/contrib/hbtip/encqp.prg b/contrib/hbtip/encqp.prg index 3a3fb5df3e..1b22c384dd 100644 --- a/contrib/hbtip/encqp.prg +++ b/contrib/hbtip/encqp.prg @@ -44,9 +44,11 @@ * */ +#pragma -gc3 + #include "hbclass.ch" -CREATE CLASS TIPEncoderQP FROM TIPEncoder +CREATE CLASS TIPEncoderQP INHERIT TIPEncoder METHOD New() CONSTRUCTOR METHOD Encode( cData ) @@ -82,7 +84,7 @@ FUNCTION tip_QPEncode( cData ) nLineLen := 0 ELSEIF hb_BCode( c ) >= 127 .OR. ; c $ '=?!"#$@[\]^`{|}~' .OR. ; - ( hb_BCode( c ) < 32 .AND. !( c $ Chr( 13 ) + Chr( 10 ) + Chr( 9 ) ) ) .OR. ; + ( hb_BCode( c ) < 32 .AND. ! c $ Chr( 13 ) + Chr( 10 ) + Chr( 9 ) ) .OR. ; ( c $ " " + Chr( 9 ) .AND. hb_BSubStr( cData, nPos + 1, 1 ) $ Chr( 13 ) + Chr( 10 ) ) IF nLineLen + 3 > 75 cString += "=" + Chr( 13 ) + Chr( 10 ) @@ -90,7 +92,7 @@ FUNCTION tip_QPEncode( cData ) ENDIF cString += "=" + hb_NumToHex( hb_BCode( c ), 2 ) nLineLen += 3 - ELSEIF !( c == Chr( 13 ) ) + ELSEIF ! c == Chr( 13 ) IF nLineLen + 3 > 75 cString += "=" + Chr( 13 ) + Chr( 10 ) nLineLen := 0 diff --git a/contrib/hbtip/encurl.prg b/contrib/hbtip/encurl.prg index aa40237e78..455212ce05 100644 --- a/contrib/hbtip/encurl.prg +++ b/contrib/hbtip/encurl.prg @@ -46,7 +46,7 @@ #include "hbclass.ch" -CREATE CLASS TIPEncoderUrl FROM TIPEncoder +CREATE CLASS TIPEncoderUrl INHERIT TIPEncoder METHOD New() CONSTRUCTOR METHOD Encode( cData ) diff --git a/contrib/hbtip/ftpcli.prg b/contrib/hbtip/ftpcli.prg index 7dac53bbd7..f355eb5e1d 100644 --- a/contrib/hbtip/ftpcli.prg +++ b/contrib/hbtip/ftpcli.prg @@ -1,6 +1,11 @@ /* * TIP Class oriented Internet protocol library (FTP) * + * Copyright 2007 Hannes Ziegler (RMD(), listFiles(), MPut()) + * Copyright 2007 Toninho@fwi (UserCommand()) + * Copyright 2007 miguelangel@marchuet.net (NoOp(), Rest(), Port(), SendPort()) + * Copyright 2007 Patrick Mast (fileSize()) + * Copyright 2005 Rafa Carmona (LS(), Rename(), UploadFile(), DownloadFile(), MKD()) * Copyright 2003 Giancarlo Niccolai * * This program is free software; you can redistribute it and/or modify @@ -44,60 +49,23 @@ * */ -/* 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 ) - - 2007-07-12, miguelangel@marchuet.net - Added method :NoOp() - Added method :Rest( nPos ) - Changed method :LS( cSpec ) - Changed method :List( cSpec ) - Changed method :TransferStart() - Changed method :Stor( cFile ) - Changed method :UploadFile( cLocalFile, cRemoteFile ) - Changed method :DownloadFile( cLocalFile, cRemoteFile ) - - Added support to Port transfer mode - Added method :Port() - Added method :SendPort() - - Cleaned unused variables. - - 2007-09-08 21:34 UTC+0100 Patrick Mast - * Formatting - + METHOD StartCleanLogFile() - Starts a clean log file, overwriting current logfile. - + METHOD fileSize( cFileSpec ) - Calculates the filesize of the given files specifications. - + DATA cLogFile - Holds the filename of the current logfile. - ! Fixed logfilename in New(), now its not limited to 9999 log files anymore - ! Fixed MGet() due to changes in hb_ATokens() - ! Fixed listFiles() due to changes in hb_ATokens() - ! listFiles() is still buggy. Needs to be fixed. -*/ - #include "hbclass.ch" #include "directry.ch" #include "tip.ch" -/* TOFIX: This won't work in MT programs. [vszakats] */ -STATIC s_nPort := 16000 +#define _PORT_MIN 16000 +#define _PORT_MAX 24000 -CREATE CLASS TIPClientFTP FROM TIPClient +STATIC s_nPort := _PORT_MIN +STATIC s_mutexPort := hb_mutexCreate() + +CREATE CLASS TIPClientFTP INHERIT TIPClient VAR nDataPort VAR cDataServer - VAR bUsePasv + VAR bUsePasv INIT .T. VAR RegBytes VAR RegPasv // Socket opened in response to a port command @@ -106,62 +74,57 @@ CREATE CLASS TIPClientFTP FROM TIPClient METHOD New( oUrl, xTrace, oCredentials ) METHOD Open( cUrl ) - METHOD Read( nLen ) - METHOD Write( cData, nLen ) METHOD Close() - METHOD TransferStart() - METHOD Commit() - METHOD GetReply() + METHOD Commit() + METHOD ScanLength() + METHOD TransferStart() + METHOD Pasv() + METHOD Quit() METHOD TypeI() METHOD TypeA() METHOD NoOp() METHOD Rest( nPos ) - METHOD List( cSpec ) - METHOD UserCommand( cCommand, lPasv, lReadPort, lGetReply ) METHOD Pwd() METHOD Cwd( cPath ) METHOD Dele( cPath ) - METHOD Port() - METHOD SendPort() - METHOD Retr( cFile ) - METHOD Stor( cFile ) - METHOD Quit() - METHOD ScanLength() - METHOD ReadAuxPort( cLocalFile ) - METHOD mget( cSpec, cLocalPath ) - - // Method below contributed by Rafa Carmona - METHOD LS( cSpec ) METHOD Rename( cFrom, cTo ) - METHOD UpLoadFile( cLocalFile, cRemoteFile ) // new method for file upload - METHOD DownLoadFile( cLocalFile, cRemoteFile ) // new method to download file - METHOD MKD( cPath ) // new method to create an directory on ftp server - + METHOD MKD( cPath ) METHOD RMD( cPath ) - METHOD listFiles( cFileSpec ) - METHOD MPut - METHOD fileSize( cFileSpec ) + METHOD Retr( cFile ) + METHOD Stor( cFile ) + METHOD List( cSpec ) + METHOD UserCommand( cCommand, lPasv, lReadPort, lGetReply ) + + METHOD Port() + METHOD SendPort() + METHOD ReadAuxPort() + METHOD Read( nLen ) + METHOD Write( cData, nLen ) + METHOD MGet( cSpec, cLocalPath ) + METHOD MPut( cFileSpec, cAttr ) + METHOD UploadFile( cLocalFile, cRemoteFile ) + METHOD DownloadFile( cLocalFile, cRemoteFile ) + METHOD ListFiles( cFileSpec ) + METHOD FileSize( cFileSpec ) ENDCLASS - METHOD New( oUrl, xTrace, oCredentials ) CLASS TIPClientFTP - ::super:new( oUrl, iif( HB_ISLOGICAL( xTrace ) .AND. xTrace, "ftp", xTrace ), oCredentials ) + ::super:new( oUrl, iif( hb_defaultValue( xTrace, .F. ), "ftp", xTrace ), oCredentials ) ::nDefaultPort := 21 ::nConnTimeout := 3000 - ::bUsePasv := .T. ::nAccessMode := TIP_RW // a read-write protocol - ::nDefaultSndBuffSize := 65536 - ::nDefaultRcvBuffSize := 65536 + + ::nDefaultSndBuffSize := ::nDefaultRcvBuffSize := 65536 // precompilation of regex for better prestations ::RegBytes := hb_regexComp( "\(([0-9]+)[ )a-zA-Z]" ) - ::RegPasv := hb_regexComp( "([0-9]*) *, *([0-9]*) *, *([0-9]*) *, *([0-9]*) *, *([0-9]*) *, *([0-9]*)" ) + ::RegPasv := hb_regexComp( "([0-9]*) *, *([0-9]*) *, *([0-9]*) *, *([0-9]*) *, *([0-9]*) *, *([0-9]*)" ) RETURN Self @@ -171,74 +134,24 @@ METHOD Open( cUrl ) CLASS TIPClientFTP ::oUrl := TUrl():New( cUrl ) ENDIF - IF Len( ::oUrl:cUserid ) == 0 .OR. Len( ::oUrl:cPassword ) == 0 - RETURN .F. - ENDIF + IF ! ::oUrl:cUserid == "" .AND. ; + ! ::oUrl:cPassword == "" - IF ! ::super:Open() - RETURN .F. - ENDIF - - IF ::GetReply() - ::inetSendAll( ::SocketCon, "USER " + ::oUrl:cUserid + ::cCRLF ) - IF ::GetReply() - ::inetSendAll( ::SocketCon, "PASS " + ::oUrl:cPassword + ::cCRLF ) - // set binary by default - IF ::GetReply() .AND. ::TypeI() - RETURN .T. + IF ::super:Open() + IF ::GetReply() + ::inetSendAll( ::SocketCon, "USER " + ::oUrl:cUserid + ::cCRLF ) + IF ::GetReply() + ::inetSendAll( ::SocketCon, "PASS " + ::oUrl:cPassword + ::cCRLF ) + IF ::GetReply() .AND. ::TypeI() // set binary by default + RETURN .T. + ENDIF + ENDIF ENDIF ENDIF ENDIF RETURN .F. -METHOD GetReply() CLASS TIPClientFTP - - LOCAL nLen - LOCAL cRep - - ::cReply := ::inetRecvLine( ::SocketCon, @nLen, 128 ) - - cRep := ::cReply - - IF cRep == NIL - RETURN .F. - ENDIF - - // now, if the reply has a "-" as fourth character, we need to proceed... - DO WHILE ! Empty( cRep ) .AND. SubStr( cRep, 4, 1 ) == "-" - ::cReply := ::inetRecvLine( ::SocketCon, @nLen, 128 ) - cRep := iif( HB_ISSTRING( ::cReply ), ::cReply, "" ) - ENDDO - - // 4 and 5 are error codes - IF ::inetErrorCode( ::SocketCon ) != 0 .OR. Val( Left( ::cReply, 1 ) ) >= 4 - RETURN .F. - ENDIF - - RETURN .T. - -METHOD Pasv() CLASS TIPClientFTP - - LOCAL aRep - - ::inetSendAll( ::SocketCon, "PASV" + ::cCRLF ) - - IF ! ::GetReply() - RETURN .F. - ENDIF - - aRep := hb_regex( ::RegPasv, ::cReply ) - - IF Empty( aRep ) - RETURN .F. - ENDIF - - ::cDataServer := aRep[ 2 ] + "." + aRep[ 3 ] + "." + aRep[ 4 ] + "." + aRep[ 5 ] - ::nDataPort := Val( aRep[ 6 ] ) * 256 + Val( aRep[ 7 ] ) - - RETURN .T. - METHOD Close() CLASS TIPClientFTP ::InetTimeOut( ::SocketCon ) @@ -247,59 +160,32 @@ METHOD Close() CLASS TIPClientFTP RETURN ::super:Close() -METHOD Quit() CLASS TIPClientFTP +METHOD GetReply() CLASS TIPClientFTP - ::inetSendAll( ::SocketCon, "QUIT" + ::cCRLF ) + LOCAL nLen + LOCAL cRep := ::cReply := ::inetRecvLine( ::SocketCon, @nLen, 128 ) - RETURN ::GetReply() - -METHOD TypeI() CLASS TIPClientFTP - - ::inetSendAll( ::SocketCon, "TYPE I" + ::cCRLF ) - - RETURN ::GetReply() - -METHOD TypeA() CLASS TIPClientFTP - - ::inetSendAll( ::SocketCon, "TYPE A" + ::cCRLF ) - - RETURN ::GetReply() - -METHOD NoOp() CLASS TIPClientFTP - - ::inetSendAll( ::SocketCon, "NOOP" + ::cCRLF ) - - RETURN ::GetReply() - -METHOD Rest( nPos ) CLASS TIPClientFTP - - ::inetSendAll( ::SocketCon, "REST " + hb_ntos( iif( Empty( nPos ), 0, nPos ) ) + ::cCRLF ) - - RETURN ::GetReply() - -METHOD CWD( cPath ) CLASS TIPClientFTP - - ::inetSendAll( ::SocketCon, "CWD " + cPath + ::cCRLF ) - - RETURN ::GetReply() - -METHOD PWD() CLASS TIPClientFTP - - ::inetSendAll( ::SocketCon, "PWD" + ::cCRLF ) - IF ! ::GetReply() + IF cRep == NIL RETURN .F. ENDIF - ::cReply := SubStr( ::cReply, At( '"', ::cReply ) + 1, ; - RAt( '"', ::cReply ) - At( '"', ::cReply ) - 1 ) - RETURN .T. + // now, if the reply has a "-" as fourth character, we need to proceed... + DO WHILE ! Empty( cRep ) .AND. SubStr( cRep, 4, 1 ) == "-" + cRep := ::cReply := hb_defaultValue( ::inetRecvLine( ::SocketCon, @nLen, 128 ), "" ) + ENDDO + // 4 and 5 are error codes + RETURN ::inetErrorCode( ::SocketCon ) == 0 .AND. Val( Left( ::cReply, 1 ) ) < 4 -METHOD DELE( cPath ) CLASS TIPClientFTP +METHOD Commit() CLASS TIPClientFTP - ::inetSendAll( ::SocketCon, "DELE " + cPath + ::cCRLF ) + hb_inetClose( ::SocketCon ) - RETURN ::GetReply() + ::SocketCon := ::SocketControl + ::bInitialized := .F. + + // error code? + RETURN ::GetReply() .AND. ! hb_LeftEq( ::cReply, "5" ) // scan last reply for an hint of length METHOD ScanLength() CLASS TIPClientFTP @@ -329,18 +215,9 @@ METHOD TransferStart() CLASS TIPClientFTP ::InetTimeOut( skt ) - /* Set internal socket send buffer to 64k, - * this should fix the speed problems some users have reported - */ - IF ! Empty( ::nDefaultSndBuffSize ) - ::InetSndBufSize( skt, ::nDefaultSndBuffSize ) - ENDIF - - IF ! Empty( ::nDefaultRcvBuffSize ) - ::InetRcvBufSize( skt, ::nDefaultRcvBuffSize ) - ENDIF - ::SocketCon := skt + ELSE + RETURN .F. ENDIF ELSE ::SocketCon := hb_inetAccept( ::SocketPortServer ) @@ -350,50 +227,187 @@ METHOD TransferStart() CLASS TIPClientFTP ::GetReply() RETURN .F. ENDIF - hb_inetSetRcvBufSize( ::SocketCon, 65536 ) - hb_inetSetSndBufSize( ::SocketCon, 65536 ) + ENDIF + + /* Set internal socket send buffer to 64 KiB, this should + resolve the speed problems some users have reported */ + IF HB_ISNUMERIC( ::nDefaultSndBuffSize ) + ::InetSndBufSize( ::SocketCon, ::nDefaultSndBuffSize ) + ENDIF + IF HB_ISNUMERIC( ::nDefaultRcvBuffSize ) + ::InetRcvBufSize( ::SocketCon, ::nDefaultRcvBuffSize ) ENDIF RETURN .T. -METHOD Commit() CLASS TIPClientFTP +METHOD Pasv() CLASS TIPClientFTP - hb_inetClose( ::SocketCon ) + LOCAL aRep - ::SocketCon := ::SocketControl - ::bInitialized := .F. + ::inetSendAll( ::SocketCon, "PASV" + ::cCRLF ) IF ! ::GetReply() RETURN .F. ENDIF - // error code? - IF Left( ::cReply, 1 ) == "5" + IF Empty( aRep := hb_regex( ::RegPasv, ::cReply ) ) RETURN .F. ENDIF + ::cDataServer := aRep[ 2 ] + "." + aRep[ 3 ] + "." + aRep[ 4 ] + "." + aRep[ 5 ] + ::nDataPort := Val( aRep[ 6 ] ) * 256 + Val( aRep[ 7 ] ) + RETURN .T. +METHOD Quit() CLASS TIPClientFTP + + ::inetSendAll( ::SocketCon, "QUIT" + ::cCRLF ) + + RETURN ::GetReply() + +METHOD TypeI() CLASS TIPClientFTP + + ::inetSendAll( ::SocketCon, "TYPE I" + ::cCRLF ) + + RETURN ::GetReply() + +METHOD TypeA() CLASS TIPClientFTP + + ::inetSendAll( ::SocketCon, "TYPE A" + ::cCRLF ) + + RETURN ::GetReply() + +METHOD NoOp() CLASS TIPClientFTP + + ::inetSendAll( ::SocketCon, "NOOP" + ::cCRLF ) + + RETURN ::GetReply() + +METHOD Rest( nPos ) CLASS TIPClientFTP + + ::inetSendAll( ::SocketCon, "REST " + hb_ntos( Int( hb_defaultValue( nPos, 0 ) ) ) + ::cCRLF ) + + RETURN ::GetReply() + +METHOD PWD() CLASS TIPClientFTP + + ::inetSendAll( ::SocketCon, "PWD" + ::cCRLF ) + IF ::GetReply() + ::cReply := SubStr( ::cReply, At( '"', ::cReply ) + 1, ; + RAt( '"', ::cReply ) - At( '"', ::cReply ) - 1 ) + RETURN .T. + ENDIF + + RETURN .F. + +METHOD CWD( cPath ) CLASS TIPClientFTP + + ::inetSendAll( ::SocketCon, "CWD " + cPath + ::cCRLF ) + + RETURN ::GetReply() + +METHOD Dele( cPath ) CLASS TIPClientFTP + + ::inetSendAll( ::SocketCon, "DELE " + cPath + ::cCRLF ) + + RETURN ::GetReply() + +METHOD LS( cSpec ) CLASS TIPClientFTP + + IF ::bUsePasv .AND. ! ::Pasv() +#if 0 + ::bUsePasv := .F. +#endif + RETURN .F. + ENDIF + + IF ! ::bUsePasv .AND. ! ::Port() + RETURN .F. + ENDIF + + ::inetSendAll( ::SocketCon, "NLST " + hb_defaultValue( cSpec, "" ) + ::cCRLF ) + + RETURN hb_defaultValue( ::ReadAuxPort(), "" ) + +METHOD Rename( cFrom, cTo ) CLASS TIPClientFTP + + ::inetSendAll( ::SocketCon, "RNFR " + hb_defaultValue( cFrom, "" ) + ::cCRLF ) + IF ::GetReply() + ::inetSendAll( ::SocketCon, "RNTO " + hb_defaultValue( cTo, "" ) + ::cCRLF ) + RETURN ::GetReply() + ENDIF + + RETURN .F. + +// Create a new directory +METHOD MKD( cPath ) CLASS TIPClientFTP + + ::inetSendAll( ::SocketCon, "MKD " + cPath + ::cCRLF ) + + RETURN ::GetReply() + +// Delete an existing directory +METHOD RMD( cPath ) CLASS TIPClientFTP + + ::inetSendAll( ::SocketCon, "RMD " + cPath + ::cCRLF ) + + RETURN ::GetReply() + +METHOD Retr( cFile ) CLASS TIPClientFTP + + IF ::bUsePasv .AND. ! ::Pasv() +#if 0 + ::bUsePasv := .F. +#endif + RETURN .F. + ENDIF + + ::inetSendAll( ::SocketCon, "RETR " + cFile + ::cCRLF ) + + IF ::TransferStart() + ::ScanLength() + RETURN .T. + ENDIF + + RETURN .F. + +METHOD Stor( cFile ) CLASS TIPClientFTP + + IF ::bUsePasv .AND. ! ::Pasv() +#if 0 + ::bUsePasv := .F. +#endif + RETURN .F. + ENDIF + + ::inetSendAll( ::SocketCon, "STOR " + cFile + ::cCRLF ) + + /* It is important not to delete these lines in order not to disrupt the timing of + the responses, which can lead to failures in transfers. */ + IF ! ::bUsePasv + ::GetReply() + ENDIF + + RETURN ::TransferStart() + METHOD List( cSpec ) CLASS TIPClientFTP LOCAL cStr - IF cSpec == NIL - cSpec := "" - ELSE - cSpec := " " + cSpec + IF ::bUsePasv .AND. ! ::Pasv() +#if 0 + ::bUsePasv := .F. +#endif + RETURN NIL ENDIF - IF ::bUsePasv - IF ! ::Pasv() - // ::bUsePasv := .F. - RETURN NIL - ENDIF + IF ! ::bUsePasv .AND. ! ::Port() + RETURN NIL ENDIF - IF ! ::bUsePasv - IF ! ::Port() - RETURN NIL - ENDIF + hb_default( @cSpec, "" ) + + IF ! Empty( cSpec ) + cSpec := " " + cSpec ENDIF ::inetSendAll( ::SocketCon, "LIST" + cSpec + ::cCRLF ) @@ -404,119 +418,84 @@ METHOD List( cSpec ) CLASS TIPClientFTP METHOD UserCommand( cCommand, lPasv, lReadPort, lGetReply ) CLASS TIPClientFTP - hb_default( @cCommand, "" ) - hb_default( @lPasv, .T. ) - hb_default( @lReadPort, .T. ) - hb_default( @lGetReply, .F. ) - - IF ::bUsePasv .AND. lPasv .AND. ! ::Pasv() + IF ::bUsePasv .AND. hb_defaultValue( lPasv, .T. ) .AND. ! ::Pasv() RETURN .F. ENDIF - ::inetSendAll( ::SocketCon, cCommand ) + ::inetSendAll( ::SocketCon, hb_defaultValue( cCommand, "" ) ) - IF lReadPort - lReadPort := ::ReadAuxPort() + IF hb_defaultValue( lReadPort, .T. ) + lReadPort := ::ReadAuxPort() /* QUESTION: is this assignment intentional? */ ENDIF - IF lGetReply - lGetReply := ::GetReply() + IF hb_defaultValue( lGetReply, .F. ) + lGetReply := ::GetReply() /* QUESTION: is this assignment intentional? */ ENDIF RETURN .T. -METHOD ReadAuxPort( cLocalFile ) CLASS TIPClientFTP - - LOCAL cRet - LOCAL cList := "" - LOCAL nFile := 0 - - IF ! ::TransferStart() - RETURN NIL - ENDIF - IF ! Empty( cLocalFile ) - nFile := FCreate( cLocalFile ) - /* TOFIX: missing error checking on nFile */ - ENDIF - cRet := ::super:Read( 512 ) - DO WHILE cRet != NIL .AND. Len( cRet ) > 0 - IF nFile > 0 - FWrite( nFile, cRet ) - ELSE - cList += cRet - ENDIF - cRet := ::super:Read( 512 ) - ENDDO - - hb_inetClose( ::SocketCon ) - ::SocketCon := ::SocketControl - IF ::GetReply() - IF nFile > 0 - FClose( nFile ) - RETURN .T. - ENDIF - RETURN cList - ENDIF - - RETURN NIL - -METHOD Stor( cFile ) CLASS TIPClientFTP - - IF ::bUsePasv - IF ! ::Pasv() - // ::bUsePasv := .F. - RETURN .F. - ENDIF - ENDIF - - ::inetSendAll( ::SocketCon, "STOR " + cFile + ::cCRLF ) - - // It is important not to delete these lines in order not to disrupt the timing of - // the responses, which can lead to failures in transfers. - IF ! ::bUsePasv - ::GetReply() - ENDIF - - RETURN ::TransferStart() - METHOD Port() CLASS TIPClientFTP ::SocketPortServer := hb_inetCreate( ::nConnTimeout ) - s_nPort++ - DO WHILE s_nPort < 24000 + + hb_mutexLock( s_mutexPort ) + + DO WHILE ++s_nPort < _PORT_MAX hb_inetServer( s_nPort, ::SocketPortServer ) IF ::inetErrorCode( ::SocketPortServer ) == 0 + hb_mutexUnlock( s_mutexPort ) RETURN ::SendPort() ENDIF - s_nPort++ ENDDO + s_nPort := _PORT_MIN + + hb_mutexUnlock( s_mutexPort ) + RETURN .F. METHOD SendPort() CLASS TIPClientFTP - LOCAL cAddr - LOCAL cPort, nPort + LOCAL nPort := hb_inetPort( ::SocketPortServer ) - cAddr := StrTran( hb_inetGetHosts( NetName() )[ 1 ], ".", "," ) - nPort := hb_inetPort( ::SocketPortServer ) - cPort := "," + hb_ntos( Int( nPort / 256 ) ) + "," + hb_ntos( Int( nPort % 256 ) ) - - ::inetSendAll( ::SocketCon, "PORT " + cAddr + cPort + ::cCRLF ) + ::inetSendAll( ::SocketCon, "PORT " + ; + StrTran( hb_inetGetHosts( NetName() )[ 1 ], ".", "," ) + "," + ; + hb_ntos( Int( nPort / 256 ) ) + "," + hb_ntos( Int( nPort % 256 ) ) + ; + ::cCRLF ) RETURN ::GetReply() +METHOD ReadAuxPort() CLASS TIPClientFTP + + LOCAL cRet + LOCAL cList + + IF ::TransferStart() + + cList := "" + DO WHILE ( cRet := ::super:Read( 512 ) ) != NIL .AND. ! cRet == "" + cList += cRet + ENDDO + + hb_inetClose( ::SocketCon ) + ::SocketCon := ::SocketControl + + IF ::GetReply() + RETURN cList + ENDIF + ENDIF + + RETURN NIL + METHOD Read( nLen ) CLASS TIPClientFTP LOCAL cRet IF ! ::bInitialized - IF ! Empty( ::oUrl:cPath ) - IF ! ::CWD( ::oUrl:cPath ) - ::bEof := .T. // no data for this transaction - RETURN NIL - ENDIF + IF ! Empty( ::oUrl:cPath ) .AND. ! ::CWD( ::oUrl:cPath ) + ::bEof := .T. // no data for this transaction + RETURN NIL ENDIF IF Empty( ::oUrl:cFile ) @@ -532,9 +511,7 @@ METHOD Read( nLen ) CLASS TIPClientFTP ::bInitialized := .T. ENDIF - cRet := ::super:Read( nLen ) - - IF cRet == NIL + IF ( cRet := ::super:Read( nLen ) ) == NIL ::Commit() ::bEof := .T. ENDIF @@ -550,10 +527,8 @@ METHOD Write( cData, nLen ) CLASS TIPClientFTP RETURN -1 ENDIF - IF ! Empty( ::oUrl:cPath ) - IF ! ::CWD( ::oUrl:cPath ) - RETURN -1 - ENDIF + IF ! Empty( ::oUrl:cPath ) .AND. ! ::CWD( ::oUrl:cPath ) + RETURN -1 ENDIF IF ! ::Stor( ::oUrl:cFile ) @@ -566,83 +541,56 @@ METHOD Write( cData, nLen ) CLASS TIPClientFTP RETURN ::super:Write( cData, nLen, .F. ) -METHOD Retr( cFile ) CLASS TIPClientFTP - - IF ::bUsePasv - IF ! ::Pasv() - // ::bUsePasv := .F. - RETURN .F. - ENDIF - ENDIF - - ::inetSendAll( ::SocketCon, "RETR " + cFile + ::cCRLF ) - - IF ::TransferStart() - ::ScanLength() - RETURN .T. - ENDIF - - RETURN .F. - -METHOD MGET( cSpec, cLocalPath ) CLASS TIPClientFTP +METHOD MGet( cSpec, cLocalPath ) CLASS TIPClientFTP LOCAL cStr, cFile - hb_default( @cSpec, "" ) - hb_default( @cLocalPath, "" ) - - IF ::bUsePasv - IF ! ::Pasv() - // ::bUsePasv := .F. - RETURN .F. - ENDIF + IF ::bUsePasv .AND. ! ::Pasv() +#if 0 + ::bUsePasv := .F. +#endif + RETURN NIL ENDIF - ::inetSendAll( ::SocketCon, "NLST " + cSpec + ::cCRLF ) - cStr := ::ReadAuxPort() + hb_default( @cLocalPath, "" ) - IF ! Empty( cStr ) - FOR EACH cFile IN hb_ATokens( StrTran( cStr, Chr( 13 ) ), Chr( 10 ) ) - IF ! Empty( cFile ) - ::downloadfile( cLocalPath + RTrim( cFile ), RTrim( cFile ) ) + ::inetSendAll( ::SocketCon, "NLST " + hb_defaultValue( cSpec, "" ) + ::cCRLF ) + + IF ( cStr := ::ReadAuxPort() ) != NIL + FOR EACH cFile IN hb_ATokens( cStr, .T. ) + cFile := RTrim( cFile ) + IF ! cFile == "" + ::Downloadfile( cLocalPath + cFile, cFile ) ENDIF NEXT ENDIF RETURN cStr -METHOD MPUT( cFileSpec, cAttr ) CLASS TIPClientFTP +METHOD MPut( cFileSpec, cAttr ) CLASS TIPClientFTP - LOCAL cPath, cFile, cExt, aFile - LOCAL cStr := "" + LOCAL aFile + LOCAL cStr IF ! HB_ISSTRING( cFileSpec ) - RETURN 0 + RETURN NIL ENDIF - hb_FNameSplit( cFileSpec, @cPath, @cFile, @cExt ) - - FOR EACH aFile IN Directory( cPath + cFile + cExt, cAttr ) - IF ::uploadFile( cPath + aFile[ F_NAME ], aFile[ F_NAME ] ) - cStr += tip_CRLF() + aFile[ F_NAME ] + cStr := "" + FOR EACH aFile IN hb_vfDirectory( cFileSpec, cAttr ) + IF ::UploadFile( hb_FNameDir( cFileSpec ) + aFile[ F_NAME ] ) + cStr += e"\r\n" + aFile[ F_NAME ] ENDIF NEXT - RETURN SubStr( cStr, Len( tip_CRLF() ) + 1 ) + /* QUESTION: Shouldn't this return an array? + Why emulate a platform specific and ill-defined format? */ + RETURN SubStr( cStr, Len( e"\r\n" ) + 1 ) - -METHOD UpLoadFile( cLocalFile, cRemoteFile ) CLASS TIPClientFTP - - LOCAL cPath - LOCAL cFile - LOCAL cExt - - hb_FNameSplit( cLocalFile, @cPath, @cFile, @cExt ) - - hb_default( @cRemoteFile, cFile + cExt ) +METHOD UploadFile( cLocalFile, cRemoteFile ) CLASS TIPClientFTP ::bEof := .F. - ::oUrl:cFile := cRemoteFile + ::oUrl:cFile := hb_defaultValue( cRemoteFile, hb_FNameNameExt( cLocalFile ) ) IF ! ::bInitialized @@ -650,12 +598,8 @@ METHOD UpLoadFile( cLocalFile, cRemoteFile ) CLASS TIPClientFTP RETURN .F. ENDIF - IF ! Empty( ::oUrl:cPath ) - - IF ! ::CWD( ::oUrl:cPath ) - RETURN .F. - ENDIF - + IF ! Empty( ::oUrl:cPath ) .AND. ! ::CWD( ::oUrl:cPath ) + RETURN .F. ENDIF IF ! ::bUsePasv .AND. ! ::Port() @@ -672,56 +616,10 @@ METHOD UpLoadFile( cLocalFile, cRemoteFile ) CLASS TIPClientFTP RETURN ::WriteFromFile( cLocalFile ) -METHOD LS( cSpec ) CLASS TIPClientFTP - - LOCAL cStr - - hb_default( @cSpec, "" ) - - IF ::bUsePasv .AND. ! ::Pasv() - // ::bUsePasv := .F. - RETURN .F. - ENDIF - - IF ! ::bUsePasv .AND. ! ::Port() - RETURN .F. - ENDIF - - ::inetSendAll( ::SocketCon, "NLST " + cSpec + ::cCRLF ) - IF ::GetReply() - cStr := ::ReadAuxPort() - ELSE - cStr := "" - ENDIF - - RETURN cStr - -/* Rename a traves del ftp */ -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 cPath - LOCAL cFile - LOCAL cExt - - hb_FNameSplit( cLocalFile, @cPath, @cFile, @cExt ) - - hb_default( @cRemoteFile, cFile + cExt ) +METHOD DownloadFile( cLocalFile, cRemoteFile ) CLASS TIPClientFTP ::bEof := .F. - ::oUrl:cFile := cRemoteFile + ::oUrl:cFile := hb_defaultValue( cRemoteFile, hb_FNameNameExt( cLocalFile ) ) IF ! ::bInitialized @@ -745,25 +643,8 @@ METHOD DownLoadFile( cLocalFile, cRemoteFile ) CLASS TIPClientFTP 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() - - // Return total file size for -METHOD fileSize( cFileSpec ) CLASS TIPClientFTP +METHOD FileSize( cFileSpec ) CLASS TIPClientFTP LOCAL aFile LOCAL nSize := 0 @@ -774,93 +655,134 @@ METHOD fileSize( cFileSpec ) CLASS TIPClientFTP RETURN nSize +/* Listing formats (from libcurl) + https://github.com/curl/curl/blob/master/lib/ftplistparser.c + Unix version 1: drwxr-xr-x 1 user01 ftp 512 Jan 29 23:32 prog + Unix version 2: drwxr-xr-x 1 user01 ftp 512 Jan 29 1997 prog + Unix version 3: drwxr-xr-x 1 1 1 512 Jan 29 23:32 prog + Unix symlink : lrwxr-xr-x 1 user01 ftp 512 Jan 29 23:32 prog -> prog2000 + DOS style/IIS : 01-29-97 11:32PM prog + DOS style/IIS : 01-29-97 11:32PM 512 prog + DOS style/IIS : 01-29-2010 11:32PM prog + */ -// Parse the :list() string into a Directory() compatible 2-dim array -METHOD listFiles( cFileSpec ) CLASS TIPClientFTP +// Parse the :list() string into a hb_vfDirectory() 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 aList, aFile, cEntry, nStart, nEnd LOCAL cYear, cMonth, cDay, cTime - cList := ::list( cFileSpec ) + LOCAL cList := ::list( cFileSpec ) IF Empty( cList ) RETURN {} ENDIF - aList := hb_ATokens( StrTran( cList, Chr( 13 ) ), Chr( 10 ) ) + aList := hb_ATokens( cList, .T. ) FOR EACH cEntry IN aList DESCEND IF Empty( cEntry ) - hb_ADel( aList, cEntry:__enumIndex(), .T. ) - ELSE - - aFile := Array( F_LEN + 3 ) - nStart := 1 - nEnd := hb_At( " ", cEntry, nStart ) + aFile := Array( F_LEN + 3 ) + nStart := 1 + nEnd := hb_At( " ", cEntry, nStart ) // file permissions (attributes) aFile[ F_ATTR ] := SubStr( cEntry, nStart, nEnd - nStart ) nStart := nEnd - // # of links - DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " - ENDDO - nEnd := hb_At( " ", cEntry, nStart ) - aFile[ F_LEN + 1 ] := Val( SubStr( cEntry, nStart, nEnd - nStart ) ) - nStart := nEnd + IF Val( StrTran( aFile[ F_ATTR ], "-" ) ) == 0 - // owner name - DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " - ENDDO - nEnd := hb_At( " ", cEntry, nStart ) - aFile[ F_LEN + 2 ] := SubStr( cEntry, nStart, nEnd - nStart ) - nStart := nEnd + // continue with Unix format - // group name - DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " - ENDDO - nEnd := hb_At( " ", cEntry, nStart ) - aFile[ F_LEN + 3 ] := SubStr( cEntry, nStart, nEnd - nStart ) - nStart := nEnd + // # of links + DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " + ENDDO + nEnd := hb_At( " ", cEntry, nStart ) + aFile[ F_LEN + 1 ] := Val( SubStr( cEntry, nStart, nEnd - nStart ) ) + nStart := nEnd - // file size - DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " - ENDDO - nEnd := hb_At( " ", cEntry, nStart ) - aFile[ F_SIZE ] := Val( SubStr( cEntry, nStart, nEnd - nStart ) ) - nStart := nEnd + // owner name + DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " + ENDDO + nEnd := hb_At( " ", cEntry, nStart ) + aFile[ F_LEN + 2 ] := SubStr( cEntry, nStart, nEnd - nStart ) + nStart := nEnd - // Month - DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " - ENDDO - nEnd := hb_At( " ", cEntry, nStart ) - cMonth := SubStr( cEntry, nStart, nEnd - nStart ) - cMonth := PadL( hb_AScan( aMonth, cMonth, , , .T. ), 2, "0" ) - nStart := nEnd + // group name + DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " + ENDDO + nEnd := hb_At( " ", cEntry, nStart ) + aFile[ F_LEN + 3 ] := SubStr( cEntry, nStart, nEnd - nStart ) + nStart := nEnd - // Day - DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " - ENDDO - nEnd := hb_At( " ", cEntry, nStart ) - cDay := SubStr( cEntry, nStart, nEnd - nStart ) - nStart := nEnd + // file size + DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " + ENDDO + nEnd := hb_At( " ", cEntry, nStart ) + aFile[ F_SIZE ] := Val( SubStr( cEntry, nStart, nEnd - nStart ) ) + nStart := nEnd - // year - DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " - ENDDO - nEnd := hb_At( " ", cEntry, nStart ) - cYear := SubStr( cEntry, nStart, nEnd - nStart ) - nStart := nEnd + // Month + DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " + ENDDO + nEnd := hb_At( " ", cEntry, nStart ) + cMonth := StrZero( hb_AScan( aMonth, SubStr( cEntry, nStart, nEnd - nStart ), , , .T. ), 2 ) + nStart := nEnd + + // Day + DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " + ENDDO + nEnd := hb_At( " ", cEntry, nStart ) + cDay := SubStr( cEntry, nStart, nEnd - nStart ) + nStart := nEnd + + // Year + DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " + ENDDO + nEnd := hb_At( " ", cEntry, nStart ) + cYear := SubStr( cEntry, nStart, nEnd - nStart ) + nStart := nEnd + + IF ":" $ cYear + cTime := cYear + cYear := StrZero( Year( Date() ), 4 ) + ELSE + cTime := "" + ENDIF + + aFile[ F_DATE ] := hb_SToD( cYear + cMonth + cDay ) + aFile[ F_TIME ] := cTime - IF ":" $ cYear - cTime := cYear - cYear := Str( Year( Date() ), 4, 0 ) ELSE - cTime := "" + + // DOS style/IIS format + + aFile[ F_LEN + 1 ] := 0 + aFile[ F_LEN + 2 ] := aFile[ F_LEN + 3 ] := aFile[ F_ATTR ] := "" + + aFile[ F_DATE ] := hb_CToD( aFile[ F_ATTR ], "mm-dd-yy" ) + + // # time + DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " + ENDDO + nEnd := hb_At( " ", cEntry, nStart ) + cTime := SubStr( cEntry, nStart, nEnd - nStart ) + nStart := nEnd + + aFile[ F_TIME ] := Left( TString( Secs( Left( cTime, 5 ) ) + iif( Right( cTime, 2 ) == "PM", 43200, 0 ) ), 5 ) + + // file size + DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " + ENDDO + nEnd := hb_At( " ", cEntry, nStart ) + aFile[ F_SIZE ] := Val( SubStr( cEntry, nStart, nEnd - nStart ) ) + nStart := nEnd + ENDIF // file name @@ -868,13 +790,9 @@ METHOD listFiles( cFileSpec ) CLASS TIPClientFTP ENDDO aFile[ F_NAME ] := SubStr( cEntry, nStart ) - aFile[ F_DATE ] := hb_SToD( cYear + cMonth + cDay ) - aFile[ F_TIME ] := cTime - - aList[ cEntry:__enumIndex() ] := aFile + cEntry := aFile ENDIF - NEXT RETURN aList diff --git a/contrib/hbtip/hbtip.hbp b/contrib/hbtip/hbtip.hbp index 6de9c5bbf9..443e851911 100644 --- a/contrib/hbtip/hbtip.hbp +++ b/contrib/hbtip/hbtip.hbp @@ -6,15 +6,15 @@ -w3 -es2 -${hb_name}.hbx +-hbx=${hb_name}.hbx encurlc.c mime.c misc.c +base64u.prg cgi.prg client.prg -credent.prg encb64.prg encoder.prg encqp.prg @@ -23,8 +23,9 @@ ftpcli.prg httpcli.prg log.prg mail.prg +mailassy.prg +mailsend.prg popcli.prg -sendmail.prg sessid.prg smtpcli.prg thtml.prg diff --git a/contrib/hbtip/hbtip.hbx b/contrib/hbtip/hbtip.hbx index 32552be707..0fce18ba80 100644 --- a/contrib/hbtip/hbtip.hbx +++ b/contrib/hbtip/hbtip.hbx @@ -42,13 +42,14 @@ DYNAMIC TIPClientFTP DYNAMIC TIPClientHTTP DYNAMIC TIPClientPOP DYNAMIC TIPClientSMTP -DYNAMIC TIPCredentials DYNAMIC TIPEncoder DYNAMIC TIPEncoderBase64 DYNAMIC TIPEncoderQP DYNAMIC TIPEncoderUrl DYNAMIC TIPLog DYNAMIC TIPMail +DYNAMIC tip_base64DecodeUrl +DYNAMIC tip_base64EncodeUrl DYNAMIC tip_CheckSID DYNAMIC tip_CRLF DYNAMIC tip_DateToGMT @@ -61,6 +62,8 @@ DYNAMIC tip_GetRawEmail DYNAMIC tip_HtmlSpecialChars DYNAMIC tip_HtmlToStr DYNAMIC tip_JSONSpecialChars +DYNAMIC tip_MailAssemble +DYNAMIC tip_MailSend DYNAMIC tip_MimeType DYNAMIC tip_QPDecode DYNAMIC tip_QPEncode @@ -71,7 +74,6 @@ DYNAMIC tip_URLDecode DYNAMIC tip_URLEncode DYNAMIC TUrl DYNAMIC __tip_FAttrToUmask -DYNAMIC __tip_PStrCompI DYNAMIC __tip_SSLConnectFD #if defined( __HBEXTREQ__ ) .OR. defined( __HBEXTERN__HBTIP__REQUEST ) diff --git a/contrib/hbtip/httpcli.prg b/contrib/hbtip/httpcli.prg index 56b55ff267..d1ec18431b 100644 --- a/contrib/hbtip/httpcli.prg +++ b/contrib/hbtip/httpcli.prg @@ -48,7 +48,7 @@ #include "fileio.ch" -CREATE CLASS TIPClientHTTP FROM TIPClient +CREATE CLASS TIPClientHTTP INHERIT TIPClient VAR cMethod VAR nReplyCode @@ -132,58 +132,52 @@ METHOD Head( xPostData, cQuery ) CLASS TIPClientHTTP METHOD PostByVerb( xPostData, cQuery, cVerb ) CLASS TIPClientHTTP - LOCAL cData, nI, cTmp, y + LOCAL cData + LOCAL item - hb_default( @cVerb, "POST" ) - - IF HB_ISHASH( xPostData ) + DO CASE + CASE HB_ISHASH( xPostData ) cData := "" - y := Len( xPostData ) - FOR nI := 1 TO y - cTmp := tip_URLEncode( AllTrim( hb_CStr( hb_HKeyAt( xPostData, nI ) ) ) ) - cData += cTmp + "=" - cTmp := tip_URLEncode( hb_CStr( hb_HValueAt( xPostData, nI ) ) ) - cData += cTmp - IF nI != y + FOR EACH item IN xPostData + cData += ; + tip_URLEncode( AllTrim( hb_CStr( item:__enumKey() ) ) ) + "=" + ; + tip_URLEncode( hb_CStr( item ) ) + IF ! item:__enumIsLast() cData += "&" ENDIF NEXT - ELSEIF HB_ISARRAY( xPostData ) + CASE HB_ISARRAY( xPostData ) cData := "" - y := Len( xPostData ) - FOR nI := 1 TO y - cTmp := tip_URLEncode( AllTrim( hb_CStr( xPostData[ nI, 1 ] ) ) ) - cData += cTmp + "=" - cTmp := tip_URLEncode( hb_CStr( xPostData[ nI, 2 ] ) ) - cData += cTmp - IF nI != y + FOR EACH item IN xPostData + cData += ; + tip_URLEncode( AllTrim( hb_CStr( item[ 1 ] ) ) ) + "=" + ; + tip_URLEncode( hb_CStr( item[ 2 ] ) ) + IF ! item:__enumIsLast() cData += "&" ENDIF NEXT - ELSEIF HB_ISSTRING( xPostData ) + CASE HB_ISSTRING( xPostData ) cData := xPostData - ELSE + OTHERWISE RETURN .F. - ENDIF + ENDCASE IF ! HB_ISSTRING( cQuery ) cQuery := ::oUrl:BuildQuery() ENDIF - ::inetSendAll( ::SocketCon, cVerb + " " + cQuery + " HTTP/1.1" + ::cCRLF ) + ::inetSendAll( ::SocketCon, hb_defaultValue( cVerb, "POST" ) + " " + cQuery + " HTTP/1.1" + ::cCRLF ) + ::StandardFields() - IF ! "Content-Type" $ ::hFields - ::inetSendAll( ::SocketCon, e"Content-Type: application/x-www-form-urlencoded\r\n" ) + ::inetSendAll( ::SocketCon, "Content-Type: application/x-www-form-urlencoded" + ::cCRLF ) ENDIF - - ::inetSendAll( ::SocketCon, "Content-Length: " + ; - hb_ntos( Len( cData ) ) + ::cCRLF ) + ::inetSendAll( ::SocketCon, "Content-Length: " + hb_ntos( hb_BLen( cData ) ) + ::cCRLF ) // End of header ::inetSendAll( ::SocketCon, ::cCRLF ) - IF ::inetErrorCode( ::SocketCon ) == 0 + IF ::inetErrorCode( ::SocketCon ) == 0 ::inetSendAll( ::SocketCon, cData ) ::bInitialized := .T. RETURN ::ReadHeaders() @@ -193,8 +187,8 @@ METHOD PostByVerb( xPostData, cQuery, cVerb ) CLASS TIPClientHTTP METHOD StandardFields() CLASS TIPClientHTTP - LOCAL iCount LOCAL oEncoder, cCookies + LOCAL field ::inetSendAll( ::SocketCon, "Host: " + ::oUrl:cServer + ::cCRLF ) ::inetSendAll( ::SocketCon, "User-agent: " + ::cUserAgent + ::cCRLF ) @@ -203,11 +197,11 @@ METHOD StandardFields() CLASS TIPClientHTTP ENDIF // Perform a basic authentication request - IF ::cAuthMode == "Basic" .AND. !( "Authorization" $ ::hFields ) + IF ::cAuthMode == "Basic" .AND. ! "Authorization" $ ::hFields oEncoder := TIPEncoderBase64():New() oEncoder:bHttpExcept := .T. ::inetSendAll( ::SocketCon, "Authorization: Basic " + ; - oEncoder:Encode( ::oUrl:cUserID + ":" + ::oUrl:cPassword ) + ::cCRLF ) + oEncoder:Encode( ::oUrl:cUserID + ":" + ::oUrl:cPassword ) + ::cCRLF ) ENDIF // send cookies @@ -217,9 +211,8 @@ METHOD StandardFields() CLASS TIPClientHTTP ENDIF // Send optional Fields - FOR iCount := 1 TO Len( ::hFields ) - ::inetSendAll( ::SocketCon, hb_HKeyAt( ::hFields, iCount ) + ; - ": " + hb_HValueAt( ::hFields, iCount ) + ::cCRLF ) + FOR EACH field IN ::hFields + ::inetSendAll( ::SocketCon, field:__enumKey() + ": " + field + ::cCRLF ) NEXT RETURN .T. @@ -229,9 +222,8 @@ METHOD ReadHeaders( lClear ) CLASS TIPClientHTTP LOCAL cLine, nPos, aVersion LOCAL aHead - // Now reads the fields and set the content lenght - cLine := ::inetRecvLine( ::SocketCon, @nPos, 500 ) - IF Empty( cLine ) + // Now reads the fields and set the content length + IF ( cLine := hb_defaultValue( ::inetRecvLine( ::SocketCon, @nPos, 500 ), "" ) ) == "" // In case of timeout or error on receiving RETURN .F. ENDIF @@ -254,13 +246,13 @@ METHOD ReadHeaders( lClear ) CLASS TIPClientHTTP ::nLength := -1 ::bChunked := .F. - cLine := ::inetRecvLine( ::SocketCon, @nPos, 500 ) - IF lClear != NIL .AND. lClear .AND. ! Empty( ::hHeaders ) + IF hb_defaultValue( lClear, .F. ) .AND. ! Empty( ::hHeaders ) ::hHeaders := { => } ENDIF - DO WHILE ::inetErrorCode( ::SocketCon ) == 0 .AND. ! Empty( cLine ) - aHead := hb_regexSplit( ":", cLine,,, 1 ) - IF aHead == NIL .OR. Len( aHead ) != 2 + cLine := ::inetRecvLine( ::SocketCon, @nPos, 500 ) + DO WHILE ::inetErrorCode( ::SocketCon ) == 0 .AND. HB_ISSTRING( cLine ) .AND. ! cLine == "" + + IF Len( aHead := hb_regexSplit( ":", cLine,,, 1 ) ) != 2 cLine := ::inetRecvLine( ::SocketCon, @nPos, 500 ) LOOP ENDIF @@ -275,7 +267,7 @@ METHOD ReadHeaders( lClear ) CLASS TIPClientHTTP // as above CASE Lower( aHead[ 1 ] ) == "transfer-encoding" - IF At( "chunked", Lower( cLine ) ) > 0 + IF "chunked" $ Lower( cLine ) ::bChunked := .T. ::nLength := -1 ENDIF @@ -302,15 +294,16 @@ METHOD Read( nLen ) CLASS TIPClientHTTP ENDIF ENDIF - /* On HTTP/1.1 protocol, content lenght can be in hex format before each chunk. + /* On HTTP/1.1 protocol, content length can be in hex format before each chunk. The chunk header is read each time nLength is -1; While reading the chunk, - nLenght is set to nRead plus the expected chunk size. After reading the - chunk, the footer is discarded, and nLenght is reset to -1. - */ + nLength is set to nRead plus the expected chunk size. After reading the + chunk, the footer is discarded, and nLength is reset to -1. + */ IF ::nLength == -1 .AND. ::bChunked + cLine := ::inetRecvLine( ::SocketCon, @nPos, 1024 ) - IF Empty( cLine ) + IF ! HB_ISSTRING( cLine ) .OR. cLine == "" RETURN NIL ENDIF @@ -318,15 +311,11 @@ METHOD Read( nLen ) CLASS TIPClientHTTP IF cLine == "0" // read the footers. - cLine := ::inetRecvLine( ::SocketCon, @nPos, 1024 ) - DO WHILE ! Empty( cLine ) + DO WHILE ! ( cLine := hb_defaultValue( ::inetRecvLine( ::SocketCon, @nPos, 1024 ), "" ) ) == "" // add Headers to footers - aHead := hb_regexSplit( ":", cLine,,, 1 ) - IF aHead != NIL + IF Len( aHead := hb_regexSplit( ":", cLine,,, 1 ) ) == 2 ::hHeaders[ aHead[ 1 ] ] := LTrim( aHead[ 2 ] ) ENDIF - - cLine := ::inetRecvLine( ::SocketCon, @nPos, 1024 ) ENDDO // we are done @@ -337,9 +326,8 @@ METHOD Read( nLen ) CLASS TIPClientHTTP // A normal chunk here // Remove the extensions - nPos := At( ";", cLine ) - IF nPos > 0 - cLine := SubStr( cLine, 1, nPos - 1 ) + IF ( nPos := At( ";", cLine ) ) > 0 + cLine := Left( cLine, nPos - 1 ) ENDIF // Convert to length @@ -356,7 +344,7 @@ METHOD Read( nLen ) CLASS TIPClientHTTP ::bEof := .F. ::nLength := -1 // chunked data is followed by a blank line - /* cLine := */ ::InetRecvLine( ::SocketCon, @nPos, 1024 ) + ::InetRecvLine( ::SocketCon, @nPos, 1024 ) ENDIF RETURN cData @@ -372,11 +360,9 @@ METHOD ReadAll() CLASS TIPClientHTTP ENDIF ENDIF IF ::bChunked - cChunk := ::read() - DO WHILE cChunk != NIL + DO WHILE ( cChunk := ::read() ) != NIL cOut += cChunk // ::nLength := -1 - cChunk := ::read() ENDDO ELSE RETURN ::read() @@ -384,213 +370,191 @@ METHOD ReadAll() CLASS TIPClientHTTP RETURN cOut -METHOD setCookie( cLine ) CLASS TIPClientHTTP +METHOD PROCEDURE setCookie( cLine ) CLASS TIPClientHTTP - // docs from http://www.ietf.org/rfc/rfc2109.txt - LOCAL aParam - LOCAL cHost, cPath, cName, cValue, aElements, cElement + // docs from https://www.ietf.org/rfc/rfc2109.txt + LOCAL cHost, cPath, cName, cValue, aElements LOCAL cDefaultHost := ::oUrl:cServer, cDefaultPath := ::oUrl:cPath - LOCAL x, y - IF Empty( cDefaultPath ) + LOCAL x + + IF cDefaultPath == "" cDefaultPath := "/" ENDIF + // this function currently ignores expires, secure and other tags that may be in the cookie for now... // ? "Setting COOKIE:", cLine - aParam := hb_regexSplit( ";", cLine ) cName := cValue := "" cHost := cDefaultHost cPath := cDefaultPath - y := Len( aParam ) - FOR x := 1 TO y - aElements := hb_regexSplit( "=", aParam[ x ], 1 ) - IF Len( aElements ) == 2 - IF x == 1 + FOR EACH x IN hb_regexSplit( ";", cLine ) + IF Len( aElements := hb_regexSplit( "=", x, 1 ) ) == 2 + IF x:__enumIsFirst() cName := AllTrim( aElements[ 1 ] ) cValue := AllTrim( aElements[ 2 ] ) ELSE - cElement := Upper( AllTrim( aElements[ 1 ] ) ) - DO CASE + SWITCH Upper( AllTrim( aElements[ 1 ] ) ) #if 0 - CASE cElement == "EXPIRES" + CASE "EXPIRES" + EXIT #endif - CASE cElement == "PATH" + CASE "PATH" cPath := AllTrim( aElements[ 2 ] ) - CASE cElement == "DOMAIN" + EXIT + CASE "DOMAIN" cHost := AllTrim( aElements[ 2 ] ) - ENDCASE + EXIT + ENDSWITCH ENDIF ENDIF NEXT IF ! Empty( cName ) // cookies are stored in hashes as host.path.name // check if we have a host hash yet - IF ! hb_HHasKey( ::hCookies, cHost ) + IF ! cHost $ ::hCookies ::hCookies[ cHost ] := { => } ENDIF - IF ! hb_HHasKey( ::hCookies[ cHost ], cPath ) + IF ! cPath $ ::hCookies[ cHost ] ::hCookies[ cHost ][ cPath ] := { => } ENDIF ::hCookies[ cHost ][ cPath ][ cName ] := cValue ENDIF - RETURN NIL + RETURN METHOD getcookies( cHost, cPath ) CLASS TIPClientHTTP - LOCAL x, y, aDomKeys := {}, aKeys, z, cKey, aPathKeys, nPath - LOCAL a, b, cOut := "", c, d + LOCAL x, aDomKeys := {}, z, cKey, aPathKeys, nPath + LOCAL a, cOut := "", c hb_default( @cHost, ::oUrl:cServer ) - IF cPath == NIL + IF ! HB_ISSTRING( cPath ) cPath := ::oUrl:cPath - IF Empty( cPath ) + IF cPath == "" cPath := "/" ENDIF ENDIF - IF Empty( cHost ) + IF cHost == "" RETURN cOut ENDIF // tail matching the domain - aKeys := hb_HKeys( ::hCookies ) - y := Len( aKeys ) z := Len( cHost ) cHost := Upper( cHost ) - FOR x := 1 TO y - cKey := Upper( aKeys[ x ] ) - IF Upper( Right( cKey, z ) ) == cHost .AND. ( Len( cKey ) == z .OR. SubStr( aKeys[ x ], 0 - z, 1 ) == "." ) - AAdd( aDomKeys, aKeys[ x ] ) + FOR EACH x IN hb_HKeys( ::hCookies ) + IF Upper( Right( x, z ) ) == cHost .AND. ( Len( x ) == z .OR. SubStr( x, -z, 1 ) == "." ) + AAdd( aDomKeys, x ) ENDIF NEXT - // more specific paths should be sent before lesser generic paths. - ASort( aDomKeys,,, {| cX, cY | Len( cX ) > Len( cY ) } ) - y := Len( aDomKeys ) - // now that we have the domain matches we have to do path matchine + + // now that we have the domain matches we have to do path matching nPath := Len( cPath ) - FOR x := 1 TO y - aKeys := hb_HKeys( ::hCookies[ aDomKeys[ x ] ] ) + FOR EACH x IN ASort( aDomKeys,,, {| cX, cY | Len( cX ) > Len( cY ) } ) // more specific paths should be sent before lesser generic paths aPathKeys := {} - b := Len( aKeys ) - FOR a := 1 TO b - cKey := aKeys[ a ] - z := Len( cKey ) - IF cKey == "/" .OR. ( z <= nPath .AND. SubStr( cKey, 1, nPath ) == cKey ) - AAdd( aPathKeys, aKeys[ a ] ) + FOR EACH cKey IN hb_HKeys( ::hCookies[ x ] ) + IF cKey == "/" .OR. ( Len( cKey ) <= nPath .AND. Left( cKey, nPath ) == cKey ) + AAdd( aPathKeys, cKey ) ENDIF NEXT - ASort( aPathKeys,,, {| cX, cY | Len( cX ) > Len( cY ) } ) - b := Len( aPathKeys ) - FOR a := 1 TO b - aKeys := hb_HKeys( ::hCookies[ aDomKeys[ x ] ][ aPathKeys[ a ] ] ) - d := Len( aKeys ) - FOR c := 1 TO d - IF ! Empty( cOut ) + + FOR EACH a IN ASort( aPathKeys,,, {| cX, cY | Len( cX ) > Len( cY ) } ) + FOR EACH c IN hb_HKeys( ::hCookies[ x ][ a ] ) + IF ! cOut == "" cOut += "; " ENDIF - cOut += aKeys[ c ] + "=" + ::hCookies[ aDomKeys[ x ] ][ aPathKeys[ a ] ][ aKeys[ c ] ] + cOut += c + "=" + ::hCookies[ x ][ a ][ c ] NEXT NEXT NEXT RETURN cOut -METHOD Boundary( nType ) CLASS TIPClientHTTP - /* - nType: 0=as found as the separator in the stdin stream +/* nType: 0=as found as the separator in the stdin stream 1=as found as the last one in the stdin stream 2=as found in the CGI enviroment Examples: - -----------------------------41184676334 //in the body or stdin stream - -----------------------------41184676334-- //last one of the stdin stream - ---------------------------41184676334 //in the header or CGI envirnment - */ + 0: -----------------------------41184676334 // in the body or stdin stream + 1: -----------------------------41184676334-- // last one of the stdin stream + 2: ---------------------------41184676334 // in the header or CGI envirnment + */ +METHOD Boundary( nType ) CLASS TIPClientHTTP - LOCAL cBound := ::cBoundary - LOCAL i + IF ::cBoundary == NIL + ::cBoundary := Replicate( "-", 27 ) + StrZero( hb_randNum( 99999999999 ), 11, 0 ) + ENDIF hb_default( @nType, 0 ) - IF Empty( cBound ) - cBound := Replicate( "-", 27 ) + Space( 11 ) - FOR i := 28 TO 38 - cBound := Stuff( cBound, i, 1, Str( Int( hb_Random( 0, 9 ) ), 1, 0 ) ) - NEXT - ::cBoundary := cBound - ENDIF - cBound := iif( nType < 2, "--", "" ) + cBound + iif( nType == 1, "--", "" ) - RETURN cBound + RETURN ; + iif( nType <= 1, "--", "" ) + ; + ::cBoundary + ; + iif( nType == 1, "--", "" ) -METHOD Attach( cName, cFileName, cType ) CLASS TIPClientHTTP +METHOD PROCEDURE Attach( cName, cFileName, cType ) CLASS TIPClientHTTP AAdd( ::aAttachments, { cName, cFileName, cType } ) - RETURN NIL + RETURN +/* https://tools.ietf.org/html/rfc2388 */ METHOD PostMultiPart( xPostData, cQuery ) CLASS TIPClientHTTP - LOCAL cData := "", nI, cTmp, y, cBound := ::boundary() - LOCAL cCrlf := ::cCRlf, oSub - LOCAL nPos - LOCAL cFilePath, cName, cFile, cType - LOCAL nFile, cBuf, nBuf, nRead + LOCAL cData := "", item, cBound := ::boundary() + LOCAL cCrlf := ::cCRlf, aAttachment + LOCAL cFile, cType + LOCAL hFile, cBuffer, nRead - IF Empty( xPostData ) - ELSEIF HB_ISHASH( xPostData ) - y := Len( xPostData ) - FOR nI := 1 TO y - cTmp := tip_URLEncode( AllTrim( hb_CStr( hb_HKeyAt( xPostData, nI ) ) ) ) - cData += cBound + cCrlf + 'Content-Disposition: form-data; name="' + cTmp + '"' + cCrlf + cCrLf - cTmp := tip_URLEncode( AllTrim( hb_CStr( hb_HValueAt( xPostData, nI ) ) ) ) - cData += cTmp + cCrLf + DO CASE + CASE Empty( xPostData ) + CASE HB_ISHASH( xPostData ) + FOR EACH item IN xPostData + cData += ; + cBound + cCrlf + "Content-Disposition: form-data; name=" + '"' + ; + tip_URLEncode( AllTrim( hb_CStr( item:__enumKey() ) ) ) + '"' + cCrlf + cCrLf + ; + tip_URLEncode( AllTrim( hb_CStr( item ) ) ) + cCrLf NEXT - ELSEIF HB_ISARRAY( xPostData ) - y := Len( xPostData ) - FOR nI := 1 TO y - cTmp := tip_URLEncode( AllTrim( hb_CStr( xPostData[ nI, 1 ] ) ) ) - cData += cBound + cCrlf + 'Content-Disposition: form-data; name="' + cTmp + '"' + cCrlf + cCrLf - cTmp := tip_URLEncode( AllTrim( hb_CStr( xPostData[ nI, 2 ] ) ) ) - cData += cTmp + cCrLf + CASE HB_ISARRAY( xPostData ) + FOR EACH item IN xPostData + IF Len( item ) >= 2 + cData += ; + cBound + cCrlf + "Content-Disposition: form-data; name=" + '"' + ; + tip_URLEncode( AllTrim( hb_CStr( item[ 1 ] ) ) ) + '"' + cCrlf + cCrLf + ; + tip_URLEncode( AllTrim( hb_CStr( item[ 2 ] ) ) ) + cCrLf + ENDIF NEXT - - ELSEIF HB_ISSTRING( xPostData ) + CASE HB_ISSTRING( xPostData ) cData := xPostData - ENDIF + ENDCASE - FOR EACH oSub IN ::aAttachments - cName := oSub[ 1 ] - cFile := oSub[ 2 ] - cType := oSub[ 3 ] - cTmp := StrTran( cFile, "/", "\" ) - IF ( nPos := RAt( "\", cTmp ) ) != 0 - cFilePath := Left( cTmp, nPos ) - ELSEIF ( nPos := RAt( ":", cTmp ) ) != 0 - cFilePath := Left( cTmp, nPos ) - ELSE - cFilePath := "" - ENDIF - cTmp := SubStr( cFile, Len( cFilePath ) + 1 ) - IF Empty( cType ) + FOR EACH aAttachment IN ::aAttachments + + cFile := hb_defaultValue( aAttachment[ 2 ], "" ) + + cType := aAttachment[ 3 ] + IF ! HB_ISSTRING( cType ) .OR. Empty( cType ) cType := "text/html" ENDIF - cData += cBound + cCrlf + 'Content-Disposition: form-data; name="' + cName + '"; filename="' + cTmp + '"' + cCrlf + 'Content-Type: ' + cType + cCrLf + cCrLf - // hope this is not a big file.... - nFile := FOpen( cFile ) - /* TOFIX: Error checking on nFile. [vszakats] */ - nBuf := 65536 - cBuf := Space( nBuf ) - DO WHILE ! hb_FEof( nFile ) - nRead := FRead( nFile, @cBuf, nBuf ) - IF nRead == nBuf - cData += cBuf - ELSE - cData += hb_BLeft( cBuf, nRead ) - ENDIF - ENDDO - FClose( nFile ) + + cData += cBound + cCrlf + ; + "Content-Disposition: form-data; " + ; + "name=" + '"' + hb_defaultValue( aAttachment[ 1 ], "unspecified" ) + '"' + "; " + ; + "filename=" + '"' + hb_FNameNameExt( hb_DirSepToOS( cFile ) ) + '"' + cCrlf + ; + "Content-Type: " + cType + cCrLf + ; + cCrLf + + IF ( hFile := hb_vfOpen( cFile, FO_READ ) ) != NIL + cBuffer := Space( 65536 ) + DO WHILE ( nRead := hb_vfRead( hFile, @cBuffer, hb_Blen( cBuffer ) ) ) > 0 + cData += hb_BLeft( cBuffer, nRead ) + ENDDO + hb_vfClose( hFile ) + ENDIF + cData += cCrlf NEXT + cData += cBound + "--" + cCrlf + IF ! HB_ISSTRING( cQuery ) cQuery := ::oUrl:BuildQuery() ENDIF @@ -599,10 +563,10 @@ METHOD PostMultiPart( xPostData, cQuery ) CLASS TIPClientHTTP ::StandardFields() IF ! "Content-Type" $ ::hFields - ::inetSendAll( ::SocketCon, e"Content-Type: multipart/form-data; boundary=" + ::boundary( 2 ) + ::cCrlf ) + ::inetSendAll( ::SocketCon, "Content-Type: multipart/form-data; boundary=" + ::boundary( 2 ) + ::cCrlf ) ENDIF - ::inetSendAll( ::SocketCon, "Content-Length: " + hb_ntos( Len( cData ) ) + ::cCRLF ) + ::inetSendAll( ::SocketCon, "Content-Length: " + hb_ntos( hb_BLen( cData ) ) + ::cCRLF ) // End of header ::inetSendAll( ::SocketCon, ::cCRLF ) @@ -616,15 +580,14 @@ METHOD PostMultiPart( xPostData, cQuery ) CLASS TIPClientHTTP METHOD WriteAll( cFile ) CLASS TIPClientHTTP - LOCAL nFile + LOCAL hFile LOCAL lSuccess - LOCAL cStream - IF ( nFile := FCreate( cFile ) ) != F_ERROR + IF ( hFile := hb_vfOpen( cFile, FO_CREAT + FO_TRUNC + FO_WRITE + FO_EXCLUSIVE ) ) != NIL cStream := ::ReadAll() - lSuccess := ( FWrite( nFile, cStream ) == hb_BLen( cStream ) ) - FClose( nFile ) + lSuccess := ( hb_vfWrite( hFile, cStream ) == hb_BLen( cStream ) ) + hb_vfClose( hFile ) ELSE lSuccess := .F. ENDIF diff --git a/contrib/hbtip/log.prg b/contrib/hbtip/log.prg index 792e21b3e7..4d3b9d378b 100644 --- a/contrib/hbtip/log.prg +++ b/contrib/hbtip/log.prg @@ -58,7 +58,7 @@ CREATE CLASS TIPLog PROTECTED: VAR cFileName - VAR fhnd INIT F_ERROR + VAR hFile INIT NIL ENDCLASS @@ -79,18 +79,18 @@ METHOD Add( cMsg ) CLASS TIPLog LOCAL cDir, cName, cExt LOCAL n - IF ::fhnd == F_ERROR + IF ::hFile == NIL hb_FNameSplit( ::cFileName, @cDir, @cName, @cExt ) n := 1 - DO WHILE ( ::fhnd := hb_FCreate( hb_FNameMerge( cDir, cName + "-" + hb_ntos( n++ ), cExt ),, FO_EXCL ) ) == F_ERROR .AND. ; - FError() != 3 /* path not found */ + DO WHILE ( ::hFile := hb_vfOpen( hb_FNameMerge( cDir, cName + "-" + hb_ntos( n++ ), cExt ), FO_CREAT + FO_EXCL + FO_WRITE ) ) == NIL .AND. ; + FError() != 3 /* path not found */ ENDDO ENDIF - IF ::fhnd != F_ERROR - RETURN FWrite( ::fhnd, cMsg ) == hb_BLen( cMsg ) + IF ::hFile != NIL + RETURN hb_vfWrite( ::hFile, cMsg ) == hb_BLen( cMsg ) ENDIF RETURN .F. @@ -99,13 +99,13 @@ METHOD Close() CLASS TIPLog LOCAL lRetVal - IF ::fhnd != F_ERROR - lRetVal := FClose( ::fhnd ) - ::fhnd := F_ERROR + IF ::hFile != NIL + lRetVal := hb_vfClose( ::hFile ) + ::hFile := NIL RETURN lRetVal ENDIF RETURN .F. METHOD Clear() CLASS TIPLog - RETURN ::Close() .AND. FErase( ::cFileName ) != F_ERROR + RETURN ::Close() .AND. hb_vfErase( ::cFileName ) != F_ERROR diff --git a/contrib/hbtip/mail.prg b/contrib/hbtip/mail.prg index ddc00c4fea..17c57067cf 100644 --- a/contrib/hbtip/mail.prg +++ b/contrib/hbtip/mail.prg @@ -2,6 +2,7 @@ * TIP Class oriented Internet protocol library * * Copyright 2003 Giancarlo Niccolai + * Copyright 2007 Hannes Ziegler (setHeader(), attachFile(), detachFile(), getFileName(), isMultiPart(), getMultiParts()) * * 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 @@ -44,15 +45,6 @@ * */ -/* 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" #include "fileio.ch" @@ -62,26 +54,21 @@ CREATE CLASS TIPMail // received fields may be more than once. VAR aReceived INIT {} - METHOD New( cBody, oEncoder ) CONSTRUCTOR + METHOD New( cBody, xEncoder ) CONSTRUCTOR METHOD SetBody( cBody ) METHOD GetBody() METHOD GetRawBody() INLINE ::cBody - METHOD SetEncoder( cEncoder ) + METHOD SetEncoder( xEncoder ) -#if 0 - METHOD FWrite( nFile ) - METHOD FRead( nFile ) - METHOD Send( sSocket ) - METHOD Recv( sSocket ) -#endif METHOD FromString( cMail, cBoundary, nPos ) + METHOD HeadersToString() METHOD ToString() METHOD GetFieldPart( cPart ) METHOD GetFieldOption( cPart, cOption ) METHOD SetFieldPart( cPart, cValue ) METHOD SetFieldOption( cPart, cOption, cValue ) - METHOD SetCharset( cCharset ) INLINE ::cCharset := iif( HB_ISSTRING( cCharset ), cCharset, "ISO-8859-1" ) + METHOD SetCharset( cCharset ) INLINE ::cCharset := hb_defaultValue( cCharset, "UTF-8" ) METHOD GetContentType() INLINE ::GetFieldPart( "Content-Type" ) METHOD GetCharEncoding() INLINE ::GetFieldOption( "Content-Type", "encoding" ) @@ -97,7 +84,7 @@ CREATE CLASS TIPMail METHOD isMultiPart() METHOD getMultiParts( aParts ) - METHOD setHeader( cSubject, cFrom, xTo, xCC, xBCC ) + METHOD setHeader( cSubject, cFrom, xTo, xCC ) METHOD attachFile( cFileName ) METHOD detachFile( cPath ) METHOD getFileName() @@ -113,113 +100,81 @@ CREATE CLASS TIPMail ENDCLASS -METHOD New( cBody, oEncoder ) CLASS TIPMail +METHOD New( cBody, xEncoder ) CLASS TIPMail - // Set header fileds to non-sensitive ::hHeaders := { => } + hb_HCaseMatch( ::hHeaders, .F. ) ::aAttachments := {} - hb_HCaseMatch( ::hHeaders, .F. ) - - IF ValType( oEncoder ) $ "CO" - ::setEncoder( oEncoder ) - ENDIF - - IF cBody != NIL - ::setBody( cBody ) - ENDIF - + ::setEncoder( xEncoder ) + ::setBody( cBody ) ::SetCharset() RETURN Self -METHOD SetEncoder( cEncoder ) CLASS TIPMail +METHOD SetEncoder( xEncoder ) CLASS TIPMail - IF HB_ISSTRING( cEncoder ) - ::oEncoder := tip_GetEncoder( cEncoder ) - ELSE - ::oEncoder := cEncoder + ::oEncoder := iif( HB_ISSTRING( xEncoder ), tip_GetEncoder( xEncoder ), xEncoder ) + + IF HB_ISOBJECT( ::oEncoder ) + ::hHeaders[ "Content-Transfer-Encoding" ] := ::oEncoder:cName + RETURN .T. ENDIF - ::hHeaders[ "Content-Transfer-Encoding" ] := ::oEncoder:cName - RETURN .T. + RETURN .F. METHOD SetBody( cBody ) CLASS TIPMail - IF ::oEncoder != NIL + IF HB_ISOBJECT( ::oEncoder ) ::cBody := ::oEncoder:Encode( cBody ) ::hHeaders[ "Content-Transfer-Encoding" ] := ::oEncoder:cName - ::lBodyEncoded := .T. // GD needed to prevent an extra crlf from being appended - ELSE + ::lBodyEncoded := .T. // needed to prevent an extra CRLF from being appended [GD] + ELSEIF HB_ISSTRING( cBody ) .OR. cBody == NIL ::cBody := cBody ENDIF - // not needed - // ::hHeaders[ "Content-Length" ] := hb_ntos( Len( cBody ) ) RETURN .T. METHOD GetBody() CLASS TIPMail - - IF ::cBody == NIL - RETURN NIL - ELSEIF ::oEncoder != NIL - RETURN ::oEncoder:Decode( ::cBody ) - ENDIF - - RETURN ::cBody + RETURN iif( HB_ISOBJECT( ::oEncoder ), ::oEncoder:Decode( ::cBody ), ::cBody ) METHOD GetFieldPart( cPart ) CLASS TIPMail - LOCAL nPos, cEnc + LOCAL nPos + LOCAL cEnc - nPos := hb_HPos( ::hHeaders, cPart ) - IF nPos == 0 - RETURN "" - ELSE - cEnc := hb_HValueAt( ::hHeaders, nPos ) - nPos := At( ";", cEnc ) - IF nPos != 0 - cEnc := SubStr( cEnc, 1, nPos - 1 ) + IF hb_HGetRef( ::hHeaders, cPart, @cEnc ) + IF ( nPos := At( ";", cEnc ) ) > 0 + cEnc := Left( cEnc, nPos - 1 ) ENDIF + RETURN cEnc ENDIF - RETURN cEnc + RETURN "" METHOD GetFieldOption( cPart, cOption ) CLASS TIPMail - LOCAL nPos, aMatch + LOCAL aMatch LOCAL cEnc - nPos := hb_HPos( ::hHeaders, cPart ) - IF nPos == 0 - RETURN "" - ELSE - cEnc := hb_HValueAt( ::hHeaders, nPos ) - // Case insensitive check - aMatch := hb_regex( ";\s*" + cOption + "\s*=\s*([^;]*)", cEnc, .F. ) - IF ! Empty( aMatch ) - cEnc := aMatch[ 2 ] - ELSE - RETURN "" - ENDIF + IF hb_HGetRef( ::hHeaders, cPart, @cEnc ) .AND. ; + ! Empty( aMatch := hb_regex( ";\s*" + cOption + "\s*=\s*([^;]*)", cEnc, .F. /* Case insensitive */ ) ) + RETURN aMatch[ 2 ] ENDIF - RETURN cEnc + RETURN "" METHOD SetFieldPart( cPart, cValue ) CLASS TIPMail - LOCAL nPos, cEnc + LOCAL nPos + LOCAL cEnc - nPos := hb_HPos( ::hHeaders, cPart ) - IF nPos == 0 - ::hHeaders[ cPart ] := cValue - ELSE - cEnc := hb_HValueAt( ::hHeaders, nPos ) - nPos := At( ";", cEnc ) - IF nPos == 0 - ::hHeaders[ cPart ] := cValue - ELSE + IF HB_ISSTRING( cValue ) .AND. ! Empty( cValue ) + IF hb_HGetRef( ::hHeaders, cPart, @cEnc ) .AND. ; + ( nPos := At( ";", cEnc ) ) > 0 ::hHeaders[ cPart ] := cValue + SubStr( cEnc, nPos ) + ELSE + ::hHeaders[ cPart ] := cValue ENDIF ENDIF @@ -227,30 +182,29 @@ METHOD SetFieldPart( cPart, cValue ) CLASS TIPMail METHOD SetFieldOption( cPart, cOption, cValue ) CLASS TIPMail - LOCAL nPos, aMatch - LOCAL cEnc + LOCAL aMatch + + IF HB_ISSTRING( cPart ) .AND. cPart $ ::hHeaders .AND. ; + HB_ISSTRING( cOption ) .AND. ! Empty( cOption ) + + aMatch := hb_regex( "(.*?;\s*)" + cOption + "\s*=[^;]*(.*)?", ::hHeaders[ cPart ], .F. ) - nPos := hb_HPos( ::hHeaders, cPart ) - IF nPos == 0 - RETURN .F. - ELSE - cEnc := hb_HValueAt( ::hHeaders, nPos ) - aMatch := hb_regex( "(.*?;\s*)" + cOption + "\s*=[^;]*(.*)?", cEnc, .F. ) IF Empty( aMatch ) - ::hHeaders[ cPart ] := cEnc += "; " + cOption + '="' + cValue + '"' + ::hHeaders[ cPart ] += "; " + cOption + "=" + '"' + cValue + '"' ELSE - ::hHeaders[ cPart ] := aMatch[ 2 ] + cOption + '="' + ; - cValue + '"' + aMatch[ 3 ] + ::hHeaders[ cPart ] := aMatch[ 2 ] + cOption + "=" + '"' + cValue + '"' + aMatch[ 3 ] ENDIF + + RETURN .T. ENDIF - RETURN .T. + RETURN .F. METHOD Attach( oSubPart ) CLASS TIPMail IF HB_ISOBJECT( oSubPart ) .AND. oSubPart:ClassName() == "TIPMAIL" // reset wrong content-type - IF At( "multipart/", Lower( ::GetFieldPart( "Content-Type" ) ) ) == 0 + IF ! ::isMultiPart() ::hHeaders[ "Content-Type" ] := "multipart/mixed" ENDIF @@ -264,11 +218,9 @@ METHOD NextAttachment() CLASS TIPMail IF ::nAttachPos > Len( ::aAttachments ) RETURN NIL - ELSE - ::nAttachPos++ ENDIF - RETURN ::aAttachments[ ::nAttachPos - 1 ] + RETURN ::aAttachments[ ::nAttachPos++ ] METHOD GetAttachment() CLASS TIPMail @@ -278,19 +230,60 @@ METHOD GetAttachment() CLASS TIPMail RETURN ::aAttachments[ ::nAttachPos ] -METHOD ToString() CLASS TIPMail +METHOD HeadersToString() CLASS TIPMail - LOCAL cBoundary, cElem, i LOCAL cRet := "" + LOCAL cElem, i - // this is a multipart message; we need a boundary - IF Len( ::aAttachments ) > 0 - ::hHeaders[ "Mime-Version" ] := "1.0" + // Begin output the fields, presenting them in a "well-known" order + FOR EACH cElem IN { "Return-Path", "Delivered-To" } + IF cElem $ ::hHeaders + cRet += cElem + ": " + ::hHeaders[ cElem ] + e"\r\n" + ENDIF + NEXT + + FOR EACH cElem IN ::aReceived + cRet += "Received: " + cElem + e"\r\n" + NEXT + + FOR EACH cElem IN { "Date", "From", "To", "Subject" } + IF cElem $ ::hHeaders + cRet += cElem + ": " + ::hHeaders[ cElem ] + e"\r\n" + ENDIF + NEXT + + IF ! Empty( ::aAttachments ) + cRet += "Mime-Version: " + ::hHeaders[ "Mime-Version" ] + e"\r\n" ENDIF - IF Len( ::aAttachments ) > 0 + FOR EACH i IN ::hHeaders + SWITCH Lower( cElem := i:__enumKey() ) + CASE "return-path" + CASE "delivered-to" + CASE "date" + CASE "from" + CASE "to" + CASE "subject" + CASE "mime-version" + EXIT + OTHERWISE + cRet += cElem + ": " + i + e"\r\n" + ENDSWITCH + NEXT + + RETURN cRet + +METHOD ToString() CLASS TIPMail + + LOCAL cBoundary, i + LOCAL cRet + + // this is a multipart message; we need a boundary + IF ! Empty( ::aAttachments ) + ::hHeaders[ "Mime-Version" ] := "1.0" + // reset failing content type - IF At( "multipart/", Lower( ::GetFieldPart( "Content-Type" ) ) ) == 0 + IF ! ::isMultiPart() ::hHeaders[ "Content-Type" ] := "multipart/mixed" ENDIF @@ -299,77 +292,35 @@ METHOD ToString() CLASS TIPMail IF Empty( cBoundary ) cBoundary := ::MakeBoundary() IF ! ::SetFieldOption( "Content-Type", "Boundary", cBoundary ) - ::hHeaders[ "Content-Type" ] := ; - 'multipart/mixed; boundary="' + cBoundary + '"' + ::hHeaders[ "Content-Type" ] := "multipart/mixed; boundary=" + '"' + cBoundary + '"' ENDIF ENDIF ENDIF - // Begin output the fields - // Presenting them in a "well-known" order - IF "Return-Path" $ ::hHeaders - cRet += "Return-Path: " + ::hHeaders[ "Return-Path" ] + e"\r\n" - ENDIF - IF "Delivered-To" $ ::hHeaders - cRet += "Delivered-To: " + ::hHeaders[ "Delivered-To" ] + e"\r\n" - ENDIF - FOR EACH cElem IN ::aReceived - cRet += "Received: " + cElem + e"\r\n" - NEXT - IF "Date" $ ::hHeaders - cRet += "Date: " + ::hHeaders[ "Date" ] + e"\r\n" - ENDIF - IF "From" $ ::hHeaders - cRet += "From: " + ::hHeaders[ "From" ] + e"\r\n" - ENDIF - IF "To" $ ::hHeaders - cRet += "To: " + ::hHeaders[ "To" ] + e"\r\n" - ENDIF - IF "Subject" $ ::hHeaders - cRet += "Subject: " + ::hHeaders[ "Subject" ] + e"\r\n" - ENDIF - IF Len( ::aAttachments ) > 0 - cRet += "Mime-Version:" + ::hHeaders[ "Mime-Version" ] + e"\r\n" - ENDIF - - FOR i := 1 TO Len( ::hHeaders ) - cElem := Lower( hb_HKeyAt( ::hHeaders, i ) ) - IF !( cElem == "return-path" ) .AND. ; - !( cElem == "delivered-to" ) .AND. ; - !( cElem == "date" ) .AND. ; - !( cElem == "from" ) .AND. ; - !( cElem == "to" ) .AND. ; - !( cElem == "subject" ) .AND. ; - !( cElem == "mime-version" ) - cRet += ; - hb_HKeyAt( ::hHeaders, i ) + ": " + ; - hb_HValueAt( ::hHeaders, i ) + e"\r\n" - ENDIF - NEXT - - // end of Header - cRet += e"\r\n" + // Header + cRet := ::HeadersToString() + e"\r\n" // Body - IF ! Empty( ::cBody ) + IF ::cBody != NIL .AND. ! ::cBody == "" IF Empty( ::aAttachments ) - // cRet += ::cBody + iif( lAttachment, "", e"\r\n" ) cRet += ::cBody + iif( ::lBodyEncoded, "", e"\r\n" ) ELSE - // GD - if there are attachements the body of the message has to be treated as an attachment. - cRet += "--" + cBoundary + e"\r\n" - cRet += "Content-Type: text/plain; charset=" + ::cCharset + "; format=flowed" + e"\r\n" - cRet += "Content-Transfer-Encoding: 7bit" + e"\r\n" - cRet += "Content-Disposition: inline" + e"\r\n" + e"\r\n" - cRet += ::cBody + e"\r\n" + // if there are attachements, the body of the message has to be treated as an attachment. [GD] + cRet += ; + "--" + cBoundary + e"\r\n" + ; + "Content-Disposition: inline" + e"\r\n" + ; + "Content-Type: text/plain; charset=" + ::cCharset + "; format=flowed" + e"\r\n" + ; + "Content-Transfer-Encoding: 7bit" + e"\r\n" + ; + e"\r\n" + ; + ::cBody + ; + e"\r\n" ENDIF ENDIF IF ! Empty( ::aAttachments ) - // Eventually go with mime multipart - FOR i := 1 TO Len( ::aAttachments ) - cRet += "--" + cBoundary + e"\r\n" - cRet += ::aAttachments[ i ]:ToString() + // Eventually go with MIME multipart + FOR EACH i IN ::aAttachments + cRet += "--" + cBoundary + e"\r\n" + i:ToString() + e"\r\n" NEXT cRet += "--" + cBoundary + "--" + e"\r\n" ENDIF @@ -382,6 +333,10 @@ METHOD FromString( cMail, cBoundary, nPos ) CLASS TIPMail LOCAL nLinePos, nSplitPos, nBodyPos LOCAL cValue, cLastField + IF ! HB_ISSTRING( cMail ) + RETURN 0 + ENDIF + IF Len( ::aAttachments ) > 0 ::aAttachments := {} ENDIF @@ -398,11 +353,11 @@ METHOD FromString( cMail, cBoundary, nPos ) CLASS TIPMail // Part 1: parsing header hb_default( @nPos, 1 ) - nLinePos := hb_At( e"\r\n", cMail, nPos ) - DO WHILE nLinePos > nPos + DO WHILE ( nLinePos := hb_At( e"\r\n", cMail, nPos ) ) > nPos // going on with last field? - IF ( SubStr( cMail, nPos, 1 ) == " " .OR. SubStr( cMail, nPos, 1 ) == e"\t" ); - .AND. cLastField != NIL + IF ( SubStr( cMail, nPos, 1 ) == " " .OR. SubStr( cMail, nPos, 1 ) == e"\t" ) .AND. ; + cLastField != NIL + cValue := LTrim( SubStr( cMail, nPos, nLinePos - nPos ) ) IF Lower( cLastField ) == "received" ::aReceived[ Len( ::aReceived ) ] += " " + cValue @@ -421,51 +376,48 @@ METHOD FromString( cMail, cBoundary, nPos ) CLASS TIPMail ENDIF nPos := nLinePos + 2 - nLinePos := hb_At( e"\r\n", cMail, nPos ) + // Prevents malformed body to affect us - IF cBoundary != NIL .AND. hb_At( "--" + cBoundary, cMail, nPos ) == 1 + IF HB_ISSTRING( cBoundary ) .AND. hb_At( "--" + cBoundary, cMail, nPos ) == 1 RETURN 0 ENDIF ENDDO - // now we may have a body or a multipart message; multipart - // messages may also have a "fake" body, that is usually not - // displayed, between their headers and the first multipart - // boundary. + /* Now we may have a body or a multipart message; multipart + messages may also have a "fake" body, that is usually not + displayed, between their headers and the first multipart + boundary. */ IF "Content-Transfer-Encoding" $ ::hHeaders ::oEncoder := tip_GetEncoder( ::hHeaders[ "Content-Transfer-Encoding" ] ) ENDIF // se if we have subparts: - IF At( "multipart/", Lower( ::GetFieldPart( "Content-Type" ) ) ) > 0 + IF ::isMultiPart() cSubBoundary := ::GetFieldOption( "Content-Type", "Boundary" ) // strip " on boundary - IF Left( cSubBoundary, 1 ) == '"' + IF hb_LeftEq( cSubBoundary, '"' ) cSubBoundary := SubStr( cSubBoundary, 2, Len( cSubBoundary ) - 2 ) ENDIF ENDIF nPos := nLinePos + 2 nBodyPos := nPos - nLinePos := hb_At( e"\r\n", cMail, nPos ) - DO WHILE nLinePos >= nPos + DO WHILE ( nLinePos := hb_At( e"\r\n", cMail, nPos ) ) >= nPos // Avoid useless tests for empty lines IF nLinePos == nPos nPos += 2 - nLinePos := hb_At( e"\r\n", cMail, nPos ) LOOP ENDIF // have we met the boundary? - IF cBoundary != NIL .AND. hb_At( "--" + cBoundary, cMail, nPos ) == nPos + IF HB_ISSTRING( cBoundary ) .AND. hb_At( "--" + cBoundary, cMail, nPos ) == nPos EXIT ENDIF // Have we met a section? - IF cSubBoundary != NIL .AND. ; - hb_At( "--" + cSubBoundary, cMail, nPos ) == nPos + IF HB_ISSTRING( cSubBoundary ) .AND. hb_At( "--" + cSubBoundary, cMail, nPos ) == nPos // is it the last subsection? IF hb_At( "--", cMail, nPos + Len( cSubBoundary ) + 2, nLinePos ) > 0 @@ -490,17 +442,19 @@ METHOD FromString( cMail, cBoundary, nPos ) CLASS TIPMail ENDIF // I must stay on the boundary found by the subsection to // enter in this part of the loop again. - ELSE // nPos := nLinePos + 2 /* 2004-05-04 - Instead of testing every single line of mail until we find next boundary, if there is a boundary we jump to it immediatly, this saves thousands of EOL test and makes splitting of a string fast - */ - nPos := iif( ! Empty( cSubBoundary ), hb_At( "--" + cSubBoundary, cMail, nPos ), iif( ! Empty( cBoundary ), hb_At( "--" + cBoundary, cMail, nPos ), nLinePos + 2 ) ) + */ + nPos := ; + iif( Empty( cSubBoundary ), ; + iif( Empty( cBoundary ), ; + nLinePos + 2, ; + hb_At( "--" + cBoundary, cMail, nPos ) ), ; + hb_At( "--" + cSubBoundary, cMail, nPos ) ) ENDIF - - nLinePos := hb_At( e"\r\n", cMail, nPos ) ENDDO // set our body if needed @@ -511,66 +465,58 @@ METHOD FromString( cMail, cBoundary, nPos ) CLASS TIPMail RETURN nPos METHOD MakeBoundary() CLASS TIPMail + RETURN ; + "=_0" + ; + StrZero( hb_randNum( 9999999999 ), 10, 0 ) + ; + StrZero( hb_randNum( 9999999999 ), 10, 0 ) + ; + "_TIP_" + ; + hb_TToS( hb_DateTime() ) + +METHOD setHeader( cSubject, cFrom, xTo, xCC ) CLASS TIPMail + + LOCAL aTo, aCC + LOCAL cTo, cCC + + LOCAL cName + LOCAL cAddr - LOCAL cBound := "=_0" + Space( 17 ) LOCAL i - FOR i := 4 TO 20 - cBound := Stuff( cBound, i, 1, Chr( hb_Random( 0, 25 ) + Asc( "A" ) ) ) - NEXT - - cBound += "_TIP_" + DToS( Date() ) + ; - "_" + StrTran( Time(), ":" ) - - RETURN cBound - -METHOD setHeader( cSubject, cFrom, xTo, xCC, xBCC ) CLASS TIPMail - - LOCAL aTo, aCC, aBCC, i, imax - LOCAL cTo, cCC, cBCC - - hb_default( @cSubject, "" ) - - IF ! HB_ISSTRING( cFrom ) + IF ! HB_ISSTRING( cFrom ) .OR. Empty( cFrom ) RETURN .F. ENDIF - IF HB_ISSTRING( xTo ) + DO CASE + CASE HB_ISSTRING( xTo ) aTo := { xTo } - ELSEIF HB_ISARRAY( xTo ) + CASE HB_ISARRAY( xTo ) aTo := xTo - ENDIF + ENDCASE IF Empty( aTO ) RETURN .F. ENDIF - IF HB_ISSTRING( xCC ) + DO CASE + CASE HB_ISSTRING( xCC ) aCC := { xCC } - ELSEIF HB_ISARRAY( xCC ) + CASE HB_ISARRAY( xCC ) aCC := xCC - ENDIF + ENDCASE - IF HB_ISSTRING( xBCC ) - aBCC := { xBCC } - ELSEIF HB_ISARRAY( xBCC ) - aBCC := xBCC - ENDIF - - IF ! ::setFieldPart( "Subject", WordEncodeQ( cSubject, ::cCharset ) ) - RETURN .F. - ENDIF - - IF ! ::setFieldPart( "From", LTrim( WordEncodeQ( tip_GetNameEmail( AllTrim( cFrom ) ), ::cCharset ) + " <" + tip_GetRawEmail( AllTrim( cFrom ) ) + ">" ) ) - RETURN .F. - ENDIF + ::setFieldPart( "Subject", WordEncodeQ( hb_defaultValue( cSubject, "" ), ::cCharset ) ) + ::setFieldPart( "From", LTrim( WordEncodeQ( tip_GetNameEmail( AllTrim( cFrom ) ), ::cCharset ) + " <" + tip_GetRawEmail( AllTrim( cFrom ) ) + ">" ) ) cTo := "" - imax := Len( aTO ) - FOR i := 1 TO imax - cTo += LTrim( WordEncodeQ( tip_GetNameEmail( AllTrim( aTo[ i ] ) ), ::cCharset ) + " <" + tip_GetRawEmail( AllTrim( aTo[ i ] ) ) + ">" ) - IF i < imax - cTo += "," + tip_CRLF() + " " + FOR EACH i IN aTo + IF ! Empty( i ) + IF ! Empty( cTo ) + cTo += "," + e"\r\n" + " " + ENDIF + i := AllTrim( i ) + cName := tip_GetNameEmail( i ) + cAddr := tip_GetRawEmail( i ) + cTo += iif( cName == cAddr, cAddr, LTrim( WordEncodeQ( cName, ::cCharset ) ) + " <" + cAddr + ">" ) ENDIF NEXT @@ -578,37 +524,24 @@ METHOD setHeader( cSubject, cFrom, xTo, xCC, xBCC ) CLASS TIPMail RETURN .F. ENDIF - IF ! ::setFieldPart( "To", cTo ) - RETURN .F. - ENDIF + ::setFieldPart( "To", cTo ) IF ! Empty( aCC ) cCC := "" - imax := Len( aCC ) - FOR i := 1 TO imax - cCC += LTrim( WordEncodeQ( tip_GetNameEmail( AllTrim( aCC[ i ] ) ), ::cCharset ) + " <" + tip_GetRawEmail( AllTrim( aCC[ i ] ) ) + ">" ) - IF i < imax - cCC += "," + tip_CRLF() + " " + FOR EACH i IN aCC + IF ! Empty( i ) + IF ! Empty( cCC ) + cCC += "," + e"\r\n" + " " + ENDIF + i := AllTrim( i ) + cName := tip_GetNameEmail( i ) + cAddr := tip_GetRawEmail( i ) + cCC += iif( cName == cAddr, cAddr, LTrim( WordEncodeQ( cName, ::cCharset ) ) + " <" + cAddr + ">" ) ENDIF NEXT - IF ! Empty( cCC ) .AND. ! ::setFieldPart( "Cc", cCC ) - RETURN .F. - ENDIF - ENDIF - - IF ! Empty( aBCC ) - cBCC := "" - imax := Len( aBCC ) - FOR i := 1 TO imax - cBCC += LTrim( WordEncodeQ( tip_GetNameEmail( AllTrim( aBCC[ i ] ) ), ::cCharset ) + " <" + tip_GetRawEmail( AllTrim( aBCC[ i ] ) ) + ">" ) - IF i < imax - cBCC += "," + tip_CRLF() + " " - ENDIF - NEXT - - IF ! Empty( cBCC ) .AND. ! ::setFieldPart( "Bcc", cBCC ) - RETURN .F. + IF ! Empty( cCC ) + ::setFieldPart( "Cc", cCC ) ENDIF ENDIF @@ -619,18 +552,22 @@ METHOD attachFile( cFileName ) CLASS TIPMail LOCAL cContent := hb_MemoRead( cFileName ) LOCAL cBaseName LOCAL oAttach + LOCAL nAttr - IF HB_ISNULL( cContent ) + IF cContent == "" RETURN .F. ENDIF oAttach := TIPMail():new( cContent, "base64" ) cBaseName := hb_FNameNameExt( cFileName ) - oAttach:setFieldPart( "Content-Type", tip_FileMimeType( cFileName ) ) - oAttach:setFieldOption( "Content-type", "name", cBaseName ) oAttach:setFieldPart( "Content-Disposition", "attachment" ) oAttach:setFieldOption( "Content-Disposition", "filename", cBaseName ) + oAttach:setFieldPart( "Content-Type", tip_FileMimeType( cFileName, "application/unknown" ) ) + oAttach:setFieldOption( "Content-Type", "name", cBaseName ) + IF hb_vfAttrGet( cFileName, @nAttr ) .AND. nAttr != 0 + oAttach:setFieldOption( "Content-Type", "x-unix-mode", hb_NumToHex( __tip_FAttrToUmask( nAttr ), 4 ) ) + ENDIF RETURN ::attach( oAttach ) @@ -639,7 +576,7 @@ METHOD detachFile( cPath ) CLASS TIPMail LOCAL cContent := ::getBody() LOCAL cFileName := ::getFileName() - IF HB_ISNULL( cFileName ) + IF cFileName == "" .OR. ::cBody == NIL RETURN .F. ENDIF @@ -679,44 +616,36 @@ METHOD getMultiParts( aParts ) CLASS TIPMail STATIC FUNCTION WordEncodeQ( cData, cCharset ) - LOCAL nPos LOCAL c LOCAL cString - LOCAL nLineLen := 0 LOCAL lToEncode := .F. - IF Empty( cCharset ) - RETURN cData + IF ! Empty( cCharset ) + + /* FIXME: Add support to handle long string. */ + + cString := "" + FOR EACH c IN cData /* FOR EACH on byte stream */ + IF hb_BCode( c ) > 126 .OR. ; + c $ '=?!"#$@[\]^`{|}~_' .OR. ; + hb_BCode( c ) <= 32 + cString += "=" + hb_NumToHex( hb_BCode( c ), 2 ) + lToEncode := .T. + ELSE + cString += c + ENDIF + NEXT ENDIF - /* TOFIX: Add support to handle long string. */ - - cString := "=?" + cCharset + "?" + "Q" + "?" - - FOR nPos := 1 TO hb_BLen( cData ) - c := hb_BSubStr( cData, nPos, 1 ) - IF hb_BCode( c ) > 126 .OR. ; - c $ '=?!"#$@[\]^`{|}~_' .OR. ; - hb_BCode( c ) <= 32 - cString += "=" + hb_NumToHex( hb_BCode( c ), 2 ) - nLineLen += 3 - lToEncode := .T. - ELSE - cString += c - nLineLen += 1 - ENDIF - NEXT - - RETURN iif( lToEncode, cString + "?=", cData ) + RETURN iif( lToEncode, "=?" + cCharset + "?Q?" + cString + "?=", cData ) FUNCTION tip_GetRawEmail( cAddress ) LOCAL tmp, tmp1 - IF ( tmp := At( "<", cAddress ) ) > 0 - IF ( tmp1 := hb_At( ">", cAddress, tmp + 1 ) ) > 0 - RETURN SubStr( cAddress, tmp + 1, tmp1 - tmp - 1 ) - ENDIF + IF ( tmp := At( "<", cAddress ) ) > 0 .AND. ; + ( tmp1 := hb_At( ">", cAddress, tmp + 1 ) ) > 0 + RETURN AllTrim( SubStr( cAddress, tmp + 1, tmp1 - tmp - 1 ) ) ENDIF RETURN cAddress @@ -725,10 +654,9 @@ FUNCTION tip_GetNameEmail( cAddress ) LOCAL tmp - IF ( tmp := At( "<", cAddress ) ) > 0 - IF hb_At( ">", cAddress, tmp + 1 ) > 0 - RETURN RTrim( Left( cAddress, tmp - 1 ) ) - ENDIF + IF ( tmp := At( "<", cAddress ) ) > 0 .AND. ; + hb_At( ">", cAddress, tmp + 1 ) > 0 + RETURN RTrim( Left( cAddress, tmp - 1 ) ) ENDIF RETURN cAddress diff --git a/contrib/hbtip/mailassy.prg b/contrib/hbtip/mailassy.prg new file mode 100644 index 0000000000..d83827cd60 --- /dev/null +++ b/contrib/hbtip/mailassy.prg @@ -0,0 +1,229 @@ +/* + * tip_MailAssemble() (This version started from Luiz's original work on SendMail()) + * + * Copyright 2007 Luiz Rafael Culik Guimaraes and Patrick Mast + * Copyright 2009 Viktor Szakats (vszakats.net/harbour) (SSL support) + * + * 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.txt. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site https://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. + * + */ + +#if defined( HB_LEGACY_LEVEL4 ) +FUNCTION hb_MailAssemble( ... ) + RETURN tip_MailAssemble( ... ) +#endif + +FUNCTION tip_MailAssemble( ; + cFrom, ; /* Required. Email address of the sender */ + xTo, ; /* Required. Character string or array of email addresses to send the email to */ + xCC, ; /* Optional. Character string or array of email addresses for CC (Carbon Copy) */ + cBody, ; /* Optional. The body message of the email as text, or the filename of the HTML message to send. */ + cSubject, ; /* Optional. Subject of the sending email */ + aFiles, ; /* Optional. Array of attachments to the email to send */ + nPriority, ; /* Optional. Email priority: 1=High, 3=Normal (Standard), 5=Low */ + lRead, ; /* Optional. If set to .T., a confirmation request is send. Standard setting is .F. */ + cReplyTo, ; /* Optional. */ + cCharset, ; /* Optional. */ + cEncoding, ; /* Optional. */ + lBodyHTML, ; /* Optional. */ + bSMIME ) /* Optional. S/MIME signing/encrypting callback */ + + LOCAL oMail + LOCAL oAttach + LOCAL aThisFile + LOCAL cMimeType + LOCAL cFile + LOCAL cData + LOCAL cContentType + LOCAL nAttr + + LOCAL cCharsetCP + LOCAL tmp + + IF Empty( cFrom ) .OR. ! HB_ISSTRING( cFrom ) + RETURN "" + ENDIF + IF Empty( xTo ) .OR. ( ! HB_ISSTRING( xTo ) .AND. ! HB_ISARRAY( xTo ) ) + RETURN "" + ENDIF + + hb_default( @cBody, "" ) + hb_default( @cSubject, "" ) + hb_default( @aFiles, {} ) + nPriority := Int( hb_defaultValue( nPriority, 3 ) ) + hb_default( @lRead, .F. ) + hb_default( @cReplyTo, "" ) + hb_default( @cCharset, "UTF-8" ) + hb_default( @cEncoding, "quoted-printable" ) + hb_default( @lBodyHTML, .F. ) + + /* Attempt to convert to selected charset if it's supported + by Harbour (and linked to app). */ + IF Upper( cCharset ) == "UTF-8" + cCharsetCP := "UTF8" + ELSEIF hb_cdpExists( Lower( cCharset ) ) + cCharsetCP := hb_cdpUniID( Lower( cCharset ) ) + ENDIF + + cContentType := iif( lBodyHTML, "text/html", "text/plain" ) + "; charset=" + cCharset + + /* add ending EOL to body, if there wasn't any */ + IF ! Right( cBody, 2 ) == Chr( 13 ) + Chr( 10 ) + cBody += Chr( 13 ) + Chr( 10 ) + ENDIF + + /* Convert input to the CP of the email */ + IF ! Empty( cCharsetCP ) + xTo := s_TransCP( xTo, cCharsetCP ) + xCC := s_TransCP( xCC, cCharsetCP ) + cFrom := s_TransCP( cFrom, cCharsetCP ) + cBody := s_TransCP( cBody, cCharsetCP ) + cSubject := s_TransCP( cSubject, cCharsetCP ) + ENDIF + + oMail := TIPMail():New() + oMail:SetEncoder( cEncoding ) + oMail:SetCharset( cCharset ) + IF Empty( aFiles ) + oMail:hHeaders[ "Content-Type" ] := cContentType + oMail:SetBody( cBody ) + ELSE + oAttach := TIPMail():New() + oAttach:SetEncoder( cEncoding ) + oAttach:SetCharset( cCharset ) + oAttach:hHeaders[ "Content-Type" ] := cContentType + oAttach:SetBody( cBody ) + oMail:Attach( oAttach ) + + FOR EACH aThisFile IN aFiles + + cMimeType := NIL + nAttr := 0 + + DO CASE + CASE HB_ISSTRING( aThisFile ) + cFile := aThisFile + cData := hb_MemoRead( cFile ) + hb_vfAttrGet( cFile, @nAttr ) + CASE HB_ISARRAY( aThisFile ) .AND. Len( aThisFile ) >= 2 + cFile := aThisFile[ 1 ] + IF HB_ISSTRING( aThisFile[ 2 ] ) + cData := aThisFile[ 2 ] + hb_default( @cFile, "unnamed" ) + ELSEIF HB_ISSTRING( cFile ) + cData := hb_MemoRead( cFile ) + hb_vfAttrGet( cFile, @nAttr ) + ELSE + LOOP /* No filename and no content. */ + ENDIF + IF Len( aThisFile ) >= 3 .AND. HB_ISSTRING( aThisFile[ 3 ] ) + cMimeType := aThisFile[ 3 ] + ENDIF + OTHERWISE + LOOP + ENDCASE + + IF cMimeType == NIL + cMimeType := tip_FileNameMimeType( cFile, "application/octet-stream" ) + ENDIF + cFile := s_TransCP( cFile, cCharsetCP ) + + oAttach := TIPMail():New() + oAttach:SetCharset( cCharset ) + oAttach:SetEncoder( iif( hb_LeftEq( cMimeType, "text/" ), cEncoding, "base64" ) ) + + IF cMimeType == "text/html" + cMimeType += "; charset=" + cCharset + IF ! Right( cData, 2 ) == Chr( 13 ) + Chr( 10 ) + cData += Chr( 13 ) + Chr( 10 ) + ENDIF + ENDIF + // Some email clients use Content-Type to check for filename + cMimeType += "; name=" + '"' + hb_FNameNameExt( cFile ) + '"' + IF ( nAttr := __tip_FAttrToUmask( nAttr ) ) != 0 + cMimeType += "; x-unix-mode=" + '"' + hb_NumToHex( nAttr, 4 ) + '"' + ENDIF + oAttach:hHeaders[ "Content-Type" ] := cMimeType + // Usually, original filename is set here + oAttach:hHeaders[ "Content-Disposition" ] := "attachment; filename=" + '"' + hb_FNameNameExt( cFile ) + '"' + oAttach:SetBody( cData ) + oMail:Attach( oAttach ) + NEXT + ENDIF + + IF HB_ISEVALITEM( bSMIME ) .AND. ; + HB_ISSTRING( tmp := Eval( bSMIME, oMail:ToString() ) ) + + oMail := TIPMail():New() + oMail:SetCharset( cCharset ) + ELSE + tmp := NIL + ENDIF + + oMail:SetHeader( cSubject, cFrom, xTo, xCC ) + oMail:hHeaders[ "Date" ] := tip_TimeStamp() + IF ! Empty( cReplyTo ) + oMail:hHeaders[ "Reply-to" ] := cReplyTo + ENDIF + IF lRead + oMail:hHeaders[ "Disposition-Notification-To" ] := tip_GetRawEmail( cFrom ) + ENDIF + IF nPriority != 3 + oMail:hHeaders[ "X-Priority" ] := hb_ntos( nPriority ) + ENDIF + + RETURN iif( HB_ISSTRING( tmp ), oMail:HeadersToString() + tmp, oMail:ToString() ) + +STATIC FUNCTION s_TransCP( xData, cCP ) + + LOCAL tmp + + IF ! Empty( cCP ) + DO CASE + CASE HB_ISSTRING( xData ) + RETURN hb_Translate( xData,, cCP ) + CASE HB_ISARRAY( xData ) + FOR EACH tmp IN xData + tmp := hb_Translate( tmp,, cCP ) + NEXT + ENDCASE + ENDIF + + RETURN xData diff --git a/contrib/hbtip/sendmail.prg b/contrib/hbtip/mailsend.prg similarity index 55% rename from contrib/hbtip/sendmail.prg rename to contrib/hbtip/mailsend.prg index 306101c55c..b22c1503a9 100644 --- a/contrib/hbtip/sendmail.prg +++ b/contrib/hbtip/mailsend.prg @@ -1,9 +1,9 @@ /* - * hb_SendMail() (This version of hb_SendMail() started from Luiz's original work on SendMail()) + * tip_MailSend() (This version started from Luiz's original work on SendMail()) * * Copyright 2007 Luiz Rafael Culik Guimaraes and Patrick Mast * Copyright 2009 Viktor Szakats (vszakats.net/harbour) (SSL support) - * Copyright 2015 Jean Lefebvre (TLS support) + * Copyright 2015 Jean Lefebvre (STARTTLS support) * * 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 @@ -46,12 +46,11 @@ * */ -#translate ( LIKE ) => ( hb_regexLike( (), () ) ) +#if defined( HB_LEGACY_LEVEL4 ) +FUNCTION hb_SendMail( ... ) + RETURN tip_MailSend( ... ) +#endif -FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ; - aFiles, cUser, cPass, cPopServer, nPriority, lRead, ; - xTrace, lPopAuth, lNoAuth, nTimeOut, cReplyTo, ; - lSSL, cSMTPPass, cCharset, cEncoding, cClientHost ) /* cServer -> Required. IP or domain name of the mail server nPort -> Optional. Port used my email server @@ -77,9 +76,14 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ; cSMTPPass -> Optional. cCharset -> Optional. cEncoding -> Optional. - cClientHost -> Optional. Domain name of the SMTP client in the format smtp.example.com OR client IP surrounded by brackets as in [200.100.100.5] + cClientHost -> Optional. Domain name of the SMTP client in the format smtp.example.net OR + client IP surrounded by brackets as [127.0.0.1] for IPv4 or as [ipv6:address] (f.e. '[ipv6:::1]') for IPv6 Note: This parameter is optional for backwards compatibility, but should be provided to comply with RFC 2812. -*/ + */ +FUNCTION tip_MailSend( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ; + aFiles, cUser, cPass, cPopServer, nPriority, lRead, ; + xTrace, lPopAuth, lNoAuth, nTimeOut, cReplyTo, ; + lSSL, cSMTPPass, cCharset, cEncoding, cClientHost ) LOCAL cTmp LOCAL cTo @@ -91,6 +95,7 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ; LOCAL oUrl LOCAL oUrl1 + LOCAL lBodyHTML LOCAL lAuthTLS := .F. LOCAL lConnect := .F. LOCAL oPop @@ -114,7 +119,8 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ; hb_default( @cSMTPPass, cPass ) // cTo - IF HB_ISARRAY( xTo ) + DO CASE + CASE HB_ISARRAY( xTo ) FOR tmp := Len( xTo ) TO 1 STEP -1 IF Empty( xTo[ tmp ] ) hb_ADel( xTo, tmp, .T. ) @@ -130,12 +136,13 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ; cTo += "," ENDIF NEXT - ELSEIF HB_ISSTRING( xTo ) + CASE HB_ISSTRING( xTo ) cTo := tip_GetRawEmail( AllTrim( xTo ) ) - ENDIF + ENDCASE // CC (Carbon Copy) - IF HB_ISARRAY( xCC ) + DO CASE + CASE HB_ISARRAY( xCC ) FOR tmp := Len( xCC ) TO 1 STEP -1 IF Empty( xCC[ tmp ] ) hb_ADel( xCC, tmp, .T. ) @@ -148,12 +155,13 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ; cCC += "," ENDIF NEXT - ELSEIF HB_ISSTRING( xCC ) + CASE HB_ISSTRING( xCC ) cCC := tip_GetRawEmail( AllTrim( xCC ) ) - ENDIF + ENDCASE // BCC (Blind Carbon Copy) - IF HB_ISARRAY( xBCC ) + DO CASE + CASE HB_ISARRAY( xBCC ) FOR tmp := Len( xBCC ) TO 1 STEP -1 IF Empty( xBCC[ tmp ] ) hb_ADel( xBCC, tmp, .T. ) @@ -166,9 +174,9 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ; cBCC += "," ENDIF NEXT - ELSEIF HB_ISSTRING( xBCC ) + CASE HB_ISSTRING( xBCC ) cBCC := tip_GetRawEmail( AllTrim( xBCC ) ) - ENDIF + ENDCASE cUser := StrTran( cUser, "@", "&at;" ) @@ -198,7 +206,10 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ; oUrl:nPort := nPort oUrl:cUserid := StrTran( cUser, "&at;", "@" ) - oUrl:cFile := cTo + iif( Empty( cCC ), "", "," + cCC ) + iif( Empty( cBCC ), "", "," + cBCC ) + oUrl:cFile := ; + cTo + ; + iif( Empty( cCC ), "", "," + cCC ) + ; + iif( Empty( cBCC ), "", "," + cBCC ) BEGIN SEQUENCE WITH __BreakBlock() oInmail := TIPClientSMTP():New( oUrl, xTrace,, cClientHost ) @@ -237,66 +248,11 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ; ENDIF ENDIF - oInMail:oUrl:cUserid := tip_GetRawEmail( cFrom ) - - oInMail:Write( hb_MailAssemble( cFrom, xTo, xCC, cBody, cSubject, aFiles, nPriority, lRead, cReplyTo, cCharset, cEncoding ) ) - oInMail:Commit() - oInMail:Close() - - RETURN .T. - -FUNCTION hb_MailAssemble( ; - cFrom, ; /* Required. Email address of the sender */ - xTo, ; /* Required. Character string or array of email addresses to send the email to */ - xCC, ; /* Optional. Character string or array of email addresses for CC (Carbon Copy) */ - cBody, ; /* Optional. The body message of the email as text, or the filename of the HTML message to send. */ - cSubject, ; /* Optional. Subject of the sending email */ - aFiles, ; /* Optional. Array of attachments to the email to send */ - nPriority, ; /* Optional. Email priority: 1=High, 3=Normal (Standard), 5=Low */ - lRead, ; /* Optional. If set to .T., a confirmation request is send. Standard setting is .F. */ - cReplyTo, ; /* Optional. */ - cCharset, ; /* Optional. */ - cEncoding ) /* Optional. */ - - LOCAL oMail - LOCAL oAttach - LOCAL aThisFile - LOCAL cMimeType - LOCAL cFile - LOCAL cData - LOCAL cContentType - LOCAL nAttr - LOCAL lBodyHTML - LOCAL cCharsetCP - - IF Empty( cFrom ) .OR. ! HB_ISSTRING( cFrom ) - RETURN .F. - ENDIF - IF Empty( xTo ) .OR. ( ! HB_ISSTRING( xTo ) .AND. ! HB_ISARRAY( xTo ) ) - RETURN .F. - ENDIF - - hb_default( @cBody, "" ) - hb_default( @cSubject, "" ) - hb_default( @aFiles, {} ) - nPriority := Int( hb_defaultValue( nPriority, 3 ) ) - hb_default( @lRead, .F. ) - hb_default( @cReplyTo, "" ) - hb_default( @cCharset, "UTF-8" ) - hb_default( @cEncoding, "quoted-printable" ) - - /* Attempt to convert to selected charset if it's supported - by Harbour (and linked to app). */ - IF Upper( cCharset ) == "UTF-8" - cCharsetCP := "UTF8" - ELSEIF hb_cdpExists( Lower( cCharset ) ) - cCharsetCP := hb_cdpUniID( Lower( cCharset ) ) - ENDIF - + /* If the string is an existing HTML filename, load it. */ SWITCH Lower( hb_FNameExt( cBody ) ) CASE ".htm" CASE ".html" - IF hb_FileExists( cBody ) + IF hb_vfExists( cBody ) cBody := MemoRead( cBody ) lBodyHTML := .T. EXIT @@ -305,117 +261,14 @@ FUNCTION hb_MailAssemble( ; lBodyHTML := .F. ENDSWITCH - cContentType := iif( lBodyHTML, "text/html", "text/plain" ) + "; charset=" + cCharset + oInMail:oUrl:cUserid := tip_GetRawEmail( cFrom ) - /* add ending EOL to body, if there wasn't any */ - IF !( Right( cBody, 2 ) == Chr( 13 ) + Chr( 10 ) ) - cBody += Chr( 13 ) + Chr( 10 ) + IF ( tmp := ( oInMail:Write( tip_MailAssemble( cFrom, xTo, xCC, cBody, ; + cSubject, aFiles, nPriority, lRead, cReplyTo, cCharset, ; + cEncoding, lBodyHTML ) ) > 0 ) ) + + oInMail:Commit() ENDIF + oInMail:Close() - /* Convert input to the CP of the e-mail */ - IF ! Empty( cCharsetCP ) - xTo := s_TransCP( xTo, cCharsetCP ) - xCC := s_TransCP( xCC, cCharsetCP ) - cFrom := s_TransCP( cFrom, cCharsetCP ) - cBody := s_TransCP( cBody, cCharsetCP ) - cSubject := s_TransCP( cSubject, cCharsetCP ) - ENDIF - - oMail := TIPMail():New() - oMail:SetEncoder( cEncoding ) - oMail:SetCharset( cCharset ) - IF Empty( aFiles ) - oMail:hHeaders[ "Content-Type" ] := cContentType - oMail:SetBody( cBody ) - ELSE - oAttach := TIPMail():New() - oAttach:SetEncoder( cEncoding ) - oAttach:SetCharset( cCharset ) - oAttach:hHeaders[ "Content-Type" ] := cContentType - oAttach:SetBody( cBody ) - oMail:Attach( oAttach ) - - FOR EACH aThisFile IN aFiles - - cMimeType := NIL - nAttr := 0 - - IF HB_ISSTRING( aThisFile ) - cFile := aThisFile - cData := hb_MemoRead( cFile ) - hb_FGetAttr( cFile, @nAttr ) - ELSEIF HB_ISARRAY( aThisFile ) .AND. Len( aThisFile ) >= 2 - cFile := aThisFile[ 1 ] - IF HB_ISSTRING( aThisFile[ 2 ] ) - cData := aThisFile[ 2 ] - hb_default( @cFile, "unnamed" ) - ELSEIF HB_ISSTRING( cFile ) - cData := hb_MemoRead( cFile ) - hb_FGetAttr( cFile, @nAttr ) - ELSE - LOOP /* No filename and no content. */ - ENDIF - IF Len( aThisFile ) >= 3 .AND. HB_ISSTRING( aThisFile[ 3 ] ) - cMimeType := aThisFile[ 3 ] - ENDIF - ELSE - LOOP - ENDIF - - IF cMimeType == NIL - cMimeType := tip_FileNameMimeType( cFile, "application/octet-stream" ) - ENDIF - cFile := s_TransCP( cFile, cCharsetCP ) - - oAttach := TIPMail():New() - oAttach:SetCharset( cCharset ) - oAttach:SetEncoder( iif( hb_LeftEq( cMimeType, "text/" ), cEncoding, "base64" ) ) - - IF cMimeType == "text/html" - cMimeType += "; charset=" + cCharset - IF !( Right( cData, 2 ) == Chr( 13 ) + Chr( 10 ) ) - cData += Chr( 13 ) + Chr( 10 ) - ENDIF - ENDIF - // Some e-mail clients use Content-Type to check for filename - cMimeType += "; name=" + '"' + hb_FNameNameExt( cFile ) + '"' - IF ( nAttr := __tip_FAttrToUmask( nAttr ) ) != 0 - cMimeType += "; x-unix-mode=" + '"' + hb_NumToHex( nAttr, 4 ) + '"' - ENDIF - oAttach:hHeaders[ "Content-Type" ] := cMimeType - // Usually, original filename is set here - oAttach:hHeaders[ "Content-Disposition" ] := "attachment; filename=" + '"' + hb_FNameNameExt( cFile ) + '"' - oAttach:SetBody( cData ) - oMail:Attach( oAttach ) - NEXT - ENDIF - - oMail:SetHeader( cSubject, cFrom, xTo, xCC ) - oMail:hHeaders[ "Date" ] := tip_TimeStamp() - IF ! Empty( cReplyTo ) - oMail:hHeaders[ "Reply-to" ] := cReplyTo - ENDIF - IF lRead - oMail:hHeaders[ "Disposition-Notification-To" ] := tip_GetRawEmail( cFrom ) - ENDIF - IF nPriority != 3 - oMail:hHeaders[ "X-Priority" ] := hb_ntos( nPriority ) - ENDIF - - RETURN oMail:ToString() - -STATIC FUNCTION s_TransCP( xData, cCP ) - - LOCAL tmp - - IF ! Empty( cCP ) - IF HB_ISSTRING( xData ) - RETURN hb_Translate( xData,, cCP ) - ELSEIF HB_ISARRAY( xData ) - FOR EACH tmp IN xData - tmp := hb_Translate( tmp,, cCP ) - NEXT - ENDIF - ENDIF - - RETURN xData + RETURN tmp diff --git a/contrib/hbtip/mime.c b/contrib/hbtip/mime.c index 9151d4a8f8..29da713468 100644 --- a/contrib/hbtip/mime.c +++ b/contrib/hbtip/mime.c @@ -2,7 +2,6 @@ * TIP MIME functions * * Copyright 2003 Giancarlo Niccolai - * Copyright 2014 Viktor Szakats (vszakats.net/harbour) * * 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 @@ -59,7 +58,7 @@ typedef struct tag_mime { - HB_ISIZ pos; /* Position in stream from which the match begins */ + HB_SIZE pos; /* Position in stream from which the match begins */ const char * pattern; /* String to match */ const char * mime_type; /* MIME type if complete */ int next; /* following entry to determine a MIME type, relative to current position (or 0) */ @@ -210,7 +209,7 @@ typedef struct tag_mime_ext /* keep this table well sorted, it's necessary for binary search algorithm */ -static EXT_MIME_ENTRY s_extMimeTable[] = +static const EXT_MIME_ENTRY s_extMimeTable[] = { { "3dm" , MIME_FLAG_CASEINSENS, "x-world/x-3dmf" }, { "3dmf" , MIME_FLAG_CASEINSENS, "x-world/x-3dmf" }, @@ -541,9 +540,8 @@ static EXT_MIME_ENTRY s_extMimeTable[] = static const char * s_findExtMimeType( const char * szFileExt ) { - HB_UINT uiFirst = 0, uiLast = HB_SIZEOFARRAY( s_extMimeTable ), uiMiddle; + HB_UINT uiFirst = 0, uiLast = HB_SIZEOFARRAY( s_extMimeTable ); char szExt[ 16 ]; - int i; if( *szFileExt == '.' ) ++szFileExt; @@ -551,6 +549,9 @@ static const char * s_findExtMimeType( const char * szFileExt ) do { + HB_UINT uiMiddle; + int i; + uiMiddle = ( uiFirst + uiLast ) >> 1; i = strcmp( szExt, s_extMimeTable[ uiMiddle ].pattern ); if( i == 0 ) @@ -570,11 +571,11 @@ static const char * s_findExtMimeType( const char * szFileExt ) return NULL; } -static const char * s_findMimeStringInTree( const char * cData, HB_ISIZ nLen, int iElem ) +static const char * s_findMimeStringInTree( const char * cData, HB_SIZE nLen, int iElem ) { const MIME_ENTRY * elem = s_mimeTable + iElem; - HB_ISIZ nPos = elem->pos; - HB_ISIZ nDataLen = strlen( elem->pattern ); + HB_SIZE nPos = elem->pos; + HB_SIZE nDataLen = strlen( elem->pattern ); /* allow \0 to be used for matches */ if( nDataLen == 0 ) @@ -582,16 +583,16 @@ static const char * s_findMimeStringInTree( const char * cData, HB_ISIZ nLen, in /* trim spaces if required */ while( nPos < nLen && - ( ( ( elem->flags & MIME_FLAG_TRIMSPACES ) == MIME_FLAG_TRIMSPACES && ( + ( ( ( elem->flags & MIME_FLAG_TRIMSPACES ) != 0 && ( cData[ nPos ] == ' ' || cData[ nPos ] == '\r' || cData[ nPos ] == '\n' ) ) || - ( ( elem->flags & MIME_FLAG_TRIMTABS ) == MIME_FLAG_TRIMTABS && cData[ nPos ] == '\t' ) ) ) + ( ( elem->flags & MIME_FLAG_TRIMTABS ) != 0 && cData[ nPos ] == '\t' ) ) ) { nPos++; } - if( nPos < nLen && nLen - nPos >= nDataLen ) + if( nPos < nLen && ( nLen - nPos ) >= nDataLen ) { - if( ( elem->flags & MIME_FLAG_CASEINSENS ) == MIME_FLAG_CASEINSENS ) + if( ( elem->flags & MIME_FLAG_CASEINSENS ) != 0 ) { if( ( *elem->pattern == 0 && cData[ nPos ] == 0 ) || hb_strnicmp( cData + nPos, elem->pattern, nDataLen ) == 0 ) { @@ -621,24 +622,24 @@ static const char * s_findMimeStringInTree( const char * cData, HB_ISIZ nLen, in return NULL; /* total giveup */ } -static const char * s_findStringMimeType( const char * cData, HB_ISIZ nLen ) +static const char * s_findStringMimeType( const char * cData, HB_SIZE nLen ) { unsigned int uiCount; for( uiCount = 0; uiCount < HB_SIZEOFARRAY( s_mimeTable ); uiCount++ ) { const MIME_ENTRY * elem = s_mimeTable + uiCount; - HB_ISIZ nPos = elem->pos; - HB_ISIZ nDataLen = strlen( elem->pattern ); + HB_SIZE nPos = elem->pos; + HB_SIZE nDataLen = ( HB_SIZE ) strlen( elem->pattern ); - if( ( elem->flags & MIME_FLAG_CONTINUE ) == MIME_FLAG_CONTINUE ) + if( ( elem->flags & MIME_FLAG_CONTINUE ) != 0 ) continue; /* trim spaces if required */ while( nPos < nLen && - ( ( ( elem->flags & MIME_FLAG_TRIMSPACES ) == MIME_FLAG_TRIMSPACES && ( + ( ( ( elem->flags & MIME_FLAG_TRIMSPACES ) != 0 && ( cData[ nPos ] == ' ' || cData[ nPos ] == '\r' || cData[ nPos ] == '\n' ) ) || - ( ( elem->flags & MIME_FLAG_TRIMTABS ) == MIME_FLAG_TRIMTABS && cData[ nPos ] == '\t' ) ) ) + ( ( elem->flags & MIME_FLAG_TRIMTABS ) != 0 && cData[ nPos ] == '\t' ) ) ) { nPos++; } @@ -649,7 +650,7 @@ static const char * s_findStringMimeType( const char * cData, HB_ISIZ nLen ) if( nLen - nPos < nDataLen ) continue; - if( ( elem->flags & MIME_FLAG_CASEINSENS ) == MIME_FLAG_CASEINSENS ) + if( ( elem->flags & MIME_FLAG_CASEINSENS ) != 0 ) { if( ( *elem->pattern == 0 && cData[ nPos ] == 0 ) || hb_strnicmp( cData + nPos, elem->pattern, nDataLen ) == 0 ) { @@ -674,20 +675,17 @@ static const char * s_findStringMimeType( const char * cData, HB_ISIZ nLen ) return NULL; } -static const char * s_findFileMimeType( HB_FHANDLE fileIn ) +static const char * s_findFileMimeType( PHB_FILE fileIn ) { - char buf[ 512 ]; - int iLen; - HB_FOFFSET nPos; + char buf[ 512 ]; - nPos = hb_fsSeekLarge( fileIn, 0, FS_RELATIVE ); - hb_fsSeek( fileIn, 0, FS_SET ); - iLen = hb_fsRead( fileIn, buf, sizeof( buf ) ); + HB_FOFFSET nPos = hb_fileSeek( fileIn, 0, FS_RELATIVE ); + HB_SIZE nLen = hb_fileResult( hb_fileReadAt( fileIn, buf, sizeof( buf ), 0 ) ); - if( iLen > 0 ) + if( nLen > 0 ) { - hb_fsSeekLarge( fileIn, nPos, FS_SET ); - return s_findStringMimeType( buf, iLen ); + hb_fileSeek( fileIn, nPos, FS_SET ); + return s_findStringMimeType( buf, nLen ); } return NULL; @@ -706,7 +704,7 @@ HB_FUNC( TIP_MIMETYPE ) else if( HB_ISCHAR( 2 ) ) hb_retc( hb_parc( 2 ) ); else - hb_retc_const( "unknown" ); /* TOFIX: change to "application/unknown" */ + hb_retc_const( "unknown" ); /* FIXME: change to "application/unknown" */ } else hb_errRT_BASE_SubstR( EG_ARG, 0, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS ); @@ -727,7 +725,7 @@ HB_FUNC( TIP_FILENAMEMIMETYPE ) else if( HB_ISCHAR( 2 ) ) hb_retc( hb_parc( 2 ) ); else - hb_retc_const( "unknown" ); /* TOFIX: change to "application/unknown" */ + hb_retc_const( "unknown" ); /* FIXME: change to "application/unknown" */ } else hb_errRT_BASE_SubstR( EG_ARG, 0, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS ); @@ -735,11 +733,10 @@ HB_FUNC( TIP_FILENAMEMIMETYPE ) HB_FUNC( TIP_FILEMIMETYPE ) { - PHB_ITEM pFile = hb_param( 1, HB_IT_STRING | HB_IT_NUMERIC ); + PHB_ITEM pFile = hb_param( 1, HB_IT_STRING | HB_IT_POINTER | HB_IT_NUMERIC ); if( pFile ) { - HB_FHANDLE fileIn; const char * ext_type = NULL; const char * magic_type = NULL; @@ -748,20 +745,27 @@ HB_FUNC( TIP_FILEMIMETYPE ) const char * fname = hb_itemGetCPtr( pFile ); PHB_FNAME pFileName = hb_fsFNameSplit( fname ); + PHB_FILE fileIn; ext_type = pFileName->szExtension ? s_findExtMimeType( pFileName->szExtension ) : NULL; hb_xfree( pFileName ); - if( ( fileIn = hb_fsOpen( fname, FO_READ ) ) != FS_ERROR ) + if( ( fileIn = hb_fileExtOpen( fname, NULL, + FO_READ | FO_SHARED | FO_PRIVATE | + FXO_SHARELOCK, + NULL, NULL ) ) != NULL ) { magic_type = s_findFileMimeType( fileIn ); - hb_fsClose( fileIn ); + hb_fileClose( fileIn ); } } + else if( hb_fileItemGet( pFile ) ) + magic_type = s_findFileMimeType( hb_fileItemGet( pFile ) ); else { - fileIn = hb_numToHandle( hb_itemGetNInt( pFile ) ); + PHB_FILE fileIn = hb_fileFromHandle( hb_numToHandle( hb_itemGetNInt( pFile ) ) ); magic_type = s_findFileMimeType( fileIn ); + hb_fileDetach( fileIn ); } if( magic_type ) @@ -771,7 +775,7 @@ HB_FUNC( TIP_FILEMIMETYPE ) else if( HB_ISCHAR( 2 ) ) hb_retc( hb_parc( 2 ) ); else - hb_retc_const( "unknown" ); /* TOFIX: change to "application/unknown" */ + hb_retc_const( "unknown" ); /* FIXME: change to "application/unknown" */ } else hb_errRT_BASE_SubstR( EG_ARG, 0, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS ); diff --git a/contrib/hbtip/misc.c b/contrib/hbtip/misc.c index 1e67d4855b..fdac9340f5 100644 --- a/contrib/hbtip/misc.c +++ b/contrib/hbtip/misc.c @@ -2,7 +2,7 @@ * TIP Class oriented Internet protocol library * * Copyright 2003 Giancarlo Niccolai - * Copyright 1999-2001 Viktor Szakats (vszakats.net/harbour) + * Copyright 1999-2001 Viktor Szakats (vszakats.net/harbour) (tip_TimeStamp() rework, cleanups) * * 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 @@ -46,7 +46,6 @@ */ #include "hbapi.h" -#include "hbapiitm.h" #include "hbapierr.h" #include "hbdate.h" @@ -60,7 +59,7 @@ HB_FUNC( TIP_TIMESTAMP ) int iYear, iMonth, iDay, iHour, iMinute, iSecond, iMSec; long lOffset; - /* TOFIX: wrong result is returned when empty dates it's passed */ + /* FIXME: wrong result is returned when empty dates it's passed */ if( HB_ISDATE( 1 ) ) { @@ -90,28 +89,6 @@ HB_FUNC( TIP_TIMESTAMP ) hb_retc( szRet ); } -/* - Case insensitive string comparison to optimize this expression: - IF Lower( ) == Lower( SubStr( , , Len( ) ) ) - must be provided as a pointer to the character string containing a substring - is the numeric position to start comparison in - is the character string to compare with characters in , beginning at - */ - -HB_FUNC( __TIP_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 ) - hb_retl( hb_strnicmp( hb_itemGetCPtr( pString ) + hb_itemGetNS( pStart ) - 1, - hb_itemGetCPtr( pSubstr ), - hb_itemGetCLen( pSubstr ) ) == 0 ); - else - hb_errRT_BASE_SubstR( EG_ARG, 1099, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS ); -} - HB_FUNC( TIP_HTMLSPECIALCHARS ) { if( HB_ISCHAR( 1 ) ) diff --git a/contrib/hbtip/popcli.prg b/contrib/hbtip/popcli.prg index d34416f461..ba691c1755 100644 --- a/contrib/hbtip/popcli.prg +++ b/contrib/hbtip/popcli.prg @@ -2,6 +2,7 @@ * TIP Class oriented Internet protocol library * * Copyright 2003 Giancarlo Niccolai + * Copyright 2007 Hannes Ziegler (countMail(), retrieveAll()) * * 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 @@ -44,18 +45,11 @@ * */ -/* 2007-04-10, Hannes Ziegler - Added method :countMail() - Added method :retrieveAll() -*/ - #include "hbclass.ch" -/** -* Inet service manager: pop3 -*/ +/* Inet service manager: pop3 */ -CREATE CLASS TIPClientPOP FROM TIPClient +CREATE CLASS TIPClientPOP INHERIT TIPClient METHOD New( oUrl, xTrace, oCredentials ) METHOD Open( cUrl ) @@ -75,24 +69,22 @@ CREATE CLASS TIPClientPOP FROM TIPClient METHOD Read( nLen ) METHOD retrieveAll( lDelete ) - METHOD getTop( nMsgId, lAsArray ) - METHOD getMessageRaw( nMsgId, lAsArray ) - METHOD getBody( nMsgId, lAsArray ) + METHOD getTop( nMsgId ) + METHOD getMessageRaw( nMsgId ) + METHOD getBody( nMsgId ) METHOD getSubject( nMsgId ) ENDCLASS METHOD New( oUrl, xTrace, oCredentials ) CLASS TIPClientPOP - ::super:new( oUrl, iif( HB_ISLOGICAL( xTrace ) .AND. xTrace, "pop3", xTrace ), oCredentials ) + ::super:new( oUrl, iif( hb_defaultValue( xTrace, .F. ), "pop3", xTrace ), oCredentials ) ::nDefaultPort := iif( ::oUrl:cProto == "pop3s" .OR. ::oUrl:cProto == "pops", 995, 110 ) ::nConnTimeout := 10000 RETURN Self -/** -*/ METHOD Open( cUrl ) CLASS TIPClientPOP IF ! ::super:Open( cUrl ) @@ -129,13 +121,10 @@ METHOD OpenDigest( cUrl ) CLASS TIPClientPOP ENDIF IF ::GetOk() - nPos := At( "<", ::cReply ) - IF nPos > 0 - nPos2 := hb_At( ">", ::cReply, nPos + 1 ) - IF nPos2 > nPos + IF ( nPos := At( "<", ::cReply ) ) > 0 + IF ( nPos2 := hb_At( ">", ::cReply, nPos + 1 ) ) > nPos cDigest := hb_MD5( SubStr( ::cReply, nPos, ( nPos2 - nPos ) + 1 ) + ::oUrl:cPassword ) - ::inetSendAll( ::SocketCon, "APOP " + ::oUrl:cUserid + " " ; - + cDigest + ::cCRLF ) + ::inetSendAll( ::SocketCon, "APOP " + ::oUrl:cUserid + " " + cDigest + ::cCRLF ) IF ::GetOK() ::isOpen := .T. RETURN .T. @@ -148,21 +137,17 @@ METHOD OpenDigest( cUrl ) CLASS TIPClientPOP METHOD Close( lAutoQuit ) CLASS TIPClientPOP - hb_default( @lAutoQuit, .T. ) - ::InetTimeOut( ::SocketCon ) - IF lAutoQuit + IF hb_defaultValue( lAutoQuit, .T. ) ::Quit() ENDIF RETURN ::super:Close() -/** -*/ METHOD Delete( nId ) CLASS TIPClientPOP - ::inetSendAll( ::SocketCon, "DELE " + hb_ntos( nId ) + ::cCRLF ) + ::inetSendAll( ::SocketCon, "DELE " + hb_ntos( Int( nId ) ) + ::cCRLF ) RETURN ::GetOk() @@ -177,14 +162,13 @@ METHOD List() CLASS TIPClientPOP ENDIF cRet := "" - DO WHILE !( cStr == "." ) .AND. ::inetErrorCode( ::SocketCon ) == 0 + DO WHILE ! cStr == "." .AND. ::inetErrorCode( ::SocketCon ) == 0 cStr := ::inetRecvLine( ::SocketCon, @nPos, 256 ) - IF !( cStr == "." ) - cRet += cStr + ::cCRLF - ELSE + IF ! HB_ISSTRING( cStr ) .OR. cStr == "." ::bEof := .T. + ELSE + cRet += cStr + ::cCRLF ENDIF - ENDDO IF ::inetErrorCode( ::SocketCon ) != 0 @@ -206,7 +190,7 @@ METHOD Retrieve( nId, nLen ) CLASS TIPClientPOP LOCAL cEOM := ::cCRLF + "." + ::cCRLF // End Of Mail IF ! ::bInitialized - ::inetSendAll( ::SocketCon, "RETR " + hb_ntos( nId ) + ::cCRLF ) + ::inetSendAll( ::SocketCon, "RETR " + hb_ntos( Int( nId ) ) + ::cCRLF ) IF ! ::GetOk() ::bEof := .T. RETURN NIL @@ -215,31 +199,30 @@ METHOD Retrieve( nId, nLen ) CLASS TIPClientPOP ENDIF cRet := "" - nRetLen := 0 /* 2004-05-04 - Instead of receiving a single char at a time until after we have the full mail, let's receive as much as we can and stop when we reach EOM (end of mail :)) sequence. This way is _a lot_ faster - */ + */ DO WHILE ::inetErrorCode( ::SocketCon ) == 0 .AND. ! ::bEof cBuffer := Space( 1024 ) - nRead := ::inetRecv( ::SocketCon, @cBuffer, 1024 ) + nRead := ::inetRecv( ::SocketCon, @cBuffer, hb_BLen( cBuffer ) ) - cRet += Left( cBuffer, nRead ) + cRet += hb_BLeft( cBuffer, nRead ) /* 2005-11-24 - "- Len( cEOM )" to be sure to always find a full EOM, otherwise if response breaks EOM in two, it will never be found - */ - IF ( nPos := hb_At( cEOM, cRet, Max( nRetLen - Len( cEOM ), 1 ) ) ) != 0 + */ + IF ( nPos := hb_BAt( cEOM, cRet, Max( nRetLen - hb_BLen( cEOM ), 1 ) ) ) > 0 // Remove ".CRLF" - cRet := Left( cRet, nPos + 1 ) + cRet := hb_BLeft( cRet, nPos + 1 ) ::bEof := .T. - ELSEIF ! Empty( nLen ) .AND. nLen < Len( cRet ) + ELSEIF HB_ISNUMERIC( nLen ) .AND. nLen < hb_BLen( cRet ) /* FIXME: might break UTF-8 chars */ EXIT ELSE nRetLen += nRead @@ -273,18 +256,18 @@ METHOD Top( nMsgId ) CLASS TIPClientPOP LOCAL nPos LOCAL cStr, cRet - ::inetSendAll( ::SocketCon, "TOP " + hb_ntos( nMsgId ) + " 0" + ::cCRLF ) + ::inetSendAll( ::SocketCon, "TOP " + hb_ntos( Int( nMsgId ) ) + " 0" + ::cCRLF ) IF ! ::GetOk() RETURN NIL ENDIF cRet := "" - DO WHILE !( cStr == "." ) .AND. ::inetErrorCode( ::SocketCon ) == 0 - cStr := ::inetRecvLine( ::SocketCon, @nPos, 256 ) - IF !( cStr == "." ) - cRet += cStr + ::cCRLF - ELSE + DO WHILE ! cStr == "." .AND. ::inetErrorCode( ::SocketCon ) == 0 + cStr := ::inetRecvLine( ::SocketCon, @nPos, 512 ) + IF ! HB_ISSTRING( cStr ) .OR. cStr == "." ::bEof := .T. + ELSE + cRet += cStr + ::cCRLF ENDIF ENDDO @@ -305,8 +288,8 @@ METHOD UIDL( nMsgId ) CLASS TIPClientPOP LOCAL nPos LOCAL cStr, cRet - IF ! Empty( nMsgId ) - ::inetSendAll( ::SocketCon, "UIDL " + hb_ntos( nMsgId ) + ::cCRLF ) + IF HB_ISNUMERIC( nMsgId ) .AND. nMsgId >= 1 + ::inetSendAll( ::SocketCon, "UIDL " + hb_ntos( Int( nMsgId ) ) + ::cCRLF ) ELSE ::inetSendAll( ::SocketCon, "UIDL" + ::cCRLF ) ENDIF @@ -315,19 +298,19 @@ METHOD UIDL( nMsgId ) CLASS TIPClientPOP RETURN NIL ENDIF - IF ! Empty( nMsgId ) - // +OK Space(1) nMsg Space(1) UID - RETURN SubStr( ::cReply, RAt( Space( 1 ), ::cReply ) + 1 ) - ELSE + IF Empty( nMsgId ) cRet := "" - DO WHILE !( cStr == "." ) .AND. ::inetErrorCode( ::SocketCon ) == 0 + DO WHILE ! cStr == "." .AND. ::inetErrorCode( ::SocketCon ) == 0 cStr := ::inetRecvLine( ::SocketCon, @nPos, 256 ) - IF !( cStr == "." ) - cRet += cStr + ::cCRLF - ELSE + IF ! HB_ISSTRING( cStr ) .OR. cStr == "." ::bEof := .T. + ELSE + cRet += cStr + ::cCRLF ENDIF ENDDO + ELSE + // +OK Space( 1 ) nMsg Space( 1 ) UID + RETURN SubStr( ::cReply, RAt( Space( 1 ), ::cReply ) + 1 ) ENDIF IF ::inetErrorCode( ::SocketCon ) != 0 @@ -336,16 +319,14 @@ METHOD UIDL( nMsgId ) CLASS TIPClientPOP RETURN cRet -/** -*/ METHOD countMail() CLASS TIPClientPop LOCAL cStat IF ::isOpen ::reset() - cStat := ::stat() - IF Left( cStat, 3 ) == "+OK" + cStat := ::Stat() + IF HB_ISSTRING( cStat ) .AND. hb_LeftEq( cStat, "+OK" ) RETURN Val( SubStr( cStat, 4, hb_At( " ", cStat, 5 ) - 4 ) ) ENDIF ENDIF @@ -354,179 +335,123 @@ METHOD countMail() CLASS TIPClientPop METHOD GetOk() CLASS TIPClientPOP - LOCAL nLen + ::cReply := ::inetRecvLine( ::SocketCon,, 128 ) - ::cReply := ::inetRecvLine( ::SocketCon, @nLen, 128 ) - IF ::inetErrorCode( ::SocketCon ) != 0 .OR. !( Left( ::cReply, 1 ) == "+" ) - RETURN .F. - ENDIF + RETURN ::inetErrorCode( ::SocketCon ) == 0 .AND. ; + HB_ISSTRING( ::cReply ) .AND. hb_LeftEq( ::cReply, "+" ) - RETURN .T. - -/* QUESTION: This method will return .T./.F./NIL or string +/* QUESTION: This method will return logical, NIL or string Is it really intended that way? [vszakats] */ METHOD Read( nLen ) CLASS TIPClientPOP - /* Set what to read for */ + /* Decide what to read */ IF Empty( ::oUrl:cFile ) - RETURN ::List() + RETURN ::List() /* return NIL or string */ + ELSEIF Val( ::oUrl:cFile ) < 0 + RETURN ::Delete( -Val( ::oUrl:cFile ) ) .AND. ::Quit() /* return logical */ ENDIF - IF Val( ::oUrl:cFile ) < 0 - IF ::Delete( - Val( ::oUrl:cFile ) ) - RETURN ::Quit() - ELSE - RETURN .F. - ENDIF - ENDIF - - RETURN ::Retrieve( Val( ::oUrl:cFile ), nLen ) + RETURN ::Retrieve( Val( ::oUrl:cFile ), nLen ) /* return NIL or string */ METHOD retrieveAll( lDelete ) CLASS TIPClientPOP - LOCAL aMails, i, imax, cMail + LOCAL aMails, oMail - hb_default( @lDelete, .F. ) + IF ::isOpen - IF ! ::isOpen - RETURN NIL - ENDIF + hb_default( @lDelete, .F. ) - imax := ::countMail() - aMails := Array( imax ) - - FOR i := 1 TO imax - ::reset() - /* TOFIX: cMail might get assigned NIL here, creating RTE later. */ - cMail := ::retrieve( i ) - aMails[ i ] := TIPMail():new() - aMails[ i ]:fromString( cMail ) - - IF lDelete + FOR EACH oMail IN aMails := Array( ::countMail() ) ::reset() - ::delete( i ) - ENDIF - NEXT + + oMail := TIPMail():new() + oMail:fromString( ::retrieve( oMail:__enumIndex() ) ) + + IF lDelete + ::reset() + ::delete( oMail:__enumIndex() ) + ENDIF + NEXT + ENDIF RETURN aMails -/*----------------------------------------------------------------------*/ -// Pritpal Bedi 20Oct2013 -/*----------------------------------------------------------------------*/ - -METHOD getTop( nMsgId, lAsArray ) CLASS TIPClientPOP +METHOD getTop( nMsgId ) CLASS TIPClientPOP LOCAL nPos, cStr, xRet - ::inetSendAll( ::SocketCon, "TOP " + hb_ntos( nMsgId ) + " 0" + ::cCRLF ) + ::inetSendAll( ::SocketCon, "TOP " + hb_ntos( Int( nMsgId ) ) + " 0" + ::cCRLF ) IF ! ::GetOk() RETURN NIL ENDIF - hb_default( @lAsArray, .F. ) - - xRet := iif( lAsArray, {}, "" ) - DO WHILE ! ( cStr == "." ) .AND. ::inetErrorCode( ::SocketCon ) == 0 + xRet := cStr := "" + DO WHILE ! cStr == "." .AND. ::inetErrorCode( ::SocketCon ) == 0 cStr := ::inetRecvLine( ::SocketCon, @nPos, 1024 ) - IF ! ( cStr == "." ) - IF lAsArray - AAdd( xRet, cStr ) - ELSE - xRet += cStr + ::cCRLF - ENDIF + IF HB_ISSTRING( cStr ) .AND. ! cStr == "." + xRet += cStr + ::cCRLF ENDIF ENDDO RETURN xRet - -METHOD getMessageRaw( nMsgId, lAsArray ) CLASS TIPClientPOP +METHOD getMessageRaw( nMsgId ) CLASS TIPClientPOP LOCAL cLine, nBytes, xRet - ::inetSendAll( ::SocketCon, "RETR " + hb_ntos( nMsgId ) + ::cCRLF ) + ::inetSendAll( ::SocketCon, "RETR " + hb_ntos( Int( nMsgId ) ) + ::cCRLF ) IF ! ::GetOk() RETURN NIL ENDIF - hb_default( @lAsArray, .F. ) - - xRet := iif( lAsArray, {}, "" ) + xRet := "" DO WHILE ::inetErrorCode( ::SocketCon ) == 0 cLine := ::inetRecvLine( ::SocketCon, @nBytes, 8192 ) - IF nBytes <= 0 + IF nBytes <= 0 .OR. ! HB_ISSTRING( cLine ) .OR. cLine == "." EXIT ENDIF - IF cLine == "." - EXIT - ENDIF - IF lAsArray - AAdd( xRet, cLine ) - ELSE - xRet += cLine + ::cCRLF - ENDIF + xRet += cLine + ::cCRLF ENDDO RETURN xRet +METHOD getBody( nMsgId ) CLASS TIPClientPOP -METHOD getBody( nMsgId, lAsArray ) CLASS TIPClientPOP + LOCAL xRet, n, n1, i, nBoundary, cBoundary, aMsg - LOCAL xRet, n, n1, i, nBoundry, cBoundary - LOCAL aMsg := ::getMessageRaw( nMsgId, .T. ) - - IF Empty( aMsg ) + IF Empty( aMsg := ::getMessageRaw( nMsgId, .T. ) ) RETURN NIL ENDIF - hb_default( @lAsArray, .F. ) - xRet := iif( lAsArray, {}, "" ) + xRet := "" - IF ( nBoundry := AScan( aMsg, { | cLine | n1 := At( "boundary=", Lower( cLine ) ), n1 > 0 } ) ) > 0 - cBoundary := SubStr( aMsg[ nBoundry ], n1 + 1 ) - cBoundary := AllTrim( StrTran( cBoundary, '"', "" ) ) + IF ( nBoundary := AScan( aMsg, {| cLine | n1 := hb_AtI( "boundary=", cLine ), n1 > 0 } ) ) > 0 + cBoundary := AllTrim( StrTran( SubStr( aMsg[ nBoundary ], n1 + 1 ), '"' ) ) ENDIF IF ! Empty( cBoundary ) - n := AScan( aMsg, { | cLine | cBoundary $ cLine }, nBoundry + 1 ) - IF n > 0 - n1 := AScan( aMsg, { | cLine | cBoundary $ cLine }, n + 1 ) - IF n1 > 0 // This must not happen, but - FOR i := n + 3 TO n1 - 1 - IF lAsArray - AAdd( xRet, aMsg[ i ] ) - ELSE - xRet += aMsg[ i ] + ::cCRLF - ENDIF - NEXT - ENDIF - ENDIF - ELSE - n := AScan( aMsg, { | cLine | Empty( cLine ) } ) - IF n > 0 - FOR i := n + 1 TO Len( aMsg ) - IF lAsArray - AAdd( xRet, aMsg[ i ] ) - ELSE - xRet += aMsg[ i ] + ::cCRLF - ENDIF + IF ( n := AScan( aMsg, {| cLine | cBoundary $ cLine }, nBoundary + 1 ) ) > 0 .AND. ; + ( n1 := AScan( aMsg, {| cLine | cBoundary $ cLine }, n + 1 ) ) > 0 // This must not happen, but + FOR i := n + 3 TO n1 - 1 + xRet += aMsg[ i ] + ::cCRLF NEXT ENDIF + ELSEIF ( n := AScan( aMsg, {| cLine | Empty( cLine ) } ) ) > 0 + FOR i := n + 1 TO Len( aMsg ) + xRet += aMsg[ i ] + ::cCRLF + NEXT ENDIF RETURN xRet - METHOD getSubject( nMsgId ) CLASS TIPClientPOP LOCAL cHeader - LOCAL aTop := ::getTop( nMsgId, .T. ) - FOR EACH cHeader IN aTop - IF Lower( Left( cHeader, 9 ) ) == "subject: " - RETURN SubStr( cHeader, 10 ) + FOR EACH cHeader IN ::getTop( nMsgId, .T. ) + IF hb_LeftEqI( cHeader, "subject: " ) + RETURN SubStr( cHeader, Len( "subject: " ) + 1 ) ENDIF NEXT RETURN NIL - diff --git a/contrib/hbtip/sessid.prg b/contrib/hbtip/sessid.prg index be57d1296c..bbd71597fb 100644 --- a/contrib/hbtip/sessid.prg +++ b/contrib/hbtip/sessid.prg @@ -2,14 +2,7 @@ * Functions to create session id and some utils * * Copyright 2008 Lorenzo Fiorini - * - * code from: - * TIP Class oriented Internet protocol library - * - * Copyright 2003 Giancarlo Niccolai - * - * CGI Session Manager Class - * + * Copyright 2003 Giancarlo Niccolai (CGI Session Manager Class) * Copyright 2003-2006 Francesco Saverio Giudice * * This program is free software; you can redistribute it and/or modify @@ -69,13 +62,14 @@ FUNCTION tip_GenerateSID( cCRCKey ) cSID := "" nKey := 0 FOR n := 1 TO SID_LENGTH - nRand := hb_RandomInt( 1, nLenKeys ) + nRand := hb_randInt( nLenKeys ) cSID += SubStr( cBaseKeys, nRand, 1 ) nKey += nRand NEXT nSIDCRC := nKey * 51 // Max Value is 99603 a 5 chars number cTemp := StrZero( nSIDCRC, 5 ) + cSIDCRC := "" FOR n := 1 TO Len( cTemp ) cSIDCRC += SubStr( cCRCKey, Val( SubStr( cTemp, n, 1 ) ) + 1, 1 ) @@ -106,17 +100,13 @@ FUNCTION tip_CheckSID( cSID, cCRCKey ) RETURN Right( cSID, 5 ) == cSIDCRC -FUNCTION tip_DateToGMT( dDate, cTime ) +FUNCTION tip_DateToGMT( tDate ) - LOCAL aDays := { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" } - LOCAL aMonths := { "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" } - - hb_default( @dDate, Date() ) - hb_default( @cTime, Time() ) + hb_default( @tDate, hb_DateTime() ) RETURN ; - aDays[ DoW( dDate ) ] + ", " + ; - StrZero( Day( dDate ), 2 ) + " " + ; - aMonths[ Month( dDate ) ] + " " + ; - StrZero( Year( dDate ), 4 ) + " " + ; - cTime + " GMT" + { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" }[ DoW( tDate ) ] + ", " + ; + StrZero( Day( tDate ), 2 ) + " " + ; + { "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" }[ Month( tDate ) ] + " " + ; + StrZero( Year( tDate ), 4 ) + " " + ; + hb_TToC( tDate, "", "hh:mm:ss" ) + " GMT" diff --git a/contrib/hbtip/smtpcli.prg b/contrib/hbtip/smtpcli.prg index f5c8f52033..52fad69462 100644 --- a/contrib/hbtip/smtpcli.prg +++ b/contrib/hbtip/smtpcli.prg @@ -2,8 +2,9 @@ * TIP Class oriented Internet protocol library * * Copyright 2003 Giancarlo Niccolai + * Copyright 2007 Hannes Ziegler (sendMail()) * Copyright 2009 Viktor Szakats (vszakats.net/harbour) (SSL support) - * Copyright 2015 Jean Lefebvre (TLS support) + * Copyright 2015 Jean Lefebvre (STARTTLS support) * * 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 @@ -46,17 +47,11 @@ * */ -/* 2007-04-12, Hannes Ziegler - Added method :sendMail() - 2015-01-29, Jean Lefebvre - Added METHOD StartTLS() -*/ - #include "hbclass.ch" #include "tip.ch" -CREATE CLASS TIPClientSMTP FROM TIPClient +CREATE CLASS TIPClientSMTP INHERIT TIPClient VAR lAuthLOGIN INIT .F. VAR lAuthPLAIN INIT .F. @@ -201,9 +196,8 @@ METHOD DetectSecurity() CLASS TIPClientSMTP ::lAuthLogin := .T. ::lAuthPlain := .T. ENDIF - IF hb_LeftEq( ::cReply, "250-" ) - LOOP - ELSEIF hb_LeftEq( ::cReply, "250 " ) + + IF hb_LeftEq( ::cReply, "250 " ) EXIT ENDIF ENDDO @@ -300,7 +294,7 @@ METHOD Write( cData, nLen, bCommit ) CLASS TIPClientSMTP ::bInitialized := .T. ENDIF - RETURN ::nLastWrite := ::super:Write( cData, nLen, bCommit ) + RETURN ::super:Write( cData, nLen, bCommit ) METHOD ServerSuportSecure( /* @ */ lAuthPlain, /* @ */ lAuthLogin ) CLASS TIPClientSMTP diff --git a/contrib/hbtip/tests/base64.prg b/contrib/hbtip/tests/base64.prg index 0b0fdfa575..ae8a20755f 100644 --- a/contrib/hbtip/tests/base64.prg +++ b/contrib/hbtip/tests/base64.prg @@ -1,100 +1,80 @@ -/****************************************** -* TIP test -* BASE64 (and other) encoding -* -* This test writes data to standard output, and is -* compiled only under GTCGI; this allow to test the -* input/output file against other OS encoded/decoded data -* -* Usage: -* base64 < file-to-encode >encoded-file -* base64 -d < encoded-file >file-to-decode -* base64 -q [-d] to use quoted printable encoding/decoding. -* base64 -u [-d] to use url encoding/decoding. -*****/ +/* TIP Base64 (and other) encoding + * + * This test writes data to standard output, and is + * compiled only under GTCGI. This allow to test the + * input/output file against other OS encoded/decoded data + */ #require "hbtip" -#define hSTDIN 0 -#define hSTDOUT 1 +#include "fileio.ch" PROCEDURE Main( ... ) - LOCAL oEncoder - LOCAL cData - LOCAL cBuffer := Space( 1024 ) - LOCAL nLen - LOCAL lHelp := .F., lDecode := .F., lQp := .F., lUrl := .F. - LOCAL hInput := hSTDIN - LOCAL hOutput := hSTDOUT + LOCAL oEncoder, cEncoder := "base64" + LOCAL lDecode := .F., lHelp := .F. + LOCAL cData, nLen, cBuffer + + LOCAL hFileInput, nFileInput := hb_GetStdIn() + LOCAL hFileOutput, nFileOutput := hb_GetStdOut() /* Parameter parsing */ - FOR nLen := 1 TO PCount() - cData := Lower( hb_PValue( nLen ) ) - DO CASE - CASE cData == "-h" + FOR EACH cData IN hb_AParams() + + SWITCH Lower( cData ) + CASE "-h" lHelp := .T. - - CASE cData == "-d" + EXIT + CASE "-d" lDecode := .T. - - CASE cData == "-q" - lQp := .T. - - CASE cData == "-u" - lUrl := .T. - + EXIT + CASE "-q" + cEncoder := "quoted-printable" + EXIT + CASE "-u" + cEncoder := "url" + EXIT OTHERWISE - IF hb_FileExists( cData ) .AND. hInput == hSTDIN - hInput := FOpen( cData ) - ELSEIF hOutput == hSTDOUT - hOutput := FCreate( cData ) + IF hb_vfExists( cData ) .AND. nFileInput == hb_GetStdIn() + IF ( hFileInput := hb_vfOpen( cData, FO_READ ) ) != NIL + nFileInput := hb_vfHandle( hFileInput ) + ENDIF + ELSEIF nFileOutput == hb_GetStdOut() + IF ( hFileOutput := hb_vfOpen( cData, FO_CREAT + FO_TRUNC + FO_WRITE ) ) != NIL + nFileOutput := hb_vfHandle( hFileOutput ) + ENDIF ELSE ? "Wrong parameter", cData ? lHelp := .T. - EXIT ENDIF - ENDCASE + ENDSWITCH NEXT /* Providing help */ IF lHelp ? "Usage:" - ? "base64test [<] file-to-encode [>] encoded-file" - ? "base64test -d [<] encoded-file [>] file-to-decode" - ? "base64test -q [-d] to use quoted printable encoding/decoding" - ? "base64test -u [-d] to use url encoding/decoding." + ? "base64 [<] file-to-encode [>] encoded-file" + ? "base64 -d [<] encoded-file [>] file-to-decode" + ? "base64 -q [-d] to use quoted printable encoding/decoding" + ? "base64 -u [-d] to use URL encoding/decoding." ? "input/output redirection is optional" ? - QUIT - ENDIF - - /* Selecting the encoder */ - IF lUrl - oEncoder := TIPEncoder():New( "url" ) - ELSEIF lQp - oEncoder := TIPEncoder():New( "quoted-printable" ) - ELSE - oEncoder := TIPEncoder():New( "base64" ) + RETURN ENDIF /* Reading input stream */ cData := "" - nLen := FRead( hInput, @cBuffer, 1024 ) - DO WHILE nLen > 0 - IF nLen < 1024 - cData += hb_BLeft( cBuffer, nLen ) - ELSE - cData += cBuffer - ENDIF - nLen := FRead( hInput, @cBuffer, 1024 ) + cBuffer := Space( 1024 ) + DO WHILE ( nLen := FRead( nFileInput, @cBuffer, hb_BLen( cBuffer ) ) ) > 0 + cData += hb_BLeft( cBuffer, nLen ) ENDDO - IF hInput != hSTDIN - FClose( hInput ) + IF hFileInput != NIL + hb_vfClose( hFileInput ) ENDIF /* Encoding/decoding */ + oEncoder := TIPEncoder():New( cEncoder ) IF lDecode cData := oEncoder:Decode( cData ) ELSE @@ -102,9 +82,9 @@ PROCEDURE Main( ... ) ENDIF /* Writing stream */ - FWrite( hOutput, cData ) - IF hOutput != hSTDOUT - FClose( hOutput ) + FWrite( nFileOutput, cData ) + IF hFileOutput != NIL + hb_vfClose( hFileOutput ) ENDIF RETURN diff --git a/contrib/hbtip/tests/dbtohtml.prg b/contrib/hbtip/tests/dbtohtml.prg index 60fa699835..4dc8dfaa0e 100644 --- a/contrib/hbtip/tests/dbtohtml.prg +++ b/contrib/hbtip/tests/dbtohtml.prg @@ -1,26 +1,19 @@ -/* - * This example demonstrates operator overloading for - * creating a HTML document. - */ +/* Demonstrating operator overloading for creating an HTML document */ #require "hbtip" +#require "hbtest" -PROCEDURE Main +PROCEDURE Main() LOCAL oDoc, oNode, oTable, oRow, oCell LOCAL i, j - CLS + IF ! hbtest_Table() + ? "Error: Test database couldn't be created" + RETURN + ENDIF - BEGIN SEQUENCE - USE ( hb_DirBase() + ".." + hb_ps() + ".." + hb_ps() + ".." + hb_ps() + "tests" + hb_ps() + ; - "test.dbf" ) - RECOVER - ? "Error: Database not found test.dbf" - QUIT - END SEQUENCE - - oDoc := THtmlDocument():new() + oDoc := THtmlDocument():New() /* Operator "+" creates a new node */ oNode := oDoc:head + "meta" @@ -35,28 +28,28 @@ PROCEDURE Main oNode := oDoc:body + "p" /* Operator "+" creates a new node with attribute */ - oNode := oNode + 'font size="5"' + oNode := oNode + 'font size="5"' oNode:text := "This is a " /* Operator "+" creates a new node */ - oNode := oNode + "b" + oNode := oNode + "b" /* Operator "+" creates a new node with attribute */ - oNode := oNode + 'font color="blue"' + oNode := oNode + 'font color="blue"' oNode:text := "sample " /* Operator "-" closes 2nd , result is node */ - oNode := oNode - "font" + oNode := oNode - "font" /* Operator "-" closes node, result is 1st node */ - oNode := oNode - "b" + oNode := oNode - "b" oNode:text := "database!" /* Operator "-" closes 1st node, result is

node */ - oNode := oNode - "font" + oNode := oNode - "font" - oNode := oNode + "hr" + oNode := oNode + "hr" HB_SYMBOL_UNUSED( oNode ) /* Operator ":" returns first "table" from body (creates if not existent) */ @@ -65,9 +58,9 @@ PROCEDURE Main oRow := oTable + 'tr bgcolor="lightcyan"' FOR i := 1 TO FCount() - oCell := oRow + "th" + oCell := oRow + "th" oCell:text := FieldName( i ) - oCell := oCell - "th" + oCell := oCell - "th" HB_SYMBOL_UNUSED( oCell ) NEXT @@ -88,21 +81,21 @@ PROCEDURE Main oRow := oRow - "tr" HB_SYMBOL_UNUSED( oRow ) - SKIP + dbSkip() NEXT - oNode := oDoc:body + "hr" + oNode := oDoc:body + "hr" HB_SYMBOL_UNUSED( oNode ) - oNode := oDoc:body + "p" + oNode := oDoc:body + "p" - oNode:text := "10 records from database " + Alias() + ".dbf" + oNode:text := "10 records from database " + Alias() dbCloseArea() IF oDoc:writeFile( "address.html" ) - ? "File created: address.html" + ? "File created:", "address.html" ELSE - ? "Error: ", FError() + ? "Error:", FError() ENDIF WAIT @@ -110,4 +103,6 @@ PROCEDURE Main hb_run( "address.html" ) + hb_vfErase( "address.html" ) + RETURN diff --git a/contrib/hbtip/tests/dnldftp.prg b/contrib/hbtip/tests/dnldftp.prg deleted file mode 100644 index f803a15f25..0000000000 --- a/contrib/hbtip/tests/dnldftp.prg +++ /dev/null @@ -1,79 +0,0 @@ -/* - * Download an file from an ftp server - */ - -#require "hbtip" - -PROCEDURE Main( cFile ) - - ? TRP20FTPEnv( cFile ) - - RETURN - -/********************************************************************** - * - * Static Function TRP20FTPEnv() - * - **********************************************************************/ - -STATIC FUNCTION TRP20FTPEnv( cCarpeta ) - - LOCAL aFiles - LOCAL cUrl - LOCAL cStr - LOCAL lRetVal := .T. - LOCAL oUrl - LOCAL oFTP - LOCAL cUser - LOCAL cServer - LOCAL cPassword - LOCAL cFile := "" - - cServer := "ftpserver" /* change ftpserver to the real name or ip of your ftp server */ - cUser := "ftpuser" /* change ftpuser to an valid user on ftpserer */ - cPassword := "ftppass" /* change ftppass to an valid password for ftpuser */ - cUrl := "ftp://" + cUser + ":" + cPassword + "@" + cServer - - /* Leemos ficheros a enviar */ - aFiles := { { cCarpeta, 1, 2, 3 } } - /* aFiles := Directory( cCarpeta ) */ - - IF Len( aFiles ) > 0 - - oUrl := TUrl():New( cUrl ) - oFTP := TIPClientFTP():New( oUrl, .T. ) - oFTP:nConnTimeout := 20000 - oFTP:bUsePasv := .T. - - /* Comprobamos si el usuario contiene una @ para forzar el userid */ - IF At( "@", cUser ) > 0 - oFTP:oUrl:cServer := cServer - oFTP:oUrl:cUserID := cUser - oFTP:oUrl:cPassword := cPassword - ENDIF - - IF oFTP:Open( cUrl ) - FOR EACH cFile IN afiles - IF ! oFtp:DownloadFile( cFile[ 1 ] ) - lRetVal := .F. - EXIT - ELSE - lRetVal := .T. - ENDIF - NEXT - oFTP:Close() - ELSE - cStr := "Could not connect to FTP server " + oURL:cServer - IF oFTP:SocketCon == NIL - cStr += hb_eol() + "Connection not initialized" - ELSEIF hb_inetErrorCode( oFTP:SocketCon ) == 0 - cStr += hb_eol() + "Server response:" + " " + oFTP:cReply - ELSE - cStr += hb_eol() + "Error in connection:" + " " + hb_inetErrorDesc( oFTP:SocketCon ) - ENDIF - ? cStr - lRetVal := .F. - ENDIF - ENDIF - - RETURN lRetVal diff --git a/contrib/hbtip/tests/email.prg b/contrib/hbtip/tests/email.prg new file mode 100644 index 0000000000..fc81765a1d --- /dev/null +++ b/contrib/hbtip/tests/email.prg @@ -0,0 +1,91 @@ +/* Copyright 2009 Viktor Szakats (vszakats.net/harbour) */ + +#require "hbssl" +#require "hbtip" + +#if ! defined( __HBSCRIPT__HBSHELL ) +REQUEST __HBEXTERN__HBSSL__ +#endif + +#include "simpleio.ch" + +PROCEDURE Main( cFrom, cPassword, cTo, cHost ) + + LOCAL nPort + LOCAL lSTARTTLS := .F. + + IF ! tip_SSL() + ? "Error: Requires SSL support" + RETURN + ENDIF + + hb_default( @cFrom , "" ) + hb_default( @cPassword, "password" ) + hb_default( @cTo , "to@example.com" ) + hb_default( @cHost , "localhost" ) + + cHost := Lower( cHost ) + + /* SMTPS works with SSL/TLS on port 465 and with STARTTLS + on port 587. STARTTLS mode is fully automatic and requires + SSL/TLS be disabled at first (it will be activated on + request after STARTTLS command) */ + + DO CASE + CASE cHost == "apple" .OR. "@icloud.com" $ cFrom .OR. "@mac.com" $ cFrom .OR. "@me.com" $ cFrom + cHost := "smtp.mail.me.com"; lSTARTTLS := .T. + CASE cHost == "fastmail" .OR. "@fastmail.com" $ cFrom .OR. "@fastmail.fm" $ cFrom + cHost := "smtp.fastmail.com" + CASE cHost == "gmx.net" .OR. "@gmx.net" $ cFrom .OR. "@gmx.ch" $ cFrom .OR. "@gmx.de" $ cFrom + cHost := "mail.gmx.net"; lSTARTTLS := .T. + CASE cHost == "google" .OR. "@gmail.com" $ cFrom .OR. "@googlemail.com" $ cFrom + cHost := "smtp.gmail.com" + CASE cHost == "mail.ru" .OR. "@mail.ru" $ cFrom + cHost := "smtp.mail.ru" + CASE cHost == "netease" .OR. "@163.com" $ cFrom + cHost := "smtp.163.com" + CASE cHost == "office365" + cHost := "smtp.office365.com"; lSTARTTLS := .T. + CASE cHost == "outlook" .OR. "@outlook.com" $ cFrom .OR. "@hotmail.com" $ cFrom + cHost := "smtp-mail.outlook.com"; lSTARTTLS := .T. + CASE cHost == "sina" .OR. "@sina.com" $ cFrom + cHost := "smtp.vip.sina.com" + CASE cHost == "uol" .OR. "@uol.com.br" $ cFrom + cHost := "smtps.uol.com.br" + CASE cHost == "yahoo" .OR. "@yahoo.com" $ cFrom + cHost := "smtp.mail.yahoo.com" + CASE ":" $ cHost + IF TUrl():New( cHost ):nPort != -1 + nPort := TUrl():New( cHost ):nPort + ENDIF + lSTARTTLS := ( nPort == 587 ) + cHost := TUrl():New( cHost ):cServer + ENDCASE + + hb_default( @nPort, iif( lSTARTTLS, 587, 465 ) ) + + ? "Host:", cHost, hb_ntos( nPort ), iif( lSTARTTLS, "(STARTTLS)", "" ) + + ? tip_MailSend( ; + cHost, ; + nPort, ; + cFrom, ; + cTo, ; + NIL /* CC */, ; + {} /* BCC */, ; + "test: body", ; + "test: subject", ; + NIL /* attachment */, ; + cFrom, ; + cPassword, ; + "", ; + NIL /* nPriority */, ; + NIL /* lRead */, ; + .T. /* lTrace */, ; + .F., ; + NIL /* lNoAuth */, ; + NIL /* nTimeOut */, ; + NIL /* cReplyTo */, ; + nPort == 465 ) + + RETURN diff --git a/contrib/hbtip/tests/ftp_adv.prg b/contrib/hbtip/tests/ftp_adv.prg new file mode 100644 index 0000000000..2cf645dc23 --- /dev/null +++ b/contrib/hbtip/tests/ftp_adv.prg @@ -0,0 +1,65 @@ +/* TIP FTP advanced operations test */ + +#require "hbtip" + +#include "directry.ch" + +PROCEDURE Main( cURL ) + + LOCAL oFTP, oURL, aFile + + IF Empty( oURL := TUrl():New( cURL ) ) + ? "Invalid URL", cURL + RETURN + ENDIF + + IF ! oURL:cProto == "ftp" + ? "This is a 'DELE' test for FTP." + ? "Use an FTP address with a file that you can delete." + RETURN + ENDIF + + Set( _SET_DATEFORMAT, "yyyy-mm-dd" ) + + oFTP := TIPClientFTP():New( oURL ) + oFTP:nConnTimeout := 20000 + ? "Connecting with", oURL:cServer + IF oFTP:Open( cURL ) + ? "Connection established" + ? "File listing" + FOR EACH aFile IN oFTP:ListFiles() + IF aFile:__enumIndex() > 10 + ? "Skipping the rest..." + EXIT + ENDIF + ? aFile[ F_DATE ], Str( aFile[ F_SIZE ], 10 ), aFile[ F_NAME ] + NEXT + IF oFTP:CWD( oURL:cPath ) + ? "CWD success" + IF ! Empty( oURL:cFile ) + ? "Deleting", oURL:cPath + IF oFTP:Dele( oURL:cFile ) + ? "DELE success" + ELSE + ? "DELE failure (server reply:", oFTP:cReply + ")" + ENDIF + ENDIF + ELSE + ? "CWD failure (server reply:", oFTP:cReply + ")" + ENDIF + + oFTP:Close() + ELSE + ? "Could not connect with", oURL:cServer + IF oFTP:SocketCon == NIL + ? "Connection not initiated" + ELSEIF hb_inetErrorCode( oFTP:SocketCon ) == 0 + ? "Server replied:", oFTP:cReply + ELSE + ? "Error in connection:", hb_inetErrorDesc( oFTP:SocketCon ) + ENDIF + ENDIF + + ? "Done" + + RETURN diff --git a/contrib/hbtip/tests/ftp_dl.prg b/contrib/hbtip/tests/ftp_dl.prg new file mode 100644 index 0000000000..6db6c67ad9 --- /dev/null +++ b/contrib/hbtip/tests/ftp_dl.prg @@ -0,0 +1,47 @@ +/* Download a file from an FTP server */ + +#require "hbtip" + +PROCEDURE Main( cURL, ... ) + + LOCAL lRetVal := .T. + + LOCAL aFiles, cFile + LOCAL oFTP, oURL + + /* fetch files to transfer */ + IF ! Empty( aFiles := { ... } ) + + hb_default( @cURL, "ftp://user:pass@ftp.example.com" ) + + oURL := TUrl():New( cURL ) + + oFTP := TIPClientFTP():New( oURL, .T. ) + oFTP:nConnTimeout := 20000 + oFTP:bUsePasv := .T. + + IF oFTP:Open( cURL ) + FOR EACH cFile IN aFiles + ? "Filename:", cFile + IF ! oFtp:DownloadFile( cFile ) + lRetVal := .F. + EXIT + ENDIF + NEXT + oFTP:Close() + ELSE + ? "Could not connect to FTP server", oURL:cServer + IF oFTP:SocketCon == NIL + ? "Connection not initialized" + ELSEIF hb_inetErrorCode( oFTP:SocketCon ) == 0 + ? "Server response:", oFTP:cReply + ELSE + ? "Error in connection:", hb_inetErrorDesc( oFTP:SocketCon ) + ENDIF + lRetVal := .F. + ENDIF + ENDIF + + ErrorLevel( iif( lRetVal, 0, 1 ) ) + + RETURN diff --git a/contrib/hbtip/tests/ftp_ul.prg b/contrib/hbtip/tests/ftp_ul.prg new file mode 100644 index 0000000000..3f260f85e5 --- /dev/null +++ b/contrib/hbtip/tests/ftp_ul.prg @@ -0,0 +1,49 @@ +/* Upload a file or files to FTP server */ + +#require "hbtip" + +#include "directry.ch" + +PROCEDURE Main( cURL, cMask ) + + LOCAL lRetVal := .T. + + LOCAL aFiles, aFile + LOCAL oFTP, oURL + + /* fetch files to transfer */ + IF ! Empty( aFiles := hb_vfDirectory( hb_defaultValue( cMask, hb_osFileMask() ) ) ) + + hb_default( @cURL, "ftp://user:pass@ftp.example.com" ) + + oURL := TUrl():New( cURL ) + + oFTP := TIPClientFTP():New( oURL, .T. ) + oFTP:nConnTimeout := 20000 + oFTP:bUsePasv := .T. + + IF oFTP:Open( cURL ) + FOR EACH aFile IN aFiles + ? "Filename:", aFile[ F_NAME ] + IF ! oFtp:UploadFile( aFile[ F_NAME ] ) + lRetVal := .F. + EXIT + ENDIF + NEXT + oFTP:Close() + ELSE + ? "Could not connect to FTP server", oURL:cServer + IF oFTP:SocketCon == NIL + ? "Connection not initialized" + ELSEIF hb_inetErrorCode( oFTP:SocketCon ) == 0 + ? "Server response:", oFTP:cReply + ELSE + ? "Error in connection:", hb_inetErrorDesc( oFTP:SocketCon ) + ENDIF + lRetVal := .F. + ENDIF + ENDIF + + ErrorLevel( iif( lRetVal, 0, 1 ) ) + + RETURN diff --git a/contrib/hbtip/tests/ftpadv.prg b/contrib/hbtip/tests/ftpadv.prg deleted file mode 100644 index b926545ce7..0000000000 --- a/contrib/hbtip/tests/ftpadv.prg +++ /dev/null @@ -1,58 +0,0 @@ -/****************************************** - * TIP test - * FTP Advanced operations Test - ******************************************/ - -#require "hbtip" - -PROCEDURE Main( cUrl ) - - LOCAL oCon, oUrl - - oUrl := TUrl():New( cUrl ) - IF Empty( oUrl ) - ? "Invalid url " + cUrl - ? - QUIT - ENDIF - - IF oUrl:cProto != "ftp" - ? "This is a 'DELE' test for ftp." - ? "Use an ftp address with a file that you can delete." - ? - QUIT - ENDIF - - oCon := TIPClientFTP():New( oUrl ) - oCon:nConnTimeout := 20000 - ? "Connecting with", oUrl:cServer - IF oCon:Open( cUrl ) - ? "Connection eshtablished" - ? "Deleting", oUrl:cPath - IF oCon:CWD( oUrl:cPath ) - ? "CWD success" - IF oCon:Dele( oUrl:cFile ) - ? "DELE success" - ELSE - ? "DELE Faliure (server reply:", oCon:cReply + ")" - ENDIF - ELSE - ? "CWD Faliure (server reply:", oCon:cReply + ")" - ENDIF - - oCon:Close() - ELSE - ? "Can't connect with", oUrl:cServer - IF oCon:SocketCon == NIL - ? "Connection not initiated" - ELSEIF hb_inetErrorCode( oCon:SocketCon ) == 0 - ? "Server sayed:", oCon:cReply - ELSE - ? "Error in connection:", hb_inetErrorDesc( oCon:SocketCon ) - ENDIF - ENDIF - - ? "Done" - ? - - RETURN diff --git a/contrib/hbtip/tests/gmail.hbp b/contrib/hbtip/tests/gmail.hbp deleted file mode 100644 index 6aef46fac3..0000000000 --- a/contrib/hbtip/tests/gmail.hbp +++ /dev/null @@ -1,3 +0,0 @@ -gmail.prg - -hbssl.hbc diff --git a/contrib/hbtip/tests/gmail.prg b/contrib/hbtip/tests/gmail.prg deleted file mode 100644 index 6046aeb1ea..0000000000 --- a/contrib/hbtip/tests/gmail.prg +++ /dev/null @@ -1,50 +0,0 @@ -/* - * Copyright 2009 Viktor Szakats (vszakats.net/harbour) - * - * Gmail work with ssl on port 465 and with tls on port 587 - * tls mode is fully automatic and require that ssl must be disabled at first (We will activate it on request after STARTTLS command) - */ - -#require "hbssl" -#require "hbtip" - -REQUEST __HBEXTERN__HBSSL__ - -#include "simpleio.ch" - -PROCEDURE Main( cFrom, cPassword, cTo, cPort) - - IF ! tip_SSL() - ? "Error: Requires SSL support" - RETURN - ENDIF - - hb_default( @cFrom , "" ) - hb_default( @cPassword, "" ) - hb_default( @cTo , "addressee@domain.com" ) - hb_default( @cPort , "465" ) - - ? hb_SendMail( ; - "smtp.gmail.com", ; - Val(cPort), ; - cFrom, ; - cTo, ; - NIL /* CC */, ; - {} /* BCC */, ; - "test: body", ; - "test: port "+cPort, ; - NIL /* attachment */, ; - cFrom, ; - cPassword, ; - "", ; - NIL /* nPriority */, ; - NIL /* lRead */, ; - .T. /* lTrace */, ; - .F., ; - NIL /* lNoAuth */, ; - NIL /* nTimeOut */, ; - NIL /* cReplyTo */, ; - iif(cPort=="465",.T.,.F.) /* lSSL */ ) - - RETURN - diff --git a/contrib/hbtip/tests/hbmk.hbm b/contrib/hbtip/tests/hbmk.hbm index 74f666b917..bab771ab13 100644 --- a/contrib/hbtip/tests/hbmk.hbm +++ b/contrib/hbtip/tests/hbmk.hbm @@ -1,3 +1,5 @@ hbtip.hbc +hbssl.hbc +hbtest.hbc -w3 -es2 diff --git a/contrib/hbtip/tests/http_adv.prg b/contrib/hbtip/tests/http_adv.prg new file mode 100644 index 0000000000..1dd2be3f9f --- /dev/null +++ b/contrib/hbtip/tests/http_adv.prg @@ -0,0 +1,61 @@ +/* TIP HTTP advanced operations test */ + +#require "hbssl" +#require "hbtip" + +#if ! defined( __HBSCRIPT__HBSHELL ) +REQUEST __HBEXTERN__HBSSL__ +#endif + +PROCEDURE Main( cURL ) + + LOCAL oHTTP, oURL, i + + IF Empty( oURL := TUrl():New( cURL ) ) + ? "Invalid URL", cURL + RETURN + ENDIF + + IF ! oURL:cProto == "http" .AND. ; + ! oURL:cProto == "https" + ? "This is a header test for http/https." + ? "Use an http/https address." + RETURN + ENDIF + + IF oURL:cProto == "https" .AND. ! tip_SSL() + ? "Error: Requires SSL support" + RETURN + ENDIF + + oHTTP := TIPClientHTTP():New( oURL ) + oHTTP:nConnTimeout := 20000 + ? "Connecting with", oURL:cServer + IF oHTTP:Open( cURL ) + ? "Connection eshtablished" + ? "Retrieving", oURL:cPath, oURL:cFile, oURL:cQuery + + IF oHTTP:Get( oURL:cPath ) + ? "Get Successful" + FOR EACH i IN oHTTP:hHeaders + ? i:__enumKey() + ":", i + NEXT + ELSE + ? "Get failure (server reply:", oHTTP:cReply, ")" + ENDIF + + oHTTP:Close() + ELSE + ? "Could not connect with", oURL:cServer + IF oHTTP:SocketCon == NIL + ? "Connection not initiated" + ELSEIF hb_inetErrorCode( oHTTP:SocketCon ) == 0 + ? "Server replied:", oHTTP:cReply + ELSE + ? "Error in connection:", hb_inetErrorDesc( oHTTP:SocketCon ) + ENDIF + ENDIF + + ? "Done" + + RETURN diff --git a/contrib/hbtip/tests/http_cli.prg b/contrib/hbtip/tests/http_cli.prg new file mode 100644 index 0000000000..de8ad23a41 --- /dev/null +++ b/contrib/hbtip/tests/http_cli.prg @@ -0,0 +1,33 @@ +#require "hbssl" +#require "hbtip" + +#if ! defined( __HBSCRIPT__HBSHELL ) +REQUEST __HBEXTERN__HBSSL__ +#endif + +PROCEDURE Main( cProxy ) + + LOCAL cURL := iif( tip_SSL(), "https", "http" ) + "://example.com/" + LOCAL oHTTP := TIPClientHTTP():New( cURL, .T. ) + + ? "Proxy:", cProxy + ? "URL:", cURL + + IF HB_ISSTRING( cProxy ) + oHTTP:setProxy( TUrl():New( cProxy ) ) + ENDIF + oHTTP:setCookie( "test01=value01" ) + + IF oHTTP:Open() + IF oHTTP:Post( "test" ) + ? oHTTP:cReply + ? hb_ValToExp( oHTTP:hHeaders ) + ELSE + ? "Error:", "oHTTP:Post()", oHTTP:lastErrorMessage() + ENDIF + oHTTP:Close() + ELSE + ? "Error:", "oHTTP:Open()", oHTTP:lastErrorMessage() + ENDIF + + RETURN diff --git a/contrib/hbtip/tests/http_qry.prg b/contrib/hbtip/tests/http_qry.prg new file mode 100644 index 0000000000..935f233951 --- /dev/null +++ b/contrib/hbtip/tests/http_qry.prg @@ -0,0 +1,46 @@ +/* Makes an internet search and displays the links from the response HTML page */ + +#require "hbssl" +#require "hbtip" + +#if ! defined( __HBSCRIPT__HBSHELL ) +REQUEST __HBEXTERN__HBSSL__ +#endif + +PROCEDURE Main() + + LOCAL cURL := iif( tip_SSL(), "https", "http" ) + "://duckduckgo.com/html/" + LOCAL oHTTP := TIPClientHTTP():New( cURL ) + LOCAL cHtml, oNode, oDoc + + ? "URL:", cURL + + /* build the search query and add it to the TUrl object */ + oHTTP:oURL:addGetForm( { ; + "q" => "Harbour+Project", ; + "kl" => "us-en" } ) + + /* Connect to the HTTP server */ + IF ! oHTTP:Open() + ? "Connection error:", oHTTP:lastErrorMessage() + RETURN + ENDIF + + /* download the response */ + cHtml := oHTTP:ReadAll() + oHTTP:Close() + ? hb_ntos( Len( cHtml ) ), "bytes received" + ? + + oDoc := THtmlDocument():New( cHtml ) + + oDoc:writeFile( "result.htm" ) + + /* "aS" is the plural of "a" and returns all tags */ + FOR EACH oNode IN oDoc:body:div( "links" ):aS + IF oNode:class == "large" + ? tip_HtmlToStr( oNode:getText( "" ) ), oNode:href + ENDIF + NEXT + + RETURN diff --git a/contrib/hbtip/tests/httpadv.prg b/contrib/hbtip/tests/httpadv.prg deleted file mode 100644 index c2c6d6ab60..0000000000 --- a/contrib/hbtip/tests/httpadv.prg +++ /dev/null @@ -1,57 +0,0 @@ -/****************************************** - * TIP test - * HTTP Advanced operations Test - ******************************************/ - -#require "hbtip" - -PROCEDURE Main( cUrl ) - - LOCAL oCon, oUrl, i - - oUrl := TUrl():New( cUrl ) - IF Empty( oUrl ) - ? "Invalid url " + cUrl - ? - QUIT - ENDIF - - IF oUrl:cProto != "http" - ? "This is a header test for http." - ? "Use an http address." - ? - QUIT - ENDIF - - oCon := TIPClientHTTP():New( oUrl ) - oCon:nConnTimeout := 20000 - ? "Connecting with", oUrl:cServer - IF oCon:Open( cUrl ) - ? "Connection eshtablished" - ? "Retreiving", oUrl:cPath, oUrl:cFile, oUrl:cQuery - - IF oCon:Get( oUrl:cPath ) - ? "Get Sucessful" - FOR i := 1 TO Len( oCon:hHeaders ) - ? hb_HKeyAt( oCon:hHeaders, i ) + ":", hb_HValueAt( oCon:hHeaders, i ) - NEXT - ELSE - ? "Get failure (server reply:", oCon:cReply, ")" - ENDIF - - oCon:Close() - ELSE - ? "Can't connect with", oUrl:cServer - IF oCon:SocketCon == NIL - ? "Connection not initiated" - ELSEIF hb_inetErrorCode( oCon:SocketCon ) == 0 - ? "Server sayed:", oCon:cReply - ELSE - ? "Error in connection:", hb_inetErrorDesc( oCon:SocketCon ) - ENDIF - ENDIF - - ? "Done" - ? - - RETURN diff --git a/contrib/hbtip/tests/httpcli.prg b/contrib/hbtip/tests/httpcli.prg deleted file mode 100644 index 2b1e801f3e..0000000000 --- a/contrib/hbtip/tests/httpcli.prg +++ /dev/null @@ -1,24 +0,0 @@ -#require "hbtip" - -PROCEDURE Main() - - LOCAL oHttp - - CLS - - oHttp := TIPClientHTTP():New( "http://www.google.com", .T. ) - - oHttp:setCookie( "test01=value01" ) - - IF ! oHttp:open() - ? "Error: oHttp:open(): " + oHttp:lastErrorMessage() - RETURN - ENDIF - - IF ! oHttp:post( "test" ) - ? "Error: oHttp:post(): " + oHttp:lastErrorMessage() - ENDIF - - oHttp:close() - - RETURN diff --git a/contrib/hbtip/tests/loadhtml.prg b/contrib/hbtip/tests/loadhtml.prg deleted file mode 100644 index ff94e759c2..0000000000 --- a/contrib/hbtip/tests/loadhtml.prg +++ /dev/null @@ -1,53 +0,0 @@ -/* - * Sends a query to Google and displays the Links from the response HTML page - */ - -#require "hbtip" - -PROCEDURE Main() - - LOCAL oHttp, cHtml, hQuery, aLink, oNode, oDoc - - oHttp := TIPClientHTTP():new( "http://www.google.com/search" ) - - /* build the Google query */ - hQUery := { => } - hb_HCaseMatch( hQuery, .F. ) - - hQuery[ "q" ] := "Harbour" - hQuery[ "hl" ] := "en" - hQuery[ "btnG" ] := "Google+Search" - - /* add query data to the TUrl object */ - oHttp:oUrl:addGetForm( hQuery ) - - /* Connect to the HTTP server */ - IF ! oHttp:open() - ? "Connection error:", oHttp:lastErrorMessage() - QUIT - ENDIF - - /* download the Google response */ - cHtml := oHttp:readAll() - oHttp:close() - ? Len( cHtml ), "bytes received " - - oDoc := THtmlDocument():new( cHtml ) - - oDoc:writeFile( "google.html" ) - - /* ":a" retrieves the first text tag */ - oNode := oDoc:body:a - ? oNode:getText( "" ), oNode:href - - /* ":divs(5)" returns the 5th

tag */ - oNode := oDoc:body:divs( 5 ) - - /* "aS" is the plural of "a" and returns all tags */ - aLink := oNode:aS - - FOR EACH oNode IN aLink - ? tip_HtmlToStr( oNode:getText( "" ) ), oNode:href - NEXT - - RETURN diff --git a/contrib/hbtip/tests/mimetype.prg b/contrib/hbtip/tests/mimetype.prg index 0289c567bc..26821afcfb 100644 --- a/contrib/hbtip/tests/mimetype.prg +++ b/contrib/hbtip/tests/mimetype.prg @@ -1,29 +1,19 @@ -/****************************************** - * TIP test - * MIME type test - * - * This test tries to detect the mime type of a give file. - ******************************************/ +/* This test tries to detect the MIME type of a given file */ #require "hbtip" PROCEDURE Main( cFileName ) - IF Empty( cFileName ) - ? + IF ! HB_ISSTRING( cFileName ) ? hb_StrFormat( "Usage: %1$s ", hb_ProgName() ) + ELSEIF hb_vfExists( cFileName ) + ? cFileName ? - QUIT + ? "tip_MimeType()", tip_MimeType( hb_MemoRead( cFileName ), "application/octet-stream" ) + ? "tip_FileMimeType()", tip_FileMimeType( cFileName, "application/octet-stream" ) + ? "tip_FileNameMimeType()", tip_FileNameMimeType( cFileName, "application/octet-stream" ) + ELSE + ? "File", cFileName, "doesn't exist." ENDIF - IF ! hb_FileExists( cFileName ) - ? - ? "File", cFileName, "is not valid" - ? - QUIT - ENDIF - - ? cFileName + ":", tip_FileMimeType( cFileName ) - ? - RETURN diff --git a/contrib/hbtip/tests/test.prg b/contrib/hbtip/tests/test.prg new file mode 100644 index 0000000000..bcb82f71aa --- /dev/null +++ b/contrib/hbtip/tests/test.prg @@ -0,0 +1,12 @@ +/* Copyright 2014 Viktor Szakats (vszakats.net/harbour) */ + +#require "hbtip" +#require "hbtest" + +PROCEDURE Main() + + HBTEST tip_MimeType( "MZ" ) IS "application/x-dosexec" + HBTEST tip_MimeType( "hello" ) IS "unknown" + HBTEST tip_MimeType( "hello", "my-unknown" ) IS "my-unknown" + + RETURN diff --git a/contrib/hbtip/tests/timestmp.prg b/contrib/hbtip/tests/timestmp.prg index 696731c10f..a90b8f7574 100644 --- a/contrib/hbtip/tests/timestmp.prg +++ b/contrib/hbtip/tests/timestmp.prg @@ -1,6 +1,4 @@ -/* - * Copyright 2009 Viktor Szakats (vszakats.net/harbour) - */ +/* Copyright 2009 Viktor Szakats (vszakats.net/harbour) */ #require "hbtip" @@ -8,11 +6,11 @@ PROCEDURE Main() - ? ">" + tip_TimeStamp() + "<" - ? ">" + tip_TimeStamp( NIL, 200 ) + "<" - ? ">" + tip_TimeStamp( Date() ) + "<" - ? ">" + tip_TimeStamp( Date(), 200 ) + "<" - ? ">" + tip_TimeStamp( hb_DateTime() ) + "<" - ? ">" + tip_TimeStamp( hb_DateTime(), 200 ) + "<" + ? "'" + tip_TimeStamp() + "'" + ? "'" + tip_TimeStamp( NIL, 200 ) + "'" + ? "'" + tip_TimeStamp( Date() ) + "'" + ? "'" + tip_TimeStamp( Date(), 200 ) + "'" + ? "'" + tip_TimeStamp( hb_DateTime() ) + "'" + ? "'" + tip_TimeStamp( hb_DateTime(), 200 ) + "'" RETURN diff --git a/contrib/hbtip/tests/tipmail.prg b/contrib/hbtip/tests/tipmail.prg index 49f0533941..0c7677e65f 100644 --- a/contrib/hbtip/tests/tipmail.prg +++ b/contrib/hbtip/tests/tipmail.prg @@ -1,14 +1,9 @@ -/****************************************** - * TIP test - * Mail - reading and writing multipart mails +/* TIP Mail - reading and writing multipart mails * * Test for reading a multipart message (that must already * be in its canonical form, that is, line terminator is - * CRLF and it must have no headers other than SMTP/Mime). - * - * This test writes data to standard output, and is - * compiled only under GTCGI; - ******************************************/ + * CRLF and it must have no headers other than SMTP/MIME). + */ #require "hbtip" @@ -16,36 +11,36 @@ PROCEDURE Main( cFileName ) LOCAL oMail, cData, i - IF cFileName != NIL - cData := MemoRead( cFileName ) - IF FError() > 0 - ? "Can't open", cFileName - QUIT - ENDIF + IF ! HB_ISSTRING( cFileName ) .OR. ; + ( cData := hb_MemoRead( cFileName ) ) == "" + + ? "Cannot open", cFileName + RETURN ENDIF + oMail := TIPMail():New() IF oMail:FromString( cData ) == 0 ? "Malformed mail. Dumping up to where parsed" ENDIF - ? "-------------============== HEADERS =================--------------" - FOR i := 1 TO Len( oMail:hHeaders ) - ? hb_HKeyAt( oMail:hHeaders, i ), ":", hb_HValueAt( oMail:hHeaders, i ) + ? PadC( " HEADERS ", 60, "-" ) + FOR EACH i IN oMail:hHeaders + ? i:__enumKey(), ":", i NEXT ? - ? "-------------============== RECEIVED =================--------------" + ? PadC( " RECEIVED ", 60, "-" ) FOR EACH cData IN oMail:aReceived ? cData NEXT ? - ? "-------------============== BODY =================--------------" + ? PadC( " BODY ", 60, "-" ) ? oMail:GetBody() ? DO WHILE oMail:GetAttachment() != NIL - ? "-------------============== ATTACHMENT =================--------------" + ? PadC( " ATTACHMENT ", 60, "-" ) ? oMail:NextAttachment():GetBody() ? ENDDO @@ -53,6 +48,8 @@ PROCEDURE Main( cFileName ) ? "DONE" ? /* Writing stream */ - /* FWrite( 1, oMail:ToString() ) */ +#if 0 + OutStd( oMail:ToString() ) +#endif RETURN diff --git a/contrib/hbtip/tests/tipmmail.prg b/contrib/hbtip/tests/tipmmail.prg index a3b738e90d..68cd337193 100644 --- a/contrib/hbtip/tests/tipmmail.prg +++ b/contrib/hbtip/tests/tipmmail.prg @@ -1,129 +1,99 @@ -/****************************************** - * TIP test - * Mail - reading and writing multipart mails +/* TIP Mail - reading and writing multipart mails * * Creating a mail message. * This will create a valid mail message, using - * the set of files given in the command line. - * - * Usage: - * tipmmail [options] attachment1, attachment2... - * options: - * -h Help - * -f "from" Set "mail from" field - * -t "to" Set "mail to" field - * -s "subject" Set mail subject - * -b "body" Set mail body (or message) - * -m "bodyfile" Set mail body using a file - * - * - * This test writes data to standard output, and is - * compiled only under GTCGI; - ******************************************/ + * the set of files given in the command-line. + */ #require "hbtip" PROCEDURE Main( ... ) LOCAL oMail, cData, i, oAttach - LOCAL cFname, cFExt + LOCAL cFname IF PCount() == 0 Usage() - QUIT + RETURN ENDIF - oMail := TIPMail( "This is the body of the mail" ) + oMail := TIPMail():New( "This is the body of the mail" ) oMail:hHeaders[ "Content-Type" ] := "text/plain; charset=utf-8" oMail:hHeaders[ "Date" ] := tip_TimeStamp() - i := 1 - DO WHILE i < PCount() - cData := hb_PValue( i ) + FOR i := 1 TO PCount() - IF Lower( cData ) == "-h" + SWITCH Lower( cData := hb_PValue( i ) ) + CASE "-h" Usage() - QUIT - ENDIF - - IF Lower( cData ) == "-f" - i++ - cData := hb_PValue( i ) - IF cData != NIL + RETURN + CASE "-f" + IF HB_ISSTRING( cData := hb_PValue( ++i ) ) oMail:hHeaders[ "From" ] := hb_StrToUTF8( cData ) ENDIF - ELSEIF Lower( cData ) == "-t" - i++ - cData := hb_PValue( i ) - IF cData != NIL + EXIT + CASE "-t" + IF HB_ISSTRING( cData := hb_PValue( ++i ) ) oMail:hHeaders[ "To" ] := hb_StrToUTF8( cData ) ENDIF - ELSEIF Lower( cData ) == "-s" - i++ - cData := hb_PValue( i ) - IF cData != NIL + EXIT + CASE "-s" + IF HB_ISSTRING( cData := hb_PValue( ++i ) ) oMail:hHeaders[ "Subject" ] := hb_StrToUTF8( cData ) ENDIF - ELSEIF Lower( cData ) == "-b" - i++ - cData := hb_PValue( i ) - IF cData != NIL + EXIT + CASE "-b" + IF HB_ISSTRING( cData := hb_PValue( ++i ) ) oMail:SetBody( hb_StrToUTF8( cData ) + e"\r\n" ) ENDIF - ELSEIF Lower( cData ) == "-m" - i++ - cData := hb_PValue( i ) - IF cData != NIL - cData := MemoRead( cData ) - IF Empty( cData ) - ? "FATAL: Can't read", hb_PValue( i ) - QUIT + EXIT + CASE "-m" + IF HB_ISSTRING( cData := hb_PValue( ++i ) ) + IF ( cData := hb_MemoRead( cData ) ) == "" + ? "Fatal: Could not read", hb_PValue( i ) + RETURN ENDIF oMail:SetBody( cData + e"\r\n" ) ENDIF - ELSE // it is an attachment file - cData := MemoRead( cData ) - IF Empty( cData ) - ? "FATAL: Can't read attachment", hb_PValue( i ) - QUIT + EXIT + OTHERWISE // it is an attachment file + IF ( cData := hb_MemoRead( cData ) ) == "" + ? "Fatal: Could not read attachment or attachment empty", hb_PValue( i ) + RETURN ENDIF - oAttach := TIPMail():New() + oAttach := TIPMail():New() oAttach:SetEncoder( "base64" ) // TODO: mime type magic auto-finder - hb_FNameSplit( hb_PValue( i ), , @cFname, @cFext ) + cFName := hb_FNameNameExt( hb_PValue( i ) ) // Some EMAIL readers use Content-Type to check for filename oAttach:hHeaders[ "Content-Type" ] := ; - "application/X-TIP-Attachment; filename="; - + cFname + cFext + "application/X-TIP-Attachment; filename=" + cFName // But usually, original filename is set here oAttach:hHeaders[ "Content-Disposition" ] := ; - "attachment; filename=" + cFname + cFext + "attachment; filename=" + cFname oAttach:SetBody( cData ) oMail:Attach( oAttach ) - ENDIF - - i++ - ENDDO + ENDSWITCH + NEXT /* Writing stream */ - FWrite( 1, oMail:ToString() ) + OutStd( oMail:ToString() ) RETURN -PROCEDURE Usage() +STATIC PROCEDURE Usage() ? "Usage:" - ? "testmmail [options] attachment1, attachment2..." - ? " options:" - ? " -h Help" - ? ' -f "from" Set "mail from" field' - ? ' -t "to" Set "mail to" field' - ? ' -s "subject" Set mail subject' - ? ' -b "body" Set mail body (or message)' - ? ' -m "bodyfile" Set mail body using a file' - ? + ? " tipmmail [options] attachment1, attachment2..." + ? "Options:" + ? " -h Help" + ? ' -f "from" Set "mail from" field' + ? ' -t "to" Set "mail to" field' + ? ' -s "subject" Set mail subject' + ? ' -b "body" Set mail body (or message)' + ? ' -m "bodyfile" Set mail body using a file' ? RETURN diff --git a/contrib/hbtip/tests/tipwget.prg b/contrib/hbtip/tests/tipwget.prg index 749aa4df29..9b7824a5e9 100644 --- a/contrib/hbtip/tests/tipwget.prg +++ b/contrib/hbtip/tests/tipwget.prg @@ -1,168 +1,150 @@ -/***************************************************** - * TEST of TIP libs (for higher level URI interface) +/* TEST of TIP libs (for higher level URI interface) * * Usage: This file is similar to a wget command * - * Without the filename, tiptest will be in demo mode, + * Without the filename, tipwget will be in demo mode, * just demostrating it is working * * With the filename, data will be stored to the file or * retrieved from the file and sent to internet. * * Usage of URI. - * HTTP Protocol - * http:///? + * HTTP[S] Protocol + * http[s]:///? * - at the moment HTTP URI is not able to send data, - * (e.g. a form) + * (f.e. a form) * - * POP Protocol - * pop://:@/[-][MsgNum] - * - Witout MsgNum, you get the list of messages + * POP[S] Protocol + * pop[s]://:@/[-][MsgNum] + * - Without MsgNum, you get the list of messages * - With MsgNum get Message MsgNum * - With -MsgNum deletes message MsgNum * - * SMTP Protocol - * smtp://@/RCPT + * SMTP[S] Protocol + * smtp[s]://@/RCPT * - (You have to provide a filename) * - use &at; in mail-from message - * - Send the letter in filename (that must include - * headers) to RCPT e.f. - * stmp://user&at;myprovider.com@smtp.myprovider.com/gian@niccolai.ws + * - Send the mail in filename (that must include + * headers) to RCPT f.e. + * stmp[s]://user&at;example.com@smtp.example.com/gian@niccolai.ws * - * NOTE: In Unix, to use '&' from command line you have to surround - * the url with "", eg "smtp://...&at;...@server/dest" + * NOTE: In Unix, to use '&' from command-line you have to surround + * the URL with "", f.e. "smtp[s]://...&at;...@server/dest" * - * FTP Protocol - * ftp://user:passwd@/[] + * FTP[S] Protocol + * ftp[s]://user:passwd@/[] * - without path, get the list of files (use path/ to get the list of * files in a dir. * - with path, get a file. If the target file (second param) starts with '+' * it will be sent instead of being retrieved. - *****************************************************/ + */ +#require "hbssl" #require "hbtip" +#if ! defined( __HBSCRIPT__HBSHELL ) +REQUEST __HBEXTERN__HBSSL__ +#endif + #include "hbclass.ch" +#include "inkey.ch" #include "tip.ch" -PROCEDURE Main( cUrl, cFile ) +PROCEDURE Main( cURL, cFile ) LOCAL bWrite := .F. - LOCAL oUrl, oClient + LOCAL oURL, oClient LOCAL cData - CLS - @ 1, 6 SAY "X H A R B O U R - TIP (class based internet client protocol) test" + ? "Harbour - TIP (class based internet client protocol) test" - IF Empty( cUrl ) - @ 4, 5 SAY hb_StrFormat( "USAGE: %1$s [dumpToOrFromFileName]", hb_ProgName() ) - Terminate() + IF ! HB_ISSTRING( cURL ) .OR. Empty( cURL ) + ? hb_StrFormat( "Usage: %1$s [dumpToOrFromFileName]", hb_ProgName() ) + RETURN ENDIF - oUrl := TUrl():New( cUrl ) - IF Empty( oUrl ) - @ 4, 5 SAY "Invalid url " + cUrl - Terminate() + IF Empty( oURL := TUrl():New( cURL ) ) + ? "Invalid URL", cURL + RETURN ENDIF - DO CASE - CASE Lower( oUrl:cProto ) == "ftp" - oClient := TIPClientFTP():new( oUrl ) - - CASE Lower( oUrl:cProto ) == "http" - oClient := TIPClientHTTP():new( oUrl ) - - CASE Lower( oUrl:cProto ) == "pop" - oClient := TIPClientPOP():new( oUrl ) - - CASE Lower( oUrl:cProto ) == "smtp" - oClient := TIPClientSMTP():new( oUrl ) - - ENDCASE + SWITCH Lower( oURL:cProto ) + CASE "ftp" + oClient := TIPClientFTP():New( oURL ) + EXIT + CASE "http" + CASE "https" + oClient := TIPClientHTTP():New( oURL ) + EXIT + CASE "pop" + CASE "pops" + oClient := TIPClientPOP():New( oURL ) + EXIT + CASE "smtp" + CASE "smtps" + oClient := TIPClientSMTP():New( oURL ) + EXIT + ENDSWITCH IF Empty( oClient ) - @ 4, 5 SAY "Invalid url " + cUrl - Terminate() + ? "Invalid URL", cURL + RETURN ENDIF - oClient:nConnTimeout := 2000 /* := 20000 */ + oClient:nConnTimeout := 2000 /* 20000 */ + oURL:cUserid := StrTran( oURL:cUserid, "&at;", "@" ) - oUrl:cUserid := StrTran( oUrl:cUserid, "&at;", "@" ) - - @ 4, 5 SAY "Connecting to " + oUrl:cProto + "://" + oUrl:cServer + ? "Connecting to", oURL:cProto + "://" + oURL:cServer IF oClient:Open() - IF Empty( oClient:cReply ) - @ 5, 5 SAY "Connection status: " - ELSE - @ 5, 5 SAY "Connection status: " + oClient:cReply - ENDIF + ? "Connection status:", iif( Empty( oClient:cReply ), "", oClient:cReply ) - IF ! Empty( cFile ) .AND. Left( cFile, 1 ) == "+" + IF HB_ISSTRING( cFile ) .AND. hb_LeftEq( cFile, "+" ) cFile := SubStr( cFile, 2 ) bWrite := .T. ENDIF + ? + oClient:exGauge := {| done, size | ShowGauge( done, size ) } +#if 0 + /* Can be also: */ + oClient:exGauge := {| done, size, oConnection | dothing( done, size, oConnection ) } +#endif + IF oClient:nAccessMode == TIP_WO .OR. ( oClient:nAccessMode == TIP_RW .AND. bWrite ) - oClient:exGauge := {| done, size | ShowGauge( done, size ) } - /* Can be also: - oClient:exGauge := {| done, size, oConnection | dothing( done, size, oConnection ) } - */ IF oClient:WriteFromFile( cFile ) - @ 7, 5 SAY "Data sucessfully sent" + ? "Data successfully sent" ELSE - @ 7, 5 SAY "ERROR: Data not sent " + oClient:lastErrorMessage() + ? "Error: Data not sent", oClient:lastErrorMessage() ENDIF ELSE - IF Empty( cFile ) - cData := oClient:Read() - IF ! Empty( cData ) - @ 7, 5 SAY "First 80 characters:" - ? RTrim( SubStr( cData, 1, 80 ) ) + IF HB_ISSTRING( cFile ) + IF ( cData := oClient:Read() ) == "" + ? "Error: file could not be retrieved", oClient:lastErrorMessage() ELSE - @ 7, 5 SAY "ERROR - file can't be retrieved " + oClient:lastErrorMessage() + ? "First 80 characters:", hb_ValToExp( hb_BLeft( cData, 80 ) ) ) ENDIF + ELSEIF oClient:ReadToFile( cFile ) + ? "File", cFile, "written." + ? "Server replied", oClient:cReply ELSE - IF oClient:ReadToFile( cFile ) - @ 7, 5 SAY "File " + cFile + " written." - @ 8, 5 SAY "Server replied " + oClient:cReply - ELSE - @ 7, 5 SAY "Generic error in writing." + cFile - ENDIF + ? "Error: Generic error in writing", cFile ENDIF ENDIF oClient:Close() - IF Empty( oClient:cReply ) - @ 22, 5 SAY "Done: (no goodbye message)" - ELSE - @ 22, 5 SAY "Done: " + oClient:cReply - ENDIF + ? "Done:", iif( Empty( oClient:cReply ), "(no goodbye message)", oClient:cReply ) ELSE - @ 5, 5 SAY "Can't open URI " + cUrl + ? "Could not open URI", cURL IF ! Empty( oClient:cReply ) - @ 6, 5 SAY oClient:cReply + ? oClient:cReply ENDIF ENDIF - Terminate() - RETURN -PROCEDURE Terminate() +STATIC FUNCTION ShowGauge( nSent, nSize ) - @ 23, 18 SAY "Program done - Press a key to terminate" - Inkey( 0 ) - @ 24, 0 - QUIT + SetPos( Row(), 0 ) + ?? "Sending:", nSent, "/", nSize - RETURN - -PROCEDURE ShowGauge( nSent, nSize ) - - @ 6, 5 SAY "Sending: " + Replicate( hb_UTF8ToStr( "░" ), 60 ) - /* nSent may be zero */ - IF nSent > 0 - @ 6, 14 SAY Replicate( hb_UTF8ToStr( "█" ), 60 * nSent / nSize ) - ENDIF - - RETURN + RETURN hb_keyStd( Inkey() ) != K_ESC diff --git a/contrib/hbtip/tests/upld_ftp.prg b/contrib/hbtip/tests/upld_ftp.prg deleted file mode 100644 index 717b21943e..0000000000 --- a/contrib/hbtip/tests/upld_ftp.prg +++ /dev/null @@ -1,82 +0,0 @@ -/* - * Send an file or list of files to ftp server - */ - -#require "hbtip" - -#include "directry.ch" - -PROCEDURE Main( cMask ) - - ? TRP20FTPEnv( cMask ) - - RETURN - -/********************************************************************** - * - * Static Function TRP20FTPEnv() - * - **********************************************************************/ - -STATIC FUNCTION TRP20FTPEnv( cCarpeta ) - - LOCAL aFiles - LOCAL cUrl - LOCAL cStr - LOCAL lRetVal := .T. - LOCAL oUrl - LOCAL oFTP - LOCAL cUser - LOCAL cServer - LOCAL cPassword - LOCAL cFile := "" - - cServer := "ftpserver" /* change ftpserver to the real name or ip of your ftp server */ - cUser := "ftpuser" /* change ftpuser to an valid user on ftpserer */ - cPassword := "ftppass" /* change ftppass to an valid password for ftpuser */ - cUrl := "ftp://" + cUser + ":" + cPassword + "@" + cServer - - /* Leemos ficheros a enviar */ - aFiles := Directory( cCarpeta ) - - IF Len( aFiles ) > 0 - - oUrl := TUrl():New( cUrl ) - oFTP := TIPClientFTP():New( oUrl, .T. ) - oFTP:nConnTimeout := 20000 - oFTP:bUsePasv := .T. - - /* Comprobamos si el usuario contiene una @ para forzar el userid */ - IF At( "@", cUser ) > 0 - oFTP:oUrl:cServer := cServer - oFTP:oUrl:cUserID := cUser - oFTP:oUrl:cPassword := cPassword - ENDIF - - IF oFTP:Open( cUrl ) - FOR EACH cFile IN afiles - ? "Filename: " + cFile[ F_NAME ] - IF ! oFtp:UploadFile( cFile[ F_NAME ] ) - lRetVal := .F. - EXIT - ELSE - lRetVal := .T. - ENDIF - - NEXT - oFTP:Close() - ELSE - cStr := "Could not connect to FTP server " + oURL:cServer - IF oFTP:SocketCon == NIL - cStr += hb_eol() + "Connection not initialized" - ELSEIF hb_inetErrorCode( oFTP:SocketCon ) == 0 - cStr += hb_eol() + "Server response:" + " " + oFTP:cReply - ELSE - cStr += hb_eol() + "Error in connection:" + " " + hb_inetErrorDesc( oFTP:SocketCon ) - ENDIF - ? cStr - lRetVal := .F. - ENDIF - ENDIF - - RETURN lRetVal diff --git a/contrib/hbtip/tests/url.prg b/contrib/hbtip/tests/url.prg new file mode 100644 index 0000000000..4a8d5752db --- /dev/null +++ b/contrib/hbtip/tests/url.prg @@ -0,0 +1,21 @@ +/* Copyright 2016 Viktor Szakats (vszakats.net/harbour) */ + +#require "hbtip" + +#include "simpleio.ch" + +PROCEDURE Main( cURL ) + + LOCAL oURL := TURL():New( hb_defaultValue( cURL, "https://user:passwd@example.com:443/mypages/mysite/page.html?avar=0&avar1=1" ) ) + + ? "cAddress" , oURL:cAddress + ? "cProto" , oURL:cProto + ? "cUserid" , oURL:cUserid + ? "cPassword" , oURL:cPassword + ? "cServer" , oURL:cServer + ? "cPath" , oURL:cPath + ? "cQuery" , oURL:cQuery + ? "cFile" , oURL:cFile + ? "nPort" , oURL:nPort + + RETURN diff --git a/contrib/hbtip/thtml.ch b/contrib/hbtip/thtml.ch index d39e24ebdd..8d401a612c 100644 --- a/contrib/hbtip/thtml.ch +++ b/contrib/hbtip/thtml.ch @@ -48,7 +48,7 @@ #define _HB_THTML /* Content model shortcut encoding taken from Tidy library - http://www.html-tidy.org */ + http://www.html-tidy.org/ */ #define CM_UNKNOWN 0 #define CM_EMPTY 0x000001 /* Elements with no content. Map to HTML specification. */ diff --git a/contrib/hbtip/thtml.prg b/contrib/hbtip/thtml.prg index be18e318f6..dd5ae8d75e 100644 --- a/contrib/hbtip/thtml.prg +++ b/contrib/hbtip/thtml.prg @@ -51,55 +51,51 @@ // The current implementation of FOR EACH is not suitable for the HTML classes // 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_PARSER( ) => { , 0, Len( ), 0 } +#xtrans :p_str => \[ 1 ] // the string to parse +#xtrans :p_pos => \[ 2 ] // current parser position +#xtrans :p_len => \[ 3 ] // length of string +#xtrans :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:=hb_At(,:p_str,:p_end+1)) -#xtrans P_SEEKI( , ) => (:p_end:=:p_pos, :p_pos:=hb_AtI(,:p_str,:p_end+1)) -#xtrans P_PEEK( , ) => (:p_end:=:p_pos, __tip_PStrCompI( :p_str, :p_pos, )) -#xtrans P_NEXT( ) => (:p_end:=:p_pos, SubStr(:p_str,++:p_pos,1)) -#xtrans P_PREV( ) => (:p_end:=:p_pos, SubStr(:p_str,--:p_pos,1)) +#xtrans P_SEEK( , ) => ( :p_end := :p_pos, :p_pos := hb_At( , :p_str, :p_end + 1 ) ) +#xtrans P_SEEKI( , ) => ( :p_end := :p_pos, :p_pos := hb_AtI( , :p_str, :p_end + 1 ) ) +#xtrans P_PEEK( , ) => ( :p_end := :p_pos, hb_LeftEqI( SubStr( :p_str, :p_pos ), ) ) +#xtrans P_NEXT( ) => ( :p_end := :p_pos, SubStr( :p_str, ++:p_pos, 1 ) ) +#xtrans P_PREV( ) => ( :p_end := :p_pos, SubStr( :p_str, --:p_pos, 1 ) ) // 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 +#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]]) +#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]] ) -THREAD STATIC t_aHtmlAttr // data for HTML attributes -THREAD STATIC t_hTagTypes // data for HTML tags +THREAD STATIC t_aHA // data for HTML attributes +THREAD STATIC t_hHT // data for HTML tags THREAD STATIC t_cHtmlCP := "" -THREAD STATIC t_aHtmlEntities // HTML character entities -THREAD STATIC t_aHtmlAnsiEntities // HTML character entities (ANSI character set) -THREAD STATIC t_lInit := .F. // initilization flag for HTML data +THREAD STATIC t_aHtmlUnicEntities // HTML character entities +THREAD STATIC t_cHtmlUnicChars +#ifdef HB_LEGACY_LEVEL4 +THREAD STATIC t_aHtmlAnsiEntities // HTML character entities (ANSI character set) +THREAD STATIC t_cHtmlAnsiChars +#endif +THREAD STATIC t_lInit := .F. // initilization flag for HTML data -// #define _DEBUG_ #ifdef _DEBUG_ -#xtranslate HIDDEN: => EXPORTED: // debugger can't see HIDDEN iVars +#xtranslate HIDDEN: => EXPORTED: // debugger cannot see HIDDEN iVars #endif -/* - * Class for handling an entire HTML document - */ +/* Class for handling an entire HTML document */ CREATE CLASS THtmlDocument MODULE FRIENDLY HIDDEN: @@ -127,12 +123,12 @@ CREATE CLASS THtmlDocument MODULE FRIENDLY ENDCLASS // accepts a HTML formatted string - METHOD new( cHtmlString ) CLASS THtmlDocument - LOCAL cEmptyHtmlDoc, oNode, oSubNode, oErrNode, aHead, aBody, nMode := 0 + LOCAL oSubNode, oErrNode, aHead, aBody, nMode := 0 - cEmptyHtmlDoc := '' + hb_eol() + ; + LOCAL cEmptyHtmlDoc := ; + "" + hb_eol() + ; "" + hb_eol() + ; " " + hb_eol() + ; " " + hb_eol() + ; @@ -142,13 +138,11 @@ METHOD new( cHtmlString ) CLASS THtmlDocument IF ! HB_ISSTRING( cHtmlString ) ::root := THtmlNode():new( cEmptyHtmlDoc ) + ELSEIF " source\rtl\txml.prg) - */ +/* Abstract super class for THtmlIteratorScan and THtmlIteratorScanRegEx + (Adopted from TXMLIterator -> contrib/xhb/txml.prg) */ CREATE CLASS THtmlIterator MODULE FRIENDLY @@ -350,14 +331,13 @@ CREATE CLASS THtmlIterator MODULE FRIENDLY 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 + ::oNode := oHtml ::aNodes := ::oNode:collect() ENDIF @@ -421,7 +401,7 @@ METHOD Next() CLASS THtmlIterator LOCAL oFound, lExit := .F. DO WHILE ! lExit - BEGIN SEQUENCE WITH {| oErr | Break( oErr ) } + BEGIN SEQUENCE WITH __BreakBlock() oFound := ::aNodes[ ++::nCurrent ] IF ::MatchCriteria( oFound ) ::oNode := oFound @@ -437,14 +417,11 @@ METHOD Next() CLASS THtmlIterator RETURN oFound METHOD MatchCriteria() CLASS THtmlIterator - RETURN .T. -/******************************************** - Iterator scan class -*********************************************/ +/* Iterator scan class */ -CLASS THtmlIteratorScan FROM THtmlIterator MODULE FRIENDLY +CREATE CLASS THtmlIteratorScan INHERIT THtmlIterator MODULE FRIENDLY METHOD New( oNodeTop ) CONSTRUCTOR @@ -464,11 +441,11 @@ METHOD MatchCriteria( oFound ) CLASS THtmlIteratorScan LOCAL xData - IF ::cName != NIL .AND. !( Lower( ::cName ) == Lower( oFound:htmlTagName ) ) + IF ::cName != NIL .AND. ! Lower( ::cName ) == Lower( oFound:htmlTagName ) RETURN .F. ENDIF - IF ::cAttribute != NIL .AND. ! hb_HHasKey( oFound:getAttributes(), ::cAttribute ) + IF ::cAttribute != NIL .AND. ! ::cAttribute $ oFound:getAttributes() RETURN .F. ENDIF @@ -481,19 +458,17 @@ METHOD MatchCriteria( oFound ) CLASS THtmlIteratorScan IF ::cData != NIL xData := oFound:getText( " " ) - /* NOTE: != changed to !( == ) */ - IF Empty( xData ) .OR. !( AllTrim( ::cData ) == AllTrim( xData ) ) + /* NOTE: != changed to ! == */ + IF Empty( xData ) .OR. ! AllTrim( ::cData ) == AllTrim( xData ) RETURN .F. ENDIF ENDIF RETURN .T. -/******************************************** - Iterator regex class -*********************************************/ +/* Iterator regex class */ -CLASS THtmlIteratorRegex FROM THtmlIterator MODULE FRIENDLY +CREATE CLASS THtmlIteratorRegex INHERIT THtmlIterator MODULE FRIENDLY METHOD New( oNodeTop ) CONSTRUCTOR HIDDEN: @@ -516,12 +491,12 @@ METHOD MatchCriteria( oFound ) CLASS THtmlIteratorRegex ENDIF IF ::cAttribute != NIL .AND. ; - hb_HScan( oFound:getAttributes(), {| cKey | hb_regexLike( Lower( ::cAttribute ), cKey ) } ) == 0 + hb_HScan( oFound:getAttributes(), {| cKey | hb_regexLike( Lower( ::cAttribute ), cKey ) } ) == 0 RETURN .F. ENDIF IF ::cValue != NIL .AND. ; - hb_HScan( oFound:getAttributes(), {| xKey, cValue | HB_SYMBOL_UNUSED( xKey ), hb_regexLike( ::cValue, cValue ) } ) == 0 + hb_HScan( oFound:getAttributes(), {| xKey, cValue | HB_SYMBOL_UNUSED( xKey ), hb_regexLike( ::cValue, cValue ) } ) == 0 RETURN .F. ENDIF @@ -534,10 +509,8 @@ METHOD MatchCriteria( oFound ) CLASS THtmlIteratorRegex RETURN .T. -/* - * Class representing a HTML node tree. - * It parses a HTML formatted string - */ +/* Class representing a HTML node tree. + It parses a HTML formatted string */ CREATE CLASS THtmlNode MODULE FRIENDLY @@ -607,10 +580,10 @@ CREATE CLASS THtmlNode MODULE FRIENDLY METHOD isAttribute( cName ) - ACCESS TEXT INLINE ::_getTextNode() + ACCESS TEXT INLINE ::_getTextNode() ASSIGN TEXT( x ) INLINE ::_setTextNode( x ) - ACCESS attr INLINE ::getAttributes() + ACCESS attr INLINE ::getAttributes() ASSIGN attr( x ) INLINE ::setAttributes( x ) METHOD pushNode OPERATOR + @@ -633,9 +606,7 @@ METHOD new( oParent, cTagName, cAttrib, cContent ) CLASS THtmlNode IF HB_ISSTRING( oParent ) // a HTML string is passed -> build new tree of objects - IF Chr( 9 ) $ oParent - oParent := StrTran( oParent, Chr( 9 ), " " ) - ENDIF + oParent := StrTran( oParent, Chr( 9 ), " " ) ::root := Self ::htmlTagName := "_root_" ::htmlTagType := THtmlTagType( "_root_" ) @@ -643,22 +614,21 @@ METHOD new( oParent, cTagName, cAttrib, cContent ) CLASS THtmlNode ::parseHtml( P_PARSER( oParent ) ) ELSEIF HB_ISOBJECT( oParent ) // a HTML object is passed -> we are in the course of building an object tree - ::root := oParent:root - ::parent := oParent + ::root := oParent:root + ::parent := oParent IF HB_ISSTRING( cAttrib ) IF Right( cAttrib, 1 ) == "/" - cAttrib := Stuff( cAttrib, Len( cAttrib ), 1, " " ) ::htmlEndTagName := "/" - ::htmlAttributes := RTrim( cAttrib ) + ::htmlAttributes := hb_StrShrink( cAttrib ) ELSE ::htmlAttributes := cAttrib ENDIF ELSE ::htmlAttributes := cAttrib ENDIF - ::htmlTagName := cTagName - ::htmlTagType := THtmlTagType( cTagName ) - ::htmlContent := iif( cContent == NIL, {}, cContent ) + ::htmlTagName := cTagName + ::htmlTagType := THtmlTagType( cTagName ) + ::htmlContent := iif( cContent == NIL, {}, cContent ) ELSE RETURN ::error( "Parameter error", ::className(), ":new()", EG_ARG, hb_AParams() ) ENDIF @@ -669,8 +639,8 @@ METHOD isType( nType ) CLASS THtmlNode LOCAL lRet - BEGIN SEQUENCE WITH {| oErr | Break( oErr ) } - lRet := hb_bitAnd( ::htmlTagType[ 2 ], nType ) > 0 + BEGIN SEQUENCE WITH __BreakBlock() + lRet := hb_bitAnd( ::htmlTagType[ 2 ], nType ) != 0 RECOVER lRet := .F. END SEQUENCE @@ -678,43 +648,30 @@ METHOD isType( nType ) CLASS THtmlNode RETURN lRet // checks if this is a node that is always empty and never has HTML text, e.g. ,, - METHOD isEmpty() CLASS THtmlNode - - RETURN hb_bitAnd( ::htmlTagType[ 2 ], CM_EMPTY ) > 0 + RETURN hb_bitAnd( ::htmlTagType[ 2 ], CM_EMPTY ) != 0 // checks if this is a node that may occur inline, eg. , - METHOD isInline() CLASS THtmlNode - - RETURN hb_bitAnd( ::htmlTagType[ 2 ], CM_INLINE ) > 0 + RETURN hb_bitAnd( ::htmlTagType[ 2 ], CM_INLINE ) != 0 // checks if this is a node that may appear without a closing tag, eg.

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

,_text_) - METHOD isNode() CLASS THtmlNode - RETURN HB_ISARRAY( ::htmlContent ) .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 hb_bitAnd( ::htmlTagType[ 2 ], CM_BLOCK ) > 0 + RETURN hb_bitAnd( ::htmlTagType[ 2 ], CM_BLOCK ) != 0 // checks if this is a node whose text line formatting must be preserved: 
    ,