diff --git a/asn1util.pas b/asn1util.pas index b94e3b3..6ab1e91 100644 --- a/asn1util.pas +++ b/asn1util.pas @@ -3,15 +3,34 @@ |==============================================================================| | Content: support for ASN.1 BER coding and decoding | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001. | diff --git a/blcksock.pas b/blcksock.pas index 07e7816..7cb6ff9 100644 --- a/blcksock.pas +++ b/blcksock.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 005.007.000 | +| Project : Delphree - Synapse | 006.001.004 | |==============================================================================| | Content: Library base | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)1999-2002. | @@ -22,6 +41,11 @@ | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{ +Special thanks to Gregor Ibic + (Intelicom d.o.o., http://www.intelicom.si) + for good inspiration about SSL programming. +} {$Q-} {$WEAKPACKAGEUNIT ON} @@ -41,6 +65,9 @@ uses const cLocalhost = 'localhost'; + cAnyHost = '0.0.0.0'; + cBroadcast = '255.255.255.255'; + cAnyPort = '0'; type @@ -75,12 +102,16 @@ type FLocalSin: TSockAddrIn; FRemoteSin: TSockAddrIn; FLastError: Integer; + FLastErrorDesc: string; FBuffer: string; FRaiseExcept: Boolean; FNonBlockMode: Boolean; FMaxLineLength: Integer; - FMaxBandwidth: Integer; + FMaxSendBandwidth: Integer; FNextSend: Cardinal; + FMaxRecvBandwidth: Integer; + FNextRecv: Cardinal; + FConvertLineEnd: Boolean; function GetSizeRecvBuffer: Integer; procedure SetSizeRecvBuffer(Size: Integer); function GetSizeSendBuffer: Integer; @@ -95,7 +126,8 @@ type function GetSinIP(Sin: TSockAddrIn): string; function GetSinPort(Sin: TSockAddrIn): Integer; procedure DoStatus(Reason: THookSocketReason; const Value: string); - procedure LimitBandwidth(Length: Integer); + procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: Cardinal); + procedure SetBandwidth(Value: Integer); public constructor Create; constructor CreateAlternate(Stub: string); @@ -115,7 +147,7 @@ type function RecvPacket(Timeout: Integer): string; virtual; function PeekBuffer(Buffer: Pointer; Length: Integer): Integer; virtual; function PeekByte(Timeout: Integer): Byte; virtual; - function WaitingData: Integer; + function WaitingData: Integer; virtual; function WaitingDataEx: Integer; procedure SetLinger(Enable: Boolean; Linger: Integer); procedure GetSins; @@ -150,6 +182,7 @@ type class function GetErrorDesc(ErrorCode: Integer): string; property Socket: TSocket read FSocket write FSocket; property LastError: Integer read FLastError; + property LastErrorDesc: string read FLastErrorDesc; property Protocol: Integer read FProtocol; property LineBuffer: string read FBuffer write FBuffer; property RaiseExcept: Boolean read FRaiseExcept write FRaiseExcept; @@ -159,7 +192,10 @@ type property OnStatus: THookSocketStatus read FOnStatus write FOnStatus; property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode; property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength; - property MaxBandwidth: Integer read FMaxBandwidth Write FMaxBandwidth; + property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth; + property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth; + property MaxBandwidth: Integer Write SetBandwidth; + property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd; end; TSocksBlockSocket = class(TBlockSocket) @@ -207,6 +243,9 @@ type FSSLCertificateFile: string; FSSLPrivateKeyFile: string; FSSLCertCAFile: string; + FSSLLastError: integer; + FSSLLastErrorDesc: string; + FSSLverifyCert: Boolean; FHTTPTunnelIP: string; FHTTPTunnelPort: string; FHTTPTunnel: Boolean; @@ -223,6 +262,7 @@ type destructor Destroy; override; procedure CreateSocket; override; procedure CloseSocket; override; + function WaitingData: Integer; override; procedure Listen; function Accept: TSocket; procedure Connect(IP, Port: string); override; @@ -241,6 +281,7 @@ type function SSLGetPeerSubjectHash: Cardinal; function SSLGetPeerIssuerHash: Cardinal; function SSLGetPeerFingerprint: string; + function SSLCheck: Boolean; published property SSLEnabled: Boolean read FSslEnabled write SetSslEnabled; property SSLBypass: Boolean read FSslBypass write FSslBypass; @@ -249,6 +290,9 @@ type property SSLCertificateFile: string read FSSLCertificateFile write FSSLCertificateFile; property SSLPrivateKeyFile: string read FSSLPrivateKeyFile write FSSLPrivateKeyFile; property SSLCertCAFile: string read FSSLCertCAFile write FSSLCertCAFile; + property SSLLastError: integer read FSSLLastError; + property SSLLastErrorDesc: string read FSSLLastErrorDesc; + property SSLverifyCert: Boolean read FSSLverifyCert write FSSLverifyCert; property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP; property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort; property HTTPTunnel: Boolean read FHTTPTunnel; @@ -299,6 +343,21 @@ type Options: DWORD; end; + TSynaClient = Class(TObject) + protected + FTargetHost: string; + FTargetPort: string; + FIPInterface: string; + FTimeout: integer; + public + constructor Create; + published + property TargetHost: string read FTargetHost Write FTargetHost; + property TargetPort: string read FTargetPort Write FTargetPort; + property IPInterface: string read FIPInterface Write FIPInterface; + property Timeout: integer read FTimeout Write FTimeout; + end; + implementation type @@ -318,8 +377,11 @@ begin FBuffer := ''; FNonBlockMode := False; FMaxLineLength := 0; - FMaxBandwidth := 0; + FMaxSendBandwidth := 0; FNextSend := 0; + FMaxRecvBandwidth := 0; + FNextRecv := 0; + FConvertLineEnd := False; if not InitSocketInterface('') then begin e := ESynapseError.Create('Error loading Winsock DLL!'); @@ -378,7 +440,7 @@ begin Sin.sin_port := synsock.htons(StrToIntDef(Port, 0)) else Sin.sin_port := ServEnt^.s_port; - if IP = '255.255.255.255' then + if IP = cBroadcast then Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) else begin @@ -472,27 +534,33 @@ begin synsock.GetPeerName(FSocket, FremoteSin, Len); end; -procedure TBlockSocket.LimitBandwidth(Length: Integer); +procedure TBlockSocket.SetBandwidth(Value: Integer); +begin + MaxSendBandwidth := Value; + MaxRecvBandwidth := Value; +end; + +procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next: Cardinal); var x: Cardinal; - y: integer; + y: Cardinal; begin - if FMaxBandwidth > 0 then + if MaxB > 0 then begin - y:= GetTick; - if FNextSend > y then + y := GetTick; + if Next > y then begin - x:= FNextSend - y; + x := Next - y; if x > 0 then sleep(x); end; - FNextSend:= y + Trunc((Length / FMaxBandwidth) * 1000); + Next := y + Trunc((Length / MaxB) * 1000); end; end; function TBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer; begin - LimitBandwidth(Length); + LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); Result := synsock.Send(FSocket, Buffer^, Length, 0); SockCheck(Result); ExceptCheck; @@ -511,6 +579,7 @@ end; function TBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer; begin + LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); Result := synsock.Recv(FSocket, Buffer^, Length, 0); if Result = 0 then FLastError := WSAECONNRESET @@ -602,7 +671,8 @@ begin begin SetLength(Result, x); x := RecvBuffer(Pointer(Result), x); - SetLength(Result, x); + if x >= 0 then + SetLength(Result, x); end; end else @@ -634,31 +704,57 @@ var x: Integer; s: string; l: Integer; + CorCRLF: Boolean; + t: string; + tl: integer; begin FLastError := 0; Result := ''; l := system.Length(Terminator); if l = 0 then Exit; + tl := l; + CorCRLF := FConvertLineEnd and (Terminator = #$0d + #$0a); // if FBuffer contains requested data, return it... if FBuffer<>'' then begin - x := pos(Terminator, FBuffer); + if CorCRLF then + begin + t := ''; + x := PosCRLF(FBuffer, t); + tl := system.Length(t); + end + else + begin + x := pos(Terminator, FBuffer); + tl := l; + end; if x > 0 then begin Result := copy(FBuffer, 1, x - 1); - System.Delete(FBuffer, 1, x + l - 1); - exit; + System.Delete(FBuffer, 1, x + tl - 1); + Exit; end; end; // now FBuffer is empty or not contains all data... s := ''; x := 0; repeat + //get rest of FBuffer or incomming new data... s := s + RecvPacket(Timeout); if FLastError <> 0 then Break; - x := Pos(Terminator, s); + if CorCRLF then + begin + t := ''; + x := PosCRLF(s, t); + tl := system.Length(t); + end + else + begin + x := pos(Terminator, s); + tl := l; + end; if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then begin FLastError := WSAENOBUFS; @@ -668,7 +764,7 @@ begin if x > 0 then begin Result := Copy(s, 1, x - 1); - System.Delete(s, 1, x + l - 1); + System.Delete(s, 1, x + tl - 1); end; FBuffer := s; ExceptCheck; @@ -710,8 +806,12 @@ end; function TBlockSocket.SockCheck(SockResult: Integer): Integer; begin - if SockResult = SOCKET_ERROR then - Result := synsock.WSAGetLastError + FLastErrorDesc := ''; + if SockResult = integer(SOCKET_ERROR) then + begin + Result := synsock.WSAGetLastError; + FLastErrorDesc := GetErrorDesc(Result); + end else Result := 0; FLastError := Result; @@ -931,7 +1031,7 @@ function TBlockSocket.SendBufferTo(Buffer: Pointer; Length: Integer): Integer; var Len: Integer; begin - LimitBandwidth(Length); + LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); Len := SizeOf(FRemoteSin); Result := synsock.SendTo(FSocket, Buffer^, Length, 0, FRemoteSin, Len); SockCheck(Result); @@ -943,6 +1043,7 @@ function TBlockSocket.RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer; var Len: Integer; begin + LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); Len := SizeOf(FRemoteSin); Result := synsock.RecvFrom(FSocket, Buffer^, Length, 0, FRemoteSin, Len); SockCheck(Result); @@ -1256,7 +1357,6 @@ function TSocksBlockSocket.SocksRequest(Cmd: Byte; var Buf: string; begin - Result := False; FBypassFlag := True; try Buf := #5 + char(Cmd) + #0 + SocksCode(IP, Port); @@ -1330,9 +1430,9 @@ begin y := Ord(Value[5]); if Length(Value) < (5 + y + 2) then Exit; - for n := 6 to 6 + y do + for n := 6 to 6 + y - 1 do FSocksResponseIP := FSocksResponseIP + Value[n]; - Result := 5 + y +1; + Result := 5 + y + 1; end; else Exit; @@ -1498,11 +1598,10 @@ begin Password := ''; if TTCPBlockSocket(userdata) is TTCPBlockSocket then Password := TTCPBlockSocket(userdata).SSLPassword; - FillChar(buf, Size, 0); if Length(Password) > (Size - 1) then SetLength(Password, Size - 1); - StrPCopy(buf, Password); Result := Length(Password); + StrLCopy(buf, PChar(Password + #0), Result + 1); end; constructor TTCPBlockSocket.Create; @@ -1516,6 +1615,9 @@ begin FSSLPassword := ''; FSsl := nil; Fctx := nil; + FSSLLastError := 0; + FSSLLastErrorDesc := ''; + FSSLverifyCert := False; FHTTPTunnelIP := ''; FHTTPTunnelPort := ''; FHTTPTunnel := False; @@ -1545,6 +1647,15 @@ begin inherited CloseSocket; end; +function TTCPBlockSocket.WaitingData: Integer; +begin + Result := 0; + if FSslEnabled and not(FSslBypass) and not(FBypassFlag) then + Result := sslpending(Fssl); + if Result = 0 then + Result := inherited WaitingData; +end; + procedure TTCPBlockSocket.Listen; var b: Boolean; @@ -1677,10 +1788,14 @@ begin FLastError := 0; if not FSSLEnabled then SSLEnabled := True; - if sslsetfd(FSsl, FSocket) < 0 then - FLastError := WSASYSNOTREADY; if (FLastError = 0) then - if sslconnect(FSsl) < 0 then + if sslsetfd(FSsl, FSocket) < 1 then + begin + FLastError := WSASYSNOTREADY; + SSLCheck; + end; + if (FLastError = 0) then + if sslconnect(FSsl) < 1 then FLastError := WSASYSNOTREADY; ExceptCheck; end; @@ -1732,46 +1847,114 @@ begin Result := inherited GetRemoteSinPort; end; +function TTCPBlockSocket.SSLCheck: Boolean; +var + ErrBuf: array[0..255] of Char; +begin + Result := true; + FSSLLastErrorDesc := ''; + FSSLLastError := ErrGetError; + ErrClearError; + if FSSLLastError <> 0 then + begin + Result := False; + ErrErrorString(FSSLLastError, ErrBuf); + FSSLLastErrorDesc := ErrBuf; + end; +end; + function TTCPBlockSocket.SetSslKeys: boolean; begin - Result := False; - if FSSLCertificateFile <> '' then - SslCtxUseCertificateChainFile(FCtx, PChar(FSSLCertificateFile)); - if FSSLPrivateKeyFile <> '' then - SslCtxUsePrivateKeyFile(FCtx, PChar(FSSLPrivateKeyFile), 1); - if FSSLCertCAFile <> '' then - SslCtxLoadVerifyLocations(FCtx, PChar(FSSLCertCAFile), nil); Result := True; + if FSSLCertificateFile <> '' then + if SslCtxUseCertificateChainFile(FCtx, PChar(FSSLCertificateFile)) <> 1 then + begin + Result := False; + SSLCheck; + Exit; + end; + if FSSLPrivateKeyFile <> '' then + if SslCtxUsePrivateKeyFile(FCtx, PChar(FSSLPrivateKeyFile), 1) <> 1 then + begin + Result := False; + SSLCheck; + Exit; + end; + if FSSLCertCAFile <> '' then + if SslCtxLoadVerifyLocations(FCtx, PChar(FSSLCertCAFile), nil) <> 1 then + begin + Result := False; + SSLCheck; + end; end; procedure TTCPBlockSocket.SetSslEnabled(Value: Boolean); +var + err: Boolean; begin + FLastError := 0; if Value <> FSslEnabled then if Value then begin + FBuffer := ''; + FSSLLastErrorDesc := ''; + FSSLLastError := 0; if InitSSLInterface then begin SslLibraryInit; SslLoadErrorStrings; + err := False; Fctx := nil; Fctx := SslCtxNew(SslMethodV23); - SslCtxSetCipherList(Fctx, PChar(FSSLCiphers)); - SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback); - SslCtxSetDefaultPasswdCbUserdata(FCtx, self); - SetSSLKeys; - Fssl := nil; - Fssl := SslNew(Fctx); - FSslEnabled := True; + if Fctx = nil then + begin + SSLCheck; + FlastError := WSAEPROTONOSUPPORT; + err := True; + end + else + begin + SslCtxSetCipherList(Fctx, PChar(FSSLCiphers)); + if FSSLverifyCert then + SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil) + else + SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil); + SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback); + SslCtxSetDefaultPasswdCbUserdata(FCtx, self); + if not SetSSLKeys then + FLastError := WSAEINVAL + else + begin + Fssl := nil; + Fssl := SslNew(Fctx); + if Fssl = nil then + begin + SSLCheck; + FlastError := WSAEPROTONOSUPPORT; + err := True; + end; + end; + end; + if err then + DestroySSLInterface + else + FSslEnabled := True; end - else DestroySSLInterface; + else + begin + DestroySSLInterface; + FlastError := WSAEPROTONOSUPPORT; + end; end else begin + FBuffer := ''; sslfree(Fssl); SslCtxFree(Fctx); DestroySSLInterface; FSslEnabled := False; end; + ExceptCheck; end; function TTCPBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer; @@ -1784,7 +1967,7 @@ begin repeat Result := SslRead(FSsl, Buffer, Length); err := SslGetError(FSsl, Result); - until (err <> SSL_ERROR_WANT_READ) or (err <> SSL_ERROR_WANT_WRITE); + until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); if err = SSL_ERROR_ZERO_RETURN then Result := 0 else @@ -1807,7 +1990,7 @@ begin repeat Result := SslWrite(FSsl, Buffer, Length); err := SslGetError(FSsl, Result); - until (err <> SSL_ERROR_WANT_READ) or (err <> SSL_ERROR_WANT_WRITE); + until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); if err = SSL_ERROR_ZERO_RETURN then Result := 0 else @@ -1822,14 +2005,17 @@ end; function TTCPBlockSocket.SSLAcceptConnection: Boolean; begin - Result := False; FLastError := 0; if not FSSLEnabled then SSLEnabled := True; - if sslsetfd(FSsl, FSocket) < 0 then - FLastError := WSASYSNOTREADY; if (FLastError = 0) then - if sslAccept(FSsl) < 0 then + if sslsetfd(FSsl, FSocket) < 1 then + begin + FLastError := WSASYSNOTREADY; + SSLCheck; + end; + if (FLastError = 0) then + if sslAccept(FSsl) < 1 then FLastError := WSASYSNOTREADY; ExceptCheck; Result := FLastError = 0; @@ -1914,4 +2100,15 @@ begin inherited CreateSocket; end; +{======================================================================} + +constructor TSynaClient.Create; +begin + inherited Create; + FIPInterface := cAnyHost; + FTargetHost := cLocalhost; + FTargetPort := cAnyPort; + FTimeout := 5000; +end; + end. diff --git a/dnssend.pas b/dnssend.pas index c1055e9..b46017d 100644 --- a/dnssend.pas +++ b/dnssend.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.001.004 | +| Project : Delphree - Synapse | 001.002.000 | |==============================================================================| | Content: DNS client | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2000,2001. | @@ -81,10 +100,8 @@ const QTYPE_ALL = 255; // type - TDNSSend = class(TObject) + TDNSSend = class(TSynaClient) private - FTimeout: Integer; - FDNSHost: string; FRCode: Integer; FBuffer: string; FSock: TUDPBlockSocket; @@ -100,8 +117,6 @@ type function DNSQuery(Name: string; QType: Integer; const Reply: TStrings): Boolean; published - property Timeout: Integer read FTimeout Write FTimeout; - property DNSHost: string read FDNSHost Write FDNSHost; property RCode: Integer read FRCode; property Sock: TUDPBlockSocket read FSock; end; @@ -117,7 +132,7 @@ begin FSock := TUDPBlockSocket.Create; FSock.CreateSocket; FTimeout := 5000; - FDNSHost := cLocalhost; + FTargetPort := cDnsProtocol; end; destructor TDNSSend.Destroy; @@ -290,7 +305,8 @@ begin if IsIP(Name) then Name := ReverseIP(Name) + '.in-addr.arpa'; FBuffer := CodeHeader + CodeQuery(Name, QType); - FSock.Connect(FDNSHost, cDnsProtocol); + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); FSock.SendString(FBuffer); FBuffer := FSock.RecvPacket(FTimeout); if (FSock.LastError = 0) and (Length(FBuffer) > 13) then @@ -337,7 +353,7 @@ begin t := TStringList.Create; DNS := TDNSSend.Create; try - DNS.DNSHost := DNSHost; + DNS.TargetHost := DNSHost; if DNS.DNSQuery(Domain, QType_MX, t) then begin { normalize preference number to 5 digits } diff --git a/ftpsend.pas b/ftpsend.pas index fc866e4..3f1523c 100644 --- a/ftpsend.pas +++ b/ftpsend.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.000.000 | +| Project : Delphree - Synapse | 002.003.001 | |==============================================================================| | Content: FTP client | |==============================================================================| -| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c) 1999-2002. | @@ -68,14 +87,11 @@ type property List: TList read FList; end; - TFTPSend = class(TObject) + TFTPSend = class(TSynaClient) private FOnStatus: TFTPStatus; FSock: TTCPBlockSocket; FDSock: TTCPBlockSocket; - FTimeout: Integer; - FFTPHost: string; - FFTPPort: string; FResultCode: Integer; FResultString: string; FFullResult: TStringList; @@ -114,6 +130,7 @@ type function FTPCommand(const Value: string): integer; function Login: Boolean; procedure Logout; + procedure Abort; function List(Directory: string; NameList: Boolean): Boolean; function RetriveFile(const FileName: string; Restore: Boolean): Boolean; function StoreFile(const FileName: string; Restore: Boolean): Boolean; @@ -129,9 +146,6 @@ type function CreateDir(const Directory: string): Boolean; function GetCurrentDir: String; published - property Timeout: Integer read FTimeout Write FTimeout; - property FTPHost: string read FFTPHost Write FFTPHost; - property FTPPort: string read FFTPPort Write FFTPPort; property ResultCode: Integer read FResultCode; property ResultString: string read FResultString; property FullResult: TStringList read FFullResult; @@ -179,8 +193,7 @@ begin FDSock := TTCPBlockSocket.Create; FFtpList := TFTPList.Create; FTimeout := 300000; - FFTPHost := cLocalhost; - FFTPPort := cFtpProtocol; + FTargetPort := cFtpProtocol; FUsername := 'anonymous'; FPassword := 'anonymous@' + FSock.LocalName; FDirectFile := False; @@ -285,10 +298,10 @@ begin Result := False; if FFWHost = '' then Mode := 0; - if (FFTPPort = cFtpProtocol) or (FFTPPort = '21') then - FTPServer := FFTPHost + if (FTargetPort = cFtpProtocol) or (FTargetPort = '21') then + FTPServer := FTargetHost else - FTPServer := FFTPHost + ':' + FFTPPort; + FTPServer := FTargetHost + ':' + FTargetPort; case Mode of -1: LogonActions := CustomLogon; @@ -349,8 +362,9 @@ function TFTPSend.Connect: Boolean; begin FSock.CloseSocket; FSock.CreateSocket; + FSock.Bind(FIPInterface, cAnyPort); if FFWHost = '' then - FSock.Connect(FFTPHost, FFTPPort) + FSock.Connect(FTargetHost, FTargetPort) else FSock.Connect(FFWHost, FFWPort); Result := FSock.LastError = 0; @@ -362,7 +376,7 @@ begin FCanResume := False; if not Connect then Exit; - if ReadResult <> 220 then + if (ReadResult div 100) <> 2 then Exit; if not Auth(FFWMode) then Exit; @@ -420,11 +434,12 @@ begin Result := False; if FPassiveMode then begin - if FTPCommand('PASV') <> 227 then + if (FTPCommand('PASV') div 100) <> 2 then Exit; ParseRemote(FResultString); FDSock.CloseSocket; FDSock.CreateSocket; + FSock.Bind(FIPInterface, cAnyPort); FDSock.Connect(FDataIP, FDataPort); Result := FDSock.LastError = 0; end @@ -436,7 +451,11 @@ begin s := cFtpDataProtocol else s := '0'; - FDSock.Bind(FDSock.LocalName, s); + //IP cannot be '0.0.0.0'! + if FIPInterface = cAnyHost then + FDSock.Bind(FDSock.LocalName, s) + else + FSock.Bind(FIPInterface, s); if FDSock.LastError <> 0 then Exit; FDSock.Listen; @@ -447,7 +466,7 @@ begin s := StringReplace(FDataIP, '.', ','); s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256) + ',' + IntToStr(FDSock.GetLocalSinPort mod 256); - Result := FTPCommand(s) = 200; + Result := (FTPCommand(s) div 100) = 2; end; end; @@ -485,9 +504,9 @@ begin if FDSock.LastError = 0 then DestStream.Write(Pointer(buf)^, Length(buf)); until FDSock.LastError <> 0; + FDSock.CloseSocket; x := ReadResult; - if (x = 226) or (x = 250) then - Result := True; + Result := (x div 100) = 2; finally FDSock.CloseSocket; end; @@ -524,8 +543,7 @@ begin Exit; FDSock.CloseSocket; x := ReadResult; - if (x = 226) or (x = 250) then - Result := True; + Result := (x div 100) = 2; finally FDSock.CloseSocket; end; @@ -577,7 +595,7 @@ begin if FDirectFile then if Restore and FileExists(FDirectFileName) then RetrStream := TFileStream.Create(FDirectFileName, - fmOpenReadWrite or fmShareExclusive) + fmOpenReadWrite or fmShareExclusive) else RetrStream := TFileStream.Create(FDirectFileName, fmCreate or fmShareDenyWrite) @@ -590,7 +608,7 @@ begin if Restore then begin RetrStream.Seek(0, soFromEnd); - if FTPCommand('REST ' + IntToStr(RetrStream.Size)) <> 350 then + if (FTPCommand('REST ' + IntToStr(RetrStream.Size)) div 100) <> 3 then Exit; end else @@ -637,7 +655,7 @@ begin RestoreAt := 0; FTPCommand('ALLO ' + IntToStr(StorSize - RestoreAt)); if FCanResume then - if FTPCommand('REST ' + IntToStr(RestoreAt)) <> 350 then + if (FTPCommand('REST ' + IntToStr(RestoreAt)) div 100) <> 3 then Exit; SendStream.Seek(RestoreAt, soFromBeginning); if (FTPCommand(Command) div 100) <> 1 then @@ -688,14 +706,14 @@ end; function TFTPSend.RenameFile(const OldName, NewName: string): Boolean; begin Result := False; - if FTPCommand('RNFR ' + OldName) <> 350 then + if (FTPCommand('RNFR ' + OldName) div 100) <> 3 then Exit; - Result := FTPCommand('RNTO ' + NewName) = 250; + Result := (FTPCommand('RNTO ' + NewName) div 100) = 2; end; function TFTPSend.DeleteFile(const FileName: string): Boolean; begin - Result := FTPCommand('DELE ' + FileName) = 250; + Result := (FTPCommand('DELE ' + FileName) div 100) = 2; end; function TFTPSend.FileSize(const FileName: string): integer; @@ -703,7 +721,7 @@ var s: string; begin Result := -1; - if FTPCommand('SIZE ' + FileName) = 213 then + if (FTPCommand('SIZE ' + FileName) div 100) = 2 then begin s := SeparateRight(ResultString, ' '); s := SeparateLeft(s, ' '); @@ -713,28 +731,28 @@ end; function TFTPSend.ChangeWorkingDir(const Directory: string): Boolean; begin - Result := FTPCommand('CWD ' + Directory) = 250; + Result := (FTPCommand('CWD ' + Directory) div 100) = 2; end; function TFTPSend.ChangeToRootDir: Boolean; begin - Result := FTPCommand('CDUP') = 200; + Result := (FTPCommand('CDUP') div 100) = 2; end; function TFTPSend.DeleteDir(const Directory: string): Boolean; begin - Result := FTPCommand('RMD ' + Directory) = 250; + Result := (FTPCommand('RMD ' + Directory) div 100) = 2; end; function TFTPSend.CreateDir(const Directory: string): Boolean; begin - Result := FTPCommand('MKD ' + Directory) = 257; + Result := (FTPCommand('MKD ' + Directory) div 100) = 2; end; function TFTPSend.GetCurrentDir: String; begin Result := ''; - if FTPCommand('PWD') = 257 then + if (FTPCommand('PWD') div 100) = 2 then begin Result := SeparateRight(FResultString, '"'); Result := Separateleft(Result, '"'); @@ -767,6 +785,7 @@ begin end; // based on idea by D. J. Bernstein, djb@pobox.com +// fixed UNIX style decoding by Alex, akudrin@rosbi.ru function TFTPList.ParseLine(Value: string): Boolean; var flr: TFTPListRec; @@ -777,10 +796,12 @@ var mday: Word; t: TDateTime; x: integer; + al_tmp : array[1..2] of string; // alex begin Result := False; if Length(Value) < 2 then Exit; + year := 0; month := 0; mday := 0; @@ -853,68 +874,69 @@ begin (Value[1] = 's') or (Value[1] = '-') then begin - if Value[1] = 'd' then - flr.Directory := True; - if Value[1] = '-' then - flr.Readable := True; - if Value[1] = 'l' then + + // alex begin + // default year + DecodeDate(date,year,month,mday); // alex + month:=0; + mday :=0; + + if Value[1] = 'd' then flr.Directory := True + else if Value[1] = '-' then flr.Readable := True + else if Value[1] = 'l' then begin flr.Directory := True; flr.Readable := True; end; - state := 1; + + state:=1; s := Fetch(Value, ' '); - while s <> '' do + while s<>'' do begin - case state of - 1: - begin - state := 2; - if (s[1] = 'f') and (Pos(' ', s) = 6) then - state := 3; - end; - 2: - state := 3; - 3: - begin - flr.FileSize := StrToIntDef(s, 0); - state := 4; - end; - 4: - begin - month := GetMonthNumber(s); - if month > 0 then - state := 5 - else - flr.FileSize := StrToIntDef(s, 0); - end; - 5: - begin - mday := StrToIntDef(s, 0); - state := 6; - end; - 6: - begin - if (Pos(':', s) > 0) then - t := GetTimeFromStr(s) - else - if Length(s) = 4 then - year := StrToIntDef(s, 0) - else Exit; - if (year = 0) or (month = 0) or (mday = 0) then - Exit; - flr.FileTime := t + Encodedate(year, month, mday); - state := 7; - end; - 7: - begin - flr.FileName := s; - Result := True; - end; - end; - s := Fetch(Value, ' '); + month:=GetMonthNumber(s); + if month>0 then + break; + al_tmp[state]:=s; + if state=1 then state:=2 + else state:=1; + s := Fetch(Value, ' '); end; - Exit; + if month>0 then begin + if state=1 then + flr.FileSize := StrToIntDef(al_tmp[2], 0) + else flr.FileSize := StrToIntDef(al_tmp[1], 0); + + state:=1; + s := Fetch(Value, ' '); + while s <> '' do + begin + case state of + 1 : mday := StrToIntDef(s, 0); + 2 : begin + if (Pos(':', s) > 0) then + t := GetTimeFromStr(s) + else if Length(s) = 4 then + year := StrToIntDef(s, 0) + else Exit; + if (year = 0) or (month = 0) or (mday = 0) then + Exit; + flr.FileTime := t + Encodedate(year, month, mday); + end; + 3 : begin + if Value <> '' then + s := s + ' ' + Value; + s := SeparateLeft(s, ' -> '); + flr.FileName := s; + Result := True; + break; + end; + end; + inc(state); + s := Fetch(Value, ' '); + end; + end; + // alex end + exit; end; {Microsoft NT 4.0 FTP Service 10-20-98 08:57AM 619098 rizrem.zip @@ -947,8 +969,7 @@ begin end; if Value = '' then Exit; - s := Fetch(Value, ' '); - flr.FileName := s; + flr.FileName := Trim(s); Result := True; Exit; end; @@ -1015,8 +1036,8 @@ begin Username := User; Password := Pass; end; - FTPHost := IP; - FTPPort := Port; + TargetHost := IP; + TargetPort := Port; if not Login then Exit; DirectFileName := LocalFile; @@ -1039,8 +1060,8 @@ begin Username := User; Password := Pass; end; - FTPHost := IP; - FTPPort := Port; + TargetHost := IP; + TargetPort := Port; if not Login then Exit; DirectFileName := LocalFile; @@ -1074,10 +1095,10 @@ begin ToFTP.Username := ToUser; ToFTP.Password := ToPass; end; - FromFTP.FTPHost := FromIP; - FromFTP.FTPPort := FromPort; - ToFTP.FTPHost := ToIP; - ToFTP.FTPPort := ToPort; + FromFTP.TargetHost := FromIP; + FromFTP.TargetPort := FromPort; + ToFTP.TargetHost := ToIP; + ToFTP.TargetPort := ToPort; if not FromFTP.Login then Exit; if not ToFTP.Login then @@ -1111,4 +1132,9 @@ begin end; end; +procedure TFTPSend.Abort; +begin + FDSock.CloseSocket; +end; + end. diff --git a/httpsend.pas b/httpsend.pas index 75c45fb..43b9304 100644 --- a/httpsend.pas +++ b/httpsend.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 003.000.003 | +| Project : Delphree - Synapse | 003.002.000 | |==============================================================================| | Content: HTTP client | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c) 1999-2002. | @@ -39,7 +58,7 @@ const type TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED); - THTTPSend = class(TObject) + THTTPSend = class(TSynaClient) private FSock: TTCPBlockSocket; FTransferEncoding: TTransferEncoding; @@ -50,9 +69,6 @@ type FMimeType: string; FProtocol: string; FKeepAlive: Boolean; - FTimeout: Integer; - FHTTPHost: string; - FHTTPPort: string; FProxyHost: string; FProxyPort: string; FProxyUser: string; @@ -74,9 +90,6 @@ type property MimeType: string read FMimeType Write FMimeType; property Protocol: string read FProtocol Write FProtocol; property KeepAlive: Boolean read FKeepAlive Write FKeepAlive; - property Timeout: Integer read FTimeout Write FTimeout; - property HTTPHost: string read FHTTPHost; - property HTTPPort: string read FHTTPPort; property ProxyHost: string read FProxyHost Write FProxyHost; property ProxyPort: string read FProxyPort Write FProxyPort; property ProxyUser: string read FProxyUser Write FProxyUser; @@ -91,7 +104,7 @@ function HttpGetBinary(const URL: string; const Response: TStream): Boolean; function HttpPostBinary(const URL: string; const Data: TStream): Boolean; function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean; function HttpPostFile(const URL, FieldName, FileName: string; - const Data: TStream; const ResultData: TStringList): Boolean; + const Data: TStream; const ResultData: TStrings): Boolean; implementation @@ -106,9 +119,9 @@ begin FSock := TTCPBlockSocket.Create; FSock.SizeRecvBuffer := 65536; FSock.SizeSendBuffer := 65536; + FSock.ConvertLineEnd := True; FTimeout := 300000; - FHTTPHost := cLocalhost; - FHTTPPort := cHttpProtocol; + FTargetPort := cHttpProtocol; FProxyHost := ''; FProxyPort := '8080'; FProxyUser := ''; @@ -155,7 +168,6 @@ var ToClose: Boolean; Size: Integer; Prot, User, Pass, Host, Port, Path, Para, URI: string; - n: Integer; s, su: string; HttpTunnel: Boolean; begin @@ -219,27 +231,30 @@ begin FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol); if (FProxyHost <> '') and not(HttpTunnel) then begin - FHTTPHost := FProxyHost; - FHTTPPort := FProxyPort; + FTargetHost := FProxyHost; + FTargetPort := FProxyPort; end else begin - FHTTPHost := Host; - FHTTPPort := Port; + FTargetHost := Host; + FTargetPort := Port; end; if FHeaders[FHeaders.Count - 1] <> '' then FHeaders.Add(''); { connect } - if (FAliveHost <> FHTTPHost) or (FAlivePort <> FHTTPPort) then + if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort) then begin FSock.CloseSocket; FSock.CreateSocket; - FSock.Connect(FHTTPHost, FHTTPPort); + FSock.Bind(FIPInterface, cAnyPort); if FSock.LastError <> 0 then Exit; - FAliveHost := FHTTPHost; - FAlivePort := FHTTPPort; + FSock.Connect(FTargetHost, FTargetPort); + if FSock.LastError <> 0 then + Exit; + FAliveHost := FTargetHost; + FAlivePort := FTargetPort; end else begin @@ -247,7 +262,10 @@ begin begin FSock.CloseSocket; FSock.CreateSocket; - FSock.Connect(FHTTPHost, FHTTPPort); + FSock.Bind(FIPInterface, cAnyPort); + if FSock.LastError <> 0 then + Exit; + FSock.Connect(FTargetHost, FTargetPort); if FSock.LastError <> 0 then Exit; end; @@ -257,7 +275,11 @@ begin if FProtocol = '0.9' then FSock.SendString(FHeaders[0] + CRLF) else +{$IFDEF LINUX} + FSock.SendString(AdjustLineBreaks(FHeaders.Text, tlbsCRLF)); +{$ELSE} FSock.SendString(FHeaders.Text); +{$ENDIF} if FSock.LastError <> 0 then Exit; @@ -320,7 +342,7 @@ begin else FHeaders.Add(Status100Error); - { if need receive hedaers, receive and parse it } + { if need receive headers, receive and parse it } ToClose := FProtocol <> '1.1'; if FHeaders.Count > 0 then repeat @@ -479,7 +501,7 @@ begin end; function HttpPostFile(const URL, FieldName, FileName: string; - const Data: TStream; const ResultData: TStringList): Boolean; + const Data: TStream; const ResultData: TStrings): Boolean; const CRLF = #$0D + #$0A; var diff --git a/imapsend.pas b/imapsend.pas index 0cc5ce3..23a464e 100644 --- a/imapsend.pas +++ b/imapsend.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.000.000 | +| Project : Delphree - Synapse | 002.001.000 | |==============================================================================| -| Content: IMAP4rev1 client | +| Content: IMAP4rev1 client | |==============================================================================| -| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2001-2002. | @@ -40,12 +59,9 @@ const cIMAPProtocol = '143'; type - TIMAPSend = class(TObject) + TIMAPSend = class(TSynaClient) private FSock: TTCPBlockSocket; - FTimeout: Integer; - FIMAPHost: string; - FIMAPPort: string; FTagCommand: integer; FResultString: string; FFullResult: TStringList; @@ -101,9 +117,6 @@ type function StartTLS: Boolean; function FindCap(const Value: string): string; published - property Timeout: Integer read FTimeout Write FTimeout; - property IMAPHost: string read FIMAPHost Write FIMAPHost; - property IMAPPort: string read FIMAPPort Write FIMAPPort; property ResultString: string read FResultString; property FullResult: TStringList read FFullResult; property IMAPcap: TStringList read FIMAPcap; @@ -134,9 +147,9 @@ begin FSock.CreateSocket; FSock.SizeRecvBuffer := 32768; FSock.SizeSendBuffer := 32768; + FSock.ConvertLineEnd := True; FTimeout := 300000; - FIMAPhost := cLocalhost; - FIMAPPort := cIMAPProtocol; + FTargetPort := cIMAPProtocol; FUsername := ''; FPassword := ''; FTagCommand := 0; @@ -316,7 +329,8 @@ begin FSock.CreateSocket; if FFullSSL then FSock.SSLEnabled := True; - FSock.Connect(FIMAPHost, FIMAPPort); + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); Result := FSock.LastError = 0; end; diff --git a/mimeinln.pas b/mimeinln.pas index caf4d8f..b8834d2 100644 --- a/mimeinln.pas +++ b/mimeinln.pas @@ -3,15 +3,34 @@ |==============================================================================| | Content: Inline MIME support procedures and functions | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2000,2001. | diff --git a/mimemess.pas b/mimemess.pas index 7eadf62..394eaff 100644 --- a/mimemess.pas +++ b/mimemess.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.007.004 | +| Project : Delphree - Synapse | 002.001.001 | |==============================================================================| | Content: MIME message object | |==============================================================================| -| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2000-2002. | @@ -48,10 +67,10 @@ type constructor Create; destructor Destroy; override; procedure Clear; - procedure EncodeHeaders(const Value: TStringList); - procedure DecodeHeaders(const Value: TStringList); + procedure EncodeHeaders(const Value: TStrings); + procedure DecodeHeaders(const Value: TStrings); function FindHeader(Value: string): string; - procedure FindHeaderList(Value: string; const HeaderList: TStringList); + procedure FindHeaderList(Value: string; const HeaderList: TStrings); published property From: string read FFrom Write FFrom; property ToList: TStringList read FToList; @@ -65,28 +84,29 @@ type TMimeMess = class(TObject) private - FPartList: TList; + FMessagePart: TMimePart; FLines: TStringList; FHeader: TMessHeader; - FMultipartType: string; public constructor Create; destructor Destroy; override; procedure Clear; - function AddPart: Integer; - procedure AddPartText(const Value: TStringList); - procedure AddPartHTML(const Value: TStringList); - procedure AddPartHTMLBinary(Value, Cid: string); - procedure AddPartBinary(Value: string); + function AddPart(const PartParent: TMimePart): TMimePart; + function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart; + function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart; + function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart; + function AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; + function AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; + function AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart; + function AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart; + function AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart; + function AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart; procedure EncodeMessage; - procedure FinalizeHeaders; - procedure ParseHeaders; procedure DecodeMessage; published - property PartList: TList read FPartList; + property MessagePart: TMimePart read FMessagePart; property Lines: TStringList read FLines; property Header: TMessHeader read FHeader; - property MultipartType: string read FMultipartType Write FMultipartType; end; implementation @@ -123,7 +143,7 @@ begin FXMailer := ''; end; -procedure TMessHeader.EncodeHeaders(const Value: TStringList); +procedure TMessHeader.EncodeHeaders(const Value: TStrings); var n: Integer; s: string; @@ -162,7 +182,7 @@ begin Value.Insert(0, 'From: ' + InlineEmail(FFrom)); end; -procedure TMessHeader.DecodeHeaders(const Value: TStringList); +procedure TMessHeader.DecodeHeaders(const Value: TStrings); var s, t: string; x: Integer; @@ -250,7 +270,7 @@ begin end; end; -procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStringList); +procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStrings); var n: integer; begin @@ -267,47 +287,58 @@ end; constructor TMimeMess.Create; begin inherited Create; - FPartList := TList.Create; + FMessagePart := TMimePart.Create; FLines := TStringList.Create; FHeader := TMessHeader.Create; - FMultipartType := 'Mixed'; end; destructor TMimeMess.Destroy; begin - Clear; + FMessagePart.Free; FHeader.Free; - Lines.Free; - PartList.Free; + FLines.Free; inherited Destroy; end; {==============================================================================} procedure TMimeMess.Clear; -var - n: Integer; begin - FMultipartType := 'Mixed'; - Lines.Clear; - for n := 0 to FPartList.Count - 1 do - TMimePart(FPartList[n]).Free; - FPartList.Clear; + FMessagePart.Clear; + FLines.Clear; FHeader.Clear; end; {==============================================================================} -function TMimeMess.AddPart: Integer; +function TMimeMess.AddPart(const PartParent: TMimePart): TMimePart; begin - Result := FPartList.Add(TMimePart.Create); + if PartParent = nil then + Result := FMessagePart + else + Result := PartParent.AddSubPart; + Result.Clear; end; {==============================================================================} -procedure TMimeMess.AddPartText(const Value: TStringList); +function TMimeMess.AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart; begin - with TMimePart(FPartList[AddPart]) do + Result := AddPart(PartParent); + with Result do + begin + Primary := 'Multipart'; + Secondary := MultipartType; + Description := 'Multipart message'; + Boundary := GenerateBoundary; + EncodePartHeader; + end; +end; + +function TMimeMess.AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart; +begin + Result := AddPart(PartParent); + with Result do begin Value.SaveToStream(DecodedLines); Primary := 'text'; @@ -319,14 +350,14 @@ begin ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]); EncodingCode := ME_QUOTED_PRINTABLE; EncodePart; + EncodePartHeader; end; end; -{==============================================================================} - -procedure TMimeMess.AddPartHTML(const Value: TStringList); +function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart; begin - with TMimePart(FPartList[AddPart]) do + Result := AddPart(PartParent); + with Result do begin Value.SaveToStream(DecodedLines); Primary := 'text'; @@ -336,43 +367,86 @@ begin CharsetCode := UTF_8; EncodingCode := ME_QUOTED_PRINTABLE; EncodePart; + EncodePartHeader; end; end; -{==============================================================================} - -procedure TMimeMess.AddPartBinary(Value: string); +function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; var - s: string; + tmp: TStrings; begin - with TMimePart(FPartList[AddPart]) do - begin - DecodedLines.LoadFromFile(Value); - s := ExtractFileName(Value); - MimeTypeFromExt(s); - Description := 'Attached file: ' + s; - Disposition := 'attachment'; - FileName := s; - EncodingCode := ME_BASE64; - EncodePart; + tmp := TStringList.Create; + try + tmp.LoadFromFile(FileName); + Result := AddPartText(tmp, PartParent); + Finally + tmp.Free; end; end; -procedure TMimeMess.AddPartHTMLBinary(Value, Cid: string); +function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; var - s: string; + tmp: TStrings; begin - with TMimePart(FPartList[AddPart]) do - begin - DecodedLines.LoadFromFile(Value); - s := ExtractFileName(Value); - MimeTypeFromExt(s); - Description := 'Included file: ' + s; - Disposition := 'inline'; - ContentID := Cid; - FileName := s; - EncodingCode := ME_BASE64; - EncodePart; + tmp := TStringList.Create; + try + tmp.LoadFromFile(FileName); + Result := AddPartHTML(tmp, PartParent); + Finally + tmp.Free; + end; +end; + +function TMimeMess.AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart; +begin + Result := AddPart(PartParent); + Result.DecodedLines.LoadFromStream(Stream); + Result.MimeTypeFromExt(FileName); + Result.Description := 'Attached file: ' + FileName; + Result.Disposition := 'attachment'; + Result.FileName := FileName; + Result.EncodingCode := ME_BASE64; + Result.EncodePart; + Result.EncodePartHeader; +end; + +function TMimeMess.AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart; +var + tmp: TMemoryStream; +begin + tmp := TMemoryStream.Create; + try + tmp.LoadFromFile(FileName); + Result := AddPartBinary(tmp, ExtractFileName(FileName), PartParent); + finally + tmp.Free; + end; +end; + +function TMimeMess.AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart; +begin + Result := AddPart(PartParent); + Result.DecodedLines.LoadFromStream(Stream); + Result.MimeTypeFromExt(FileName); + Result.Description := 'Included file: ' + FileName; + Result.Disposition := 'inline'; + Result.ContentID := Cid; + Result.FileName := FileName; + Result.EncodingCode := ME_BASE64; + Result.EncodePart; + Result.EncodePartHeader; +end; + +function TMimeMess.AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart; +var + tmp: TMemoryStream; +begin + tmp := TMemoryStream.Create; + try + tmp.LoadFromFile(FileName); + Result :=AddPartHTMLBinary(tmp, ExtractFileName(FileName), Cid, PartParent); + finally + tmp.Free; end; end; @@ -380,96 +454,44 @@ end; procedure TMimeMess.EncodeMessage; var - bound: string; - n: Integer; - m:TMimepart; + l: TStringList; + x: integer; begin - FLines.Clear; - if FPartList.Count = 1 then - begin - TMimePart(FPartList[0]).EncodePart; - FLines.Assign(TMimePart(FPartList[0]).Lines) - end - else - begin - bound := GenerateBoundary; - for n := 0 to FPartList.Count - 1 do - begin - FLines.Add('--' + bound); - TMimePart(FPartList[n]).EncodePart; - FLines.AddStrings(TMimePart(FPartList[n]).Lines); - end; - FLines.Add('--' + bound + '--'); - m := TMimePart.Create; - try - FLines.SaveToStream(m.DecodedLines); - m.Primary := 'Multipart'; - m.Secondary := FMultipartType; - m.Description := 'Multipart message'; - m.Boundary := bound; - m.EncodePart; - FLines.Assign(m.Lines); - finally - m.Free; - end; + //merge headers from THeaders and header field from MessagePart + l := TStringList.Create; + try + FHeader.EncodeHeaders(l); + x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers); + if x >= 0 then + l.add(FMessagePart.Headers[x]); + x := IndexByBegin('CONTENT-DESCRIPTION', FMessagePart.Headers); + if x >= 0 then + l.add(FMessagePart.Headers[x]); + x := IndexByBegin('CONTENT-DISPOSITION', FMessagePart.Headers); + if x >= 0 then + l.add(FMessagePart.Headers[x]); + x := IndexByBegin('CONTENT-ID', FMessagePart.Headers); + if x >= 0 then + l.add(FMessagePart.Headers[x]); + x := IndexByBegin('CONTENT-TRANSFER-ENCODING', FMessagePart.Headers); + if x >= 0 then + l.add(FMessagePart.Headers[x]); + FMessagePart.Headers.Assign(l); + finally + l.Free; end; -end; - -{==============================================================================} - -procedure TMimeMess.FinalizeHeaders; -begin - FHeader.EncodeHeaders(FLines); -end; - -{==============================================================================} - -procedure TMimeMess.ParseHeaders; -begin - FHeader.DecodeHeaders(FLines); + FMessagePart.ComposeParts; + FLines.Assign(FMessagePart.Lines); end; {==============================================================================} procedure TMimeMess.DecodeMessage; -var - l: TStringList; - m: TMimePart; - i: Integer; - bound: string; begin - l := TStringList.Create; - m := TMimePart.Create; - try - l.Assign(FLines); - FHeader.Clear; - ParseHeaders; - m.ExtractPart(l, 0); - if m.PrimaryCode = MP_MULTIPART then - begin - bound := m.Boundary; - i := 0; - repeat - with TMimePart(PartList[AddPart]) do - begin - Boundary := bound; - i := ExtractPart(l, i); - DecodePart; - end; - until i >= l.Count - 2; - end - else - begin - with TMimePart(PartList[AddPart]) do - begin - ExtractPart(l, 0); - DecodePart; - end; - end; - finally - m.Free; - l.Free; - end; + FHeader.Clear; + FHeader.DecodeHeaders(FLines); + FMessagePart.Lines.Assign(FLines); + FMessagePart.DecomposeParts; end; end. diff --git a/mimepart.pas b/mimepart.pas index 0b62362..a9593c4 100644 --- a/mimepart.pas +++ b/mimepart.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.008.004 | +| Project : Delphree - Synapse | 002.001.002 | |==============================================================================| | Content: MIME support procedures and functions | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2000-2002. | @@ -29,10 +48,16 @@ interface uses SysUtils, Classes, +{$IFNDEF LINUX} + Windows, +{$ENDIF} SynaChar, SynaCode, SynaUtil, MIMEinLn; type + TMimePart = class; + THookWalkPart = procedure(const Sender: TMimePart) of object; + TMimePrimary = (MP_TEXT, MP_MULTIPART, MP_MESSAGE, MP_BINARY); @@ -42,22 +67,28 @@ type TMimePart = class(TObject) private FPrimary: string; - FEncoding: string; - FCharset: string; - FDefaultCharset: string; FPrimaryCode: TMimePrimary; + FSecondary: string; + FEncoding: string; FEncodingCode: TMimeEncoding; + FDefaultCharset: string; + FCharset: string; FCharsetCode: TMimeChar; FTargetCharset: TMimeChar; - FSecondary: string; FDescription: string; FDisposition: string; FContentID: string; FBoundary: string; FFileName: string; FLines: TStringList; + FPartBody: TStringList; + FHeaders: TStringList; + FPrePart: TStringList; + FPostPart: TStringList; FDecodedLines: TMemoryStream; - FSkipLast: Boolean; + FSubParts: TList; + FOnWalkPart: THookWalkPart; + FMaxLineLength: integer; procedure SetPrimary(Value: string); procedure SetEncoding(Value: string); procedure SetCharset(Value: string); @@ -65,10 +96,18 @@ type constructor Create; destructor Destroy; override; procedure Clear; - function ExtractPart(Value: TStringList; BeginLine: Integer): Integer; procedure DecodePart; + procedure DecodePartHeader; procedure EncodePart; + procedure EncodePartHeader; procedure MimeTypeFromExt(Value: string); + function GetSubPartCount: integer; + function GetSubPart(index: integer): TMimePart; + procedure ClearSubParts; + function AddSubPart: TMimePart; + procedure DecomposeParts; + procedure ComposeParts; + procedure WalkPart; published property Primary: string read FPrimary write SetPrimary; property Encoding: string read FEncoding write SetEncoding; @@ -85,8 +124,13 @@ type property Boundary: string read FBoundary Write FBoundary; property FileName: string read FFileName Write FFileName; property Lines: TStringList read FLines; + property PartBody: TStringList read FPartBody; + property Headers: TStringList read FHeaders; + property PrePart: TStringList read FPrePart; + property PostPart: TStringList read FPostPart; property DecodedLines: TMemoryStream read FDecodedLines; - property SkipLast: Boolean read FSkipLast Write FSkipLast; + property OnWalkPart: THookWalkPart read FOnWalkPart write FOnWalkPart; + property MaxLineLength: integer read FMaxLineLength Write FMaxLineLength; end; const @@ -121,12 +165,12 @@ const ('ZIP', 'application', 'ZIP') ); -function NormalizeHeader(Value: TStringList; var Index: Integer): string; +function NormalizeHeader(Value: TStrings; var Index: Integer): string; function GenerateBoundary: string; implementation -function NormalizeHeader(Value: TStringList; var Index: Integer): string; +function NormalizeHeader(Value: TStrings; var Index: Integer): string; var s, t: string; n: Integer; @@ -150,7 +194,7 @@ begin Inc(Index); end; end; - Result := s; + Result := TrimRight(s); end; {==============================================================================} @@ -158,17 +202,29 @@ end; constructor TMIMEPart.Create; begin inherited Create; + FOnWalkPart := nil; FLines := TStringList.Create; + FPartBody := TStringList.Create; + FHeaders := TStringList.Create; + FPrePart := TStringList.Create; + FPostPart := TStringList.Create; FDecodedLines := TMemoryStream.Create; + FSubParts := TList.Create; FTargetCharset := GetCurCP; FDefaultCharset := 'US-ASCII'; - FSkipLast := True; + FMaxLineLength := 78; end; destructor TMIMEPart.Destroy; begin + ClearSubParts; + FSubParts.Free; FDecodedLines.Free; + FPartBody.Free; FLines.Free; + FHeaders.Free; + FPrePart.Free; + FPostPart.Free; inherited Destroy; end; @@ -189,51 +245,316 @@ begin FDescription := ''; FBoundary := ''; FFileName := ''; - FLines.Clear; + FPartBody.Clear; + FHeaders.Clear; + FPrePart.Clear; + FPostPart.Clear; FDecodedLines.Clear; + ClearSubParts; end; {==============================================================================} -function TMIMEPart.ExtractPart(Value: TStringList; BeginLine: Integer): Integer; -var - n, x, x1, x2: Integer; - t: TStringList; - s, su, b: string; - st, st2: string; - e: Boolean; - fn: string; +function TMIMEPart.GetSubPartCount: integer; begin - t := TStringlist.Create; - try - { defaults } - FLines.Clear; - Primary := 'text'; - FSecondary := 'plain'; - FDescription := ''; - Charset := FDefaultCharset; - FFileName := ''; - Encoding := '7BIT'; + Result := FSubParts.Count; +end; - fn := ''; - x := BeginLine; - b := FBoundary; - { if multipart - skip pre-part } - if b <> '' then - while Value.Count > x do - begin - s := Value[x]; - Inc(x); - if Pos('--' + b, s) = 1 then - Break; - end; +{==============================================================================} - { parse header } - while Value.Count > x do +function TMIMEPart.GetSubPart(index: integer): TMimePart; +begin + Result := nil; + if Index < GetSubPartCount then + Result := TMimePart(FSubParts[Index]); +end; + +{==============================================================================} + +procedure TMIMEPart.ClearSubParts; +var + n: integer; +begin + for n := 0 to GetSubPartCount - 1 do + TMimePart(FSubParts[n]).Free; + FSubParts.Clear; +end; + +{==============================================================================} + +function TMIMEPart.AddSubPart: TMimePart; +begin + Result := TMimePart.Create; + Result.DefaultCharset := FDefaultCharset; + FSubParts.Add(Result); +end; + +{==============================================================================} + +procedure TMIMEPart.DecomposeParts; +var + x: integer; + s: string; + Mime: TMimePart; + + procedure SkipEmpty; + begin + while FLines.Count > x do begin - s := NormalizeHeader(Value, x); - if s = '' then + s := TrimRight(FLines[x]); + if s <> '' then Break; + Inc(x); + end; + end; + +begin + x := 0; + Clear; + //extract headers + while FLines.Count > x do + begin + s := NormalizeHeader(FLines, x); + if s = '' then + Break; + FHeaders.Add(s); + end; + StringsTrim(FHeaders); + DecodePartHeader; + //extract prepart + if FPrimaryCode = MP_MULTIPART then + begin + SkipEmpty; + while FLines.Count > x do + begin + s := TrimRight(FLines[x]); + Inc(x); + if s = '--' + FBoundary then + Break; + FPrePart.Add(s); + end; + StringsTrim(FPrePart); + end; + //extract body part + if FPrimaryCode = MP_MULTIPART then + begin + repeat + Mime := AddSubPart; + while FLines.Count > x do + begin + s := TrimRight(FLines[x]); + Inc(x); + if Pos('--' + FBoundary, s) = 1 then + Break; + Mime.Lines.Add(s); + end; + StringsTrim(Mime.Lines); + Mime.DecomposeParts; + if x >= FLines.Count then + break; + until s = '--' + FBoundary + '--'; + end; + if FPrimaryCode = MP_MESSAGE then + begin + Mime := AddSubPart; + SkipEmpty; + while FLines.Count > x do + begin + s := TrimRight(FLines[x]); + Inc(x); + Mime.Lines.Add(s); + end; + StringsTrim(Mime.Lines); + Mime.DecomposeParts; + end + else + begin + SkipEmpty; + while FLines.Count > x do + begin + s := TrimRight(FLines[x]); + Inc(x); + FPartBody.Add(s); + end; + StringsTrim(FPartBody); + end; + //extract postpart + if FPrimaryCode = MP_MULTIPART then + begin + SkipEmpty; + while FLines.Count > x do + begin + s := TrimRight(FLines[x]); + Inc(x); + FPostPart.Add(s); + end; + StringsTrim(FPostPart); + end; +end; + +{==============================================================================} + +procedure TMIMEPart.ComposeParts; +var + n: integer; + mime: TMimePart; + s, t: string; + d1, d2, d3: integer; + x: integer; +begin + FLines.Clear; + //add headers + for n := 0 to FHeaders.Count -1 do + begin + s := FHeaders[n]; + repeat + if Length(s) < FMaxLineLength then + begin + t := s; + s := ''; + end + else + begin + d1 := RPosEx('; ', s, FMaxLineLength); + d2 := RPosEx(' ', s, FMaxLineLength); + d3 := RPosEx(', ', s, FMaxLineLength); + if (d1 <= 1) and (d2 <= 1) and (d3 <= 1) then + begin + x := Pos(' ', Copy(s, 2, Length(s) - 1)); + if x < 1 then + x := Length(s) + else + inc(x); + end + else + if d1 > 0 then + x := d1 + else + if d3 > 0 then + x := d3 + else + x := d2 - 1; + t := Copy(s, 1, x); + Delete(s, 1, x); + end; + Flines.Add(t); + until s = ''; + end; + + Flines.Add(''); + //add body + //if multipart + if FPrimaryCode = MP_MULTIPART then + begin + Flines.AddStrings(FPrePart); + Flines.Add(''); + for n := 0 to GetSubPartCount - 1 do + begin + Flines.Add('--' + FBoundary); + mime := GetSubPart(n); + mime.ComposeParts; + FLines.AddStrings(mime.Lines); + Flines.Add(''); + end; + Flines.Add('--' + FBoundary + '--'); + Flines.AddStrings(FPostPart); + end; + //if message + if FPrimaryCode = MP_MESSAGE then + begin + if GetSubPartCount > 0 then + begin + mime := GetSubPart(0); + mime.ComposeParts; + FLines.AddStrings(mime.Lines); + Flines.Add(''); + end; + end + else + //if normal part + begin + FLines.AddStrings(FPartBody); + Flines.Add(''); + end; +end; + +{==============================================================================} + +procedure TMIMEPart.DecodePart; +const + CRLF = #13#10; +var + n: Integer; + s: string; +begin + FDecodedLines.Clear; + for n := 0 to FPartBody.Count - 1 do + begin + s := FPartBody[n]; + case FEncodingCode of + ME_7BIT: + begin + if FPrimaryCode = MP_TEXT then + s := CharsetConversion(s, FCharsetCode, FTargetCharset); + s := s + CRLF; + end; + ME_8BIT: + begin + if FPrimaryCode = MP_TEXT then + s := CharsetConversion(s, FCharsetCode, FTargetCharset); + s := s + CRLF; + end; + ME_QUOTED_PRINTABLE: + begin + if s = '' then + s := CRLF + else + if s[Length(s)] <> '=' then + s := s + CRLF; + s := DecodeQuotedPrintable(s); + if FPrimaryCode = MP_TEXT then + s := CharsetConversion(s, FCharsetCode, FTargetCharset); + end; + ME_BASE64: + begin + if s <> '' then + s := DecodeBase64(s); + if FPrimaryCode = MP_TEXT then + s := CharsetConversion(s, FCharsetCode, FTargetCharset); + end; + ME_UU: + if s <> '' then + s := DecodeUU(s); + ME_XX: + if s <> '' then + s := DecodeXX(s); + end; + FDecodedLines.Write(Pointer(s)^, Length(s)); + end; + FDecodedLines.Seek(0, soFromBeginning); +end; + +{==============================================================================} + +procedure TMIMEPart.DecodePartHeader; +var + n: integer; + s, su, fn: string; + st, st2: string; +begin + Primary := 'text'; + FSecondary := 'plain'; + FDescription := ''; + Charset := FDefaultCharset; + FFileName := ''; + Encoding := '7BIT'; + FDisposition := ''; + FContentID := ''; + fn := ''; + for n := 0 to FHeaders.Count - 1 do + if FHeaders[n] <> '' then + begin + s := FHeaders[n]; su := UpperCase(s); if Pos('CONTENT-TYPE:', su) = 1 then begin @@ -271,141 +592,10 @@ begin if Pos('CONTENT-ID:', su) = 1 then FContentID := SeparateRight(s, ':'); end; - - if (PrimaryCode = MP_BINARY) and (FFileName = '') then - FFileName := fn; - FFileName := InlineDecode(FFileName, getCurCP); - FFileName := ExtractFileName(FFileName); - - { finding part content x1-begin x2-end } - x1 := x; - x2 := Value.Count - 1; - { if multipart - end is before next boundary } - if b <> '' then - begin - for n := x to Value.Count - 1 do - begin - x2 := n; - s := Value[n]; - if Pos('--' + b, s) = 1 then - begin - Dec(x2); - Break; - end; - end; - end; - { if content is multipart - content is delimited by their boundaries } - if FPrimaryCode = MP_MULTIPART then - begin - for n := x to Value.Count - 1 do - begin - s := Value[n]; - if Pos('--' + FBoundary, s) = 1 then - begin - x1 := n; - Break; - end; - end; - for n := Value.Count - 1 downto x do - begin - s := Value[n]; - if Pos('--' + FBoundary, s) = 1 then - begin - x2 := n; - Break; - end; - end; - end; - { copy content } - for n := x1 to x2 do - FLines.Add(Value[n]); - Result := x2; - { if content is multipart - find real end } - if FPrimaryCode = MP_MULTIPART then - begin - e := False; - for n := x2 + 1 to Value.Count - 1 do - if Pos('--' + b, Value[n]) = 1 then - begin - e := True; - Break; - end; - if not e then - Result := Value.Count - 1; - end; - { if multipart - skip ending postpart} - if b <> '' then - begin - x1 := Result; - for n := x1 to Value.Count - 1 do - begin - s := Value[n]; - if Pos('--' + b, s) = 1 then - begin - s := TrimRight(s); - if s = ('--' + b + '--') then - if FSkipLast then - Result := Value.Count - 1 - else - Result := n + 1; - Break; - end; - end; - end; - finally - t.Free; - end; -end; - -{==============================================================================} - -procedure TMIMEPart.DecodePart; -const - CRLF = #13#10; -var - n: Integer; - s: string; -begin - FDecodedLines.Clear; - for n := 0 to FLines.Count - 1 do - begin - s := FLines[n]; - case FEncodingCode of - ME_7BIT: - s := s + CRLF; - ME_8BIT: - begin - s := CharsetConversion(s, FCharsetCode, FTargetCharset); - s := s + CRLF; - end; - ME_QUOTED_PRINTABLE: - begin - if s = '' then - s := CRLF - else - if s[Length(s)] <> '=' then - s := s + CRLF; - s := DecodeQuotedPrintable(s); - if FPrimaryCode = MP_TEXT then - s := CharsetConversion(s, FCharsetCode, FTargetCharset); - end; - ME_BASE64: - begin - if s <> '' then - s := DecodeBase64(s); - if FPrimaryCode = MP_TEXT then - s := CharsetConversion(s, FCharsetCode, FTargetCharset); - end; - ME_UU: - if s <> '' then - s := DecodeUU(s); - ME_XX: - if s <> '' then - s := DecodeXX(s); - end; - FDecodedLines.Write(Pointer(s)^, Length(s)); - end; - FDecodedLines.Seek(0, soFromBeginning); + if (PrimaryCode = MP_BINARY) and (FFileName = '') then + FFileName := fn; + FFileName := InlineDecode(FFileName, getCurCP); + FFileName := ExtractFileName(FFileName); end; {==============================================================================} @@ -416,18 +606,16 @@ var s, t: string; n, x: Integer; d1, d2: integer; -const - MaxLine = 75; begin if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then Encoding := 'base64'; l := TStringList.Create; - FLines.Clear; + FPartBody.Clear; FDecodedLines.Seek(0, soFromBeginning); try case FPrimaryCode of MP_MULTIPART, MP_MESSAGE: - FLines.LoadFromStream(FDecodedLines); + FPartBody.LoadFromStream(FDecodedLines); MP_TEXT, MP_BINARY: if FEncodingCode = ME_BASE64 then begin @@ -439,7 +627,7 @@ begin if FPrimaryCode = MP_TEXT then s := CharsetConversion(s, FTargetCharset, FCharsetCode); s := EncodeBase64(s); - FLines.Add(s); + FPartBody.Add(s); end; end else @@ -454,85 +642,37 @@ begin begin s := EncodeQuotedPrintable(s); repeat - if Length(s) < MaxLine then + if Length(s) < FMaxLineLength then begin t := s; s := ''; end else begin - d1 := RPosEx('=', s, MaxLine); - d2 := RPosEx(' ', s, MaxLine); + d1 := RPosEx('=', s, FMaxLineLength); + d2 := RPosEx(' ', s, FMaxLineLength); if (d1 = 0) and (d2 = 0) then - x := MaxLine + x := FMaxLineLength else if d1 > d2 then x := d1 - 1 else x := d2 - 1; + if x = 0 then + x := FMaxLineLength; t := Copy(s, 1, x); s := Copy(s, x + 1, Length(s) - x); if s <> '' then t := t + '='; end; - FLines.Add(t); + FPartBody.Add(t); until s = ''; end else - FLines.Add(s); + FPartBody.Add(s); end; end; end; - FLines.Add(''); - FLines.Insert(0, ''); - if FSecondary = '' then - case FPrimaryCode of - MP_TEXT: - FSecondary := 'plain'; - MP_MULTIPART: - FSecondary := 'mixed'; - MP_MESSAGE: - FSecondary := 'rfc822'; - MP_BINARY: - FSecondary := 'octet-stream'; - end; - if FDescription <> '' then - FLines.Insert(0, 'Content-Description: ' + FDescription); - if FDisposition <> '' then - begin - s := ''; - if FFileName <> '' then - s := '; FileName="' + FFileName + '"'; - FLines.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s); - end; - if FContentID <> '' then - FLines.Insert(0, 'Content-ID: ' + FContentID); - - case FEncodingCode of - ME_7BIT: - s := '7bit'; - ME_8BIT: - s := '8bit'; - ME_QUOTED_PRINTABLE: - s := 'Quoted-printable'; - ME_BASE64: - s := 'Base64'; - end; - case FPrimaryCode of - MP_TEXT, - MP_BINARY: FLines.Insert(0, 'Content-Transfer-Encoding: ' + s); - end; - case FPrimaryCode of - MP_TEXT: - s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode); - MP_MULTIPART: - s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"'; - MP_MESSAGE: - s := FPrimary + '/' + FSecondary + ''; - MP_BINARY: - s := FPrimary + '/' + FSecondary + '; name="' + FFileName + '"'; - end; - FLines.Insert(0, 'Content-type: ' + s); finally l.Free; end; @@ -540,6 +680,63 @@ end; {==============================================================================} +procedure TMIMEPart.EncodePartHeader; +var + s: string; +begin + FHeaders.Clear; + if FSecondary = '' then + case FPrimaryCode of + MP_TEXT: + FSecondary := 'plain'; + MP_MULTIPART: + FSecondary := 'mixed'; + MP_MESSAGE: + FSecondary := 'rfc822'; + MP_BINARY: + FSecondary := 'octet-stream'; + end; + if FDescription <> '' then + FHeaders.Insert(0, 'Content-Description: ' + FDescription); + if FDisposition <> '' then + begin + s := ''; + if FFileName <> '' then + s := '; FileName="' + FFileName + '"'; + FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s); + end; + if FContentID <> '' then + FHeaders.Insert(0, 'Content-ID: ' + FContentID); + + case FEncodingCode of + ME_7BIT: + s := '7bit'; + ME_8BIT: + s := '8bit'; + ME_QUOTED_PRINTABLE: + s := 'Quoted-printable'; + ME_BASE64: + s := 'Base64'; + end; + case FPrimaryCode of + MP_TEXT, + MP_BINARY: FHeaders.Insert(0, 'Content-Transfer-Encoding: ' + s); + end; + case FPrimaryCode of + MP_TEXT: + s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode); + MP_MULTIPART: + s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"'; + MP_MESSAGE: + s := FPrimary + '/' + FSecondary + ''; + MP_BINARY: + s := FPrimary + '/' + FSecondary + '; name="' + FFileName + '"'; + end; + FHeaders.Insert(0, 'Content-type: ' + s); +end; + +{==============================================================================} + procedure TMIMEPart.MimeTypeFromExt(Value: string); var s: string; @@ -566,6 +763,25 @@ end; {==============================================================================} +procedure TMIMEPart.WalkPart; +var + n: integer; + m: TMimepart; +begin + if assigned(OnWalkPart) then + begin + OnWalkPart(self); + for n := 0 to GetSubPartCount - 1 do + begin + m := GetSubPart(n); + m.OnWalkPart := OnWalkPart; + m.WalkPart; + end; + end; +end; + +{==============================================================================} + procedure TMIMEPart.SetPrimary(Value: string); var s: string; @@ -612,9 +828,10 @@ function GenerateBoundary: string; var x: Integer; begin + Sleep(1); Randomize; x := Random(MaxInt); - Result := '--' + IntToHex(x, 8) + '_Synapse_message_boundary'; + Result := IntToHex(x, 8) + '_Synapse_message_boundary'; end; end. diff --git a/nntpsend.pas b/nntpsend.pas index 9d73422..3a6d4e5 100644 --- a/nntpsend.pas +++ b/nntpsend.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.000.000 | +| Project : Delphree - Synapse | 001.001.000 | |==============================================================================| | Content: NNTP client | |==============================================================================| -| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001. | @@ -37,12 +56,9 @@ const cNNTPProtocol = 'nntp'; type - TNNTPSend = class(TObject) + TNNTPSend = class(TSynaClient) private FSock: TTCPBlockSocket; - FTimeout: Integer; - FNNTPHost: string; - FNNTPPort: string; FResultCode: Integer; FResultString: string; FData: TStringList; @@ -69,9 +85,6 @@ type function PostArticle: Boolean; function SwitchToSlave: Boolean; published - property Timeout: Integer read FTimeout Write FTimeout; - property NNTPHost: string read FNNTPHost Write FNNTPHost; - property NNTPPort: string read FNNTPPort Write FNNTPPort; property ResultCode: Integer read FResultCode; property ResultString: string read FResultString; property Data: TStringList read FData; @@ -89,9 +102,9 @@ begin FData := TStringList.Create; FSock := TTCPBlockSocket.Create; FSock.CreateSocket; + FSock.ConvertLineEnd := True; FTimeout := 300000; - FNNTPhost := cLocalhost; - FNNTPPort := cNNTPProtocol; + FTargetPort := cNNTPProtocol; end; destructor TNNTPSend.Destroy; @@ -120,7 +133,6 @@ function TNNTPSend.ReadData: boolean; var s: string; begin - Result := False; repeat s := FSock.RecvString(FTimeout); if s = '.' then @@ -137,7 +149,6 @@ var s: string; n: integer; begin - Result := False; for n := 0 to FData.Count -1 do begin s := FData[n]; @@ -154,7 +165,8 @@ function TNNTPSend.Connect: Boolean; begin FSock.CloseSocket; FSock.CreateSocket; - FSock.Connect(FNNTPHost, FNNTPPort); + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); Result := FSock.LastError = 0; end; diff --git a/pingsend.pas b/pingsend.pas index 13cde86..626bfb5 100644 --- a/pingsend.pas +++ b/pingsend.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.002.000 | +| Project : Delphree - Synapse | 002.003.001 | |==============================================================================| | Content: PING sender | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2000,2001. | @@ -59,13 +78,12 @@ type TimeStamp: ULONG; end; - TPINGSend = class(TObject) + TPINGSend = class(TSynaClient) private FSock: TICMPBlockSocket; FBuffer: string; FSeq: Integer; FId: Integer; - FTimeout: Integer; FPacketSize: Integer; FPingTime: Integer; function Checksum: Integer; @@ -75,7 +93,6 @@ type constructor Create; destructor Destroy; override; published - property Timeout: Integer read FTimeout Write FTimeout; property PacketSize: Integer read FPacketSize Write FPacketSize; property PingTime: Integer read FPingTime; property Sock: TICMPBlockSocket read FSock; @@ -119,6 +136,7 @@ var t: Boolean; begin Result := False; + FSock.Bind(FIPInterface, cAnyPort); FSock.Connect(Host, '0'); FBuffer := StringOfChar(#0, SizeOf(TICMPEchoHeader) + FPacketSize); IcmpEchoHeaderPtr := Pointer(FBuffer); @@ -144,7 +162,7 @@ begin IPHeadPtr := Pointer(FBuffer); IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4; IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1]; - until IcmpEchoHeaderPtr^.i_type <> ICMP_ECHO; + until (IcmpEchoHeaderPtr^.i_type <> ICMP_ECHO) and (IcmpEchoHeaderPtr^.i_id = FId); //it discard sometimes possible 'echoes' of previosly sended packet... if t then if (IcmpEchoHeaderPtr^.i_type = ICMP_ECHOREPLY) then diff --git a/pop3send.pas b/pop3send.pas index 5151bc8..9b66e76 100644 --- a/pop3send.pas +++ b/pop3send.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.000.000 | +| Project : Delphree - Synapse | 002.001.000 | |==============================================================================| | Content: POP3 client | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2001-2002. | @@ -45,12 +64,9 @@ const type TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP); - TPOP3Send = class(TObject) + TPOP3Send = class(TSynaClient) private FSock: TTCPBlockSocket; - FTimeout: Integer; - FPOP3Host: string; - FPOP3Port: string; FResultCode: Integer; FResultString: string; FFullResult: TStringList; @@ -84,9 +100,6 @@ type function StartTLS: Boolean; function FindCap(const Value: string): string; published - property Timeout: Integer read FTimeout Write FTimeout; - property POP3Host: string read FPOP3Host Write FPOP3Host; - property POP3Port: string read FPOP3Port Write FPOP3Port; property ResultCode: Integer read FResultCode; property ResultString: string read FResultString; property FullResult: TStringList read FFullResult; @@ -113,9 +126,9 @@ begin FPOP3cap := TStringList.Create; FSock := TTCPBlockSocket.Create; FSock.CreateSocket; + FSock.ConvertLineEnd := True; FTimeout := 300000; - FPOP3host := cLocalhost; - FPOP3Port := cPop3Protocol; + FTargetPort := cPop3Protocol; FUsername := ''; FPassword := ''; FStatCount := 0; @@ -182,7 +195,8 @@ begin FSock.CreateSocket; if FFullSSL then FSock.SSLEnabled := True; - FSock.Connect(POP3Host, POP3Port); + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); Result := FSock.LastError = 0; end; diff --git a/slogsend.pas b/slogsend.pas index 0d935b4..7cd1b4c 100644 --- a/slogsend.pas +++ b/slogsend.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.000.001 | +| Project : Delphree - Synapse | 001.001.000 | |==============================================================================| | Content: SysLog client | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2001. | @@ -68,10 +87,8 @@ type TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info, Debug); - TSyslogSend = class(TObject) + TSyslogSend = class(TSynaClient) private - FSyslogHost: string; - FSyslogPort: string; FSock: TUDPBlockSocket; FFacility: Byte; FSeverity: TSyslogSeverity; @@ -82,8 +99,6 @@ type destructor Destroy; override; function DoIt: Boolean; published - property SyslogHost: string read FSyslogHost Write FSyslogHost; - property SyslogPort: string read FSyslogPort Write FSyslogPort; property Facility: Byte read FFacility Write FFacility; property Severity: TSyslogSeverity read FSeverity Write FSeverity; property Tag: string read FTag Write FTag; @@ -100,12 +115,12 @@ begin inherited Create; FSock := TUDPBlockSocket.Create; FSock.CreateSocket; - FSyslogHost := cLocalhost; - FSyslogPort := cSysLogProtocol; + FTargetPort := cSysLogProtocol; FFacility := FCL_Local0; FSeverity := Debug; FTag := ExtractFileName(ParamStr(0)); FMessage := ''; + FIPInterface := cAnyHost; end; destructor TSyslogSend.Destroy; @@ -138,8 +153,10 @@ begin if Length(Buf) <= 1024 then begin if FSock.EnableReuse(True) then - Fsock.Bind('0.0.0.0', FSyslogPort); - FSock.Connect(FSyslogHost, FSyslogPort); + Fsock.Bind(FIPInterface, FTargetPort) + else + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); FSock.SendString(Buf); Result := FSock.LastError = 0; end; @@ -153,7 +170,7 @@ begin Result := False; with TSyslogSend.Create do try - SyslogHost :=SyslogServer; + TargetHost :=SyslogServer; Facility := Facil; Severity := Sever; LogMessage := Content; diff --git a/smtpsend.pas b/smtpsend.pas index 9b741cb..5c6808d 100644 --- a/smtpsend.pas +++ b/smtpsend.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 003.001.000 | +| Project : Delphree - Synapse | 003.002.001 | |==============================================================================| | Content: SMTP client | |==============================================================================| -| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c) 1999-2002. | @@ -37,12 +56,9 @@ const cSmtpProtocol = 'smtp'; type - TSMTPSend = class(TObject) + TSMTPSend = class(TSynaClient) private FSock: TTCPBlockSocket; - FTimeout: Integer; - FSMTPHost: string; - FSMTPPort: string; FResultCode: Integer; FResultString: string; FFullResult: TStringList; @@ -82,9 +98,6 @@ type function EnhCodeString: string; function FindCap(const Value: string): string; published - property Timeout: Integer read FTimeout Write FTimeout; - property SMTPHost: string read FSMTPHost Write FSMTPHost; - property SMTPPort: string read FSMTPPort Write FSMTPPort; property ResultCode: Integer read FResultCode; property ResultString: string read FResultString; property FullResult: TStringList read FFullResult; @@ -123,9 +136,9 @@ begin FESMTPcap := TStringList.Create; FSock := TTCPBlockSocket.Create; FSock.CreateSocket; + FSock.ConvertLineEnd := True; FTimeout := 300000; - FSMTPhost := cLocalhost; - FSMTPPort := cSmtpProtocol; + FTargetPort := cSmtpProtocol; FUsername := ''; FPassword := ''; FSystemName := FSock.LocalName; @@ -232,7 +245,8 @@ begin FSock.CreateSocket; if FFullSSL then FSock.SSLEnabled := True; - FSock.Connect(FSMTPHost, FSMTPPort); + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); Result := FSock.LastError = 0; end; @@ -302,8 +316,6 @@ begin if (Pos('LOGIN', auths) > 0) and (not FauthDone) then FAuthDone := AuthLogin; end; - if FAuthDone then - Ehlo; end; s := FindCap('SIZE'); if s <> '' then @@ -498,10 +510,10 @@ begin // SMTP.AutoTLS := True; // if you need support for TSL/SSL tunnel, uncomment next lines: // SMTP.FullSSL := True; - SMTP.SMTPHost := SeparateLeft(SMTPHost, ':'); + SMTP.TargetHost := SeparateLeft(SMTPHost, ':'); s := SeparateRight(SMTPHost, ':'); if (s <> '') and (s <> SMTPHost) then - SMTP.SMTPPort := s; + SMTP.TargetPort := s; SMTP.Username := Username; SMTP.Password := Password; if SMTP.Login then diff --git a/snmpsend.pas b/snmpsend.pas index dc80cea..eede4da 100644 --- a/snmpsend.pas +++ b/snmpsend.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.003.006 | +| Project : Delphree - Synapse | 002.005.000 | |==============================================================================| | Content: SNMP client | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2000,2001. | @@ -93,12 +112,10 @@ type property SNMPMibList: TList read FSNMPMibList; end; - TSNMPSend = class(TObject) + TSNMPSend = class(TSynaClient) private FSock: TUDPBlockSocket; FBuffer: string; - FTimeout: Integer; - FHost: string; FHostIP: string; FQuery: TSNMPRec; FReply: TSNMPRec; @@ -107,8 +124,6 @@ type destructor Destroy; override; function DoIt: Boolean; published - property Timeout: Integer read FTimeout write FTimeout; - property Host: string read FHost write FHost; property HostIP: string read FHostIP; property Query: TSNMPRec read FQuery; property Reply: TSNMPRec read FReply; @@ -117,6 +132,9 @@ type function SNMPGet(const OID, Community, SNMPHost: string; var Value: string): Boolean; function SNMPSet(const OID, Community, SNMPHost, Value: string; ValueType: Integer): Boolean; +function SNMPGetNext(var OID: string; const Community, SNMPHost: string; var Value: string): Boolean; +function SNMPGetTable(const BaseOID, Community, SNMPHost: string; const Value: TStrings): Boolean; +function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: string; var Value: String): Boolean; implementation @@ -278,7 +296,7 @@ begin FSock := TUDPBlockSocket.Create; FSock.CreateSocket; FTimeout := 5000; - FHost := cLocalhost; + FTargetPort := cSnmpProtocol; FHostIP := ''; end; @@ -294,8 +312,9 @@ function TSNMPSend.DoIt: Boolean; begin FReply.Clear; FBuffer := FQuery.EncodeBuf; - FSock.Connect(FHost, cSnmpProtocol); - FHostIP := '0.0.0.0'; + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + FHostIP := cAnyHost; FSock.SendString(FBuffer); FBuffer := FSock.RecvPacket(FTimeout); if FSock.LastError = 0 then @@ -319,12 +338,11 @@ begin SNMPSend.Query.Community := Community; SNMPSend.Query.PDUType := PDUGetRequest; SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL); - SNMPSend.Host := SNMPHost; + SNMPSend.TargetHost := SNMPHost; Result := SNMPSend.DoIt; + Value := ''; if Result then - Value := SNMPSend.Reply.MIBGet(OID) - else - Value := ''; + Value := SNMPSend.Reply.MIBGet(OID); finally SNMPSend.Free; end; @@ -340,13 +358,79 @@ begin SNMPSend.Query.Community := Community; SNMPSend.Query.PDUType := PDUSetRequest; SNMPSend.Query.MIBAdd(OID, Value, ValueType); - SNMPSend.Host := SNMPHost; + SNMPSend.TargetHost := SNMPHost; Result := SNMPSend.DoIt = True; finally SNMPSend.Free; end; end; +function SNMPGetNext(var OID: string; const Community, SNMPHost: string; var Value: string): Boolean; +var + SNMPSend: TSNMPSend; +begin + SNMPSend := TSNMPSend.Create; + try + SNMPSend.Query.Clear; + SNMPSend.Query.Community := Community; + SNMPSend.Query.PDUType := PDUGetNextRequest; + SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL); + SNMPSend.TargetHost := SNMPHost; + Result := SNMPSend.DoIt; + Value := ''; + if Result then + if SNMPSend.Reply.SNMPMibList.Count > 0 then + begin + OID := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).OID; + Value := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).Value; + end; + finally + SNMPSend.Free; + end; +end; + +function SNMPGetTable(const BaseOID, Community, SNMPHost: string; const Value: TStrings): Boolean; +var + OID: string; + s: string; + col,row: string; + lastcol: string; + x, n: integer; +begin + Value.Clear; + OID := BaseOID; + lastcol := ''; + x := 0; + repeat + Result := SNMPGetNext(OID, Community, SNMPHost, s); + if Pos(BaseOID, OID) <> 1 then + break; + row := separateright(oid, baseoid + '.'); + col := fetch(row, '.'); + if col = lastcol then + inc(x) + else + x:=0; + lastcol := col; + if value.count <= x then + for n := value.Count - 1 to x do + value.add(''); + if value[x] <> '' then + value[x] := value[x] + ','; + if IsBinaryString(s) then + s := StrToHex(s); + value[x] := value[x] + AnsiQuotedStr(s, '"'); + until not result; +end; + +function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: string; var Value: String): Boolean; +var + s: string; +begin + s := BaseOID + '.' + ColID + '.' + RowID; + Result := SnmpGet(s, Community, SNMPHost, Value); +end; + end. diff --git a/snmptrap.pas b/snmptrap.pas index 5cc87e9..e75862c 100644 --- a/snmptrap.pas +++ b/snmptrap.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.002.004 | +| Project : Delphree - Synapse | 002.003.000 | |==============================================================================| | Content: SNMP traps | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Hernan Sanchez are Copyright (c)2000,2001. | @@ -50,7 +69,6 @@ type TTrapPDU = class(TObject) private FBuffer: string; - FTrapPort: string; FVersion: Integer; FPDUType: Integer; FCommunity: string; @@ -73,7 +91,6 @@ type property Version: Integer read FVersion Write FVersion; property Community: string read FCommunity Write FCommunity; property PDUType: Integer read FPDUType Write FPDUType; - property TrapPort: string read FTrapPort Write FTrapPort; property Enterprise: string read FEnterprise Write FEnterprise; property TrapHost: string read FTrapHost Write FTrapHost; property GenTrap: Integer read FGenTrap Write FGenTrap; @@ -82,12 +99,10 @@ type property SNMPMibList: TList read FSNMPMibList; end; - TTrapSNMP = class(TObject) + TTrapSNMP = class(TSynaClient) private FSock: TUDPBlockSocket; FTrap: TTrapPDU; - FSNMPHost: string; - FTimeout: Integer; public constructor Create; destructor Destroy; override; @@ -95,8 +110,6 @@ type function Recv: Integer; published property Trap: TTrapPDU read FTrap; - property SNMPHost: string read FSNMPHost Write FSNMPHost; - property Timeout: Integer read FTimeout Write FTimeout; property Sock: TUDPBlockSocket read FSock; end; @@ -113,7 +126,6 @@ constructor TTrapPDU.Create; begin inherited Create; FSNMPMibList := TList.Create; - FTrapPort := cSnmpTrapProtocol; FVersion := SNMP_VERSION; FPDUType := PDU_TRAP; FCommunity := 'public'; @@ -136,7 +148,6 @@ begin for i := 0 to FSNMPMibList.Count - 1 do TSNMPMib(FSNMPMibList[i]).Free; FSNMPMibList.Clear; - FTrapPort := cSnmpTrapProtocol; FVersion := SNMP_VERSION; FPDUType := PDU_TRAP; FCommunity := 'public'; @@ -261,10 +272,10 @@ constructor TTrapSNMP.Create; begin inherited Create; FSock := TUDPBlockSocket.Create; + FSock.CreateSocket; FTrap := TTrapPDU.Create; FTimeout := 5000; - FSNMPHost := cLocalhost; - FSock.CreateSocket; + FTargetPort := cSnmpTrapProtocol; end; destructor TTrapSNMP.Destroy; @@ -277,7 +288,8 @@ end; function TTrapSNMP.Send: Integer; begin FTrap.EncodeTrap; - FSock.Connect(SNMPHost, FTrap.TrapPort); + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); FSock.SendString(FTrap.FBuffer); Result := 1; end; @@ -285,7 +297,7 @@ end; function TTrapSNMP.Recv: Integer; begin Result := 0; - FSock.Bind('0.0.0.0', FTrap.TrapPort); + FSock.Bind(FIPInterface, FTargetPort); FTrap.FBuffer := FSock.RecvPacket(FTimeout); if Fsock.Lasterror = 0 then if FTrap.DecodeTrap then @@ -298,7 +310,7 @@ function SendTrap(const Dest, Source, Enterprise, Community: string; begin with TTrapSNMP.Create do try - SNMPHost := Dest; + TargetHost := Dest; Trap.TrapHost := Source; Trap.Enterprise := Enterprise; Trap.Community := Community; @@ -320,11 +332,11 @@ var begin with TTrapSNMP.Create do try - SNMPHost := Dest; + TargetHost := Dest; Result := Recv; if Result <> 0 then begin - Dest := SNMPHost; + Dest := TargetHost; Source := Trap.TrapHost; Enterprise := Trap.Enterprise; Community := Trap.Community; diff --git a/sntpsend.pas b/sntpsend.pas index c7d3bf7..d64aeba 100644 --- a/sntpsend.pas +++ b/sntpsend.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.001.000 | +| Project : Delphree - Synapse | 002.002.000 | |==============================================================================| | Content: SNTP client | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2000,2001. | @@ -58,7 +77,7 @@ type Xmit2: Longint; end; - TSNTPSend = class(TObject) + TSNTPSend = class(TSynaClient) private FNTPReply: TNtp; FNTPTime: TDateTime; @@ -66,8 +85,6 @@ type FNTPDelay: double; FMaxSyncDiff: double; FSyncTime: Boolean; - FSntpHost: string; - FTimeout: Integer; FSock: TUDPBlockSocket; FBuffer: string; FLi, FVn, Fmode : byte; @@ -86,8 +103,6 @@ type property NTPDelay: Double read FNTPDelay; property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff; property SyncTime: Boolean read FSyncTime write FSyncTime; - property SntpHost: string read FSntpHost write FSntpHost; - property Timeout: Integer read FTimeout write FTimeout; property Sock: TUDPBlockSocket read FSock; end; @@ -99,7 +114,7 @@ begin FSock := TUDPBlockSocket.Create; FSock.CreateSocket; FTimeout := 5000; - FSntpHost := cLocalhost; + FTargetPort := cNtpProtocol; FMaxSyncDiff := 3600; FSyncTime := False; end; @@ -158,12 +173,12 @@ var x: Integer; begin Result := False; - FSock.Bind('0.0.0.0', cNtpProtocol); + FSock.Bind(FIPInterface, cAnyPort); FBuffer := FSock.RecvPacket(FTimeout); if FSock.LastError = 0 then begin x := Length(FBuffer); - if (SntpHost = '0.0.0.0') or (FSock.GetRemoteSinIP = SntpHost) then + if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FTargetHost) then if x >= SizeOf(NTPReply) then begin NtpPtr := Pointer(FBuffer); @@ -183,7 +198,8 @@ var x: Integer; begin Result := False; - FSock.Connect(sntphost, cNtpProtocol); + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); FillChar(q, SizeOf(q), 0); q.mode := $1B; FSock.SendBuffer(@q, SizeOf(q)); @@ -211,7 +227,8 @@ var t1, t2, t3, t4 : TDateTime; begin Result := False; - FSock.Connect(sntphost, cNtpProtocol); + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); FillChar(q, SizeOf(q), 0); q.mode := $1B; t1 := GetUTTime; diff --git a/synachar.pas b/synachar.pas index 2206a85..263ac73 100644 --- a/synachar.pas +++ b/synachar.pas @@ -3,15 +3,34 @@ |==============================================================================| | Content: Charset conversion support | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2000,2001. | diff --git a/synacode.pas b/synacode.pas index 4c4d844..17accb5 100644 --- a/synacode.pas +++ b/synacode.pas @@ -3,15 +3,34 @@ |==============================================================================| | Content: Coding and decoding support | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2000-2002. | diff --git a/synassl.pas b/synassl.pas index 76ef390..a7cc178 100644 --- a/synassl.pas +++ b/synassl.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.004.000 | +| Project : Delphree - Synapse | 001.006.000 | |==============================================================================| | Content: SSL support | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2002. | @@ -22,6 +41,11 @@ | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{ +Special thanks to Gregor Ibic + (Intelicom d.o.o., http://www.intelicom.si) + for good inspiration about SSL programming. +} unit SynaSSL; @@ -55,6 +79,8 @@ type const EVP_MAX_MD_SIZE = 16+20; + SSL_ERROR_NONE = 0; + SSL_ERROR_SSL = 1; SSL_ERROR_WANT_READ = 2; SSL_ERROR_WANT_WRITE = 3; SSL_ERROR_ZERO_RETURN = 6; @@ -62,12 +88,14 @@ const SSL_OP_NO_SSLv3 = $02000000; SSL_OP_NO_TLSv1 = $04000000; SSL_OP_ALL = $000FFFFF; + SSL_VERIFY_NONE = $00; + SSL_VERIFY_PEER = $01; var SSLLibHandle: Integer = 0; SSLUtilHandle: Integer = 0; -// ssleay.dll +// libssl.dll SslGetError : function(s: PSSL; ret_code: Integer):Integer cdecl = nil; SslLibraryInit : function:Integer cdecl = nil; SslLoadErrorStrings : procedure cdecl = nil; @@ -90,8 +118,10 @@ var SslRead : function(ssl: PSSL; buf: PChar; num: Integer):Integer cdecl = nil; SslPeek : function(ssl: PSSL; buf: PChar; num: Integer):Integer cdecl = nil; SslWrite : function(ssl: PSSL; const buf: PChar; num: Integer):Integer cdecl = nil; + SslPending : function(ssl: PSSL):Integer cdecl = nil; SslGetVersion : function(ssl: PSSL):PChar cdecl = nil; SslGetPeerCertificate : function(ssl: PSSL):PX509 cdecl = nil; + SslCtxSetVerify : procedure(ctx: PSSL_CTX; mode: Integer; arg2: Pointer) cdecl = nil; // libeay.dll SslX509Free : procedure(x: PX509) cdecl = nil; @@ -101,6 +131,9 @@ var SslX509NameHash : function(x: PX509_NAME):Cardinal cdecl = nil; SslX509Digest : function(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer cdecl = nil; SslEvpMd5 : function:PEVP_MD cdecl = nil; + ErrErrorString : function(e: integer; buf: PChar): PChar cdecl = nil; + ErrGetError : function: integer cdecl = nil; + ErrClearError : procedure cdecl = nil; function InitSSLInterface: Boolean; function DestroySSLInterface: Boolean; @@ -153,8 +186,10 @@ begin SslRead := GetProcAddress(SSLLibHandle, PChar('SSL_read')); SslPeek := GetProcAddress(SSLLibHandle, PChar('SSL_peek')); SslWrite := GetProcAddress(SSLLibHandle, PChar('SSL_write')); + SslPending := GetProcAddress(SSLLibHandle, PChar('SSL_pending')); SslGetPeerCertificate := GetProcAddress(SSLLibHandle, PChar('SSL_get_peer_certificate')); SslGetVersion := GetProcAddress(SSLLibHandle, PChar('SSL_get_version')); + SslCtxSetVerify := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_verify')); SslX509Free := GetProcAddress(SSLUtilHandle, PChar('X509_free')); SslX509NameOneline := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_oneline')); @@ -163,6 +198,9 @@ begin SslX509NameHash := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_hash')); SslX509Digest := GetProcAddress(SSLUtilHandle, PChar('X509_digest')); SslEvpMd5 := GetProcAddress(SSLUtilHandle, PChar('EVP_md5')); + ErrerrorString := GetProcAddress(SSLUtilHandle, PChar('ERR_error_string')); + ErrGetError := GetProcAddress(SSLUtilHandle, PChar('ERR_get_error')); + ErrClearError := GetProcAddress(SSLUtilHandle, PChar('ERR_clear_error')); Result := True; end; diff --git a/synautil.pas b/synautil.pas index c60f0f8..bfde498 100644 --- a/synautil.pas +++ b/synautil.pas @@ -1,17 +1,36 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.011.001 | +| Project : Delphree - Synapse | 003.002.001 | |==============================================================================| | Content: support procedures and functions | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c) 1999-2002. | @@ -62,6 +81,8 @@ procedure DumpEx(const Buffer, DumpFile: string); function SeparateLeft(const Value, Delimiter: string): string; function SeparateRight(const Value, Delimiter: string): string; function GetParameter(const Value, Parameter: string): string; +procedure ParseParameters(Value: string; const Parameters: TStrings); +function IndexByBegin(Value: string; const List: TStrings): integer; function GetEmailAddr(const Value: string): string; function GetEmailDesc(Value: string): string; function StrToHex(const Value: string): string; @@ -73,45 +94,22 @@ function StringReplace(Value, Search, Replace: string): string; function RPosEx(const Sub, Value: string; From: integer): Integer; function RPos(const Sub, Value: String): Integer; function Fetch(var Value: string; const Delimiter: string): string; +function IsBinaryString(const Value: string): Boolean; +function PosCRLF(const Value: string; var Terminator: string): integer; +Procedure StringsTrim(const value: TStrings); +function PosFrom(const SubStr, Value: String; From: integer): integer; implementation + {==============================================================================} -var - SaveDayNames: array[1..7] of string; - SaveMonthNames: array[1..12] of string; + const MyDayNames: array[1..7] of string = - ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'); + ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'); MyMonthNames: array[1..12] of string = - ('Jan', 'Feb', 'Mar', 'Apr', - 'May', 'Jun', 'Jul', 'Aug', - 'Sep', 'Oct', 'Nov', 'Dec'); + ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', + 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'); -procedure SaveNames; -var - I: integer; -begin - for I := Low(ShortDayNames) to High(ShortDayNames) do - begin - SaveDayNames[I] := ShortDayNames[I]; - ShortDayNames[I] := MyDayNames[I]; - end; - for I := Low(ShortMonthNames) to High(ShortMonthNames) do - begin - SaveMonthNames[I] := ShortMonthNames[I]; - ShortMonthNames[I] := MyMonthNames[I]; - end; -end; - -procedure RestoreNames; -var - I: integer; -begin - for I := Low(ShortDayNames) to High(ShortDayNames) do - ShortDayNames[I] := SaveDayNames[I]; - for I := Low(ShortMonthNames) to High(ShortMonthNames) do - ShortMonthNames[I] := SaveMonthNames[I]; -end; {==============================================================================} function TimeZoneBias: integer; @@ -161,52 +159,41 @@ end; {==============================================================================} function Rfc822DateTime(t: TDateTime): string; +var + wYear, wMonth, wDay: word; begin - SaveNames; - try - Result := FormatDateTime('ddd, d mmm yyyy hh:nn:ss', t); - Result := Result + ' ' + Timezone; - finally - RestoreNames; - end; + DecodeDate(t, wYear, wMonth, wDay); + Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay, + MyMonthNames[wMonth], FormatDateTime('yyyy hh:nn:ss', t), TimeZone]); end; {==============================================================================} function CDateTime(t: TDateTime): string; +var + wYear, wMonth, wDay: word; begin - SaveNames; - try - Result := FormatDateTime('mmm dd hh:nn:ss', t); - if Result[5] = '0' then - Result[5] := ' '; - finally - RestoreNames; - end; + DecodeDate(t, wYear, wMonth, wDay); + Result:= Format('%s %2d %s', [MyMonthNames[wMonth], wDay, + FormatDateTime('hh:nn:ss', t)]); end; {==============================================================================} function SimpleDateTime(t: TDateTime): string; begin - SaveNames; - try - Result := FormatDateTime('yymmdd hhnnss', t); - finally - RestoreNames; - end; + Result := FormatDateTime('yymmdd hhnnss', t); end; {==============================================================================} function AnsiCDateTime(t: TDateTime): string; +var + wYear, wMonth, wDay: word; begin - SaveNames; - try - Result := FormatDateTime('ddd mmm d hh:nn:ss yyyy', t); - finally - RestoreNames; - end; + DecodeDate(t, wYear, wMonth, wDay); + Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[wMonth], + wDay, FormatDateTime('hh:nn:ss yyyy ', t)]); end; {==============================================================================} @@ -316,19 +303,17 @@ end; function GetTimeFromStr(Value: string): TDateTime; var - SaveSeparator: char; + x: integer; begin - SaveSeparator := TimeSeparator; + x := rpos(':', Value); + if (x > 0) and ((Length(Value) - x) > 2) then + Value := Copy(Value, 1, x + 2); + Value := StringReplace(Value, ':', TimeSeparator); + Result := 0; try - TimeSeparator := ':'; - Result := 0; - try - Result := StrToTime(Value); - except - on Exception do ; - end; - finally - TimeSeparator := SaveSeparator; + Result := StrToTime(Value); + except + on Exception do ; end; end; @@ -336,23 +321,27 @@ end; function GetDateMDYFromStr(Value: string): TDateTime; var - SaveSeparator: char; - SaveFormat: string; + wYear, wMonth, wDay: word; + s: string; begin - SaveSeparator := DateSeparator; - SaveFormat := ShortDateFormat; + Result := 0; + s := Fetch(Value, '-'); + wMonth := StrToIntDef(s, 12); + s := Fetch(Value, '-'); + wDay := StrToIntDef(s, 30); + wYear := StrToIntDef(Value, 1899); + if wYear < 1000 then + if (wYear > 99) then + wYear := wYear + 1900 + else + if wYear > 50 then + wYear := wYear + 1900 + else + wYear := wYear + 2000; try - DateSeparator := '-'; - ShortDateFormat := 'm-d-y'; - Result := 0; - try - Result := StrToDate(Value); - except - on Exception do ; - end; - finally - ShortDateFormat := SaveFormat; - DateSeparator := SaveSeparator; + Result := EncodeDate(wYear, wMonth, wDay); + except + on Exception do ; end; end; @@ -362,7 +351,7 @@ function DecodeRfcDateTime(Value: string): TDateTime; var day, month, year: Word; zone: integer; - x: integer; + x, y: integer; s: string; t: TDateTime; begin @@ -426,8 +415,14 @@ begin continue; end; // month - month := GetMonthNumber(s); + y := GetMonthNumber(s); + if y > 0 then + month := y; end; + if (month < 1) or (month > 12) then + month := 1; + if (day < 1) or (day > 31) then + day := 1; Result := Result + Encodedate(year, month, day); zone := zone - TimeZoneBias; t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0); @@ -523,34 +518,36 @@ end; function IsIP(const Value: string): Boolean; var - n, x, i: Integer; -begin - Result := true; - if Pos('..',Value) > 0 then - Result := False - else + TempIP: string; + + function ByteIsOk(const Value: string): Boolean; + var + x, n: integer; begin - i := 0; - x := 0; - for n := 1 to Length(Value) do - begin - if (Value[n] in ['0'..'9']) then - i := i +1 - else - if (Value[n] in ['.']) then - i := 0 - else + x := StrToIntDef(Value, -1); + Result := (x >= 0) and (x < 256); + // X may be in correct range, but value still may not be correct value! + // i.e. "$80" + if Result then + for n := 1 to length(Value) do + if not (Value[n] in ['0'..'9']) then + begin Result := False; - if Value[n] = '.' - then Inc(x); - if i > 3 then - result := False; - if result = false then - Break; - end; - if x <> 3 then - Result := False; + Break; + end; end; + +begin + TempIP := Value; + Result := False; + if not ByteIsOk(Fetch(TempIP, '.')) then + Exit; + if not ByteIsOk(Fetch(TempIP, '.')) then + Exit; + if not ByteIsOk(Fetch(TempIP, '.')) then + Exit; + if ByteIsOk(TempIP) then + Result := True; end; {==============================================================================} @@ -704,6 +701,40 @@ end; {==============================================================================} +procedure ParseParameters(Value: string; const Parameters: TStrings); +var + s: string; +begin + Parameters.Clear; + while Value <> '' do + begin + s := Fetch(Value, ';'); + Parameters.Add(s); + end; +end; + +{==============================================================================} + +function IndexByBegin(Value: string; const List: TStrings): integer; +var + n: integer; + s: string; +begin + Result := -1; + Value := uppercase(Value); + for n := 0 to List.Count -1 do + begin + s := UpperCase(List[n]); + if Pos(Value, s) = 1 then + begin + Result := n; + Break; + end; + end; +end; + +{==============================================================================} + function GetEmailAddr(const Value: string): string; var s: string; @@ -936,4 +967,98 @@ begin Result := Trim(Result); end; +{==============================================================================} + +function IsBinaryString(const Value: string): Boolean; +var + n: integer; +begin + Result := False; + for n := 1 to Length(Value) do + if Value[n] in [#0..#8, #10..#31] then + begin + Result := True; + Break; + end; +end; + +{==============================================================================} + +function PosCRLF(const Value: string; var Terminator: string): integer; +var + p1, p2, p3, p4: integer; +const + t1 = #$0d + #$0a; + t2 = #$0a + #$0d; + t3 = #$0d; + t4 = #$0a; +begin + Terminator := ''; + p1 := Pos(t1, Value); + p2 := Pos(t2, Value); + p3 := Pos(t3, Value); + p4 := Pos(t4, Value); + if p1 > 0 then + Terminator := t1; + Result := p1; + if (p2 > 0) then + if (Result = 0) or (p2 < Result) then + begin + Result := p2; + Terminator := t2; + end; + if (p3 > 0) then + if (Result = 0) or (p3 < Result) then + begin + Result := p3; + Terminator := t3; + end; + if (p4 > 0) then + if (Result = 0) or (p4 < Result) then + begin + Result := p4; + Terminator := t4; + end; +end; + +{==============================================================================} + +Procedure StringsTrim(const Value: TStrings); +var + n: integer; +begin + for n := Value.Count - 1 downto 0 do + if Value[n] = '' then + Value.Delete(n) + else + Break; +end; + +{==============================================================================} + +function PosFrom(const SubStr, Value: String; From: integer): integer; +var + ls,lv: integer; +begin + Result := 0; + ls := Length(SubStr); + lv := Length(Value); + if (ls = 0) or (lv = 0) then + Exit; + if From < 1 then + From := 1; + while (ls + from - 1) <= (lv) do + begin + if CompareMem(@SubStr[1],@Value[from],ls) then + begin + result := from; + break; + end + else + inc(from); + end; +end; + +{==============================================================================} + end. diff --git a/synsock.pas b/synsock.pas index afcdf02..ee4d05f 100644 --- a/synsock.pas +++ b/synsock.pas @@ -3,15 +3,34 @@ |==============================================================================| | Content: Socket Independent Platform Layer | |==============================================================================| -| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | -| (the "License"); you may not use this file except in compliance with the | -| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ | +| Copyright (c)1999-2002, Lukas Gebauer | +| All rights reserved. | | | -| Software distributed under the License is distributed on an "AS IS" basis, | -| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | -| the specific language governing rights and limitations under the License. | -|==============================================================================| -| The Original Code is Synapse Delphi Library. | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2001. |