pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

Release 26

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@55 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2008-04-24 07:12:01 +00:00
parent ecf3d4aa68
commit 47b69e0a35
15 changed files with 1748 additions and 227 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

575
IMAPsend.pas Normal file
View File

@ -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.

310
NNTPsend.pas Normal file
View File

@ -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.

2
asn1util.pas
View File

@ -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 |

200
blcksock.pas
View File

@ -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);

4
mimeinln.pas
View File

@ -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);

86
mimemess.pas
View File

@ -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

43
mimepart.pas
View File

@ -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, '');

22
pingsend.pas
View File

@ -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;

11
pop3send.pas
View File

@ -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;

4
slogsend.pas
View File

@ -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;

98
snmpsend.pas
View File

@ -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.

113
sntpsend.pas
View File

@ -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.

4
synachar.pas
View File

@ -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;

156
synacode.pas
View File

@ -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;

347
synautil.pas
View File

@ -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.