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

2015-03-10 18:06 UTC+0100 Przemyslaw Czerpak (druzus/at/poczta.onet.pl)

Browse Source 
* contrib/hbtip/cgi.prg
  * contrib/hbtip/client.prg
  * contrib/hbtip/encb64.prg
  * contrib/hbtip/encoder.prg
  * contrib/hbtip/encqp.prg
  * contrib/hbtip/mail.prg
  * contrib/hbtip/sendmail.prg
    * synced manually with Viktor's branch (not all things).

  * doc/xhb-diff.txt
    ! fixed few typos
This commit is contained in:
Przemysław Czerpak
2015-03-10 18:06:11 +01:00
parent f832dbe9a4
commit 7f80c2e286
9 changed files with 601 additions and 970 deletions
Download Patch File Download Diff File Expand all files Collapse all files

13
ChangeLog.txt
View File

@@ -10,6 +10,19 @@
* Change, ! Fix, % Optimization, + Addition, - Removal, ; Comment
*/
2015-03-10 18:06 UTC+0100 Przemyslaw Czerpak (druzus/at/poczta.onet.pl)
* contrib/hbtip/cgi.prg
* contrib/hbtip/client.prg
* contrib/hbtip/encb64.prg
* contrib/hbtip/encoder.prg
* contrib/hbtip/encqp.prg
* contrib/hbtip/mail.prg
* contrib/hbtip/sendmail.prg
* synced manually with Viktor's branch (not all things).
* doc/xhb-diff.txt
! fixed few typos
2015-03-09 19:16 UTC+0100 Przemyslaw Czerpak (druzus/at/poczta.onet.pl)
* contrib/hbtip/smtpcli.prg
! consume whole EHLO output after STARTTLS

417
contrib/hbtip/cgi.prg
View File

@@ -60,10 +60,7 @@
#include "fileio.ch"
#define CGI_IN 0
#define CGI_OUT 1
#define _CRLF Chr( 13 ) + Chr( 10 )
#define _BR "<br />"
CREATE CLASS TIPCgi
@@ -104,83 +101,63 @@ ENDCLASS
METHOD New() CLASS TIPCgi
LOCAL aTemp
LOCAL aVar
LOCAL lPost
LOCAL nCount
LOCAL nLen
LOCAL nRead
LOCAL cTemp
LOCAL item
::bSavedErrHandler := ErrorBlock( {| e | ::ErrHandler( e ) } )
::cCgiHeader := ""
::cHtmlPage := ""
lPost := ( "POST" $ Upper( GetEnv( "REQUEST_METHOD" ) ) )
IF lPost
IF "POST" $ Upper( GetEnv( "REQUEST_METHOD" ) )
nLen := Val( GetEnv( "CONTENT_LENGTH" ) )
cTemp := Space( nLen )
IF ( ( nRead := FRead( CGI_IN, @cTemp, nLen ) ) != nLen )
IF ( nRead := FRead( hb_GetStdIn(), @cTemp, nLen ) ) != nLen
::ErrHandler( "post error read " + hb_ntos( nRead ) + " instead of " + hb_ntos( nLen ) )
ELSE
::HTTP_RAW_POST_DATA := 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( tip_URLDecode( aVar[ 1 ] ) ) ] := tip_URLDecode( 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( tip_URLDecode( aVar[ 1 ] ) ) ] := tip_URLDecode( aVar[ 2 ] )
ENDIF
NEXT
ENDIF
ENDIF
ENDIF
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( tip_URLDecode( aVar[ 1 ] ) ) ] := tip_URLDecode( aVar[ 2 ] )
FOR EACH item IN hb_ATokens( cTemp, "&" )
IF Len( aVar := hb_ATokens( item, "=" ) ) == 2
::hPosts[ AllTrim( tip_URLDecode( aVar[ 1 ] ) ) ] := tip_URLDecode( aVar[ 2 ] )
ENDIF
NEXT
ENDIF
ELSEIF ! Empty( cTemp := GetEnv( "QUERY_STRING" ) )
FOR EACH item IN hb_ATokens( cTemp, "&" )
IF Len( aVar := hb_ATokens( item, "=" ) ) == 2
::hGets[ AllTrim( tip_URLDecode( aVar[ 1 ] ) ) ] := tip_URLDecode( aVar[ 2 ] )
ENDIF
NEXT
ENDIF
IF ! Empty( cTemp := GetEnv( "HTTP_COOKIE" ) )
FOR EACH item IN hb_ATokens( cTemp, ";" )
IF Len( aVar := hb_ATokens( item, "=" ) ) == 2
::hCookies[ AllTrim( tip_URLDecode( aVar[ 1 ] ) ) ] := tip_URLDecode( aVar[ 2 ] )
ENDIF
NEXT
ENDIF
RETURN Self
METHOD Header( cValue ) CLASS TIPCgi
IF Empty( cValue )
::cCgiHeader += "Content-Type: text/html" + _CRLF
ELSE
IF HB_ISSTRING( cValue ) .AND. ! Empty( cValue )
::cCgiHeader += cValue + _CRLF
ELSE
::cCgiHeader += "Content-Type: text/html" + _CRLF
ENDIF
RETURN Self
METHOD Redirect( cUrl ) CLASS TIPCgi
::cCgiHeader += "Location: " + cUrl + _CRLF
IF HB_ISSTRING( cUrl ) .AND. ! Empty( cUrl )
::cCgiHeader += "Location: " + cUrl + _CRLF
ENDIF
RETURN Self
@@ -192,62 +169,43 @@ METHOD Flush() CLASS TIPCgi
LOCAL nH
LOCAL cFile
LOCAL cSID := ::cSID
LOCAL cSession
hb_HEval( ::hCookies, {| k, v | ::cCgiHeader += "Set-Cookie: " + k + "=" + v + ";" + _CRLF } )
cStream := ::cCgiHeader + _CRLF + ::cHtmlPage + _CRLF
lRet := ( FWrite( CGI_OUT, cStream ) == hb_BLen( cStream ) )
lRet := ( FWrite( hb_GetStdOut(), cStream ) == hb_BLen( cStream ) )
IF ::lDumpHtml
IF Empty( ::cDumpSavePath )
::cDumpSavePath := hb_DirTemp()
ENDIF
IF ( nH := FCreate( ::cDumpSavePath + "dump.html", FC_NORMAL ) ) != F_ERROR
FWrite( nH, ::cHtmlPage )
ENDIF
FClose( nH )
hb_MemoWrit( ::cDumpSavePath + "dump.html", ::cHtmlPage )
ENDIF
::cCgiHeader := ""
::cHtmlPage := ""
IF ! Empty( cSID )
IF ! Empty( ::cSID )
cFile := ::cSessionSavePath + "SESSIONID_" + cSID
cFile := ::cSessionSavePath + "SESSIONID_" + ::cSID
IF ( nH := FCreate( cFile, FC_NORMAL ) ) != F_ERROR
IF ( nH := FCreate( cFile ) ) != F_ERROR
cSession := ::SessionEncode()
IF FWrite( nH, cSession ) != hb_BLen( cSession )
::Write( "ERROR: On writing session file : " + cFile + ", File error : " + hb_CStr( FError() ) )
::Write( "ERROR: On writing session file: " + cFile + ", File error: " + hb_CStr( FError() ) )
ENDIF
FClose( nH )
ELSE
::Write( "ERROR: On writing session file : " + cFile + ", File error : " + hb_CStr( FError() ) )
::Write( "ERROR: On writing session file: " + cFile + ", File error: " + hb_CStr( FError() ) )
ENDIF
ENDIF
RETURN lRet
METHOD SaveHtmlPage( cFile ) CLASS TIPCgi
LOCAL nFile
LOCAL lSuccess
LOCAL cStream
nFile := FCreate( cFile )
IF nFile != F_ERROR
cStream := ::cHtmlPage + _CRLF
lSuccess := ( FWrite( nFile, cStream ) == hb_BLen( cStream ) )
FClose( nFile )
ELSE
lSuccess := .F.
ENDIF
RETURN lSuccess
RETURN hb_MemoWrit( cFile, ::cHtmlPage + _CRLF )
METHOD StartSession( cSID ) CLASS TIPCgi
@@ -256,16 +214,12 @@ METHOD StartSession( cSID ) CLASS TIPCgi
LOCAL nFileSize
LOCAL cBuffer
IF Empty( cSID )
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
IF ! HB_ISSTRING( cSID ) .OR. Empty( cSID )
DO CASE
CASE hb_HGetRef( ::hGets, "SESSIONID", @cSID )
CASE hb_HGetRef( ::hPosts, "SESSIONID", @cSID )
CASE hb_HGetRef( ::hCookies, "SESSIONID", @cSID )
ENDCASE
ENDIF
IF Empty( ::cSessionSavePath )
@@ -279,26 +233,23 @@ METHOD StartSession( cSID ) CLASS TIPCgi
cFile := ::cSessionSavePath + "SESSIONID_" + cSID
IF hb_FileExists( cFile )
IF ( nH := FOpen( cFile, FO_READ ) ) != F_ERROR
IF ( nH := FOpen( cFile ) ) != F_ERROR
nFileSize := FSeek( nH, 0, FS_END )
FSeek( nH, 0, FS_SET )
cBuffer := Space( nFileSize )
IF ( FRead( nH, @cBuffer, nFileSize ) ) != nFileSize
::ErrHandler( "ERROR: On reading session file : " + cFile + ", File error : " + hb_CStr( FError() ) )
IF FRead( nH, @cBuffer, nFileSize ) != nFileSize
::ErrHandler( "ERROR: On reading session file: " + cFile + ", File error: " + hb_CStr( FError() ) )
ELSE
::SessionDecode( cBuffer )
ENDIF
FClose( nH )
ENDIF
ELSE
::ErrHandler( "ERROR: On opening session file : " + cFile + ", file not exist." )
::ErrHandler( "ERROR: On opening session file: " + cFile + ", file not exist." )
ENDIF
ELSE
::CreateSID()
::hSession := { => }
ENDIF
::hCookies[ "SESSIONID" ] := ::cSID
@@ -306,23 +257,21 @@ METHOD StartSession( cSID ) CLASS TIPCgi
RETURN Self
METHOD SessionEncode() CLASS TIPCgi
RETURN hb_Serialize( ::hSession )
METHOD SessionDecode( cData ) CLASS TIPCgi
::hSession := hb_Deserialize( cData )
RETURN HB_ISHASH( ::hSession )
RETURN HB_ISHASH( ::hSession := hb_Deserialize( cData ) )
METHOD DestroySession( cID ) CLASS TIPCgi
LOCAL cFile
LOCAL cSID := ::cSID
LOCAL lRet
LOCAL cSID
LOCAL lOk
IF ! Empty( cID )
IF HB_ISSTRING( cID ) .AND. ! Empty( cID )
cSID := cID
ELSE
cSID := ::cSID
ENDIF
IF ! Empty( cSID )
@@ -331,41 +280,39 @@ METHOD DestroySession( cID ) CLASS TIPCgi
cFile := ::cSessionSavePath + "SESSIONID_" + cSID
IF !( lRet := ( FErase( cFile ) == 0 ) )
::Write( "ERROR: On deleting session file : " + cFile + ", File error : " + hb_CStr( FError() ) )
ELSE
IF ( lOk := ( FErase( cFile ) != F_ERROR ) )
::hCookies[ "SESSIONID" ] := cSID + "; expires= " + tip_DateToGMT( Date() - 1 )
::CreateSID()
cSID := ::cSID
::hCookies[ "SESSIONID" ] := cSID
::hCookies[ "SESSIONID" ] := ::cSID
ELSE
::Write( "ERROR: On deleting session file: " + cFile + ", File error: " + hb_CStr( FError() ) )
ENDIF
ENDIF
RETURN lRet
RETURN lOk
METHOD ErrHandler( xError ) CLASS TIPCgi
LOCAL nCalls
LOCAL cErrMsg := ""
cErrMsg += '<table border="1">'
LOCAL cErrMsg := ;
'<table border="1">' + ;
"<tr><td>SCRIPT NAME:</td><td>" + GetEnv( "SCRIPT_NAME" ) + "</td></tr>"
cErrMsg += "<tr><td>SCRIPT NAME:</td><td>" + GetEnv( "SCRIPT_NAME" ) + "</td></tr>"
IF HB_ISOBJECT( xError )
cErrMsg += "<tr><td>CRITICAL ERROR:</td><td>" + xError:Description + "</td></tr>"
cErrMsg += "<tr><td>OPERATION:</td><td>" + xError:Operation + "</td></tr>"
cErrMsg += "<tr><td>OS ERROR:</td><td>" + hb_ntos( xError:OsCode ) + " IN " + xError:SubSystem + "/" + hb_ntos( xError:SubCode ) + "</td></tr>"
cErrMsg += "<tr><td>FILENAME:</td><td>" + Right( xError:FileName, 40 ) + "</td></tr>"
ELSEIF HB_ISSTRING( xError )
DO CASE
CASE HB_ISOBJECT( xError )
cErrMsg += ;
"<tr><td>CRITICAL ERROR:</td><td>" + xError:Description + "</td></tr>" + ;
"<tr><td>OPERATION:</td><td>" + xError:Operation + "</td></tr>" + ;
"<tr><td>OS ERROR:</td><td>" + hb_ntos( xError:OsCode ) + " IN " + xError:SubSystem + "/" + hb_ntos( xError:SubCode ) + "</td></tr>" + ;
"<tr><td>FILENAME:</td><td>" + Right( xError:FileName, 40 ) + "</td></tr>"
CASE HB_ISSTRING( xError )
cErrMsg += "<tr><td>ERROR MESSAGE:</td><td>" + tip_HtmlSpecialChars( xError ) + "</td></tr>"
ENDIF
ENDCASE
nCalls := 1
DO WHILE ! Empty( ProcName( nCalls ) )
nCalls := 0
DO WHILE ! Empty( ProcName( ++nCalls ) )
cErrMsg += "<tr><td>PROC/LINE:</td><td>" + ProcName( nCalls ) + "/" + hb_ntos( ProcLine( nCalls ) ) + "</td></tr>"
nCalls++
ENDDO
cErrMsg += "</table>"
@@ -389,19 +336,15 @@ METHOD Write( cString ) CLASS TIPCgi
METHOD StartHtml( hOptions ) CLASS TIPCgi
::cHtmlPage += ;
'<?xml version="1.0"' + HtmlOption( hOptions, "encoding", " " ) + "?>" + _CRLF + ;
'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"' + _CRLF + ;
'"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">' + _CRLF + ;
'<html xmlns="http://www.w3.org/1999/xhtml">' + ;
"<head>" + ;
"<!DOCTYPE html>" + _CRLF + ;
"<html>" + ;
'<head><meta charset="' + HtmlOption( hOptions, "encoding" ) + '" />' + ;
HtmlTag( hOptions, "title", "title" ) + ;
HtmlScript( hOptions ) + ;
HtmlStyle( hOptions ) + ;
HtmlLinkRel( hOptions ) + ;
"</head>" + ;
"<body " + ;
HtmlAllOption( hOptions ) + ;
">"
"<body " + HtmlAllOption( hOptions ) + ">"
RETURN Self
@@ -413,57 +356,43 @@ METHOD EndHtml() CLASS TIPCgi
STATIC FUNCTION HtmlTag( xVal, cKey, cDefault )
LOCAL cVal := ""
LOCAL cVal
hb_default( @cDefault, "" )
IF ! Empty( xVal ) .AND. ! Empty( cKey )
IF hb_HHasKey( xVal, cKey )
cVal := xVal[ cKey ]
hb_HDel( xVal, cKey )
ENDIF
IF HB_ISHASH( xVal ) .AND. ! Empty( cKey ) .AND. cKey $ xVal
cVal := xVal[ cKey ]
hb_HDel( xVal, cKey )
ELSE
cVal := ""
ENDIF
IF cVal == ""
cVal := cDefault
cVal := hb_defaultValue( cDefault, "" )
ENDIF
IF !( cVal == "" )
cVal := "<" + cKey + ">" + cVal + "</" + cKey + ">"
IF cVal == ""
RETURN cVal
ENDIF
RETURN cVal
/*
STATIC FUNCTION HtmlAllTag( hTags, cSep )
LOCAL cVal := ""
hb_default( @cSep, " " )
hb_HEval( hTags, {| k | cVal += HtmlTag( hTags, k ) + cSep } )
RETURN cVal
*/
RETURN "<" + cKey + ">" + cVal + "</" + cKey + ">"
STATIC FUNCTION HtmlOption( xVal, cKey, cPre, cPost, lScan )
LOCAL cVal := ""
IF ! Empty( xVal )
IF HB_ISHASH( xVal )
IF Empty( cKey )
cVal := xVal
ELSEIF hb_HHasKey( xVal, cKey )
ELSEIF cKey $ xVal
cVal := xVal[ cKey ]
IF Empty( lScan )
IF hb_defaultValue( lScan, .F. )
hb_HDel( xVal, cKey )
ENDIF
cVal := cKey + '="' + cVal + '"'
IF cPre != NIL
cVal := cKey + "=" + '"' + cVal + '"'
IF HB_ISSTRING( cPre )
cVal := cPre + cVal
ENDIF
IF cPost != NIL
cVal := cVal + cPost
IF HB_ISSTRING( cPost )
cVal += cPost
ENDIF
ENDIF
ENDIF
@@ -474,7 +403,7 @@ STATIC FUNCTION HtmlAllOption( hOptions, cSep )
LOCAL cVal := ""
IF ! Empty( hOptions )
IF HB_ISHASH( hOptions )
hb_default( @cSep, " " )
hb_HEval( hOptions, {| k | cVal += HtmlOption( hOptions, k,,, .T. ) + cSep } )
@@ -482,153 +411,97 @@ STATIC FUNCTION HtmlAllOption( hOptions, cSep )
RETURN cVal
/*
STATIC FUNCTION HtmlValue( xVal, cKey, cDefault )
LOCAL cVal := ""
hb_default( @cDefault, "" )
IF ! Empty( xVal ) .AND. ! Empty( cKey )
IF hb_HHasKey( xVal, cKey )
cVal := xVal[ cKey ]
hb_HDel( xVal, cKey )
ENDIF
ENDIF
IF cVal == ""
cVal := cDefault
ENDIF
RETURN cVal
STATIC FUNCTION HtmlAllValue( hValues, cSep )
LOCAL cVal := ""
IF ! Empty( hValues )
hb_default( @cSep, " " )
hb_HEval( hValues, {| k | cVal += HtmlValue( hValues, k ) + cSep } )
ENDIF
RETURN cVal
*/
STATIC FUNCTION HtmlScript( hVal, cKey )
LOCAL hTmp
LOCAL cRet := ""
LOCAL hTmp
LOCAL cVal
LOCAL nPos
LOCAL cTmp
hb_default( @cKey, "script" )
IF ! Empty( hVal )
IF ( nPos := hb_HPos( hVal, cKey ) ) != 0
hTmp := hb_HValueAt( hVal, nPos )
IF HB_ISHASH( hTmp )
IF ( nPos := hb_HPos( hTmp, "src" ) ) != 0
cVal := hb_HValueAt( hTmp, nPos )
IF HB_ISSTRING( cVal )
cVal := { cVal }
ENDIF
IF HB_ISARRAY( cVal )
cTmp := ""
AScan( cVal, {| cFile | cTmp += '<script src="' + cFile + '" type="text/javascript"></script>' + _CRLF } )
cRet += cTmp
ENDIF
ENDIF
IF ( nPos := hb_HPos( hTmp, "var" ) ) != 0
cVal := hb_HValueAt( hTmp, nPos )
IF HB_ISSTRING( cVal )
cVal := { cVal }
ENDIF
IF HB_ISARRAY( cVal )
cTmp := ""
AScan( cVal, {| cVar | cTmp += cVar } )
cRet += '<script type="text/javascript">' + _CRLF + "<!--" + _CRLF + cTmp + _CRLF + "-->" + _CRLF + "</script>" + _CRLF
ENDIF
ENDIF
IF hb_HGetRef( hVal, cKey, @hTmp )
IF hb_HGetRef( hTmp, "src", @cVal )
IF HB_ISSTRING( cVal )
cVal := { cVal }
ENDIF
IF HB_ISARRAY( cVal )
cTmp := ""
AScan( cVal, {| cFile | cTmp += '<script src="' + cFile + '" type="text/javascript"></script>' + _CRLF } )
cRet += cTmp
ENDIF
hb_HDel( hVal, cKey )
ENDIF
IF hb_HGetRef( hTmp, "var", @cVal )
IF HB_ISSTRING( cVal )
cVal := { cVal }
ENDIF
IF HB_ISARRAY( cVal )
cTmp := ""
AScan( cVal, {| cVar | cTmp += cVar } )
cRet += '<script type="text/javascript">' + _CRLF + "<!--" + _CRLF + cTmp + _CRLF + "-->" + _CRLF + "</script>" + _CRLF
ENDIF
ENDIF
hb_HDel( hVal, cKey )
ENDIF
RETURN cRet
STATIC FUNCTION HtmlStyle( hVal, cKey )
LOCAL hTmp
LOCAL cRet := ""
LOCAL hTmp
LOCAL cVal
LOCAL nPos
LOCAL cTmp
hb_default( @cKey, "style" )
IF ! Empty( hVal )
IF ( nPos := hb_HPos( hVal, cKey ) ) != 0
hTmp := hb_HValueAt( hVal, nPos )
IF HB_ISHASH( hTmp )
IF ( nPos := hb_HPos( hTmp, "src" ) ) != 0
cVal := hb_HValueAt( hTmp, nPos )
IF HB_ISSTRING( cVal )
cVal := { cVal }
ENDIF
IF HB_ISARRAY( cVal )
cTmp := ""
AScan( cVal, {| cFile | cTmp += '<link rel="StyleSheet" href="' + cFile + '" type="text/css">' + _CRLF } )
cRet += cTmp
ENDIF
ENDIF
IF ( nPos := hb_HPos( hTmp, "var" ) ) != 0
cVal := hb_HValueAt( hTmp, nPos )
IF HB_ISSTRING( cVal )
cVal := { cVal }
ENDIF
IF HB_ISARRAY( cVal )
cTmp := ""
AScan( cVal, {| cVar | cTmp += cVar } )
cRet += '<style type="text/css">' + _CRLF + "<!--" + _CRLF + cTmp + _CRLF + "-->" + _CRLF + "</style>" + _CRLF
ENDIF
ENDIF
IF hb_HGetRef( hVal, cKey, @hTmp )
IF hb_HGetRef( hTmp, "src", @cVal )
IF HB_ISSTRING( cVal )
cVal := { cVal }
ENDIF
IF HB_ISARRAY( cVal )
cTmp := ""
AScan( cVal, {| cFile | cTmp += '<link rel="StyleSheet" href="' + cFile + '" type="text/css">' + _CRLF } )
cRet += cTmp
ENDIF
hb_HDel( hVal, cKey )
ENDIF
IF hb_HGetRef( hTmp, "var", @cVal )
IF HB_ISSTRING( cVal )
cVal := { cVal }
ENDIF
IF HB_ISARRAY( cVal )
cTmp := ""
AScan( cVal, {| cVar | cTmp += cVar } )
cRet += '<style type="text/css">' + _CRLF + "<!--" + _CRLF + cTmp + _CRLF + "-->" + _CRLF + "</style>" + _CRLF
ENDIF
ENDIF
hb_HDel( hVal, cKey )
ENDIF
RETURN cRet
STATIC FUNCTION HtmlLinkRel( hVal, cKey )
LOCAL hTmp
LOCAL cRet := ""
LOCAL hTmp
LOCAL cVal
LOCAL nPos
LOCAL cTmp
hb_default( @cKey, "link" )
IF ! Empty( hVal )
IF ( nPos := hb_HPos( hVal, cKey ) ) != 0
hTmp := hb_HValueAt( hVal, nPos )
IF HB_ISHASH( hTmp )
IF ( nPos := hb_HPos( hTmp, "rel" ) ) != 0
cVal := hb_HValueAt( hTmp, nPos )
IF HB_ISSTRING( cVal )
cVal := { cVal, cVal }
ENDIF
IF HB_ISARRAY( cVal )
cTmp := ""
AScan( cVal, {| aVal | cTmp += '<link rel="' + aVal[ 1 ] + '" href="' + aVal[ 2 ] + '"/>' + _CRLF } )
cRet += cTmp
ENDIF
ENDIF
IF hb_HGetRef( hVal, cKey, @hTmp )
IF hb_HGetRef( hTmp, "rel", @cVal )
IF HB_ISSTRING( cVal )
cVal := { cVal, cVal }
ENDIF
IF HB_ISARRAY( cVal )
AScan( cVal, {| aVal | cRet += '<link rel="' + aVal[ 1 ] + '" href="' + aVal[ 2 ] + '"/>' + _CRLF } )
ENDIF
hb_HDel( hVal, cKey )
ENDIF
hb_HDel( hVal, cKey )
ENDIF
RETURN cRet

339
contrib/hbtip/client.prg
View File

@@ -75,7 +75,7 @@
#include "fileio.ch"
#if defined( _SSL_DEBUG_TEMP )
# include "simpleio.ch"
#include "simpleio.ch"
#endif
#include "hbssl.ch"
@@ -85,9 +85,7 @@
#define RCV_BUF_SIZE Int( ::InetRcvBufSize( ::SocketCon ) / 2 )
#define SND_BUF_SIZE Int( ::InetSndBufSize( ::SocketCon ) / 2 )
/**
* Inet Client class
*/
/* Inet Client class */
CREATE CLASS TIPClient
CLASS VAR bInitSocks INIT .F.
@@ -142,14 +140,12 @@ CREATE CLASS TIPClient
METHOD Read( nLen )
METHOD ReadToFile( cFile, nMode, nSize )
METHOD Write( cData, nLen, bCommit )
METHOD Write( cData, nLen, lCommit )
METHOD Commit()
METHOD WriteFromFile( cFile )
METHOD Reset()
METHOD Close()
/* METHOD Data( cData ) */ // commented: calls undeclared METHOD :getOk
METHOD SetProxy( cProxyHost, nProxyPort, cProxyUser, cProxyPassword )
METHOD lastErrorCode() INLINE ::nLastError
@@ -166,8 +162,8 @@ CREATE CLASS TIPClient
VAR nLastError INIT 0
METHOD OpenProxy( cServer, nPort, cProxy, nProxyPort, cResp, cUserName, cPassWord, cUserAgent )
METHOD ReadHTTPProxyResponse( sResponse )
METHOD OpenProxy( cServer, nPort, cProxy, nProxyPort, cResp, cUserName, cPassword, cUserAgent )
METHOD ReadHTTPProxyResponse( cResponse )
/* Methods to log data if needed */
METHOD inetRecv( SocketCon, cStr1, len )
@@ -187,12 +183,9 @@ METHOD New( oUrl, xTrace, oCredentials ) CLASS TIPClient
LOCAL oErr
LOCAL oLog
LOCAL lSSL
LOCAL aProtoAccepted := { "ftp", "http", "pop", "smtp" }
LOCAL aProtoAcceptedSSL := iif( ::lHasSSL, { "ftps", "https", "pop3s", "pops", "smtps" }, {} )
IF HB_ISSTRING( xTrace ) .OR. ;
( HB_ISLOGICAL( xTrace ) .AND. xTrace )
IF HB_ISSTRING( xTrace ) .OR. hb_defaultValue( xTrace, .F. )
oLog := TIPLog():New( iif( HB_ISSTRING( xTrace ), xTrace, NIL ) )
::bTrace := {| cMsg | iif( PCount() > 0, oLog:Add( cMsg ), oLog:Close() ) }
ELSEIF HB_ISEVALITEM( xTrace )
@@ -203,9 +196,23 @@ METHOD New( oUrl, xTrace, oCredentials ) CLASS TIPClient
oUrl := TUrl():New( oUrl )
ENDIF
IF AScan( aProtoAccepted , {| tmp | tmp == oURL:cProto } ) == 0 .AND. ;
AScan( aProtoAcceptedSSL, {| tmp | tmp == oURL:cProto } ) == 0
SWITCH oURL:cProto
CASE "ftp"
CASE "http"
CASE "pop"
CASE "smtp"
lSSL := .F.
EXIT
CASE "ftps"
CASE "https"
CASE "pop3s"
CASE "pops"
CASE "smtps"
IF ::lHasSSL
lSSL := .T.
EXIT
ENDIF
OTHERWISE
oErr := ErrorNew()
oErr:Args := { Self, oURL:cProto }
oErr:CanDefault := .F.
@@ -218,61 +225,47 @@ METHOD New( oUrl, xTrace, oCredentials ) CLASS TIPClient
oErr:SubCode := 1081
oErr:SubSystem := "BASE"
Eval( ErrorBlock(), oErr )
ENDIF
ENDSWITCH
IF ! ::bInitSocks
hb_inetInit()
IF ::lHasSSL
SSL_init()
RAND_seed( Time() + hb_UserName() + DToS( Date() ) + hb_DirBase() + NetName() )
RAND_seed( hb_randStr( 20 ) + hb_UserName() + hb_TToS( hb_DateTime() ) + NetName() )
ENDIF
::bInitSocks := .T.
ENDIF
IF ::lHasSSL
IF oURL:cProto == "ftps" .OR. ;
oURL:cProto == "https" .OR. ;
oURL:cProto == "pop3s" .OR. oURL:cProto == "pops" .OR. ;
oURL:cProto == "smtps"
::EnableSSL( .T. )
ENDIF
IF ::lHasSSL .AND. lSSL
::EnableSSL( .T. )
ENDIF
::oUrl := oUrl
::oCredentials := oCredentials
RETURN self
RETURN Self
METHOD Open( cUrl ) CLASS TIPClient
LOCAL nPort
LOCAL cResp
IF HB_ISSTRING( cUrl )
::oUrl := TUrl():New( cUrl )
ENDIF
IF ::oUrl:nPort == -1
nPort := ::nDefaultPort
ELSE
nPort := ::oUrl:nPort
ENDIF
nPort := iif( ::oUrl:nPort == -1, ::nDefaultPort, ::oUrl:nPort )
::SocketCon := hb_inetCreate()
::InetTimeOut( ::SocketCon )
IF ! Empty( ::cProxyHost )
cResp := ""
IF ! ::OpenProxy( ::oUrl:cServer, nPort, ::cProxyHost, ::nProxyPort, @cResp, ::cProxyUser, ::cProxyPassword, "Mozilla/3.0 compatible" )
RETURN .F.
ENDIF
ELSE
IF Empty( ::cProxyHost )
::inetConnect( ::oUrl:cServer, nPort, ::SocketCon )
IF ::inetErrorCode( ::SocketCon ) != 0
RETURN .F.
ENDIF
ELSEIF ! ::OpenProxy( ::oUrl:cServer, nPort, ::cProxyHost, ::nProxyPort,, ::cProxyUser, ::cProxyPassword, "Mozilla/3.0 compatible" )
RETURN .F.
ENDIF
::isOpen := .T.
@@ -306,7 +299,7 @@ METHOD EnableSSL( lEnable ) CLASS TIPClient
RETURN lSuccess
METHOD OpenProxy( cServer, nPort, cProxy, nProxyPort, cResp, cUserName, cPassWord, cUserAgent ) CLASS TIPClient
METHOD OpenProxy( cServer, nPort, cProxy, nProxyPort, cResp, cUserName, cPassword, cUserAgent ) CLASS TIPClient
LOCAL cRequest
LOCAL lRet := .F.
@@ -315,51 +308,43 @@ METHOD OpenProxy( cServer, nPort, cProxy, nProxyPort, cResp, cUserName, cPassWor
::inetConnect( cProxy, nProxyPort, ::SocketCon )
IF ( tmp := ::inetErrorCode( ::SocketCon ) ) == 0
cRequest := "CONNECT " + cServer + ":" + hb_ntos( nPort ) + " HTTP/1.1" + Chr( 13 ) + Chr( 10 )
IF ! Empty( cUserAgent )
cRequest += "User-agent: " + cUserAgent + Chr( 13 ) + Chr( 10 )
cRequest := ;
"CONNECT " + cServer + ":" + hb_ntos( nPort ) + " HTTP/1.1" + Chr( 13 ) + Chr( 10 ) + ;
"Proxy-Connection: Keep-Alive" + Chr( 13 ) + Chr( 10 )
IF HB_ISSTRING( cUserAgent ) .AND. ! Empty( cUserAgent )
cRequest += "User-Agent: " + cUserAgent + Chr( 13 ) + Chr( 10 )
ENDIF
IF ! Empty( cUserName )
cRequest += "Proxy-authorization: Basic " + hb_base64Encode( cUserName + ":" + cPassWord ) + Chr( 13 ) + Chr( 10 )
IF HB_ISSTRING( cUserName ) .AND. ! Empty( cUserName )
cRequest += "Proxy-Authorization: Basic " + hb_base64Encode( cUserName + ":" + hb_defaultValue( cPassword, "" ) ) + Chr( 13 ) + Chr( 10 )
ENDIF
cRequest += Chr( 13 ) + Chr( 10 )
::inetSendAll( ::SocketCon, cRequest )
cResp := ""
IF ::ReadHTTPProxyResponse( @cResp )
tmp := At( " ", cResp )
IF tmp > 0 .AND. Val( SubStr( cResp, tmp + 1 ) ) == 200
lRet := .T.
ENDIF
ENDIF
IF ! lRet
IF ::ReadHTTPProxyResponse( @cResp ) .AND. ;
( tmp := At( " ", cResp ) ) > 0 .AND. ;
Val( SubStr( cResp, tmp + 1 ) ) == 200
lRet := .T.
ELSE
::close()
ENDIF
ELSE
cResp := hb_ntos( tmp )
lRet := .F.
ENDIF
RETURN lRet
METHOD ReadHTTPProxyResponse( /* @ */ sResponse ) CLASS TIPClient
METHOD ReadHTTPProxyResponse( /* @ */ cResponse ) CLASS TIPClient
LOCAL bMoreDataToRead := .T.
LOCAL nLength, nData
LOCAL szResponse
LOCAL cBuffer
DO WHILE bMoreDataToRead
szResponse := Space( 1 )
nData := ::inetRecv( ::SocketCon, @szResponse, Len( szResponse ) )
IF nData == 0
DO WHILE .T.
cBuffer := Space( 1 )
IF ::inetRecv( ::SocketCon, @cBuffer, hb_BLen( cBuffer ) ) <= 0
RETURN .F.
ENDIF
sResponse += szResponse
nLength := Len( sResponse )
IF nLength >= 4
bMoreDataToRead := !( SubStr( sResponse, nLength - 3, 1 ) == Chr( 13 ) .AND. SubStr( sResponse, nLength - 2, 1 ) == Chr( 10 ) .AND. ;
SubStr( sResponse, nLength - 1, 1 ) == Chr( 13 ) .AND. SubStr( sResponse, nLength, 1 ) == Chr( 10 ) )
cResponse += cBuffer
IF hb_BRight( cResponse, 4 ) == e"\r\n\r\n"
EXIT
ENDIF
ENDDO
@@ -367,13 +352,14 @@ METHOD ReadHTTPProxyResponse( /* @ */ sResponse ) CLASS TIPClient
METHOD Close() CLASS TIPClient
LOCAL nRet := -1
IF ! Empty( ::SocketCon )
LOCAL nRet
IF Empty( ::SocketCon )
nRet := -1
ELSE
nRet := hb_inetClose( ::SocketCon )
IF ::lHasSSL .AND. ::lSSL
IF ::lSSL .AND. ::lHasSSL
SSL_shutdown( ::ssl )
::ssl := NIL
::ssl_ctx := NIL
@@ -409,31 +395,27 @@ METHOD Read( nLen ) CLASS TIPClient
RETURN NIL
ENDIF
IF Empty( nLen ) .OR. nLen < 0 .OR. ( ::nLength > 0 .AND. nLen > ::nLength - ::nRead )
IF ! HB_ISNUMERIC( nLen ) .OR. nLen <= 0 .OR. ( ::nLength > 0 .AND. nLen > ::nLength - ::nRead )
nLen := ::nLength - ::nRead
ENDIF
IF Empty( nLen ) .OR. nLen < 0
IF nLen <= 0
// read till end of stream
cStr1 := Space( RCV_BUF_SIZE )
cStr0 := ""
::nLastRead := ::inetRecv( ::SocketCon, @cStr1, RCV_BUF_SIZE )
DO WHILE ::nLastRead > 0
DO WHILE ( ::nLastRead := ::inetRecv( ::SocketCon, @cStr1, RCV_BUF_SIZE ) ) > 0
::nRead += ::nLastRead
cStr0 += Left( cStr1, ::nLastRead )
::nLastRead := ::inetRecv( ::SocketCon, @cStr1, RCV_BUF_SIZE )
cStr0 += hb_BLeft( cStr1, ::nLastRead )
ENDDO
::bEof := .T.
ELSE
// read an amount of data
cStr0 := Space( nLen )
IF ::lSSL
IF ::lHasSSL
/* Getting around implementing the hack used in non-SSL branch for now.
IMO the proper fix would have been done to hb_inetRecvAll(). [vszakats] */
::nLastRead := ::inetRecvAll( ::SocketCon, @cStr0, nLen )
ENDIF
IF ::lSSL .AND. ::lHasSSL
/* Getting around implementing the hack used in non-SSL branch for now.
IMO the proper fix would have been done to hb_inetRecvAll(). [vszakats] */
::nLastRead := ::inetRecvAll( ::SocketCon, @cStr0, nLen )
ELSE
// S.R. if len of file is less than RCV_BUF_SIZE hb_inetRecvAll return 0
// ::nLastRead := ::InetRecvAll( ::SocketCon, @cStr0, nLen )
@@ -444,8 +426,10 @@ METHOD Read( nLen ) CLASS TIPClient
IF ::nLastRead != nLen
::bEof := .T.
cStr0 := Left( cStr0, ::nLastRead )
// S.R. RETURN NIL
cStr0 := hb_BLeft( cStr0, ::nLastRead )
#if 0
RETURN NIL
#endif
ENDIF
IF ::nRead == ::nLength
@@ -455,49 +439,53 @@ METHOD Read( nLen ) CLASS TIPClient
RETURN cStr0
METHOD ReadToFile( cFile, nMode, nSize ) CLASS TIPClient
METHOD ReadToFile( /* @ */ cFile, nMode, nSize ) CLASS TIPClient
LOCAL nFout
LOCAL nFOut
LOCAL cData
LOCAL nSent
LOCAL nSent := 0
hb_default( @nMode, FC_NORMAL )
LOCAL lToMemory := hb_PIsByRef( 1 )
nSent := 0
hb_default( @nSize, 0 )
IF ! Empty( ::exGauge )
hb_ExecFromArray( ::exGauge, { nSent, nSize, Self } )
IF lToMemory
cFile := ""
ENDIF
IF HB_ISEVALITEM( ::exGauge )
Eval( ::exGauge, nSent, nSize, Self )
ENDIF
::nRead := 0
::nStatus := 1
DO WHILE ::inetErrorCode( ::SocketCon ) == 0 .AND. ! ::bEof
cData := ::Read( RCV_BUF_SIZE )
IF cData == NIL
IF nFout != NIL
FClose( nFout )
IF ( cData := ::Read( RCV_BUF_SIZE ) ) == NIL
IF nFOut != NIL
FClose( nFOut )
ENDIF
RETURN ::inetErrorCode( ::SocketCon ) == 0
ENDIF
IF nFout == NIL
nFout := FCreate( cFile, nMode )
IF nFout == F_ERROR
IF ! lToMemory .AND. nFOut == NIL
IF ( nFOut := FCreate( cFile, nMode ) ) == F_ERROR
::nStatus := 0
RETURN .F.
ENDIF
ENDIF
IF FWrite( nFout, cData ) != hb_BLen( cData )
FClose( nFout )
IF lToMemory
cFile += cData
ELSEIF FWrite( nFOut, cData ) != hb_BLen( cData )
FClose( nFOut )
RETURN .F.
ENDIF
nSent += Len( cData )
IF ! Empty( ::exGauge )
hb_ExecFromArray( ::exGauge, { nSent, nSize, Self } )
ENDIF
nSent += hb_BLen( cData )
IF HB_ISEVALITEM( ::exGauge )
Eval( ::exGauge, nSent, nSize, Self )
ENDIF
ENDDO
IF nSent > 0
@@ -505,50 +493,47 @@ METHOD ReadToFile( cFile, nMode, nSize ) CLASS TIPClient
ENDIF
::nStatus := 2
FClose( nFout )
IF ::inetErrorCode( ::SocketCon ) != 0
RETURN .F.
IF nFOut != NIL
FClose( nFOut )
ENDIF
RETURN .T.
RETURN ::inetErrorCode( ::SocketCon ) == 0
METHOD WriteFromFile( cFile ) CLASS TIPClient
LOCAL nFin
LOCAL nFIn
LOCAL cData
LOCAL nLen
LOCAL nSize, nSent, nBufSize
::nWrite := 0
::nStatus := 0
nFin := FOpen( cFile, FO_READ )
IF nFin == F_ERROR
IF ( nFIn := FOpen( cFile ) ) == F_ERROR
RETURN .F.
ENDIF
nSize := FSeek( nFin, 0, FS_END )
FSeek( nFin, 0 )
nSize := FSeek( nFIn, 0, FS_END )
FSeek( nFIn, 0 )
nBufSize := SND_BUF_SIZE
// allow initialization of the gauge
nSent := 0
IF ! Empty( ::exGauge )
hb_ExecFromArray( ::exGauge, { nSent, nSize, Self } )
IF HB_ISEVALITEM( ::exGauge )
Eval( ::exGauge, nSent, nSize, Self )
ENDIF
::nStatus := 1
cData := Space( nBufSize )
nLen := FRead( nFin, @cData, nBufSize )
DO WHILE nLen > 0
DO WHILE ( nLen := FRead( nFIn, @cData, nBufSize ) ) > 0
IF ::Write( @cData, nLen ) != nLen
FClose( nFin )
FClose( nFIn )
RETURN .F.
ENDIF
nSent += nLen
IF ! Empty( ::exGauge )
hb_ExecFromArray( ::exGauge, { nSent, nSize, Self } )
IF HB_ISEVALITEM( ::exGauge )
Eval( ::exGauge, nSent, nSize, Self )
ENDIF
nLen := FRead( nFin, @cData, nBufSize )
ENDDO
// it may happen that the file has length 0
@@ -557,32 +542,19 @@ METHOD WriteFromFile( cFile ) CLASS TIPClient
ENDIF
::nStatus := 2
FClose( nFin )
FClose( nFIn )
RETURN .T.
#if 0
METHOD Write( cData, nLen, lCommit ) CLASS TIPClient
/* HZ: METHOD :getOk() is not declared in TIPClient */
METHOD Data( cData ) CLASS TIPClient
::InetSendall( ::SocketCon, "DATA" + ::cCRLF )
IF ! ::GetOk()
RETURN .F.
ENDIF
::InetSendall(::SocketCon, cData + ::cCRLF + "." + ::cCRLF )
RETURN ::GetOk()
#endif
METHOD Write( cData, nLen, bCommit ) CLASS TIPClient
IF Empty( nLen )
nLen := Len( cData )
IF ! HB_ISNUMERIC( nLen ) .OR. nLen <= 0
nLen := hb_BLen( cData )
ENDIF
::nLastWrite := ::inetSendAll( ::SocketCon, cData, nLen )
IF ! Empty( bCommit ) .AND. bCommit
IF hb_defaultValue( lCommit, .F. )
::Commit()
ENDIF
@@ -594,8 +566,8 @@ METHOD inetSendAll( SocketCon, cData, nLen ) CLASS TIPClient
LOCAL nRet
IF Empty( nLen )
nLen := Len( cData )
IF ! HB_ISNUMERIC( nLen ) .OR. nLen <= 0
nLen := hb_BLen( cData )
ENDIF
IF ::lSSL
@@ -732,44 +704,42 @@ METHOD inetErrorCode( SocketCon ) CLASS TIPClient
METHOD inetErrorDesc( SocketCon ) CLASS TIPClient
LOCAL cMsg := ""
hb_default( @SocketCon, ::SocketCon )
IF ! Empty( SocketCon )
IF ::lSSL
IF ::lHasSSL
IF ::nSSLError != 0
cMsg := ERR_error_string( SSL_get_error( ::ssl, ::nSSLError ) )
ENDIF
IF ::lHasSSL .AND. ::nSSLError != 0
RETURN ERR_error_string( SSL_get_error( ::ssl, ::nSSLError ) )
ENDIF
ELSE
cMsg := hb_inetErrorDesc( SocketCon )
RETURN hb_inetErrorDesc( SocketCon )
ENDIF
ENDIF
RETURN cMsg
RETURN ""
/* BROKEN, should test number of parameters and act accordingly, see doc\inet.txt */
/* BROKEN, should test number of parameters and act accordingly, see doc/inet.txt */
METHOD inetConnect( cServer, nPort, SocketCon ) CLASS TIPClient
hb_inetConnect( cServer, nPort, SocketCon )
IF hb_inetStatus( SocketCon ) == -1 /* IMPORTANT: if internet connection is off and address is not resolved and it is SSL compliant, then RTE , must be avoided - Pritpal*/
/* IMPORTANT: if internet connection is off and address is not
resolved and it is SSL compliant, then RTE must
be avoided [pritpal] */
IF hb_inetStatus( SocketCon ) == -1
RETURN NIL
ENDIF
IF ! Empty( ::nDefaultSndBuffSize )
IF hb_defaultValue( ::nDefaultSndBuffSize, 0 ) > 0
::InetSndBufSize( SocketCon, ::nDefaultSndBuffSize )
ENDIF
IF ! Empty( ::nDefaultRcvBuffSize )
IF hb_defaultValue( ::nDefaultRcvBuffSize, 0 ) > 0
::InetRcvBufSize( SocketCon, ::nDefaultRcvBuffSize )
ENDIF
IF ::lHasSSL .AND. ::lSSL
ActivateSSL(Self)
/* TODO: Add error handling */
IF ::lSSL .AND. ::lHasSSL
__tip_SSLConnectFD( ::ssl, SocketCon )
ENDIF
IF HB_ISEVALITEM( ::bTrace )
@@ -781,7 +751,7 @@ METHOD inetConnect( cServer, nPort, SocketCon ) CLASS TIPClient
/* Methods to manage buffers */
METHOD InetRcvBufSize( SocketCon, nSizeBuff ) CLASS TIPClient
IF ! Empty( nSizeBuff )
IF HB_ISNUMERIC( nSizeBuff ) .AND. nSizeBuff > 0
hb_inetSetRcvBufSize( SocketCon, nSizeBuff )
ENDIF
@@ -789,7 +759,7 @@ METHOD InetRcvBufSize( SocketCon, nSizeBuff ) CLASS TIPClient
METHOD InetSndBufSize( SocketCon, nSizeBuff ) CLASS TIPClient
IF ! Empty( nSizeBuff )
IF HB_ISNUMERIC( nSizeBuff ) .AND. nSizeBuff > 0
hb_inetSetSndBufSize( SocketCon, nSizeBuff )
ENDIF
@@ -809,8 +779,7 @@ METHOD InetTimeOut( SocketCon, nConnTimeout ) CLASS TIPClient
/* Called from another method with list of parameters and, as last parameter, return code
of function being logged.
Example, I want to log MyFunc( a, b, c ) which returns m,
::Log( a, b, c, m )
*/
::Log( a, b, c, m ) */
METHOD Log( ... ) CLASS TIPClient
LOCAL xVar
@@ -825,18 +794,18 @@ METHOD Log( ... ) CLASS TIPClient
FOR EACH xVar IN hb_AParams()
// Preserves CRLF on result
IF xVar:__enumIndex() < PCount()
cMsg += StrTran( StrTran( AllTrim( hb_CStr( xVar ) ), Chr( 13 ), "<cr>" ), Chr( 10 ), "<lf>" )
ELSE
IF xVar:__enumIsLast()
cMsg += hb_CStr( xVar )
ELSE
cMsg += hb_StrReplace( AllTrim( hb_CStr( xVar ) ), Chr( 13 ) + Chr( 10 ), { "<cr>", "<lf>" } )
ENDIF
cMsg += iif( xVar:__enumIndex() < PCount() - 1, ", ", "" )
IF xVar:__enumIndex() == PCount() - 1
cMsg += " )" + hb_eol() + ">> "
ELSEIF xVar:__enumIndex() == PCount()
IF xVar:__enumIsLast()
cMsg += " <<" + hb_eol() + hb_eol()
ELSEIF xVar:__enumIndex() == PCount() - 1
cMsg += " )" + hb_eol() + ">> "
ELSE
cMsg += ", "
ENDIF
NEXT
@@ -847,25 +816,29 @@ METHOD Log( ... ) CLASS TIPClient
METHOD SetProxy( cProxyHost, nProxyPort, cProxyUser, cProxyPassword ) CLASS TIPClient
::cProxyHost := cProxyHost
::nProxyPort := nProxyPort
::cProxyUser := cProxyUser
::cProxyPassword := cProxyPassword
IF __clsParent( cProxyHost:classH(), "TURL" )
::cProxyHost := cProxyHost:cServer
::nProxyPort := cProxyHost:nPort
::cProxyUser := cProxyHost:cUserid
::cProxyPassword := cProxyHost:cPassword
ELSE
::cProxyHost := hb_defaultValue( cProxyHost, "" )
::nProxyPort := hb_defaultValue( nProxyPort, 0 )
::cProxyUser := hb_defaultValue( cProxyUser, "" )
::cProxyPassword := hb_defaultValue( cProxyPassword, "" )
ENDIF
RETURN Self
FUNCTION tip_SSL()
RETURN hb_IsFunction( "__HBEXTERN__HBSSL__" )
FUNCTION ActivateSSL(Self)
LOCAL SocketCon
FUNCTION __tip_SSLConnectFD( ssl, SocketCon )
Hb_Default(@SocketCon, ::SocketCon )
SSL_set_mode( ::ssl, HB_SSL_MODE_AUTO_RETRY )
SSL_set_fd( ::ssl, hb_inetFD( SocketCon ) )
SSL_connect( ::ssl )
SSL_set_mode( ssl, HB_SSL_MODE_AUTO_RETRY )
SSL_set_fd( ssl, hb_inetFD( SocketCon ) )
SSL_connect( ssl )
/* TODO: Add error handling */
RETURN .T.
RETURN .T.

35
contrib/hbtip/encb64.prg
View File

@@ -50,12 +50,12 @@
CREATE CLASS TIPEncoderBase64 FROM TIPEncoder
// Set this to .T. to enable RFC 2068 (HTTP/1.1) exception to
// RFC 2045 (MIME) base64 format. This exception consists in
// not applying CRLF after each 76 output bytes.
VAR bHttpExcept
/* Set this to .T. to enable RFC 2068 (HTTP/1.1) exception to
RFC 2045 (MIME) base64 format. This exception consists in
not applying CRLF after each 76 output bytes. */
VAR bHttpExcept INIT .F.
METHOD New() Constructor
METHOD New() CONSTRUCTOR
METHOD Encode( cData )
METHOD Decode( cData )
@@ -63,33 +63,12 @@ ENDCLASS
METHOD New() CLASS TIPEncoderBase64
::cName := "Base64"
::bHttpExcept := .F.
::cName := "base64"
RETURN Self
METHOD Encode( cData ) CLASS TIPEncoderBase64
RETURN tip_Base64Encode( cData, iif( ::bHttpExcept, NIL, 72 ), Chr( 13 ) + Chr( 10 ) )
RETURN hb_base64Encode( cData, iif( ::bHttpExcept, NIL, 76 ) )
METHOD Decode( cData ) CLASS TIPEncoderBase64
RETURN hb_base64Decode( cData )
FUNCTION tip_Base64Encode( cBinary, nLineLength, cCRLF )
LOCAL cTextIn := hb_base64Encode( cBinary )
LOCAL cText
LOCAL tmp
IF ! HB_ISNUMERIC( nLineLength )
RETURN cTextIn
ENDIF
hb_default( @cCRLF, hb_eol() )
cText := ""
FOR tmp := 1 TO Len( cTextIn ) STEP nLineLength
cText += SubStr( cTextIn, tmp, nLineLength ) + cCRLF
NEXT
RETURN cText

53
contrib/hbtip/encoder.prg
View File

@@ -58,54 +58,37 @@
#include "fileio.ch"
FUNCTION tip_GetEncoder( cModel )
LOCAL oEncoder
hb_default( @cModel, "as-is" )
cModel := Lower( cModel )
DO CASE
CASE cModel == "base64"
oEncoder := TIPEncoderBase64():New()
CASE cModel == "quoted-printable"
oEncoder := TIPEncoderQP():New()
CASE cModel == "url" .OR. cModel == "urlencoded"
oEncoder := TIPEncoderUrl():New()
CASE cModel == "7bit" .OR. cModel == "8bit"
oEncoder := TIPEncoder():New( cModel )
oEncoder:cName := cModel
OTHERWISE
oEncoder := TIPEncoder():New()
ENDCASE
RETURN oEncoder
CREATE CLASS TIPEncoder
VAR cName
METHOD New( cModel )
METHOD New( cMode )
METHOD Encode( cData )
METHOD Decode( cData )
ENDCLASS
METHOD New( cModel ) CLASS TIPEncoder
#define MODE_PASSTHROUGH "as-is"
hb_default( @cModel, "as-is" )
::cName := cModel
METHOD New( cMode ) CLASS TIPEncoder
::cName := Lower( hb_defaultValue( cMode, MODE_PASSTHROUGH ) )
RETURN Self
METHOD Encode( cData ) CLASS TIPEncoder
RETURN cData
RETURN iif( ::cName == MODE_PASSTHROUGH, cData, tip_GetEncoder( ::cName ):Encode( cData ) )
METHOD Decode( cData ) CLASS TIPEncoder
RETURN cData
RETURN iif( ::cName == MODE_PASSTHROUGH, cData, tip_GetEncoder( ::cName ):Decode( cData ) )
FUNCTION tip_GetEncoder( cMode )
SWITCH Lower( hb_defaultValue( cMode, MODE_PASSTHROUGH ) )
CASE "base64" ; RETURN TIPEncoderBase64():New()
CASE "quoted-printable" ; RETURN TIPEncoderQP():New()
CASE "url"
CASE "urlencoded" ; RETURN TIPEncoderUrl():New()
ENDSWITCH
RETURN TIPEncoder():New()

23
contrib/hbtip/encqp.prg
View File

@@ -48,14 +48,7 @@
#include "hbclass.ch"
/* TOFIX: Removed TIPEncode as parent class to make it
work from a dynamically loaded hbtip library.
'VAR cName' was the only inherited item/logic.
This should be reverted once derived classes
work fine from dynamically loaded libs. */
CREATE CLASS TIPEncoderQP
VAR cName
CREATE CLASS TIPEncoderQP FROM TIPEncoder
METHOD New() CONSTRUCTOR
METHOD Encode( cData )
@@ -86,20 +79,24 @@ FUNCTION tip_QPEncode( cData )
nLen := hb_BLen( cData )
FOR nPos := 1 TO nLen
c := hb_BSubStr( cData, nPos, 1 )
IF c == Chr( 13 )
IF c == Chr( 10 )
cString += Chr( 13 ) + Chr( 10 )
nLineLen := 0
ELSEIF hb_BCode( c ) > 126 .OR. ;
ELSEIF hb_BCode( c ) >= 127 .OR. ;
c $ '=?!"#$@[\]^`{|}~' .OR. ;
( hb_BCode( c ) < 32 .AND. !( c $ Chr( 13 ) + Chr( 10 ) + Chr( 9 ) ) ) .OR. ;
( c $ " " + Chr( 9 ) .AND. hb_BSubStr( cData, nPos + 1, 1 ) $ Chr( 13 ) + Chr( 10 ) )
IF nLineLen + 3 > 76
IF nLineLen + 3 > 75
cString += "=" + Chr( 13 ) + Chr( 10 )
nLineLen := 0
ENDIF
cString += "=" + hb_NumToHex( hb_BCode( c ), 2 )
nLineLen += 3
ELSEIF !( c == Chr( 10 ) )
ELSEIF !( c == Chr( 13 ) )
IF nLineLen + 3 > 75
cString += "=" + Chr( 13 ) + Chr( 10 )
nLineLen := 0
ENDIF
cString += c
nLineLen += 1
ENDIF
@@ -116,7 +113,7 @@ FUNCTION tip_QPDecode( cData )
/* delete soft line break. */
cData := StrTran( cData, "=" + Chr( 13 ) + Chr( 10 ) )
cData := StrTran( cData, "=" + Chr( 10 ) ) /* also delete non-standard line breaks */
cData := StrTran( cData, "=" + Chr( 10 ) ) /* also delete non-standard line breaks */
nLen := hb_BLen( cData )
FOR nPos := 1 TO nLen

16
contrib/hbtip/mail.prg
View File

@@ -56,6 +56,7 @@
*/
#include "hbclass.ch"
#include "fileio.ch"
CREATE CLASS TIPMail
@@ -746,3 +747,18 @@ FUNCTION tip_GetNameEmail( cAddress )
ENDIF
RETURN cAddress
FUNCTION __tip_FAttrToUmask( nAttr )
RETURN hb_bitOr( ;
Min( hb_bitAnd( nAttr, HB_FA_SUID ), 1 ) * 0x4000, ;
Min( hb_bitAnd( nAttr, HB_FA_SGID ), 1 ) * 0x2000, ;
Min( hb_bitAnd( nAttr, HB_FA_SVTX ), 1 ) * 0x1000, ;
Min( hb_bitAnd( nAttr, HB_FA_RUSR ), 1 ) * 0x0400, ;
Min( hb_bitAnd( nAttr, HB_FA_WUSR ), 1 ) * 0x0200, ;
Min( hb_bitAnd( nAttr, HB_FA_XUSR ), 1 ) * 0x0100, ;
Min( hb_bitAnd( nAttr, HB_FA_RGRP ), 1 ) * 0x0040, ;
Min( hb_bitAnd( nAttr, HB_FA_WGRP ), 1 ) * 0x0020, ;
Min( hb_bitAnd( nAttr, HB_FA_XGRP ), 1 ) * 0x0010, ;
Min( hb_bitAnd( nAttr, HB_FA_ROTH ), 1 ) * 0x0004, ;
Min( hb_bitAnd( nAttr, HB_FA_WOTH ), 1 ) * 0x0002, ;
Min( hb_bitAnd( nAttr, HB_FA_XOTH ), 1 ) * 0x0001 )

662
contrib/hbtip/sendmail.prg
View File

@@ -54,34 +54,34 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ;
aFiles, cUser, cPass, cPopServer, nPriority, lRead, ;
xTrace, lPopAuth, lNoAuth, nTimeOut, cReplyTo, ;
lSSL, cSMTPPass, cCharset, cEncoding, cClientHost )
/*
cServer -> Required. IP or domain name of the mail server
nPort -> Optional. Port used my email server
cFrom -> Required. Email address of the sender
xTo -> Required. Character string or array of email addresses to send the email to
xCC -> Optional. Character string or array of email adresses for CC (Carbon Copy)
xBCC -> Optional. Character string or array of email adresses for BCC (Blind Carbon Copy)
cBody -> Optional. The body message of the email as text, or the filename of the HTML message to send.
cSubject -> Optional. Subject of the sending email
aFiles -> Optional. Array of attachments to the email to send
cUser -> Required. User name for the POP3 server
cPass -> Required. Password for cUser
cPopServer -> Required. POP3 server name or address
nPriority -> Optional. Email priority: 1=High, 3=Normal (Standard), 5=Low
lRead -> Optional. If set to .T., a confirmation request is send. Standard setting is .F.
xTrace -> Optional. If set to .T., a log file is created (smtp-<n>.log). Standard setting is .F.
If a block is passed, it will be called for each log event with the message a string, no param on session close.
lPopAuth -> Optional. Do POP3 authentication before sending mail.
lNoAuth -> Optional. Disable Autentication methods
nTimeOut -> Optional. Number os ms to wait default 10000 (10s)
cReplyTo -> Optional.
lSSl -> Optional. Need SSL at connect time (TLS need this param set to False)
cSMTPPass -> Optional.
cCharset -> Optional.
cEncoding -> Optional.
cClientHost-> Optional. Domain name of the SMTP client in the format smtp.example.com OR client IP surrounded by brackets as in [200.100.100.5]
Note: This parameter is optional for backwards compatibility, but should be provided to comply with RFC 2812.
*/
/*
cServer -> Required. IP or domain name of the mail server
nPort -> Optional. Port used my email server
cFrom -> Required. Email address of the sender
xTo -> Required. Character string or array of email addresses to send the email to
xCC -> Optional. Character string or array of email addresses for CC (Carbon Copy)
xBCC -> Optional. Character string or array of email addresses for BCC (Blind Carbon Copy)
cBody -> Optional. The body message of the email as text, or the filename of the HTML message to send.
cSubject -> Optional. Subject of the sending email
aFiles -> Optional. Array of attachments to the email to send
cUser -> Required. User name for the POP3 server
cPass -> Required. Password for cUser
cPopServer -> Required. POP3 server name or address
nPriority -> Optional. Email priority: 1=High, 3=Normal (Standard), 5=Low
lRead -> Optional. If set to .T., a confirmation request is send. Standard setting is .F.
xTrace -> Optional. If set to .T., a log file is created (smtp-<n>.log). Standard setting is .F.
If a block is passed, it will be called for each log event with the message a string, no param on session close.
lPopAuth -> Optional. Do POP3 authentication before sending mail.
lNoAuth -> Optional. Disable Autentication methods
nTimeOut -> Optional. Number os ms to wait default 10000 (10s)
cReplyTo -> Optional.
lSSL -> Optional. Need SSL at connect time (TLS need this param set to False)
cSMTPPass -> Optional.
cCharset -> Optional.
cEncoding -> Optional.
cClientHost -> Optional. Domain name of the SMTP client in the format smtp.example.com OR client IP surrounded by brackets as in [200.100.100.5]
Note: This parameter is optional for backwards compatibility, but should be provided to comply with RFC 2812.
*/
LOCAL cTmp
LOCAL cTo
@@ -94,9 +94,6 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ;
LOCAL oUrl1
LOCAL lConnectPlain := .F.
LOCAL lReturn := .T.
//LOCAL lAuthLogin := .F.
//LOCAL lAuthPlain := .F.
LOCAL lAuthTLS := .F.
LOCAL lConnect := .T.
LOCAL oPop
@@ -126,25 +123,20 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ;
hb_ADel( xTo, tmp, .T. )
ENDIF
NEXT
IF Empty( xTo )
RETURN .F.
ENDIF
cTo := ""
cTmp := ""
IF Len( xTo ) > 1
FOR EACH cTo IN xTo
IF cTo:__enumIndex() != 1
cTmp += tip_GetRawEmail( AllTrim( cTo ) ) + ","
ENDIF
NEXT
cTmp := SubStr( cTmp, 1, Len( cTmp ) - 1 )
ENDIF
cTo := tip_GetRawEmail( AllTrim( xTo[ 1 ] ) )
IF Len( cTmp ) > 0
cTo += "," + cTmp
ENDIF
FOR EACH cTmp IN xTo
cTo += tip_GetRawEmail( AllTrim( cTmp ) )
IF ! cTmp:__enumIsLast()
cTo += ","
ENDIF
NEXT
ELSEIF HB_ISSTRING( xTo )
cTo := tip_GetRawEmail( AllTrim( xTo ) )
ENDIF
// CC (Carbon Copy)
IF HB_ISARRAY( xCC )
FOR tmp := Len( xCC ) TO 1 STEP -1
@@ -153,17 +145,16 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ;
ENDIF
NEXT
cCC := ""
IF Len( xCC ) > 0
FOR EACH cTmp IN xCC
cCC += tip_GetRawEmail( AllTrim( cTmp ) ) + ","
NEXT
cCC := SubStr( cCC, 1, Len( cCC ) - 1 )
ENDIF
FOR EACH cTmp IN xCC
cCC += tip_GetRawEmail( AllTrim( cTmp ) )
IF ! cTmp:__enumIsLast()
cCC += ","
ENDIF
NEXT
ELSEIF HB_ISSTRING( xCC )
cCC := tip_GetRawEmail( AllTrim( xCC ) )
ENDIF
// BCC (Blind Carbon Copy)
IF HB_ISARRAY( xBCC )
FOR tmp := Len( xBCC ) TO 1 STEP -1
@@ -172,89 +163,71 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ;
ENDIF
NEXT
cBCC := ""
IF Len( xBCC ) > 0
FOR EACH cTmp IN xBCC
cBCC += tip_GetRawEmail( AllTrim( cTmp ) ) + ","
NEXT
cBCC := SubStr( cBCC, 1, Len( cBCC ) - 1 )
ENDIF
FOR EACH cTmp IN xBCC
cBCC += tip_GetRawEmail( AllTrim( cTmp ) )
IF ! cTmp:__enumIsLast()
cBCC += ","
ENDIF
NEXT
ELSEIF HB_ISSTRING( xBCC )
cBCC := tip_GetRawEmail( AllTrim( xBCC ) )
ENDIF
cUser := StrTran( cUser, "@", "&at;" )
IF cPopServer != NIL .AND. lPopAuth
BEGIN SEQUENCE
IF HB_ISSTRING( cPopServer ) .AND. lPopAuth
BEGIN SEQUENCE WITH __BreakBlock()
oUrl1 := TUrl():New( iif( lSSL, "pop3s://", "pop://" ) + cUser + ":" + cPass + "@" + cPopServer + "/" )
oUrl1:cUserid := StrTran( cUser, "&at;", "@" )
oPop := TIPClientPOP():New( oUrl1, xTrace )
IF oPop:Open()
oPop:Close()
ELSE
lReturn := .F.
ENDIF
RECOVER
lReturn := .F.
RETURN .F.
END SEQUENCE
IF oPop:Open()
oPop:Close()
ELSE
RETURN .F.
ENDIF
ENDIF
IF ! lReturn
RETURN .F.
ENDIF
BEGIN SEQUENCE
BEGIN SEQUENCE WITH __BreakBlock()
oUrl := TUrl():New( iif( lSSL, "smtps://", "smtp://" ) + cUser + iif( Empty( cSMTPPass ), "", ":" + cSMTPPass ) + "@" + cServer )
RECOVER
lReturn := .F.
END SEQUENCE
IF ! lReturn
RETURN .F.
ENDIF
END SEQUENCE
oUrl:nPort := nPort
oUrl:cUserid := StrTran( cUser, "&at;", "@" )
oUrl:cFile := cTo + iif( Empty( cCC ), "", "," + cCC ) + iif( Empty( cBCC ), "", "," + cBCC )
BEGIN SEQUENCE
oInmail := TIPClientSMTP():New( oUrl, xTrace, NIL, cClientHost )
BEGIN SEQUENCE WITH __BreakBlock()
oInmail := TIPClientSMTP():New( oUrl, xTrace,, cClientHost )
RECOVER
lReturn := .F.
END SEQUENCE
IF ! lReturn
RETURN .F.
ENDIF
END SEQUENCE
oInmail:nConnTimeout := nTimeOut
IF ! lNoAuth
IF ! lNoAuth .AND. oInMail:OpenSecure( , lSSL )
IF oInMail:OpenSecure( NIL, lSSL)
lAuthTLS := oInMail:lTLS
lAuthTls := oInMail:lTLS
IF oInMail:lAuthLogin
IF ! oInMail:Auth( cUser, cSMTPPass )
lConnect := .F.
ELSE
lConnectPlain := .T.
ENDIF
ENDIF
IF oInMail:lAuthPlain .AND. ! lConnect
IF ! oInMail:AuthPlain( cUser, cSMTPPass )
lConnect := .F.
ENDIF
IF oInMail:lAuthLogin
IF oInMail:Auth( cUser, cSMTPPass )
lConnectPlain := .T.
ELSE
IF ! lConnectPlain
lConnect := .F.
ENDIF
lConnect := .F.
ENDIF
ELSE
ENDIF
IF oInMail:lAuthPlain .AND. ! lConnect
IF ! oInMail:AuthPlain( cUser, cSMTPPass )
lConnect := .F.
ENDIF
ELSEIF ! lConnectPlain
lConnect := .F.
ENDIF
ELSE
@@ -267,10 +240,10 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ;
oInMail:Close()
ENDIF
BEGIN SEQUENCE
oInmail := TIPClientSMTP():New( oUrl, xTrace, NIL, cClientHost )
BEGIN SEQUENCE WITH __BreakBlock()
oInmail := TIPClientSMTP():New( oUrl, xTrace,, cClientHost )
RECOVER
lReturn := .F.
RETURN .F.
END SEQUENCE
oInmail:nConnTimeout := nTimeOut
@@ -287,11 +260,10 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ;
IF oInMail:cReply == NIL
EXIT
ENDIF
IF Left( oInMail:cReply, 4 ) == "250 "
IF hb_LeftEq( oInMail:cReply, "250 " )
EXIT
ENDIF
ENDDO
ENDIF
oInMail:oUrl:cUserid := tip_GetRawEmail( cFrom )
@@ -300,355 +272,179 @@ FUNCTION hb_SendMail( cServer, nPort, cFrom, xTo, xCC, xBCC, cBody, cSubject, ;
oInMail:Commit()
oInMail:Close()
RETURN lReturn
RETURN .T.
FUNCTION hb_MailAssemble( cFrom, xTo, xCC, cBody, cSubject, ;
aFiles, nPriority, lRead, ;
cReplyTo, ;
cCharset, cEncoding )
/*
cFrom -> Required. Email address of the sender
xTo -> Required. Character string or array of email addresses to send the email to
xCC -> Optional. Character string or array of email addresses for CC (Carbon Copy)
cBody -> Optional. The body message of the email as text, or the filename of the HTML message to send.
cSubject -> Optional. Subject of the sending email
aFiles -> Optional. Array of attachments to the email to send
nPriority -> Optional. Email priority: 1=High, 3=Normal (Standard), 5=Low
lRead -> Optional. If set to .T., a confirmation request is send. Standard setting is .F.
cReplyTo -> Optional.
*/
FUNCTION hb_MailAssemble( ;
cFrom, ; /* Required. Email address of the sender */
xTo, ; /* Required. Character string or array of email addresses to send the email to */
xCC, ; /* Optional. Character string or array of email addresses for CC (Carbon Copy) */
cBody, ; /* Optional. The body message of the email as text, or the filename of the HTML message to send. */
cSubject, ; /* Optional. Subject of the sending email */
aFiles, ; /* Optional. Array of attachments to the email to send */
nPriority, ; /* Optional. Email priority: 1=High, 3=Normal (Standard), 5=Low */
lRead, ; /* Optional. If set to .T., a confirmation request is send. Standard setting is .F. */
cReplyTo, ; /* Optional. */
cCharset, ; /* Optional. */
cEncoding ) /* Optional. */
LOCAL cBodyTemp
LOCAL oMail
LOCAL oAttach
LOCAL aThisFile
LOCAL cMimeText
LOCAL cMimeType
LOCAL cFile
LOCAL cFname
LOCAL cFext
LOCAL cData
LOCAL cContentType
LOCAL nAttr
LOCAL lBodyHTML
LOCAL cCharsetCP
hb_default( @aFiles, {} )
hb_default( @nPriority, 3 )
hb_default( @lRead, .F. )
hb_default( @cReplyTo, "" )
hb_default( @cCharset, "ISO-8859-1" )
hb_default( @cEncoding, "quoted-printable" )
IF !( ( ".htm" $ Lower( cBody ) .OR. ".html" $ Lower( cBody ) ) .AND. hb_FileExists( cBody ) )
IF !( Right( cBody, 2 ) == Chr( 13 ) + Chr( 10 ) )
cBody += Chr( 13 ) + Chr( 10 )
ENDIF
IF Empty( cFrom ) .OR. ! HB_ISSTRING( cFrom )
RETURN .F.
ENDIF
IF Empty( xTo ) .OR. ( ! HB_ISSTRING( xTo ) .AND. ! HB_ISARRAY( xTo ) )
RETURN .F.
ENDIF
oMail := TIPMail():new()
hb_default( @cBody, "" )
hb_default( @cSubject, "" )
hb_default( @aFiles, {} )
nPriority := Int( hb_defaultValue( nPriority, 3 ) )
hb_default( @lRead, .F. )
hb_default( @cReplyTo, "" )
hb_default( @cCharset, "UTF-8" )
hb_default( @cEncoding, "quoted-printable" )
/* Attempt to convert to selected charset if it's supported
by Harbour (and linked to app). */
IF Upper( cCharset ) == "UTF-8"
cCharsetCP := "UTF8"
ELSEIF hb_cdpExists( Lower( cCharset ) )
cCharsetCP := hb_cdpUniID( Lower( cCharset ) )
ENDIF
SWITCH Lower( hb_FNameExt( cBody ) )
CASE ".htm"
CASE ".html"
IF hb_FileExists( cBody )
cBody := MemoRead( cBody )
lBodyHTML := .T.
EXIT
ENDIF
OTHERWISE
lBodyHTML := .F.
ENDSWITCH
cContentType := iif( lBodyHTML, "text/html", "text/plain" ) + "; charset=" + cCharset
/* add ending EOL to body, if there wasn't any */
IF !( Right( cBody, 2 ) == Chr( 13 ) + Chr( 10 ) )
cBody += Chr( 13 ) + Chr( 10 )
ENDIF
/* Convert input to the CP of the e-mail */
IF ! Empty( cCharsetCP )
xTo := s_TransCP( xTo, cCharsetCP )
xCC := s_TransCP( xCC, cCharsetCP )
cFrom := s_TransCP( cFrom, cCharsetCP )
cBody := s_TransCP( cBody, cCharsetCP )
cSubject := s_TransCP( cSubject, cCharsetCP )
ENDIF
oMail := TIPMail():New()
oMail:SetEncoder( cEncoding )
oMail:SetCharset( cCharset )
IF Empty( aFiles )
oMail:hHeaders[ "Content-Type" ] := cContentType
oMail:SetBody( cBody )
ELSE
oAttach := TIPMail():New()
oAttach:SetEncoder( cEncoding )
oAttach:SetCharset( cCharset )
oAttach:hHeaders[ "Content-Type" ] := cContentType
oAttach:SetBody( cBody )
oMail:Attach( oAttach )
FOR EACH aThisFile IN aFiles
cMimeType := NIL
nAttr := 0
IF HB_ISSTRING( aThisFile )
cFile := aThisFile
cData := hb_MemoRead( cFile )
hb_FGetAttr( cFile, @nAttr )
ELSEIF HB_ISARRAY( aThisFile ) .AND. Len( aThisFile ) >= 2
cFile := aThisFile[ 1 ]
IF HB_ISSTRING( aThisFile[ 2 ] )
cData := aThisFile[ 2 ]
hb_default( @cFile, "unnamed" )
ELSEIF HB_ISSTRING( cFile )
cData := hb_MemoRead( cFile )
hb_FGetAttr( cFile, @nAttr )
ELSE
LOOP /* No filename and no content. */
ENDIF
IF Len( aThisFile ) >= 3 .AND. HB_ISSTRING( aThisFile[ 3 ] )
cMimeType := aThisFile[ 3 ]
ENDIF
ELSE
LOOP
ENDIF
IF cMimeType == NIL
cMimeType := tip_FileNameMimeType( cFile, "application/octet-stream" )
ENDIF
cFile := s_TransCP( cFile, cCharsetCP )
oAttach := TIPMail():New()
oAttach:SetCharset( cCharset )
oAttach:SetEncoder( iif( hb_LeftEq( cMimeType, "text/" ), cEncoding, "base64" ) )
IF cMimeType == "text/html"
cMimeType += "; charset=" + cCharset
IF !( Right( cData, 2 ) == Chr( 13 ) + Chr( 10 ) )
cData += Chr( 13 ) + Chr( 10 )
ENDIF
ENDIF
// Some e-mail clients use Content-Type to check for filename
cMimeType += "; name=" + '"' + hb_FNameNameExt( cFile ) + '"'
IF ( nAttr := __tip_FAttrToUmask( nAttr ) ) != 0
cMimeType += "; x-unix-mode=" + '"' + hb_NumToHex( nAttr, 4 ) + '"'
ENDIF
oAttach:hHeaders[ "Content-Type" ] := cMimeType
// Usually, original filename is set here
oAttach:hHeaders[ "Content-Disposition" ] := "attachment; filename=" + '"' + hb_FNameNameExt( cFile ) + '"'
oAttach:SetBody( cData )
oMail:Attach( oAttach )
NEXT
ENDIF
oMail:SetHeader( cSubject, cFrom, xTo, xCC )
oMail:hHeaders[ "Date" ] := tip_TimeStamp()
IF ! Empty( cReplyTo )
oMail:hHeaders[ "Reply-to" ] := cReplyTo
ENDIF
IF ! Empty( aFiles )
oAttach := TIPMail():new()
oAttach:SetEncoder( cEncoding )
oAttach:SetCharset( cCharset )
IF ( ".htm" $ Lower( cBody ) .OR. ".html" $ Lower( cBody ) ) .AND. hb_FileExists( cBody )
cMimeText := "text/html; charset=" + cCharset
oAttach:hHeaders[ "Content-Type" ] := cMimeText
cBodyTemp := cBody
cBody := MemoRead( cBodyTemp ) + Chr( 13 ) + Chr( 10 )
ELSE
oAttach:hHeaders[ "Content-Type" ] := "text/plain; charset=" + cCharset
ENDIF
oAttach:SetBody( cBody )
oMail:Attach( oAttach )
ELSE
IF ( ".htm" $ Lower( cBody ) .OR. ".html" $ Lower( cBody ) ) .AND. hb_FileExists( cBody )
cMimeText := "text/html ; charset=" + cCharset
oMail:hHeaders[ "Content-Type" ] := cMimeText
cBodyTemp := cBody
cBody := MemoRead( cBodyTemp ) + Chr( 13 ) + Chr( 10 )
ELSE
oMail:hHeaders[ "Content-Type" ] := "text/plain; charset=" + cCharset
ENDIF
oMail:SetBody( cBody )
ENDIF
FOR EACH aThisFile IN aFiles
IF HB_ISSTRING( aThisFile )
cFile := aThisFile
cData := hb_MemoRead( cFile )
ELSEIF HB_ISARRAY( aThisFile ) .AND. Len( aThisFile ) >= 2
cFile := aThisFile[ 1 ]
IF HB_ISSTRING( aThisFile[ 2 ] )
cData := aThisFile[ 2 ]
hb_default( @cFile, "unnamed" )
ELSE
IF ! HB_ISSTRING( cFile )
LOOP /* No filename and no content. */
ELSE
cData := hb_MemoRead( cFile )
ENDIF
ENDIF
ELSE
LOOP
ENDIF
cData += Chr( 13 ) + Chr( 10 )
oAttach := TIPMail():New()
oAttach:SetCharset( cCharset )
hb_FNameSplit( cFile,, @cFname, @cFext )
cFile := Lower( cFile )
IF ( cFile LIKE ".+\.(vbd|asn|asz|asd|pqi|tsp|exe|sml|ofml)" ) .OR. ;
( cFile LIKE ".+\.(pfr|frl|spl|gz||stk|ips|ptlk|hqx|mbd)" ) .OR. ;
( cFile LIKE ".+\.(mfp|pot|pps|ppt|ppz|doc|n2p|bin|class)" ) .OR. ;
( cFile LIKE ".+\.(lha|lzh|lzx|dbf|cdx|dbt|fpt|ntx|oda)" ) .OR. ;
( cFile LIKE ".+\.(axs|zpa|pdf|ai|eps|ps|shw|qrt|rtc|rtf)" ) .OR. ;
( cFile LIKE ".+\.(smp|dst|talk|tbk|vmd|vmf|wri|wid|rrf)" ) .OR. ;
( cFile LIKE ".+\.(wis|ins|tmv|arj|asp|aabaam|aas|bcpio)" ) .OR. ;
( cFile LIKE ".+\.(vcd|chat|cnc|coda|page|z|con|cpio|pqf)" ) .OR. ;
( cFile LIKE ".+\.(csh|cu|csm|dcr|dir|dxr|swa|dvi|evy|ebk)" ) .OR. ;
( cFile LIKE ".+\.(gtar|hdf|map|phtml|php3|ica|ipx|ips|js)" ) .OR. ;
( cFile LIKE ".+\.(latex|bin|mif|mpl|mpire|adr|wlt|nc|cdf)" ) .OR. ;
( cFile LIKE ".+\.(npx|nsc|pgp|css|sh||shar|swf|spr|sprite)" ) .OR. ;
( cFile LIKE ".+\.(sit|sca|sv4cpio|sv4crc|tar|tcl|tex)" ) .OR. ;
( cFile LIKE ".+\.(texinfo|texi|tlk|t|tr|roff|man|mems)" ) .OR. ;
( cFile LIKE ".+\.(alt|che|ustar|src|xls|xlt|zip|au|snd)" ) .OR. ;
( cFile LIKE ".+\.(es|gsm|gsd|rmf|tsi|vox|wtx|aif|aiff)" ) .OR. ;
( cFile LIKE ".+\.(aifc|cht|dus|mid|midi|mp3|mp2|m3u|ram)" ) .OR. ;
( cFile LIKE ".+\.(ra|rpm|stream|rmf|vqf|vql|vqe|wav|wtx)" ) .OR. ;
( cFile LIKE ".+\.(mol|pdb|dwf|ivr|cod|cpi|fif|gif|ief)" ) .OR. ;
( cFile LIKE ".+\.(jpeg|jpg|jpe|rip|svh|tiff|tif|mcf|svf)" ) .OR. ;
( cFile LIKE ".+\.(dwg|dxf|wi|ras|etf|fpx|fh5|fh4|fhc|dsf)" ) .OR. ;
( cFile LIKE ".+\.(pnm|pbm|pgm|ppm|rgb|xbm|xpm|xwd|dig)" ) .OR. ;
( cFile LIKE ".+\.(push|wan|waf||afl|mpeg|mpg|mpe|qt|mov)" ) .OR. ;
( cFile LIKE ".+\.(viv|vivo|asf|asx|avi|movie|vgm|vgx)" ) .OR. ;
( cFile LIKE ".+\.(xdr|vgp|vts|vtts|3dmf|3dm|qd3d|qd3)" ) .OR. ;
( cFile LIKE ".+\.(svr|wrl|wrz|vrt|xml)" ) .OR. Empty( cFExt )
oAttach:SetEncoder( "base64" )
ELSE
oAttach:SetEncoder( cEncoding )
ENDIF
cMimeText := hb_SetMimeType( cFile, cFname, cFext )
// Some EMAIL readers use Content-Type to check for filename
IF ".html" $ Lower( cFext ) .OR. ".htm" $ Lower( cFext )
cMimeText += "; charset=" + cCharset
ENDIF
oAttach:hHeaders[ "Content-Type" ] := cMimeText
// But usually, original filename is set here
oAttach:hHeaders[ "Content-Disposition" ] := "attachment; filename=" + '"' + cFname + cFext + '"'
oAttach:SetBody( cData )
oMail:Attach( oAttach )
NEXT
IF lRead
oMail:hHeaders[ "Disposition-Notification-To" ] := tip_GetRawEmail( cFrom )
ENDIF
IF nPriority != 3
oMail:hHeaders[ "X-Priority" ] := Str( nPriority, 1 )
oMail:hHeaders[ "X-Priority" ] := hb_ntos( nPriority )
ENDIF
RETURN oMail:ToString()
FUNCTION hb_SetMimeType( cFile, cFname, cFext )
STATIC FUNCTION s_TransCP( xData, cCP )
cFile := Lower( cFile )
LOCAL tmp
DO CASE
CASE ( cFile LIKE ".+\.vbd" ); RETURN "application/activexdocument; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(asn|asz|asd)" ); RETURN "application/astound; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.pqi" ); RETURN "application/cprplayer; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.tsp" ); RETURN "application/dsptype; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.exe" ); RETURN "application/exe; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(sml|ofml)" ); RETURN "application/fml; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.pfr" ); RETURN "application/font-tdpfr; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.frl" ); RETURN "application/freeloader; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.spl" ); RETURN "application/futuresplash; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.gz" ); RETURN "application/gzip; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.stk" ); RETURN "application/hstu; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.ips" ); RETURN "application/ips; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.ptlk" ); RETURN "application/listenup; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.hqx" ); RETURN "application/mac-binhex40; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.mbd" ); RETURN "application/mbedlet; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.mfp" ); RETURN "application/mirage; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(pot|pps|ppt|ppz)" ); RETURN "application/mspowerpoint; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.doc" ); RETURN "application/msword; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.n2p" ); RETURN "application/n2p; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(bin|class|lha|lzh|lzx|dbf)" ); RETURN "application/octet-stream; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.oda" ); RETURN "application/oda; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.axs" ); RETURN "application/olescript; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.zpa" ); RETURN "application/pcphoto; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.pdf" ); RETURN "application/pdf; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(ai|eps|ps)" ); RETURN "application/postscript; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.shw" ); RETURN "application/presentations; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.qrt" ); RETURN "application/quest; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.rtc" ); RETURN "application/rtc; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.rtf" ); RETURN "application/rtf; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.smp" ); RETURN "application/studiom; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.dst" ); RETURN "application/tajima; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.talk" ); RETURN "application/talker; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.tbk" ); RETURN "application/toolbook; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.vmd" ); RETURN "application/vocaltec-media-desc; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.vmf" ); RETURN "application/vocaltec-media-file; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.wri" ); RETURN "application/write; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.wid" ); RETURN "application/x-DemoShield; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.rrf" ); RETURN "application/x-InstallFromTheWeb; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.wis" ); RETURN "application/x-InstallShield; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.ins" ); RETURN "application/x-NET-Install; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.tmv" ); RETURN "application/x-Parable-Thing; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.arj" ); RETURN "application/x-arj; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.asp" ); RETURN "application/x-asap; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.aab" ); RETURN "application/x-authorware-bin; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(aam|aas)" ); RETURN "application/x-authorware-map; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.bcpio" ); RETURN "application/x-bcpio; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.vcd" ); RETURN "application/x-cdlink; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.chat" ); RETURN "application/x-chat; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.cnc" ); RETURN "application/x-cnc; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(coda|page)" ); RETURN "application/x-coda; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.z" ); RETURN "application/x-compress; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.con" ); RETURN "application/x-connector; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.cpio" ); RETURN "application/x-cpio; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.pqf" ); RETURN "application/x-cprplayer; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.csh" ); RETURN "application/x-csh; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(cu|csm)" ); RETURN "application/x-cu-seeme; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(dcr|dir|dxr|swa)" ); RETURN "application/x-director; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.dvi" ); RETURN "application/x-dvi; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.evy" ); RETURN "application/x-envoy; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.ebk" ); RETURN "application/x-expandedbook; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.gtar" ); RETURN "application/x-gtar; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.hdf" ); RETURN "application/x-hdf; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.map" ); RETURN "application/x-httpd-imap; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.phtml" ); RETURN "application/x-httpd-php; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.php3" ); RETURN "application/x-httpd-php3; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.ica" ); RETURN "application/x-ica; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.ipx" ); RETURN "application/x-ipix; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.ips" ); RETURN "application/x-ipscript; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.js" ); RETURN "application/x-javascript; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.latex" ); RETURN "application/x-latex; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.bin" ); RETURN "application/x-macbinary; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.mif" ); RETURN "application/x-mif; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(mpl|mpire)" ); RETURN "application/x-mpire; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.adr" ); RETURN "application/x-msaddr; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.wlt" ); RETURN "application/x-mswallet; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(nc|cdf)" ); RETURN "application/x-netcdf; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.npx" ); RETURN "application/x-netfpx; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.nsc" ); RETURN "application/x-nschat; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.pgp" ); RETURN "application/x-pgp-plugin; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.css" ); RETURN "application/x-pointplus; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.sh" ); RETURN "application/x-sh; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.shar" ); RETURN "application/x-shar; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.swf" ); RETURN "application/x-shockwave-flash; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.spr" ); RETURN "application/x-sprite; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.sprite" ); RETURN "application/x-sprite; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.sit" ); RETURN "application/x-stuffit; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.sca" ); RETURN "application/x-supercard; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.sv4cpio" ); RETURN "application/x-sv4cpio; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.sv4crc" ); RETURN "application/x-sv4crc; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.tar" ); RETURN "application/x-tar; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.tcl" ); RETURN "application/x-tcl; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.tex" ); RETURN "application/x-tex; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(texinfo|texi)" ); RETURN "application/x-texinfo; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.tlk" ); RETURN "application/x-tlk; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(t|tr|roff)" ); RETURN "application/x-troff; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.man" ); RETURN "application/x-troff-man; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.me" ); RETURN "application/x-troff-me; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.ms" ); RETURN "application/x-troff-ms; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.alt" ); RETURN "application/x-up-alert; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.che" ); RETURN "application/x-up-cacheop; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.ustar" ); RETURN "application/x-ustar; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.src" ); RETURN "application/x-wais-source; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.xls" ); RETURN "application/xls; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.xlt" ); RETURN "application/xlt; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.zip" ); RETURN "application/zip; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(au|snd)" ); RETURN "audio/basic; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.es" ); RETURN "audio/echospeech; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(gsm|gsd)" ); RETURN "audio/gsm; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.rmf" ); RETURN "audio/rmf; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.tsi" ); RETURN "audio/tsplayer; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.vox" ); RETURN "audio/voxware; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.wtx" ); RETURN "audio/wtx; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(aif|aiff|aifc)" ); RETURN "audio/x-aiff; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(cht|dus)" ); RETURN "audio/x-dspeech; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(mid|midi)" ); RETURN "audio/x-midi; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.mp3" ); RETURN "audio/x-mpeg; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.mp2" ); RETURN "audio/x-mpeg; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.m3u" ); RETURN "audio/x-mpegurl; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(ram|ra)" ); RETURN "audio/x-pn-realaudio; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.rpm" ); RETURN "audio/x-pn-realaudio-plugin; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.stream" ); RETURN "audio/x-qt-stream; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.rmf" ); RETURN "audio/x-rmf; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(vqf|vql)" ); RETURN "audio/x-twinvq; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.vqe" ); RETURN "audio/x-twinvq-plugin; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.wav" ); RETURN "audio/x-wav; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.wtx" ); RETURN "audio/x-wtx; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.mol" ); RETURN "chemical/x-mdl-molfile; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.pdb" ); RETURN "chemical/x-pdb; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.dwf" ); RETURN "drawing/x-dwf; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.ivr" ); RETURN "i-world/i-vrml; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.cod" ); RETURN "image/cis-cod; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.cpi" ); RETURN "image/cpi; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.fif" ); RETURN "image/fif; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.gif" ); RETURN "image/gif; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.ief" ); RETURN "image/ief; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(jpeg|jpg|jpe)" ); RETURN "image/jpeg; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.rip" ); RETURN "image/rip; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.svh" ); RETURN "image/svh; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(tiff|tif)" ); RETURN "image/tiff; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.mcf" ); RETURN "image/vasa; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(svf|dwg|dxf)" ); RETURN "image/vnd; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.wi" ); RETURN "image/wavelet; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.ras" ); RETURN "image/x-cmu-raster; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.etf" ); RETURN "image/x-etf; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.fpx" ); RETURN "image/x-fpx; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(fh5|fh4|fhc)" ); RETURN "image/x-freehand; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.dsf" ); RETURN "image/x-mgx-dsf; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.pnm" ); RETURN "image/x-portable-anymap; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.pbm" ); RETURN "image/x-portable-bitmap; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.pgm" ); RETURN "image/x-portable-graymap; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.ppm" ); RETURN "image/x-portable-pixmap; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.rgb" ); RETURN "image/x-rgb; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.xbm" ); RETURN "image/x-xbitmap; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.xpm" ); RETURN "image/x-xpixmap; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.xwd" ); RETURN "image/x-xwindowdump; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.dig" ); RETURN "multipart/mixed; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.push" ); RETURN "multipart/x-mixed-replace; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(wan|waf)" ); RETURN "plugin/wanimate; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.ccs" ); RETURN "text/ccs; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(htm|html)" ); RETURN "text/html; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.pgr" ); RETURN "text/parsnegar-document; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.xml" ); RETURN "text/xml; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.txt" ); RETURN "text/plain; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.rtx" ); RETURN "text/richtext; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.tsv" ); RETURN "text/tab-separated-values; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.hdml" ); RETURN "text/x-hdml; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.etx" ); RETURN "text/x-setext; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(talk|spc)" ); RETURN "text/x-speech; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.afl" ); RETURN "video/animaflex; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(mpeg|mpg|mpe)" ); RETURN "video/mpeg; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(qt|mov)" ); RETURN "video/quicktime; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(viv|vivo)" ); RETURN "video/vnd.vivo; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(asf|asx)" ); RETURN "video/x-ms-asf; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.avi" ); RETURN "video/x-msvideo; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.movie" ); RETURN "video/x-sgi-movie; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(vgm|vgx|xdr)" ); RETURN "video/x-videogram; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.vgp" ); RETURN "video/x-videogram-plugin; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.vts" ); RETURN "workbook/formulaone; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.vtts" ); RETURN "workbook/formulaone; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(3dmf|3dm|qd3d|qd3)" ); RETURN "x-world/x-3dmf; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.svr" ); RETURN "x-world/x-svr; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.(wrl|wrz)" ); RETURN "x-world/x-vrml; name=" + cFname + cFext
CASE ( cFile LIKE ".+\.vrt" ); RETURN "x-world/x-vrt; name=" + cFname + cFext
ENDCASE
IF ! Empty( cCP )
IF HB_ISSTRING( xData )
RETURN hb_Translate( xData,, cCP )
ELSEIF HB_ISARRAY( xData )
FOR EACH tmp IN xData
tmp := hb_Translate( tmp,, cCP )
NEXT
ENDIF
ENDIF
RETURN "text/plain; name=" + cFname + cFext
RETURN xData

13
doc/xhb-diff.txt
View File

@@ -551,14 +551,14 @@ generate runtime error
Error BASE/1002 Alias does not exist: TABLE
for the second QOUT() call. It means that it correctly recognized scope
of both variables and also bound alias TABLE with field F though it was
declared two lines below codeblock initialization.
declared one line below codeblock initialization.
In fact Clipper probably does not make two passes but parsing declarations
which have to be at the beginning of function or module it stores names of
variables which should be initialized with the initialization expressions.
Then when all declarations are processed for each line with declared and
initialized variables it generates code which pushes on VM stack results
of initialization expressions and then code which pops it initializing
of initialization expressions and then code which pops them initializing
variables. As result in Clipper this code cannot work:
local x := 10, y := x + 2
because Clipper generate PCODE like:
@@ -602,13 +602,14 @@ initialization expressions but then it generates slightly different code
initializing variables one by one without line groping like in Clipper.
Please also note that in Clipper PRIVATE and PUBLIC declarations are
executable statements so they are not used used as declarations by
executable statements so they are not used as declarations by
Clipper compiler even if -a compiler switch is used. So when we talk
about initialization then it means that we are talking about LOCAL
variables. STATIC variables are initialized in different way at
application startup so cannot use local variables though due to but
in Clipper in some cases compiler can accept local variables and then
it may cause VM crash or runtime error, i.e. this code:
application startup so cannot use local variables as initializers though
due to bug in Clipper in some cases compiler can accept local variables
in such context and then it may cause VM crash or error at runtime,
i.e. this code:
proc main()
local n