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

2009-07-09 14:58 UTC+0200 Viktor Szakats (harbour.01 syenar.hu)

Browse Source 
* include/hbextern.ch
  * source/rtl/Makefile
  + source/rtl/base64c.c
  + source/rtl/base64.prg
    + Added HB_BASE64ENCODE(), HB_BASE64DECODE() to core.
      They were copied from hbtip and hbvpdf and currently
      the decoder is .prg code while encoding is .c code.
      Latter has one TOFIX for an error situation.

  * contrib/hbtip/encurl.prg
  * contrib/hbtip/thtml.prg
  * contrib/hbtip/sessid.prg
  * contrib/hbtip/popcln.prg
  * contrib/hbtip/sendmail.prg
  * contrib/hbtip/tip.ch
  * contrib/hbtip/cgi.prg
  * contrib/hbtip/url.prg
  * contrib/hbtip/encqp.prg
  * contrib/hbtip/base64x.c
  * contrib/hbtip/httpcln.prg
  * contrib/hbtip/client.prg
  * contrib/hbtip/encoder.prg
  * contrib/hbtip/smtpcln.prg
  * contrib/hbtip/encb64.prg
  * contrib/hbtip/mail.prg
  * contrib/hbtip/credent.prg
  * contrib/hbtip/ftpcln.prg
    + Added TOFIXes, QUESTIONs
    ! Fixed to use hb_MemoRead() instead of MemoRead() in one place.
    ! Fixed a wrong error checks after FCreate() calls.
    ! Fixed to use Len( hb_inetCRLF ) instead of hardwired length.
    ! Using hb_ntos() instead of Str() in POP3 commands.
    * Changed explicit values to manifest constants (F_ERROR)
    * Changed high ASCII chars in source to Chr() representation,
      now source can be edited with any editor.
    ! Added missing copyright header to tip.ch. Although this header
      seems to be unnecessary.
    ! TipMail:MakeBoundary() to not add any date punctuations in the ID.
    ! Fixed tIPClientFTP:fileSize() to not return permantent zero.
    % Heavier optimizations and cleanup in TIpClientSmtp().
    % Optimizations.
    * Formatting.
    ; Please test.
This commit is contained in:
Viktor Szakats
2009-07-09 13:03:59 +00:00
parent b347767d27
commit 9ba5e3e952
23 changed files with 4137 additions and 4031 deletions
Download Patch File Download Diff File Expand all files Collapse all files

57
harbour/ChangeLog
View File

@@ -17,6 +17,51 @@
past entries belonging to author(s): Viktor Szakats.
*/
2009-07-09 14:58 UTC+0200 Viktor Szakats (harbour.01 syenar.hu)
* include/hbextern.ch
* source/rtl/Makefile
+ source/rtl/base64c.c
+ source/rtl/base64.prg
+ Added HB_BASE64ENCODE(), HB_BASE64DECODE() to core.
They were copied from hbtip and hbvpdf and currently
the decoder is .prg code while encoding is .c code.
Latter has one TOFIX for an error situation.
* contrib/hbtip/encurl.prg
* contrib/hbtip/thtml.prg
* contrib/hbtip/sessid.prg
* contrib/hbtip/popcln.prg
* contrib/hbtip/sendmail.prg
* contrib/hbtip/tip.ch
* contrib/hbtip/cgi.prg
* contrib/hbtip/url.prg
* contrib/hbtip/encqp.prg
* contrib/hbtip/base64x.c
* contrib/hbtip/httpcln.prg
* contrib/hbtip/client.prg
* contrib/hbtip/encoder.prg
* contrib/hbtip/smtpcln.prg
* contrib/hbtip/encb64.prg
* contrib/hbtip/mail.prg
* contrib/hbtip/credent.prg
* contrib/hbtip/ftpcln.prg
+ Added TOFIXes, QUESTIONs
! Fixed to use hb_MemoRead() instead of MemoRead() in one place.
! Fixed a wrong error checks after FCreate() calls.
! Fixed to use Len( hb_inetCRLF ) instead of hardwired length.
! Using hb_ntos() instead of Str() in POP3 commands.
* Changed explicit values to manifest constants (F_ERROR)
* Changed high ASCII chars in source to Chr() representation,
now source can be edited with any editor.
! Added missing copyright header to tip.ch. Although this header
seems to be unnecessary.
! TipMail:MakeBoundary() to not add any date punctuations in the ID.
! Fixed tIPClientFTP:fileSize() to not return permantent zero.
% Heavier optimizations and cleanup in TIpClientSmtp().
% Optimizations.
* Formatting.
; Please test.
2009-07-09 14:40 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)
* harbour/include/hbexpra.c
% reduce macro expressions used in POP operation.
@@ -50,7 +95,7 @@
* harbour/contrib/hbxbp/xbpstatic.prg
+ Implemented :type == XBPSTATIC_TYPE_BITMAP.
* harbour/contrib/hbxbp/xbpwindow.prg
+ Implemented :setFont( oXbpFont ).
! Enhanced "Attribute" factor of :compoundName to accept bold and italic together.
@@ -62,7 +107,7 @@
2. Click on <Font Dialog> toolbar icon.
3. Adjust and select a font.
4. See the result in MLE text editor.
+ Demonstrated XbpBitmap() functionality as in Xbase++, code shows up with both compilers.
2009-07-08 16:50 UTC-0800 Pritpal Bedi (pritpal@vouchcac.com)
@@ -118,17 +163,17 @@
! Updated for exact constructor parameters.
If the constructor accepts parameters with identical .prg supplied values,
a new parameter is inserted as a first argument and then resolved in .cpp.
oBrush := QBrush():new( "QPixmap" , pQPixmap )
oBrush := QBrush():new( "QImage" , pQImage )
oBrush := QBrush():new( "QGradient", pQGradient )
Note that constructor fetches only one argument, a pointer to relevant
object, which at prg to cpp level can never be differed so this
object, which at prg to cpp level can never be differed so this
mechanism was necessary. The first parameter will be matched exact
and hence it is case sensitive. If this parameter is of the same type
object is being created then it call will only supply pointer:
oBrush := QBrush():new( pQBrush_other )
2009-07-08 22:47 UTC+0200 Viktor Szakats (harbour.01 syenar.hu)

1
harbour/contrib/hbtip/base64x.c
View File

@@ -7,7 +7,6 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify

426
harbour/contrib/hbtip/cgi.prg
View File

@@ -12,7 +12,6 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* www - http://www.harbour-project.org
*
* CGI Session Manager Class
@@ -62,30 +61,32 @@
*/
#include "hbclass.ch"
#include "tip.ch"
#include "common.ch"
#include "fileio.ch"
#include "tip.ch"
#define CGI_IN 0
#define CGI_OUT 1
#define _CRLF chr(13)+chr(10)
#define _CRLF Chr( 13 ) + Chr( 10 )
#define _BR "<br />"
CLASS TIpCgi
CREATE CLASS TIpCgi
DATA HTTP_RAW_POST_DATA
VAR HTTP_RAW_POST_DATA
DATA cCgiHeader
DATA cHtmlPage
DATA hGets INIT {=>}
DATA hPosts INIT {=>}
DATA hCookies INIT {=>}
DATA hSession INIT {=>}
DATA bSavedErrHandler
DATA cSessionSavePath
DATA cSID
DATA cDumpSavePath
DATA lDumpHtml INIT FALSE
VAR cCgiHeader
VAR cHtmlPage
VAR hGets INIT { => }
VAR hPosts INIT { => }
VAR hCookies INIT { => }
VAR hSession INIT { => }
VAR bSavedErrHandler
VAR cSessionSavePath
VAR cSID
VAR cDumpSavePath
VAR lDumpHtml INIT .F.
METHOD New()
METHOD Header( hOptions )
@@ -124,64 +125,64 @@ METHOD New() CLASS TIpCgi
::cCgiHeader := ""
::cHtmlPage := ""
lPost := ( "POST" $ Upper( getenv( "REQUEST_METHOD" ) ) )
if lPost
nLen := val( getenv( "CONTENT_LENGTH" ) )
cTemp := space( nLen )
if ( ( nRead := FRead( CGI_IN, @cTemp, nLen, 0 ) ) != nLen )
::ErrHandler( "post error read " + str( nRead ) + " instead of " + str( nLen ) )
else
lPost := ( "POST" $ Upper( GetEnv( "REQUEST_METHOD" ) ) )
IF lPost
nLen := Val( GetEnv( "CONTENT_LENGTH" ) )
cTemp := Space( nLen )
IF ( ( nRead := FRead( CGI_IN, @cTemp, nLen, 0 ) ) != nLen )
::ErrHandler( "post error read " + Str( nRead ) + " instead of " + Str( nLen ) )
ELSE
::HTTP_RAW_POST_DATA := cTemp
aTemp := HB_ATOKENS( cTemp, "&" )
aTemp := hb_ATokens( cTemp, "&" )
nLen := Len( aTemp )
if nLen > 0
for nCount := 1 TO nLen
aVar := HB_ATOKENS( aTemp[ nCount ], "=" )
if Len( aVar ) == 2
::hPosts[ alltrim( TipEncoderUrl_Decode( aVar[ 1 ] ) ) ] := TipEncoderUrl_Decode( aVar[ 2 ] )
endif
next
endif
endif
else
cTemp := getenv( "QUERY_STRING" )
if !empty( cTemp )
aTemp := HB_ATOKENS( cTemp, "&" )
IF nLen > 0
FOR nCount := 1 TO nLen
aVar := hb_ATokens( aTemp[ nCount ], "=" )
IF Len( aVar ) == 2
::hPosts[ AllTrim( TipEncoderUrl_Decode( aVar[ 1 ] ) ) ] := TipEncoderUrl_Decode( aVar[ 2 ] )
ENDIF
NEXT
ENDIF
ENDIF
ELSE
cTemp := GetEnv( "QUERY_STRING" )
IF ! Empty( cTemp )
aTemp := hb_ATokens( cTemp, "&" )
nLen := Len( aTemp )
if nLen > 0
for nCount := 1 TO nLen
aVar := HB_ATOKENS( aTemp[ nCount ], "=" )
if Len( aVar ) == 2
::hGets[ alltrim( TipEncoderUrl_Decode( aVar[ 1 ] ) ) ] := TipEncoderUrl_Decode( aVar[ 2 ] )
endif
next
endif
endif
endif
IF nLen > 0
FOR nCount := 1 TO nLen
aVar := hb_ATokens( aTemp[ nCount ], "=" )
IF Len( aVar ) == 2
::hGets[ AllTrim( TipEncoderUrl_Decode( aVar[ 1 ] ) ) ] := TipEncoderUrl_Decode( aVar[ 2 ] )
ENDIF
NEXT
ENDIF
ENDIF
ENDIF
cTemp := getenv( "HTTP_COOKIE" )
if !empty( cTemp )
aTemp := HB_ATOKENS( cTemp, ";" )
cTemp := GetEnv( "HTTP_COOKIE" )
IF ! Empty( cTemp )
aTemp := hb_ATokens( cTemp, ";" )
nLen := Len( aTemp )
if nLen > 0
for nCount := 1 TO nLen
aVar := HB_ATOKENS( aTemp[ nCount ], "=" )
if Len( aVar ) == 2
::hCookies[ alltrim( TipEncoderUrl_Decode( aVar[ 1 ] ) ) ] := TipEncoderUrl_Decode( aVar[ 2 ] )
endif
next
endif
endif
IF nLen > 0
FOR nCount := 1 TO nLen
aVar := hb_ATokens( aTemp[ nCount ], "=" )
IF Len( aVar ) == 2
::hCookies[ AllTrim( TipEncoderUrl_Decode( aVar[ 1 ] ) ) ] := TipEncoderUrl_Decode( aVar[ 2 ] )
ENDIF
NEXT
ENDIF
ENDIF
RETURN Self
METHOD Header( cValue ) CLASS TIpCgi
if empty( cValue )
IF Empty( cValue )
::cCgiHeader += "Content-Type: text/html" + _CRLF
else
ELSE
::cCgiHeader += cValue + _CRLF
endif
ENDIF
RETURN Self
@@ -210,45 +211,45 @@ METHOD Flush() CLASS TIpCgi
LOCAL cSID := ::cSID
LOCAL cSession
hb_hEval( ::hCookies, { |k,v| ::cCgiHeader += "Set-Cookie: " + k + "=" + v + ";" + _CRLF } )
hb_HEval( ::hCookies, { | k, v | ::cCgiHeader += "Set-Cookie: " + k + "=" + v + ";" + _CRLF } )
cStream := ::cCgiHeader + _CRLF + ::cHtmlPage + _CRLF
nLen := len( cStream )
nLen := Len( cStream )
lRet := ( Fwrite( CGI_OUT, cStream, nLen ) == nLen )
if ::lDumpHtml
if empty( ::cDumpSavePath )
IF ::lDumpHtml
IF Empty( ::cDumpSavePath )
/* TOFIX: *nix specific default. [vszakats] */
::cDumpSavePath := "/tmp/"
endif
if ( nH := FCreate( ::cDumpSavePath + "dump.html", FC_NORMAL ) ) != -1
Fwrite( nH, ::cHtmlPage, len( ::cHtmlPage ) )
endif
ENDIF
IF ( nH := FCreate( ::cDumpSavePath + "dump.html", FC_NORMAL ) ) != F_ERROR
FWrite( nH, ::cHtmlPage )
ENDIF
FClose( nH )
endif
ENDIF
::cCgiHeader := ""
::cHtmlPage := ""
if !empty( cSID )
IF ! Empty( cSID )
cFile := ::cSessionSavePath + "SESSIONID_" + cSID
cFile := ::cSessionSavePath + "SESSIONID_" + cSID
cSession := ::SessionEncode()
cSession := ::SessionEncode()
nFileSize := len( cSession )
nFileSize := Len( cSession )
if ( nH := FCreate( cFile, FC_NORMAL ) ) != -1
if ( FWrite( nH, @cSession, nFileSize ) ) != nFileSize
::Print( "ERROR: On writing session file : " + cFile + ", File error : " + hb_cStr( FError() ) )
endif
FClose( nH )
else
::Print( "ERROR: On writing session file : " + cFile + ", File error : " + hb_cStr( FError() ) )
endif
endif
IF ( nH := FCreate( cFile, FC_NORMAL ) ) != F_ERROR
IF ( FWrite( nH, @cSession, nFileSize ) ) != nFileSize
::Print( "ERROR: On writing session file : " + cFile + ", File error : " + hb_cStr( FError() ) )
ENDIF
FClose( nH )
ELSE
::Print( "ERROR: On writing session file : " + cFile + ", File error : " + hb_cStr( FError() ) )
ENDIF
ENDIF
RETURN lRet
@@ -258,28 +259,28 @@ METHOD DestroySession( cID ) CLASS TIpCgi
LOCAL cSID := ::cSID
LOCAL lRet
if !empty( cID )
IF ! Empty( cID )
cSID := cID
endif
ENDIF
if !empty( cSID )
IF ! Empty( cSID )
::hSession := {=>}
::hSession := { => }
cFile := ::cSessionSavePath + "SESSIONID_" + cSID
if !( lRet := ( FErase( cFile ) == 0 ) )
IF !( lRet := ( FErase( cFile ) == 0 ) )
::Print( "ERROR: On deleting session file : " + cFile + ", File error : " + hb_cStr( FError() ) )
else
::hCookies[ "SESSIONID" ] := cSID + "; expires= " + TIP_DateToGMT( DATE() - 1 )
::CreateSID()
cSID := ::cSID
::hCookies[ "SESSIONID" ] := cSID
endif
ELSE
::hCookies[ "SESSIONID" ] := cSID + "; expires= " + TIP_DateToGMT( Date() - 1 )
::CreateSID()
cSID := ::cSID
::hCookies[ "SESSIONID" ] := cSID
ENDIF
endif
ENDIF
RETURN lRet
RETURN lRet
METHOD ErrHandler( xError ) CLASS TIpCgi
@@ -287,22 +288,22 @@ METHOD ErrHandler( xError ) CLASS TIpCgi
::Print( '<table border="1">' )
::Print( '<tr><td>SCRIPT NAME:</td><td>' + getenv( 'SCRIPT_NAME' ) + '</td></tr>' )
::Print( '<tr><td>SCRIPT NAME:</td><td>' + GetEnv( "SCRIPT_NAME" ) + '</td></tr>' )
if ISOBJECT( xError )
IF ISOBJECT( xError )
::Print( '<tr><td>CRITICAL ERROR:</td><td>' + xError:Description + '</td></tr>' )
::Print( '<tr><td>OPERATION:</td><td>' + xError:Operation + '</td></tr>' )
::Print( '<tr><td>OS ERROR:</td><td>' + alltrim( str( xError:OsCode ) ) + ' IN ' + xError:SubSystem + '/' + alltrim( str( xError:SubCode ) ) + '</td></tr>' )
::Print( '<tr><td>OS ERROR:</td><td>' + hb_ntos( xError:OsCode ) + ' IN ' + xError:SubSystem + '/' + hb_ntos( xError:SubCode ) + '</td></tr>' )
::Print( '<tr><td>FILENAME:</td><td>' + right( xError:FileName, 40 ) + '</td></tr>' )
ELSEIF ISCHARACTER( xError )
::Print( '<tr><td>ERROR MESSAGE:</td><td>' + xError + '</td></tr>' )
endif
ENDIF
for nCalls := 2 to 6
if !empty( procname( nCalls ) )
::Print( '<tr><td>PROC/LINE:</td><td>' + procname( nCalls ) + "/" + alltrim( str( procline( nCalls ) ) ) + '</td></tr>' )
endif
next
FOR nCalls := 2 to 6
IF ! Empty( procname( nCalls ) )
::Print( '<tr><td>PROC/LINE:</td><td>' + ProcName( nCalls ) + "/" + hb_ntos( ProcLine( nCalls ) ) + '</td></tr>' )
ENDIF
NEXT
::Print( '</table>' )
@@ -367,16 +368,16 @@ METHOD SaveHtmlPage( cFile ) CLASS TIpCgi
cStream := ::cHtmlPage + _CRLF
nLen := len( cStream )
nLen := Len( cStream )
nFile := FCreate( cFile )
if nFile != 0
IF nFile != F_ERROR
lSuccess := ( FWrite( nFile, cStream, nLen ) == nLen )
FClose( nFile )
else
ELSE
lSuccess := .F.
endif
ENDIF
RETURN lSuccess
@@ -387,50 +388,51 @@ METHOD StartSession( cSID ) CLASS TIpCgi
LOCAL nFileSize
LOCAL cBuffer
if empty( cSID )
IF Empty( cSID )
if ( nH := hb_HPos( ::hGets, "SESSIONID" ) ) != 0
IF ( nH := hb_HPos( ::hGets, "SESSIONID" ) ) != 0
cSID := hb_HValueAt( ::hGets, nH )
ELSEIF ( nH := hb_HPos( ::hPosts, "SESSIONID" ) ) != 0
cSID := hb_HValueAt( ::hPosts, nH )
ELSEIF ( nH := hb_HPos( ::hCookies, "SESSIONID" ) ) != 0
cSID := hb_HValueAt( ::hCookies, nH )
endif
ENDIF
endif
ENDIF
if empty( ::cSessionSavePath )
IF Empty( ::cSessionSavePath )
/* TOFIX: *nix specific default. [vszakats] */
::cSessionSavePath := "/tmp/"
endif
ENDIF
if !empty( cSID )
IF ! Empty( cSID )
::cSID := cSID
cFile := ::cSessionSavePath + "SESSIONID_" + cSID
if hb_FileExists( cFile )
if ( nH := FOpen( cFile, FO_READ ) ) != -1
IF hb_FileExists( cFile )
IF ( nH := FOpen( cFile, FO_READ ) ) != F_ERROR
nFileSize := FSeek( nH, 0, FS_END )
FSeek( nH, 0, FS_SET )
cBuffer := Space( nFileSize )
if ( FRead( nH, @cBuffer, nFileSize ) ) != nFileSize
IF ( FRead( nH, @cBuffer, nFileSize ) ) != nFileSize
::ErrHandler( "ERROR: On reading session file : " + cFile + ", File error : " + hb_cStr( FError() ) )
else
ELSE
::SessionDecode( cBuffer )
endif
ENDIF
FClose( nH )
endif
else
ENDIF
ELSE
::ErrHandler( "ERROR: On opening session file : " + cFile + ", file not exist." )
endif
ENDIF
else
ELSE
::CreateSID()
::hSession := {=>}
endif
ENDIF
::hCookies[ "SESSIONID" ] := ::cSID
@@ -438,13 +440,13 @@ METHOD StartSession( cSID ) CLASS TIpCgi
METHOD SessionEncode() CLASS TIpCgi
RETURN HB_Serialize( ::hSession )
RETURN hb_Serialize( ::hSession )
METHOD SessionDecode( cData ) CLASS TIpCgi
::hSession := HB_Deserialize( cData )
::hSession := hb_Deserialize( cData )
RETURN Valtype( ::hSession ) == "H"
RETURN hb_isHash( ::hSession )
STATIC FUNCTION HtmlTag( xVal, cKey, cDefault )
@@ -452,20 +454,20 @@ STATIC FUNCTION HtmlTag( xVal, cKey, cDefault )
DEFAULT cDefault TO ""
if !empty( xVal ) .AND. !empty( cKey )
if hb_hHasKey( xVal, cKey )
cVal := hb_hGet( xVal, cKey )
hb_hDel( xVal, cKey )
endif
endif
IF ! Empty( xVal ) .AND. ! Empty( cKey )
IF hb_HHasKey( xVal, cKey )
cVal := hb_HGet( xVal, cKey )
hb_HDel( xVal, cKey )
ENDIF
ENDIF
if cVal == ""
IF cVal == ""
cVal := cDefault
endif
ENDIF
if !( cVal == "" )
IF !( cVal == "" )
cVal := "<" + cKey + ">" + cVal + "</" + cKey + ">"
endif
ENDIF
RETURN cVal
@@ -475,7 +477,7 @@ STATIC FUNCTION HtmlAllTag( hTags, cSep )
DEFAULT cSep TO " "
hb_hEval( hTags, { |k| cVal += HtmlTag( hTags, k ) + cSep } )
hb_HEval( hTags, { |k| cVal += HtmlTag( hTags, k ) + cSep } )
RETURN cVal
@@ -483,23 +485,23 @@ STATIC FUNCTION HtmlOption( xVal, cKey, cPre, cPost, lScan )
LOCAL cVal := ""
if !empty( xVal )
if empty( cKey )
IF ! Empty( xVal )
IF Empty( cKey )
cVal := xVal
ELSEIF hb_hHasKey( xVal, cKey )
cVal := hb_hGet( xVal, cKey )
if empty( lScan )
hb_hDel( xVal, cKey )
endif
ELSEIF hb_HHasKey( xVal, cKey )
cVal := hb_HGet( xVal, cKey )
IF Empty( lScan )
hb_HDel( xVal, cKey )
ENDIF
cVal := cKey + '="' + cVal + '"'
if cPre != NIL
IF cPre != NIL
cVal := cPre + cVal
endif
if cPost != NIL
ENDIF
IF cPost != NIL
cVal := cVal + cPost
endif
endif
endif
ENDIF
ENDIF
ENDIF
RETURN cVal
@@ -507,11 +509,11 @@ STATIC FUNCTION HtmlAllOption( hOptions, cSep )
LOCAL cVal := ""
DEFAULT cSep TO " "
IF ! Empty( hOptions )
DEFAULT cSep TO " "
if !empty( hOptions )
hb_hEval( hOptions, { |k| cVal += HtmlOption( hOptions, k,,, .T. ) + cSep } )
endif
hb_HEval( hOptions, { |k| cVal += HtmlOption( hOptions, k,,, .T. ) + cSep } )
ENDIF
RETURN cVal
@@ -521,16 +523,16 @@ STATIC FUNCTION HtmlValue( xVal, cKey, cDefault )
DEFAULT cDefault TO ""
if !empty( xVal ) .AND. !empty( cKey )
if hb_hHasKey( xVal, cKey )
cVal := hb_hGet( xVal, cKey )
hb_hDel( xVal, cKey )
endif
endif
IF ! Empty( xVal ) .AND. ! Empty( cKey )
IF hb_HHasKey( xVal, cKey )
cVal := hb_HGet( xVal, cKey )
hb_HDel( xVal, cKey )
ENDIF
ENDIF
if cVal == ""
IF cVal == ""
cVal := cDefault
endif
ENDIF
RETURN cVal
@@ -538,11 +540,11 @@ STATIC FUNCTION HtmlAllValue( hValues, cSep )
LOCAL cVal := ""
DEFAULT cSep TO " "
IF ! Empty( hValues )
DEFAULT cSep TO " "
if !empty( hValues )
hb_hEval( hValues, { |k| cVal += HtmlValue( hValues, k ) + cSep } )
endif
hb_HEval( hValues, { |k| cVal += HtmlValue( hValues, k ) + cSep } )
ENDIF
RETURN cVal
@@ -554,36 +556,36 @@ STATIC FUNCTION HtmlScript( xVal, cKey )
DEFAULT cKey TO "script"
if !empty( xVal )
if ( nPos := hb_HPos( xVal, cKey ) ) != 0
IF ! Empty( xVal )
IF ( nPos := hb_HPos( xVal, cKey ) ) != 0
cVal := hb_HValueAt( xVal, nPos )
if valtype( cVal ) == "H"
if ( nPos := hb_HPos( cVal, "src" ) ) != 0
IF hb_isHash( cVal )
IF ( nPos := hb_HPos( cVal, "src" ) ) != 0
cVal := hb_HValueAt( cVal, nPos )
if ISCHARACTER( cVal )
IF ISCHARACTER( cVal )
cVal := { cVal }
endif
if ISARRAY( cVal )
ENDIF
IF ISARRAY( cVal )
cTmp := ""
ascan( cVal, { |cFile| cTmp += '<script src="' + cFile + '" type="text/javascript">' + _CRLF } )
ascan( cVal, { | cFile | cTmp += '<script src="' + cFile + '" type="text/javascript">' + _CRLF } )
cVal := cTmp
endif
endif
if ( nPos := hb_HPos( cVal, "var" ) ) != 0
ENDIF
ENDIF
IF ( nPos := hb_HPos( cVal, "var" ) ) != 0
cVal := hb_HValueAt( cVal, nPos )
if ISCHARACTER( cVal )
IF ISCHARACTER( cVal )
cVal := { cVal }
endif
if ISARRAY( cVal )
ENDIF
IF ISARRAY( cVal )
cTmp := ""
ascan( cVal, { |cVar| cTmp += cVar } )
ascan( cVal, { | cVar | cTmp += cVar } )
cVal := '<script type="text/javascript">' + _CRLF + '<!--' + _CRLF + cTmp + _CRLF + '-->' + _CRLF + '</script>' + _CRLF
endif
endif
endif
hb_hDel( xVal, cKey )
endif
endif
ENDIF
ENDIF
ENDIF
hb_HDel( xVal, cKey )
ENDIF
ENDIF
RETURN cVal
@@ -595,35 +597,35 @@ STATIC FUNCTION HtmlStyle( xVal, cKey )
DEFAULT cKey TO "style"
if !empty( xVal )
if ( nPos := hb_HPos( xVal, cKey ) ) != 0
IF ! Empty( xVal )
IF ( nPos := hb_HPos( xVal, cKey ) ) != 0
cVal := hb_HValueAt( xVal, nPos )
if valtype( cVal ) == "H"
if ( nPos := hb_HPos( cVal, "src" ) ) != 0
IF hb_isHash( cVal )
IF ( nPos := hb_HPos( cVal, "src" ) ) != 0
cVal := hb_HValueAt( cVal, nPos )
if ISCHARACTER( cVal )
IF ISCHARACTER( cVal )
cVal := { cVal }
endif
if ISARRAY( cVal )
ENDIF
IF ISARRAY( cVal )
cTmp := ""
ascan( cVal, { |cFile| cTmp += '<link rel="StyleSheet" href="' + cFile + '" type="text/css" />' + _CRLF } )
AScan( cVal, { | cFile | cTmp += '<link rel="StyleSheet" href="' + cFile + '" type="text/css" />' + _CRLF } )
cVal := cTmp
endif
endif
if ( nPos := hb_HPos( cVal, "var" ) ) != 0
ENDIF
ENDIF
IF ( nPos := hb_HPos( cVal, "var" ) ) != 0
cVal := hb_HValueAt( cVal, nPos )
if ISCHARACTER( cVal )
IF ISCHARACTER( cVal )
cVal := { cVal }
endif
if ISARRAY( cVal )
ENDIF
IF ISARRAY( cVal )
cTmp := ""
ascan( cVal, { |cVar| cTmp += cVar } )
cVal := '<style type="text/css">' + _CRLF + '<!--' + _CRLF + cTmp + _CRLF + '-->' + _CRLF + '</style>' + _CRLF
endif
endif
endif
hb_hDel( xVal, cKey )
endif
endif
ENDIF
ENDIF
ENDIF
hb_HDel( xVal, cKey )
ENDIF
ENDIF
RETURN cVal

8
harbour/contrib/hbtip/client.prg
View File

@@ -378,7 +378,7 @@ METHOD ReadToFile( cFile, nMode, nSize ) CLASS tIPClient
nSent := 0
IF !Empty( ::exGauge )
HB_ExecFromArray( ::exGauge, { nSent, nSize, Self } )
hb_ExecFromArray( ::exGauge, { nSent, nSize, Self } )
ENDIF
::nRead := 0
@@ -407,7 +407,7 @@ METHOD ReadToFile( cFile, nMode, nSize ) CLASS tIPClient
nSent += Len( cData )
IF ! Empty( ::exGauge )
HB_ExecFromArray( ::exGauge, { nSent, nSize, Self } )
hb_ExecFromArray( ::exGauge, { nSent, nSize, Self } )
ENDIF
ENDDO
@@ -441,7 +441,7 @@ METHOD WriteFromFile( cFile ) CLASS tIPClient
// allow initialization of the gauge
nSent := 0
IF ! Empty( ::exGauge )
HB_ExecFromArray( ::exGauge, { nSent, nSize, Self } )
hb_ExecFromArray( ::exGauge, { nSent, nSize, Self } )
ENDIF
::nStatus := 1
@@ -454,7 +454,7 @@ METHOD WriteFromFile( cFile ) CLASS tIPClient
ENDIF
nSent += nLen
IF ! Empty( ::exGauge )
HB_ExecFromArray( ::exGauge, {nSent, nSize, Self} )
hb_ExecFromArray( ::exGauge, {nSent, nSize, Self} )
ENDIF
nLen := FRead( nFin, @cData, nBufSize )
ENDDO

1
harbour/contrib/hbtip/credent.prg
View File

@@ -7,7 +7,6 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify

3
harbour/contrib/hbtip/encb64.prg
View File

@@ -7,7 +7,6 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
@@ -67,4 +66,4 @@ ENDCLASS
METHOD New() CLASS TIPEncoderBase64
::cName := "Base64"
::bHttpExcept := .F.
RETURN Self
RETURN Self

26
harbour/contrib/hbtip/encoder.prg
View File

@@ -7,7 +7,6 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
@@ -62,10 +61,11 @@
#include "hbclass.ch"
#include "fileio.ch"
#include "tip.ch"
#include "common.ch"
#include "common.ch"
#include "fileio.ch"
#include "tip.ch"
FUNCTION TIp_GetEncoder( cModel )
LOCAL oEncoder
@@ -95,9 +95,7 @@ FUNCTION TIp_GetEncoder( cModel )
ENDCASE
RETURN oEncoder
RETURN oEncoder
CREATE CLASS TIPEncoder
VAR cName
@@ -107,17 +105,15 @@ CREATE CLASS TIPEncoder
METHOD Decode( cData )
ENDCLASS
METHOD New( cModel ) class TIPEncoder
METHOD New( cModel ) CLASS TIPEncoder
IF ! ISCHARACTER( cModel )
cModel := "as-is"
ENDIF
::cName := cModel
RETURN self
RETURN Self
METHOD Encode( cData ) CLASS TIPEncoder
RETURN cData
METHOD Encode( cData ) class TIPEncoder
RETURN cData
METHOD Decode( cData ) class TIPEncoder
RETURN cData
METHOD Decode( cData ) CLASS TIPEncoder
RETURN cData

6
harbour/contrib/hbtip/encqp.prg
View File

@@ -7,7 +7,6 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
@@ -53,13 +52,12 @@
#include "hbclass.ch"
CREATE CLASS TIPEncoderQP FROM TIPEncoder
METHOD New() CONSTRUCTOR
METHOD New() CONSTRUCTOR
METHOD Encode( cData )
METHOD Decode( cData )
ENDCLASS
METHOD New() CLASS TIPEncoderQP
::cName := "Quoted-Printable"
RETURN Self
RETURN Self

10
harbour/contrib/hbtip/encurl.prg
View File

@@ -7,7 +7,6 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
@@ -53,13 +52,12 @@
#include "hbclass.ch"
CREATE CLASS TIPEncoderUrl FROM TIPEncoder
METHOD New() CONSTRUCTOR
METHOD Encode()
METHOD Decode()
METHOD New() CONSTRUCTOR
METHOD Encode( cData )
METHOD Decode( cData )
ENDCLASS
METHOD New() CLASS TIPEncoderURL
::cName := "urlencoded"
RETURN Self
RETURN Self

429
harbour/contrib/hbtip/ftpcln.prg
View File

@@ -4,10 +4,9 @@
/*
* xHarbour Project source code:
* TIP Class oriented Internet protocol library
* TIP Class oriented Internet protocol library (FTP)
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
@@ -57,13 +56,11 @@
Added method :MPut()
Changed method :downloadFile() to enable display of progress
Changed method :uploadFile() to enable display of progress
*/
/* 2007-06-01, Toninho@fwi
2007-06-01, Toninho@fwi
Added method UserCommand( cCommand, lPasv, lReadPort, lGetReply )
*/
/* 2007-07-12, miguelangel@marchuet.net
2007-07-12, miguelangel@marchuet.net
Added method :NoOp()
Added method :Rest( nPos )
Changed method :LS( cSpec )
@@ -78,9 +75,8 @@
Added method :SendPort()
Cleaned unused variables.
*/
/* 2007-09-08 21:34 UTC+0100 Patrick Mast <patrick/dot/mast/at/xharbour.com>
2007-09-08 21:34 UTC+0100 Patrick Mast <patrick/dot/mast/at/xharbour.com>
* source\tip\ftpcln.prg
* Formatting
+ METHOD StartCleanLogFile()
@@ -90,22 +86,21 @@
+ DATA cLogFile
Holds the filename of the current logfile.
! Fixed logfilename in New(), now its not limited to 9999 log files anymore
! Fixed MGet() due to changes in HB_aTokens()
! Fixed listFiles() due to changes in HB_aTokens()
! Fixed MGet() due to changes in hb_ATokens()
! Fixed listFiles() due to changes in hb_ATokens()
! listFiles() is still buggy. Needs to be fixed.
*/
#include "directry.ch"
#include "hbclass.ch"
#include "tip.ch"
#include "common.ch"
#include "directry.ch"
#include "tip.ch"
/* TOFIX: This won't work in MT programs. [vszakats] */
STATIC s_nPort := 16000
/**
* Inet service manager: ftp
*/
CREATE CLASS tIPClientFTP FROM tIPClient
VAR nDataPort
VAR cDataServer
@@ -144,16 +139,14 @@ CREATE CLASS tIPClientFTP FROM tIPClient
METHOD ScanLength()
METHOD ReadAuxPort()
METHOD mget()
// Method bellow contributed by Rafa Carmona
// Method below contributed by Rafa Carmona
METHOD LS( cSpec )
METHOD Rename( cFrom, cTo )
// new method for file upload
METHOD UpLoadFile( cLocalFile, cRemoteFile )
// new method to download file
METHOD DownLoadFile( cLocalFile, cRemoteFile )
// new method to create an directory on ftp server
METHOD MKD( cPath )
METHOD UpLoadFile( cLocalFile, cRemoteFile ) // new method for file upload
METHOD DownLoadFile( cLocalFile, cRemoteFile ) // new method to download file
METHOD MKD( cPath ) // new method to create an directory on ftp server
METHOD RMD( cPath )
METHOD listFiles( cList )
@@ -163,11 +156,11 @@ CREATE CLASS tIPClientFTP FROM tIPClient
ENDCLASS
METHOD New( oUrl,lTrace, oCredentials) CLASS tIPClientFTP
LOCAL cFile :="ftp"
LOCAL n := 0
METHOD New( oUrl, lTrace, oCredentials ) CLASS tIPClientFTP
LOCAL n
::super:new( oUrl, lTrace, oCredentials )
::super:new( oUrl, lTrace, oCredentials)
::nDefaultPort := 21
::nConnTimeout := 3000
::bUsePasv := .T.
@@ -175,34 +168,33 @@ METHOD New( oUrl,lTrace, oCredentials) CLASS tIPClientFTP
::nDefaultSndBuffSize := 65536
::nDefaultRcvBuffSize := 65536
if ::ltrace
if !hb_FileExists("ftp.log")
::nHandle := FCreate("ftp.log")
else
while hb_FileExists(cFile+hb_NToS(Int(n))+".log")
n++
enddo
::cLogFile:= cFile+hb_NToS(Int(n))+".log"
::nHandle := FCreate(::cLogFile)
endif
endif
IF ::lTrace
IF ! hb_FileExists( "ftp.log" )
::nHandle := FCreate( "ftp.log" )
ELSE
n := 0
DO WHILE hb_FileExists( "ftp" + hb_ntos( n ) + ".log" )
n++
ENDDO
::cLogFile := "ftp" + hb_ntos( n ) + ".log"
::nHandle := FCreate( ::cLogFile )
ENDIF
ENDIF
// precompilation of regex for better prestations
::RegBytes := HB_RegexComp( "\(([0-9]+)[ )a-zA-Z]" )
::RegPasv := HB_RegexComp( "([0-9]*) *, *([0-9]*) *, *([0-9]*) *, *([0-9]*) *, *([0-9]*) *, *([0-9]*)" )
RETURN Self
::RegBytes := hb_regexComp( "\(([0-9]+)[ )a-zA-Z]" )
::RegPasv := hb_regexComp( "([0-9]*) *, *([0-9]*) *, *([0-9]*) *, *([0-9]*) *, *([0-9]*) *, *([0-9]*)" )
RETURN Self
METHOD StartCleanLogFile() CLASS tIPClientFTP
FClose(::nHandle)
::nHandle := FCreate(::cLogFile)
RETURN NIL
FClose( ::nHandle )
::nHandle := FCreate( ::cLogFile )
RETURN NIL
METHOD Open( cUrl ) CLASS tIPClientFTP
IF HB_IsString( cUrl )
IF hb_isString( cUrl )
::oUrl := tUrl():New( cUrl )
ENDIF
@@ -214,7 +206,7 @@ METHOD Open( cUrl ) CLASS tIPClientFTP
RETURN .F.
ENDIF
HB_InetTimeout( ::SocketCon, ::nConnTimeout )
hb_inetTimeout( ::SocketCon, ::nConnTimeout )
IF ::GetReply()
::InetSendall( ::SocketCon, "USER " + ::oUrl:cUserid + ::cCRLF )
IF ::GetReply()
@@ -225,7 +217,7 @@ METHOD Open( cUrl ) CLASS tIPClientFTP
ENDIF
ENDIF
ENDIF
RETURN .F.
RETURN .F.
METHOD GetReply() CLASS tIPClientFTP
LOCAL nLen
@@ -240,9 +232,9 @@ METHOD GetReply() CLASS tIPClientFTP
ENDIF
// now, if the reply has a "-" as fourth character, we need to proceed...
DO WHILE ! Empty(cRep) .AND. SubStr( cRep, 4, 1 ) == "-"
DO WHILE ! Empty( cRep ) .AND. SubStr( cRep, 4, 1 ) == "-"
::cReply := ::InetRecvLine( ::SocketCon, @nLen, 128 )
cRep := IIf(ISCHARACTER(::cReply), ::cReply, "")
cRep := iif( ISCHARACTER( ::cReply ), ::cReply, "" )
ENDDO
// 4 and 5 are error codes
@@ -250,66 +242,63 @@ METHOD GetReply() CLASS tIPClientFTP
RETURN .F.
ENDIF
RETURN .T.
RETURN .T.
METHOD Pasv() CLASS tIPClientFTP
LOCAL aRep
::InetSendall( ::SocketCon, "PASV" + ::cCRLF )
IF ! ::GetReply()
RETURN .F.
ENDIF
aRep := HB_Regex( ::RegPasv, ::cReply )
IF Empty(aRep)
aRep := hb_regex( ::RegPasv, ::cReply )
IF Empty( aRep )
RETURN .F.
ENDIF
::cDataServer := aRep[2] + "." + aRep[3] + "." + aRep[4] + "." + aRep[5]
::nDataPort := Val(aRep[6]) *256 + Val( aRep[7] )
RETURN .T.
::cDataServer := aRep[ 2 ] + "." + aRep[ 3 ] + "." + aRep[ 4 ] + "." + aRep[ 5 ]
::nDataPort := Val( aRep[ 6 ] ) * 256 + Val( aRep[ 7 ] )
RETURN .T.
METHOD Close() CLASS tIPClientFTP
HB_InetTimeOut( ::SocketCon, ::nConnTimeout )
if ::ltrace
fClose(::nHandle)
endif
hb_inetTimeOut( ::SocketCon, ::nConnTimeout )
IF ::lTrace
FClose( ::nHandle )
ENDIF
::Quit()
RETURN ::super:Close()
RETURN ::super:Close()
METHOD Quit() CLASS tIPClientFTP
::InetSendall( ::SocketCon, "QUIT" + ::cCRLF )
RETURN ::GetReply()
RETURN ::GetReply()
METHOD TypeI() CLASS tIPClientFTP
::InetSendall( ::SocketCon, "TYPE I" + ::cCRLF )
RETURN ::GetReply()
RETURN ::GetReply()
METHOD TypeA() CLASS tIPClientFTP
::InetSendall( ::SocketCon, "TYPE A" + ::cCRLF )
RETURN ::GetReply()
RETURN ::GetReply()
METHOD NoOp() CLASS tIPClientFTP
::InetSendall( ::SocketCon, "NOOP" + ::cCRLF )
RETURN ::GetReply()
RETURN ::GetReply()
METHOD Rest( nPos ) CLASS tIPClientFTP
::InetSendall( ::SocketCon, "REST " + AllTrim( Str( iif( Empty( nPos ), 0, nPos ) ) ) + ::cCRLF )
RETURN ::GetReply()
::InetSendall( ::SocketCon, "REST " + hb_ntos( iif( Empty( nPos ), 0, nPos ) ) + ::cCRLF )
RETURN ::GetReply()
METHOD CWD( cPath ) CLASS tIPClientFTP
::InetSendall( ::SocketCon, "CWD " + cPath + ::cCRLF )
RETURN ::GetReply()
RETURN ::GetReply()
METHOD PWD() CLASS tIPClientFTP
@@ -317,40 +306,40 @@ METHOD PWD() CLASS tIPClientFTP
IF ! ::GetReply()
RETURN .F.
ENDIF
::cReply := SubStr( ::cReply, At('"', ::cReply) + 1, ;
Rat('"', ::cReply) - At('"', ::cReply) - 1 )
RETURN .T.
::cReply := SubStr( ::cReply, At( '"', ::cReply ) + 1, ;
RAt( '"', ::cReply ) - At( '"', ::cReply ) - 1 )
RETURN .T.
METHOD DELE( cPath ) CLASS tIPClientFTP
::InetSendall( ::SocketCon, "DELE " + cPath + ::cCRLF )
RETURN ::GetReply()
RETURN ::GetReply()
// scan last reply for an hint of length
METHOD ScanLength() CLASS tIPClientFTP
LOCAL aBytes
aBytes := HB_Regex( ::RegBytes, ::cReply )
IF ! Empty(aBytes)
::nLength := Val( aBytes[2] )
ENDIF
RETURN .T.
LOCAL aBytes := hb_regex( ::RegBytes, ::cReply )
IF ! Empty( aBytes )
::nLength := Val( aBytes[ 2 ] )
ENDIF
RETURN .T.
METHOD TransferStart() CLASS tIPClientFTP
LOCAL skt
::SocketControl := ::SocketCon
IF ::bUsePasv
skt := HB_InetConnectIP( ::cDataServer, ::nDataPort )
skt := hb_inetConnectIP( ::cDataServer, ::nDataPort )
IF skt != NIL .AND. ::InetErrorCode( skt ) == 0
// Get the start message from the control connection
IF ! ::GetReply()
HB_InetClose( skt )
hb_inetClose( skt )
RETURN .F.
ENDIF
HB_InetTimeout( skt, ::nConnTimeout )
hb_inetTimeout( skt, ::nConnTimeout )
/* Set internal socket send buffer to 64k,
* this should fix the speed problems some users have reported
*/
@@ -365,22 +354,23 @@ METHOD TransferStart() CLASS tIPClientFTP
::SocketCon := skt
ENDIF
ELSE
::SocketCon := HB_InetAccept( ::SocketPortServer )
::SocketCon := hb_inetAccept( ::SocketPortServer )
IF Empty( ::SocketCon )
::bInitialized := .F.
::SocketCon := ::SocketControl
::GetReply()
RETURN .F.
ENDIF
HB_InetSetRcvBufSize( ::SocketCon, 65536 )
HB_InetSetSndBufSize( ::SocketCon, 65536 )
hb_inetSetRcvBufSize( ::SocketCon, 65536 )
hb_inetSetSndBufSize( ::SocketCon, 65536 )
ENDIF
RETURN .T.
RETURN .T.
METHOD Commit() CLASS tIPClientFTP
HB_InetClose( ::SocketCon )
hb_inetClose( ::SocketCon )
::SocketCon := ::SocketControl
::bInitialized := .F.
@@ -393,8 +383,7 @@ METHOD Commit() CLASS tIPClientFTP
RETURN .F.
ENDIF
RETURN .T.
RETURN .T.
METHOD List( cSpec ) CLASS tIPClientFTP
LOCAL cStr
@@ -420,7 +409,8 @@ METHOD List( cSpec ) CLASS tIPClientFTP
::InetSendAll( ::SocketCon, "LIST" + cSpec + ::cCRLF )
cStr := ::ReadAuxPort()
::bEof := .F.
RETURN cStr
RETURN cStr
METHOD UserCommand( cCommand, lPasv, lReadPort, lGetReply ) CLASS tIPClientFTP
@@ -429,22 +419,21 @@ METHOD UserCommand( cCommand, lPasv, lReadPort, lGetReply ) CLASS tIPClientFTP
DEFAULT lReadPort TO .T.
DEFAULT lGetReply TO .F.
if ::bUsePasv .AND. lPasv .AND. !::Pasv()
IF ::bUsePasv .AND. lPasv .AND. !::Pasv()
RETURN .F.
endif
ENDIF
::InetSendAll( ::SocketCon, cCommand )
if lReadPort
IF lReadPort
lReadPort := ::ReadAuxPort()
endif
ENDIF
if lGetReply
IF lGetReply
lGetReply := ::GetReply()
endif
RETURN .T.
ENDIF
RETURN .T.
METHOD ReadAuxPort( cLocalFile ) CLASS tIPClientFTP
LOCAL cRet
@@ -467,7 +456,7 @@ METHOD ReadAuxPort( cLocalFile ) CLASS tIPClientFTP
cRet := ::super:Read( 512 )
ENDDO
HB_InetClose( ::SocketCon )
hb_inetClose( ::SocketCon )
::SocketCon := ::SocketControl
IF ::GetReply()
IF nFile > 0
@@ -476,8 +465,7 @@ METHOD ReadAuxPort( cLocalFile ) CLASS tIPClientFTP
ENDIF
RETURN cList
ENDIF
RETURN NIL
RETURN NIL
METHOD Stor( cFile ) CLASS tIPClientFTP
@@ -496,36 +484,33 @@ METHOD Stor( cFile ) CLASS tIPClientFTP
::GetReply()
ENDIF
RETURN ::TransferStart()
RETURN ::TransferStart()
METHOD Port() CLASS tIPClientFTP
::SocketPortServer := HB_InetCreate( ::nConnTimeout )
s_nPort ++
::SocketPortServer := hb_inetCreate( ::nConnTimeout )
s_nPort++
DO WHILE s_nPort < 24000
HB_InetServer( s_nPort, ::SocketPortServer )
hb_inetServer( s_nPort, ::SocketPortServer )
IF ::InetErrorCode( ::SocketPortServer ) == 0
RETURN ::SendPort()
ENDIF
s_nPort ++
s_nPort++
ENDDO
RETURN .F.
RETURN .F.
METHOD SendPort() CLASS tIPClientFTP
LOCAL cAddr
LOCAL cPort, nPort
cAddr := HB_InetGetHosts( NetName() )[1]
cAddr := StrTran( cAddr, ".", "," )
nPort := HB_InetPort( ::SocketPortServer )
cPort := "," + AllTrim( Str( Int( nPort / 256 ) ) ) + "," + AllTrim( Str( Int( nPort % 256 ) ) )
cAddr := StrTran( hb_inetGetHosts( NetName() )[ 1 ], ".", "," )
nPort := hb_inetPort( ::SocketPortServer )
cPort := "," + hb_ntos( Int( nPort / 256 ) ) + "," + hb_ntos( Int( nPort % 256 ) )
::InetSendall( ::SocketCon, "PORT " + cAddr + cPort + ::cCRLF )
RETURN ::GetReply()
::InetSendall( ::SocketCon, "PORT " + cAddr + cPort + ::cCRLF )
RETURN ::GetReply()
METHOD Read( nLen ) CLASS tIPClientFTP
LOCAL cRet
@@ -533,64 +518,47 @@ METHOD Read( nLen ) CLASS tIPClientFTP
IF ! ::bInitialized
IF ! Empty( ::oUrl:cPath )
IF ! ::CWD( ::oUrl:cPath )
::bEof := .T. // no data for this transaction
RETURN NIL
ENDIF
ENDIF
IF Empty( ::oUrl:cFile )
RETURN ::List()
ENDIF
IF ! ::Retr( ::oUrl:cFile )
::bEof := .T. // no data for this transaction
RETURN NIL
ENDIF
// now channel is open
::bInitialized := .T.
ENDIF
cRet := ::super:Read( nLen )
IF cRet == NIL
::Commit()
::bEof := .T.
ENDIF
RETURN cRet
RETURN cRet
*
* FTP transfer wants commit only at end.
*
/* FTP transfer wants commit only at end. */
METHOD Write( cData, nLen ) CLASS tIPClientFTP
IF ! ::bInitialized
IF Empty( ::oUrl:cFile )
RETURN -1
ENDIF
IF ! Empty( ::oUrl:cPath )
IF ! ::CWD( ::oUrl:cPath )
RETURN -1
ENDIF
ENDIF
IF ! ::Stor( ::oUrl:cFile )
@@ -601,11 +569,7 @@ METHOD Write( cData, nLen ) CLASS tIPClientFTP
::bInitialized := .T.
ENDIF
RETURN ::super:Write( cData, nLen, .F. )
/*
* HZ: What's cLocalFile good for? It's unused
*/
RETURN ::super:Write( cData, nLen, .F. )
METHOD Retr( cFile ) CLASS tIPClientFTP
@@ -623,18 +587,15 @@ METHOD Retr( cFile ) CLASS tIPClientFTP
RETURN .T.
ENDIF
RETURN .F.
RETURN .F.
METHOD MGET( cSpec,cLocalPath ) CLASS tIPClientFTP
METHOD MGET( cSpec, cLocalPath ) CLASS tIPClientFTP
LOCAL cStr,cfile,aFiles
LOCAL cStr, cFile
DEFAULT cSpec TO ""
DEFAULT cLocalPath TO ""
IF cSpec == NIL
cSpec := ""
ENDIF
IF cLocalPath == NIL
cLocalPath:=""
ENDIF
IF ::bUsePasv
IF ! ::Pasv()
//::bUsePasv := .F.
@@ -645,48 +606,45 @@ METHOD MGET( cSpec,cLocalPath ) CLASS tIPClientFTP
::InetSendAll( ::SocketCon, "NLST " + cSpec + ::cCRLF )
cStr := ::ReadAuxPort()
IF !empty(cStr)
aFiles:=hb_atokens(strtran(cStr,chr(13),""),chr(10))
FOR each cFile in aFiles
IF !Empty(cFile) //PM:09-08-2007 Needed because of the new HB_aTokens()
::downloadfile( cLocalPath+trim(cFile), trim(cFile) )
IF ! Empty( cStr )
FOR EACH cFile IN hb_ATokens( StrTran( cStr, Chr( 13 ) ), Chr( 10 ) )
IF ! Empty( cFile ) //PM:09-08-2007 Needed because of the new hb_ATokens()
::downloadfile( cLocalPath + RTrim( cFile ), RTrim( cFile ) )
ENDIF
NEXT
ENDIF
RETURN cStr
RETURN cStr
METHOD MPUT( cFileSpec, cAttr ) CLASS tIPClientFTP
LOCAL cPath,cFile, cExt, aFile, aFiles
LOCAL cPath, cFile, cExt, aFile
LOCAL cStr := ""
IF ! ISCHARACTER( cFileSpec )
RETURN 0
ENDIF
HB_FNameSplit( cFileSpec, @cPath, @cFile, @cExt )
hb_FNameSplit( cFileSpec, @cPath, @cFile, @cExt )
aFiles := Directory( cPath + cFile + cExt, cAttr )
FOR each aFile in aFiles
IF ::uploadFile( cPath + aFile[F_NAME], aFile[F_NAME] )
cStr += HB_InetCrlf() + aFile[F_NAME]
FOR EACH aFile IN Directory( cPath + cFile + cExt, cAttr )
IF ::uploadFile( cPath + aFile[ F_NAME ], aFile[ F_NAME ] )
cStr += hb_inetCrlf() + aFile[ F_NAME ]
ENDIF
NEXT
RETURN SubStr(cStr,3)
RETURN SubStr( cStr, Len( hb_inetCrlf() ) + 1 )
METHOD UpLoadFile( cLocalFile, cRemoteFile ) CLASS tIPClientFTP
LOCAL cPath := ""
LOCAL cFile := ""
LOCAL cExt := ""
LOCAL cPath
LOCAL cFile
LOCAL cExt
HB_FNameSplit( cLocalFile, @cPath, @cFile,@cExt )
hb_FNameSplit( cLocalFile, @cPath, @cFile,@cExt )
DEFAULT cRemoteFile to cFile + cExt
DEFAULT cRemoteFile TO cFile + cExt
::bEof := .F.
::oUrl:cFile := cRemoteFile
@@ -717,16 +675,13 @@ METHOD UpLoadFile( cLocalFile, cRemoteFile ) CLASS tIPClientFTP
::bInitialized := .T.
ENDIF
RETURN ::WriteFromFile( cLocalFile )
RETURN ::WriteFromFile( cLocalFile )
METHOD LS( cSpec ) CLASS tIPClientFTP
LOCAL cStr
IF cSpec == NIL
cSpec := ""
ENDIF
DEFAULT cSpec TO ""
IF ::bUsePasv .AND. ! ::Pasv()
//::bUsePasv := .F.
@@ -744,34 +699,30 @@ METHOD LS( cSpec ) CLASS tIPClientFTP
cStr := ""
ENDIF
RETURN cStr
/*Rename a traves del ftp */
RETURN cStr
/* Rename a traves del ftp */
METHOD Rename( cFrom, cTo ) CLASS tIPClientFTP
LOCAL lResult := .F.
LOCAL lResult := .F.
::InetSendAll( ::SocketCon, "RNFR " + cFrom + ::cCRLF )
::InetSendAll( ::SocketCon, "RNFR " + cFrom + ::cCRLF )
IF ::GetReply()
IF ::GetReply()
::InetSendAll( ::SocketCon, "RNTO " + cTo + ::cCRLF )
lResult := ::GetReply()
ENDIF
::InetSendAll( ::SocketCon, "RNTO " + cTo + ::cCRLF )
lResult := ::GetReply()
ENDIF
RETURN lResult
RETURN lResult
METHOD DownLoadFile( cLocalFile, cRemoteFile ) CLASS tIPClientFTP
LOCAL cPath := ""
LOCAL cFile := ""
LOCAL cExt := ""
LOCAL cPath
LOCAL cFile
LOCAL cExt
HB_FNameSplit( cLocalFile, @cPath, @cFile, @cExt )
hb_FNameSplit( cLocalFile, @cPath, @cFile, @cExt )
DEFAULT cRemoteFile to cFile+cExt
DEFAULT cRemoteFile TO cFile + cExt
::bEof := .F.
::oUrl:cFile := cRemoteFile
@@ -794,36 +745,36 @@ METHOD DownLoadFile( cLocalFile, cRemoteFile ) CLASS tIPClientFTP
// now channel is open
::bInitialized := .T.
ENDIF
RETURN ::ReadToFile( cLocalFile, , ::nLength )
RETURN ::ReadToFile( cLocalFile, , ::nLength )
// Create a new folder
METHOD MKD( cPath ) CLASS tIPClientFTP
::InetSendall( ::SocketCon, "MKD " + cPath + ::cCRLF )
RETURN ::GetReply()
RETURN ::GetReply()
// Delete an existing folder
METHOD RMD( cPath ) CLASS tIPClientFTP
::InetSendall( ::SocketCon, "RMD " + cPath + ::cCRLF )
RETURN ::GetReply()
RETURN ::GetReply()
// Return total file size for <cFileSpec>
METHOD fileSize( cFileSpec ) CLASS tIPClientFTP
LOCAL aFiles:=::ListFiles( cFileSpec ), nSize:=0, n
FOR n =1 TO Len(aFiles)
nSize+=Val(aFiles[n][7]) // Should [7] not be [F_SIZE] ?
LOCAL aFile
LOCAL nSize := 0
FOR EACH aFile IN ::ListFiles( cFileSpec )
nSize += Val( aFile[ F_SIZE ] )
NEXT
RETURN nSize
RETURN nSize
// Parse the :list() string into a Directory() compatible 2-dim array
METHOD listFiles( cFileSpec ) CLASS tIPClientFTP
LOCAL aMonth:= { "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" }
LOCAL aMonth := { "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" }
LOCAL cList, aList, aFile, cEntry, nStart, nEnd
LOCAL cYear, cMonth, cDay, cTime
@@ -833,70 +784,70 @@ METHOD listFiles( cFileSpec ) CLASS tIPClientFTP
RETURN {}
ENDIF
aList := HB_ATokens( StrTran( cList, Chr(13),""), Chr(10) )
aList := hb_ATokens( StrTran( cList, Chr( 13 ) ), Chr( 10 ) )
FOR EACH cEntry IN aList
IF Empty( cEntry ) //PM:09-08-2007 Needed because of the new HB_aTokens()
IF Empty( cEntry ) //PM:09-08-2007 Needed because of the new hb_ATokens()
hb_ADel(aList, cEntry:__enumIndex(), .T.)
hb_ADel( aList, cEntry:__enumIndex(), .T. )
ELSE
aFile := Array( F_LEN+3 )
aFile := Array( F_LEN + 3 )
nStart := 1
nEnd := hb_At( Chr(32), cEntry, nStart )
nEnd := hb_At( " ", cEntry, nStart )
// file permissions (attributes)
aFile[F_ATTR] := SubStr( cEntry, nStart, nEnd-nStart )
nStart := nEnd
aFile[ F_ATTR ] := SubStr( cEntry, nStart, nEnd - nStart )
nStart := nEnd
// # of links
DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " ; ENDDO
nEnd := hb_At( Chr(32), cEntry, nStart )
aFile[F_LEN+1]:= Val( SubStr( cEntry, nStart, nEnd-nStart ) )
nStart := nEnd
nEnd := hb_At( " ", cEntry, nStart )
aFile[ F_LEN + 1 ] := Val( SubStr( cEntry, nStart, nEnd - nStart ) )
nStart := nEnd
// owner name
DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " ; ENDDO
nEnd := hb_At( Chr(32), cEntry, nStart )
aFile[F_LEN+2]:= SubStr( cEntry, nStart, nEnd-nStart )
nStart := nEnd
nEnd := hb_At( " ", cEntry, nStart )
aFile[ F_LEN + 2 ] := SubStr( cEntry, nStart, nEnd - nStart )
nStart := nEnd
// group name
DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " ; ENDDO
nEnd := hb_At( Chr(32), cEntry, nStart )
aFile[F_LEN+3]:= SubStr( cEntry, nStart, nEnd-nStart )
nStart := nEnd
nEnd := hb_At( " ", cEntry, nStart )
aFile[ F_LEN + 3 ] := SubStr( cEntry, nStart, nEnd - nStart )
nStart := nEnd
// file size
DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " ; ENDDO
nEnd := hb_At( Chr(32), cEntry, nStart )
aFile[F_SIZE] := Val( SubStr( cEntry, nStart, nEnd-nStart ) )
nStart := nEnd
nEnd := hb_At( " ", cEntry, nStart )
aFile[ F_SIZE ] := Val( SubStr( cEntry, nStart, nEnd - nStart ) )
nStart := nEnd
// Month
DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " ; ENDDO
nEnd := hb_At( Chr(32), cEntry, nStart )
cMonth := SubStr( cEntry, nStart, nEnd-nStart )
nEnd := hb_At( " ", cEntry, nStart )
cMonth := SubStr( cEntry, nStart, nEnd - nStart )
cMonth := PadL( AScan( aMonth, cMonth ), 2, "0" )
nStart := nEnd
// Day
DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " ; ENDDO
nEnd := hb_At( Chr(32), cEntry, nStart )
cDay := SubStr( cEntry, nStart, nEnd-nStart )
nEnd := hb_At( " ", cEntry, nStart )
cDay := SubStr( cEntry, nStart, nEnd - nStart )
nStart := nEnd
// year
DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " ; ENDDO
nEnd := hb_At( Chr(32), cEntry, nStart )
cYear := SubStr( cEntry, nStart, nEnd-nStart )
nEnd := hb_At( " ", cEntry, nStart )
cYear := SubStr( cEntry, nStart, nEnd - nStart )
nStart := nEnd
IF ":" $ cYear
cTime := cYear
cYear := Str( Year(Date()), 4, 0 )
cYear := Str( Year( Date() ), 4, 0 )
ELSE
cTime := ""
ENDIF
@@ -904,9 +855,9 @@ METHOD listFiles( cFileSpec ) CLASS tIPClientFTP
// file name
DO WHILE SubStr( cEntry, ++nStart, 1 ) == " " ; ENDDO
aFile[F_NAME] := SubStr( cEntry, nStart )
aFile[F_DATE] := hb_StoD( cYear+cMonth+cDay )
aFile[F_TIME] := cTime
aFile[ F_NAME ] := SubStr( cEntry, nStart )
aFile[ F_DATE ] := hb_SToD( cYear + cMonth + cDay )
aFile[ F_TIME ] := cTime
aList[ cEntry:__enumIndex() ] := aFile
@@ -914,4 +865,4 @@ METHOD listFiles( cFileSpec ) CLASS tIPClientFTP
NEXT
RETURN aList
RETURN aList

523
harbour/contrib/hbtip/httpcln.prg
View File

@@ -7,7 +7,6 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
@@ -51,8 +50,11 @@
*
*/
#include "common.ch"
#include "hbclass.ch"
#include "common.ch"
#include "fileio.ch"
#include "tip.ch"
/**
@@ -60,51 +62,56 @@
*/
CREATE CLASS tIPClientHTTP FROM tIPClient
VAR cMethod
VAR nReplyCode
VAR cReplyDescr
VAR nVersion INIT 1
VAR nSubversion INIT 0
VAR nVersion INIT 1
VAR nSubversion INIT 0
VAR bChunked
VAR hHeaders INIT {=>}
VAR hCookies INIT {=>}
VAR hFields INIT {=>}
VAR cUserAgent INIT "Mozilla/3.0 compatible"
VAR hHeaders INIT { => }
VAR hCookies INIT { => }
VAR hFields INIT { => }
VAR cUserAgent INIT "Mozilla/3.0 compatible"
VAR cAuthMode INIT ""
VAR cBoundary
VAR aAttachments init {}
VAR aAttachments INIT {}
METHOD New( oUrl,lTrace, oCredentials)
METHOD New( oUrl, lTrace, oCredentials )
METHOD Get( cQuery )
METHOD Post( cPostData, cQuery )
METHOD Post( xPostData, cQuery )
METHOD ReadHeaders()
METHOD Read( nLen )
METHOD UseBasicAuth() INLINE ::cAuthMode := "Basic"
Method ReadAll()
Method SetCookie
Method GetCookies
Method Boundary
METHOD Attach(cName,cFileName,cType)
Method PostMultiPart
Method WriteAll( cFile )
METHOD ReadAll()
METHOD SetCookie
METHOD GetCookies
METHOD Boundary
METHOD Attach( cName, cFileName, cType )
METHOD PostMultiPart( xPostData, cQuery )
METHOD WriteAll( cFile )
HIDDEN:
HIDDEN:
METHOD StandardFields()
ENDCLASS
METHOD New( oUrl,lTrace, oCredentials) CLASS tIPClientHTTP
METHOD New( oUrl, lTrace, oCredentials ) CLASS tIPClientHTTP
::super:new( oUrl, lTrace, oCredentials )
::nDefaultPort := 80
::nConnTimeout := 5000
::bChunked := .F.
hb_hCaseMatch( ::hHeaders, .F. )
RETURN Self
hb_HCaseMatch( ::hHeaders, .F. )
RETURN Self
METHOD Get( cQuery ) CLASS tIPClientHTTP
IF ! HB_IsString( cQuery )
IF ! hb_isString( cQuery )
cQuery := ::oUrl:BuildQuery()
ENDIF
@@ -114,52 +121,44 @@ METHOD Get( cQuery ) CLASS tIPClientHTTP
IF ::InetErrorCode( ::SocketCon ) == 0
RETURN ::ReadHeaders()
ENDIF
RETURN .F.
RETURN .F.
METHOD Post( cPostData, cQuery ) CLASS tIPClientHTTP
LOCAL cData, nI, cTmp,y
METHOD Post( xPostData, cQuery ) CLASS tIPClientHTTP
LOCAL cData, nI, cTmp, y
IF HB_IsHash( cPostData )
IF hb_isHash( xPostData )
cData := ""
FOR nI := 1 TO Len( cPostData )
cTmp := hb_HKeyAt( cPostData, nI )
cTmp := hb_cStr( cTmp )
cTmp := AllTrim( cTmp )
cTmp := TipEncoderUrl_Encode( cTmp )
cData += cTmp +"="
cTmp := hb_HValueAt( cPostData, nI )
cTmp := hb_cStr( cTmp )
cTmp := TipEncoderUrl_Encode( cTmp )
cData += cTmp + "&"
NEXT
cData := left( cData, len( cData ) - 1 )
ELSEIF HB_IsArray( cPostData )
cData := ""
y:=Len(cPostData)
y := Len( xPostData )
FOR nI := 1 TO y
cTmp := cPostData[ nI ,1]
cTmp := hb_cStr( cTmp )
cTmp := AllTrim( cTmp )
cTmp := TipEncoderUrl_Encode( cTmp )
cData += cTmp +"="
cTmp := cPostData[ nI,2]
cTmp := hb_cStr( cTmp )
cTmp := TipEncoderUrl_Encode( cTmp )
cTmp := TipEncoderUrl_Encode( AllTrim( hb_cStr( hb_HKeyAt( xPostData, nI ) ) ) )
cData += cTmp + "="
cTmp := TipEncoderUrl_Encode( hb_cStr( hb_HValueAt( xPostData, nI ) ) )
cData += cTmp
IF nI!=y
cData+="&"
IF nI != y
cData += "&"
ENDIF
NEXT
ELSEIF HB_IsString( cPostData )
cData := cPostData
ELSEIF hb_isArray( xPostData )
cData := ""
y := Len( xPostData )
FOR nI := 1 TO y
cTmp := TipEncoderUrl_Encode( AllTrim( hb_cStr( xPostData[ nI, 1 ] ) ) )
cData += cTmp + "="
cTmp := TipEncoderUrl_Encode( hb_cStr( xPostData[ nI, 2 ] ) )
cData += cTmp
IF nI != y
cData += "&"
ENDIF
NEXT
ELSEIF hb_isString( xPostData )
cData := xPostData
ELSE
Alert( "TipClientHTTP_PostRequest: Invalid parameters" )
RETURN .F.
ENDIF
IF ! HB_IsString( cQuery )
IF ! hb_isString( cQuery )
cQuery := ::oUrl:BuildQuery()
ENDIF
@@ -180,10 +179,9 @@ METHOD Post( cPostData, cQuery ) CLASS tIPClientHTTP
::InetSendall( ::SocketCon, cData )
::bInitialized := .T.
RETURN ::ReadHeaders()
/* else
alert("Post HB_InetErrorCode:"+winsockerrorcode(::InetErrorCode( ::SocketCon )))*/
ENDIF
RETURN .F.
RETURN .F.
METHOD StandardFields() CLASS tIPClientHTTP
LOCAL iCount
@@ -214,11 +212,9 @@ METHOD StandardFields() CLASS tIPClientHTTP
": " + hb_HValueAt( ::hFields, iCount ) + ::cCRLF )
NEXT
RETURN .T.
RETURN .T.
METHOD ReadHeaders(lClear) CLASS tIPClientHTTP
METHOD ReadHeaders( lClear ) CLASS tIPClientHTTP
LOCAL cLine, nPos, aVersion
LOCAL aHead
@@ -230,7 +226,7 @@ METHOD ReadHeaders(lClear) CLASS tIPClientHTTP
ENDIF
// Get Protocol version
aVersion := HB_Regex( "^HTTP/(.)\.(.) ([0-9][0-9][0-9]) +(.*)$", cLine )
aVersion := hb_regex( "^HTTP/(.)\.(.) ([0-9][0-9][0-9]) +(.*)$", cLine )
::cReply := cLine
IF aVersion == NIL
@@ -239,50 +235,49 @@ METHOD ReadHeaders(lClear) CLASS tIPClientHTTP
::nReplyCode := 0
::cReplyDescr := ""
ELSE
::nVersion := Val(aVersion[2])
::nSubversion := Val( aVersion[3] )
::nReplyCode := val( aVersion[4] )
::cReplyDescr := aVersion[5]
::nVersion := Val( aVersion[ 2 ] )
::nSubversion := Val( aVersion[ 3 ] )
::nReplyCode := Val( aVersion[ 4 ] )
::cReplyDescr := aVersion[ 5 ]
ENDIF
::nLength := -1
::bChunked := .F.
cLine := ::InetRecvLine( ::SocketCon, @nPos, 500 )
IF ! lClear == .F. .AND. !empty(::hHeaders)
::hHeaders := {=>}
IF ! lClear == .F. .AND. ! Empty( ::hHeaders )
::hHeaders := { => }
ENDIF
DO WHILE ::InetErrorCode( ::SocketCon ) == 0 .AND. ! Empty( cLine )
aHead := HB_RegexSplit( ":", cLine,,, 1 )
aHead := hb_regexSplit( ":", cLine,,, 1 )
IF aHead == NIL .OR. Len( aHead ) != 2
cLine := ::InetRecvLine( ::SocketCon, @nPos, 500 )
LOOP
ENDIF
::hHeaders[ aHead[1] ] := LTrim(aHead[2])
::hHeaders[ aHead[ 1 ] ] := LTrim( aHead[ 2 ] )
DO CASE
// RFC 2068 forces to discard content length on chunked encoding
CASE Lower( aHead[ 1 ] ) == "content-length" .AND. ! ::bChunked
cLine := SubStr( cLine, 16 )
::nLength := Val( cLine )
// RFC 2068 forces to discard content length on chunked encoding
CASE lower( aHead[1] ) == "content-length" .AND. ! ::bChunked
cLine := Substr( cLine, 16 )
::nLength := Val( cLine )
// as above
CASE lower( aHead[1] ) == "transfer-encoding"
IF At( "chunked", lower( cLine ) ) > 0
::bChunked := .T.
::nLength := -1
ENDIF
CASE lower( aHead[1] ) == "set-cookie"
::setCookie(aHead[2])
// as above
CASE Lower( aHead[ 1 ] ) == "transfer-encoding"
IF At( "chunked", Lower( cLine ) ) > 0
::bChunked := .T.
::nLength := -1
ENDIF
CASE Lower( aHead[ 1 ] ) == "set-cookie"
::setCookie( aHead[ 2 ] )
ENDCASE
cLine := ::InetRecvLine( ::SocketCon, @nPos, 500 )
ENDDO
IF ::InetErrorCode( ::SocketCon ) != 0
RETURN .F.
ENDIF
RETURN .T.
RETURN .T.
METHOD Read( nLen ) CLASS tIPClientHTTP
LOCAL cData, nPos, cLine, aHead
@@ -313,7 +308,7 @@ METHOD Read( nLen ) CLASS tIPClientHTTP
cLine := ::InetRecvLine( ::SocketCon, @nPos, 1024 )
DO WHILE ! Empty( cLine )
// add Headers to footers
aHead := HB_RegexSplit( ":", cLine,,, 1 )
aHead := hb_regexSplit( ":", cLine,,, 1 )
IF aHead != NIL
::hHeaders[ aHead[1] ] := LTrim(aHead[2])
ENDIF
@@ -329,9 +324,9 @@ METHOD Read( nLen ) CLASS tIPClientHTTP
// A normal chunk here
// Remove the extensions
nPos := at( ";", cLine )
nPos := At( ";", cLine )
IF nPos > 0
cLine := Substr( cLine, 1, nPos - 1 )
cLine := SubStr( cLine, 1, nPos - 1 )
ENDIF
// Convert to length
@@ -352,11 +347,11 @@ METHOD Read( nLen ) CLASS tIPClientHTTP
ENDIF
RETURN cData
RETURN cData
METHOD ReadAll() CLASS tIPClientHTTP
LOCAL cOut:="", cChunk
LOCAL cOut := "", cChunk
IF ! ::bInitialized
::bInitialized := .T.
IF ! ::Get()
@@ -365,227 +360,216 @@ METHOD ReadAll() CLASS tIPClientHTTP
ENDIF
IF ::bChunked
cChunk:=::read()
do while cChunk != NIL
cOut+=cChunk
// ::nLength:=-1
cChunk:=::read()
enddo
else
DO WHILE cChunk != NIL
cOut += cChunk
// ::nLength := -1
cChunk := ::read()
ENDDO
ELSE
RETURN ::read()
endif
ENDIF
RETURN cOut
METHOD setCookie(cLine) CLASS tIPClientHTTP
METHOD setCookie( cLine ) CLASS tIPClientHTTP
//docs from http://www.ietf.org/rfc/rfc2109.txt
LOCAL aParam
LOCAL cHost, cPath, cName, cValue, aElements, cElement
LOCAL cDefaultHost:=::oUrl:cServer, cDefaultPath:=::oUrl:cPath
LOCAL x,y
IF empty(cDefaultPath)
cDefaultPath:="/"
LOCAL cDefaultHost := ::oUrl:cServer, cDefaultPath := ::oUrl:cPath
LOCAL x, y
IF Empty( 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
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
cName:=alltrim(aElements[1])
cValue:=alltrim(aElements[2])
else
cElement:=upper(alltrim(aElements[1]))
do case
//case cElement=="EXPIRES"
case cElement=="PATH"
cPath:=alltrim(aElements[2])
case cElement=="DOMAIN"
cHost:=alltrim(aElements[2])
endcase
cName := AllTrim( aElements[ 1 ] )
cValue := AllTrim( aElements[ 2 ] )
ELSE
cElement := Upper( AllTrim( aElements[ 1 ] ) )
DO CASE
//CASE cElement == "EXPIRES"
CASE cElement == "PATH"
cPath := AllTrim( aElements[ 2 ] )
CASE cElement == "DOMAIN"
cHost := AllTrim( aElements[ 2 ] )
ENDCASE
ENDIF
ENDIF
next
IF !empty(cName)
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)
::hCookies[cHost]:={=>}
endif
if !HB_HHASKEY(::hCookies[cHost],cPath)
::hCookies[cHost][cPath]:={=>}
endif
::hCookies[cHost][cPath][cName]:=cValue
IF ! hb_HHasKey( ::hCookies, cHost )
::hCookies[ cHost ] := { => }
ENDIF
IF ! hb_HHasKey( ::hCookies[ cHost ], cPath )
::hCookies[ cHost ][ cPath ] := { => }
ENDIF
::hCookies[ cHost ][ cPath ][ cName ] := cValue
ENDIF
RETURN NIL
RETURN NIL
METHOD getcookies(cHost,cPath) CLASS tIPClientHTTP
LOCAL x,y,aDomKeys:={},aKeys,z,cKey,aPathKeys,nPath
METHOD getcookies( cHost, cPath ) CLASS tIPClientHTTP
LOCAL x, y, aDomKeys := {}, aKeys, z, cKey, aPathKeys, nPath
LOCAL a, b, cOut := "", c, d
IF cHost == NIL
cHost:=::oUrl:cServer
ENDIF
DEFAULT cHost TO ::oUrl:cServer
IF cPath == NIL
cPath:=::oUrl:cPath
IF empty(cPath)
cPath:="/"
cPath := ::oUrl:cPath
IF Empty( cPath )
cPath := "/"
ENDIF
ENDIF
IF empty(cHost)
IF Empty( cHost )
RETURN cOut
ENDIF
//tail matching the domain
aKeys:=hb_hkeys(::hCookies)
y:=len(aKeys)
z:=len(cHost)
cHost:=upper(cHost)
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])
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 ] )
ENDIF
NEXT
//more specific paths should be sent before lesser generic paths.
asort(aDomKeys,,, {|cX,cY| len(cX) > len(cY)} )
y:=len(aDomKeys)
ASort( aDomKeys,,, {| cX, cY | Len( cX ) > Len( cY ) } )
y := Len( aDomKeys )
//now that we have the domain matches we have to do path matchine
nPath:=len(cPath)
nPath := Len( cPath )
FOR x := 1 TO y
aKeys:=hb_hkeys(::hCookies[aDomKeys[x]])
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])
aKeys := hb_Hkeys( ::hCookies[ aDomKeys[ x ] ] )
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 ] )
ENDIF
NEXT
asort(aPathKeys,,, {|cX,cY| len(cX) > len(cY)} )
b:=len(aPathKeys)
ASort( aPathKeys,,, {| cX, cY | Len( cX ) > Len( cY ) } )
b := Len( aPathKeys )
FOR a := 1 TO b
aKeys:=hb_hkeyat(::hCookies[aDomKeys[x]][aPathKeys[a]])
d:=len(aKeys)
aKeys := hb_Hkeyat( ::hCookies[ aDomKeys[ x ] ] [ aPathKeys[ a ] ] )
d := Len( aKeys )
FOR c := 1 TO d
IF !empty(cOut)
cOut+="; "
IF ! Empty( cOut )
cOut += "; "
ENDIF
cOut+=aKeys[c]+"="+::hCookies[aDomKeys[x]][aPathKeys[a]][aKeys[c]]
cOut += aKeys[ c ] + "=" + ::hCookies[ aDomKeys[ x ] ][ aPathKeys[ a ] ][ aKeys[ c ] ]
NEXT
NEXT
NEXT
RETURN cOut
RETURN cOut
METHOD Boundary(nType) CLASS tIPClientHTTP
METHOD Boundary( nType ) CLASS tIPClientHTTP
/*
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
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
---------------------------41184676334 //in the header or CGI envirnment
*/
LOCAL cBound:=::cBoundary
LOCAL cBound := ::cBoundary
LOCAL i
IF nType == NIL
nType := 0
ENDIF
IF empty(cBound)
cBound:=replicate("-",27)+space(11)
DEFAULT nType TO 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) )
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)
METHOD Attach(cName,cFileName,cType) CLASS tIPClientHTTP
aadd(::aAttachments,{cName,cFileName,cType})
RETURN NIL
METHOD PostMultiPart( cPostData, 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
IF empty(cPostData)
ELSEIF HB_IsHash( cPostData )
FOR nI := 1 TO Len( cPostData )
cTmp := hb_HKeyAt( cPostData, nI )
cTmp := hb_cStr( cTmp )
cTmp := AllTrim( cTmp )
cTmp := TipEncoderUrl_Encode( cTmp )
cData += cBound+cCrlf+'Content-Disposition: form-data; name="'+cTmp +'"'+cCrlf+cCrLf
cTmp := hb_HValueAt( cPostData, nI )
cTmp := hb_cStr( cTmp )
cTmp := AllTrim( cTmp )
cTmp := TipEncoderUrl_Encode( cTmp )
cData += cTmp+cCrLf
NEXT
ELSEIF HB_IsArray( cPostData )
y:=Len(cPostData)
FOR nI := 1 TO y
cTmp := cPostData[ nI ,1]
cTmp := hb_cStr( cTmp )
cTmp := AllTrim( cTmp )
cTmp := TipEncoderUrl_Encode( cTmp )
cData += cBound+cCrlf+'Content-Disposition: form-data; name="'+cTmp +'"'+cCrlf+cCrLf
cTmp := cPostData[ nI,2]
cTmp := hb_cStr( cTmp )
cTmp := AllTrim( cTmp )
cTmp := TipEncoderUrl_Encode( cTmp )
cData += cTmp+cCrLf
NEXT
ELSEIF HB_IsString( cPostData )
cData := cPostData
::cBoundary := cBound
ENDIF
FOR each oSub in ::aAttachments
cName:=oSub[1]
cFile:=oSub[2]
cType:=oSub[3]
cTmp:=strtran(cFile,"/","\")
IF ( nPos := rat( "\", cTmp ) ) != 0
cFilePath := substr( cTmp, 1, nPos )
ELSEIF ( nPos := rat( ":", cTmp ) ) != 0
cFilePath := substr( cTmp, 1, nPos )
cBound := iif( nType < 2, "--", "" ) + cBound + iif( nType == 1, "--", "" )
RETURN cBound
METHOD Attach( cName, cFileName, cType ) CLASS tIPClientHTTP
AAdd( ::aAttachments, { cName, cFileName, cType } )
RETURN NIL
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
IF Empty( xPostData )
ELSEIF hb_isHash( xPostData )
y := Len( xPostData )
FOR nI := 1 TO y
cTmp := TipEncoderUrl_Encode( AllTrim( hb_cStr( hb_HKeyAt( xPostData, nI ) ) ) )
cData += cBound + cCrlf + 'Content-Disposition: form-data; name="' + cTmp + '"' + cCrlf + cCrLf
cTmp := TipEncoderUrl_Encode( AllTrim( hb_cStr( hb_HValueAt( xPostData, nI ) ) ) )
cData += cTmp + cCrLf
NEXT
ELSEIF hb_isArray( xPostData )
y := Len( xPostData )
FOR nI := 1 TO y
cTmp := TipEncoderUrl_Encode( AllTrim( hb_cStr( xPostData[ nI, 1 ] ) ) )
cData += cBound + cCrlf + 'Content-Disposition: form-data; name="' + cTmp + '"' + cCrlf + cCrLf
cTmp := TipEncoderUrl_Encode( AllTrim( hb_cStr( xPostData[ nI, 2 ] ) ) )
cData += cTmp + cCrLf
NEXT
ELSEIF hb_isString( xPostData )
cData := xPostData
ENDIF
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)
cType:="text/html"
cTmp := SubStr( cFile, Len( cFilePath ) + 1 )
IF Empty( cType )
cType := "text/html"
ENDIF
cData += cBound+cCrlf+'Content-Disposition: form-data; name="'+cName +'"; filename="'+cTmp+'"'+cCrlf+'Content-Type: '+cType+cCrLf+cCrLf
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)
nbuf:=8192
nRead:=nBuf
//cBuf:=space(nBuf)
do while nRead == nBuf
//nRead := FRead( nFile,@cBuf,nBuf)
cBuf:=FReadstr( nFile,nBuf)
nRead:=len(cBuf)
/* IF nRead<nBuf
cBuf:=pad(cBuf,nRead)
nFile := FOpen( cFile )
/* TOFIX: Error checking on nFile. [vszakats] */
nbuf := 8192
nRead := nBuf
//cBuf := Space( nBuf )
DO WHILE nRead == nBuf
// nRead := FRead( nFile, @cBuf, nBuf )
cBuf := FReadStr( nFile, nBuf )
nRead := Len( cBuf )
/* IF nRead < nBuf
cBuf := PadR( cBuf, nRead )
ENDIF
*/
cData+=cBuf
enddo
fClose(nFile)
cData+=cCrlf
cData += cBuf
ENDDO
FClose( nFile )
cData += cCrlf
NEXT
cData+=cBound+"--"+cCrlf
IF ! HB_IsString( cQuery )
cData += cBound + "--" + cCrlf
IF ! hb_isString( cQuery )
cQuery := ::oUrl:BuildQuery()
ENDIF
@@ -593,11 +577,10 @@ METHOD PostMultiPart( cPostData, cQuery ) CLASS tIPClientHTTP
::StandardFields()
IF ! "Content-Type" $ ::hFields
::InetSendall( ::SocketCon, e"Content-Type: multipart/form-data; boundary="+::boundary(2)+::cCrlf )
::InetSendall( ::SocketCon, e"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( Len( cData ) ) + ::cCRLF )
// End of header
::InetSendall( ::SocketCon, ::cCRLF )
@@ -605,29 +588,25 @@ METHOD PostMultiPart( cPostData, cQuery ) CLASS tIPClientHTTP
::InetSendall( ::SocketCon, cData )
::bInitialized := .T.
RETURN ::ReadHeaders()
/* else
alert("Post HB_InetErrorCode:"+winsockerrorcode(::InetErrorCode( ::SocketCon )))*/
ENDIF
RETURN .F.
RETURN .F.
METHOD WriteAll( cFile ) CLASS tIPClientHTTP
LOCAL nFile
LOCAL lSuccess
LOCAL nLen
LOCAL cStream
cStream := ::ReadAll()
nLen := len( cStream )
nFile := FCreate( cFile )
if nFile != 0
IF ( nFile := FCreate( cFile ) ) != F_ERROR
cStream := ::ReadAll()
nLen := Len( cStream )
lSuccess := ( FWrite( nFile, cStream, nLen ) == nLen )
FClose( nFile )
else
ELSE
lSuccess := .F.
endif
ENDIF
RETURN lSuccess

227
harbour/contrib/hbtip/mail.prg
View File

@@ -7,7 +7,6 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
@@ -61,6 +60,7 @@
*/
#include "hbclass.ch"
#include "common.ch"
CREATE CLASS TipMail
@@ -106,7 +106,9 @@ CREATE CLASS TipMail
METHOD attachFile( cFileName )
METHOD detachFile( cPath )
METHOD getFileName()
HIDDEN:
HIDDEN:
VAR cBody
VAR lBodyEncoded init .F.
VAR oEncoder
@@ -118,7 +120,7 @@ ENDCLASS
METHOD New( cBody, oEncoder ) CLASS TipMail
// Set header fileds to non-sensitive
::hHeaders := hb_HSetCaseMatch( {=>}, .F. )
::hHeaders := hb_HSetCaseMatch( { => }, .F. )
::aAttachments := {}
IF Valtype( oEncoder ) $ "CO"
@@ -132,22 +134,19 @@ METHOD New( cBody, oEncoder ) CLASS TipMail
ELSE
::cBody := cBody
ENDIF
::hHeaders[ "Content-Length" ] := Ltrim( Str( Len( ::cBody ) ) )
::hHeaders[ "Content-Length" ] := hb_ntos( Len( ::cBody ) )
ENDIF
RETURN Self
RETURN Self
METHOD SetEncoder( cEnc ) CLASS TipMail
if HB_IsString( cEnc )
if hb_isString( cEnc )
::oEncoder := TIp_GetEncoder( cEnc )
ELSE
::oEncoder := cEnc
ENDIF
::hHeaders[ "Content-transfer-encoding" ] := ::oEncoder:cName
RETURN .T.
RETURN .T.
METHOD SetBody( cBody ) CLASS TipMail
IF ::oEncoder != NIL
@@ -156,9 +155,8 @@ METHOD SetBody( cBody ) CLASS TipMail
ELSE
::cBody := cBody
ENDIF
//::hHeaders[ "Content-Length" ] := Ltrim( Str( Len( cBody ) ) ) //GD -not needed
RETURN .T.
//::hHeaders[ "Content-Length" ] := hb_ntos( Len( cBody ) ) //GD -not needed
RETURN .T.
METHOD GetBody() CLASS TipMail
IF ::cBody == NIL
@@ -166,8 +164,7 @@ METHOD GetBody() CLASS TipMail
ELSEIF ::oEncoder != NIL
RETURN ::oEncoder:Decode( ::cBody )
ENDIF
RETURN ::cBody
RETURN ::cBody
METHOD GetFieldPart( cPart ) CLASS TipMail
LOCAL nPos, cEnc
@@ -179,12 +176,11 @@ METHOD GetFieldPart( cPart ) CLASS TipMail
cEnc := hb_HValueAt( ::hHeaders, nPos )
nPos := At( ";", cEnc )
IF nPos != 0
cEnc := Substr( cEnc, 1, nPos - 1)
cEnc := SubStr( cEnc, 1, nPos - 1)
ENDIF
ENDIF
RETURN cEnc
RETURN cEnc
METHOD GetFieldOption( cPart, cOption ) CLASS TipMail
LOCAL nPos, aMatch
@@ -196,15 +192,15 @@ METHOD GetFieldOption( cPart, cOption ) CLASS TipMail
ELSE
cEnc := hb_HValueAt( ::hHeaders, nPos )
// Case insensitive check
aMatch := HB_Regex( ";\s*" + cOption +"\s*=\s*([^;]*)", cEnc, .F. )
aMatch := hb_regex( ";\s*" + cOption + "\s*=\s*([^;]*)", cEnc, .F. )
IF aMatch != NIL
cEnc := aMatch[2]
cEnc := aMatch[ 2 ]
ELSE
RETURN ""
ENDIF
ENDIF
RETURN cEnc
RETURN cEnc
METHOD SetFieldPart( cPart, cValue ) CLASS TipMail
LOCAL nPos, cEnc
@@ -218,12 +214,11 @@ METHOD SetFieldPart( cPart, cValue ) CLASS TipMail
IF nPos == 0
::hHeaders[ cPart ] := cValue
ELSE
::hHeaders[ cPart ] := cValue + Substr( cEnc, nPos )
::hHeaders[ cPart ] := cValue + SubStr( cEnc, nPos )
ENDIF
ENDIF
RETURN .T.
RETURN .T.
METHOD SetFieldOption( cPart, cOption, cValue ) CLASS TipMail
LOCAL nPos, aMatch
@@ -234,45 +229,40 @@ METHOD SetFieldOption( cPart, cOption, cValue ) CLASS TipMail
Return .F.
ELSE
cEnc := hb_HValueAt( ::hHeaders, nPos )
aMatch := HB_Regex( "(.*?;\s*)" + cOption +"\s*=[^;]*(.*)?", cEnc, .F. )
aMatch := hb_regex( "(.*?;\s*)" + cOption + "\s*=[^;]*(.*)?", cEnc, .F. )
IF Empty( aMatch )
::hHeaders[ cPart ] := cEnc += "; "+ cOption + '="' + cValue + '"'
ELSE
::hHeaders[ cPart ] := aMatch[2] + cOption + '="' +;
cValue + '"' + aMatch[3]
::hHeaders[ cPart ] := aMatch[ 2 ] + cOption + '="' +;
cValue + '"' + aMatch[ 3 ]
ENDIF
ENDIF
RETURN .T.
RETURN .T.
METHOD Attach( oSubPart ) CLASS TipMail
IF HB_IsObject( oSubPart ) .AND. oSubPart:ClassName == "TIPMAIL"
IF hb_isObject( oSubPart ) .AND. oSubPart:ClassName == "TIPMAIL"
// reset wrong content-type
IF At( "multipart/", Lower( ::GetFieldPart("Content-Type")) ) == 0
IF At( "multipart/", Lower( ::GetFieldPart( "Content-Type" ) ) ) == 0
::hHeaders[ "Content-Type" ] := "multipart/mixed"
ENDIF
AAdd( ::aAttachments, oSubPart )
RETURN .T.
ELSE
Alert( "TipMail:Attach() must be called with another TipMail object" )
ENDIF
RETURN .F.
RETURN .F.
METHOD NextAttachment() CLASS TipMail
IF ::nAttachPos > Len( ::aAttachments )
RETURN NIL
ELSE
::nAttachPos ++
::nAttachPos++
ENDIF
RETURN ::aAttachments[ ::nAttachPos - 1 ]
RETURN ::aAttachments[ ::nAttachPos - 1 ]
METHOD GetAttachment() CLASS TipMail
@@ -280,20 +270,20 @@ METHOD GetAttachment() CLASS TipMail
RETURN NIL
ENDIF
RETURN ::aAttachments[ ::nAttachPos ]
RETURN ::aAttachments[ ::nAttachPos ]
METHOD ToString() CLASS TipMail
LOCAL cBoundary, cElem, i
LOCAL cRet := ""
// this is a multipart message; we need a boundary
IF Len( ::aAttachments ) > 0
::hHeaders[ "Mime-Version" ] :="1.0"
endif
IF Len( ::aAttachments ) > 0
::hHeaders[ "Mime-Version" ] := "1.0"
ENDIF
IF Len( ::aAttachments ) > 0
//Reset failing content type
IF At( "multipart/", Lower( ::GetFieldPart("Content-Type")) ) == 0
IF At( "multipart/", Lower( ::GetFieldPart( "Content-Type" ) ) ) == 0
::hHeaders[ "Content-Type" ] := "multipart/mixed"
ENDIF
@@ -336,7 +326,7 @@ METHOD ToString() CLASS TipMail
ENDIF
FOR i := 1 TO Len( ::hHeaders )
cElem := Lower(hb_HKeyAt( ::hHeaders, i ))
cElem := Lower( hb_HKeyAt( ::hHeaders, i ) )
IF !( cElem == "return-path" ) .AND.;
!( cElem == "delivered-to" ) .AND.;
!( cElem == "date" ) .AND.;
@@ -354,31 +344,29 @@ METHOD ToString() CLASS TipMail
//Body
IF ! Empty( ::cBody )
IF empty(::aAttachments)
//cRet += ::cBody +iif(lAttachment,"", e"\r\n")
cRet += ::cBody + iif(::lBodyEncoded,"", e"\r\n")
else
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=ISO-8859-1; 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"
cRet += "Content-Type: text/plain; charset=ISO-8859-1; 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"
ENDIF
ENDIF
IF ! Empty( ::aAttachments )
//Eventually go with mime multipart
FOR i := 1 TO Len(::aAttachments )
// Eventually go with mime multipart
FOR i := 1 TO Len( ::aAttachments )
cRet += "--" + cBoundary + e"\r\n"
cRet += ::aAttachments[i]:ToString()
cRet += ::aAttachments[ i ]:ToString()
NEXT
cRet += "--" + cBoundary + "--" + e"\r\n"
ENDIF
RETURN cRet
RETURN cRet
METHOD FromString( cMail, cBoundary, nPos ) CLASS TipMail
LOCAL oSubSection, cSubBoundary
@@ -390,7 +378,7 @@ METHOD FromString( cMail, cBoundary, nPos ) CLASS TipMail
ENDIF
IF Len( ::hHeaders ) > 0
::hHeaders := hb_HSetCaseMatch( {=>} , .F. )
::hHeaders := hb_HSetCaseMatch( { => }, .F. )
ENDIF
IF Len( ::aReceived ) > 0
@@ -398,27 +386,24 @@ METHOD FromString( cMail, cBoundary, nPos ) CLASS TipMail
ENDIF
// Part 1: parsing header
IF nPos == NIL
nPos := 1
ENDIF
DEFAULT nPos TO 1
nLinePos := hb_At( e"\r\n", cMail, nPos )
DO WHILE nLinePos > nPos
// going on with last field?
IF (SubStr( cMail, nPos, 1 ) == " " .OR. SubStr( cMail, nPos, 1 ) == e"\t" );
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
cValue := LTrim( SubStr( cMail, nPos, nLinePos - nPos ) )
IF Lower( cLastField ) == "received"
::aReceived[ Len( ::aReceived ) ] += " " + cValue
ELSE
::hHeaders[ cLastField ] += " " +cValue
ENDIF
ELSE
nSplitPos := hb_At( ":", cMail, nPos )
cLastField := Substr( cMail, nPos, nSplitPos - nPos)
cValue := Ltrim(Substr( cMail, nSplitPos +1, nLinePos - nSplitPos -1))
IF Lower(cLastField) == "received"
cLastField := SubStr( cMail, nPos, nSplitPos - nPos )
cValue := LTrim( SubStr( cMail, nSplitPos + 1, nLinePos - nSplitPos - 1 ) )
IF Lower( cLastField ) == "received"
AAdd( ::aReceived, cValue )
ELSE
::hHeaders[ cLastField ] := cValue
@@ -443,11 +428,11 @@ METHOD FromString( cMail, cBoundary, nPos ) CLASS TipMail
ENDIF
// se if we have subparts:
IF At( "multipart/", Lower( ::GetFieldPart("Content-Type")) ) > 0
IF At( "multipart/", Lower( ::GetFieldPart( "Content-Type" ) ) ) > 0
cSubBoundary := ::GetFieldOption( "Content-Type", "Boundary" )
//strip " on boundary
// strip " on boundary
IF Left( cSubBoundary, 1 ) == '"'
cSubBoundary := Substr( cSubBoundary, 2, Len( cSubBoundary ) - 2)
cSubBoundary := SubStr( cSubBoundary, 2, Len( cSubBoundary ) - 2 )
ENDIF
ENDIF
@@ -463,23 +448,23 @@ METHOD FromString( cMail, cBoundary, nPos ) CLASS TipMail
LOOP
ENDIF
//have we met the boundary?
IF cBoundary != NIL .AND. hb_At( "--"+cBoundary, cMail, nPos ) == nPos
// have we met the boundary?
IF cBoundary != NIL .AND. hb_At( "--" + cBoundary, cMail, nPos ) == nPos
EXIT
ENDIF
//Have we met a section?
// Have we met a section?
IF cSubBoundary != NIL .AND.;
hb_At( "--" + cSubBoundary, cMail, nPos ) == nPos
//is it the last subsection?
IF hb_At( "--", cMail, nPos + Len(cSubBoundary)+2, nLinePos) > 0
// is it the last subsection?
IF hb_At( "--", cMail, nPos + Len( cSubBoundary ) + 2, nLinePos ) > 0
EXIT
ENDIF
// set our body
IF nBodyPos > 0
::cBody := Substr( cMail, nBodyPos, nPos - nBodyPos )
::cBody := SubStr( cMail, nBodyPos, nPos - nBodyPos )
nBodyPos := 0
ENDIF
@@ -497,12 +482,12 @@ METHOD FromString( cMail, cBoundary, nPos ) CLASS TipMail
// enter in this part of the loop again.
ELSE
//nPos := nLinePos + 2
// nPos := nLinePos + 2
/* 04/05/2004 - <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 ), hb_At("--" + cSubBoundary, cMail, nPos ), iif( ! Empty( cBoundary ), hb_At( "--" + cBoundary, cMail, nPos ), nLinePos + 2 ) )
ENDIF
nLinePos := hb_At( e"\r\n", cMail, nPos )
@@ -510,27 +495,23 @@ METHOD FromString( cMail, cBoundary, nPos ) CLASS TipMail
// set our body if needed
IF nBodyPos > 0
::cBody := Substr( cMail, nBodyPos, nPos - nBodyPos )
::cBody := SubStr( cMail, nBodyPos, nPos - nBodyPos )
ENDIF
RETURN nPos
RETURN nPos
METHOD MakeBoundary() CLASS TipMail
LOCAL cBound := "=_0" + Space(17)
LOCAL cBound := "=_0" + Space( 17 )
LOCAL i
FOR i := 4 TO 20
cBound := Stuff( cBound, i, 1, Chr( HB_Random(0, 25 ) + Asc("A") ) )
cBound := Stuff( cBound, i, 1, Chr( hb_Random( 0, 25 ) + Asc( "A" ) ) )
NEXT
cBound += "_TIP_" + StrTran(Dtoc( Date() ),"/","") +;
"_" + StrTran(Time(), ":", "" )
RETURN cBound
cBound += "_TIP_" + DToS( Date() ) +;
"_" + StrTran(Time(), ":" )
RETURN cBound
METHOD setHeader( cSubject, cFrom, cTo, cCC, cBCC ) CLASS TipMail
LOCAL aTo, aCC, aBCC, i, imax
@@ -569,14 +550,14 @@ METHOD setHeader( cSubject, cFrom, cTo, cCC, cBCC ) CLASS TipMail
RETURN .F.
ENDIF
IF ! ::setFieldPart( "From" , cFrom )
IF ! ::setFieldPart( "From", cFrom )
RETURN .F.
ENDIF
cTo := aTO[1]
cTo := aTO[ 1 ]
imax := Len( aTO )
FOR i:=2 TO imax
cTo += "," + HB_InetCrlf() + Chr(9) + aTo[i]
FOR i := 2 TO imax
cTo += "," + hb_inetCrlf() + Chr( 9 ) + aTo[ i ]
NEXT
IF ! ::setFieldPart( "To", cTo )
@@ -584,10 +565,10 @@ METHOD setHeader( cSubject, cFrom, cTo, cCC, cBCC ) CLASS TipMail
ENDIF
IF aCC != NIL
cCC := aCC[1]
cCC := aCC[ 1 ]
imax := Len( aCC )
FOR i:=2 TO imax
cCC += "," + HB_InetCrlf() + Chr(9) + aCC[i]
FOR i := 2 TO imax
cCC += "," + hb_inetCrlf() + Chr( 9 ) + aCC[ i ]
NEXT
IF ! ::setFieldPart( "Cc", cCC )
@@ -596,10 +577,10 @@ METHOD setHeader( cSubject, cFrom, cTo, cCC, cBCC ) CLASS TipMail
ENDIF
IF aBCC != NIL
cBCC := aBCC[1]
cBCC := aBCC[ 1 ]
imax := Len( aBCC )
FOR i:=2 TO imax
cBCC += "," + HB_InetCrlf() + Chr(9) + aBCC[i]
FOR i := 2 TO imax
cBCC += "," + hb_inetCrlf() + Chr( 9 ) + aBCC[ i ]
NEXT
IF ! ::setFieldPart( "Bcc", cBCC )
@@ -607,13 +588,12 @@ METHOD setHeader( cSubject, cFrom, cTo, cCC, cBCC ) CLASS TipMail
ENDIF
ENDIF
RETURN .T.
RETURN .T.
METHOD attachFile( cFileName ) CLASS TipMail
LOCAL cContent := MemoRead( cFileName )
LOCAL cMimeType:= TIP_FileMimetype( cFileName )
LOCAL cDelim := HB_OsPathSeparator()
LOCAL cContent := hb_MemoRead( cFileName )
LOCAL cMimeType := TIP_FileMimetype( cFileName )
LOCAL cDelim := hb_osPathSeparator()
LOCAL oAttach
@@ -622,21 +602,20 @@ METHOD attachFile( cFileName ) CLASS TipMail
ENDIF
oAttach := TIPMail():new( cContent, "base64" )
cFileName := SubStr( cFileName, Rat( cFileName, cDelim ) + 1 )
cFileName := SubStr( cFileName, RAt( cFileName, cDelim ) + 1 )
oAttach:setFieldPart ( "Content-Type", cMimeType )
oAttach:setFieldPart( "Content-Type", cMimeType )
oAttach:setFieldOption( "Content-Type", "name", cFileName )
oAttach:setFieldPart ( "Content-Disposition", "attachment" )
oAttach:setFieldPart( "Content-Disposition", "attachment" )
oAttach:setFieldOption( "Content-Disposition", "filename", cFileName )
RETURN ::attach( oAttach )
RETURN ::attach( oAttach )
METHOD detachFile( cPath ) CLASS TipMail
LOCAL cContent := ::getBody()
LOCAL cContent := ::getBody()
LOCAL cFileName := ::getFileName()
LOCAL cDelim := HB_OsPathSeparator()
LOCAL cDelim := hb_osPathSeparator()
LOCAL nFileHandle
IF Empty( cFileName )
@@ -644,7 +623,7 @@ METHOD detachFile( cPath ) CLASS TipMail
ENDIF
IF ISCHARACTER( cPath )
cFileName := StrTran( cPath + cDelim + cFileName, cDelim+cDelim, cDelim )
cFileName := StrTran( cPath + cDelim + cFileName, cDelim + cDelim, cDelim )
ENDIF
nFileHandle := FCreate( cFileName )
@@ -653,27 +632,22 @@ METHOD detachFile( cPath ) CLASS TipMail
ENDIF
FWrite( nFileHandle, cContent )
FClose( nFileHandle )
RETURN FError() == 0
RETURN FError() == 0
METHOD getFileName() CLASS TipMail
RETURN StrTran( ::getFieldOption( "Content-Type", "name" ), '"', "" )
RETURN StrTran( ::getFieldOption( "Content-Type", "name" ), '"' )
METHOD isMultiPart CLASS TipMail
RETURN "multipart/" $ Lower( ::GetFieldPart("Content-Type") )
RETURN "multipart/" $ Lower( ::GetFieldPart("Content-Type") )
METHOD getMultiParts( aParts ) CLASS TipMail
LOCAL oSubPart, lReset := .F.
::resetAttachment()
IF aParts == NIL
aParts := {}
ENDIF
DEFAULT aParts TO {}
DO WHILE ( oSubPart := ::nextAttachment() ) != NIL
lReset := .T.
@@ -686,4 +660,5 @@ METHOD getMultiParts( aParts ) CLASS TipMail
IF lReset
::resetAttachment()
ENDIF
RETURN aParts
RETURN aParts

123
harbour/contrib/hbtip/popcln.prg
View File

@@ -7,7 +7,6 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
@@ -86,26 +85,26 @@ ENDCLASS
METHOD New( oUrl, lTrace, oCredentials ) CLASS tIPClientPOP
LOCAL cFile :="pop3"
LOCAL n := 0
LOCAL n
::super:New( oUrl, lTrace, oCredentials )
::nDefaultPort := 110
::nConnTimeout := 10000
if ::ltrace
if !hb_FileExists("pop3.log")
::nHandle := FCreate("pop3.log")
else
while hb_FileExists(cFile+hb_NToS(n)+".log")
n++
enddo
::nHandle := FCreate(cFile+hb_NToS(n)+".log")
endif
endif
RETURN Self
IF ::lTrace
IF ! hb_FileExists( "pop3.log" )
::nHandle := FCreate( "pop3.log" )
ELSE
n := 0
DO WHILE hb_FileExists( "pop3" + hb_ntos( n ) + ".log" )
n++
ENDDO
::nHandle := FCreate( "pop3" + hb_ntos( n ) + ".log" )
ENDIF
ENDIF
RETURN Self
METHOD Open( cUrl ) CLASS tIPClientPOP
IF ! ::super:Open( cUrl )
@@ -116,7 +115,7 @@ METHOD Open( cUrl ) CLASS tIPClientPOP
RETURN .F.
ENDIF
HB_InetTimeout( ::SocketCon, ::nConnTimeout )
hb_inetTimeout( ::SocketCon, ::nConnTimeout )
IF ::GetOk()
::InetSendall( ::SocketCon, "USER " + ::oUrl:cUserid + ::cCRLF )
IF ::GetOK()
@@ -127,44 +126,41 @@ METHOD Open( cUrl ) CLASS tIPClientPOP
ENDIF
ENDIF
ENDIF
RETURN .F.
RETURN .F.
METHOD GetOk() CLASS tIPClientPOP
LOCAL nLen
::cReply := ::InetRecvLine( ::SocketCon, @nLen, 128 )
IF ::InetErrorCode( ::SocketCon ) != 0 .OR. !( SubStr( ::cReply, 1, 1 ) == "+" )
IF ::InetErrorCode( ::SocketCon ) != 0 .OR. !( Left( ::cReply, 1 ) == "+" )
RETURN .F.
ENDIF
RETURN .T.
RETURN .T.
METHOD Noop() CLASS tIPClientPOP
::InetSendall( ::SocketCon, "NOOP" + ::cCRLF )
RETURN ::GetOk()
RETURN ::GetOk()
METHOD Close() CLASS tIPClientPOP
HB_InetTimeOut( ::SocketCon, ::nConnTimeout )
if ::ltrace
fClose(::nHandle)
endif
hb_inetTimeOut( ::SocketCon, ::nConnTimeout )
IF ::lTrace
FClose( ::nHandle )
ENDIF
::Quit()
RETURN ::super:Close()
RETURN ::super:Close()
METHOD Quit() CLASS tIPClientPOP
::InetSendall( ::SocketCon, "QUIT" + ::cCRLF )
RETURN ::GetOk()
RETURN ::GetOk()
METHOD Stat() CLASS tIPClientPOP
LOCAL nRead
::InetSendall( ::SocketCon, "STAT" + ::cCRLF )
RETURN ::InetRecvLine( ::SocketCon, @nRead, 128)
RETURN ::InetRecvLine( ::SocketCon, @nRead, 128)
METHOD Read( nLen ) CLASS tIPClientPOP
/** Set what to read for */
@@ -172,23 +168,21 @@ METHOD Read( nLen ) CLASS tIPClientPOP
RETURN ::List()
ENDIF
IF Val (::oUrl:cFile ) < 0
IF ::Delete( - Val (::oUrl:cFile ) )
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 )
METHOD Top( nMsgId ) CLASS tIPClientPOP
LOCAL nPos
LOCAL cStr, cRet
::InetSendall( ::SocketCon, "TOP " + Str( nMsgId ) + " 0 " + ::cCRLF )
::InetSendall( ::SocketCon, "TOP " + hb_ntos( nMsgId ) + " 0 " + ::cCRLF )
IF ! ::GetOk()
RETURN NIL
ENDIF
@@ -201,16 +195,13 @@ METHOD Top( nMsgId ) CLASS tIPClientPOP
ELSE
::bEof := .T.
ENDIF
ENDDO
IF ::InetErrorCode( ::SocketCon ) != 0
RETURN NIL
ENDIF
RETURN cRet
RETURN cRet
METHOD List() CLASS tIPClientPOP
LOCAL nPos
@@ -236,9 +227,7 @@ METHOD List() CLASS tIPClientPOP
RETURN NIL
ENDIF
RETURN cRet
RETURN cRet
METHOD UIDL( nMsgId ) CLASS tIPClientPOP
@@ -246,7 +235,7 @@ METHOD UIDL( nMsgId ) CLASS tIPClientPOP
LOCAL cStr, cRet
IF ! Empty( nMsgId )
::InetSendall( ::SocketCon, "UIDL " + Str( nMsgId ) + ::cCRLF )
::InetSendall( ::SocketCon, "UIDL " + hb_ntos( nMsgId ) + ::cCRLF )
ELSE
::InetSendall( ::SocketCon, "UIDL" + ::cCRLF )
ENDIF
@@ -256,12 +245,9 @@ METHOD UIDL( nMsgId ) CLASS tIPClientPOP
ENDIF
IF ! Empty( nMsgId )
// +OK Space(1) nMsg Space(1) UID
RETURN SubStr(::cReply, Rat(Space(1), ::cReply) + 1)
RETURN SubStr( ::cReply, RAt( Space( 1 ), ::cReply ) + 1 )
ELSE
cRet := ""
DO WHILE !( cStr == "." ) .AND. ::InetErrorCode( ::SocketCon ) == 0
cStr := ::InetRecvLine( ::SocketCon, @nPos, 256 )
@@ -270,18 +256,14 @@ METHOD UIDL( nMsgId ) CLASS tIPClientPOP
ELSE
::bEof := .T.
ENDIF
ENDDO
ENDIF
IF ::InetErrorCode( ::SocketCon ) != 0
RETURN NIL
ENDIF
RETURN cRet
RETURN cRet
METHOD Retrieve( nId, nLen ) CLASS tIPClientPOP
@@ -290,7 +272,7 @@ METHOD Retrieve( nId, nLen ) CLASS tIPClientPOP
LOCAL cEOM := ::cCRLF + "." + ::cCRLF // End Of Mail
IF ! ::bInitialized
::InetSendall( ::SocketCon, "RETR "+ Str( nId ) + ::cCRLF )
::InetSendall( ::SocketCon, "RETR " + hb_ntos( nId ) + ::cCRLF )
IF ! ::GetOk()
::bEof := .T.
RETURN NIL
@@ -306,7 +288,7 @@ METHOD Retrieve( nId, nLen ) CLASS tIPClientPOP
*/
DO WHILE ::InetErrorCode( ::SocketCon ) == 0 .AND. ! ::bEof
cBuffer := Space(1024)
cBuffer := Space( 1024 )
nRead := ::InetRecv( ::SocketCon, @cBuffer, 1024 )
@@ -324,12 +306,9 @@ METHOD Retrieve( nId, nLen ) CLASS tIPClientPOP
ELSEIF ! Empty( nLen ) .AND. nLen < Len( cRet )
EXIT
ELSE
nRetLen += nRead
ENDIF
ENDDO
IF ::InetErrorCode( ::SocketCon ) != 0
@@ -337,25 +316,21 @@ METHOD Retrieve( nId, nLen ) CLASS tIPClientPOP
ENDIF
// Remove byte-stuffed termination octet(s) if any
RETURN StrTran( cRet, ::cCRLF + "..", ::cCRLF + "." )
RETURN StrTran( cRet, ::cCRLF + "..", ::cCRLF + "." )
METHOD Delete( nId ) CLASS tIPClientPOP
::InetSendall( ::SocketCon, "DELE " + AllTrim( Str( nId ) ) + ::cCRLF )
RETURN ::GetOk()
::InetSendall( ::SocketCon, "DELE " + hb_ntos( nId ) + ::cCRLF )
RETURN ::GetOk()
METHOD countMail CLASS TIpClientPop
LOCAL aMails
IF ::isOpen
::reset()
aMails := HB_ATokens( StrTran( ::list(), Chr(13),""), Chr(10) )
aMails := hb_ATokens( StrTran( ::list(), Chr( 13 ) ), Chr( 10 ) )
RETURN Len( aMails )
ENDIF
RETURN -1
RETURN -1
METHOD retrieveAll( lDelete )
LOCAL aMails, i, imax, cMail
@@ -371,16 +346,16 @@ METHOD retrieveAll( lDelete )
imax := ::countMail()
aMails := Array( imax )
FOR i:=1 TO imax
FOR i := 1 TO imax
::reset()
cMail := ::retrieve( i )
aMails[i] := TIpMail():new()
aMails[i]:fromString( cMail )
aMails[ i ] := TIpMail():new()
aMails[ i ]:fromString( cMail )
IF lDelete
::reset()
::delete(i)
::delete( i )
ENDIF
NEXT
RETURN aMails
RETURN aMails

458
harbour/contrib/hbtip/sendmail.prg
View File

@@ -4,11 +4,9 @@
/*
* xHarbour Project source code:
* HB_SendMail()
* ( This version of HB_SendMail() started from Luiz's original work on SendMail() )
* hb_SendMail() (This version of hb_SendMail() started from Luiz's original work on SendMail())
*
* Copyright 2007 Luiz Rafael Culik Guimaraes & Patrick Mast
*
* www - http://www.xharbour.org
*
* This program is free software; you can redistribute it and/or modify
@@ -54,9 +52,9 @@
#include "common.ch"
#translate ( <exp1> LIKE <exp2> ) => ( HB_REGEXLIKE( (<exp2>), (<exp1>) ) )
#translate ( <exp1> LIKE <exp2> ) => ( hb_regexLike( (<exp2>), (<exp1>) ) )
FUNCTION HB_SendMail( cServer, nPort, cFrom, aTo, aCC, aBCC, cBody, cSubject, aFiles, cUser, cPass, cPopServer, nPriority, lRead, lTrace, lPopAuth, lNoAuth, nTimeOut, cReplyTo )
FUNCTION hb_SendMail( cServer, nPort, cFrom, aTo, aCC, aBCC, cBody, cSubject, aFiles, cUser, cPass, cPopServer, nPriority, lRead, lTrace, lPopAuth, lNoAuth, nTimeOut, cReplyTo )
/*
cServer -> Required. IP or domain name of the mail server
nPort -> Optional. Port used my email server
@@ -132,10 +130,10 @@ FUNCTION HB_SendMail( cServer, nPort, cFrom, aTo, aCC, aBCC, cBody, cSubject, aF
cUser := StrTran( cUser, "@", "&at;" )
IF !( (".htm" $ Lower( cBody ) .OR. ".html" $ Lower( cBody ) ) .AND. hb_FileExists(cBody) )
IF !( ( ".htm" $ Lower( cBody ) .OR. ".html" $ Lower( cBody ) ) .AND. hb_FileExists( cBody ) )
IF !( Right( cBody, 2 ) == HB_OSNewLine() )
cBody += HB_OsNewLine()
IF !( Right( cBody, 2 ) == hb_osNewLine() )
cBody += hb_osNewLine()
ENDIF
ENDIF
@@ -145,7 +143,7 @@ FUNCTION HB_SendMail( cServer, nPort, cFrom, aTo, aCC, aBCC, cBody, cSubject, aF
IF Len( aTo ) > 1
FOR EACH cTo IN aTo
IF cTo:__enumIndex() != 1
IF !Empty( cTo )
IF ! Empty( cTo )
cTmp += cTo + ","
ENDIF
ENDIF
@@ -165,35 +163,35 @@ FUNCTION HB_SendMail( cServer, nPort, cFrom, aTo, aCC, aBCC, cBody, cSubject, aF
IF ISARRAY( aCC )
IF Len( aCC ) > 0
FOR EACH cTmp IN aCC
IF !Empty( cTmp )
IF ! Empty( cTmp )
cCC += cTmp + ","
ENDIF
NEXT
cCC := SubStr( cCC, 1, Len( cCC ) - 1 )
ENDIF
ELSEIF ISCHARACTER(aCC)
ELSEIF ISCHARACTER( aCC )
cCC := AllTrim( aCC )
ENDIF
// BCC (Blind Carbon Copy)
IF ISARRAY(aBCC)
IF Len(aBCC) > 0
IF ISARRAY( aBCC )
IF Len( aBCC ) > 0
FOR EACH cTmp IN aBCC
IF !Empty( cTmp )
IF ! Empty( cTmp )
cBCC += cTmp + ","
ENDIF
NEXT
cBCC := SubStr( cBCC, 1, Len( cBCC ) - 1 )
ENDIF
ELSEIF ISCHARACTER(aBCC)
ELSEIF ISCHARACTER( aBCC )
cBCC := AllTrim( aBCC )
ENDIF
IF cPopServer != NIL .AND. lPopAuth
BEGIN SEQUENCE
oUrl1 := tUrl():New( "pop://" + cUser + ":" + cPass + "@" + cPopServer + "/" )
oUrl1:cUserid := Strtran( cUser, "&at;", "@" )
oUrl1:cUserid := StrTran( cUser, "&at;", "@" )
opop:= tIPClientPOP():New( oUrl1, lTrace )
IF oPop:Open()
oPop:Close()
@@ -204,7 +202,7 @@ FUNCTION HB_SendMail( cServer, nPort, cFrom, aTo, aCC, aBCC, cBody, cSubject, aF
ENDIF
IF !lReturn
IF ! lReturn
RETURN .F.
ENDIF
@@ -214,18 +212,18 @@ FUNCTION HB_SendMail( cServer, nPort, cFrom, aTo, aCC, aBCC, cBody, cSubject, aF
lReturn := .F.
END SEQUENCE
IF !lReturn
IF ! lReturn
RETURN .F.
ENDIF
oUrl:nPort := nPort
oUrl:cUserid := Strtran( cUser, "&at;", "@" )
oUrl:cUserid := StrTran( cUser, "&at;", "@" )
oMail := tipMail():new()
oAttach := tipMail():new()
oAttach:SetEncoder( "7-bit" )
IF (".htm" $ Lower( cBody ) .OR. ".html" $ Lower( cBody ) ) .AND. hb_FileExists(cBody)
IF ( ".htm" $ Lower( cBody ) .OR. ".html" $ Lower( cBody ) ) .AND. hb_FileExists( cBody )
cMimeText := "text/html ; charset=ISO-8859-1"
oAttach:hHeaders[ "Content-Type" ] := cMimeText
cBodyTemp := cBody
@@ -237,34 +235,34 @@ FUNCTION HB_SendMail( cServer, nPort, cFrom, aTo, aCC, aBCC, cBody, cSubject, aF
oAttach:SetBody( cBody )
oMail:Attach( oAttach )
oUrl:cFile := cTo + iif( Empty(cCC), "", "," + cCC ) + iif( Empty(cBCC), "", "," + cBCC)
oUrl:cFile := cTo + iif( Empty( cCC ), "", "," + cCC ) + iif( Empty( cBCC ), "", "," + cBCC )
oMail:hHeaders[ "Date" ] := tip_Timestamp()
oMail:hHeaders[ "From" ] := cFrom
IF !Empty(cCC)
IF ! Empty( cCC )
oMail:hHeaders[ "Cc" ] := cCC
ENDIF
IF !Empty(cBCC)
IF ! Empty( cBCC )
oMail:hHeaders[ "Bcc" ] := cBCC
ENDIF
IF !Empty(cReplyTo)
IF ! Empty( cReplyTo )
oMail:hHeaders[ "Reply-To" ] := cReplyTo
ENDIF
BEGIN SEQUENCE
oInmail := tIPClientSMTP():New( oUrl, lTrace)
oInmail := tIPClientSMTP():New( oUrl, lTrace )
RECOVER
lReturn := .F.
END SEQUENCE
IF !lReturn
IF ! lReturn
RETURN .F.
ENDIF
oInmail:nConnTimeout:= nTimeOut
oInmail:nConnTimeout := nTimeOut
IF !lNoAuth
IF ! lNoAuth
IF oInMail:OpenSecure()
@@ -280,14 +278,14 @@ FUNCTION HB_SendMail( cServer, nPort, cFrom, aTo, aCC, aBCC, cBody, cSubject, aF
ENDDO
IF lAuthLogin
IF !oInMail:Auth( cUser, cPass )
IF ! oInMail:Auth( cUser, cPass )
lConnect := .F.
ELSE
lConnectPlain := .T.
ENDIF
ENDIF
IF lAuthPlain .AND. !lConnect
IF lAuthPlain .AND. ! lConnect
IF !oInMail:AuthPlain( cUser, cPass )
lConnect := .F.
ENDIF
@@ -304,22 +302,21 @@ FUNCTION HB_SendMail( cServer, nPort, cFrom, aTo, aCC, aBCC, cBody, cSubject, aF
lConnect := .F.
ENDIF
IF !lConnect
IF ! lConnect
if !lNoAuth
IF ! lNoAuth
oInMail:Close()
endif
ENDIF
BEGIN SEQUENCE
oInmail := tIPClientsmtp():New( oUrl, lTrace)
oInmail := tIPClientsmtp():New( oUrl, lTrace )
RECOVER
lReturn := .F.
END SEQUENCE
oInmail:nConnTimeout:=nTimeOut
oInmail:nConnTimeout := nTimeOut
IF !oInMail:Open()
IF ! oInMail:Open()
oInmail:Close()
RETURN .F.
ENDIF
@@ -334,17 +331,18 @@ FUNCTION HB_SendMail( cServer, nPort, cFrom, aTo, aCC, aBCC, cBody, cSubject, aF
ENDIF
oInMail:oUrl:cUserid := cFrom
oMail:hHeaders[ "To" ] := cTo
oMail:hHeaders[ "Subject" ] := cSubject
FOR EACH aThisFile IN AFiles
FOR EACH aThisFile IN aFiles
IF ISCHARACTER( aThisFile )
cFile := aThisFile
cData := Memoread( cFile ) + chr( 13 ) + chr( 10 )
cData := Memoread( cFile ) + Chr( 13 ) + Chr( 10 )
ELSEIF ISARRAY( aThisFile ) .AND. Len( aThisFile ) >= 2
cFile := aThisFile[ 1 ]
cData := aThisFile[ 2 ] + chr( 13 ) + chr( 10 )
cData := aThisFile[ 2 ] + Chr( 13 ) + Chr( 10 )
ELSE
lReturn := .F.
EXIT
@@ -352,7 +350,7 @@ FUNCTION HB_SendMail( cServer, nPort, cFrom, aTo, aCC, aBCC, cBody, cSubject, aF
oAttach := TipMail():New()
HB_FNameSplit( cFile,, @cFname, @cFext )
hb_FNameSplit( cFile,, @cFname, @cFext )
cFile := Lower( cFile )
IF ( cFile LIKE ".+\.(vbd|asn|asz|asd|pqi|tsp|exe|sml|ofml)" ) .OR. ;
@@ -386,10 +384,10 @@ FUNCTION HB_SendMail( cServer, nPort, cFrom, aTo, aCC, aBCC, cBody, cSubject, aF
oAttach:SetEncoder( "7-bit" )
ENDIF
cMimeText := HB_SetMimeType( cFile, cFname, cFext )
cMimeText := hb_SetMimeType( cFile, cFname, cFext )
// Some EMAIL readers use Content-Type to check for filename
IF ".html" $ lower( cFext) .OR. ".htm" $ lower( cFext )
IF ".html" $ Lower( cFext ) .OR. ".htm" $ Lower( cFext )
cMimeText += "; charset=ISO-8859-1"
ENDIF
@@ -413,198 +411,198 @@ FUNCTION HB_SendMail( cServer, nPort, cFrom, aTo, aCC, aBCC, cBody, cSubject, aF
oInMail:Commit()
oInMail:Close()
RETURN lReturn
RETURN lReturn
//-------------------------------------------------------------//
FUNCTION HB_SetMimeType( cFile, cFname, cFext )
FUNCTION hb_SetMimeType( cFile, cFname, cFext )
cFile := Lower( cFile )
IF ( cFile LIKE ".+\.vbd" ); RETURN "application/activexdocument="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.(asn|asz|asd)" ); RETURN "application/astound="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.pqi" ); RETURN "application/cprplayer=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.tsp" ); RETURN "application/dsptype="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.exe" ); RETURN "application/exe="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.(sml|ofml)" ); RETURN "application/fml="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.pfr" ); RETURN "application/font-tdpfr=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.frl" ); RETURN "application/freeloader=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.spl" ); RETURN "application/futuresplash =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.gz" ); RETURN "application/gzip =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.stk" ); RETURN "application/hstu =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.ips" ); RETURN "application/ips="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.ptlk" ); RETURN "application/listenup =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.hqx" ); RETURN "application/mac-binhex40 =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.mbd" ); RETURN "application/mbedlet="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.mfp" ); RETURN "application/mirage=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.(pot|pps|ppt|ppz)" ); RETURN "application/mspowerpoint =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.doc" ); RETURN "application/msword=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.n2p" ); RETURN "application/n2p="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.(bin|class|lha|lzh|lzx|dbf)" ); RETURN "application/octet-stream =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.oda" ); RETURN "application/oda="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.axs" ); RETURN "application/olescript=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.zpa" ); RETURN "application/pcphoto="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.pdf" ); RETURN "application/pdf="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.(ai|eps|ps)" ); RETURN "application/postscript=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.shw" ); RETURN "application/presentations=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.qrt" ); RETURN "application/quest=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.rtc" ); RETURN "application/rtc="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.rtf" ); RETURN "application/rtf="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.smp" ); RETURN "application/studiom="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.dst" ); RETURN "application/tajima=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.talk" ); RETURN "application/talker=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.tbk" ); RETURN "application/toolbook =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.vmd" ); RETURN "application/vocaltec-media-desc="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.vmf" ); RETURN "application/vocaltec-media-file="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.wri" ); RETURN "application/write=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.wid" ); RETURN "application/x-DemoShield =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.rrf" ); RETURN "application/x-InstallFromTheWeb="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.wis" ); RETURN "application/x-InstallShield="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.ins" ); RETURN "application/x-NET-Install=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.tmv" ); RETURN "application/x-Parable-Thing="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.arj" ); RETURN "application/x-arj=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.asp" ); RETURN "application/x-asap=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.aab" ); RETURN "application/x-authorware-bin =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(aam|aas)" ); RETURN "application/x-authorware-map =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.bcpio" ); RETURN "application/x-bcpio="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.vcd" ); RETURN "application/x-cdlink =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.chat" ); RETURN "application/x-chat=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.cnc" ); RETURN "application/x-cnc=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(coda|page)" ); RETURN "application/x-coda=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.z" ); RETURN "application/x-compress=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.con" ); RETURN "application/x-connector="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.cpio" ); RETURN "application/x-cpio=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.pqf" ); RETURN "application/x-cprplayer="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.csh" ); RETURN "application/x-csh=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(cu|csm)" ); RETURN "application/x-cu-seeme=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.(dcr|dir|dxr|swa)" ); RETURN "application/x-director=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.dvi" ); RETURN "application/x-dvi=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.evy" ); RETURN "application/x-envoy="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.ebk" ); RETURN "application/x-expandedbook=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.gtar" ); RETURN "application/x-gtar=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.hdf" ); RETURN "application/x-hdf=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.map" ); RETURN "application/x-httpd-imap =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.phtml" ); RETURN "application/x-httpd-php="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.php3" ); RETURN "application/x-httpd-php3 =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.ica" ); RETURN "application/x-ica=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.ipx" ); RETURN "application/x-ipix=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.ips" ); RETURN "application/x-ipscript=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.js" ); RETURN "application/x-javascript =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.latex" ); RETURN "application/x-latex="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.bin" ); RETURN "application/x-macbinary="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.mif" ); RETURN "application/x-mif=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(mpl|mpire)" ); RETURN "application/x-mpire="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.adr" ); RETURN "application/x-msaddr =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.wlt" ); RETURN "application/x-mswallet=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.(nc|cdf)" ); RETURN "application/x-netcdf =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.npx" ); RETURN "application/x-netfpx =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.nsc" ); RETURN "application/x-nschat =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.pgp" ); RETURN "application/x-pgp-plugin =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.css" ); RETURN "application/x-pointplus="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.sh" ); RETURN "application/x-sh =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.shar" ); RETURN "application/x-shar=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.swf" ); RETURN "application/x-shockwave-flash=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.spr" ); RETURN "application/x-sprite =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.sprite" ); RETURN "application/x-sprite =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.sit" ); RETURN "application/x-stuffit=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.sca" ); RETURN "application/x-supercard="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.sv4cpio" ); RETURN "application/x-sv4cpio=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.sv4crc" ); RETURN "application/x-sv4crc =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.tar" ); RETURN "application/x-tar=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.tcl" ); RETURN "application/x-tcl=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.tex" ); RETURN "application/x-tex=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(texinfo|texi)" ); RETURN "application/x-texinfo=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.tlk" ); RETURN "application/x-tlk=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(t|tr|roff)" ); RETURN "application/x-troff="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.man" ); RETURN "application/x-troff-man="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.me" ); RETURN "application/x-troff-me=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.ms" ); RETURN "application/x-troff-ms=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.alt" ); RETURN "application/x-up-alert=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.che" ); RETURN "application/x-up-cacheop =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.ustar" ); RETURN "application/x-ustar="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.src" ); RETURN "application/x-wais-source=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.xls" ); RETURN "application/xls="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.xlt" ); RETURN "application/xlt="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.zip" ); RETURN "application/zip="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.(au|snd)" ); RETURN "audio/basic="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.es" ); RETURN "audio/echospeech =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(gsm|gsd)" ); RETURN "audio/gsm=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.rmf" ); RETURN "audio/rmf=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.tsi" ); RETURN "audio/tsplayer=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.vox" ); RETURN "audio/voxware=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.wtx" ); RETURN "audio/wtx=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(aif|aiff|aifc)" ); RETURN "audio/x-aiff =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(cht|dus)" ); RETURN "audio/x-dspeech="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.(mid|midi)" ); RETURN "audio/x-midi =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.mp3" ); RETURN "audio/x-mpeg =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.mp2" ); RETURN "audio/x-mpeg =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.m3u" ); RETURN "audio/x-mpegurl="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.(ram|ra)" ); RETURN "audio/x-pn-realaudio =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.rpm" ); RETURN "audio/x-pn-realaudio-plugin="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.stream" ); RETURN "audio/x-qt-stream=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.rmf" ); RETURN "audio/x-rmf="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.(vqf|vql)" ); RETURN "audio/x-twinvq=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.vqe" ); RETURN "audio/x-twinvq-plugin=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.wav" ); RETURN "audio/x-wav="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.wtx" ); RETURN "audio/x-wtx="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.mol" ); RETURN "chemical/x-mdl-molfile=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.pdb" ); RETURN "chemical/x-pdb=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.dwf" ); RETURN "drawing/x-dwf=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.ivr" ); RETURN "i-world/i-vrml=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.cod" ); RETURN "image/cis-cod=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.cpi" ); RETURN "image/cpi=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.fif" ); RETURN "image/fif=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.gif" ); RETURN "image/gif=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.ief" ); RETURN "image/ief=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(jpeg|jpg|jpe)" ); RETURN "image/jpeg=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.rip" ); RETURN "image/rip=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.svh" ); RETURN "image/svh=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(tiff|tif)" ); RETURN "image/tiff=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.mcf" ); RETURN "image/vasa=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.(svf|dwg|dxf)" ); RETURN "image/vnd=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.wi" ); RETURN "image/wavelet=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.ras" ); RETURN "image/x-cmu-raster=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.etf" ); RETURN "image/x-etf="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.fpx" ); RETURN "image/x-fpx="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.(fh5|fh4|fhc)" ); RETURN "image/x-freehand =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.dsf" ); RETURN "image/x-mgx-dsf="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.pnm" ); RETURN "image/x-portable-anymap="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.pbm" ); RETURN "image/x-portable-bitmap="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.pgm" ); RETURN "image/x-portable-graymap =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.ppm" ); RETURN "image/x-portable-pixmap="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.rgb" ); RETURN "image/x-rgb="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.xbm" ); RETURN "image/x-xbitmap="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.xpm" ); RETURN "image/x-xpixmap="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.xwd" ); RETURN "image/x-xwindowdump="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.dig" ); RETURN "multipart/mixed="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.push" ); RETURN "multipart/x-mixed-replace=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(wan|waf)" ); RETURN "plugin/wanimate="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.ccs" ); RETURN "text/ccs =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(htm|html)" ); RETURN "text/html=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.pgr" ); RETURN "text/parsnegar-document="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.txt" ); RETURN "text/plain=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.rtx" ); RETURN "text/richtext=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.tsv" ); RETURN "text/tab-separated-values=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.hdml" ); RETURN "text/x-hdml="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.etx" ); RETURN "text/x-setext=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(talk|spc)" ); RETURN "text/x-speech=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.afl" ); RETURN "video/animaflex="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.(mpeg|mpg|mpe)" ); RETURN "video/mpeg=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.(qt|mov)" ); RETURN "video/quicktime="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.(viv|vivo)" ); RETURN "video/vnd.vivo=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.(asf|asx)" ); RETURN "video/x-ms-asf=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.avi" ); RETURN "video/x-msvideo="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.movie" ); RETURN "video/x-sgi-movie=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(vgm|vgx|xdr)" ); RETURN "video/x-videogram=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.vgp" ); RETURN "video/x-videogram-plugin =" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.vts" ); RETURN "workbook/formulaone="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.vtts" ); RETURN "workbook/formulaone="+cFname + cFext
ELSEIF ( cFile LIKE ".+\.(3dmf|3dm|qd3d|qd3)" ); RETURN "x-world/x-3dmf=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.svr" ); RETURN "x-world/x-svr=" + cFname + cFext
ELSEIF ( cFile LIKE ".+\.(wrl|wrz)" ); RETURN "x-world/x-vrml=" +cFname + cFext
ELSEIF ( cFile LIKE ".+\.vrt" ); RETURN "x-world/x-vrt=" + cFname + cFext
ENDIF
DO CASE
CASE ( cFile LIKE ".+\.vbd" ); RETURN "application/activexdocument="+cFname + cFext
CASE ( cFile LIKE ".+\.(asn|asz|asd)" ); RETURN "application/astound="+cFname + cFext
CASE ( cFile LIKE ".+\.pqi" ); RETURN "application/cprplayer=" + cFname + cFext
CASE ( cFile LIKE ".+\.tsp" ); RETURN "application/dsptype="+cFname + cFext
CASE ( cFile LIKE ".+\.exe" ); RETURN "application/exe="+cFname + cFext
CASE ( cFile LIKE ".+\.(sml|ofml)" ); RETURN "application/fml="+cFname + cFext
CASE ( cFile LIKE ".+\.pfr" ); RETURN "application/font-tdpfr=" +cFname + cFext
CASE ( cFile LIKE ".+\.frl" ); RETURN "application/freeloader=" +cFname + cFext
CASE ( cFile LIKE ".+\.spl" ); RETURN "application/futuresplash =" + cFname + cFext
CASE ( cFile LIKE ".+\.gz" ); RETURN "application/gzip =" + cFname + cFext
CASE ( cFile LIKE ".+\.stk" ); RETURN "application/hstu =" + cFname + cFext
CASE ( cFile LIKE ".+\.ips" ); RETURN "application/ips="+cFname + cFext
CASE ( cFile LIKE ".+\.ptlk" ); RETURN "application/listenup =" + cFname + cFext
CASE ( cFile LIKE ".+\.hqx" ); RETURN "application/mac-binhex40 =" + cFname + cFext
CASE ( cFile LIKE ".+\.mbd" ); RETURN "application/mbedlet="+cFname + cFext
CASE ( cFile LIKE ".+\.mfp" ); RETURN "application/mirage=" +cFname + cFext
CASE ( cFile LIKE ".+\.(pot|pps|ppt|ppz)" ); RETURN "application/mspowerpoint =" + cFname + cFext
CASE ( cFile LIKE ".+\.doc" ); RETURN "application/msword=" +cFname + cFext
CASE ( cFile LIKE ".+\.n2p" ); RETURN "application/n2p="+cFname + cFext
CASE ( cFile LIKE ".+\.(bin|class|lha|lzh|lzx|dbf)" ); RETURN "application/octet-stream =" + cFname + cFext
CASE ( cFile LIKE ".+\.oda" ); RETURN "application/oda="+cFname + cFext
CASE ( cFile LIKE ".+\.axs" ); RETURN "application/olescript=" + cFname + cFext
CASE ( cFile LIKE ".+\.zpa" ); RETURN "application/pcphoto="+cFname + cFext
CASE ( cFile LIKE ".+\.pdf" ); RETURN "application/pdf="+cFname + cFext
CASE ( cFile LIKE ".+\.(ai|eps|ps)" ); RETURN "application/postscript=" +cFname + cFext
CASE ( cFile LIKE ".+\.shw" ); RETURN "application/presentations=" + cFname + cFext
CASE ( cFile LIKE ".+\.qrt" ); RETURN "application/quest=" + cFname + cFext
CASE ( cFile LIKE ".+\.rtc" ); RETURN "application/rtc="+cFname + cFext
CASE ( cFile LIKE ".+\.rtf" ); RETURN "application/rtf="+cFname + cFext
CASE ( cFile LIKE ".+\.smp" ); RETURN "application/studiom="+cFname + cFext
CASE ( cFile LIKE ".+\.dst" ); RETURN "application/tajima=" +cFname + cFext
CASE ( cFile LIKE ".+\.talk" ); RETURN "application/talker=" +cFname + cFext
CASE ( cFile LIKE ".+\.tbk" ); RETURN "application/toolbook =" + cFname + cFext
CASE ( cFile LIKE ".+\.vmd" ); RETURN "application/vocaltec-media-desc="+cFname + cFext
CASE ( cFile LIKE ".+\.vmf" ); RETURN "application/vocaltec-media-file="+cFname + cFext
CASE ( cFile LIKE ".+\.wri" ); RETURN "application/write=" + cFname + cFext
CASE ( cFile LIKE ".+\.wid" ); RETURN "application/x-DemoShield =" + cFname + cFext
CASE ( cFile LIKE ".+\.rrf" ); RETURN "application/x-InstallFromTheWeb="+cFname + cFext
CASE ( cFile LIKE ".+\.wis" ); RETURN "application/x-InstallShield="+cFname + cFext
CASE ( cFile LIKE ".+\.ins" ); RETURN "application/x-NET-Install=" + cFname + cFext
CASE ( cFile LIKE ".+\.tmv" ); RETURN "application/x-Parable-Thing="+cFname + cFext
CASE ( cFile LIKE ".+\.arj" ); RETURN "application/x-arj=" + cFname + cFext
CASE ( cFile LIKE ".+\.asp" ); RETURN "application/x-asap=" +cFname + cFext
CASE ( cFile LIKE ".+\.aab" ); RETURN "application/x-authorware-bin =" + cFname + cFext
CASE ( cFile LIKE ".+\.(aam|aas)" ); RETURN "application/x-authorware-map =" + cFname + cFext
CASE ( cFile LIKE ".+\.bcpio" ); RETURN "application/x-bcpio="+cFname + cFext
CASE ( cFile LIKE ".+\.vcd" ); RETURN "application/x-cdlink =" + cFname + cFext
CASE ( cFile LIKE ".+\.chat" ); RETURN "application/x-chat=" +cFname + cFext
CASE ( cFile LIKE ".+\.cnc" ); RETURN "application/x-cnc=" + cFname + cFext
CASE ( cFile LIKE ".+\.(coda|page)" ); RETURN "application/x-coda=" +cFname + cFext
CASE ( cFile LIKE ".+\.z" ); RETURN "application/x-compress=" +cFname + cFext
CASE ( cFile LIKE ".+\.con" ); RETURN "application/x-connector="+cFname + cFext
CASE ( cFile LIKE ".+\.cpio" ); RETURN "application/x-cpio=" +cFname + cFext
CASE ( cFile LIKE ".+\.pqf" ); RETURN "application/x-cprplayer="+cFname + cFext
CASE ( cFile LIKE ".+\.csh" ); RETURN "application/x-csh=" + cFname + cFext
CASE ( cFile LIKE ".+\.(cu|csm)" ); RETURN "application/x-cu-seeme=" +cFname + cFext
CASE ( cFile LIKE ".+\.(dcr|dir|dxr|swa)" ); RETURN "application/x-director=" +cFname + cFext
CASE ( cFile LIKE ".+\.dvi" ); RETURN "application/x-dvi=" + cFname + cFext
CASE ( cFile LIKE ".+\.evy" ); RETURN "application/x-envoy="+cFname + cFext
CASE ( cFile LIKE ".+\.ebk" ); RETURN "application/x-expandedbook=" +cFname + cFext
CASE ( cFile LIKE ".+\.gtar" ); RETURN "application/x-gtar=" +cFname + cFext
CASE ( cFile LIKE ".+\.hdf" ); RETURN "application/x-hdf=" + cFname + cFext
CASE ( cFile LIKE ".+\.map" ); RETURN "application/x-httpd-imap =" + cFname + cFext
CASE ( cFile LIKE ".+\.phtml" ); RETURN "application/x-httpd-php="+cFname + cFext
CASE ( cFile LIKE ".+\.php3" ); RETURN "application/x-httpd-php3 =" + cFname + cFext
CASE ( cFile LIKE ".+\.ica" ); RETURN "application/x-ica=" + cFname + cFext
CASE ( cFile LIKE ".+\.ipx" ); RETURN "application/x-ipix=" +cFname + cFext
CASE ( cFile LIKE ".+\.ips" ); RETURN "application/x-ipscript=" +cFname + cFext
CASE ( cFile LIKE ".+\.js" ); RETURN "application/x-javascript =" + cFname + cFext
CASE ( cFile LIKE ".+\.latex" ); RETURN "application/x-latex="+cFname + cFext
CASE ( cFile LIKE ".+\.bin" ); RETURN "application/x-macbinary="+cFname + cFext
CASE ( cFile LIKE ".+\.mif" ); RETURN "application/x-mif=" + cFname + cFext
CASE ( cFile LIKE ".+\.(mpl|mpire)" ); RETURN "application/x-mpire="+cFname + cFext
CASE ( cFile LIKE ".+\.adr" ); RETURN "application/x-msaddr =" + cFname + cFext
CASE ( cFile LIKE ".+\.wlt" ); RETURN "application/x-mswallet=" +cFname + cFext
CASE ( cFile LIKE ".+\.(nc|cdf)" ); RETURN "application/x-netcdf =" + cFname + cFext
CASE ( cFile LIKE ".+\.npx" ); RETURN "application/x-netfpx =" + cFname + cFext
CASE ( cFile LIKE ".+\.nsc" ); RETURN "application/x-nschat =" + cFname + cFext
CASE ( cFile LIKE ".+\.pgp" ); RETURN "application/x-pgp-plugin =" + cFname + cFext
CASE ( cFile LIKE ".+\.css" ); RETURN "application/x-pointplus="+cFname + cFext
CASE ( cFile LIKE ".+\.sh" ); RETURN "application/x-sh =" + cFname + cFext
CASE ( cFile LIKE ".+\.shar" ); RETURN "application/x-shar=" +cFname + cFext
CASE ( cFile LIKE ".+\.swf" ); RETURN "application/x-shockwave-flash=" + cFname + cFext
CASE ( cFile LIKE ".+\.spr" ); RETURN "application/x-sprite =" + cFname + cFext
CASE ( cFile LIKE ".+\.sprite" ); RETURN "application/x-sprite =" + cFname + cFext
CASE ( cFile LIKE ".+\.sit" ); RETURN "application/x-stuffit=" + cFname + cFext
CASE ( cFile LIKE ".+\.sca" ); RETURN "application/x-supercard="+cFname + cFext
CASE ( cFile LIKE ".+\.sv4cpio" ); RETURN "application/x-sv4cpio=" + cFname + cFext
CASE ( cFile LIKE ".+\.sv4crc" ); RETURN "application/x-sv4crc =" + cFname + cFext
CASE ( cFile LIKE ".+\.tar" ); RETURN "application/x-tar=" + cFname + cFext
CASE ( cFile LIKE ".+\.tcl" ); RETURN "application/x-tcl=" + cFname + cFext
CASE ( cFile LIKE ".+\.tex" ); RETURN "application/x-tex=" + cFname + cFext
CASE ( cFile LIKE ".+\.(texinfo|texi)" ); RETURN "application/x-texinfo=" + cFname + cFext
CASE ( cFile LIKE ".+\.tlk" ); RETURN "application/x-tlk=" + cFname + cFext
CASE ( cFile LIKE ".+\.(t|tr|roff)" ); RETURN "application/x-troff="+cFname + cFext
CASE ( cFile LIKE ".+\.man" ); RETURN "application/x-troff-man="+cFname + cFext
CASE ( cFile LIKE ".+\.me" ); RETURN "application/x-troff-me=" +cFname + cFext
CASE ( cFile LIKE ".+\.ms" ); RETURN "application/x-troff-ms=" +cFname + cFext
CASE ( cFile LIKE ".+\.alt" ); RETURN "application/x-up-alert=" +cFname + cFext
CASE ( cFile LIKE ".+\.che" ); RETURN "application/x-up-cacheop =" + cFname + cFext
CASE ( cFile LIKE ".+\.ustar" ); RETURN "application/x-ustar="+cFname + cFext
CASE ( cFile LIKE ".+\.src" ); RETURN "application/x-wais-source=" + cFname + cFext
CASE ( cFile LIKE ".+\.xls" ); RETURN "application/xls="+cFname + cFext
CASE ( cFile LIKE ".+\.xlt" ); RETURN "application/xlt="+cFname + cFext
CASE ( cFile LIKE ".+\.zip" ); RETURN "application/zip="+cFname + cFext
CASE ( cFile LIKE ".+\.(au|snd)" ); RETURN "audio/basic="+cFname + cFext
CASE ( cFile LIKE ".+\.es" ); RETURN "audio/echospeech =" + cFname + cFext
CASE ( cFile LIKE ".+\.(gsm|gsd)" ); RETURN "audio/gsm=" + cFname + cFext
CASE ( cFile LIKE ".+\.rmf" ); RETURN "audio/rmf=" + cFname + cFext
CASE ( cFile LIKE ".+\.tsi" ); RETURN "audio/tsplayer=" +cFname + cFext
CASE ( cFile LIKE ".+\.vox" ); RETURN "audio/voxware=" + cFname + cFext
CASE ( cFile LIKE ".+\.wtx" ); RETURN "audio/wtx=" + cFname + cFext
CASE ( cFile LIKE ".+\.(aif|aiff|aifc)" ); RETURN "audio/x-aiff =" + cFname + cFext
CASE ( cFile LIKE ".+\.(cht|dus)" ); RETURN "audio/x-dspeech="+cFname + cFext
CASE ( cFile LIKE ".+\.(mid|midi)" ); RETURN "audio/x-midi =" + cFname + cFext
CASE ( cFile LIKE ".+\.mp3" ); RETURN "audio/x-mpeg =" + cFname + cFext
CASE ( cFile LIKE ".+\.mp2" ); RETURN "audio/x-mpeg =" + cFname + cFext
CASE ( cFile LIKE ".+\.m3u" ); RETURN "audio/x-mpegurl="+cFname + cFext
CASE ( cFile LIKE ".+\.(ram|ra)" ); RETURN "audio/x-pn-realaudio =" + cFname + cFext
CASE ( cFile LIKE ".+\.rpm" ); RETURN "audio/x-pn-realaudio-plugin="+cFname + cFext
CASE ( cFile LIKE ".+\.stream" ); RETURN "audio/x-qt-stream=" + cFname + cFext
CASE ( cFile LIKE ".+\.rmf" ); RETURN "audio/x-rmf="+cFname + cFext
CASE ( cFile LIKE ".+\.(vqf|vql)" ); RETURN "audio/x-twinvq=" +cFname + cFext
CASE ( cFile LIKE ".+\.vqe" ); RETURN "audio/x-twinvq-plugin=" + cFname + cFext
CASE ( cFile LIKE ".+\.wav" ); RETURN "audio/x-wav="+cFname + cFext
CASE ( cFile LIKE ".+\.wtx" ); RETURN "audio/x-wtx="+cFname + cFext
CASE ( cFile LIKE ".+\.mol" ); RETURN "chemical/x-mdl-molfile=" +cFname + cFext
CASE ( cFile LIKE ".+\.pdb" ); RETURN "chemical/x-pdb=" +cFname + cFext
CASE ( cFile LIKE ".+\.dwf" ); RETURN "drawing/x-dwf=" + cFname + cFext
CASE ( cFile LIKE ".+\.ivr" ); RETURN "i-world/i-vrml=" +cFname + cFext
CASE ( cFile LIKE ".+\.cod" ); RETURN "image/cis-cod=" + cFname + cFext
CASE ( cFile LIKE ".+\.cpi" ); RETURN "image/cpi=" + cFname + cFext
CASE ( cFile LIKE ".+\.fif" ); RETURN "image/fif=" + cFname + cFext
CASE ( cFile LIKE ".+\.gif" ); RETURN "image/gif=" + cFname + cFext
CASE ( cFile LIKE ".+\.ief" ); RETURN "image/ief=" + cFname + cFext
CASE ( cFile LIKE ".+\.(jpeg|jpg|jpe)" ); RETURN "image/jpeg=" +cFname + cFext
CASE ( cFile LIKE ".+\.rip" ); RETURN "image/rip=" + cFname + cFext
CASE ( cFile LIKE ".+\.svh" ); RETURN "image/svh=" + cFname + cFext
CASE ( cFile LIKE ".+\.(tiff|tif)" ); RETURN "image/tiff=" +cFname + cFext
CASE ( cFile LIKE ".+\.mcf" ); RETURN "image/vasa=" +cFname + cFext
CASE ( cFile LIKE ".+\.(svf|dwg|dxf)" ); RETURN "image/vnd=" + cFname + cFext
CASE ( cFile LIKE ".+\.wi" ); RETURN "image/wavelet=" + cFname + cFext
CASE ( cFile LIKE ".+\.ras" ); RETURN "image/x-cmu-raster=" +cFname + cFext
CASE ( cFile LIKE ".+\.etf" ); RETURN "image/x-etf="+cFname + cFext
CASE ( cFile LIKE ".+\.fpx" ); RETURN "image/x-fpx="+cFname + cFext
CASE ( cFile LIKE ".+\.(fh5|fh4|fhc)" ); RETURN "image/x-freehand =" + cFname + cFext
CASE ( cFile LIKE ".+\.dsf" ); RETURN "image/x-mgx-dsf="+cFname + cFext
CASE ( cFile LIKE ".+\.pnm" ); RETURN "image/x-portable-anymap="+cFname + cFext
CASE ( cFile LIKE ".+\.pbm" ); RETURN "image/x-portable-bitmap="+cFname + cFext
CASE ( cFile LIKE ".+\.pgm" ); RETURN "image/x-portable-graymap =" + cFname + cFext
CASE ( cFile LIKE ".+\.ppm" ); RETURN "image/x-portable-pixmap="+cFname + cFext
CASE ( cFile LIKE ".+\.rgb" ); RETURN "image/x-rgb="+cFname + cFext
CASE ( cFile LIKE ".+\.xbm" ); RETURN "image/x-xbitmap="+cFname + cFext
CASE ( cFile LIKE ".+\.xpm" ); RETURN "image/x-xpixmap="+cFname + cFext
CASE ( cFile LIKE ".+\.xwd" ); RETURN "image/x-xwindowdump="+cFname + cFext
CASE ( cFile LIKE ".+\.dig" ); RETURN "multipart/mixed="+cFname + cFext
CASE ( cFile LIKE ".+\.push" ); RETURN "multipart/x-mixed-replace=" + cFname + cFext
CASE ( cFile LIKE ".+\.(wan|waf)" ); RETURN "plugin/wanimate="+cFname + cFext
CASE ( cFile LIKE ".+\.ccs" ); RETURN "text/ccs =" + cFname + cFext
CASE ( cFile LIKE ".+\.(htm|html)" ); RETURN "text/html=" + cFname + cFext
CASE ( cFile LIKE ".+\.pgr" ); RETURN "text/parsnegar-document="+cFname + cFext
CASE ( cFile LIKE ".+\.txt" ); RETURN "text/plain=" +cFname + cFext
CASE ( cFile LIKE ".+\.rtx" ); RETURN "text/richtext=" + cFname + cFext
CASE ( cFile LIKE ".+\.tsv" ); RETURN "text/tab-separated-values=" + cFname + cFext
CASE ( cFile LIKE ".+\.hdml" ); RETURN "text/x-hdml="+cFname + cFext
CASE ( cFile LIKE ".+\.etx" ); RETURN "text/x-setext=" + cFname + cFext
CASE ( cFile LIKE ".+\.(talk|spc)" ); RETURN "text/x-speech=" + cFname + cFext
CASE ( cFile LIKE ".+\.afl" ); RETURN "video/animaflex="+cFname + cFext
CASE ( cFile LIKE ".+\.(mpeg|mpg|mpe)" ); RETURN "video/mpeg=" +cFname + cFext
CASE ( cFile LIKE ".+\.(qt|mov)" ); RETURN "video/quicktime="+cFname + cFext
CASE ( cFile LIKE ".+\.(viv|vivo)" ); RETURN "video/vnd.vivo=" +cFname + cFext
CASE ( cFile LIKE ".+\.(asf|asx)" ); RETURN "video/x-ms-asf=" +cFname + cFext
CASE ( cFile LIKE ".+\.avi" ); RETURN "video/x-msvideo="+cFname + cFext
CASE ( cFile LIKE ".+\.movie" ); RETURN "video/x-sgi-movie=" + cFname + cFext
CASE ( cFile LIKE ".+\.(vgm|vgx|xdr)" ); RETURN "video/x-videogram=" + cFname + cFext
CASE ( cFile LIKE ".+\.vgp" ); RETURN "video/x-videogram-plugin =" + cFname + cFext
CASE ( cFile LIKE ".+\.vts" ); RETURN "workbook/formulaone="+cFname + cFext
CASE ( cFile LIKE ".+\.vtts" ); RETURN "workbook/formulaone="+cFname + cFext
CASE ( cFile LIKE ".+\.(3dmf|3dm|qd3d|qd3)" ); RETURN "x-world/x-3dmf=" +cFname + cFext
CASE ( cFile LIKE ".+\.svr" ); RETURN "x-world/x-svr=" + cFname + cFext
CASE ( cFile LIKE ".+\.(wrl|wrz)" ); RETURN "x-world/x-vrml=" +cFname + cFext
CASE ( cFile LIKE ".+\.vrt" ); RETURN "x-world/x-vrt=" + cFname + cFext
ENDCASE
RETURN "text/plain;filename=" + cFname + cFext
RETURN "text/plain;filename=" + cFname + cFext

3
harbour/contrib/hbtip/sessid.prg
View File

@@ -12,7 +12,6 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* www - http://www.harbour-project.org
*
* CGI Session Manager Class
@@ -84,7 +83,7 @@ FUNCTION TIP_GENERATESID( cCRCKey )
/* Let's generate the sequence */
cSID := Space( nLenSID )
for n := 1 TO nLenSID
nRand := HB_RandomInt( 1, nLenKeys )
nRand := hb_RandomInt( 1, nLenKeys )
cSID := Stuff( cSID, n, 1, SubStr( cBaseKeys, nRand, 1 ) )
nKey += nRand
next

143
harbour/contrib/hbtip/smtpcln.prg
View File

@@ -57,14 +57,10 @@
#include "hbclass.ch"
#include "tip.ch"
/**
* Inet service manager: smtp
*/
CREATE CLASS tIPClientSMTP FROM tIPClient
METHOD New( oUrl, lTrace, oCredentials )
METHOD Open()
METHOD Open( cUrl )
METHOD Close()
METHOD Write( cData, nLen, bCommit )
METHOD Mail( cFrom )
@@ -73,14 +69,13 @@ CREATE CLASS tIPClientSMTP FROM tIPClient
METHOD Commit()
METHOD Quit()
METHOD GetOK()
METHOD SendMail( oTIpMail )
/* Methods for smtp server that require login */
METHOD OpenSecure()
METHOD AUTH( cUser, cPass) // Auth by login method
METHOD AUTHplain( cUser, cPass) // Auth by plain method
METHOD ServerSuportSecure( lAuthp, lAuthl )
METHOD sendMail
METHOD OpenSecure( cUrl )
METHOD Auth( cUser, cPass ) // Auth by login method
METHOD AuthPlain( cUser, cPass ) // Auth by plain method
METHOD ServerSuportSecure( lAuthPlain, lAuthLogin )
HIDDEN:
@@ -102,10 +97,10 @@ METHOD New( oUrl, lTrace, oCredentials ) CLASS tIPClientSMTP
::nHandle := FCreate( "sendmail.log" )
ELSE
n := 1
DO WHILE hb_FileExists( "sendmail" + hb_NToS( n ) + ".log" )
DO WHILE hb_FileExists( "sendmail" + hb_ntos( n ) + ".log" )
n++
ENDDO
::nHandle := FCreate( "sendmail" + hb_NToS( n ) + ".log" )
::nHandle := FCreate( "sendmail" + hb_ntos( n ) + ".log" )
ENDIF
ENDIF
@@ -117,29 +112,37 @@ METHOD Open( cUrl ) CLASS tIPClientSMTP
RETURN .F.
ENDIF
HB_InetTimeout( ::SocketCon, ::nConnTimeout )
IF ! Empty( ::oUrl:cUserid )
::InetSendall( ::SocketCon, "HELO " + ::oUrl:cUserid + ::cCRLF )
ELSE
::InetSendall( ::SocketCon, "HELO tipClientSMTP" + ::cCRLF )
hb_inetTimeout( ::SocketCon, ::nConnTimeout )
::InetSendall( ::SocketCon, "HELO " + iif( Empty( ::oUrl:cUserid ), "tipClientSMTP", ::oUrl:cUserid ) + ::cCRLF )
RETURN ::GetOk()
METHOD OpenSecure( cUrl ) CLASS tIPClientSMTP
IF ! ::super:Open( cUrl )
RETURN .F.
ENDIF
hb_inetTimeout( ::SocketCon, ::nConnTimeout )
::InetSendall( ::SocketCon, "EHLO " + iif( Empty( ::oUrl:cUserid ), "tipClientSMTP", ::oUrl:cUserid ) + ::cCRLF )
RETURN ::GetOk()
METHOD GetOk() CLASS tIPClientSMTP
LOCAL nLen
::cReply := ::InetRecvLine( ::SocketCon, @nLen, 512 )
IF ::InetErrorCode( ::SocketCon ) != 0 .OR. SubStr( ::cReply, 1, 1 ) == "5"
::cReply := ::InetRecvLine( ::SocketCon,, 512 )
IF ::InetErrorCode( ::SocketCon ) != 0 .OR. Left( ::cReply, 1 ) == "5"
RETURN .F.
ENDIF
RETURN .T.
METHOD Close() CLASS tIPClientSMTP
HB_InetTimeOut( ::SocketCon, ::nConnTimeout )
hb_inetTimeOut( ::SocketCon, ::nConnTimeout )
IF ::ltrace
FClose(::nHandle)
FClose( ::nHandle )
ENDIF
::Quit()
RETURN ::super:Close()
@@ -154,7 +157,7 @@ METHOD Quit() CLASS tIPClientSMTP
RETURN ::GetOk()
METHOD Mail( cFrom ) CLASS tIPClientSMTP
::InetSendall( ::SocketCon, "MAIL FROM: <" + cFrom +">" + ::cCRLF )
::InetSendall( ::SocketCon, "MAIL FROM: <" + cFrom + ">" + ::cCRLF )
RETURN ::GetOk()
METHOD Rcpt( cTo ) CLASS tIPClientSMTP
@@ -169,61 +172,30 @@ METHOD Data( cData ) CLASS tIPClientSMTP
::InetSendall(::SocketCon, cData + ::cCRLF + "." + ::cCRLF )
RETURN ::GetOk()
METHOD OpenSecure( cUrl ) CLASS tIPClientSMTP
METHOD Auth( cUser, cPass ) CLASS tIPClientSMTP
LOCAL cUser
IF ! ::super:Open( cUrl )
RETURN .F.
ENDIF
HB_InetTimeout( ::SocketCon, ::nConnTimeout )
cUser := ::oUrl:cUserid
IF ! Empty ( ::oUrl:cUserid )
::InetSendall( ::SocketCon, "EHLO " + cUser + ::cCRLF )
ELSE
::InetSendall( ::SocketCon, "EHLO tipClientSMTP" + ::cCRLF )
ENDIF
RETURN ::getOk()
METHOD AUTH( cUser, cPass ) CLASS tIPClientSMTP
LOCAL cEncodedUser
LOCAL cEncodedPAss
cUser := StrTran( cUser, "&at;", "@" )
cEncodedUser := AllTrim( HB_BASE64( cUser ) )
cEncodedPAss := AllTrim( HB_BASE64( cPass ) )
::InetSendall( ::SocketCon, "AUTH LOGIN" + ::ccrlf )
::InetSendall( ::SocketCon, "AUTH LOGIN" + ::cCRLF )
IF ::GetOk()
::InetSendall( ::SocketCon, cEncodedUser + ::cCrlf )
IF ::Getok()
::InetSendall( ::SocketCon, cEncodedPass + ::cCrlf )
::InetSendall( ::SocketCon, hb_BASE64( StrTran( cUser, "&at;", "@" ) ) + ::cCRLF )
IF ::GetOk()
::InetSendall( ::SocketCon, hb_BASE64( cPass ) + ::cCRLF )
ENDIF
ENDIF
RETURN ::isAuth := ::GetOk()
METHOD AuthPlain( cUser, cPass) CLASS tIPClientSMTP
METHOD AuthPlain( cUser, cPass ) CLASS tIPClientSMTP
::InetSendall( ::SocketCon, "AUTH PLAIN" +;
HB_BASE64( BUILDUSERPASSSTRING( cUser, cPass ) ) +;
::cCrlf )
::InetSendall( ::SocketCon, "AUTH PLAIN" + hb_BASE64( Chr( 0 ) + cUser + Chr( 0 ) + cPass ) + ::cCRLF )
RETURN ::isAuth := ::GetOk()
METHOD Write( cData, nLen, bCommit ) CLASS tIPClientSMTP
LOCAL aTo
LOCAL cRecpt
LOCAL cRcpt
IF ! ::bInitialized
//IF Empty( ::oUrl:cUserid ) .OR. Empty( ::oUrl:cFile )
IF Empty( ::oUrl:cFile ) // GD user id not needed if we did not auth
RETURN -1
ENDIF
@@ -231,10 +203,9 @@ METHOD Write( cData, nLen, bCommit ) CLASS tIPClientSMTP
IF ! ::Mail( ::oUrl:cUserid )
RETURN -1
ENDIF
aTo := HB_RegexSplit( ",", ::oUrl:cFile )
FOR EACH cRecpt IN Ato
IF ! ::Rcpt( cRecpt )
FOR EACH cRcpt IN hb_regexSplit( ",", ::oUrl:cFile )
IF ! ::Rcpt( cRcpt )
RETURN -1
ENDIF
NEXT
@@ -250,11 +221,12 @@ METHOD Write( cData, nLen, bCommit ) CLASS tIPClientSMTP
RETURN ::nLastWrite
METHOD ServerSuportSecure( /* @ */ lAuthp, /* @ */ lAuthl ) CLASS tIPClientSMTP
LOCAL lAuthLogin := .F.
LOCAL lAuthPlain := .F.
METHOD ServerSuportSecure( /* @ */ lAuthPlain, /* @ */ lAuthLogin ) CLASS tIPClientSMTP
IF ::OPENSECURE()
lAuthLogin := .F.
lAuthPlain := .F.
IF ::OpenSecure()
DO WHILE .T.
::GetOk()
IF ::cReply == NIL
@@ -265,45 +237,34 @@ METHOD ServerSuportSecure( /* @ */ lAuthp, /* @ */ lAuthl ) CLASS tIPClientSMTP
lAuthPlain := .T.
ENDIF
ENDDO
::CLOSE()
::Close()
ENDIF
lAuthp := lAuthPlain
lAuthl := lAuthLogin
RETURN lAuthLogin .OR. lAuthPlain
METHOD sendMail( oTIpMail ) CLASS TIpClientSmtp
LOCAL cFrom
METHOD SendMail( oTIpMail ) CLASS TIpClientSmtp
LOCAL cTo
LOCAL aTo
IF ! ::isOpen
RETURN .F.
ENDIF
IF ! ::isAuth
::auth( ::oUrl:cUserId, ::oUrl:cPassWord )
::Auth( ::oUrl:cUserId, ::oUrl:cPassWord )
IF ! ::isAuth
RETURN .F.
ENDIF
ENDIF
cFrom := oTIpMail:getFieldPart( "From" )
::mail( oTIpMail:getFieldPart( "From" ) )
cTo := oTIpMail:getFieldPart( "To" )
cTo := StrTran( cTo, hb_inetCRLF() )
cTo := StrTran( cTo, Chr( 9 ) )
cTo := StrTran( cTo, Chr( 32 ) )
cTo := StrTran( cTo, HB_InetCRLF(), "" )
cTo := StrTran( cTo, Chr( 9 ), "" )
cTo := StrTran( cTo, Chr( 32 ), "" )
aTo := HB_RegExSplit( ",", cTo )
::mail( cFrom )
FOR EACH cTo IN aTo
FOR EACH cTo IN hb_regexSplit( ",", cTo )
::rcpt( cTo )
NEXT
RETURN ::data( oTIpMail:toString() )
FUNCTION BUILDUSERPASSSTRING( cUser, cPass )
RETURN Chr( 0 ) + cUser + Chr( 0 ) + cPass

5319
harbour/contrib/hbtip/thtml.prg
View File

File diff suppressed because it is too large Load Diff

67
harbour/contrib/hbtip/tip.ch
View File

@@ -2,23 +2,62 @@
* $Id$
*/
/**********************************************
* tip.ch
*
* Class oriented Internet protocol library
* Base definitions
*
* (C) 2002 Giancarlo Niccolai
************************************************/
/*
* xHarbour Project source code:
* TIP Class oriented Internet protocol library (header)
*
* Copyright 2002 Giancarlo Niccolai <gian@niccolai.ws>
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#ifndef TIP_CH
#define TIP_CH
/* Tip read only protocol */
#define TIP_RO 0
/* Tip write only protocol */
#define TIP_WO 1
/* Tip read/write protocol */
#define TIP_RW 2
/* QUESTION: These values serve no purpose in code.
Shouldn't we delete them with this file? [vszakats] */
#define TIP_RO 0 /* Tip read only protocol */
#define TIP_WO 1 /* Tip write only protocol */
#define TIP_RW 2 /* Tip read/write protocol */
#endif

114
harbour/contrib/hbtip/url.prg
View File

@@ -7,7 +7,6 @@
* TIP Class oriented Internet protocol library
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
*
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
@@ -79,20 +78,20 @@ CREATE CLASS tURL
METHOD SetAddress( cUrl )
METHOD BuildAddress()
METHOD BuildQuery( )
METHOD AddGetForm( cPostData )
METHOD AddGetForm( xPostData )
HIDDEN:
CLASSDATA cREuri INIT HB_RegexComp("(?:(.*)://)?([^?/]*)(/[^?]*)?\??(.*)")
CLASSDATA cREServ INIT HB_RegexComp("(?:([^:@]*):?([^@:]*)@|)([^:]+):?(.*)")
CLASSDATA cREFile INIT HB_RegexComp("^((?:/.*/)|/)*(.*)$")
HIDDEN:
CLASSDATA cREuri INIT hb_regexComp("(?:(.*)://)?([^?/]*)(/[^?]*)?\??(.*)")
CLASSDATA cREServ INIT hb_regexComp("(?:([^:@]*):?([^@:]*)@|)([^:]+):?(.*)")
CLASSDATA cREFile INIT hb_regexComp("^((?:/.*/)|/)*(.*)$")
ENDCLASS
METHOD New( cUrl ) CLASS tURL
::SetAddress( cUrl )
RETURN Self
RETURN Self
METHOD SetAddress( cUrl ) CLASS tURL
LOCAL aMatch, cServer, cPath
@@ -107,39 +106,39 @@ METHOD SetAddress( cUrl ) CLASS tURL
::cFile := ""
::nPort := -1
IF Empty( cUrl ) .OR. Len( cUrl ) == 0
IF Empty( cUrl )
RETURN .T.
ENDIF
// TOPLEVEL url parsing
aMatch:= HB_Regex( ::cREuri, cUrl )
aMatch := hb_regex( ::cREuri, cUrl )
// May fail
IF Empty( aMatch )
RETURN .F.
ENDIF
::cProto := Lower( aMatch[2] )
cServer := aMatch[3]
cPath := aMatch[4]
::cQuery := aMatch[5]
::cProto := Lower( aMatch[ 2 ] )
cServer := aMatch[ 3 ]
cPath := aMatch[ 4 ]
::cQuery := aMatch[ 5 ]
// server parsing (can't fail)
aMatch := HB_Regex( ::cREServ, cServer )
::cUserId := aMatch[2]
::cPassword := aMatch[3]
::cServer := aMatch[4]
::nPort := Val(aMatch[5])
aMatch := hb_regex( ::cREServ, cServer )
::cUserId := aMatch[ 2 ]
::cPassword := aMatch[ 3 ]
::cServer := aMatch[ 4 ]
::nPort := Val( aMatch[ 5 ] )
IF ::nPort < 1
::nPort := -1
ENDIF
// Parse path and file (can't fail )
aMatch := HB_Regex( ::cREFile, cPath )
::cPath := aMatch[2]
::cFile := aMatch[3]
// Parse path and file (can't fail)
aMatch := hb_regex( ::cREFile, cPath )
::cPath := aMatch[ 2 ]
::cFile := aMatch[ 3 ]
RETURN .T.
RETURN .T.
METHOD BuildAddress() CLASS tURL
@@ -156,7 +155,7 @@ METHOD BuildAddress() CLASS tURL
IF ! Empty( ::cUserid )
cRet += ::cUserid
IF ! Empty( ::cPassword )
cRet+= ":" + ::cPassword
cRet += ":" + ::cPassword
ENDIF
cRet += "@"
ENDIF
@@ -164,7 +163,7 @@ METHOD BuildAddress() CLASS tURL
IF ! Empty( ::cServer )
cRet += ::cServer
IF ::nPort > 0
cRet += ":" + AllTrim( Str( ::nPort ) )
cRet += ":" + hb_ntos( ::nPort )
ENDIF
ENDIF
@@ -183,9 +182,9 @@ METHOD BuildAddress() CLASS tURL
::cAddress := cRet
ENDIF
RETURN cRet
RETURN cRet
METHOD BuildQuery( ) CLASS tURL
METHOD BuildQuery() CLASS tURL
LOCAL cLine
IF Len( ::cPath ) == 0 .OR. !( Right( ::cPath, 1 ) == "/" )
@@ -197,49 +196,38 @@ METHOD BuildQuery( ) CLASS tURL
cLine += "?" + ::cQuery
ENDIF
RETURN cLine
RETURN cLine
METHOD AddGetForm( cPostData )
LOCAL cData:="", nI, cTmp,y, cRet
METHOD AddGetForm( xPostData )
LOCAL cData := ""
LOCAL nI
LOCAL y
LOCAL cRet
IF HB_IsHash( cPostData )
FOR nI := 1 TO Len( cPostData )
cTmp := hb_HKeyAt( cPostData, nI )
cTmp := hb_cStr( cTmp )
cTmp := AllTrim( cTmp )
cTmp := TipEncoderUrl_Encode( cTmp )
cData += cTmp +"="
cTmp := hb_HValueAt( cPostData, nI )
cTmp := hb_cStr( cTmp )
cTmp := AllTrim( cTmp )
cTmp := TipEncoderUrl_Encode( cTmp )
cData += cTmp + "&"
NEXT
cData := Left( cData, Len( cData ) - 1 )
ELSEIF HB_IsArray( cPostData )
y := Len(cPostData)
IF hb_isHash( xPostData )
y := Len( xPostData )
FOR nI := 1 TO y
cTmp := cPostData[ nI ,1]
cTmp := hb_cStr( cTmp )
cTmp := AllTrim( cTmp )
cTmp := TipEncoderUrl_Encode( cTmp )
cData += cTmp +"="
cTmp := cPostData[ nI,2]
cTmp := hb_cStr( cTmp )
cTmp := AllTrim( cTmp )
cTmp := TipEncoderUrl_Encode( cTmp )
cData += cTmp
cData += TipEncoderUrl_Encode( AllTrim( hb_cStr( hb_HKeyAt( xPostData, nI ) ) ) ) + "="
cData += TipEncoderUrl_Encode( AllTrim( hb_cStr( hb_HValueAt( xPostData, nI ) ) ) )
IF nI != y
cData += "&"
ENDIF
NEXT
ELSEIF HB_IsString( cPostData )
cData := cPostData
ELSEIF hb_isArray( xPostData )
y := Len( xPostData )
FOR nI := 1 TO y
cData += TipEncoderUrl_Encode( AllTrim( hb_cStr( xPostData[ nI, 1 ] ) ) ) + "="
cData += TipEncoderUrl_Encode( AllTrim( hb_cStr( xPostData[ nI, 2 ] ) ) )
IF nI != y
cData += "&"
ENDIF
NEXT
ELSEIF hb_isString( xPostData )
cData := xPostData
ENDIF
IF !empty(cData)
cRet := ::cQuery += iif(empty(::cQuery),"","&") + cData
IF ! Empty( cData )
cRet := ::cQuery += iif( Empty( ::cQuery ), "", "&" ) + cData
ENDIF
RETURN cRet
RETURN cRet

3
harbour/include/hbextern.ch
View File

@@ -965,6 +965,9 @@ EXTERNAL HB_CRCCT
EXTERNAL HB_MD5
EXTERNAL HB_MD5FILE
EXTERNAL HB_BASE64DECODE
EXTERNAL HB_BASE64ENCODE
EXTERNAL HB_GTALERT
EXTERNAL HB_GTVERSION
EXTERNAL HB_GTSYS

2
harbour/source/rtl/Makefile
View File

@@ -14,6 +14,7 @@ C_SOURCES=\
ampm.c \
at.c \
ati.c \
base64c.c \
binnum.c \
binnumx.c \
box.c \
@@ -184,6 +185,7 @@ PRG_SOURCES=\
adir.prg \
alert.prg \
altd.prg \
base64.prg \
browdb.prg \
browdbx.prg \
browse.prg \

119
harbour/source/rtl/base64.prg Normal file
View File

@@ -0,0 +1,119 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* HB_BASE64DECODE() function
*
* Based on VB code by: 1999-2004 Antonin Foller, http://www.motobit.com, http://motobit.cz
* Converted to Clipper and optimized by Viktor Szakats (harbour.01 syenar.hu)
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
FUNCTION HB_BASE64DECODE( cString )
LOCAL cResult
LOCAL nLen
LOCAL nGroupPos
LOCAL nGroup
LOCAL nCharPos
LOCAL nDataLen
LOCAL nData
/* remove white spaces, If any */
cString := StrTran( cString, Chr( 10 ) )
cString := StrTran( cString, Chr( 13 ) )
cString := StrTran( cString, Chr( 9 ) )
cString := StrTran( cString, " " )
/* The source must consists from groups with Len of 4 chars */
IF ( nLen := Len( cString ) ) % 4 != 0
RETURN "" /* Bad Base64 string */
ENDIF
#if 0
IF nLen > Int( MAXSTRINGLENGTH / 1.34 ) /* Base64 is 1/3rd larger than source text. */
RETURN "" /* Not enough memory to decode */
ENDIF
#endif
cResult := ""
/* Now decode each group: */
FOR nGroupPos := 1 TO nLen STEP 4
/* Each data group encodes up To 3 actual bytes */
nDataLen := 3
nGroup := 0
FOR nCharPos := 0 TO 3
/* Convert each character into 6 bits of data, And add it To
an integer For temporary storage. If a character is a '=', there
is one fewer data byte. (There can only be a maximum of 2 '=' In
the whole string.) */
nData := At( SubStr( cString, nGroupPos + nCharPos, 1 ), "=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" ) - 2
DO CASE
CASE nData >= 0
/* Do nothing (for speed) */
CASE nData == -1
nData := 0
nDataLen--
CASE nData == -2
RETURN "" /* Bad character In Base64 string */
ENDCASE
nGroup := 64 * nGroup + nData
NEXT
/* Convert the 24 bits to 3 characters
and add nDataLen characters To out string */
cResult += Left( Chr( nGroup / 65536 ) +; /* bitwise AND 255, which is done by Chr() automatically */
Chr( nGroup / 256 ) +; /* bitwise AND 255, which is done by Chr() automatically */
Chr( nGroup ), nDataLen ) /* bitwise AND 255, which is done by Chr() automatically */
NEXT
RETURN cResult

100
harbour/source/rtl/base64c.c Normal file
View File

@@ -0,0 +1,100 @@
/*
* $Id$
*/
/*
* xHarbour Project source code:
* BASE64 encoder
*
* Copyright 2003 Giancarlo Niccolai <gian@niccolai.ws>
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include "hbapi.h"
HB_FUNC( HB_BASE64ENCODE )
{
ULONG len = hb_parclen( 1 );
if( len <= INT_MAX ) /* TOFIX */
{
const char * s = hb_parcx( 1 );
char * t, * p;
t = p = ( char * ) hb_xgrab( ( 4 * ( ( len + 2 ) / 3 ) + 1 ) * sizeof( *t ) );
while( len-- > 0 )
{
static const char s_b64chars[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
int x, y;
x = *s++;
*p++ = s_b64chars[ ( x >> 2 ) & 0x3F ];
if( len-- <= 0 )
{
*p++ = s_b64chars[ ( x << 4 ) & 0x3F ];
*p++ = '=';
*p++ = '=';
break;
}
y = *s++;
*p++ = s_b64chars[ ( ( x << 4 ) | ( ( y >> 4 ) & 0x0F ) ) & 0x3F ];
if( len-- <= 0 )
{
*p++ = s_b64chars[ ( y << 2 ) & 0x3F ];
*p++ = '=';
break;
}
x = *s++;
*p++ = s_b64chars[ ( ( y << 2 ) | ( ( x >> 6 ) & 3 ) ) & 0x3F ];
*p++ = s_b64chars[ x & 0x3F ];
}
*p = '\0';
hb_retc_buffer( t );
}
else
hb_retc_null();
}