diff --git a/IMAPsend.pas b/IMAPsend.pas new file mode 100644 index 0000000..adb881b --- /dev/null +++ b/IMAPsend.pas @@ -0,0 +1,575 @@ +{==============================================================================| +| Project : Delphree - Synapse | 001.001.001 | +|==============================================================================| +| Content: IMAP4rev1 client | +|==============================================================================| +| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 | +| (the "License"); you may not use this file except in compliance with the | +| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ | +| | +| Software distributed under the License is distributed on an "AS IS" basis, | +| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | +| the specific language governing rights and limitations under the License. | +|==============================================================================| +| The Original Code is Synapse Delphi Library. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2001. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{$WEAKPACKAGEUNIT ON} + +//RFC-2060 + +unit IMAPsend; + +interface + +uses + SysUtils, Classes, + blcksock, SynaUtil, SynaCode; + +const + cIMAPProtocol = '143'; + +type + TIMAPSend = class(TObject) + private + FSock: TTCPBlockSocket; + FTimeout: Integer; + FIMAPHost: string; + FIMAPPort: string; + FTagCommand: integer; + FResultString: string; + FFullResult: TStringList; + FIMAPcap: TStringList; + FUsername: string; + FPassword: string; + FAuthDone: Boolean; + FSelectedFolder: string; + FSelectedCount: integer; + FSelectedRecent: integer; + FSelectedUIDvalidity: integer; + FUID: Boolean; + + function ReadResult: string; + function AuthLogin: Boolean; + function Connect: Boolean; + procedure ParseMess(Value:TStrings); + procedure ParseFolderList(Value:TStrings); + procedure ParseSelect; + procedure ParseSearch(Value:TStrings); + public + constructor Create; + destructor Destroy; override; + function IMAPcommand(Value: string): string; + function IMAPuploadCommand(Value: string; const Data:TStrings): string; + function Login: Boolean; + procedure Logout; + function NoOp: Boolean; + function List(FromFolder: string; const FolderList: TStrings): Boolean; + function ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean; + function CreateFolder(FolderName: string): Boolean; + function DeleteFolder(FolderName: string): Boolean; + function RenameFolder(FolderName, NewFolderName: string): Boolean; + function SubscribeFolder(FolderName: string): Boolean; + function UnsubscribeFolder(FolderName: string): Boolean; + function SelectFolder(FolderName: string): Boolean; + function SelectROFolder(FolderName: string): Boolean; + function CloseFolder: Boolean; + function StatusFolder(FolderName, Value: string): integer; + function ExpungeFolder: Boolean; + function CheckFolder: Boolean; + function AppendMess(ToFolder: string; const Mess: TStrings): Boolean; + function DeleteMess(MessID: integer): boolean; + function FetchMess(MessID: integer; const Mess: TStrings): Boolean; + function FetchHeader(MessID: integer; const Headers: TStrings): Boolean; + function MessageSize(MessID: integer): integer; + function CopyMess(MessID: integer; ToFolder: string): Boolean; + function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean; + function SetFlagsMess(MessID: integer; Flags: string): Boolean; + function GetFlagsMess(MessID: integer; var Flags: string): Boolean; + + function FindCap(const Value: string): string; + published + property Timeout: Integer read FTimeout Write FTimeout; + property IMAPHost: string read FIMAPHost Write FIMAPHost; + property IMAPPort: string read FIMAPPort Write FIMAPPort; + property ResultString: string read FResultString; + property FullResult: TStringList read FFullResult; + property IMAPcap: TStringList read FIMAPcap; + property Username: string read FUsername Write FUsername; + property Password: string read FPassword Write FPassword; + property AuthDone: Boolean read FAuthDone; + property UID: Boolean read FUID Write FUID; + property Sock: TTCPBlockSocket read FSock; + property SelectedFolder: string read FSelectedFolder; + property SelectedCount: integer read FSelectedCount; + property SelectedRecent: integer read FSelectedRecent; + property SelectedUIDvalidity: integer read FSelectedUIDvalidity; + end; + +implementation + +const + CRLF = #13#10; + +constructor TIMAPSend.Create; +begin + inherited Create; + FFullResult := TStringList.Create; + FIMAPcap := TStringList.Create; + FSock := TTCPBlockSocket.Create; + FSock.CreateSocket; + FSock.SizeRecvBuffer := 32768; + FSock.SizeSendBuffer := 32768; + FTimeout := 300000; + FIMAPhost := cLocalhost; + FIMAPPort := cIMAPProtocol; + FUsername := ''; + FPassword := ''; + FTagCommand := 0; + FSelectedFolder := ''; + FSelectedCount := 0; + FSelectedRecent := 0; + FSelectedUIDvalidity := 0; + FUID := False; +end; + +destructor TIMAPSend.Destroy; +begin + FSock.Free; + FIMAPcap.Free; + FFullResult.Free; + inherited Destroy; +end; + + +function TIMAPSend.ReadResult: string; +var + s: string; + x, l: integer; +begin + Result := ''; + FFullResult.Clear; + FResultString := ''; + repeat + s := FSock.RecvString(FTimeout); + if Pos('S' + IntToStr(FTagCommand) + ' ', s) = 1 then + begin + FResultString := s; + break; + end + else + FFullResult.Add(s); + if (s <> '') and (s[Length(s)]='}') then + begin + s := Copy(s, 1, Length(s) - 1); + x := RPos('{', s); + s := Copy(s, x + 1, Length(s) - x); + l := StrToIntDef(s, -1); + if l <> -1 then + begin + setlength(s, l); + x := FSock.recvbufferex(PChar(s), l, FTimeout); + SetLength(s, x); + FFullResult.Add(s); + end; + end; + until FSock.LastError <> 0; + s := separateright(FResultString, ' '); + Result:=uppercase(separateleft(s, ' ')); +end; + +function TIMAPSend.IMAPcommand(Value: string): string; +begin + Inc(FTagCommand); + FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + CRLF); + Result := ReadResult; +end; + +function TIMAPSend.IMAPuploadCommand(Value: string; const Data:TStrings): string; +var + l: integer; +begin + Inc(FTagCommand); + l := Length(Data.Text); + FSock.SendString(IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF); + FSock.SendString(Data.Text + CRLF); + Result := ReadResult; +end; + +procedure TIMAPSend.ParseMess(Value:TStrings); +var + n: integer; +begin + Value.Clear; + for n := 0 to FFullResult.Count - 2 do + if FFullResult[n][Length(FFullResult[n])] = '}' then + begin + Value.Text := FFullResult[n + 1]; + Break; + end; +end; + +procedure TIMAPSend.ParseFolderList(Value:TStrings); +var + n, x: integer; + s: string; +begin + Value.Clear; + 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)); + end; +end; + +procedure TIMAPSend.ParseSelect; +var + n: integer; + s, t: string; +begin + FSelectedCount := 0; + FSelectedRecent := 0; + FSelectedUIDvalidity := 0; + for n := 0 to FFullResult.Count - 1 do + begin + s := uppercase(FFullResult[n]); + if Pos(' EXISTS', s) > 0 then + begin + t := separateleft(s, ' EXISTS'); + t := separateright(t, '* '); + FSelectedCount := StrToIntDef(t, 0); + end; + if Pos(' RECENT', s) > 0 then + begin + t := separateleft(s, ' RECENT'); + t := separateright(t, '* '); + FSelectedRecent := StrToIntDef(t, 0); + end; + if Pos('UIDVALIDITY', s) > 0 then + begin + t := separateright(s, 'UIDVALIDITY '); + t := separateleft(t, ']'); + FSelectedUIDvalidity := StrToIntDef(t, 0); + end; + end; +end; + +procedure TIMAPSend.ParseSearch(Value:TStrings); +var + n: integer; + s: string; +begin + Value.Clear; + for n := 0 to FFullResult.Count - 1 do + begin + s := uppercase(FFullResult[n]); + if Pos('* SEARCH', s) = 1 then + begin + s := SeparateRight(s, '* SEARCH'); + while s <> '' do + Value.Add(Fetch(s, ' ')); + end; + end; +end; + +function TIMAPSend.FindCap(const Value: string): string; +var + n: Integer; + s: string; +begin + s := UpperCase(Value); + Result := ''; + for n := 0 to FIMAPcap.Count - 1 do + if Pos(s, UpperCase(FIMAPcap[n])) = 1 then + begin + Result := FIMAPcap[n]; + Break; + end; +end; + +function TIMAPSend.AuthLogin: Boolean; +begin + Result := IMAPcommand('LOGIN ' + FUsername + ' ' + FPassword) = 'OK'; +end; + +function TIMAPSend.Connect: Boolean; +begin + FSock.CloseSocket; + FSock.CreateSocket; + FSock.Connect(FIMAPHost, FIMAPPort); + Result := FSock.LastError = 0; +end; + +function TIMAPSend.Login: Boolean; +var + n: Integer; + s, t: string; +begin + FSelectedFolder := ''; + FSelectedCount := 0; + FSelectedRecent := 0; + FSelectedUIDvalidity := 0; + Result := False; + FAuthDone := False; + if not Connect then + Exit; + s := FSock.RecvString(FTimeout); + if Pos('* PREAUTH', s) = 1 then + FAuthDone := True + else + if Pos('* OK', s) = 1 then + FAuthDone := False + else + Exit; + FIMAPcap.Clear; + s := IMAPcommand('CAPABILITY'); + if s = 'OK' then + begin + for n := 0 to FFullResult.Count - 1 do + if Pos('* CAPABILITY ', FFullResult[n]) = 1 then + begin + s := SeparateRight(FFullResult[n], '* CAPABILITY '); + while not (s = '') do + begin + t := separateleft(s, ' '); + s := separateright(s, ' '); + if s = t then + s := ''; + FIMAPcap.Add(t); + end; + end; + if Findcap('IMAP4rev1') = '' then + Exit; + end; + Result := AuthLogin; +end; + +procedure TIMAPSend.Logout; +begin + IMAPcommand('LOGOUT'); + FSelectedFolder := ''; + FSock.CloseSocket; +end; + +function TIMAPSend.NoOp: Boolean; +begin + Result := IMAPcommand('NOOP') = 'OK'; +end; + +function TIMAPSend.List(FromFolder: string; const FolderList: TStrings): Boolean; +begin + Result := IMAPcommand('LIST "' + FromFolder + '" *') = 'OK'; + ParseFolderList(FolderList); +end; + +function TIMAPSend.ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean; +begin + Result := IMAPcommand('LSUB "' + FromFolder + '" *') = 'OK'; + ParseFolderList(FolderList); +end; + +function TIMAPSend.CreateFolder(FolderName: string): Boolean; +begin + Result := IMAPcommand('CREATE "' + FolderName + '"') = 'OK'; +end; + +function TIMAPSend.DeleteFolder(FolderName: string): Boolean; +begin + Result := IMAPcommand('DELETE "' + FolderName + '"') = 'OK'; +end; + +function TIMAPSend.RenameFolder(FolderName, NewFolderName: string): Boolean; +begin + Result := IMAPcommand('RENAME "' + FolderName + '" "' + NewFolderName + '"') = 'OK'; +end; + +function TIMAPSend.SubscribeFolder(FolderName: string): Boolean; +begin + Result := IMAPcommand('SUBSCRIBE "' + FolderName + '"') = 'OK'; +end; + +function TIMAPSend.UnsubscribeFolder(FolderName: string): Boolean; +begin + Result := IMAPcommand('UNSUBSCRIBE "' + FolderName + '"') = 'OK'; +end; + +function TIMAPSend.SelectFolder(FolderName: string): Boolean; +begin + Result := IMAPcommand('SELECT "' + FolderName + '"') = 'OK'; + FSelectedFolder := FolderName; + ParseSelect; +end; + +function TIMAPSend.SelectROFolder(FolderName: string): Boolean; +begin + Result := IMAPcommand('EXAMINE "' + FolderName + '"') = 'OK'; + FSelectedFolder := FolderName; + ParseSelect; +end; + +function TIMAPSend.CloseFolder: Boolean; +begin + Result := IMAPcommand('CLOSE') = 'OK'; + FSelectedFolder := ''; +end; + +function TIMAPSend.StatusFolder(FolderName, Value: string): integer; +var + n: integer; + s, t: string; +begin + Result := -1; + Value := Uppercase(Value); + if IMAPcommand('STATUS "' + FolderName + '" (' + Value + ')' ) = 'OK' then + for n := 0 to FFullResult.Count - 1 do + begin + s := UpperCase(FFullResult[n]); + if (Pos('* STATUS ', s) = 1) and (Pos(Value, s) > 0 ) then + begin + t := SeparateRight(s, Value); + t := SeparateLeft(t, ')'); + t := trim(t); + Result := StrToIntDef(t, -1); + Break; + end; + end; +end; + +function TIMAPSend.ExpungeFolder: Boolean; +begin + Result := IMAPcommand('EXPUNGE') = 'OK'; +end; + +function TIMAPSend.CheckFolder: Boolean; +begin + Result := IMAPcommand('CHECK') = 'OK'; +end; + +function TIMAPSend.AppendMess(ToFolder: string; const Mess: TStrings): Boolean; +begin + Result := IMAPuploadCommand('APPEND "' + ToFolder + '"', Mess) = 'OK'; +end; + +function TIMAPSend.DeleteMess(MessID: integer): boolean; +var + s: string; +begin + s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (\Deleted)'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; +end; + +function TIMAPSend.FetchMess(MessID: integer; const Mess: TStrings): Boolean; +var + s: string; +begin + s := 'FETCH ' + IntToStr(MessID) + ' (RFC822)'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; + ParseMess(Mess); +end; + +function TIMAPSend.FetchHeader(MessID: integer; const Headers: TStrings): Boolean; +var + s: string; +begin + s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.HEADER)'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; + ParseMess(Headers); +end; + +function TIMAPSend.MessageSize(MessID: integer): integer; +var + n: integer; + s, t: string; +begin + Result := -1; + s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.SIZE)'; + if FUID then + s := 'UID ' + s; + if IMAPcommand(s) = 'OK' then + for n := 0 to FFullResult.Count - 1 do + begin + s := UpperCase(FFullResult[n]); + if (Pos('* ', s) = 1) and (Pos('RFC822.SIZE', s) > 0 ) then + begin + t := SeparateRight(s, 'RFC822.SIZE '); + t := SeparateLeft(t, ')'); + t := trim(t); + Result := StrToIntDef(t, -1); + Break; + end; + end; +end; + +function TIMAPSend.CopyMess(MessID: integer; ToFolder: string): Boolean; +var + s: string; +begin + s := 'COPY ' + IntToStr(MessID) + ' "' + ToFolder + '"'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; +end; + +function TIMAPSend.SearchMess(Criteria: string; const FoundMess: TStrings): Boolean; +var + s: string; +begin + s := 'SEARCH ' + Criteria; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; + ParseSearch(FoundMess); +end; + +function TIMAPSend.SetFlagsMess(MessID: integer; Flags: string): Boolean; +var + s: string; +begin + s := 'STORE ' + IntToStr(MessID) + ' FLAGS.SILENT (' + Flags + ')'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; +end; + +function TIMAPSend.GetFlagsMess(MessID: integer; var Flags: string): Boolean; +var + s: string; + n: integer; +begin + Flags := ''; + s := 'FETCH ' + IntToStr(MessID) + ' (FLAGS)'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; + for n := 0 to FFullResult.Count - 1 do + begin + s := uppercase(FFullResult[n]); + if Pos('* FETCH (FLAGS', s) = 1 then + begin + s := SeparateRight(s, 'FLAGS'); + s := Separateright(s, '('); + Flags := SeparateLeft(s, ')'); + end; + end; +end; + +{==============================================================================} + +end. diff --git a/NNTPsend.pas b/NNTPsend.pas new file mode 100644 index 0000000..9d73422 --- /dev/null +++ b/NNTPsend.pas @@ -0,0 +1,310 @@ +{==============================================================================| +| Project : Delphree - Synapse | 001.000.000 | +|==============================================================================| +| Content: NNTP client | +|==============================================================================| +| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 | +| (the "License"); you may not use this file except in compliance with the | +| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ | +| | +| Software distributed under the License is distributed on an "AS IS" basis, | +| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | +| the specific language governing rights and limitations under the License. | +|==============================================================================| +| The Original Code is Synapse Delphi Library. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{$WEAKPACKAGEUNIT ON} + +unit NNTPsend; + +interface + +uses + SysUtils, Classes, + blcksock, SynaUtil, SynaCode; + +const + cNNTPProtocol = 'nntp'; + +type + TNNTPSend = class(TObject) + private + FSock: TTCPBlockSocket; + FTimeout: Integer; + FNNTPHost: string; + FNNTPPort: string; + FResultCode: Integer; + FResultString: string; + FData: TStringList; + function ReadResult: Integer; + function ReadData: boolean; + function SendData: boolean; + function Connect: Boolean; + public + constructor Create; + destructor Destroy; override; + function Login: Boolean; + procedure Logout; + function GetArticle(const Value: string): Boolean; + function GetBody(const Value: string): Boolean; + function GetHead(const Value: string): Boolean; + function GetStat(const Value: string): Boolean; + function SelectGroup(const Value: string): Boolean; + function IHave(const MessID: string): Boolean; + function GotoLast: Boolean; + function GotoNext: Boolean; + function ListGroups: Boolean; + function ListNewGroups(Since: TDateTime): Boolean; + function NewArticles(const Group: string; Since: TDateTime): Boolean; + function PostArticle: Boolean; + function SwitchToSlave: Boolean; + published + property Timeout: Integer read FTimeout Write FTimeout; + property NNTPHost: string read FNNTPHost Write FNNTPHost; + property NNTPPort: string read FNNTPPort Write FNNTPPort; + property ResultCode: Integer read FResultCode; + property ResultString: string read FResultString; + property Data: TStringList read FData; + property Sock: TTCPBlockSocket read FSock; + end; + +implementation + +const + CRLF = #13#10; + +constructor TNNTPSend.Create; +begin + inherited Create; + FData := TStringList.Create; + FSock := TTCPBlockSocket.Create; + FSock.CreateSocket; + FTimeout := 300000; + FNNTPhost := cLocalhost; + FNNTPPort := cNNTPProtocol; +end; + +destructor TNNTPSend.Destroy; +begin + FSock.Free; + FData.Free; + inherited Destroy; +end; + +function TNNTPSend.ReadResult: Integer; +var + s: string; +begin + Result := 0; + FData.Clear; + s := FSock.RecvString(FTimeout); + FResultString := Copy(s, 5, Length(s) - 4); + if FSock.LastError <> 0 then + Exit; + if Length(s) >= 3 then + Result := StrToIntDef(Copy(s, 1, 3), 0); + FResultCode := Result; +end; + +function TNNTPSend.ReadData: boolean; +var + s: string; +begin + Result := False; + repeat + s := FSock.RecvString(FTimeout); + if s = '.' then + break; + if (s <> '') and (s[1] = '.') then + s := Copy(s, 2, Length(s) - 1); + FData.Add(s); + until FSock.LastError <> 0; + Result := FSock.LastError = 0; +end; + +function TNNTPSend.SendData: boolean; +var + s: string; + n: integer; +begin + Result := False; + for n := 0 to FData.Count -1 do + begin + s := FData[n]; + if (s <> '') and (s[1]='.') then + s := s + '.'; + FSock.SendString(s + CRLF); + if FSock.LastError <> 0 then + break; + end; + Result := FSock.LastError = 0; +end; + +function TNNTPSend.Connect: Boolean; +begin + FSock.CloseSocket; + FSock.CreateSocket; + FSock.Connect(FNNTPHost, FNNTPPort); + Result := FSock.LastError = 0; +end; + +function TNNTPSend.Login: Boolean; +begin + Result := False; + if not Connect then + Exit; + Result := (ReadResult div 100) = 2; +end; + +procedure TNNTPSend.Logout; +begin + FSock.SendString('QUIT' + CRLF); + ReadResult; + FSock.CloseSocket; +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; +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; +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; +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; +end; + +function TNNTPSend.SelectGroup(const Value: string): Boolean; +begin + FSock.SendString('GROUP ' + Value + CRLF); + Result := (ReadResult div 100) = 2; +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; +end; + +function TNNTPSend.GotoLast: Boolean; +begin + FSock.SendString('LAST' + CRLF); + Result := (ReadResult div 100) = 2; +end; + +function TNNTPSend.GotoNext: Boolean; +begin + FSock.SendString('NEXT' + CRLF); + Result := (ReadResult div 100) = 2; +end; + +function TNNTPSend.ListGroups: Boolean; +begin + FSock.SendString('LIST' + CRLF); + Result := (ReadResult div 100) = 2; + if Result then + Result := ReadData; +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; +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; +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; +end; + +function TNNTPSend.SwitchToSlave: Boolean; +begin + FSock.SendString('SLAVE' + CRLF); + Result := (ReadResult div 100) = 2; +end; + +{==============================================================================} + +end. diff --git a/asn1util.pas b/asn1util.pas index 277d453..b94e3b3 100644 --- a/asn1util.pas +++ b/asn1util.pas @@ -1,7 +1,7 @@ {==============================================================================| | Project : Delphree - Synapse | 001.003.004 | |==============================================================================| -| Content: support for ASN.1 coding and decoding | +| Content: support for ASN.1 BER coding and decoding | |==============================================================================| | The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | (the "License"); you may not use this file except in compliance with the | diff --git a/blcksock.pas b/blcksock.pas index e658132..b2ccf33 100644 --- a/blcksock.pas +++ b/blcksock.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 004.000.000 | +| Project : Delphree - Synapse | 004.004.000 | |==============================================================================| | Content: Library base | |==============================================================================| @@ -23,6 +23,7 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{$Q-} {$WEAKPACKAGEUNIT ON} unit blcksock; @@ -76,10 +77,15 @@ type FLastError: Integer; FBuffer: string; FRaiseExcept: Boolean; + FNonBlockMode: Boolean; + FMaxLineLength: Integer; + FMaxBandwidth: Integer; + FNextSend: Cardinal; function GetSizeRecvBuffer: Integer; procedure SetSizeRecvBuffer(Size: Integer); function GetSizeSendBuffer: Integer; procedure SetSizeSendBuffer(Size: Integer); + procedure SetNonBlockMode(Value: Boolean); protected FSocket: TSocket; FProtocol: Integer; @@ -88,6 +94,7 @@ type function GetSinIP(Sin: TSockAddrIn): string; function GetSinPort(Sin: TSockAddrIn): Integer; procedure DoStatus(Reason: THookSocketReason; const Value: string); + procedure LimitBandwidth(Length: Integer); public constructor Create; constructor CreateAlternate(Stub: string); @@ -103,6 +110,7 @@ type Timeout: Integer): Integer; virtual; function RecvByte(Timeout: Integer): Byte; virtual; function RecvString(Timeout: Integer): string; virtual; + function RecvTerminated(Timeout: Integer; const Terminator: string): string; virtual; function RecvPacket(Timeout: Integer): string; virtual; function PeekBuffer(Buffer: Pointer; Length: Integer): Integer; virtual; function PeekByte(Timeout: Integer): Byte; virtual; @@ -126,6 +134,7 @@ type function RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer; virtual; function GroupCanRead(const SocketList: TList; Timeout: Integer; const CanReadList: TList): Boolean; + function EnableReuse(Value: Boolean): Boolean; //See 'winsock2.txt' file in distribute package! function SetTimeout(Timeout: Integer): Boolean; @@ -145,6 +154,9 @@ type 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 MaxBandwidth: Integer read FMaxBandwidth Write FMaxBandwidth; end; TSocksBlockSocket = class(TBlockSocket) @@ -206,6 +218,8 @@ type function RecvBuffer(Buffer: Pointer; Length: Integer): Integer; override; function SendBufferTo(Buffer: Pointer; Length: Integer): Integer; override; function RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer; override; + procedure AddMulticast(MCastIP:string); + procedure DropMulticast(MCastIP:string); end; //See 'winsock2.txt' file in distribute package! @@ -236,6 +250,12 @@ type implementation +type + TMulticast = record + MCastAddr : u_long; + MCastIfc : u_long; + end; + constructor TBlockSocket.Create; var e: ESynapseError; @@ -245,6 +265,10 @@ begin FSocket := INVALID_SOCKET; FProtocol := IPPROTO_IP; FBuffer := ''; + FNonBlockMode := False; + FMaxLineLength := 0; + FMaxBandwidth := 0; + FNextSend := 0; if not InitSocketInterface('') then begin e := ESynapseError.Create('Error loading Winsock DLL!'); @@ -345,6 +369,7 @@ end; procedure TBlockSocket.CloseSocket; begin + synsock.Shutdown(FSocket, 2); synsock.CloseSocket(FSocket); DoStatus(HR_SocketClose, ''); end; @@ -385,8 +410,22 @@ begin synsock.GetPeerName(FSocket, FremoteSin, Len); end; +procedure TBlockSocket.LimitBandwidth(Length: Integer); +var + x: Cardinal; +begin + if FMaxBandwidth > 0 then + begin + x := FNextSend - GetTick; + if x > 0 then + Sleep(x); + FNextSend := GetTick + Trunc((FMaxBandwidth / 1000) * Length); + end; +end; + function TBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer; begin + LimitBandwidth(Length); Result := synsock.Send(FSocket, Buffer^, Length, 0); SockCheck(Result); ExceptCheck; @@ -454,14 +493,9 @@ begin if (system.Length(ss) + l) > fs then l := fs - system.Length(ss); SetLength(st, l); - x := synsock.Recv(FSocket, Pointer(st)^, l, 0); - if x = 0 then - FLastError := WSAECONNRESET - else - SockCheck(x); + x := RecvBuffer(Pointer(st), l); if FLastError <> 0 then Break; - DoStatus(HR_ReadCount, IntToStr(x)); lss := system.Length(ss); SetLength(ss, lss + x); Move(Pointer(st)^, Pointer(@ss[lss + 1])^, x); @@ -515,47 +549,44 @@ end; function TBlockSocket.RecvByte(Timeout: Integer): Byte; var - y: Integer; - Data: Byte; + s: String; begin - Data := 0; Result := 0; if CanRead(Timeout) then begin - y := synsock.Recv(FSocket, Data, 1, 0); - if y = 0 then - FLastError := WSAECONNRESET - else - SockCheck(y); - Result := Data; - DoStatus(HR_ReadCount, '1'); + SetLength(s, 1); + RecvBuffer(Pointer(s), 1); + if s <> '' then + Result := Ord(s[1]); end else FLastError := WSAETIMEDOUT; ExceptCheck; end; -function TBlockSocket.RecvString(Timeout: Integer): string; +function TBlockSocket.RecvTerminated(Timeout: Integer; const Terminator: string): string; const - MaxBuf = 1024; + MaxSize = 1024; var x: Integer; s: string; c: Char; - r: Integer; + r,l: Integer; begin s := ''; + l := Length(Terminator); + Result := ''; + if l = 0 then + Exit; FLastError := 0; - c := #0; repeat + x := 0; if FBuffer = '' then begin x := WaitingData; - if x = 0 then - x := 1; - if x > MaxBuf then - x := MaxBuf; - if x = 1 then + if x > MaxSize then + x := MaxSize; + if x <= 1 then begin c := Char(RecvByte(Timeout)); if FLastError <> 0 then @@ -565,42 +596,44 @@ begin else begin SetLength(FBuffer, x); - r := synsock.Recv(FSocket, Pointer(FBuffer)^, x, 0); - SockCheck(r); - if r = 0 then - FLastError := WSAECONNRESET; + r := RecvBuffer(Pointer(FBuffer), x); if FLastError <> 0 then Break; - DoStatus(HR_ReadCount, IntToStr(r)); if r < x then SetLength(FBuffer, r); end; end; - x := Pos(#10, FBuffer); - if x < 1 then x := Length(FBuffer); - s := s + Copy(FBuffer, 1, x - 1); - c := FBuffer[x]; - Delete(FBuffer, 1, x); - s := s + c; - until c = #10; - - if FLastError = 0 then - begin -{$IFDEF LINUX} - s := AdjustLineBreaks(s, tlbsCRLF); -{$ELSE} - s := AdjustLineBreaks(s); -{$ENDIF} - x := Pos(#13 + #10, s); + s := s + FBuffer; + FBuffer := ''; + x := Pos(Terminator, s); if x > 0 then + begin + FBuffer := Copy(s, x + l, Length(s) - x - l + 1); s := Copy(s, 1, x - 1); - Result := s; - end + end; + if (FMaxLineLength <> 0) and (Length(s) > FMaxLineLength) then + begin + FLastError := WSAENOBUFS; + Break; + end; + until x > 0; + if FLastError = 0 then + Result := s else Result := ''; ExceptCheck; end; +function TBlockSocket.RecvString(Timeout: Integer): string; +var + s: string; +begin + Result := ''; + s := RecvTerminated(Timeout, #13 + #10); + if FLastError = 0 then + Result := s; +end; + function TBlockSocket.PeekBuffer(Buffer: Pointer; Length: Integer): Integer; begin Result := synsock.Recv(FSocket, Buffer^, Length, MSG_PEEK); @@ -610,18 +643,15 @@ end; function TBlockSocket.PeekByte(Timeout: Integer): Byte; var - y: Integer; - Data: Byte; + s: string; begin - Data := 0; Result := 0; if CanRead(Timeout) then begin - y := synsock.Recv(FSocket, Data, 1, MSG_PEEK); - if y = 0 then - FLastError := WSAECONNRESET; - SockCheck(y); - Result := Data; + SetLength(s, 1); + PeekBuffer(Pointer(s), 1); + if s <> '' then + Result := Ord(s[1]); end else FLastError := WSAETIMEDOUT; @@ -642,7 +672,8 @@ var e: ESynapseError; s: string; begin - if FRaiseExcept and (LastError <> 0) then + if FRaiseExcept and (LastError <> 0) and (LastError <> WSAEINPROGRESS) + and (LastError <> WSAEWOULDBLOCK) then begin s := GetErrorDesc(LastError); e := ESynapseError.CreateFmt('TCP/IP Socket error %d: %s', [LastError, s]); @@ -833,10 +864,12 @@ function TBlockSocket.SendBufferTo(Buffer: Pointer; Length: Integer): Integer; var Len: Integer; begin + LimitBandwidth(Length); Len := SizeOf(FRemoteSin); Result := synsock.SendTo(FSocket, Buffer^, Length, 0, FRemoteSin, Len); SockCheck(Result); ExceptCheck; + DoStatus(HR_WriteCount, IntToStr(Result)); end; function TBlockSocket.RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer; @@ -847,6 +880,7 @@ begin Result := synsock.RecvFrom(FSocket, Buffer^, Length, 0, FRemoteSin, Len); SockCheck(Result); ExceptCheck; + DoStatus(HR_ReadCount, IntToStr(Result)); end; function TBlockSocket.GetSizeRecvBuffer: Integer; @@ -883,6 +917,18 @@ begin ExceptCheck; end; +procedure TBlockSocket.SetNonBlockMode(Value: Boolean); +var + x: integer; +begin + FNonBlockMode := Value; + if Value then + x := 1 + else + x := 0; + synsock.IoctlSocket(FSocket, FIONBIO, u_long(x)); +end; + //See 'winsock2.txt' file in distribute package! function TBlockSocket.SetTimeout(Timeout: Integer): Boolean; begin @@ -940,6 +986,18 @@ begin CanReadList.Add(TBlockSocket(SocketList.Items[n])); end; +function TBlockSocket.EnableReuse(Value: Boolean): Boolean; +var + Opt: Integer; + Res: Integer; +begin + opt := Ord(Value); + Res := synsock.SetSockOpt(FSocket, SOL_SOCKET, SO_REUSEADDR, @Opt, SizeOf(opt)); + SockCheck(Res); + Result := res = 0; + ExceptCheck; +end; + procedure TBlockSocket.DoStatus(Reason: THookSocketReason; const Value: string); begin if assigned(OnStatus) then @@ -1044,7 +1102,7 @@ begin WSANOTINITIALISED: {10093} Result := 'Winsock not initialized'; WSAEDISCON: {10101} - Result := 'WSAEDISCON-10101'; + Result := 'Disconnect'; WSAHOST_NOT_FOUND: {11001} Result := 'Host not found'; WSATRY_AGAIN: {11002} @@ -1325,6 +1383,28 @@ begin end; end; +procedure TUDPBlockSocket.AddMulticast(MCastIP: string); +var + Multicast: TMulticast; +begin + Multicast.MCastAddr := synsock.inet_addr(PChar(MCastIP)); + Multicast.MCastIfc := u_long(INADDR_ANY); + SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_ADD_MEMBERSHIP, + pchar(@Multicast), SizeOf(Multicast))); + ExceptCheck; +end; + +procedure TUDPBlockSocket.DropMulticast(MCastIP: string); +var + Multicast: TMulticast; +begin + Multicast.MCastAddr := synsock.inet_addr(PChar(MCastIP)); + Multicast.MCastIfc := u_long(INADDR_ANY); + SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_DROP_MEMBERSHIP, + pchar(@Multicast), SizeOf(Multicast))); + ExceptCheck; +end; + {======================================================================} procedure TTCPBlockSocket.CreateSocket; @@ -1356,7 +1436,7 @@ begin if Sip = '0.0.0.0' then Sip := LocalName; SPort := IntToStr(GetLocalSinPort); - Connect(FSocksIP, FSocksPort); + inherited Connect(FSocksIP, FSocksPort); b := SocksOpen; if b then b := SocksRequest(2, Sip, SPort); diff --git a/mimeinln.pas b/mimeinln.pas index f42ba16..caf4d8f 100644 --- a/mimeinln.pas +++ b/mimeinln.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.000.002 | +| Project : Delphree - Synapse | 001.000.003 | |==============================================================================| | Content: Inline MIME support procedures and functions | |==============================================================================| @@ -72,7 +72,7 @@ begin Result := Value; x := Pos('=?', Result); y := SearchEndInline(Result, x); - while y > x do + while (y > x) and (x > 0) do //fix by Marcus Moennig (minibbjd@gmx.de) begin s := Copy(Result, x, y - x + 2); su := Copy(s, 3, Length(s) - 4); diff --git a/mimemess.pas b/mimemess.pas index bbe77de..83ca7fa 100644 --- a/mimemess.pas +++ b/mimemess.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.005.000 | +| Project : Delphree - Synapse | 001.007.000 | |==============================================================================| | Content: MIME message object | |==============================================================================| @@ -38,21 +38,27 @@ type private FFrom: string; FToList: TStringList; + FCCList: TStringList; FSubject: string; FOrganization: string; FCustomHeaders: TStringList; + FDate: TDateTime; public constructor Create; destructor Destroy; override; procedure Clear; - procedure EncodeHeaders(Value: TStringList); - procedure DecodeHeaders(Value: TStringList); + procedure EncodeHeaders(const Value: TStringList); + procedure DecodeHeaders(const Value: TStringList); + function FindHeader(Value: string): string; + procedure FindHeaderList(Value: string; const HeaderList: TStringList); published property From: string read FFrom Write FFrom; property ToList: TStringList read FToList; + property CCList: TStringList read FCCList; property Subject: string read FSubject Write FSubject; property Organization: string read FOrganization Write FOrganization; property CustomHeaders: TStringList read FCustomHeaders; + property Date: TDateTime read FDate Write FDate; end; TMimeMess = class(TObject) @@ -66,8 +72,8 @@ type destructor Destroy; override; procedure Clear; function AddPart: Integer; - procedure AddPartText(Value: TStringList); - procedure AddPartHTML(Value: TStringList); + procedure AddPartText(const Value: TStringList); + procedure AddPartHTML(const Value: TStringList); procedure AddPartHTMLBinary(Value, Cid: string); procedure AddPartBinary(Value: string); procedure EncodeMessage; @@ -89,12 +95,14 @@ constructor TMessHeader.Create; begin inherited Create; FToList := TStringList.Create; + FCCList := TStringList.Create; FCustomHeaders := TStringList.Create; end; destructor TMessHeader.Destroy; begin FCustomHeaders.Free; + FCCList.Free; FToList.Free; inherited Destroy; end; @@ -105,23 +113,29 @@ procedure TMessHeader.Clear; begin FFrom := ''; FToList.Clear; + FCCList.Clear; FSubject := ''; FOrganization := ''; FCustomHeaders.Clear; + FDate := 0; end; -procedure TMessHeader.EncodeHeaders(Value: TStringList); +procedure TMessHeader.EncodeHeaders(const Value: TStringList); var n: Integer; begin + if FDate = 0 then + FDate := Now; for n := FCustomHeaders.Count - 1 downto 0 do if FCustomHeaders[n] <> '' then Value.Insert(0, FCustomHeaders[n]); - Value.Insert(0, 'x-mailer: Synapse - Delphi TCP/IP library by Lukas Gebauer'); + Value.Insert(0, 'x-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer'); Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)'); - Value.Insert(0, 'date: ' + Rfc822DateTime(Now)); if FOrganization <> '' then Value.Insert(0, 'Organization: ' + InlineCode(FOrganization)); + for n := 0 to FCCList.Count - 1 do + Value.Insert(0, 'CC: ' + InlineEmail(FCCList[n])); + Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate)); if FSubject <> '' then Value.Insert(0, 'Subject: ' + InlineCode(FSubject)); for n := 0 to FToList.Count - 1 do @@ -129,9 +143,9 @@ begin Value.Insert(0, 'From: ' + InlineEmail(FFrom)); end; -procedure TMessHeader.DecodeHeaders(Value: TStringList); +procedure TMessHeader.DecodeHeaders(const Value: TStringList); var - s: string; + s, t: string; x: Integer; cp: TMimeChar; begin @@ -160,13 +174,58 @@ begin end; if Pos('TO:', UpperCase(s)) = 1 then begin - FToList.Add(InlineDecode(SeparateRight(s, ':'), cp)); + s := SeparateRight(s, ':'); + repeat + t := InlineDecode(fetch(s, ','), cp); + if t <> '' then + FToList.Add(t); + until s = ''; + continue; + end; + if Pos('CC:', UpperCase(s)) = 1 then + begin + s := SeparateRight(s, ':'); + repeat + t := InlineDecode(fetch(s, ','), cp); + if t <> '' then + FCCList.Add(t); + until s = ''; + continue; + end; + if Pos('DATE:', UpperCase(s)) = 1 then + begin + FDate := DecodeRfcDateTime(SeparateRight(s, ':')); continue; end; FCustomHeaders.Add(s); end; end; +function TMessHeader.FindHeader(Value: string): string; +var + n: integer; +begin + Result := ''; + for n := 0 to FCustomHeaders.Count - 1 do + if Pos(Value, FCustomHeaders[n]) = 1 then + begin + Result := SeparateRight(FCustomHeaders[n], ':'); + break; + end; +end; + +procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStringList); +var + n: integer; +begin + HeaderList.Clear; + for n := 0 to FCustomHeaders.Count - 1 do + if Pos(Value, FCustomHeaders[n]) = 1 then + begin + HeaderList.Add(SeparateRight(FCustomHeaders[n], ':')); + end; +end; + {==============================================================================} constructor TMimeMess.Create; @@ -180,6 +239,7 @@ end; destructor TMimeMess.Destroy; begin + Clear; FHeader.Free; Lines.Free; PartList.Free; @@ -209,7 +269,7 @@ end; {==============================================================================} -procedure TMimeMess.AddPartText(Value: TStringList); +procedure TMimeMess.AddPartText(const Value: TStringList); begin with TMimePart(FPartList[AddPart]) do begin @@ -228,7 +288,7 @@ end; {==============================================================================} -procedure TMimeMess.AddPartHTML(Value: TStringList); +procedure TMimeMess.AddPartHTML(const Value: TStringList); begin with TMimePart(FPartList[AddPart]) do begin diff --git a/mimepart.pas b/mimepart.pas index 014820f..407766b 100644 --- a/mimepart.pas +++ b/mimepart.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.005.002 | +| Project : Delphree - Synapse | 001.007.000 | |==============================================================================| | Content: MIME support procedures and functions | |==============================================================================| @@ -44,6 +44,7 @@ type FPrimary: string; FEncoding: string; FCharset: string; + FDefaultCharset: string; FPrimaryCode: TMimePrimary; FEncodingCode: TMimeEncoding; FCharsetCode: TMimeChar; @@ -71,6 +72,7 @@ type property Primary: string read FPrimary write SetPrimary; property Encoding: string read FEncoding write SetEncoding; property Charset: string read FCharset write SetCharset; + property DefaultCharset: string read FDefaultCharset write FDefaultCharset; property PrimaryCode: TMimePrimary read FPrimaryCode Write FPrimaryCode; property EncodingCode: TMimeEncoding read FEncodingCode Write FEncodingCode; property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode; @@ -157,6 +159,7 @@ begin FLines := TStringList.Create; FDecodedLines := TMemoryStream.Create; FTargetCharset := GetCurCP; + FDefaultCharset := 'US-ASCII'; end; destructor TMIMEPart.Destroy; @@ -205,7 +208,7 @@ begin Primary := 'text'; FSecondary := 'plain'; FDescription := ''; - Charset := 'US-ASCII'; + Charset := FDefaultCharset; FFileName := ''; Encoding := '7BIT'; @@ -337,10 +340,8 @@ begin if Pos('--' + b, s) = 1 then begin s := TrimRight(s); - x := Length(s); - if x > 4 then - if (s[x] = '-') and (S[x-1] = '-') then - Result := Value.Count - 1; + if s = ('--' + b + '--') then + Result := Value.Count - 1; Break; end; end; @@ -406,8 +407,10 @@ end; procedure TMIMEPart.EncodePart; var l: TStringList; - s, buff: string; + s, t: string; n, x: Integer; +const + MaxLine = 75; begin if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then Encoding := 'base64'; @@ -423,11 +426,9 @@ begin begin while FDecodedLines.Position < FDecodedLines.Size do begin - Setlength(Buff, 54); - s := ''; - x := FDecodedLines.Read(pointer(Buff)^, 54); - for n := 1 to x do - s := s + Buff[n]; + Setlength(s, 54); + x := FDecodedLines.Read(pointer(s)^, 54); + Setlength(s, x); if FPrimaryCode = MP_TEXT then s := CharsetConversion(s, FTargetCharset, FCharsetCode); s := EncodeBase64(s); @@ -440,13 +441,23 @@ begin for n := 0 to l.Count - 1 do begin s := l[n]; - if FPrimaryCode = MP_TEXT then + if (FPrimaryCode = MP_TEXT) and (FEncodingCode <> ME_7BIT) then s := CharsetConversion(s, FTargetCharset, FCharsetCode); - s := EncodeQuotedPrintable(s); - FLines.Add(s); + if FEncodingCode = ME_QUOTED_PRINTABLE then + begin + s := EncodeQuotedPrintable(s); + repeat + t := Copy(s, 1, MaxLine); + s := Copy(s, MaxLine + 1, Length(s) - MaxLine); + if s <> '' then + t := t + '='; + FLines.Add(t); + until s = ''; + end + else + FLines.Add(s); end; end; - end; FLines.Add(''); FLines.Insert(0, ''); diff --git a/pingsend.pas b/pingsend.pas index 614adc5..13cde86 100644 --- a/pingsend.pas +++ b/pingsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.001.002 | +| Project : Delphree - Synapse | 002.002.000 | |==============================================================================| | Content: PING sender | |==============================================================================| @@ -69,7 +69,6 @@ type FPacketSize: Integer; FPingTime: Integer; function Checksum: Integer; - function GetTick: Cardinal; function ReadPacket: Boolean; public function Ping(const Host: string): Boolean; @@ -178,25 +177,6 @@ begin Result := Word(not CkSum); end; -{$IFDEF LINUX} - -function TPINGSend.GetTick: Cardinal; -var - Stamp: TTimeStamp; -begin - Stamp := DateTimeToTimeStamp(Now); - Result := Stamp.Time; -end; - -{$ELSE} - -function TPINGSend.GetTick: Cardinal; -begin - Result := Windows.GetTickCount; -end; - -{$ENDIF} - {==============================================================================} function PingHost(const Host: string): Integer; diff --git a/pop3send.pas b/pop3send.pas index 5b4cd93..eb254f0 100644 --- a/pop3send.pas +++ b/pop3send.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.001.002 | +| Project : Delphree - Synapse | 001.002.000 | |==============================================================================| | Content: POP3 client | |==============================================================================| @@ -185,7 +185,16 @@ begin end; Result := False; if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then + begin Result := AuthApop; + if not Result then + begin + if not Connect then + Exit; + if ReadResult(False) <> 1 then + Exit; + end; + end; if not Result and not (FAuthType = POP3AuthAPOP) then Result := AuthLogin; end; diff --git a/slogsend.pas b/slogsend.pas index 84f6ac3..0d935b4 100644 --- a/slogsend.pas +++ b/slogsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.000.000 | +| Project : Delphree - Synapse | 001.000.001 | |==============================================================================| | Content: SysLog client | |==============================================================================| @@ -137,6 +137,8 @@ begin Buf := Buf + Tag + ': ' + FMessage; if Length(Buf) <= 1024 then begin + if FSock.EnableReuse(True) then + Fsock.Bind('0.0.0.0', FSyslogPort); FSock.Connect(FSyslogHost, FSyslogPort); FSock.SendString(Buf); Result := FSock.LastError = 0; diff --git a/snmpsend.pas b/snmpsend.pas index 59c3989..dc80cea 100644 --- a/snmpsend.pas +++ b/snmpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.003.005 | +| Project : Delphree - Synapse | 002.003.006 | |==============================================================================| | Content: SNMP client | |==============================================================================| @@ -18,7 +18,7 @@ | All Rights Reserved. | |==============================================================================| | Contributor(s): | -| Jean-Fabien Connault (jfconnault@mail.dotcom.fr) | +| Jean-Fabien Connault (cycocrew@worldnet.fr) | |==============================================================================| | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | @@ -38,14 +38,14 @@ uses const cSnmpProtocol = '161'; -//PDU type + //PDU type PDUGetRequest = $A0; PDUGetNextRequest = $A1; PDUGetResponse = $A2; PDUSetRequest = $A3; PDUTrap = $A4; -//errors + //errors ENoError = 0; ETooBig = 1; ENoSuchName = 2; @@ -60,9 +60,9 @@ type FValue: string; FValueType: Integer; published - property OID: string read FOID Write FOID; - property Value: string read FValue Write FValue; - property ValueType: Integer read FValueType Write FValueType; + property OID: string read FOID write FOID; + property Value: string read FValue write FValue; + property ValueType: Integer read FValueType write FValueType; end; TSNMPRec = class(TObject) @@ -84,12 +84,12 @@ type procedure MIBDelete(Index: Integer); function MIBGet(const MIB: string): string; published - property Version: Integer read FVersion Write FVersion; - property Community: string read FCommunity Write FCommunity; - property PDUType: Integer read FPDUType Write FPDUType; - property ID: Integer read FID Write FID; - property ErrorStatus: Integer read FErrorStatus Write FErrorStatus; - property ErrorIndex: Integer read FErrorIndex Write FErrorIndex; + property Version: Integer read FVersion write FVersion; + property Community: string read FCommunity write FCommunity; + property PDUType: Integer read FPDUType write FPDUType; + property ID: Integer read FID write FID; + property ErrorStatus: Integer read FErrorStatus write FErrorStatus; + property ErrorIndex: Integer read FErrorIndex write FErrorIndex; property SNMPMibList: TList read FSNMPMibList; end; @@ -107,18 +107,16 @@ type destructor Destroy; override; function DoIt: Boolean; published - property Timeout: Integer read FTimeout Write FTimeout; - property Host: string read FHost Write FHost; + property Timeout: Integer read FTimeout write FTimeout; + property Host: string read FHost write FHost; property HostIP: string read FHostIP; property Query: TSNMPRec read FQuery; property Reply: TSNMPRec read FReply; property Sock: TUDPBlockSocket read FSock; end; -function SNMPGet(const Oid, Community, SNMPHost: string; - var Value: string): Boolean; -function SNMPSet(const Oid, Community, SNMPHost, Value: string; - ValueType: Integer): Boolean; +function SNMPGet(const OID, Community, SNMPHost: string; var Value: string): Boolean; +function SNMPSet(const OID, Community, SNMPHost, Value: string; ValueType: Integer): Boolean; implementation @@ -128,7 +126,7 @@ constructor TSNMPRec.Create; begin inherited Create; FSNMPMibList := TList.Create; - id := 1; + FID := 1; end; destructor TSNMPRec.Destroy; @@ -137,6 +135,7 @@ var begin for i := 0 to FSNMPMibList.Count - 1 do TSNMPMib(FSNMPMibList[i]).Free; + FSNMPMibList.Clear; FSNMPMibList.Free; inherited Destroy; end; @@ -292,12 +291,9 @@ begin end; function TSNMPSend.DoIt: Boolean; -var - x: Integer; begin - Result := False; FReply.Clear; - FBuffer := Query.EncodeBuf; + FBuffer := FQuery.EncodeBuf; FSock.Connect(FHost, cSnmpProtocol); FHostIP := '0.0.0.0'; FSock.SendString(FBuffer); @@ -305,43 +301,45 @@ begin if FSock.LastError = 0 then begin FHostIP := FSock.GetRemoteSinIP; - Result := True; - end; - if Result then Result := FReply.DecodeBuf(FBuffer); + end + else + Result := False; end; {==============================================================================} -function SNMPGet(const Oid, Community, SNMPHost: string; - var Value: string): Boolean; -var - SNMP: TSNMPSend; -begin - SNMP := TSNMPSend.Create; - try - SNMP.Query.Community := Community; - SNMP.Query.PDUType := PDUGetRequest; - SNMP.Query.MIBAdd(Oid, '', ASN1_NULL); - SNMP.Host := SNMPHost; - Result := SNMP.DoIt; - if Result then - Value := SNMP.Reply.MIBGet(Oid); - finally - SNMP.Free; - end; -end; - -function SNMPSet(const Oid, Community, SNMPHost, Value: string; - ValueType: Integer): Boolean; +function SNMPGet(const OID, 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 := PDUGetRequest; + SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL); + SNMPSend.Host := SNMPHost; + Result := SNMPSend.DoIt; + if Result then + Value := SNMPSend.Reply.MIBGet(OID) + else + Value := ''; + finally + SNMPSend.Free; + end; +end; + +function SNMPSet(const OID, Community, SNMPHost, Value: string; ValueType: Integer): Boolean; +var + SNMPSend: TSNMPSend; +begin + SNMPSend := TSNMPSend.Create; + try + SNMPSend.Query.Clear; SNMPSend.Query.Community := Community; SNMPSend.Query.PDUType := PDUSetRequest; - SNMPSend.Query.MIBAdd(Oid, Value, ValueType); + SNMPSend.Query.MIBAdd(OID, Value, ValueType); SNMPSend.Host := SNMPHost; Result := SNMPSend.DoIt = True; finally @@ -350,3 +348,5 @@ begin end; end. + + diff --git a/sntpsend.pas b/sntpsend.pas index de9d60b..c7d3bf7 100644 --- a/sntpsend.pas +++ b/sntpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.000.002 | +| Project : Delphree - Synapse | 002.001.000 | |==============================================================================| | Content: SNTP client | |==============================================================================| @@ -18,6 +18,7 @@ | All Rights Reserved. | |==============================================================================| | Contributor(s): | +| Patrick Chevalley | |==============================================================================| | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | @@ -32,7 +33,7 @@ interface uses SysUtils, - synsock, blcksock; + synsock, blcksock, SynaUtil; const cNtpProtocol = 'ntp'; @@ -61,19 +62,30 @@ type private FNTPReply: TNtp; FNTPTime: TDateTime; + FNTPOffset: double; + FNTPDelay: double; + FMaxSyncDiff: double; + FSyncTime: Boolean; FSntpHost: string; FTimeout: Integer; FSock: TUDPBlockSocket; FBuffer: string; + FLi, FVn, Fmode : byte; public constructor Create; destructor Destroy; override; function DecodeTs(Nsec, Nfrac: Longint): TDateTime; + procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); + function GetSNTP: Boolean; function GetNTP: Boolean; function GetBroadcastNTP: Boolean; published property NTPReply: TNtp read FNTPReply; property NTPTime: TDateTime read FNTPTime; + property NTPOffset: Double read FNTPOffset; + property NTPDelay: Double read FNTPDelay; + property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff; + property SyncTime: Boolean read FSyncTime write FSyncTime; property SntpHost: string read FSntpHost write FSntpHost; property Timeout: Integer read FTimeout write FTimeout; property Sock: TUDPBlockSocket read FSock; @@ -88,6 +100,8 @@ begin FSock.CreateSocket; FTimeout := 5000; FSntpHost := cLocalhost; + FMaxSyncDiff := 3600; + FSyncTime := False; end; destructor TSNTPSend.Destroy; @@ -98,7 +112,7 @@ end; function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime; const - maxi = 4294967296.0; + maxi = 4294967295.0; var d, d1: Double; begin @@ -106,16 +120,38 @@ begin Nfrac := synsock.htonl(Nfrac); d := Nsec; if d < 0 then - d := maxi + d - 1; + d := maxi + d + 1; d1 := Nfrac; if d1 < 0 then - d1 := maxi + d1 - 1; + d1 := maxi + d1 + 1; d1 := d1 / maxi; - d1 := Trunc(d1 * 1000) / 1000; + d1 := Trunc(d1 * 10000) / 10000; Result := (d + d1) / 86400; Result := Result + 2; end; +procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); +const + maxi = 4294967295.0; + maxilongint = 2147483647; +var + d, d1: Double; +begin + d := (dt - 2) * 86400; + d1 := frac(d); + d := trunc(d); + if d>maxilongint then + d := d - maxi - 1; + d1 := Trunc(d1 * 10000) / 10000; + d1 := d1 * maxi; + if d1>maxilongint then + d1 := d1 - maxi - 1; + Nsec:=trunc(d); + Nfrac:=trunc(d1); + Nsec := synsock.htonl(Nsec); + Nfrac := synsock.htonl(Nfrac); +end; + function TSNTPSend.GetBroadcastNTP: Boolean; var NtpPtr: PNtp; @@ -123,23 +159,24 @@ var begin Result := False; FSock.Bind('0.0.0.0', cNtpProtocol); - if FSock.CanRead(Timeout) then + FBuffer := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then begin - x := FSock.WaitingData; - SetLength(FBuffer, x); - FSock.RecvBufferFrom(Pointer(FBuffer), x); + x := Length(FBuffer); if (SntpHost = '0.0.0.0') or (FSock.GetRemoteSinIP = SntpHost) then if x >= SizeOf(NTPReply) then begin NtpPtr := Pointer(FBuffer); FNTPReply := NtpPtr^; FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); + if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then + SetUTTime(FNTPTime); Result := True; end; end; end; -function TSNTPSend.GetNTP: Boolean; +function TSNTPSend.GetSNTP: Boolean; var q: TNtp; NtpPtr: PNtp; @@ -150,19 +187,65 @@ begin FillChar(q, SizeOf(q), 0); q.mode := $1B; FSock.SendBuffer(@q, SizeOf(q)); - if FSock.CanRead(Timeout) then + FBuffer := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then begin - x := FSock.WaitingData; - SetLength(FBuffer, x); - FSock.RecvBuffer(Pointer(FBuffer), x); + x := Length(FBuffer); if x >= SizeOf(NTPReply) then begin NtpPtr := Pointer(FBuffer); FNTPReply := NtpPtr^; FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); + if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then + SetUTTime(FNTPTime); Result := True; end; end; end; +function TSNTPSend.GetNTP: Boolean; +var + q: TNtp; + NtpPtr: PNtp; + x: Integer; + t1, t2, t3, t4 : TDateTime; +begin + Result := False; + FSock.Connect(sntphost, cNtpProtocol); + FillChar(q, SizeOf(q), 0); + q.mode := $1B; + t1 := GetUTTime; + EncodeTs(t1,q.org1,q.org2); + FSock.SendBuffer(@q, SizeOf(q)); + FBuffer := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + begin + x := Length(FBuffer); + t4 := GetUTTime; + if x >= SizeOf(NTPReply) then + begin + NtpPtr := Pointer(FBuffer); + FNTPReply := NtpPtr^; + FLi := (NTPReply.mode and $C0) shr 6; + FVn := (NTPReply.mode and $38) shr 3; + Fmode := NTPReply.mode and $07; + if (Fli < 3) and (Fmode = 4) and + (NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and + (NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0) + then begin + t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2); + t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); + FNTPDelay := (T4 - T1) - (T2 - T3); + FNTPTime := t3 + FNTPDelay / 2; + FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400; + FNTPDelay := FNTPDelay * 86400; + if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then + SetUTTime(FNTPTime); + Result := True; + end + else result:=false; + end; + end; +end; + end. diff --git a/synachar.pas b/synachar.pas index bf72382..2206a85 100644 --- a/synachar.pas +++ b/synachar.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 004.000.000 | +| Project : Delphree - Synapse | 004.000.001 | |==============================================================================| | Content: Charset conversion support | |==============================================================================| @@ -947,7 +947,7 @@ begin s := s + c; end; if s = '' then - s := '+' + s := WriteMulti(Ord('+'), 0, 0, 0, 2) else s := DecodeBase64(s); Result := Result + s; diff --git a/synacode.pas b/synacode.pas index 0b2f3e9..a82473e 100644 --- a/synacode.pas +++ b/synacode.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 001.004.001 | +| Project : Delphree - Synapse | 001.005.002 | |==============================================================================| | Content: Coding and decoding support | |==============================================================================| @@ -52,7 +52,33 @@ const '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_'; TableXX = '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_'; - + ReTablebase64 = + #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$3E +#$40 + +#$40 +#$40 +#$3F +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C + +#$3D +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$01 +#$02 +#$03 + +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C +#$0D +#$0E +#$0F + +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 + +#$22 +#$23 +#$24 +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D + +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; + ReTableUU = + #$01 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C + +#$0D +#$0E +#$0F +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 + +#$19 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 + +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D +#$2E +#$2F +#$30 + +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C + +#$3D +#$3E +#$3F +#$00 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; + ReTableXX = + #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$40 + +#$01 +#$40 +#$40 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A + +#$0B +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$0C +#$0D +#$0E +#$0F + +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$1A +#$1B + +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 +#$25 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D + +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 + +#$3A +#$3B +#$3C +#$3D +#$3E +#$3F +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; function DecodeTriplet(const Value: string; Delimiter: Char): string; function DecodeQuotedPrintable(const Value: string): string; @@ -63,6 +89,8 @@ function EncodeQuotedPrintable(const Value: string): string; function EncodeURLElement(const Value: string): string; function EncodeURL(const Value: string): string; function Decode4to3(const Value, Table: string): string; +function Decode4to3Ex(const Value, Table: string): string; +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; @@ -193,27 +221,31 @@ type function DecodeTriplet(const Value: string; Delimiter: Char): string; var - x: Integer; + x, l: Integer; c: Char; s: string; begin - Result := ''; + SetLength(Result, Length(Value)); x := 1; + l := 1; while x <= Length(Value) do begin c := Value[x]; Inc(x); if c <> Delimiter then - Result := Result + c + Result[l] := c else if x < Length(Value) then begin s := Copy(Value, x, 2); Inc(x, 2); if pos(#13, s) + pos(#10, s) = 0 then - Result := Result + Char(StrToIntDef('$' + s, 32)); + Result[l] := Char(StrToIntDef('$' + s, 32)); end; + Inc(l); end; + Dec(l); + SetLength(Result, l); end; {==============================================================================} @@ -235,17 +267,33 @@ end; function EncodeTriplet(const Value: string; Delimiter: Char; Specials: TSpecials): string; var - n: Integer; + n, l: Integer; s: string; + c: char; begin - Result := ''; + SetLength(Result, Length(Value) * 3); + l := 1; for n := 1 to Length(Value) do begin - s := Value[n]; - if s[1] in Specials then - s := Delimiter + IntToHex(Ord(s[1]), 2); - Result := Result + s; + c := Value[n]; + if c in Specials then + begin + Result[l] := Delimiter; + Inc(l); + s := IntToHex(Ord(c), 2); + Result[l] := s[1]; + Inc(l); + Result[l] := s[2]; + Inc(l); + end + else + begin + Result[l] := c; + Inc(l); + end; end; + Dec(l); + SetLength(Result, l); end; {==============================================================================} @@ -274,11 +322,12 @@ end; function Decode4to3(const Value, Table: string): string; var - x, y, n: Integer; + x, y, n, l: Integer; d: array[0..3] of Byte; begin - Result := ''; + SetLength(Result, Length(Value)); x := 1; + l := 1; while x < Length(Value) do begin for n := 0 to 3 do @@ -294,33 +343,77 @@ begin end; Inc(x); end; - Result := Result + Char((D[0] and $3F) shl 2 + (D[1] and $30) shr 4); + Result[l] := Char((D[0] and $3F) shl 2 + (D[1] and $30) shr 4); + Inc(l); if d[2] <> 64 then begin - Result := Result + Char((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2); + Result[l] := Char((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2); + Inc(l); if d[3] <> 64 then - Result := Result + Char((D[2] and $03) shl 6 + (D[3] and $3F)); + begin + Result[l] := Char((D[2] and $03) shl 6 + (D[3] and $3F)); + Inc(l); + end; end; end; + Dec(l); + SetLength(Result, l); end; {==============================================================================} -function DecodeBase64(const Value: string): string; +function Decode4to3Ex(const Value, Table: string): string; +var + x, y, n, l: Integer; + d: array[0..3] of Byte; begin - Result := Decode4to3(Value, TableBase64); + SetLength(Result, Length(Value)); + x := 1; + l := 1; + while x < Length(Value) do + begin + for n := 0 to 3 do + begin + if x > Length(Value) then + d[n] := 64 + else + begin + y := Ord(Value[x]); + if (y < 33) or (y > 127) then + d[n] := 64 + else + d[n] := Ord(Table[y - 32]); + end; + Inc(x); + end; + Result[l] := Char((D[0] and $3F) shl 2 + (D[1] and $30) shr 4); + Inc(l); + if d[2] <> 64 then + begin + Result[l] := Char((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2); + Inc(l); + if d[3] <> 64 then + begin + Result[l] := Char((D[2] and $03) shl 6 + (D[3] and $3F)); + Inc(l); + end; + end; + end; + Dec(l); + SetLength(Result, l); end; {==============================================================================} -function EncodeBase64(const Value: string): string; +function Encode3to4(const Value, Table: string): string; var c: Byte; - n: Integer; + n, l: Integer; Count: Integer; DOut: array[0..3] of Byte; begin - Result := ''; + setlength(Result, ((Length(Value) + 2) div 3) * 4); + l := 1; Count := 1; while Count <= Length(Value) do begin @@ -352,12 +445,29 @@ begin DOut[3] := $40; end; for n := 0 to 3 do - Result := Result + TableBase64[DOut[n] + 1]; + begin + Result[l] := Table[DOut[n] + 1]; + Inc(l); + end; end; end; {==============================================================================} +function DecodeBase64(const Value: string): string; +begin + Result := Decode4to3Ex(Value, ReTableBase64); +end; + +{==============================================================================} + +function EncodeBase64(const Value: string): string; +begin + Result := Encode3to4(Value, TableBase64); +end; + +{==============================================================================} + function DecodeUU(const Value: string): string; var s: string; diff --git a/synautil.pas b/synautil.pas index c637998..e4007d4 100644 --- a/synautil.pas +++ b/synautil.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Delphree - Synapse | 002.003.000 | +| Project : Delphree - Synapse | 002.007.001 | |==============================================================================| | Content: support procedures and functions | |==============================================================================| @@ -39,15 +39,22 @@ uses Windows; {$ENDIF} -function Timezone: string; +function TimeZoneBias: integer; +function TimeZone: string; function Rfc822DateTime(t: TDateTime): string; function CDateTime(t: TDateTime): string; +function SimpleDateTime(t: TDateTime): string; +function DecodeRfcDateTime(Value: string): TDateTime; +function GetUTTime: TDateTime; +function SetUTTime(Newdt: TDateTime): Boolean; +function GetTick: Cardinal; function CodeInt(Value: Word): string; function DecodeInt(const Value: string; Index: Integer): Word; function IsIP(const Value: string): Boolean; function ReverseIP(Value: string): string; function IPToID(Host: string): string; procedure Dump(const Buffer, DumpFile: string); +procedure DumpEx(const Buffer, DumpFile: string); function SeparateLeft(const Value, Delimiter: string): string; function SeparateRight(const Value, Delimiter: string): string; function GetParameter(const Value, Parameter: string): string; @@ -102,26 +109,19 @@ begin end; {==============================================================================} -function Timezone: string; +function TimeZoneBias: integer; {$IFDEF LINUX} var t: TTime_T; UT: TUnixTime; - bias: Integer; - h, m: Integer; begin __time(@T); localtime_r(@T, UT); - bias := ut.__tm_gmtoff div 60; - if bias >= 0 then - Result := '+' - else - Result := '-'; + Result := ut.__tm_gmtoff div 60; {$ELSE} var zoneinfo: TTimeZoneInformation; bias: Integer; - h, m: Integer; begin case GetTimeZoneInformation(Zoneinfo) of 2: @@ -131,11 +131,22 @@ begin else bias := zoneinfo.Bias; end; - if bias <= 0 then + Result := bias * (-1); +{$ENDIF} +end; + +{==============================================================================} + +function TimeZone: string; +var + bias: Integer; + h, m: Integer; +begin + bias := TimeZoneBias; + if bias >= 0 then Result := '+' else Result := '-'; -{$ENDIF} bias := Abs(bias); h := bias div 60; m := bias mod 60; @@ -148,7 +159,7 @@ function Rfc822DateTime(t: TDateTime): string; begin SaveNames; try - Result := FormatDateTime('ddd, d mmm yyyy hh:mm:ss', t); + Result := FormatDateTime('ddd, d mmm yyyy hh:nn:ss', t); Result := Result + ' ' + Timezone; finally RestoreNames; @@ -161,7 +172,7 @@ function CDateTime(t: TDateTime): string; begin SaveNames; try - Result := FormatDateTime('mmm dd hh:mm:ss', t); + Result := FormatDateTime('mmm dd hh:nn:ss', t); if Result[5] = '0' then Result[5] := ' '; finally @@ -171,6 +182,260 @@ end; {==============================================================================} +function SimpleDateTime(t: TDateTime): string; +begin + SaveNames; + try + Result := FormatDateTime('yymmdd hhnnss', t); + finally + RestoreNames; + end; +end; + +{==============================================================================} + +function DecodeTimeZone(Value: string; var Zone: integer): Boolean; +var + x: integer; + zh, zm: integer; + s: string; +begin + Result := false; + s := Value; + if (Pos('+', s) = 1) or (Pos('-',s) = 1) then + begin + if s = '-0000' then + Zone := TimeZoneBias + else + if Length(s) > 4 then + begin + zh := StrToIntdef(s[2] + s[3], 0); + zm := StrToIntdef(s[4] + s[5], 0); + zone := zh * 60 + zm; + if s[1] = '-' then + zone := zone * (-1); + end; + Result := True; + end + else + begin + x := 32767; + if s = 'NZDT' then x := 13; + if s = 'IDLE' then x := 12; + if s = 'NZST' then x := 12; + if s = 'NZT' then x := 12; + if s = 'EADT' then x := 11; + if s = 'GST' then x := 10; + if s = 'JST' then x := 9; + if s = 'CCT' then x := 8; + if s = 'WADT' then x := 8; + if s = 'WAST' then x := 7; + if s = 'ZP6' then x := 6; + if s = 'ZP5' then x := 5; + if s = 'ZP4' then x := 4; + if s = 'BT' then x := 3; + if s = 'EET' then x := 2; + if s = 'MEST' then x := 2; + if s = 'MESZ' then x := 2; + if s = 'SST' then x := 2; + if s = 'FST' then x := 2; + if s = 'CEST' then x := 2; + if s = 'CET' then x := 1; + if s = 'FWT' then x := 1; + if s = 'MET' then x := 1; + if s = 'MEWT' then x := 1; + if s = 'SWT' then x := 1; + if s = 'UT' then x := 0; + if s = 'UTC' then x := 0; + if s = 'GMT' then x := 0; + if s = 'WET' then x := 0; + if s = 'WAT' then x := -1; + if s = 'BST' then x := -1; + if s = 'AT' then x := -2; + if s = 'ADT' then x := -3; + if s = 'AST' then x := -4; + if s = 'EDT' then x := -4; + if s = 'EST' then x := -5; + if s = 'CDT' then x := -5; + if s = 'CST' then x := -6; + if s = 'MDT' then x := -6; + if s = 'MST' then x := -7; + if s = 'PDT' then x := -7; + if s = 'PST' then x := -8; + if s = 'YDT' then x := -8; + if s = 'YST' then x := -9; + if s = 'HDT' then x := -9; + if s = 'AHST' then x := -10; + if s = 'CAT' then x := -10; + if s = 'HST' then x := -10; + if s = 'EAST' then x := -10; + if s = 'NT' then x := -11; + if s = 'IDLW' then x := -12; + if x <> 32767 then + begin + zone := x * 60; + Result := True; + end; + end; +end; + +{==============================================================================} + +function DecodeRfcDateTime(Value: string): TDateTime; +var + day, month, year: Word; + zone: integer; + x: integer; + s: string; + SaveSeparator: char; + n: integer; + t: TDateTime; +begin +// ddd, d mmm yyyy hh:mm:ss +// ddd, d mmm yy hh:mm:ss +// ddd, mmm d yyyy hh:mm:ss +// ddd mmm dd hh:mm:ss yyyy +// Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 +// Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 +// Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format + + Result := 0; + SaveSeparator := TimeSeparator; + try + TimeSeparator := ':'; + day := 0; + month := 0; + year := 0; + zone := 0; + Value := StringReplace(Value, ' -', ' #'); + Value := StringReplace(Value, '-', ' '); + Value := StringReplace(Value, ' #', ' -'); + while Value <> '' do + begin + s := Fetch(Value, ' '); + s := uppercase(s); + // timezone + if DecodetimeZone(s, x) then + begin + zone := x; + continue; + end; + x := StrToIntDef(s, 0); + // day or year + if x > 0 then + if (x < 32) and (day = 0) then + begin + day := x; + continue; + end + else + begin + year := x; + if year < 32 then + year := year + 2000; + if year < 1000 then + year := year + 1900; + continue; + end; + // time + if rpos(':', s) > Pos(':', s) then + begin + t := 0; + try + t := StrToTime(s); + except + on Exception do ; + end; + if t <> 0 then + Result := t; + continue; + end; + //timezone daylight saving time + if s = 'DST' then + begin + zone := zone + 60; + continue; + end; + // month + for n := 1 to 12 do + if s = uppercase(MyMonthNames[n]) then + begin + month := n; + break; + end; + end; + Result := Result + Encodedate(year, month, day); + zone := zone - TimeZoneBias; + t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0); + if zone < 0 then + t := 0 - t; + Result := Result - t; + finally + TimeSeparator := SaveSeparator; + end; +end; + +{==============================================================================} + +function GetUTTime: TDateTime; +{$IFNDEF LINUX} +var + st: TSystemTime; +begin + GetSystemTime(st); + result:=SystemTimeToDateTime(st); +{$ELSE} +var + TV: TTimeVal; +begin + gettimeofday(TV, nil); + Result:=UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; +{$ENDIF} +end; + +{==============================================================================} + +function SetUTTime(Newdt: TDateTime): Boolean; +{$IFNDEF LINUX} +var + st: TSystemTime; +begin + DateTimeToSystemTime(newdt,st); + Result:=SetSystemTime(st); +{$ELSE} +var + TV: TTimeVal; + d: double; + TZ: Ttimezone; +begin + Result := false; + gettimeofday(TV, TZ); + d := (newdt - UnixDateDelta) * 86400; + TV.tv_sec := trunc(d); + TV.tv_usec := trunc(frac(d) * 1000000); + Result := settimeofday(TV, TZ) <> -1; +{$ENDIF} +end; + +{==============================================================================} + +{$IFDEF LINUX} +function GetTick: Cardinal; +var + Stamp: TTimeStamp; +begin + Stamp := DateTimeToTimeStamp(Now); + Result := Stamp.Time; +end; +{$ELSE} +function GetTick: Cardinal; +begin + Result := Windows.GetTickCount; +end; +{$ENDIF} + +{==============================================================================} + function CodeInt(Value: Word): string; begin Result := Chr(Hi(Value)) + Chr(Lo(Value)) @@ -278,6 +543,35 @@ end; {==============================================================================} +procedure DumpEx(const Buffer, DumpFile: string); +var + n: Integer; + x: Byte; + s: string; + f: Text; +begin + s := ''; + for n := 1 to Length(Buffer) do + begin + x := Ord(Buffer[n]); + if x in [65..90, 97..122] then + s := s + ' +''' + char(x) + '''' + else + s := s + ' +#$' + IntToHex(Ord(Buffer[n]), 2); + end; + AssignFile(f, DumpFile); + if FileExists(DumpFile) then + DeleteFile(PChar(DumpFile)); + Rewrite(f); + try + Writeln(f, s); + finally + CloseFile(f); + end; +end; + +{==============================================================================} + function SeparateLeft(const Value, Delimiter: string): string; var x: Integer; @@ -359,13 +653,13 @@ begin s := SeparateLeft(s, '"') else begin - s := SeparateRight(Value, '('); - if s <> Value then - s := SeparateLeft(s, ')') - else + s := SeparateLeft(Value, '<'); + if s = Value then begin - s := SeparateLeft(Value, '<'); - if s = Value then + s := SeparateRight(Value, '('); + if s <> Value then + s := SeparateLeft(s, ')') + else s := ''; end; end; @@ -449,7 +743,7 @@ begin else sURL := URL; x := Pos('@', sURL); - if x > 0 then + if (x > 0) and (x < Pos('/', sURL)) then begin s := SeparateLeft(sURL, '@'); sURL := SeparateRight(sURL, '@'); @@ -547,9 +841,16 @@ end; {==============================================================================} function Fetch(var Value: string; const Delimiter: string): string; +var + s: string; begin Result := SeparateLeft(Value, Delimiter); - Value := SeparateRight(Value, Delimiter); + s := SeparateRight(Value, Delimiter); + if s = Value then + Value := '' + else + Value := Trim(s); + Result := Trim(Result); end; end.