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

2017-04-14 13:22 UTC+0200 Aleksander Czajczynski (hb fki.pl)

Browse Source 
* 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
This commit is contained in:
Viktor Szakats
2017-04-14 13:22:09 +02:00
committed by Aleksander Czajczynski
parent 11d3cbfa0b
commit 1938dd0a70
51 changed files with 4708 additions and 5272 deletions
Download Patch File Download Diff File Expand all files Collapse all files

50
ChangeLog.txt
View File

@@ -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()

42
contrib/hbtip/WARNING.txt Normal file
View File

@@ -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 <targe-source-file>` 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.

21
contrib/hbtip/credent.prg → contrib/hbtip/base64u.prg
View File

@@ -1,7 +1,7 @@
/*
* TIP Class oriented Internet protocol library
* hb_base64EncodeUrl(), hb_base64DecodeUrl()
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
* 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, "-_", "+/" ) )

50
contrib/hbtip/cgi.prg
View File

@@ -2,14 +2,6 @@
* TIPCgi Class oriented cgi protocol
*
* Copyright 2006 Lorenzo Fiorini <lorenzo.fiorini@gmail.com>
*
* code from:
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* CGI Session Manager Class
*
* Copyright 2003-2006 Francesco Saverio Giudice <info / at / fsgiudice / dot / com>
*
* 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

145
contrib/hbtip/client.prg
View File

@@ -2,8 +2,11 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
* 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 ), { "<cr>", "<lf>" } )
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 )

2
contrib/hbtip/encb64.prg
View File

@@ -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

9
contrib/hbtip/encoder.prg
View File

@@ -2,6 +2,7 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
* Copyright 2007 Hannes Ziegler <hz AT knowlexbase.com> (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 <hz AT knowlexbase.com>
Added Function: tip_GetEncoder()
*/
/* Internet Messaging: https://www.ietf.org/rfc/rfc2045.txt */
#include "hbclass.ch"

8
contrib/hbtip/encqp.prg
View File

@@ -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

2
contrib/hbtip/encurl.prg
View File

@@ -46,7 +46,7 @@
#include "hbclass.ch"
CREATE CLASS TIPEncoderUrl FROM TIPEncoder
CREATE CLASS TIPEncoderUrl INHERIT TIPEncoder
METHOD New() CONSTRUCTOR
METHOD Encode( cData )

894
contrib/hbtip/ftpcli.prg
View File

File diff suppressed because it is too large Load Diff

7
contrib/hbtip/hbtip.hbp
View File

@@ -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

6
contrib/hbtip/hbtip.hbx
View File

@@ -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 )

351
contrib/hbtip/httpcli.prg
View File

@@ -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

20
contrib/hbtip/log.prg
View File

@@ -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

510
contrib/hbtip/mail.prg
View File

@@ -2,6 +2,7 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
* Copyright 2007 Hannes Ziegler <hz AT knowlexbase.com> (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 <hz AT knowlexbase.com>
Added method :setHeader()
Added method :attachFile()
Added method :detachFile()
Added method :getFileName()
Added method :isMultiPart()
Added method :getMultiParts()
*/
#include "hbclass.ch"
#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 - <maurilio.longo@libero.it>
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

229
contrib/hbtip/mailassy.prg Normal file
View File

@@ -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

227
contrib/hbtip/sendmail.prg → contrib/hbtip/mailsend.prg
View File

@@ -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 ( <exp1> LIKE <exp2> ) => ( hb_regexLike( (<exp2>), (<exp1>) ) )
#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

78
contrib/hbtip/mime.c
View File

@@ -2,7 +2,6 @@
* TIP MIME functions
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
* 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 );

27
contrib/hbtip/misc.c
View File

@@ -2,7 +2,7 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
* 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( <cSubStr> ) == Lower( SubStr( <cString>, <nStart>, Len( <cSubStr> ) ) )
<cString> must be provided as a pointer to the character string containing a substring
<nStart> is the numeric position to start comparison in <cString>
<cSubStr> is the character string to compare with characters in <cString>, beginning at <nStart>
*/
HB_FUNC( __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 ) )

261
contrib/hbtip/popcli.prg
View File

@@ -2,6 +2,7 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
* Copyright 2007 Hannes Ziegler <hz AT knowlexbase.com> (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 <hz AT knowlexbase.com>
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 - <maurilio.longo@libero.it>
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 - <maurilio.longo@libero.it>
"- 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

30
contrib/hbtip/sessid.prg
View File

@@ -2,14 +2,7 @@
* Functions to create session id and some utils
*
* Copyright 2008 Lorenzo Fiorini <lorenzo.fiorini@gmail.com>
*
* code from:
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* CGI Session Manager Class
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws> (CGI Session Manager Class)
* Copyright 2003-2006 Francesco Saverio Giudice <info / at / fsgiudice / dot / com>
*
* 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"

18
contrib/hbtip/smtpcli.prg
View File

@@ -2,8 +2,9 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
* Copyright 2007 Hannes Ziegler <hz AT knowlexbase.com> (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 <hz AT knowlexbase.com>
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

118
contrib/hbtip/tests/base64.prg
View File

@@ -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

55
contrib/hbtip/tests/dbtohtml.prg
View File

@@ -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 <font> node with attribute */
oNode := oNode + 'font size="5"'
oNode := oNode + 'font size="5"'
oNode:text := "This is a "
/* Operator "+" creates a new <b> node */
oNode := oNode + "b"
oNode := oNode + "b"
/* Operator "+" creates a new <font> node with attribute */
oNode := oNode + 'font color="blue"'
oNode := oNode + 'font color="blue"'
oNode:text := "sample "
/* Operator "-" closes 2nd <font>, result is <b> node */
oNode := oNode - "font"
oNode := oNode - "font"
/* Operator "-" closes <b> node, result is 1st <font> node */
oNode := oNode - "b"
oNode := oNode - "b"
oNode:text := "database!"
/* Operator "-" closes 1st <font> node, result is <p> 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

79
contrib/hbtip/tests/dnldftp.prg
View File

@@ -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

91
contrib/hbtip/tests/email.prg Normal file
View File

@@ -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 , "<from@example.net>" )
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

65
contrib/hbtip/tests/ftp_adv.prg Normal file
View File

@@ -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

47
contrib/hbtip/tests/ftp_dl.prg Normal file
View File

@@ -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

49
contrib/hbtip/tests/ftp_ul.prg Normal file
View File

@@ -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

58
contrib/hbtip/tests/ftpadv.prg
View File

@@ -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

3
contrib/hbtip/tests/gmail.hbp
View File

@@ -1,3 +0,0 @@
gmail.prg
hbssl.hbc

50
contrib/hbtip/tests/gmail.prg
View File

@@ -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 , "<myname@gmail.com>" )
hb_default( @cPassword, "<mypassword>" )
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

2
contrib/hbtip/tests/hbmk.hbm
View File

@@ -1,3 +1,5 @@
hbtip.hbc
hbssl.hbc
hbtest.hbc
-w3 -es2

61
contrib/hbtip/tests/http_adv.prg Normal file
View File

@@ -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

33
contrib/hbtip/tests/http_cli.prg Normal file
View File

@@ -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

46
contrib/hbtip/tests/http_qry.prg Normal file
View File

@@ -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 <a href="url"> tags */
FOR EACH oNode IN oDoc:body:div( "links" ):aS
IF oNode:class == "large"
? tip_HtmlToStr( oNode:getText( "" ) ), oNode:href
ENDIF
NEXT
RETURN

57
contrib/hbtip/tests/httpadv.prg
View File

@@ -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

24
contrib/hbtip/tests/httpcli.prg
View File

@@ -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

53
contrib/hbtip/tests/loadhtml.prg
View File

@@ -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 <a href="url"> text </a> tag */
oNode := oDoc:body:a
? oNode:getText( "" ), oNode:href
/* ":divs(5)" returns the 5th <div> tag */
oNode := oDoc:body:divs( 5 )
/* "aS" is the plural of "a" and returns all <a href="url"> tags */
aLink := oNode:aS
FOR EACH oNode IN aLink
? tip_HtmlToStr( oNode:getText( "" ) ), oNode:href
NEXT
RETURN

28
contrib/hbtip/tests/mimetype.prg
View File

@@ -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 <file to test>", 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

12
contrib/hbtip/tests/test.prg Normal file
View File

@@ -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

16
contrib/hbtip/tests/timestmp.prg
View File

@@ -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

39
contrib/hbtip/tests/tipmail.prg
View File

@@ -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

126
contrib/hbtip/tests/tipmmail.prg
View File

@@ -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

180
contrib/hbtip/tests/tipwget.prg
View File

@@ -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://<sitename>/<path>?<query>
* HTTP[S] Protocol
* http[s]://<sitename>/<path>?<query>
* - at the moment HTTP URI is not able to send data,
* (e.g. a form)
* (f.e. a form)
*
* POP Protocol
* pop://<username>:<password>@<popserver>/[-][MsgNum]
* - Witout MsgNum, you get the list of messages
* POP[S] Protocol
* pop[s]://<username>:<password>@<popserver>/[-][MsgNum]
* - Without MsgNum, you get the list of messages
* - With MsgNum get Message MsgNum
* - With -MsgNum deletes message MsgNum
*
* SMTP Protocol
* smtp://<mail-from>@<server>/RCPT
* SMTP[S] Protocol
* smtp[s]://<mail-from>@<server>/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@<ftpserver>/[<path>]
* FTP[S] Protocol
* ftp[s]://user:passwd@<ftpserver>/[<path>]
* - 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 <URI> [dumpToOrFromFileName]", hb_ProgName() )
Terminate()
IF ! HB_ISSTRING( cURL ) .OR. Empty( cURL )
? hb_StrFormat( "Usage: %1$s <URI> [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: <connected>"
ELSE
@ 5, 5 SAY "Connection status: " + oClient:cReply
ENDIF
? "Connection status:", iif( Empty( oClient:cReply ), "<connected>", 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

82
contrib/hbtip/tests/upld_ftp.prg
View File

@@ -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

21
contrib/hbtip/tests/url.prg Normal file
View File

@@ -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

2
contrib/hbtip/thtml.ch
View File

@@ -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. */

5528
contrib/hbtip/thtml.prg
View File

File diff suppressed because it is too large Load Diff

2
contrib/hbtip/tip.ch
View File

@@ -1,4 +1,4 @@
*/*
/*
* TIP Class oriented Internet protocol library (header)
*
* Copyright 2002 Giancarlo Niccolai <gian@niccolai.ws>

66
contrib/hbtip/url.prg
View File

@@ -47,13 +47,13 @@
#include "hbclass.ch"
/* An URL:
https://user:passwd@example.com/mypages/mysite/page.html?avar=0&avar1=1
^---^ ^--^ ^----^ ^---------^ ^----------------------^ ^------------^
cProto UID PWD cServer cPath cQuery
^------------^ ^-------^
cDirectory cFile
^--^ ^--^
cFname cExt
https://user:passwd@example.com:port/mypages/mysite/page.html?avar=0&avar1=1
^---^ ^--^ ^----^ ^---------^ ^--^ ^----------------------^ ^------------^
cProto UID PWD cServer nPort cPath cQuery
^------------^ ^-------^
cDirectory cFile
^--^ ^--^
cFname cExt
*/
CREATE CLASS TUrl
@@ -82,7 +82,6 @@ CREATE CLASS TUrl
ENDCLASS
METHOD New( cUrl ) CLASS TUrl
::SetAddress( cUrl )
@@ -107,15 +106,12 @@ METHOD SetAddress( cUrl ) CLASS TUrl
::cFile := ""
::nPort := -1
IF Empty( cUrl )
IF cUrl == ""
RETURN .T.
ENDIF
// TOPLEVEL url parsing
aMatch := hb_regex( ::cREuri, cUrl )
// May fail
IF Empty( aMatch )
// TOPLEVEL url parsing. May fail.
IF Empty( aMatch := hb_regex( ::cREuri, cUrl ) )
RETURN .F.
ENDIF
@@ -141,7 +137,6 @@ METHOD SetAddress( cUrl ) CLASS TUrl
RETURN .T.
METHOD BuildAddress() CLASS TUrl
LOCAL cRet := ""
@@ -150,46 +145,46 @@ METHOD BuildAddress() CLASS TUrl
::cProto := Lower( ::cProto )
ENDIF
IF ! Empty( ::cProto ) .AND. ! Empty( ::cServer )
IF ! Empty( ::cProto ) .AND. ! ::cServer == ""
cRet := ::cProto + "://"
ENDIF
IF ! Empty( ::cUserid )
IF ! ::cUserid == ""
cRet += ::cUserid
IF ! Empty( ::cPassword )
IF ! ::cPassword == ""
cRet += ":" + ::cPassword
ENDIF
cRet += "@"
ENDIF
IF ! Empty( ::cServer )
IF ! ::cServer == ""
cRet += ::cServer
IF ::nPort > 0
cRet += ":" + hb_ntos( ::nPort )
ENDIF
ENDIF
IF Len( ::cPath ) == 0 .OR. !( Right( ::cPath, 1 ) == "/" )
IF ::cPath == "" .OR. ! Right( ::cPath, 1 ) == "/"
::cPath += "/"
ENDIF
cRet += ::cPath + ::cFile
IF ! Empty( ::cQuery )
IF ! ::cQuery == ""
cRet += "?" + ::cQuery
ENDIF
RETURN iif( Len( cRet ) == 0, NIL, ::cAddress := cRet )
RETURN iif( cRet == "", NIL, ::cAddress := cRet )
METHOD BuildQuery() CLASS TUrl
LOCAL cLine
IF Len( ::cPath ) == 0 .OR. !( Right( ::cPath, 1 ) == "/" )
IF ::cPath == "" .OR. ! Right( ::cPath, 1 ) == "/"
::cPath += "/"
ENDIF
cLine := ::cPath + ::cFile
IF ! Empty( ::cQuery )
IF ! ::cQuery == ""
cLine += "?" + ::cQuery
ENDIF
@@ -200,25 +195,28 @@ METHOD AddGetForm( xPostData ) CLASS TUrl
LOCAL cData := ""
LOCAL item
IF HB_ISHASH( xPostData )
DO CASE
CASE HB_ISHASH( xPostData )
FOR EACH item IN xPostData
cData += tip_URLEncode( AllTrim( hb_CStr( item:__enumKey() ) ) ) + "=" + ;
tip_URLEncode( AllTrim( hb_CStr( item ) ) )
cData += ;
tip_URLEncode( AllTrim( hb_CStr( item:__enumKey() ) ) ) + "=" + ;
tip_URLEncode( AllTrim( hb_CStr( item ) ) )
IF ! item:__enumIsLast()
cData += "&"
ENDIF
NEXT
ELSEIF HB_ISARRAY( xPostData )
CASE HB_ISARRAY( xPostData )
FOR EACH item IN xPostData
cData += tip_URLEncode( AllTrim( hb_CStr( item[ 1 ] ) ) ) + "=" + ;
tip_URLEncode( AllTrim( hb_CStr( item[ 2 ] ) ) )
cData += ;
tip_URLEncode( AllTrim( hb_CStr( item:__enumIndex() ) ) ) + "=" + ;
tip_URLEncode( AllTrim( hb_CStr( item ) ) )
IF ! item:__enumIsLast()
cData += "&"
ENDIF
NEXT
ELSEIF HB_ISSTRING( xPostData )
CASE HB_ISSTRING( xPostData )
cData := xPostData
ENDIF
ENDCASE
RETURN iif( Empty( cData ), NIL, ;
::cQuery += iif( Empty( ::cQuery ), "", "&" ) + cData )
RETURN iif( cData == "", NIL, ;
::cQuery += iif( ::cQuery == "", "", "&" ) + cData )