From 9f400a899b9d7f067dee8dee44862ffd59d60669 Mon Sep 17 00:00:00 2001 From: geby Date: Thu, 24 Apr 2008 07:22:17 +0000 Subject: [PATCH] Release 30 git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@66 7c85be65-684b-0410-a082-b2ed4fbef004 --- asn1util.pas | 7 +- blcksock.pas | 594 +++++++++++++++++++++++++++++++++------------------ dnssend.pas | 305 ++++++++++++++++++-------- ftpsend.pas | 197 +++++++++++++---- httpsend.pas | 94 ++++++-- imapsend.pas | 59 +++-- mimeinln.pas | 31 +-- mimemess.pas | 10 +- mimepart.pas | 65 +++++- nntpsend.pas | 160 ++++++++------ pingsend.pas | 4 +- pop3send.pas | 15 +- slogsend.pas | 7 +- smtpsend.pas | 21 +- snmpsend.pas | 111 ++++++---- snmptrap.pas | 4 +- sntpsend.pas | 14 +- synachar.pas | 34 ++- synacode.pas | 28 ++- synamisc.pas | 306 ++++++++++++++++++++++++++ synassl.pas | 16 +- synautil.pas | 33 ++- synsock.pas | 17 +- tlntsend.pas | 306 ++++++++++++++++++++++++++ 24 files changed, 1846 insertions(+), 592 deletions(-) create mode 100644 synamisc.pas create mode 100644 tlntsend.pas diff --git a/asn1util.pas b/asn1util.pas index 6ab1e91..af3b1ca 100644 --- a/asn1util.pas +++ b/asn1util.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.003.004 | +| Project : Delphree - Synapse | 001.003.005 | |==============================================================================| | Content: support for ASN.1 BER coding and decoding | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2003 | | Portions created by Hernan Sanchez are Copyright (c) 2000. | | All Rights Reserved. | |==============================================================================| @@ -301,7 +301,6 @@ begin else // NULL begin Result := ''; - Inc(Start); Start := Start + ASNSize; end; end; diff --git a/blcksock.pas b/blcksock.pas index 7cb6ff9..4b55912 100644 --- a/blcksock.pas +++ b/blcksock.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 006.001.004 | +| Project : Delphree - Synapse | 006.006.001 | |==============================================================================| | Content: Library base | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)1999-2002. | +| Portions created by Lukas Gebauer are Copyright (c)1999-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -48,7 +48,18 @@ Special thanks to Gregor Ibic } {$Q-} -{$WEAKPACKAGEUNIT ON} + +{$DEFINE ONCEWINSOCK} +{Note about define ONCEWINSOCK: +If you remove this compiler directive, then socket interface is loaded and +initialized on constructor of TBlockSocket class for each socket separately. +Socket interface is used only if your need it. + +If you leave this directive here, then socket interface is loaded and +initialized only once at start of your program! It boost performace on high +count of created and destroyed sockets. It eliminate possible small resource +leak on Windows systems too. +} unit blcksock; @@ -68,13 +79,20 @@ const cAnyHost = '0.0.0.0'; cBroadcast = '255.255.255.255'; cAnyPort = '0'; + CR = #$0d; + LF = #$0a; + CRLF = CR + LF; + type ESynapseError = class(Exception) - public - ErrorCode: Integer; - ErrorMessage: string; + private + FErrorCode: Integer; + FErrorMessage: string; + published + property ErrorCode: Integer read FErrorCode Write FErrorCode; + property ErrorMessage: string read FErrorMessage Write FErrorMessage; end; THookSocketReason = ( @@ -89,15 +107,20 @@ type HR_Listen, HR_Accept, HR_ReadCount, - HR_WriteCount + HR_WriteCount, + HR_Wait ); THookSocketStatus = procedure(Sender: TObject; Reason: THookSocketReason; const Value: string) of object; + THookDataFilter = procedure(Sender: TObject; var Value: string) of object; + TBlockSocket = class(TObject) private FOnStatus: THookSocketStatus; + FOnReadFilter: THookDataFilter; + FOnWriteFilter: THookDataFilter; FWsaData: TWSADATA; FLocalSin: TSockAddrIn; FRemoteSin: TSockAddrIn; @@ -112,11 +135,16 @@ type FMaxRecvBandwidth: Integer; FNextRecv: Cardinal; FConvertLineEnd: Boolean; + FLastCR: Boolean; + FLastLF: Boolean; + FBinded: Boolean; function GetSizeRecvBuffer: Integer; procedure SetSizeRecvBuffer(Size: Integer); function GetSizeSendBuffer: Integer; procedure SetSizeSendBuffer(Size: Integer); procedure SetNonBlockMode(Value: Boolean); + procedure SetTTL(TTL: integer); + function GetTTL:integer; protected FSocket: TSocket; FProtocol: Integer; @@ -126,6 +154,8 @@ type function GetSinIP(Sin: TSockAddrIn): string; function GetSinPort(Sin: TSockAddrIn): Integer; procedure DoStatus(Reason: THookSocketReason; const Value: string); + procedure DoReadFilter(Buffer: Pointer; var Length: Integer); + procedure DoWriteFilter(Buffer: Pointer; var Length: Integer); procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: Cardinal); procedure SetBandwidth(Value: Integer); public @@ -141,6 +171,7 @@ type function RecvBuffer(Buffer: Pointer; Length: Integer): Integer; virtual; function RecvBufferEx(Buffer: Pointer; Length: Integer; Timeout: Integer): Integer; virtual; + function RecvBufferStr(Length: Integer; Timeout: Integer): String; virtual; function RecvByte(Timeout: Integer): Byte; virtual; function RecvString(Timeout: Integer): string; virtual; function RecvTerminated(Timeout: Integer; const Terminator: string): string; virtual; @@ -189,13 +220,16 @@ type property SizeRecvBuffer: Integer read GetSizeRecvBuffer write SetSizeRecvBuffer; property SizeSendBuffer: Integer read GetSizeSendBuffer write SetSizeSendBuffer; property WSAData: TWSADATA read FWsaData; - property OnStatus: THookSocketStatus read FOnStatus write FOnStatus; property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode; property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength; 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; + property TTL: Integer read GetTTL Write SetTTL; + property OnStatus: THookSocketStatus read FOnStatus write FOnStatus; + property OnReadFilter: THookDataFilter read FOnReadFilter write FOnReadFilter; + property OnWriteFilter: THookDataFilter read FOnWriteFilter write FOnWriteFilter; end; TSocksBlockSocket = class(TBlockSocket) @@ -304,6 +338,8 @@ type protected FSocksControlSock: TTCPBlockSocket; function UdpAssociation: Boolean; + procedure SetMulticastTTL(TTL: integer); + function GetMulticastTTL:integer; public destructor Destroy; override; procedure CreateSocket; override; @@ -315,6 +351,9 @@ type function RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer; override; procedure AddMulticast(MCastIP:string); procedure DropMulticast(MCastIP:string); + function EnableMulticastLoop(Value: Boolean): Boolean; + published + property MulticastTTL: Integer read GetMulticastTTL Write SetMulticastTTL; end; //See 'winsock2.txt' file in distribute package! @@ -366,9 +405,54 @@ type MCastIfc : u_long; end; +{$IFDEF ONCEWINSOCK} +var + WsaDataOnce: TWSADATA; + e: ESynapseError; +{$ENDIF} + + constructor TBlockSocket.Create; +{$IFNDEF ONCEWINSOCK} var e: ESynapseError; +{$ENDIF} +begin + inherited Create; + FRaiseExcept := False; + FSocket := INVALID_SOCKET; + FProtocol := IPPROTO_IP; + FBuffer := ''; + FLastCR := False; + FLastLF := False; + FBinded := False; + FNonBlockMode := False; + FMaxLineLength := 0; + FMaxSendBandwidth := 0; + FNextSend := 0; + FMaxRecvBandwidth := 0; + FNextRecv := 0; + FConvertLineEnd := False; +{$IFDEF ONCEWINSOCK} + FWsaData := WsaDataOnce; +{$ELSE} + if not InitSocketInterface('') then + begin + e := ESynapseError.Create('Error loading Winsock DLL!'); + e.ErrorCode := 0; + e.ErrorMessage := 'Error loading Winsock DLL!'; + raise e; + end; + SockCheck(synsock.WSAStartup($101, FWsaData)); + ExceptCheck; +{$ENDIF} +end; + +constructor TBlockSocket.CreateAlternate(Stub: string); +{$IFNDEF ONCEWINSOCK} +var + e: ESynapseError; +{$ENDIF} begin inherited Create; FRaiseExcept := False; @@ -382,26 +466,9 @@ begin FMaxRecvBandwidth := 0; FNextRecv := 0; FConvertLineEnd := False; - if not InitSocketInterface('') then - begin - e := ESynapseError.Create('Error loading Winsock DLL!'); - e.ErrorCode := 0; - e.ErrorMessage := 'Error loading Winsock DLL!'; - raise e; - end; - SockCheck(synsock.WSAStartup($101, FWsaData)); - ExceptCheck; -end; - -constructor TBlockSocket.CreateAlternate(Stub: string); -var - e: ESynapseError; -begin - inherited Create; - FRaiseExcept := False; - FSocket := INVALID_SOCKET; - FProtocol := IPPROTO_IP; - FBuffer := ''; +{$IFDEF ONCEWINSOCK} + FWsaData := WsaDataOnce; +{$ELSE} if not InitSocketInterface(Stub) then begin e := ESynapseError.Create('Error loading alternate Winsock DLL (' + Stub + ')!'); @@ -411,13 +478,16 @@ begin end; SockCheck(synsock.WSAStartup($101, FWsaData)); ExceptCheck; +{$ENDIF} end; destructor TBlockSocket.Destroy; begin CloseSocket; +{$IFNDEF ONCEWINSOCK} synsock.WSACleanup; DestroySocketInterface; +{$ENDIF} inherited Destroy; end; @@ -430,27 +500,32 @@ var HostEnt: PHostEnt; begin DoStatus(HR_ResolvingBegin, IP + ':' + Port); - FillChar(Sin, Sizeof(Sin), 0); - Sin.sin_family := AF_INET; - ProtoEnt := synsock.GetProtoByNumber(FProtocol); - ServEnt := nil; - if ProtoEnt <> nil then - ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); - if ServEnt = nil then - Sin.sin_port := synsock.htons(StrToIntDef(Port, 0)) - else - Sin.sin_port := ServEnt^.s_port; - if IP = cBroadcast then - Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) - else - begin - Sin.sin_addr.s_addr := synsock.inet_addr(PChar(IP)); - if SIn.sin_addr.s_addr = u_long(INADDR_NONE) then + SynSockCS.Enter; + try + FillChar(Sin, Sizeof(Sin), 0); + Sin.sin_family := AF_INET; + ProtoEnt := synsock.GetProtoByNumber(FProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Sin.sin_port := synsock.htons(StrToIntDef(Port, 0)) + else + Sin.sin_port := ServEnt^.s_port; + if IP = cBroadcast then + Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) + else begin - HostEnt := synsock.GetHostByName(PChar(IP)); - if HostEnt <> nil then - SIn.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); + Sin.sin_addr.s_addr := synsock.inet_addr(PChar(IP)); + if SIn.sin_addr.s_addr = u_long(INADDR_NONE) then + begin + HostEnt := synsock.GetHostByName(PChar(IP)); + if HostEnt <> nil then + SIn.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); + end; end; + finally + SynSockCS.Leave; end; DoStatus(HR_ResolvingEnd, IP + ':' + Port); end; @@ -474,6 +549,7 @@ end; procedure TBlockSocket.CreateSocket; begin FBuffer := ''; + FBinded := False; if FSocket = INVALID_SOCKET then FLastError := synsock.WSAGetLastError else @@ -490,7 +566,6 @@ end; procedure TBlockSocket.CloseSocket; begin - synsock.Shutdown(FSocket, 2); synsock.CloseSocket(FSocket); FSocket := INVALID_SOCKET; DoStatus(HR_SocketClose, ''); @@ -507,6 +582,7 @@ begin Len := SizeOf(FLocalSin); synsock.GetSockName(FSocket, FLocalSin, Len); FBuffer := ''; + FBinded := True; ExceptCheck; DoStatus(HR_Bind, IP + ':' + Port); end; @@ -520,6 +596,8 @@ begin SockCheck(synsock.Connect(FSocket, Sin, SizeOf(Sin))); GetSins; FBuffer := ''; + FLastCR := False; + FLastLF := False; ExceptCheck; DoStatus(HR_Connect, IP + ':' + Port); end; @@ -552,7 +630,10 @@ begin begin x := Next - y; if x > 0 then + begin + DoStatus(HR_Wait, IntToStr(x)); sleep(x); + end; end; Next := y + Trunc((Length / MaxB) * 1000); end; @@ -561,6 +642,7 @@ end; function TBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer; begin LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); + DoWriteFilter(Buffer, Length); Result := synsock.Send(FSocket, Buffer^, Length, 0); SockCheck(Result); ExceptCheck; @@ -587,68 +669,46 @@ begin SockCheck(Result); ExceptCheck; DoStatus(HR_ReadCount, IntToStr(Result)); + DoReadFilter(Buffer, Result); end; function TBlockSocket.RecvBufferEx(Buffer: Pointer; Length: Integer; Timeout: Integer): Integer; var - s, ss, st: string; - x, l, lss: Integer; - fb, fs: Integer; - max: Integer; + s: string; + rl, l: integer; begin FLastError := 0; - x := System.Length(FBuffer); - if Length <= x then + rl := 0; + repeat + s := RecvPacket(Timeout); + l := System.Length(s); + if (rl + l) > Length then + l := Length - rl; + Move(Pointer(s)^, IncPoint(Buffer, rl)^, l); + rl := rl + l; + if FLastError <> 0 then + Break; + until rl >= Length; + delete(s, 1, l); + FBuffer := s; + Result := rl; +end; + +function TBlockSocket.RecvBufferStr(Length: Integer; Timeout: Integer): string; +var + x: integer; +begin + Result := ''; + if Length > 0 then begin - fb := Length; - fs := 0; - end - else - begin - fb := x; - fs := Length - x; + Setlength(Result, Length); + x := RecvBufferEx(PChar(Result), Length , Timeout); + if FLastError = 0 then + SetLength(Result, x) + else + Result := ''; end; - ss := ''; - if fb > 0 then - begin - s := Copy(FBuffer, 1, fb); - Delete(FBuffer, 1, fb); - end; - if fs > 0 then - begin - Max := GetSizeRecvBuffer; - ss := ''; - while System.Length(ss) < fs do - begin - if CanRead(Timeout) then - begin - l := WaitingData; - if l > max then - l := max; - if (system.Length(ss) + l) > fs then - l := fs - system.Length(ss); - SetLength(st, l); - x := RecvBuffer(Pointer(st), l); - if FLastError <> 0 then - Break; - lss := system.Length(ss); - SetLength(ss, lss + x); - Move(Pointer(st)^, Pointer(@ss[lss + 1])^, x); - {It is 3x faster then ss:=ss+copy(st,1,x);} - Sleep(0); - end - else - FLastError := WSAETIMEDOUT; - if FLastError <> 0 then - Break; - end; - fs := system.Length(ss); - end; - Result := fb + fs; - s := s + ss; - Move(Pointer(s)^, Buffer^, Result); - ExceptCheck; end; function TBlockSocket.RecvPacket(Timeout: Integer): string; @@ -657,16 +717,19 @@ var begin Result := ''; FLastError := 0; - x := -1; if FBuffer <> '' then begin Result := FBuffer; FBuffer := ''; end else + begin + Sleep(0); if CanRead(Timeout) then begin x := WaitingData; + if x = 0 then + FLastError := WSAECONNRESET; if x > 0 then begin SetLength(Result, x); @@ -677,9 +740,8 @@ begin end else FLastError := WSAETIMEDOUT; + end; ExceptCheck; - if x = 0 then - FLastError := WSAECONNRESET; end; @@ -689,9 +751,7 @@ begin FLastError := 0; if FBuffer = '' then FBuffer := RecvPacket(Timeout); - if (FBuffer = '') and (FLastError = 0) then - FLastError := WSAETIMEDOUT; - if FLastError = 0 then + if (FLastError = 0) and (FBuffer <> '') then begin Result := Ord(FBuffer[1]); System.Delete(FBuffer, 1, 1); @@ -714,29 +774,7 @@ begin if l = 0 then Exit; tl := l; - CorCRLF := FConvertLineEnd and (Terminator = #$0d + #$0a); - // if FBuffer contains requested data, return it... - if FBuffer<>'' then - begin - 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 + tl - 1); - Exit; - end; - end; - // now FBuffer is empty or not contains all data... + CorCRLF := FConvertLineEnd and (Terminator = CRLF); s := ''; x := 0; repeat @@ -744,17 +782,29 @@ begin s := s + RecvPacket(Timeout); if FLastError <> 0 then Break; - if CorCRLF then - begin - t := ''; - x := PosCRLF(s, t); - tl := system.Length(t); - end - else - begin - x := pos(Terminator, s); - tl := l; - end; + x := 0; + if Length(s) > 0 then + if CorCRLF then + begin + if FLastCR and (s[1] = LF) then + Delete(s, 1, 1); + if FLastLF and (s[1] = CR) then + Delete(s, 1, 1); + FLastCR := False; + FLastLF := False; + t := ''; + x := PosCRLF(s, t); + tl := system.Length(t); + if t = CR then + FLastCR := True; + if t = LF then + FLastLF := True; + end + else + begin + x := pos(Terminator, s); + tl := l; + end; if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then begin FLastError := WSAENOBUFS; @@ -775,7 +825,7 @@ var s: string; begin Result := ''; - s := RecvTerminated(Timeout, #13 + #10); + s := RecvTerminated(Timeout, CRLF); if FLastError = 0 then Result := s; end; @@ -872,9 +922,14 @@ begin if BufPtr[0] <> #0 then begin // try get Fully Qualified Domain Name - RemoteHost := synsock.GetHostByName(BufPtr); - if RemoteHost <> nil then - Result := PChar(RemoteHost^.h_name); + SynSockCS.Enter; + try + RemoteHost := synsock.GetHostByName(BufPtr); + if RemoteHost <> nil then + Result := PChar(RemoteHost^.h_name); + finally + SynSockCS.Leave; + end; end; if Result = '' then Result := '127.0.0.1'; @@ -896,23 +951,28 @@ begin IP := synsock.inet_addr(PChar(Name)); if IP = u_long(INADDR_NONE) then begin - RemoteHost := synsock.GetHostByName(PChar(Name)); - if RemoteHost <> nil then - begin - PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); - i := 0; - while PAdrPtr^[i] <> nil do + SynSockCS.Enter; + try + RemoteHost := synsock.GetHostByName(PChar(Name)); + if RemoteHost <> nil then begin - InAddr := PAdrPtr^[i]^; - with InAddr.S_un_b do - s := Format('%d.%d.%d.%d', - [Ord(s_b1), Ord(s_b2), Ord(s_b3), Ord(s_b4)]); - IPList.Add(s); - Inc(i); + PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); + i := 0; + while PAdrPtr^[i] <> nil do + begin + InAddr := PAdrPtr^[i]^; + with InAddr.S_un_b do + s := Format('%d.%d.%d.%d', + [Ord(s_b1), Ord(s_b2), Ord(s_b3), Ord(s_b4)]); + IPList.Add(s); + Inc(i); + end; end; + if IPList.Count = 0 then + IPList.Add('0.0.0.0'); + finally + SynSockCS.Leave; end; - if IPList.Count = 0 then - IPList.Add('0.0.0.0'); end else IPList.Add(Name); @@ -936,14 +996,19 @@ var ProtoEnt: PProtoEnt; ServEnt: PServEnt; begin - ProtoEnt := synsock.GetProtoByNumber(FProtocol); - ServEnt := nil; - if ProtoEnt <> nil then - ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); - if ServEnt = nil then - Result := synsock.htons(StrToIntDef(Port, 0)) - else - Result := ServEnt^.s_port; + SynSockCS.Enter; + try + ProtoEnt := synsock.GetProtoByNumber(FProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Result := synsock.htons(StrToIntDef(Port, 0)) + else + Result := ServEnt^.s_port; + finally + SynSockCS.Leave; + end; end; procedure TBlockSocket.SetRemoteSin(IP, Port: string); @@ -1166,12 +1231,64 @@ begin ExceptCheck; end; +procedure TBlockSocket.SetTTL(TTL: integer); +var + Res: Integer; +begin + Res := synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_TTL, @TTL, SizeOf(TTL)); + SockCheck(Res); + ExceptCheck; +end; + +function TBlockSocket.GetTTL:integer; +var + l: Integer; +begin + l := SizeOf(Result); + SockCheck(synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_TTL, @Result, l)); + ExceptCheck; +end; + procedure TBlockSocket.DoStatus(Reason: THookSocketReason; const Value: string); begin if assigned(OnStatus) then OnStatus(Self, Reason, Value); end; +procedure TBlockSocket.DoReadFilter(Buffer: Pointer; var Length: Integer); +var + s: string; +begin + if assigned(OnReadFilter) then + if Length > 0 then + begin + SetLength(s, Length); + Move(Buffer^, Pointer(s)^, Length); + OnReadFilter(Self, s); + if System.Length(s) > Length then + SetLength(s, Length); + Length := System.Length(s); + Move(Pointer(s)^, Buffer^, Length); + end; +end; + +procedure TBlockSocket.DoWriteFilter(Buffer: Pointer; var Length: Integer); +var + s: string; +begin + if assigned(OnWriteFilter) then + if Length > 0 then + begin + SetLength(s, Length); + Move(Buffer^, Pointer(s)^, Length); + OnWriteFilter(Self, s); + if System.Length(s) > Length then + SetLength(s, Length); + Length := System.Length(s); + Move(Pointer(s)^, Buffer^, Length); + end; +end; + class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string; begin case ErrorCode of @@ -1320,8 +1437,7 @@ begin else Buf := #5 + #2 + #2 +#0; SendString(Buf); - Buf := RecvPacket(FSocksTimeout); - FBuffer := Copy(Buf, 3, Length(buf) - 2); + Buf := RecvBufferStr(2, FSocksTimeout); if Length(Buf) < 2 then Exit; if Buf[1] <> #5 then @@ -1335,8 +1451,7 @@ begin Buf := #1 + char(Length(FSocksUsername)) + FSocksUsername + char(Length(FSocksPassword)) + FSocksPassword; SendString(Buf); - Buf := RecvPacket(FSocksTimeout); - FBuffer := Copy(Buf, 3, Length(buf) - 2); + Buf := RecvBufferStr(2, FSocksTimeout); if Length(Buf) < 2 then Exit; if Buf[2] <> #0 then @@ -1369,7 +1484,7 @@ end; function TSocksBlockSocket.SocksResponse: Boolean; var - Buf: string; + Buf, s: string; x: integer; begin Result := False; @@ -1377,18 +1492,33 @@ begin try FSocksResponseIP := ''; FSocksResponsePort := ''; - Buf := RecvPacket(FSocksTimeout); + + Buf := RecvBufferStr(4, FSocksTimeout); if FLastError <> 0 then Exit; - if Length(Buf) < 5 then - Exit; if Buf[1] <> #5 then Exit; + case Ord(Buf[4]) of + 1: + s := RecvBufferStr(4, FSocksTimeout); + 3: + begin + x := RecvByte(FSocksTimeout); + if FLastError <> 0 then + Exit; + s := char(x) + RecvBufferStr(x, FSocksTimeout); + end; + else + Exit; + end; + Buf := Buf + s + RecvBufferStr(2, FSocksTimeout); + if FLastError <> 0 then + Exit; + FSocksLastError := Ord(Buf[2]); if FSocksLastError <> 0 then Exit; - x := SocksDecode(Buf); - FBuffer := Copy(Buf, x, Length(buf) - x + 1); + SocksDecode(Buf); Result := True; finally FBypassFlag := False; @@ -1414,6 +1544,8 @@ var w: Word; begin FSocksResponsePort := '0'; + if Length(Value) < 4 then + Exit; Atyp := Ord(Value[4]); Result := 5; case Atyp of @@ -1505,14 +1637,12 @@ begin if FSocksControlSock.LastError <> 0 then Exit; // if not assigned local port, assign it! - if GetLocalSinPort = 0 then - Bind(GetLocalSinIP, '0'); - GetSins; + if not FBinded then + Bind('0.0.0.0', '0'); //open control TCP connection to SOCKS b := FSocksControlSock.SocksOpen; if b then - b := FSocksControlSock.SocksRequest(3, GetLocalSinIP, - IntToStr(GetLocalSinPort)); + b := FSocksControlSock.SocksRequest(3, GetLocalSinIP, IntToStr(GetLocalSinPort)); if b then b := FSocksControlSock.SocksResponse; if not b and (FLastError = 0) then @@ -1520,7 +1650,7 @@ begin FUsingSocks :=FSocksControlSock.UsingSocks; FSocksRemoteIP := FSocksControlSock.FSocksResponseIP; FSocksRemotePort := FSocksControlSock.FSocksResponsePort; - Result := True; + Result := b and (FLastError = 0); end; end; @@ -1530,22 +1660,27 @@ var SPort: integer; Buf: string; begin - UdpAssociation; - if FUsingSocks then - begin - Sip := GetRemoteSinIp; - SPort := GetRemoteSinPort; - SetRemoteSin(FSocksRemoteIP, FSocksRemotePort); - SetLength(Buf,Length); - Move(Buffer^, PChar(Buf)^, Length); - Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf; - Result := inherited SendBufferTo(PChar(Buf), System.Length(buf)); - SetRemoteSin(Sip, IntToStr(SPort)); - end + FUsingSocks := False; + if (FSocksIP <> '') and (not UdpAssociation) then + FLastError := WSANO_RECOVERY else begin - Result := inherited SendBufferTo(Buffer, Length); - GetSins; + if FUsingSocks then + begin + Sip := GetRemoteSinIp; + SPort := GetRemoteSinPort; + SetRemoteSin(FSocksRemoteIP, FSocksRemotePort); + SetLength(Buf,Length); + Move(Buffer^, PChar(Buf)^, Length); + Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf; + Result := inherited SendBufferTo(PChar(Buf), System.Length(buf)); + SetRemoteSin(Sip, IntToStr(SPort)); + end + else + begin + Result := inherited SendBufferTo(Buffer, Length); + GetSins; + end; end; end; @@ -1589,6 +1724,36 @@ begin ExceptCheck; end; +procedure TUDPBlockSocket.SetMulticastTTL(TTL: integer); +var + Res: Integer; +begin + Res := synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, @TTL, SizeOf(TTL)); + SockCheck(Res); + ExceptCheck; +end; + +function TUDPBlockSocket.GetMulticastTTL:integer; +var + l: Integer; +begin + l := SizeOf(Result); + SockCheck(synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, @Result, l)); + ExceptCheck; +end; + +function TUDPBlockSocket.EnableMulticastLoop(Value: Boolean): Boolean; +var + Opt: Integer; + Res: Integer; +begin + opt := Ord(Value); + Res := synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_LOOP, @Opt, SizeOf(opt)); + SockCheck(Res); + Result := res = 0; + ExceptCheck; +end; + {======================================================================} function PasswordCallback(buf:PChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl; @@ -1643,7 +1808,8 @@ end; procedure TTCPBlockSocket.CloseSocket; begin - synsock.Shutdown(FSocket, 1); + if FSocket <> INVALID_SOCKET then + synsock.Shutdown(FSocket, 1); inherited CloseSocket; end; @@ -1761,11 +1927,11 @@ begin if FLastError <> 0 then Exit; FHTTPTunnel := False; - SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + #$0d + #$0a); + SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + CRLF); if FHTTPTunnelUser <> '' then Sendstring('Proxy-Authorization: Basic ' + - EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + #$0d + #$0a); - SendString(#$0d + #$0a); + EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + CRLF); + SendString(CRLF); repeat s := RecvTerminated(30000, #$0a); if FLastError <> 0 then @@ -1975,6 +2141,7 @@ begin FLastError := WSASYSNOTREADY; ExceptCheck; DoStatus(HR_ReadCount, IntToStr(Result)); + DoReadFilter(Buffer, Result); end else Result := inherited RecvBuffer(Buffer, Length); @@ -1987,6 +2154,7 @@ begin if FSslEnabled and not(FSslBypass) and not(FBypassFlag) then begin FLastError := 0; + DoWriteFilter(Buffer, Length); repeat Result := SslWrite(FSsl, Buffer, Length); err := SslGetError(FSsl, Result); @@ -2111,4 +2279,26 @@ begin FTimeout := 5000; end; +{======================================================================} + +{$IFDEF ONCEWINSOCK} +initialization +begin + if not InitSocketInterface('') then + begin + e := ESynapseError.Create('Error loading Winsock DLL!'); + e.ErrorCode := 0; + e.ErrorMessage := 'Error loading Winsock DLL!'; + raise e; + end; + synsock.WSAStartup($101, WsaDataOnce); +end; + +finalization +begin + synsock.WSACleanup; + DestroySocketInterface; +end; +{$ENDIF} + end. diff --git a/dnssend.pas b/dnssend.pas index b46017d..4411464 100644 --- a/dnssend.pas +++ b/dnssend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.002.000 | +| Project : Delphree - Synapse | 002.001.001 | |==============================================================================| | Content: DNS client | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000,2001. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -94,31 +94,48 @@ const QTYPE_NAPTR = 35; // RFC-2168 QTYPE_KX = 36; - QTYPE_AXFR = 252; // + QTYPE_AXFR = 252; QTYPE_MAILB = 253; // QTYPE_MAILA = 254; // - QTYPE_ALL = 255; // + QTYPE_ALL = 255; type TDNSSend = class(TSynaClient) private + FID: Word; FRCode: Integer; FBuffer: string; FSock: TUDPBlockSocket; + FTCPSock: TTCPBlockSocket; + FUseTCP: Boolean; + FAnsferInfo: TStringList; + FNameserverInfo: TStringList; + FAdditionalInfo: TStringList; + FAuthoritative: Boolean; function CompressName(const Value: string): string; function CodeHeader: string; function CodeQuery(const Name: string; QType: Integer): string; function DecodeLabels(var From: Integer): string; - function DecodeResource(var i: Integer; const Name: string; + function DecodeString(var From: Integer): string; + function DecodeResource(var i: Integer; const Info: TStringList; QType: Integer): string; + function RecvTCPResponse(const WorkSock: TBlockSocket): string; + function DecodeResponse(const Buf: string; const Reply: TStrings; + QType: Integer):boolean; public constructor Create; destructor Destroy; override; function DNSQuery(Name: string; QType: Integer; const Reply: TStrings): Boolean; published - property RCode: Integer read FRCode; property Sock: TUDPBlockSocket read FSock; + property TCPSock: TTCPBlockSocket read FTCPSock; + property UseTCP: Boolean read FUseTCP Write FUseTCP; + property RCode: Integer read FRCode; + property Authoritative: Boolean read FAuthoritative; + property AnsferInfo: TStringList read FAnsferInfo; + property NameserverInfo: TStringList read FNameserverInfo; + property AdditionalInfo: TStringList read FAdditionalInfo; end; function GetMailServers(const DNSHost, Domain: string; @@ -130,13 +147,22 @@ constructor TDNSSend.Create; begin inherited Create; FSock := TUDPBlockSocket.Create; - FSock.CreateSocket; - FTimeout := 5000; + FTCPSock := TTCPBlockSocket.Create; + FUseTCP := False; + FTimeout := 10000; FTargetPort := cDnsProtocol; + FAnsferInfo := TStringList.Create; + FNameserverInfo := TStringList.Create; + FAdditionalInfo := TStringList.Create; + Randomize; end; destructor TDNSSend.Destroy; begin + FAnsferInfo.Free; + FNameserverInfo.Free; + FAdditionalInfo.Free; + FTCPSock.Free; FSock.Free; inherited Destroy; end; @@ -168,8 +194,8 @@ end; function TDNSSend.CodeHeader: string; begin - Randomize; - Result := CodeInt(Random(32767)); // ID + FID := Random(32767); + Result := CodeInt(FID); // ID Result := Result + CodeInt($0100); // flags Result := Result + CodeInt(1); // QDCount Result := Result + CodeInt(0); // ANCount @@ -184,6 +210,16 @@ begin Result := Result + CodeInt(1); // Type INTERNET end; +function TDNSSend.DecodeString(var From: Integer): string; +var + Len: integer; +begin + Len := Ord(FBuffer[From]); + Inc(From); + Result := Copy(FBuffer, From, Len); + Inc(From, Len); +end; + function TDNSSend.DecodeLabels(var From: Integer): string; var l, f: Integer; @@ -191,6 +227,8 @@ begin Result := ''; while True do begin + if From >= Length(FBuffer) then + Break; l := Ord(FBuffer[From]); Inc(From); if l = 0 then @@ -213,88 +251,112 @@ begin end; end; -function TDNSSend.DecodeResource(var i: Integer; const Name: string; +function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList; QType: Integer): string; var Rname: string; RType, Len, j, x, n: Integer; + R: string; + t1, t2, ttl: integer; begin Result := ''; + R := ''; Rname := DecodeLabels(i); RType := DecodeInt(FBuffer, i); - Inc(i, 8); + Inc(i, 4); + t1 := DecodeInt(FBuffer, i); + Inc(i, 2); + t2 := DecodeInt(FBuffer, i); + Inc(i, 2); + ttl := t1 * 65536 + t2; Len := DecodeInt(FBuffer, i); Inc(i, 2); // i point to begin of data j := i; i := i + len; // i point to next record - if (Name = Rname) and (QType = RType) then - begin - case RType of - QTYPE_A: + case RType of + QTYPE_A: + begin + R := IntToStr(Ord(FBuffer[j])); + Inc(j); + R := R + '.' + IntToStr(Ord(FBuffer[j])); + Inc(j); + R := R + '.' + IntToStr(Ord(FBuffer[j])); + Inc(j); + R := R + '.' + IntToStr(Ord(FBuffer[j])); + end; + QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB, + QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP, + QTYPE_NSAPPTR: + R := DecodeLabels(j); + QTYPE_SOA: + begin + R := DecodeLabels(j); + R := R + ',' + DecodeLabels(j); + for n := 1 to 5 do begin - Result := IntToStr(Ord(FBuffer[j])); - Inc(j); - Result := Result + '.' + IntToStr(Ord(FBuffer[j])); - Inc(j); - Result := Result + '.' + IntToStr(Ord(FBuffer[j])); - Inc(j); - Result := Result + '.' + IntToStr(Ord(FBuffer[j])); + x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2); + Inc(j, 4); + R := R + ',' + IntToStr(x); end; - QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB, - QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP, - QTYPE_NSAPPTR: - Result := DecodeLabels(j); - QTYPE_SOA: - begin - Result := DecodeLabels(j); - Result := Result + ',' + DecodeLabels(j); - for n := 1 to 5 do - begin - x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2); - Inc(j, 4); - Result := Result + ',' + IntToStr(x); - end; - end; - QTYPE_NULL: - begin - end; - QTYPE_WKS: - begin - end; - QTYPE_HINFO, QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN: - begin - Result := DecodeLabels(j); - Result := Result + ',' + DecodeLabels(j); - end; - QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX: - begin - x := DecodeInt(FBuffer, j); - Inc(j, 2); - Result := IntToStr(x); - Result := Result + ',' + DecodeLabels(j); - end; - QTYPE_TXT: - Result := DecodeLabels(j); - QTYPE_GPOS: - begin - Result := DecodeLabels(j); - Result := Result + ',' + DecodeLabels(j); - Result := Result + ',' + DecodeLabels(j); - end; - QTYPE_PX: - begin - x := DecodeInt(FBuffer, j); - Inc(j, 2); - Result := IntToStr(x); - Result := Result + ',' + DecodeLabels(j); - Result := Result + ',' + DecodeLabels(j); - end; - end; + end; + QTYPE_NULL: + begin + end; + QTYPE_WKS: + begin + end; + QTYPE_HINFO: + begin + R := DecodeString(j); + R := R + ',' + DecodeString(j); + end; + QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN: + begin + R := DecodeLabels(j); + R := R + ',' + DecodeLabels(j); + end; + QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX: + begin + x := DecodeInt(FBuffer, j); + Inc(j, 2); + R := IntToStr(x); + R := R + ',' + DecodeLabels(j); + end; + QTYPE_TXT: + R := DecodeString(j); + QTYPE_GPOS: + begin + R := DecodeLabels(j); + R := R + ',' + DecodeLabels(j); + R := R + ',' + DecodeLabels(j); + end; + QTYPE_PX: + begin + x := DecodeInt(FBuffer, j); + Inc(j, 2); + R := IntToStr(x); + R := R + ',' + DecodeLabels(j); + R := R + ',' + DecodeLabels(j); + end; end; + if R <> '' then + Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R); + if QType = RType then + Result := R; end; -function TDNSSend.DNSQuery(Name: string; QType: Integer; - const Reply: TStrings): Boolean; +function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): string; +var + l: integer; +begin + Result := ''; + l := WorkSock.recvbyte(FTimeout) * 256 + WorkSock.recvbyte(FTimeout); + if l > 0 then + Result := WorkSock.RecvBufferStr(l, FTimeout); +end; + +function TDNSSend.DecodeResponse(const Buf: string; const Reply: TStrings; + QType: Integer):boolean; var n, i: Integer; flag, qdcount, ancount, nscount, arcount: Integer; @@ -302,43 +364,100 @@ var begin Result := False; Reply.Clear; - if IsIP(Name) then - Name := ReverseIP(Name) + '.in-addr.arpa'; - FBuffer := CodeHeader + CodeQuery(Name, QType); - FSock.Bind(FIPInterface, cAnyPort); - FSock.Connect(FTargetHost, FTargetPort); - FSock.SendString(FBuffer); - FBuffer := FSock.RecvPacket(FTimeout); - if (FSock.LastError = 0) and (Length(FBuffer) > 13) then + FAnsferInfo.Clear; + FNameserverInfo.Clear; + FAdditionalInfo.Clear; + FAuthoritative := False; + if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then begin - flag := DecodeInt(FBuffer, 3); + flag := DecodeInt(Buf, 3); FRCode := Flag and $000F; + FAuthoritative := (Flag and $0400) > 0; if FRCode = 0 then begin - qdcount := DecodeInt(FBuffer, 5); - ancount := DecodeInt(FBuffer, 7); - nscount := DecodeInt(FBuffer, 9); - arcount := DecodeInt(FBuffer, 11); + qdcount := DecodeInt(Buf, 5); + ancount := DecodeInt(Buf, 7); + nscount := DecodeInt(Buf, 9); + arcount := DecodeInt(Buf, 11); i := 13; //begin of body - if qdcount > 0 then //skip questions + if (qdcount > 0) and (Length(Buf) > i) then //skip questions for n := 1 to qdcount do begin - while (FBuffer[i] <> #0) and ((Ord(FBuffer[i]) and $C0) <> $C0) do + while (Buf[i] <> #0) and ((Ord(Buf[i]) and $C0) <> $C0) do Inc(i); Inc(i, 5); end; - if ancount > 0 then + if (ancount > 0) and (Length(Buf) > i) then // decode reply for n := 1 to ancount do begin - s := DecodeResource(i, Name, QType); + s := DecodeResource(i, FAnsferInfo, QType); if s <> '' then Reply.Add(s); end; + if (nscount > 0) and (Length(Buf) > i) then // decode nameserver info + for n := 1 to nscount do + DecodeResource(i, FNameserverInfo, QType); + if (arcount > 0) and (Length(Buf) > i) then // decode additional info + for n := 1 to arcount do + DecodeResource(i, FAdditionalInfo, QType); Result := True; end; end; end; +function TDNSSend.DNSQuery(Name: string; QType: Integer; + const Reply: TStrings): Boolean; +var + WorkSock: TBlockSocket; + t: TStringList; + b: boolean; +begin + Result := False; + if IsIP(Name) then + Name := ReverseIP(Name) + '.in-addr.arpa'; + FBuffer := CodeHeader + CodeQuery(Name, QType); + if FUseTCP then + WorkSock := FTCPSock + else + WorkSock := FSock; + WorkSock.Bind(FIPInterface, cAnyPort); + WorkSock.Connect(FTargetHost, FTargetPort); + if FUseTCP then + FBuffer := Codeint(length(FBuffer)) + FBuffer; + WorkSock.SendString(FBuffer); + if FUseTCP then + FBuffer := RecvTCPResponse(WorkSock) + else + FBuffer := WorkSock.RecvPacket(FTimeout); + if FUseTCP and (QType = QTYPE_AXFR) then //zone transfer + begin + t := TStringList.Create; + try + repeat + b := DecodeResponse(FBuffer, Reply, QType); + if (t.Count > 1) and (AnsferInfo.Count > 0) then //find end of transfer + b := b and (t[0] <> AnsferInfo[AnsferInfo.count - 1]); + if b then + begin + t.AddStrings(AnsferInfo); + FBuffer := RecvTCPResponse(WorkSock); + if FBuffer = '' then + Break; + if WorkSock.LastError <> 0 then + Break; + end; + until not b; + Reply.Assign(t); + Result := True; + finally + t.free; + end; + end + else //normal query + if WorkSock.LastError = 0 then + Result := DecodeResponse(FBuffer, Reply, QType); +end; + {==============================================================================} function GetMailServers(const DNSHost, Domain: string; diff --git a/ftpsend.pas b/ftpsend.pas index 3f1523c..2afb4cc 100644 --- a/ftpsend.pas +++ b/ftpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.003.001 | +| Project : Delphree - Synapse | 002.005.004 | |==============================================================================| | Content: FTP client | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2002. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -112,6 +112,10 @@ type FPassiveMode: Boolean; FForceDefaultPort: Boolean; FFtpList: TFTPList; + FBinaryMode: Boolean; + FAutoTLS: Boolean; + FIsTLS: Boolean; + FFullSSL: Boolean; function Auth(Mode: integer): Boolean; function Connect: Boolean; function InternalStor(const Command: string; RestoreAt: integer): Boolean; @@ -169,6 +173,10 @@ type property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort; property OnStatus: TFTPStatus read FOnStatus write FOnStatus; property FtpList: TFTPList read FFtpList; + property BinaryMode: Boolean read FBinaryMode Write FBinaryMode; + property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + property FullSSL: Boolean read FFullSSL Write FFullSSL; + property IsTLS: Boolean read FIsTLS; end; function FtpGetFile(const IP, Port, FileName, LocalFile, @@ -181,15 +189,13 @@ function FtpInterServerTransfer( implementation -const - CRLF = #13#10; - constructor TFTPSend.Create; begin inherited Create; FFullResult := TStringList.Create; FDataStream := TMemoryStream.Create; FSock := TTCPBlockSocket.Create; + FSock.ConvertLineEnd := True; FDSock := TTCPBlockSocket.Create; FFtpList := TFTPList.Create; FTimeout := 300000; @@ -205,6 +211,10 @@ begin FFWUsername := ''; FFWPassword := ''; FFWMode := 0; + FBinaryMode := True; + FAutoTLS := False; + FFullSSL := False; + FIsTLS := False; end; destructor TFTPSend.Destroy; @@ -256,38 +266,114 @@ end; // based on idea by Petr Esner function TFTPSend.Auth(Mode: integer): Boolean; const - // Direct connection USER[+PASS[+ACCT]] + //if not USER then + // if not PASS then + // if not ACCT then ERROR! + //OK! Action0: TLogonActions = - (0, FTP_OK, 3, 1, FTP_OK, 6, 2, FTP_OK, FTP_ERR, 0, 0, 0, 0, 0, 0, 0, 0, 0); - // SITE + (0, FTP_OK, 3, + 1, FTP_OK, 6, + 2, FTP_OK, FTP_ERR, + 0, 0, 0, 0, 0, 0, 0, 0, 0); + + //if not USER then + // if not PASS then ERROR! + //if SITE then ERROR! + //if not USER then + // if not PASS then + // if not ACCT then ERROR! + //OK! Action1: TLogonActions = - (3, 6, 3, 4, 6, FTP_ERR, 5, FTP_ERR, 9, 0, FTP_OK, 12, 1, FTP_OK, 15, 2, - FTP_OK, FTP_ERR); - // USER after logon + (3, 6, 3, + 4, 6, FTP_ERR, + 5, FTP_ERR, 9, + 0, FTP_OK, 12, + 1, FTP_OK, 15, + 2, FTP_OK, FTP_ERR); + + //if not USER then + // if not PASS then ERROR! + //if USER '@' then OK! + //if not PASS then + // if not ACCT then ERROR! + //OK! Action2: TLogonActions = - (3, 6, 3, 4, 6, FTP_ERR, 6, FTP_OK, 9, 1, FTP_OK, 12, 2, FTP_OK, FTP_ERR, + (3, 6, 3, + 4, 6, FTP_ERR, + 6, FTP_OK, 9, + 1, FTP_OK, 12, + 2, FTP_OK, FTP_ERR, 0, 0, 0); - // Transparent + + //if not USER then + // if not PASS then ERROR! + //if not USER then + // if not PASS then + // if not ACCT then ERROR! + //OK! Action3: TLogonActions = - (3, 6, 3, 4, 6, FTP_ERR, 0, FTP_OK, 9, 1, FTP_OK, 12, 2, FTP_OK, FTP_ERR, + (3, 6, 3, + 4, 6, FTP_ERR, + 0, FTP_OK, 9, + 1, FTP_OK, 12, + 2, FTP_OK, FTP_ERR, 0, 0, 0); - // proxy OPEN + + //OPEN + //if not USER then + // if not PASS then + // if not ACCT then ERROR! + //OK! Action4: TLogonActions = - (7, 3, 3, 0, FTP_OK, 6, 1, FTP_OK, 9, 2, FTP_OK, FTP_ERR, + (7, 3, 3, + 0, FTP_OK, 6, + 1, FTP_OK, 9, + 2, FTP_OK, FTP_ERR, 0, 0, 0, 0, 0, 0); - // USER with no logon + + //if USER '@' then OK! + //if not PASS then + // if not ACCT then ERROR! + //OK! Action5: TLogonActions = - (6, FTP_OK, 3, 1, FTP_OK, 6, 2, FTP_OK, FTP_ERR, 0, 0, 0, 0, 0, 0, 0, 0, 0); - // USER fireID@remotehost + (6, FTP_OK, 3, + 1, FTP_OK, 6, + 2, FTP_OK, FTP_ERR, + 0, 0, 0, 0, 0, 0, 0, 0, 0); + + //if not USER @ then + // if not PASS then ERROR! + //if not USER then + // if not PASS then + // if not ACCT then ERROR! + //OK! Action6: TLogonActions = - (8, 6, 3, 4, 6, FTP_ERR, 0, FTP_OK, 9, 1, FTP_OK, 12, 2, FTP_OK, FTP_ERR, + (8, 6, 3, + 4, 6, FTP_ERR, + 0, FTP_OK, 9, + 1, FTP_OK, 12, + 2, FTP_OK, FTP_ERR, 0, 0, 0); - // USER remoteID@remotehost fireID + + //if USER @ then ERROR! + //if not PASS then + // if not ACCT then ERROR! + //OK! Action7: TLogonActions = - (9, FTP_ERR, 3, 1, FTP_OK, 6, 2, FTP_OK, FTP_ERR, 0, 0, 0, 0, 0, 0, 0, 0, 0); - // USER remoteID@fireID@remotehost + (9, FTP_ERR, 3, + 1, FTP_OK, 6, + 2, FTP_OK, FTP_ERR, + 0, 0, 0, 0, 0, 0, 0, 0, 0); + + //if not USER @@ then + // if not PASS @ then + // if not ACCT then ERROR! + //OK! Action8: TLogonActions = - (10, FTP_OK, 3, 11, FTP_OK, 6, 2, FTP_OK, FTP_ERR, 0, 0, 0, 0, 0, 0, 0, 0, 0); + (10, FTP_OK, 3, + 11, FTP_OK, 6, + 2, FTP_OK, FTP_ERR, + 0, 0, 0, 0, 0, 0, 0, 0, 0); var FTPServer: string; LogonActions: TLogonActions; @@ -362,6 +448,8 @@ function TFTPSend.Connect: Boolean; begin FSock.CloseSocket; FSock.CreateSocket; + if FFullSSL then + FSock.SSLEnabled := True; FSock.Bind(FIPInterface, cAnyPort); if FFWHost = '' then FSock.Connect(FTargetHost, FTargetPort) @@ -376,10 +464,22 @@ begin FCanResume := False; if not Connect then Exit; + FIsTLS := FFullSSL; if (ReadResult div 100) <> 2 then Exit; + if FAutoTLS and not(FIsTLS) then + if (FTPCommand('AUTH TLS') div 100) = 2 then + begin + FSock.SSLDoConnect; + FIsTLS := True; + end; if not Auth(FFWMode) then Exit; + if FIsTLS then + begin + FTPCommand('PROT P'); + FTPCommand('PBSZ 0'); + end; FTPCommand('TYPE I'); FTPCommand('STRU F'); FTPCommand('MODE S'); @@ -458,12 +558,13 @@ begin FSock.Bind(FIPInterface, s); if FDSock.LastError <> 0 then Exit; + FDSock.SetLinger(True, 10); FDSock.Listen; FDSock.GetSins; FDataIP := FDSock.GetLocalSinIP; FDataIP := FDSock.ResolveName(FDataIP); FDataPort := IntToStr(FDSock.GetLocalSinPort); - s := StringReplace(FDataIP, '.', ','); + s := ReplaceString(FDataIP, '.', ','); s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256) + ',' + IntToStr(FDSock.GetLocalSinPort mod 256); Result := (FTPCommand(s) div 100) = 2; @@ -488,6 +589,8 @@ begin Result := True; end; end; + if FIsTLS then + FDSock.SSLDoConnect; end; function TFTPSend.DataRead(const DestStream: TStream): Boolean; @@ -604,7 +707,10 @@ begin try if not DataSocket then Exit; - FTPCommand('TYPE I'); + if FBinaryMode then + FTPCommand('TYPE I') + else + FTPCommand('TYPE A'); if Restore then begin RetrStream.Seek(0, soFromEnd); @@ -642,7 +748,10 @@ begin try if not DataSocket then Exit; - FTPCommand('TYPE I'); + if FBinaryMode then + FTPCommand('TYPE I') + else + FTPCommand('TYPE A'); StorSize := SendStream.Size; if not FCanResume then RestoreAt := 0; @@ -759,6 +868,11 @@ begin end; end; +procedure TFTPSend.Abort; +begin + FDSock.CloseSocket; +end; + {==============================================================================} constructor TFTPList.Create; @@ -965,11 +1079,11 @@ begin else begin flr.Readable := true; - flr.Filesize := StrToIntDef(s, 0); + flr.FileSize := StrToIntDef(s, 0); end; if Value = '' then Exit; - flr.FileName := Trim(s); + flr.FileName := Trim(Value); Result := True; Exit; end; @@ -1103,27 +1217,27 @@ begin Exit; if not ToFTP.Login then Exit; - if FromFTP.FTPCommand('PASV') <> 227 then + if (FromFTP.FTPCommand('PASV') div 100) <> 2 then Exit; FromFTP.ParseRemote(FromFTP.ResultString); - s := StringReplace(FromFTP.DataIP, '.', ','); + s := ReplaceString(FromFTP.DataIP, '.', ','); s := 'PORT ' + s + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) div 256) + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) mod 256); - if ToFTP.FTPCommand(s) <> 200 then + if (ToFTP.FTPCommand(s) div 100) <> 2 then Exit; - x := FromFTP.FTPCommand('STOR ' + FromFile); - if (x <> 125) and (x <> 150) then + x := ToFTP.FTPCommand('RETR ' + FromFile); + if (x div 100) <> 1 then Exit; - x := ToFTP.FTPCommand('RETR ' + ToFile); - if (x <> 125) and (x <> 150) then + x := FromFTP.FTPCommand('STOR ' + ToFile); + if (x div 100) <> 1 then Exit; FromFTP.Timeout := 21600000; x := FromFTP.ReadResult; - if (x <> 226) and (x <> 250) then + if (x div 100) <> 2 then Exit; ToFTP.Timeout := 21600000; x := ToFTP.ReadResult; - if (x <> 226) and (x <> 250) then + if (x div 100) <> 2 then Exit; Result := True; finally @@ -1132,9 +1246,4 @@ begin end; end; -procedure TFTPSend.Abort; -begin - FDSock.CloseSocket; -end; - end. diff --git a/httpsend.pas b/httpsend.pas index 43b9304..bbf2c6b 100644 --- a/httpsend.pas +++ b/httpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 003.002.000 | +| Project : Delphree - Synapse | 003.004.004 | |==============================================================================| | Content: HTTP client | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2002. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -75,18 +75,29 @@ type FProxyPass: string; FResultCode: Integer; FResultString: string; + FUserAgent: string; + FCookies: TStringList; + FDownloadSize: integer; + FUploadSize: integer; + FRangeStart: integer; + FRangeEnd: integer; function ReadUnknown: Boolean; function ReadIdentity(Size: Integer): Boolean; function ReadChunked: Boolean; + procedure ParseCookies; public constructor Create; destructor Destroy; override; procedure Clear; procedure DecodeStatus(const Value: string); function HTTPMethod(const Method, URL: string): Boolean; + procedure Abort; published - property Headers: TStringList read FHeaders Write FHeaders; - property Document: TMemoryStream read FDocument Write FDocument; + property Headers: TStringList read FHeaders; + property Cookies: TStringList read FCookies; + property Document: TMemoryStream read FDocument; + property RangeStart: integer read FRangeStart Write FRangeStart; + property RangeEnd: integer read FRangeEnd Write FRangeEnd; property MimeType: string read FMimeType Write FMimeType; property Protocol: string read FProtocol Write FProtocol; property KeepAlive: Boolean read FKeepAlive Write FKeepAlive; @@ -94,8 +105,11 @@ type property ProxyPort: string read FProxyPort Write FProxyPort; property ProxyUser: string read FProxyUser Write FProxyUser; property ProxyPass: string read FProxyPass Write FProxyPass; + property UserAgent: string read FUserAgent Write FUserAgent; property ResultCode: Integer read FResultCode; property ResultString: string read FResultString; + property DownloadSize: integer read FDownloadSize; + property UploadSize: integer read FUploadSize; property Sock: TTCPBlockSocket read FSock; end; @@ -108,18 +122,16 @@ function HttpPostFile(const URL, FieldName, FileName: string; implementation -const - CRLF = #13#10; - constructor THTTPSend.Create; begin inherited Create; FHeaders := TStringList.Create; + FCookies := TStringList.Create; FDocument := TMemoryStream.Create; FSock := TTCPBlockSocket.Create; + FSock.ConvertLineEnd := True; FSock.SizeRecvBuffer := 65536; FSock.SizeSendBuffer := 65536; - FSock.ConvertLineEnd := True; FTimeout := 300000; FTargetPort := cHttpProtocol; FProxyHost := ''; @@ -130,6 +142,9 @@ begin FAlivePort := ''; FProtocol := '1.0'; FKeepAlive := True; + FUserAgent := 'Mozilla/4.0 (compatible; Synapse)'; + FDownloadSize := 0; + FUploadSize := 0; Clear; end; @@ -137,12 +152,15 @@ destructor THTTPSend.Destroy; begin FSock.Free; FDocument.Free; + FCookies.Free; FHeaders.Free; inherited Destroy; end; procedure THTTPSend.Clear; begin + FRangeStart := 0; + FRangeEnd := 0; FDocument.Clear; FHeaders.Clear; FMimeType := 'text/html'; @@ -170,11 +188,14 @@ var Prot, User, Pass, Host, Port, Path, Para, URI: string; s, su: string; HttpTunnel: Boolean; + n: integer; begin {initial values} Result := False; FResultCode := 500; FResultString := ''; + FDownloadSize := 0; + FUploadSize := 0; URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para); @@ -208,6 +229,15 @@ begin if FMimeType <> '' then FHeaders.Insert(0, 'Content-Type: ' + FMimeType); end; + { setting User-agent } + if FUserAgent <> '' then + FHeaders.Insert(0, 'User-Agent: ' + FUserAgent); + { setting Ranges } + if FRangeEnd > 0 then + FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd)); + { setting Cookies } + for n := 0 to FCookies.Count - 1 do + FHeaders.Insert(0, 'Cookie: ' + FCookies[n]); { setting KeepAlives } if not FKeepAlive then FHeaders.Insert(0, 'Connection: close'); @@ -309,6 +339,7 @@ begin { send document } if Sending then begin + FUploadSize := FDocument.Size; FSock.SendBuffer(FDocument.Memory, FDocument.Size); if FSock.LastError <> 0 then Exit; @@ -382,15 +413,16 @@ begin TE_CHUNKED: ReadChunked; end; + Result := True; FDocument.Seek(0, soFromBeginning); - Result := True; if ToClose then begin FSock.CloseSocket; FAliveHost := ''; FAlivePort := ''; end; + ParseCookies; end; function THTTPSend.ReadUnknown: Boolean; @@ -407,17 +439,13 @@ end; function THTTPSend.ReadIdentity(Size: Integer): Boolean; var - mem: TMemoryStream; + x: integer; begin - mem := TMemoryStream.Create; - try - mem.SetSize(Size); - FSock.RecvBufferEx(mem.Memory, Size, FTimeout); - Result := FSock.LastError = 0; - FDocument.CopyFrom(mem, 0); - finally - mem.Free; - end; + FDownloadSize := Size; + FDocument.SetSize(FDocument.Position + Size); + x := FSock.RecvBufferEx(IncPoint(FDocument.Memory, FDocument.Position), Size, FTimeout); + FDocument.SetSize(FDocument.Position + x); + Result := FSock.LastError = 0; end; function THTTPSend.ReadChunked: Boolean; @@ -440,6 +468,28 @@ begin Result := FSock.LastError = 0; end; +procedure THTTPSend.ParseCookies; +var + n: integer; + s: string; + sn, sv: string; +begin + for n := 0 to FHeaders.Count - 1 do + if Pos('set-cookie:', lowercase(FHeaders[n])) = 1 then + begin + s := SeparateRight(FHeaders[n], ':'); + s := trim(SeparateLeft(s, ';')); + sn := trim(SeparateLeft(s, '=')); + sv := trim(SeparateRight(s, '=')); + FCookies.Values[sn] := sv; + end; +end; + +procedure THTTPSend.Abort; +begin + FSock.CloseSocket; +end; + {==============================================================================} function HttpGetText(const URL: string; const Response: TStrings): Boolean; @@ -502,8 +552,6 @@ end; function HttpPostFile(const URL, FieldName, FileName: string; const Data: TStream; const ResultData: TStrings): Boolean; -const - CRLF = #$0D + #$0A; var HTTP: THTTPSend; Bound, s: string; @@ -519,7 +567,7 @@ begin HTTP.Document.CopyFrom(Data, 0); s := CRLF + '--' + Bound + '--' + CRLF; HTTP.Document.Write(Pointer(s)^, Length(s)); - HTTP.MimeType := 'multipart/form-data, boundary=' + Bound; + HTTP.MimeType := 'multipart/form-data; boundary=' + Bound; Result := HTTP.HTTPMethod('POST', URL); ResultData.LoadFromStream(HTTP.Document); finally diff --git a/imapsend.pas b/imapsend.pas index 23a464e..792def7 100644 --- a/imapsend.pas +++ b/imapsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.001.000 | +| Project : Delphree - Synapse | 002.002.002 | |==============================================================================| | Content: IMAP4rev1 client | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2001-2002. | +| Portions created by Lukas Gebauer are Copyright (c)2001-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -115,6 +115,7 @@ type function SetFlagsMess(MessID: integer; Flags: string): Boolean; function GetFlagsMess(MessID: integer; var Flags: string): Boolean; function StartTLS: Boolean; + function GetUID(MessID: integer; var UID : Integer): Boolean; function FindCap(const Value: string): string; published property ResultString: string read FResultString; @@ -135,19 +136,16 @@ type implementation -const - CRLF = #13#10; - constructor TIMAPSend.Create; begin inherited Create; FFullResult := TStringList.Create; FIMAPcap := TStringList.Create; FSock := TTCPBlockSocket.Create; + FSock.ConvertLineEnd := True; FSock.CreateSocket; FSock.SizeRecvBuffer := 32768; FSock.SizeSendBuffer := 32768; - FSock.ConvertLineEnd := True; FTimeout := 300000; FTargetPort := cIMAPProtocol; FUsername := ''; @@ -196,9 +194,7 @@ begin l := StrToIntDef(s, -1); if l <> -1 then begin - setlength(s, l); - x := FSock.recvbufferex(PChar(s), l, FTimeout); - SetLength(s, x); + s := FSock.RecvBufferStr(l, FTimeout); FFullResult.Add(s); end; end; @@ -220,7 +216,8 @@ var begin Inc(FTagCommand); l := Length(Data.Text); - FSock.SendString(IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF); + FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF); + FSock.RecvString(FTimeout); FSock.SendString(Data.Text + CRLF); Result := ReadResult; end; @@ -247,9 +244,18 @@ begin for n := 0 to FFullResult.Count - 1 do begin s := FFullResult[n]; - x := RPos(' ', s); - if (x > 0) and (Pos('NOSELECT', UpperCase(s)) = 0) then - Value.Add(Copy(s, x + 1, Length(s) - x)); + if (s <> '') and (Pos('\NOSELECT', UpperCase(s)) = 0) then + begin + if s[Length(s)] = '"' then + begin + Delete(s, Length(s), 1); + x := RPos('"', s); + end + else + x := RPos(' ', s); + if (x > 0) then + Value.Add(Copy(s, x + 1, Length(s) - x)); + end; end; end; @@ -472,7 +478,7 @@ begin for n := 0 to FFullResult.Count - 1 do begin s := UpperCase(FFullResult[n]); - if (Pos('* STATUS ', s) = 1) and (Pos(Value, s) > 0 ) then + if (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then begin t := SeparateRight(s, Value); t := SeparateLeft(t, ')'); @@ -598,7 +604,7 @@ begin for n := 0 to FFullResult.Count - 1 do begin s := uppercase(FFullResult[n]); - if Pos('* FETCH (FLAGS', s) = 1 then + if (Pos('* ', s) = 1) and (Pos('FLAGS', s) > 0 ) then begin s := SeparateRight(s, 'FLAGS'); s := Separateright(s, '('); @@ -620,6 +626,27 @@ begin end; end; +//Paul Buskermolen +function TIMAPSend.GetUID(MessID: integer; var UID : Integer): boolean; +var + s, sUid: string; + n: integer; +begin + sUID := ''; + s := 'FETCH ' + IntToStr(MessID) + ' UID'; + Result := IMAPcommand(s) = 'OK'; + for n := 0 to FFullResult.Count - 1 do + begin + s := uppercase(FFullResult[n]); + if Pos('FETCH (UID', s) >= 1 then + begin + s := Separateright(s, '(UID '); + sUID := SeparateLeft(s, ')'); + end; + end; + UID := StrToIntDef(sUID, 0); +end; + {==============================================================================} end. diff --git a/mimeinln.pas b/mimeinln.pas index b8834d2..4a132da 100644 --- a/mimeinln.pas +++ b/mimeinln.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.000.003 | +| Project : Delphree - Synapse | 001.000.005 | |==============================================================================| | Content: Inline MIME support procedures and functions | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000,2001. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -64,7 +64,7 @@ implementation function InlineDecode(const Value: string; CP: TMimeChar): string; var - s, su: string; + s, su, v: string; x, y, z, n: Integer; ichar: TMimeChar; c: Char; @@ -88,12 +88,17 @@ var end; begin - Result := Value; - x := Pos('=?', Result); - y := SearchEndInline(Result, x); - while (y > x) and (x > 0) do //fix by Marcus Moennig (minibbjd@gmx.de) + Result := ''; + v := Value; + x := Pos('=?', v); + y := SearchEndInline(v, x); + while (y > x) and (x > 0) do begin - s := Copy(Result, x, y - x + 2); + s := Copy(v, 1, x - 1); + if Trim(s) <> '' then + Result := Result + s; + s := Copy(v, x, y - x + 2); + Delete(v, 1, y + 1); su := Copy(s, 3, Length(s) - 4); ichar := GetCPFromID(su); z := Pos('?', su); @@ -118,11 +123,11 @@ begin s := CharsetConversion(s, ichar, CP); end; end; - Result := Copy(Result, 1, x - 1) + s + - Copy(Result, y + 2, Length(Result) - y - 1); - x := Pos('=?', Result); - y := SearchEndInline(Result, x); + Result := Result + s; + x := Pos('=?', v); + y := SearchEndInline(v, x); end; + Result := Result + v; end; {==============================================================================} diff --git a/mimemess.pas b/mimemess.pas index 394eaff..669ecc8 100644 --- a/mimemess.pas +++ b/mimemess.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.001.001 | +| Project : Delphree - Synapse | 002.001.002 | |==============================================================================| | Content: MIME message object | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2002. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -154,9 +154,9 @@ begin if FCustomHeaders[n] <> '' then Value.Insert(0, FCustomHeaders[n]); if FXMailer = '' then - Value.Insert(0, 'x-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer') + Value.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer') else - Value.Insert(0, 'x-mailer: ' + FXMailer); + Value.Insert(0, 'X-mailer: ' + FXMailer); Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)'); if FOrganization <> '' then Value.Insert(0, 'Organization: ' + InlineCode(FOrganization)); diff --git a/mimepart.pas b/mimepart.pas index a9593c4..03c6662 100644 --- a/mimepart.pas +++ b/mimepart.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.001.002 | +| Project : Delphree - Synapse | 002.003.002 | |==============================================================================| | Content: MIME support procedures and functions | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2002. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -95,6 +95,8 @@ type public constructor Create; destructor Destroy; override; + procedure Assign(Value: TMimePart); + procedure AssignSubParts(Value: TMimePart); procedure Clear; procedure DecodePart; procedure DecodePartHeader; @@ -103,6 +105,7 @@ type procedure MimeTypeFromExt(Value: string); function GetSubPartCount: integer; function GetSubPart(index: integer): TMimePart; + procedure DeleteSubPart(index: integer); procedure ClearSubParts; function AddSubPart: TMimePart; procedure DecomposeParts; @@ -255,6 +258,47 @@ end; {==============================================================================} +procedure TMIMEPart.Assign(Value: TMimePart); +begin + Primary := Value.Primary; + Encoding := Value.Encoding; + Charset := Value.Charset; + DefaultCharset := Value.DefaultCharset; + PrimaryCode := Value.PrimaryCode; + EncodingCode := Value.EncodingCode; + CharsetCode := Value.CharsetCode; + TargetCharset := Value.TargetCharset; + Secondary := Value.Secondary; + Description := Value.Description; + Disposition := Value.Disposition; + ContentID := Value.ContentID; + Boundary := Value.Boundary; + FileName := Value.FileName; + Lines.Assign(Value.Lines); + PartBody.Assign(Value.PartBody); + Headers.Assign(Value.Headers); + PrePart.Assign(Value.PrePart); + PostPart.Assign(Value.PostPart); + MaxLineLength := Value.MaxLineLength; +end; + +{==============================================================================} + +procedure TMIMEPart.AssignSubParts(Value: TMimePart); +var + n: integer; + p: TMimePart; +begin + Assign(Value); + for n := 0 to Value.GetSubPartCount - 1 do + begin + p := AddSubPart; + p.AssignSubParts(Value.GetSubPart(n)); + end; +end; + +{==============================================================================} + function TMIMEPart.GetSubPartCount: integer; begin Result := FSubParts.Count; @@ -271,6 +315,17 @@ end; {==============================================================================} +procedure TMIMEPart.DeleteSubPart(index: integer); +begin + if Index < GetSubPartCount then + begin + GetSubPart(Index).Free; + FSubParts.Delete(Index); + end; +end; + +{==============================================================================} + procedure TMIMEPart.ClearSubParts; var n: integer; @@ -342,7 +397,7 @@ begin Mime := AddSubPart; while FLines.Count > x do begin - s := TrimRight(FLines[x]); + s := FLines[x]; Inc(x); if Pos('--' + FBoundary, s) = 1 then Break; @@ -702,7 +757,7 @@ begin begin s := ''; if FFileName <> '' then - s := '; FileName="' + FFileName + '"'; + s := '; FileName="' + InlineCode(FFileName) + '"'; FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s); end; if FContentID <> '' then diff --git a/nntpsend.pas b/nntpsend.pas index 3a6d4e5..d60d576 100644 --- a/nntpsend.pas +++ b/nntpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.001.000 | +| Project : Delphree - Synapse | 001.002.003 | |==============================================================================| | Content: NNTP client | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -62,6 +62,9 @@ type FResultCode: Integer; FResultString: string; FData: TStringList; + FDataToSend: TStringList; + FUsername: string; + FPassword: string; function ReadResult: Integer; function ReadData: boolean; function SendData: boolean; @@ -71,6 +74,9 @@ type destructor Destroy; override; function Login: Boolean; procedure Logout; + function DoCommand(const Command: string): boolean; + function DoCommandRead(const Command: string): boolean; + function DoCommandWrite(const Command: string): boolean; function GetArticle(const Value: string): Boolean; function GetBody(const Value: string): Boolean; function GetHead(const Value: string): Boolean; @@ -84,7 +90,10 @@ type function NewArticles(const Group: string; Since: TDateTime): Boolean; function PostArticle: Boolean; function SwitchToSlave: Boolean; + function Xover(xoStart, xoEnd: string): boolean; published + property Username: string read FUsername write FUsername; + property Password: string read FPassword write FPassword; property ResultCode: Integer read FResultCode; property ResultString: string read FResultString; property Data: TStringList read FData; @@ -93,23 +102,23 @@ type implementation -const - CRLF = #13#10; - constructor TNNTPSend.Create; begin inherited Create; FData := TStringList.Create; + FDataToSend := TStringList.Create; FSock := TTCPBlockSocket.Create; - FSock.CreateSocket; FSock.ConvertLineEnd := True; FTimeout := 300000; FTargetPort := cNNTPProtocol; + FUsername := ''; + FPassword := ''; end; destructor TNNTPSend.Destroy; begin FSock.Free; + FDataToSend.Free; FData.Free; inherited Destroy; end; @@ -149,22 +158,26 @@ var s: string; n: integer; begin - for n := 0 to FData.Count -1 do + for n := 0 to FDataToSend.Count - 1 do begin - s := FData[n]; - if (s <> '') and (s[1]='.') then + s := FDataToSend[n]; + if (s <> '') and (s[1] = '.') then s := s + '.'; FSock.SendString(s + CRLF); if FSock.LastError <> 0 then break; end; + if FDataToSend.Count = 0 then + FSock.SendString(CRLF); + if FSock.LastError = 0 then + FSock.SendString('.' + CRLF); + FDataToSend.Clear; Result := FSock.LastError = 0; end; function TNNTPSend.Connect: Boolean; begin FSock.CloseSocket; - FSock.CreateSocket; FSock.Bind(FIPInterface, cAnyPort); FSock.Connect(FTargetHost, FTargetPort); Result := FSock.LastError = 0; @@ -176,6 +189,15 @@ begin if not Connect then Exit; Result := (ReadResult div 100) = 2; + if (FUsername <> '') and Result then + begin + FSock.SendString('AUTHINFO USER ' + FUsername + CRLF); + if (ReadResult div 100) = 3 then + begin + FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF); + Result := (ReadResult div 100) = 2; + end; + end; end; procedure TNNTPSend.Logout; @@ -185,136 +207,132 @@ begin FSock.CloseSocket; end; +function TNNTPSend.DoCommand(const Command: string): Boolean; +begin + FSock.SendString(Command + CRLF); + Result := (ReadResult div 100) = 2; + Result := Result and (FSock.LastError = 0); +end; + +function TNNTPSend.DoCommandRead(const Command: string): Boolean; +begin + Result := DoCommand(Command); + if Result then + begin + Result := ReadData; + Result := Result and (FSock.LastError = 0); + end; +end; + +function TNNTPSend.DoCommandWrite(const Command: string): Boolean; +var + x: integer; +begin + FDataToSend.Assign(FData); + FSock.SendString(Command + CRLF); + x := (ReadResult div 100); + if x = 3 then + begin + SendData; + x := (ReadResult div 100); + end; + Result := x = 2; + Result := Result and (FSock.LastError = 0); +end; + function TNNTPSend.GetArticle(const Value: string): Boolean; var s: string; begin - Result := False; s := 'ARTICLE'; if Value <> '' then s := s + ' ' + Value; - FSock.SendString(s + CRLF); - if (ReadResult div 100) <> 2 then - Exit; - Result := ReadData; + Result := DoCommandRead(s); end; function TNNTPSend.GetBody(const Value: string): Boolean; var s: string; begin - Result := False; s := 'BODY'; if Value <> '' then s := s + ' ' + Value; - FSock.SendString(s + CRLF); - if (ReadResult div 100) <> 2 then - Exit; - Result := ReadData; + Result := DoCommandRead(s); end; function TNNTPSend.GetHead(const Value: string): Boolean; var s: string; begin - Result := False; s := 'HEAD'; if Value <> '' then s := s + ' ' + Value; - FSock.SendString(s + CRLF); - if (ReadResult div 100) <> 2 then - Exit; - Result := ReadData; + Result := DoCommandRead(s); end; function TNNTPSend.GetStat(const Value: string): Boolean; var s: string; begin - Result := False; s := 'STAT'; if Value <> '' then s := s + ' ' + Value; - FSock.SendString(s + CRLF); - if (ReadResult div 100) <> 2 then - Exit; - Result := FSock.LastError = 0; + Result := DoCommandRead(s); end; function TNNTPSend.SelectGroup(const Value: string): Boolean; begin - FSock.SendString('GROUP ' + Value + CRLF); - Result := (ReadResult div 100) = 2; + Result := DoCommand('GROUP ' + Value); end; function TNNTPSend.IHave(const MessID: string): Boolean; -var - x: integer; begin - FSock.SendString('IHAVE ' + MessID + CRLF); - x := (ReadResult div 100); - if x = 3 then - begin - SendData; - x := (ReadResult div 100); - end; - Result := x = 2; + Result := DoCommandWrite('IHAVE ' + MessID); end; function TNNTPSend.GotoLast: Boolean; begin - FSock.SendString('LAST' + CRLF); - Result := (ReadResult div 100) = 2; + Result := DoCommand('LAST'); end; function TNNTPSend.GotoNext: Boolean; begin - FSock.SendString('NEXT' + CRLF); - Result := (ReadResult div 100) = 2; + Result := DoCommand('NEXT'); end; function TNNTPSend.ListGroups: Boolean; begin - FSock.SendString('LIST' + CRLF); - Result := (ReadResult div 100) = 2; - if Result then - Result := ReadData; + Result := DoCommandRead('LIST'); end; function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean; begin - FSock.SendString('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT' + CRLF); - Result := (ReadResult div 100) = 2; - if Result then - Result := ReadData; + Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT'); end; function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean; begin - FSock.SendString('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT' + CRLF); - Result := (ReadResult div 100) = 2; - if Result then - Result := ReadData; + Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT'); end; function TNNTPSend.PostArticle: Boolean; -var - x: integer; begin - FSock.SendString('POST' + CRLF); - x := (ReadResult div 100); - if x = 3 then - begin - SendData; - x := (ReadResult div 100); - end; - Result := x = 2; + Result := DoCommandWrite('POST'); end; function TNNTPSend.SwitchToSlave: Boolean; begin - FSock.SendString('SLAVE' + CRLF); - Result := (ReadResult div 100) = 2; + Result := DoCommand('SLAVE'); +end; + +function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean; +var + s: string; +begin + s := 'XOVER ' + xoStart; + if xoEnd <> xoStart then + s := s + '-' + xoEnd; + Result := DoCommandRead(s); end; {==============================================================================} diff --git a/pingsend.pas b/pingsend.pas index 626bfb5..5e50963 100644 --- a/pingsend.pas +++ b/pingsend.pas @@ -3,7 +3,7 @@ |==============================================================================| | Content: PING sender | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000,2001. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | diff --git a/pop3send.pas b/pop3send.pas index 9b66e76..63aff73 100644 --- a/pop3send.pas +++ b/pop3send.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.001.000 | +| Project : Delphree - Synapse | 002.001.004 | |==============================================================================| | Content: POP3 client | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2001-2002. | +| Portions created by Lukas Gebauer are Copyright (c)2001-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -116,9 +116,6 @@ type implementation -const - CRLF = #13#10; - constructor TPOP3Send.Create; begin inherited Create; @@ -126,7 +123,7 @@ begin FPOP3cap := TStringList.Create; FSock := TTCPBlockSocket.Create; FSock.CreateSocket; - FSock.ConvertLineEnd := True; + FSock.ConvertLineEnd := true; FTimeout := 300000; FTargetPort := cPop3Protocol; FUsername := ''; @@ -161,6 +158,9 @@ begin s := FSock.RecvString(FTimeout); if s = '.' then Break; + if s <> '' then + if s[1] = '.' then + Delete(s, 1, 1); FFullResult.Add(s); until FSock.LastError <> 0; FResultCode := Result; @@ -203,7 +203,6 @@ end; function TPOP3Send.Capability: Boolean; begin FPOP3cap.Clear; - Result := False; FSock.SendString('CAPA' + CRLF); Result := ReadResult(True) = 1; if Result then diff --git a/slogsend.pas b/slogsend.pas index 7cd1b4c..a106a8f 100644 --- a/slogsend.pas +++ b/slogsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.001.000 | +| Project : Delphree - Synapse | 001.001.001 | |==============================================================================| | Content: SysLog client | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2001. | +| Portions created by Lukas Gebauer are Copyright (c)2001-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -167,7 +167,6 @@ end; function ToSysLog(const SyslogServer: string; Facil: Byte; Sever: TSyslogSeverity; const Content: string): Boolean; begin - Result := False; with TSyslogSend.Create do try TargetHost :=SyslogServer; diff --git a/smtpsend.pas b/smtpsend.pas index 5c6808d..014953e 100644 --- a/smtpsend.pas +++ b/smtpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 003.002.001 | +| Project : Delphree - Synapse | 003.002.004 | |==============================================================================| | Content: SMTP client | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2002. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -126,9 +126,6 @@ function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string; implementation -const - CRLF = #13#10; - constructor TSMTPSend.Create; begin inherited Create; @@ -136,7 +133,7 @@ begin FESMTPcap := TStringList.Create; FSock := TTCPBlockSocket.Create; FSock.CreateSocket; - FSock.ConvertLineEnd := True; + FSock.ConvertLineEnd := true; FTimeout := 300000; FTargetPort := cSmtpProtocol; FUsername := ''; @@ -547,11 +544,11 @@ begin try t.Assign(MailData); t.Insert(0, ''); - t.Insert(0, 'x-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer'); - t.Insert(0, 'subject: ' + Subject); - t.Insert(0, 'date: ' + Rfc822DateTime(now)); - t.Insert(0, 'to: ' + MailTo); - t.Insert(0, 'from: ' + MailFrom); + t.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer'); + t.Insert(0, 'Subject: ' + Subject); + t.Insert(0, 'Date: ' + Rfc822DateTime(now)); + t.Insert(0, 'To: ' + MailTo); + t.Insert(0, 'From: ' + MailFrom); Result := SendToRaw(MailFrom, MailTo, SMTPHost, t, Username, Password); finally t.Free; diff --git a/snmpsend.pas b/snmpsend.pas index eede4da..57eda2e 100644 --- a/snmpsend.pas +++ b/snmpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.005.000 | +| Project : Delphree - Synapse | 002.006.000 | |==============================================================================| | Content: SNMP client | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000,2001. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -102,6 +102,8 @@ type procedure MIBAdd(const MIB, Value: string; ValueType: Integer); procedure MIBDelete(Index: Integer); function MIBGet(const MIB: string): string; + function MIBCount: integer; + function MIBByIndex(Index: Integer): TSNMPMib; published property Version: Integer read FVersion write FVersion; property Community: string read FCommunity write FCommunity; @@ -262,19 +264,31 @@ end; procedure TSNMPRec.MIBDelete(Index: Integer); begin - if (Index >= 0) and (Index < FSNMPMibList.Count) then + if (Index >= 0) and (Index < MIBCount) then begin TSNMPMib(FSNMPMibList[Index]).Free; FSNMPMibList.Delete(Index); end; end; +function TSNMPRec.MIBCount: integer; +begin + Result := FSNMPMibList.Count; +end; + +function TSNMPRec.MIBByIndex(Index: Integer): TSNMPMib; +begin + Result := nil; + if (Index >= 0) and (Index < MIBCount) then + Result := TSNMPMib(FSNMPMibList[Index]); +end; + function TSNMPRec.MIBGet(const MIB: string): string; var i: Integer; begin Result := ''; - for i := 0 to FSNMPMibList.Count - 1 do + for i := 0 to MIBCount - 1 do begin if ((TSNMPMib(FSNMPMibList[i])).OID = MIB) then begin @@ -365,25 +379,32 @@ begin end; end; +function InternalGetNext(const SNMPSend: TSNMPSend; var OID: string; + const Community: string; var Value: string): Boolean; +begin + SNMPSend.Query.Clear; + SNMPSend.Query.ID := SNMPSend.Query.ID + 1; + SNMPSend.Query.Community := Community; + SNMPSend.Query.PDUType := PDUGetNextRequest; + SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL); + 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; +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; + Result := InternalGetNext(SNMPSend, OID, Community, Value); finally SNMPSend.Free; end; @@ -394,33 +415,39 @@ var OID: string; s: string; col,row: string; - lastcol: string; - x, n: integer; + x: integer; + SNMPSend: TSNMPSend; + RowList: TStringList; 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; + SNMPSend := TSNMPSend.Create; + RowList := TStringList.Create; + try + SNMPSend.TargetHost := SNMPHost; + OID := BaseOID; + repeat + Result := InternalGetNext(SNMPSend, OID, Community, s); + if Pos(BaseOID, OID) <> 1 then + break; + row := separateright(oid, baseoid + '.'); + col := fetch(row, '.'); + + if IsBinaryString(s) then + s := StrToHex(s); + x := RowList.indexOf(Row); + if x < 0 then + begin + x := RowList.add(Row); + Value.Add(''); + end; + if (Value[x] <> '') then + Value[x] := Value[x] + ','; + Value[x] := Value[x] + AnsiQuotedStr(s, '"'); + until not result; + finally + SNMPSend.Free; + RowList.Free; + end; end; function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: string; var Value: String): Boolean; diff --git a/snmptrap.pas b/snmptrap.pas index e75862c..5ff2d07 100644 --- a/snmptrap.pas +++ b/snmptrap.pas @@ -3,7 +3,7 @@ |==============================================================================| | Content: SNMP traps | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Hernan Sanchez are Copyright (c)2000,2001. | +| Portions created by Hernan Sanchez are Copyright (c)2000-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | diff --git a/sntpsend.pas b/sntpsend.pas index d64aeba..fa77dfd 100644 --- a/sntpsend.pas +++ b/sntpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.002.000 | +| Project : Delphree - Synapse | 002.002.001 | |==============================================================================| | Content: SNTP client | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000,2001. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -154,12 +154,12 @@ var begin d := (dt - 2) * 86400; d1 := frac(d); - d := trunc(d); - if d>maxilongint then + if d > maxilongint then d := d - maxi - 1; + d := trunc(d); d1 := Trunc(d1 * 10000) / 10000; d1 := d1 * maxi; - if d1>maxilongint then + if d1 > maxilongint then d1 := d1 - maxi - 1; Nsec:=trunc(d); Nfrac:=trunc(d1); @@ -232,7 +232,7 @@ begin FillChar(q, SizeOf(q), 0); q.mode := $1B; t1 := GetUTTime; - EncodeTs(t1,q.org1,q.org2); + EncodeTs(t1, q.org1, q.org2); FSock.SendBuffer(@q, SizeOf(q)); FBuffer := FSock.RecvPacket(FTimeout); if FSock.LastError = 0 then diff --git a/synachar.pas b/synachar.pas index 263ac73..ab96e1f 100644 --- a/synachar.pas +++ b/synachar.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 004.000.001 | +| Project : Delphree - Synapse | 004.000.003 | |==============================================================================| | Content: Charset conversion support | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000,2001. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -671,7 +671,7 @@ const $0158, $0052, $0160, $0053, $0164, $0053, - $00DA, $0054, + $00DA, $0055, $016E, $0055, $00DD, $0059, $017D, $005A @@ -806,8 +806,15 @@ begin b[1] := 0; b[2] := 0; b[3] := 0; - if (Length(Value) + 1) < Index + mb then + b1 := 0; + b2 := 0; + b3 := 0; + b4 := 0; + if length(Value) < (Index + mb - 1) then + begin + Inc(index, mb); Exit; + end; s := ''; for n := 1 to mb do begin @@ -937,9 +944,9 @@ end; {==============================================================================} function UTF7toUCS2(const Value: string): string; var - n: Integer; + n, i: Integer; c: Char; - s: string; + s, t: string; begin Result := ''; n := 1; @@ -968,7 +975,18 @@ begin if s = '' then s := WriteMulti(Ord('+'), 0, 0, 0, 2) else - s := DecodeBase64(s); + begin + t := DecodeBase64(s); + if not odd(length(t)) then + s := t + else + begin //ill-formed sequence + t := s; + s := WriteMulti(Ord('+'), 0, 0, 0, 2); + for i := 1 to length(t) do + s := s + WriteMulti(Ord(t[i]), 0, 0, 0, 2); + end; + end; Result := Result + s; end; end; diff --git a/synacode.pas b/synacode.pas index 17accb5..0e94174 100644 --- a/synacode.pas +++ b/synacode.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.005.005 | +| Project : Delphree - Synapse | 001.006.001 | |==============================================================================| | Content: Coding and decoding support | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2002. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -113,6 +113,7 @@ function Encode3to4(const Value, Table: string): string; function DecodeBase64(const Value: string): string; function EncodeBase64(const Value: string): string; function DecodeUU(const Value: string): string; +function EncodeUU(const Value: string): string; function DecodeXX(const Value: string): string; function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; function Crc32(const Value: string): Integer; @@ -506,7 +507,11 @@ begin Exit; //ignore Table yet (set custom UUT) //begin decoding x := Pos(Value[1], uut) - 1; - x := Round((x / 3) * 4); + case (x mod 3) of + 0: x :=(x div 3)* 4; + 1: x :=((x div 3) * 4) + 2; + 2: x :=((x div 3) * 4) + 3; + end; //x - lenght UU line s := Copy(Value, 2, x); if s = '' then @@ -516,6 +521,15 @@ end; {==============================================================================} +function EncodeUU(const Value: string): string; +begin + Result := ''; + if Length(Value) < Length(TableUU) then + Result := TableUU[Length(Value) + 1] + Encode3to4(Value, TableUU); +end; + +{==============================================================================} + function DecodeXX(const Value: string): string; var s: string; @@ -531,7 +545,11 @@ begin Exit; //begin decoding x := Pos(Value[1], TableXX) - 1; - x := Round((x / 3) * 4); + case (x mod 3) of + 0: x :=(x div 3)* 4; + 1: x :=((x div 3) * 4) + 2; + 2: x :=((x div 3) * 4) + 3; + end; //x - lenght XX line s := Copy(Value, 2, x); if s = '' then diff --git a/synamisc.pas b/synamisc.pas new file mode 100644 index 0000000..d426541 --- /dev/null +++ b/synamisc.pas @@ -0,0 +1,306 @@ +{==============================================================================| +| Project : Delphree - Synapse | 001.000.004 | +|==============================================================================| +| Content: misc. procedures and functions | +|==============================================================================| +| Copyright (c)1999-2003, Lukas Gebauer | +| All rights reserved. | +| | +| 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-2003. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{$Q-} + +unit SynaMisc; + +interface + +uses + SynaUtil, blcksock, SysUtils, Classes, +{$IFDEF LINUX} + Libc; +{$ELSE} + Windows, Wininet; +{$ENDIF} + +Type + TProxySetting = record + Host: string; + Port: string; + Bypass: string; + end; + +procedure WakeOnLan(MAC, IP: string); +function GetDNS: string; +function GetIEProxy(protocol: string): TProxySetting; + +implementation + +{==============================================================================} +procedure WakeOnLan(MAC, IP: string); +var + sock: TUDPBlockSocket; + HexMac: string; + data: string; + n: integer; + b: Byte; +begin + if MAC <> '' then + begin + MAC := ReplaceString(MAC, '-', ''); + MAC := ReplaceString(MAC, ':', ''); + if Length(MAC) < 12 then + Exit; + HexMac := ''; + for n := 0 to 5 do + begin + b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0); + HexMac := HexMac + char(b); + end; + if IP = '' then + IP := cBroadcast; + sock := TUDPBlockSocket.Create; + try + sock.CreateSocket; + sock.EnableBroadcast(true); + sock.Connect(IP, '9'); + data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF; + for n := 1 to 16 do + data := data + HexMac; + sock.SendString(data); + finally + sock.Free; + end; + end; +end; + +{==============================================================================} + +{$IFNDEF LINUX} +function GetDNSbyIpHlp: string; +type + PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING; + TIP_ADDRESS_STRING = array[0..15] of char; + PTIP_ADDR_STRING = ^TIP_ADDR_STRING; + TIP_ADDR_STRING = packed record + Next: PTIP_ADDR_STRING; + IpAddress: TIP_ADDRESS_STRING; + IpMask: TIP_ADDRESS_STRING; + Context: DWORD; + end; + PTFixedInfo = ^TFixedInfo; + TFixedInfo = packed record + HostName: array[1..128 + 4] of char; + DomainName: array[1..128 + 4] of char; + CurrentDNSServer: PTIP_ADDR_STRING; + DNSServerList: TIP_ADDR_STRING; + NodeType: UINT; + ScopeID: array[1..256 + 4] of char; + EnableRouting: UINT; + EnableProxy: UINT; + EnableDNS: UINT; + end; +const + IpHlpDLL = 'IPHLPAPI.DLL'; +var + IpHlpModule: THandle; + FixedInfo: PTFixedInfo; + InfoSize: Longint; + PDnsServer: PTIP_ADDR_STRING; + err: integer; + GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall; +begin + InfoSize := 0; + Result := '...'; + IpHlpModule := LoadLibrary(IpHlpDLL); + if IpHlpModule = 0 then + exit; + try + GetNetworkParams := GetProcAddress(IpHlpModule,'GetNetworkParams'); + if @GetNetworkParams = nil then + Exit; + err := GetNetworkParams(Nil, @InfoSize); + if err <> ERROR_BUFFER_OVERFLOW then + Exit; + Result := ''; + GetMem (FixedInfo, InfoSize); + try + err := GetNetworkParams(FixedInfo, @InfoSize); + if err <> ERROR_SUCCESS then + exit; + with FixedInfo^ do + begin + Result := DnsServerList.IpAddress; + PDnsServer := DnsServerList.Next; + while PDnsServer <> Nil do + begin + if Result <> '' then + Result := Result + ','; + Result := Result + PDnsServer^.IPAddress; + PDnsServer := PDnsServer.Next; + end; + end; + finally + FreeMem(FixedInfo); + end; + finally + FreeLibrary(IpHlpModule); + end; +end; + +function ReadReg(SubKey, Vn: PChar): string; +var + OpenKey: HKEY; + DataType, DataSize: integer; + Temp: array [0..2048] of char; +begin + Result := ''; + if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE, + KEY_READ, OpenKey) = ERROR_SUCCESS then + begin + DataType := REG_SZ; + DataSize := SizeOf(Temp); + if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then + Result := string(Temp); + RegCloseKey(OpenKey); + end; +end ; +{$ENDIF} + +function GetDNS: string; +{$IFDEF LINUX} +var + l: TStringList; + n: integer; +begin + Result := ''; + l := TStringList.Create; + try + l.LoadFromFile('/etc/resolv.conf'); + for n := 0 to l.Count - 1 do + if Pos('NAMESERVER', uppercase(l[n])) = 1 then + begin + if Result <> '' then + Result := Result + ','; + Result := Result + SeparateRight(l[n], ' '); + end; + finally + l.Free; + end; +end; +{$ELSE} +const + NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary'; + NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters'; + W9xfix = 'System\CurrentControlSet\Services\MSTCP'; +begin + Result := GetDNSbyIpHlp; + if Result = '...' then + if Win32Platform = VER_PLATFORM_WIN32_NT then + begin + Result := ReadReg(NTdyn, 'NameServer'); + if result = '' then + Result := ReadReg(NTfix, 'NameServer'); + end + else + Result := ReadReg(W9xfix, 'NameServer'); +end; +{$ENDIF} + +{==============================================================================} + +function GetIEProxy(protocol: string): TProxySetting; +{$IFDEF LINUX} +begin + Result.Host := ''; + Result.Port := ''; + Result.Bypass := ''; +end; +{$ELSE} +var + ProxyInfo: PInternetProxyInfo; + Err: Boolean; + Len: DWORD; + Proxy: string; + DefProxy: string; + ProxyList: TStringList; + n: integer; +begin + Result.Host := ''; + Result.Port := ''; + Result.Bypass := ''; + if protocol = '' then + protocol := 'http'; + Len := 4096; + GetMem(ProxyInfo, Len); + ProxyList := TStringList.Create; + try + Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len); + if Err then + if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then + begin + ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ','); + Proxy := ''; + DefProxy := ''; + for n := 0 to ProxyList.Count -1 do + begin + if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then + begin + Proxy := SeparateRight(ProxyList[n], '='); + break; + end; + if Pos('=', ProxyList[n]) < 1 then + DefProxy := ProxyList[n]; + end; + if Proxy = '' then + Proxy := DefProxy; + if Proxy <> '' then + begin + Result.Host := SeparateLeft(Proxy, ':'); + Result.Port := SeparateRight(Proxy, ':'); + end; + Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ','); + end; + finally + ProxyList.Free; + FreeMem(ProxyInfo); + end; +end; +{$ENDIF} + +{==============================================================================} + +end. diff --git a/synassl.pas b/synassl.pas index a7cc178..d0c7927 100644 --- a/synassl.pas +++ b/synassl.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.006.000 | +| Project : Delphree - Synapse | 001.007.000 | |==============================================================================| | Content: SSL support | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2002. | +| Portions created by Lukas Gebauer are Copyright (c)2002-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -63,8 +63,8 @@ const DLLSSLName = 'libssl.so'; DLLUtilName = 'libcrypto.so'; {$ELSE} - DLLSSLName = 'libssl32.dll'; - DLLSSLName2 = 'ssleay32.dll'; + DLLSSLName = 'ssleay32.dll'; + DLLSSLName2 = 'libssl32.dll'; DLLUtilName = 'libeay32.dll'; {$ENDIF} @@ -94,6 +94,7 @@ const var SSLLibHandle: Integer = 0; SSLUtilHandle: Integer = 0; + SSLLibName: string = ''; // libssl.dll SslGetError : function(s: PSSL; ret_code: Integer):Integer cdecl = nil; @@ -155,11 +156,16 @@ begin begin {$IFDEF LINUX} SSLLibHandle := HMODULE(dlopen(DLLSSLName, RTLD_GLOBAL)); + SSLLibName := DLLSSLName; SSLUtilHandle := HMODULE(dlopen(DLLUtilName, RTLD_GLOBAL)); {$ELSE} SSLLibHandle := LoadLibrary(PChar(DLLSSLName)); + SSLLibName := DLLSSLName; if (SSLLibHandle = 0) then + begin SSLLibHandle := LoadLibrary(PChar(DLLSSLName2)); + SSLLibName := DLLSSLName2; + end; SSLUtilHandle := LoadLibrary(PChar(DLLUtilName)); {$ENDIF} if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then diff --git a/synautil.pas b/synautil.pas index bfde498..019e185 100644 --- a/synautil.pas +++ b/synautil.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 003.002.001 | +| Project : Delphree - Synapse | 003.003.000 | |==============================================================================| | Content: support procedures and functions | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2002. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. | | Portions created by Hernan Sanchez are Copyright (c) 2000. | | All Rights Reserved. | |==============================================================================| @@ -90,7 +90,7 @@ function IntToBin(Value: Integer; Digits: Byte): string; function BinToInt(const Value: string): Integer; function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path, Para: string): string; -function StringReplace(Value, Search, Replace: string): string; +function ReplaceString(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; @@ -98,6 +98,7 @@ 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; +function IncPoint(const p: pointer; Value: integer): pointer; implementation @@ -308,7 +309,7 @@ begin x := rpos(':', Value); if (x > 0) and ((Length(Value) - x) > 2) then Value := Copy(Value, 1, x + 2); - Value := StringReplace(Value, ':', TimeSeparator); + Value := ReplaceString(Value, ':', TimeSeparator); Result := 0; try Result := StrToTime(Value); @@ -370,9 +371,9 @@ begin month := 0; year := 0; zone := 0; - Value := StringReplace(Value, ' -', ' #'); - Value := StringReplace(Value, '-', ' '); - Value := StringReplace(Value, ' #', ' -'); + Value := ReplaceString(Value, ' -', ' #'); + Value := ReplaceString(Value, '-', ' '); + Value := ReplaceString(Value, ' #', ' -'); while Value <> '' do begin s := Fetch(Value, ' '); @@ -419,6 +420,8 @@ begin if y > 0 then month := y; end; + if year = 0 then + year := 1980; if (month < 1) or (month > 12) then month := 1; if (day < 1) or (day > 31) then @@ -826,7 +829,7 @@ end; function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path, Para: string): string; var - x: Integer; + x, y: Integer; sURL: string; s: string; s1, s2: string; @@ -850,7 +853,8 @@ begin if UpperCase(Prot) = 'FTP' then Port := '21'; x := Pos('@', sURL); - if (x > 0) and (x < Pos('/', sURL)) then + y := Pos('/', sURL); + if (x > 0) and ((x < y) or (y < 1))then begin s := SeparateLeft(sURL, '@'); sURL := SeparateRight(sURL, '@'); @@ -897,7 +901,7 @@ end; {==============================================================================} -function StringReplace(Value, Search, Replace: string): string; +function ReplaceString(Value, Search, Replace: string): string; var x, l, ls, lr: Integer; begin @@ -1061,4 +1065,11 @@ end; {==============================================================================} +function IncPoint(const p: pointer; Value: integer): pointer; +begin + Result := pointer(integer(p) + Value); +end; + +{==============================================================================} + end. diff --git a/synsock.pas b/synsock.pas index ee4d05f..c63889c 100644 --- a/synsock.pas +++ b/synsock.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.001.000 | +| Project : Delphree - Synapse | 002.002.000 | |==============================================================================| | Content: Socket Independent Platform Layer | |==============================================================================| -| Copyright (c)1999-2002, Lukas Gebauer | +| Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2001. | +| Portions created by Lukas Gebauer are Copyright (c)2001-2003. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -53,6 +53,7 @@ unit synsock; interface uses + SyncObjs, {$IFDEF LINUX} Libc, KernelIoctl; {$ELSE} @@ -273,14 +274,14 @@ function LSSelect(nfds: Integer; readfds, writefds, exceptfds: PFDSet; timeout: PTimeVal): Longint; stdcall; {$ENDIF} +var + SynSockCS: TCriticalSection; + implementation {$IFNDEF LINUX} {$IFNDEF STATICWINSOCK} -uses syncobjs; - var - SynSockCS: TCriticalSection; SynSockCount: Integer = 0; {$ENDIF} {$ENDIF} @@ -622,8 +623,6 @@ begin Result := True; end; -{$IFNDEF LINUX} -{$IFNDEF STATICWINSOCK} initialization begin SynSockCS:= TCriticalSection.Create; @@ -633,7 +632,5 @@ finalization begin SynSockCS.Free; end; -{$ENDIF} -{$ENDIF} end. diff --git a/tlntsend.pas b/tlntsend.pas new file mode 100644 index 0000000..97ad8d3 --- /dev/null +++ b/tlntsend.pas @@ -0,0 +1,306 @@ +{==============================================================================| +| Project : Delphree - Synapse | 001.000.002 | +|==============================================================================| +| Content: TELNET client | +|==============================================================================| +| Copyright (c)1999-2003, Lukas Gebauer | +| All rights reserved. | +| | +| 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-2003. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{$WEAKPACKAGEUNIT ON} + +//RFC-854 + +unit TlntSend; + +interface + +uses + SysUtils, Classes, + blcksock, SynaUtil; + +const + cTelnetProtocol = 'telnet'; + + TLNT_EOR = #239; + TLNT_SE = #240; + TLNT_NOP = #241; + TLNT_DATA_MARK = #242; + TLNT_BREAK = #243; + TLNT_IP = #244; + TLNT_AO = #245; + TLNT_AYT = #246; + TLNT_EC = #247; + TLNT_EL = #248; + TLNT_GA = #249; + TLNT_SB = #250; + TLNT_WILL = #251; + TLNT_WONT = #252; + TLNT_DO = #253; + TLNT_DONT = #254; + TLNT_IAC = #255; + +type + TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT, + tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC); + + TTelnetSend = class(TSynaClient) + private + FSock: TTCPBlockSocket; + FBuffer: string; + FState: TTelnetState; + FSessionLog: string; + FSubNeg: string; + FSubType: char; + function Connect: Boolean; + function Negotiate(const Buf: string): string; + procedure FilterHook(Sender: TObject; var Value: string); + public + constructor Create; + destructor Destroy; override; + function Login: Boolean; + procedure Logout; + procedure Send(const Value: string); + function WaitFor(const Value: string): Boolean; + function RecvTerminated(const Terminator: string): string; + function RecvString: string; + published + property Sock: TTCPBlockSocket read FSock; + property SessionLog: string read FSessionLog write FSessionLog; + end; + +implementation + +constructor TTelnetSend.Create; +begin + inherited Create; + FSock := TTCPBlockSocket.Create; + FSock.OnReadFilter := FilterHook; + FTimeout := 300000; + FTargetPort := cTelnetProtocol; + FSubNeg := ''; + FSubType := #0; +end; + +destructor TTelnetSend.Destroy; +begin + FSock.Free; + inherited Destroy; +end; + +function TTelnetSend.Connect: Boolean; +begin + // Do not call this function! It is calling by LOGIN method! + FBuffer := ''; + FSessionLog := ''; + FState := tsDATA; + FSock.CloseSocket; + FSock.LineBuffer := ''; + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + Result := FSock.LastError = 0; +end; + +function TTelnetSend.RecvTerminated(const Terminator: string): string; +begin + Result := FSock.RecvTerminated(FTimeout, Terminator); +end; + +function TTelnetSend.RecvString: string; +begin + Result := FSock.RecvTerminated(FTimeout, CRLF); +end; + +function TTelnetSend.WaitFor(const Value: string): Boolean; +begin + Result := FSock.RecvTerminated(FTimeout, Value) <> ''; +end; + +procedure TTelnetSend.FilterHook(Sender: TObject; var Value: string); +begin + Value := Negotiate(Value); + FSessionLog := FSessionLog + Value; +end; + +function TTelnetSend.Negotiate(const Buf: string): string; +var + n: integer; + c: char; + Reply: string; + SubReply: string; +begin + Result := ''; + for n := 1 to Length(Buf) do + begin + c := Buf[n]; + Reply := ''; + case FState of + tsData: + if c = TLNT_IAC then + FState := tsIAC + else + Result := Result + c; + + tsIAC: + case c of + TLNT_IAC: + begin + FState := tsData; + Result := Result + TLNT_IAC; + end; + TLNT_WILL: + FState := tsIAC_WILL; + TLNT_WONT: + FState := tsIAC_WONT; + TLNT_DONT: + FState := tsIAC_DONT; + TLNT_DO: + FState := tsIAC_DO; + TLNT_EOR: + FState := tsDATA; + TLNT_SB: + begin + FState := tsIAC_SB; + FSubType := #0; + FSubNeg := ''; + end; + else + FState := tsData; + end; + + tsIAC_WILL: + begin + case c of + #3: //suppress GA + Reply := TLNT_DO; + else + Reply := TLNT_DONT; + end; + FState := tsData; + end; + + tsIAC_WONT: + begin + Reply := TLNT_DONT; + FState := tsData; + end; + + tsIAC_DO: + begin + case c of + #24: //termtype + Reply := TLNT_WILL; + else + Reply := TLNT_WONT; + end; + FState := tsData; + end; + + tsIAC_DONT: + begin + Reply := TLNT_WONT; + FState := tsData; + end; + + tsIAC_SB: + begin + FSubType := c; + FState := tsIAC_SBDATA; + end; + + tsIAC_SBDATA: + begin + if c = TLNT_IAC then + FState := tsSBDATA_IAC + else + FSubNeg := FSubNeg + c; + end; + + tsSBDATA_IAC: + case c of + TLNT_IAC: + begin + FState := tsIAC_SBDATA; + FSubNeg := FSubNeg + c; + end; + TLNT_SE: + begin + SubReply := ''; + case FSubType of + #24: //termtype + begin + if (FSubNeg <> '') and (FSubNeg[1] = #1) then + SubReply := #0 + 'SYNAPSE'; + end; + end; + Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE); + FState := tsDATA; + end; + else + FState := tsDATA; + end; + + else + FState := tsData; + end; + if Reply <> '' then + Sock.SendString(TLNT_IAC + Reply + c); + end; + +end; + +procedure TTelnetSend.Send(const Value: string); +begin + Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC)); +end; + +function TTelnetSend.Login: Boolean; +begin + Result := False; + if not Connect then + Exit; + Result := True; +end; + +procedure TTelnetSend.Logout; +begin + FSock.CloseSocket; +end; + + +end.