From 3caad66c4b0f85380c7f587016b52e8c849a8140 Mon Sep 17 00:00:00 2001 From: geby Date: Tue, 13 Mar 2012 14:46:54 +0000 Subject: [PATCH] Bugfixes in OpenSSL, enhanced OpenSSL support, enhanced binary MIME (all by Petr Fejfar) git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@147 7c85be65-684b-0410-a082-b2ed4fbef004 --- blcksock.pas | 27 ++++- ftpsend.pas | 3 + mimemess.pas | 33 ++++++- mimepart.pas | 141 +++++++++++++++++++++++++- smtpsend.pas | 1 - ssl_cryptlib.pas | 14 ++- ssl_openssl.pas | 123 ++++++++++++++++++----- ssl_openssl_lib.pas | 72 +++++++++++++- synacode.pas | 5 +- synamisc.pas | 2 + synautil.pas | 236 +++++++++++++++++++++++++++++++++++++++++++- 11 files changed, 600 insertions(+), 57 deletions(-) diff --git a/blcksock.pas b/blcksock.pas index 6fdcd26..38d300d 100644 --- a/blcksock.pas +++ b/blcksock.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 009.008.004 | +| Project : Ararat Synapse | 009.008.005 | |==============================================================================| | Content: Library base | |==============================================================================| -| Copyright (c)1999-2011, Lukas Gebauer | +| Copyright (c)1999-2012, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)1999-2011. | +| Portions created by Lukas Gebauer are Copyright (c)1999-2012. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -81,6 +81,8 @@ Core with implementation basic socket classes. {$Q-} {$H+} {$M+} +{$TYPEDADDRESS OFF} + //old Delphi does not have MSWINDOWS define. {$IFDEF WIN32} @@ -1297,6 +1299,9 @@ type {:Return subject of remote SSL peer.} function GetPeerSubject: string; virtual; + {:Return Serial number if remote X509 certificate.} + function GetPeerSerialNo: integer; virtual; + {:Return issuer certificate of remote SSL peer.} function GetPeerIssuer: string; virtual; @@ -1304,6 +1309,10 @@ type if certificate is generated for remote side IP name.} function GetPeerName: string; virtual; + {:Returns has of peer name from remote side certificate. This is good + for fast remote side authentication.} + function GetPeerNameHash: cardinal; virtual; + {:Return fingerprint of remote SSL peer.} function GetPeerFingerprint: string; virtual; @@ -2682,7 +2691,7 @@ end; function TBlockSocket.ResolveIPToName(IP: string): string; begin - if not IsIP(IP) or not IsIp6(IP) then + if not IsIP(IP) and not IsIp6(IP) then IP := ResolveName(IP); Result := synsock.ResolveIPToName(IP, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType); end; @@ -4224,11 +4233,21 @@ begin Result := ''; end; +function TCustomSSL.GetPeerSerialNo: integer; +begin + Result := -1; +end; + function TCustomSSL.GetPeerName: string; begin Result := ''; end; +function TCustomSSL.GetPeerNameHash: cardinal; +begin + Result := 0; +end; + function TCustomSSL.GetPeerIssuer: string; begin Result := ''; diff --git a/ftpsend.pas b/ftpsend.pas index 1849f1a..0d36835 100644 --- a/ftpsend.pas +++ b/ftpsend.pas @@ -52,6 +52,9 @@ Used RFC: RFC-959, RFC-2228, RFC-2428 {$MODE DELPHI} {$ENDIF} {$H+} +{$TYPEINFO ON}// Borland changed defualt Visibility from Public to Published + // and it requires RTTI to be generated $M+ +{$M+} {$IFDEF UNICODE} {$WARN IMPLICIT_STRING_CAST OFF} diff --git a/mimemess.pas b/mimemess.pas index 261c942..0ad814d 100644 --- a/mimemess.pas +++ b/mimemess.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 002.005.002 | +| Project : Ararat Synapse | 002.006.000 | |==============================================================================| | Content: MIME message object | |==============================================================================| -| Copyright (c)1999-2006, Lukas Gebauer | +| Copyright (c)1999-2012, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,8 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2006. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2012. | +| Portions created by Petr Fejfar are Copyright (c)2011-2012. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -50,6 +51,7 @@ Classes for easy handling with e-mail message. {$MODE DELPHI} {$ENDIF} {$H+} +{$M+} unit mimemess; @@ -269,6 +271,20 @@ type {:Decode message from @link(Lines) to @link(MessagePart). Massage headers are parsed into @link(Header) object.} procedure DecodeMessage; + + {pf} + {: HTTP message is received by @link(THTTPSend) component in two parts: + headers are stored in @link(THTTPSend.Headers) and a body in memory stream + @link(THTTPSend.Document). + + On the top of it, HTTP connections are always 8-bit, hence data are + transferred in native format i.e. no transfer encoding is applied. + + This method operates the similiar way and produces the same + result as @link(DecodeMessage). + } + procedure DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream); + {/pf} published {:@link(TMimePart) object with decoded MIME message. This object can handle any number of nested @link(TMimePart) objects itself. It is used for handle @@ -821,4 +837,15 @@ begin FMessagePart.DecomposeParts; end; +{pf} +procedure TMimeMess.DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream); +begin + FHeader.Clear; + FLines.Clear; + FLines.Assign(AHeader); + FHeader.DecodeHeaders(FLines); + FMessagePart.DecomposePartsBinary(AHeader,PANSIChar(AData.Memory),PANSIChar(AData.Memory)+AData.Size); +end; +{/pf} + end. diff --git a/mimepart.pas b/mimepart.pas index 93e0b91..a637e67 100644 --- a/mimepart.pas +++ b/mimepart.pas @@ -1,10 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 002.008.000 | +| Project : Ararat Synapse | 002.009.000 | |==============================================================================| | Content: MIME support procedures and functions | |==============================================================================| -| Copyright (c)1999-2008, Lukas Gebauer | -| All rights reserved. | +| Copyright (c)1999-200812 | | | | Redistribution and use in source and binary forms, with or without | | modification, are permitted provided that the following conditions are met: | @@ -33,7 +32,8 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2008. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2012. | +| Portions created by Petr Fejfar are Copyright (c)2011-2012. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -54,6 +54,7 @@ Used RFC: RFC-2045 {$H+} {$Q-} {$R-} +{$M+} {$IFDEF UNICODE} {$WARN IMPLICIT_STRING_CAST OFF} @@ -137,6 +138,7 @@ type FAttachInside: boolean; FConvertCharset: Boolean; FForcedHTMLConvert: Boolean; + FBinaryDecomposer: boolean; procedure SetPrimary(Value: string); procedure SetEncoding(Value: string); procedure SetCharset(Value: string); @@ -204,6 +206,20 @@ type method @link(GetSubPart)).} procedure DecomposeParts; + {pf} + {: HTTP message is received by @link(THTTPSend) component in two parts: + headers are stored in @link(THTTPSend.Headers) and a body in memory stream + @link(THTTPSend.Document). + + On the top of it, HTTP connections are always 8-bit, hence data are + transferred in native format i.e. no transfer encoding is applied. + + This method operates the similiar way and produces the same + result as @link(DecomposeParts). + } + procedure DecomposePartsBinary(AHeader:TStrings; AStx,AEtx:PANSIChar); + {/pf} + {:This part and all subparts is composed into one MIME message stored in @link(Lines) property.} procedure ComposeParts; @@ -535,6 +551,7 @@ var end; begin + FBinaryDecomposer := false; x := 0; Clear; //extract headers @@ -624,6 +641,95 @@ begin end; end; +procedure TMIMEPart.DecomposePartsBinary(AHeader:TStrings; AStx,AEtx:PANSIChar); +var + x: integer; + s: ANSIString; + Mime: TMimePart; + BOP: PANSIChar; // Beginning of Part + EOP: PANSIChar; // End of Part + + function ___HasUUCode(ALines:TStrings): boolean; + var + x: integer; + begin + Result := FALSE; + for x:=0 to ALines.Count-1 do + if IsUUcode(ALInes[x]) then + begin + Result := TRUE; + exit; + end; + end; + +begin + FBinaryDecomposer := true; + Clear; + // Parse passed headers (THTTPSend returns HTTP headers and body separately) + x := 0; + while x CRYPT_SESSION(CRYPT_SESSION_NONE) then -// cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0); //no-op + if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then + cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0); DeInit; FReadBuffer := ''; Result := True; @@ -478,8 +478,6 @@ begin end; function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; -var - l: integer; begin FLastError := 0; FLastErrorDesc := ''; diff --git a/ssl_openssl.pas b/ssl_openssl.pas index 91123df..7a2678d 100644 --- a/ssl_openssl.pas +++ b/ssl_openssl.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.001.001 | +| Project : Ararat Synapse | 001.002.000 | |==============================================================================| | Content: SSL support by OpenSSL | |==============================================================================| @@ -33,7 +33,8 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2005-2008. | +| Portions created by Lukas Gebauer are Copyright (c)2005-2012. | +| Portions created by Petr Fejfar are Copyright (c)2011-2012. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -139,10 +140,14 @@ type {:See @inherited} function GetPeerSubject: string; override; {:See @inherited} + function GetPeerSerialNo: integer; override; {pf} + {:See @inherited} function GetPeerIssuer: string; override; {:See @inherited} function GetPeerName: string; override; {:See @inherited} + function GetPeerNameHash: cardinal; override; {pf} + {:See @inherited} function GetPeerFingerprint: string; override; {:See @inherited} function GetCertInfo: string; override; @@ -331,10 +336,18 @@ begin cert := nil; pkey := nil; ca := nil; - if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then - if SSLCTXusecertificate(Fctx, cert) > 0 then - if SSLCTXusePrivateKey(Fctx, pkey) > 0 then - Result := True; + try {pf} + if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then + if SSLCTXusecertificate(Fctx, cert) > 0 then + if SSLCTXusePrivateKey(Fctx, pkey) > 0 then + Result := True; + {pf} + finally + EvpPkeyFree(pkey); + X509free(cert); + SkX509PopFree(ca,_X509Free); // for ca=nil a new STACK was allocated... + end; + {/pf} finally PKCS12free(p12); end; @@ -622,8 +635,11 @@ begin err := SslGetError(FSsl, Result); until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); if err = SSL_ERROR_ZERO_RETURN then - Result := 0; - if (err <> 0) then + Result := 0 + {pf}// Verze 1.1.0 byla s else tak jak to ted mam, + // ve verzi 1.1.1 bylo ELSE zruseno, ale pak je SSL_ERROR_ZERO_RETURN + // propagovano jako Chyba. + {pf} else {/pf} if (err <> 0) then FLastError := err; end; @@ -669,6 +685,31 @@ begin X509Free(cert); end; + +function TSSLOpenSSL.GetPeerSerialNo: integer; {pf} +var + cert: PX509; + SN: PASN1_INTEGER; +begin + if not assigned(FSsl) then + begin + Result := -1; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + try + if not assigned(cert) then + begin + Result := -1; + Exit; + end; + SN := X509GetSerialNumber(cert); + Result := Asn1IntegerGet(SN); + finally + X509Free(cert); + end; +end; + function TSSLOpenSSL.GetPeerName: string; var s: ansistring; @@ -678,6 +719,28 @@ begin Result := Trim(SeparateLeft(s, '/')); end; +function TSSLOpenSSL.GetPeerNameHash: cardinal; {pf} +var + cert: PX509; +begin + if not assigned(FSsl) then + begin + Result := 0; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + try + if not assigned(cert) then + begin + Result := 0; + Exit; + end; + Result := X509NameHash(X509GetSubjectName(cert)); + finally + X509Free(cert); + end; +end; + function TSSLOpenSSL.GetPeerIssuer: string; var cert: PX509; @@ -760,28 +823,34 @@ begin Result := ''; Exit; end; - b := BioNew(BioSMem); - try - X509Print(b, cert); - x := bioctrlpending(b); -{$IFDEF CIL} - sb := StringBuilder.Create(x); - y := bioread(b, sb, x); - if y > 0 then - begin - sb.Length := y; - s := sb.ToString; + try {pf} + b := BioNew(BioSMem); + try + X509Print(b, cert); + x := bioctrlpending(b); + {$IFDEF CIL} + sb := StringBuilder.Create(x); + y := bioread(b, sb, x); + if y > 0 then + begin + sb.Length := y; + s := sb.ToString; + end; + {$ELSE} + setlength(s,x); + y := bioread(b,s,x); + if y > 0 then + setlength(s, y); + {$ENDIF} + Result := ReplaceString(s, LF, CRLF); + finally + BioFreeAll(b); end; -{$ELSE} - setlength(s,x); - y := bioread(b,s,x); - if y > 0 then - setlength(s, y); -{$ENDIF} - Result := ReplaceString(s, LF, CRLF); + {pf} finally - BioFreeAll(b); + X509Free(cert); end; + {/pf} end; function TSSLOpenSSL.GetCipherName: string; diff --git a/ssl_openssl_lib.pas b/ssl_openssl_lib.pas index dbe7186..d009684 100644 --- a/ssl_openssl_lib.pas +++ b/ssl_openssl_lib.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 003.006.003 | +| Project : Ararat Synapse | 003.007.000 | |==============================================================================| | Content: SSL support by OpenSSL | |==============================================================================| -| Copyright (c)1999-2011, Lukas Gebauer | +| Copyright (c)1999-2012, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,8 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2002-2011. | +| Portions created by Lukas Gebauer are Copyright (c)2002-2012. | +| Portions created by Petr Fejfar are Copyright (c)2011-2012. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -143,6 +144,9 @@ type PASN1_INTEGER = SslPtr; PPasswdCb = SslPtr; PFunction = procedure; + PSTACK = SslPtr; {pf} + TSkPopFreeFunc = procedure(p:SslPtr); cdecl; {pf} + TX509Free = procedure(x: PX509); cdecl; {pf} DES_cblock = array[0..7] of Byte; PDES_cblock = ^DES_cblock; @@ -770,7 +774,13 @@ var function Asn1UtctimeNew: PASN1_UTCTIME; procedure Asn1UtctimeFree(a: PASN1_UTCTIME); function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; + function Asn1IntegerGet(a: PASN1_INTEGER): integer; {pf} function i2dX509bio(b: PBIO; x: PX509): integer; + function d2iX509bio(b:PBIO; x:PX509): PX509; {pf} + function PEMReadBioX509(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg: SslPtr): PX509; {pf} + procedure SkX509PopFree(st: PSTACK; func: TSkPopFreeFunc); {pf} + + function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; // 3DES functions @@ -784,6 +794,9 @@ function IsSSLloaded: Boolean; function InitSSLInterface: Boolean; function DestroySSLInterface: Boolean; +var + _X509Free: TX509Free = nil; {pf} + implementation uses SyncObjs; @@ -836,7 +849,6 @@ type // libeay.dll TX509New = function: PX509; cdecl; - TX509Free = procedure(x: PX509); cdecl; TX509NameOneline = function(a: PX509_NAME; buf: PAnsiChar; size: Integer):PAnsiChar; cdecl; TX509GetSubjectName = function(a: PX509):PX509_NAME; cdecl; TX509GetIssuerName = function(a: PX509):PX509_NAME; cdecl; @@ -880,7 +892,11 @@ type TAsn1UtctimeNew = function: PASN1_UTCTIME; cdecl; TAsn1UtctimeFree = procedure(a: PASN1_UTCTIME); cdecl; TAsn1IntegerSet = function(a: PASN1_INTEGER; v: integer): integer; cdecl; + TAsn1IntegerGet = function(a: PASN1_INTEGER): integer; cdecl; {pf} Ti2dX509bio = function(b: PBIO; x: PX509): integer; cdecl; + Td2iX509bio = function(b:PBIO; x:PX509): PX509; cdecl; {pf} + TPEMReadBioX509 = function(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg:SslPtr): PX509; cdecl; {pf} + TSkX509PopFree = procedure(st: PSTACK; func: TSkPopFreeFunc); cdecl; {pf} Ti2dPrivateKeyBio= function(b: PBIO; pkey: EVP_PKEY): integer; cdecl; // 3DES functions @@ -936,7 +952,6 @@ var // libeay.dll _X509New: TX509New = nil; - _X509Free: TX509Free = nil; _X509NameOneline: TX509NameOneline = nil; _X509GetSubjectName: TX509GetSubjectName = nil; _X509GetIssuerName: TX509GetIssuerName = nil; @@ -979,7 +994,11 @@ var _Asn1UtctimeNew: TAsn1UtctimeNew = nil; _Asn1UtctimeFree: TAsn1UtctimeFree = nil; _Asn1IntegerSet: TAsn1IntegerSet = nil; + _Asn1IntegerGet: TAsn1IntegerGet = nil; {pf} _i2dX509bio: Ti2dX509bio = nil; + _d2iX509bio: Td2iX509bio = nil; {pf} + _PEMReadBioX509: TPEMReadBioX509 = nil; {pf} + _SkX509PopFree: TSkX509PopFree = nil; {pf} _i2dPrivateKeyBio: Ti2dPrivateKeyBio = nil; // 3DES functions @@ -1640,6 +1659,28 @@ begin Result := 0; end; +function d2iX509bio(b: PBIO; x: PX509): PX509; {pf} +begin + if InitSSLInterface and Assigned(_d2iX509bio) then + Result := _d2iX509bio(x,b) + else + Result := nil; +end; + +function PEMReadBioX509(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg: SslPtr): PX509; {pf} +begin + if InitSSLInterface and Assigned(_PEMReadBioX509) then + Result := _PEMReadBioX509(b,x,callback,cb_arg) + else + Result := nil; +end; + +procedure SkX509PopFree(st: PSTACK; func:TSkPopFreeFunc); {pf} +begin + if InitSSLInterface and Assigned(_SkX509PopFree) then + _SkX509PopFree(st,func); +end; + function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; begin if InitSSLInterface and Assigned(_i2dPrivateKeyBio) then @@ -1664,6 +1705,14 @@ begin Result := 0; end; +function Asn1IntegerGet(a: PASN1_INTEGER): integer; {pf} +begin + if InitSSLInterface and Assigned(_Asn1IntegerGet) then + Result := _Asn1IntegerGet(a) + else + Result := 0; +end; + function X509GetSerialNumber(x: PX509): PASN1_INTEGER; begin if InitSSLInterface and Assigned(_X509GetSerialNumber) then @@ -1748,6 +1797,13 @@ var s: string; x: integer; begin + {pf} + if SSLLoaded then + begin + Result := TRUE; + exit; + end; + {/pf} SSLCS.Enter; try if not IsSSLloaded then @@ -1853,7 +1909,11 @@ begin _Asn1UtctimeNew := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_new'); _Asn1UtctimeFree := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_free'); _Asn1IntegerSet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_set'); + _Asn1IntegerGet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_get'); {pf} _i2dX509bio := GetProcAddr(SSLUtilHandle, 'i2d_X509_bio'); + _d2iX509bio := GetProcAddr(SSLUtilHandle, 'd2i_X509_bio'); {pf} + _PEMReadBioX509 := GetProcAddr(SSLUtilHandle, 'PEM_read_bio_X509'); {pf} + _SkX509PopFree := GetProcAddr(SSLUtilHandle, 'SK_X509_POP_FREE'); {pf} _i2dPrivateKeyBio := GetProcAddr(SSLUtilHandle, 'i2d_PrivateKey_bio'); // 3DES functions @@ -2038,6 +2098,8 @@ begin _Asn1UtctimeNew := nil; _Asn1UtctimeFree := nil; _Asn1IntegerSet := nil; + _Asn1IntegerGet := nil; {pf} + _SkX509PopFree := nil; {pf} _i2dX509bio := nil; _i2dPrivateKeyBio := nil; diff --git a/synacode.pas b/synacode.pas index 18c9040..757a838 100644 --- a/synacode.pas +++ b/synacode.pas @@ -3,7 +3,7 @@ |==============================================================================| | Content: Coding and decoding support | |==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | +| Copyright (c)1999-2012, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2010. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2012. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -49,6 +49,7 @@ {$Q-} {$R-} {$H+} +{$TYPEDADDRESS OFF} {$IFDEF UNICODE} {$WARN IMPLICIT_STRING_CAST OFF} diff --git a/synamisc.pas b/synamisc.pas index 81d42b6..7b06523 100644 --- a/synamisc.pas +++ b/synamisc.pas @@ -57,6 +57,8 @@ {$ENDIF} {$ENDIF} +{$TYPEDADDRESS OFF} + {$IFDEF UNICODE} {$WARN IMPLICIT_STRING_CAST OFF} {$WARN IMPLICIT_STRING_CAST_LOSS OFF} diff --git a/synautil.pas b/synautil.pas index 7181193..7b564f7 100644 --- a/synautil.pas +++ b/synautil.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 004.014.001 | +| Project : Ararat Synapse | 004.015.000 | |==============================================================================| | Content: support procedures and functions | |==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | +| Copyright (c)1999-2012, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,8 +33,9 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2012. | | Portions created by Hernan Sanchez are Copyright (c) 2000. | +| Portions created by Petr Fejfar are Copyright (c)2011-2012. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -331,6 +332,34 @@ function XorString(Indata1, Indata2: AnsiString): AnsiString; is Splitted into multiple lines, then this procedure de-split it into one line.} function NormalizeHeader(Value: TStrings; var Index: Integer): string; +{pf} +{:Search for one of line terminators CR, LF or NUL. Return position of the + line beginning and length of text.} +procedure SearchForLineBreak(var APtr:PANSIChar; AEtx:PANSIChar; out ABol:PANSIChar; out ALength:integer); +{:Skip both line terminators CR LF (if any). Move APtr position forward.} +procedure SkipLineBreak(var APtr:PANSIChar; AEtx:PANSIChar); +{:Skip all blank lines in a buffer starting at APtr and move APtr position forward.} +procedure SkipNullLines (var APtr:PANSIChar; AEtx:PANSIChar); +{:Copy all lines from a buffer starting at APtr to ALines until empty line + or end of the buffer is reached. Move APtr position forward).} +procedure CopyLinesFromStreamUntilNullLine(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings); +{:Copy all lines from a buffer starting at APtr to ALines until ABoundary + or end of the buffer is reached. Move APtr position forward).} +procedure CopyLinesFromStreamUntilBoundary(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings; const ABoundary:ANSIString); +{:Search ABoundary in a buffer starting at APtr. + Return beginning of the ABoundary. Move APtr forward behind a trailing CRLF if any).} +function SearchForBoundary (var APtr:PANSIChar; AEtx:PANSIChar; const ABoundary:ANSIString): PANSIChar; +{:Compare a text at position ABOL with ABoundary and return position behind the + match (including a trailing CRLF if any).} +function MatchBoundary (ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar; +{:Compare a text at position ABOL with ABoundary + the last boundary suffix + and return position behind the match (including a trailing CRLF if any).} +function MatchLastBoundary (ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar; +{:Copy data from a buffer starting at position APtr and delimited by AEtx + position into ANSIString.} +function BuildStringFromBuffer (AStx,AEtx:PANSIChar): ANSIString; +{/pf} + var {:can be used for your own months strings for @link(getmonthnumber)} CustomMonthNames: array[1..12] of string; @@ -1823,6 +1852,207 @@ begin Result := TrimRight(s); end; +{==============================================================================} + +{pf} +procedure SearchForLineBreak(var APtr:PANSIChar; AEtx:PANSIChar; out ABol:PANSIChar; out ALength:integer); +begin + ABol := APtr; + while (APtr0 then + begin + APtr := bol; + Break; + end; + end; +end; +{/pf} + +{pf} +procedure CopyLinesFromStreamUntilNullLine(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings); +var + bol: PANSIChar; + lng: integer; + s: ANSIString; +begin + // Copying until body separator will be reached + while (APtr#0) do + begin + SearchForLineBreak(APtr,AEtx,bol,lng); + SkipLineBreak(APtr,AEtx); + if lng=0 then + Break; + SetString(s,bol,lng); + ALines.Add(s); + end; +end; +{/pf} + +{pf} +procedure CopyLinesFromStreamUntilBoundary(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings; const ABoundary:ANSIString); +var + bol: PANSIChar; + lng: integer; + s: ANSIString; + BackStop: ANSIString; + eob1: PANSIChar; + eob2: PANSIChar; +begin + BackStop := '--'+ABoundary; + eob2 := nil; + // Copying until Boundary will be reached + while (APtrAETX then + exit; + if strlcomp(MatchPos,#13#10,2)=0 then + inc(MatchPos,2); + if (MatchPos+2+Lng)>AETX then + exit; + if strlcomp(MatchPos,'--',2)<>0 then + exit; + inc(MatchPos,2); + if strlcomp(MatchPos,PANSIChar(ABoundary),Lng)<>0 then + exit; + inc(MatchPos,Lng); + if ((MatchPos+2)<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then + inc(MatchPos,2); + Result := MatchPos; +end; +{/pf} + +{pf} +function MatchLastBoundary(ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar; +var + MatchPos: PANSIChar; +begin + Result := nil; + MatchPos := MatchBoundary(ABOL,AETX,ABoundary); + if not Assigned(MatchPos) then + exit; + if strlcomp(MatchPos,'--',2)<>0 then + exit; + inc(MatchPos,2); + if (MatchPos+2<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then + inc(MatchPos,2); + Result := MatchPos; +end; +{/pf} + +{pf} +function BuildStringFromBuffer(AStx,AEtx:PANSIChar): ANSIString; +var + lng: integer; +begin + Lng := 0; + if Assigned(AStx) and Assigned(AEtx) then + begin + Lng := AEtx-AStx; + if Lng<0 then + Lng := 0; + end; + SetString(Result,AStx,lng); +end; +{/pf} + + + + {==============================================================================} var n: integer;