TransGUI/ 0000755 0000000 0000000 00000000000 12261774331 011216 5 ustar root root TransGUI/connoptions.pas 0000644 0000000 0000000 00000041016 12261763702 014276 0 ustar root root {*************************************************************************************
This file is part of Transmission Remote GUI.
Copyright (c) 2008-2014 by Yury Sidorov.
Transmission Remote GUI is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
Transmission Remote GUI is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Transmission Remote GUI; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*************************************************************************************}
unit ConnOptions;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, Spin, ComCtrls, Buttons, ButtonPanel, ExtCtrls, BaseForm;
const
DefSpeeds = '0,10,25,50,100,250,500,750,1000,2500,5000,7000';
resourcestring
sNoHost = 'No host name specified.';
sNoProxy = 'No proxy server specified.';
SDelConnection = 'Are you sure to delete connection ''%s''?';
SNewConnection = 'New connection to Transmission';
type
{ TConnOptionsForm }
TConnOptionsForm = class(TBaseForm)
btNew: TButton;
btDel: TButton;
btRename: TButton;
Buttons: TButtonPanel;
cbProxyAuth: TCheckBox;
cbUseProxy: TCheckBox;
cbUseSocks5: TCheckBox;
cbAuth: TCheckBox;
cbShowAdvanced: TCheckBox;
cbAskPassword: TCheckBox;
edRpcPath: TEdit;
edUpSpeeds: TEdit;
edHost: TEdit;
cbSSL: TCheckBox;
cbConnection: TComboBox;
edDownSpeeds: TEdit;
edProxy: TEdit;
edProxyPassword: TEdit;
edProxyPort: TSpinEdit;
edProxyUserName: TEdit;
edUserName: TEdit;
edPassword: TEdit;
edPaths: TMemo;
gbSpeed: TGroupBox;
txRpcPath: TLabel;
txConName: TLabel;
txConnHelp: TLabel;
txDownSpeeds: TLabel;
panTop: TPanel;
tabProxy: TTabSheet;
tabMisc: TTabSheet;
txUpSpeeds: TLabel;
txPaths: TLabel;
tabPaths: TTabSheet;
Page: TPageControl;
tabConnection: TTabSheet;
txProxy: TLabel;
txProxyPassword: TLabel;
txProxyPort: TLabel;
txProxyUserName: TLabel;
txUserName: TLabel;
txPort: TLabel;
edPort: TSpinEdit;
txHost: TLabel;
txPassword: TLabel;
procedure btDelClick(Sender: TObject);
procedure btNewClick(Sender: TObject);
procedure btOKClick(Sender: TObject);
procedure btRenameClick(Sender: TObject);
procedure cbAskPasswordClick(Sender: TObject);
procedure cbAuthClick(Sender: TObject);
procedure cbConnectionSelect(Sender: TObject);
procedure cbProxyAuthClick(Sender: TObject);
procedure cbShowAdvancedClick(Sender: TObject);
procedure cbUseProxyClick(Sender: TObject);
procedure edHostChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure tabPathsShow(Sender: TObject);
private
FCurConn: string;
FCurHost: string;
edConnection: TEdit;
function Validate: boolean;
procedure BeginEdit;
procedure EndEdit;
procedure SaveConnectionsList;
public
ActiveConnection: string;
ActiveSettingChanged: boolean;
procedure LoadConnSettings(const ConnName: string);
procedure SaveConnSettings(const ConnName: string);
function IsConnSettingsChanged(const ConnName: string): boolean;
end;
implementation
uses Main, synacode, utils, rpc;
{ TConnOptionsForm }
procedure TConnOptionsForm.btOKClick(Sender: TObject);
begin
if not Validate then
exit;
EndEdit;
SaveConnSettings(FCurConn);
SaveConnectionsList;
ModalResult:=mrOk;
end;
procedure TConnOptionsForm.btRenameClick(Sender: TObject);
begin
if edConnection.Visible then begin
if Trim(edConnection.Text) = '' then exit;
EndEdit;
exit;
end;
if cbConnection.Text = '' then exit;
BeginEdit;
ActiveControl:=edConnection;
edConnection.SelectAll;
end;
procedure TConnOptionsForm.cbAskPasswordClick(Sender: TObject);
begin
EnableControls(not cbAskPassword.Checked and cbAskPassword.Enabled, [txPassword, edPassword]);
end;
procedure TConnOptionsForm.cbAuthClick(Sender: TObject);
begin
EnableControls(cbAuth.Checked, [txUserName, edUserName, txPassword, cbAskPassword]);
cbAskPasswordClick(nil);
end;
procedure TConnOptionsForm.cbConnectionSelect(Sender: TObject);
var
i: integer;
s: string;
begin
if edConnection.Visible then
exit;
i:=cbConnection.ItemIndex;
if i >= 0 then
s:=cbConnection.Items[i]
else
s:='';
if (FCurConn <> s) and (FCurConn <> '') then begin
if not Validate then begin
cbConnection.ItemIndex:=cbConnection.Items.IndexOf(FCurConn);
exit;
end;
SaveConnSettings(FCurConn);
end;
if s <> '' then
LoadConnSettings(s);
end;
procedure TConnOptionsForm.cbProxyAuthClick(Sender: TObject);
begin
EnableControls(cbProxyAuth.Checked and cbProxyAuth.Enabled, [txProxyUserName, edProxyUserName, txProxyPassword, edProxyPassword]);
end;
procedure TConnOptionsForm.cbShowAdvancedClick(Sender: TObject);
begin
txRpcPath.Visible:=cbShowAdvanced.Checked;
edRpcPath.Visible:=cbShowAdvanced.Checked;
{$ifndef LCLgtk2}
tabConnection.TabVisible:=cbShowAdvanced.Checked;
{$endif LCLgtk2}
tabProxy.TabVisible:=cbShowAdvanced.Checked;
tabPaths.TabVisible:=cbShowAdvanced.Checked;
tabMisc.TabVisible:=cbShowAdvanced.Checked;
cbShowAdvanced.Visible:=not cbShowAdvanced.Checked;
Page.ActivePage:=tabConnection;
end;
procedure TConnOptionsForm.btNewClick(Sender: TObject);
begin
EndEdit;
if (FCurConn <> '') and not Validate then
exit;
SaveConnSettings(FCurConn);
LoadConnSettings('');
BeginEdit;
edConnection.Text:='';
Page.ActivePage:=tabConnection;
ActiveControl:=edHost;
end;
procedure TConnOptionsForm.btDelClick(Sender: TObject);
var
i: integer;
begin
if edConnection.Visible or (cbConnection.Text = '') then
exit;
if MessageDlg('', Format(SDelConnection, [cbConnection.Text]), mtConfirmation, mbYesNo, 0, mbNo) <> mrYes then exit;
if FCurConn <> '' then begin
Ini.EraseSection('Connection.' + FCurConn);
Ini.EraseSection('Connection');
Ini.EraseSection('AddTorrent.' + FCurConn);
i:=cbConnection.ItemIndex;
if i >= 0 then begin
cbConnection.Items.Delete(i);
if i >= cbConnection.Items.Count then begin
i:=cbConnection.Items.Count - 1;
if i < 0 then
i:=0;
end;
end
else
i:=0;
if i < cbConnection.Items.Count then
cbConnection.ItemIndex:=i
else
cbConnection.ItemIndex:=-1;
end
else
cbConnection.ItemIndex:=-1;
if cbConnection.ItemIndex >= 0 then begin
if FCurConn = ActiveConnection then
ActiveConnection:='';
LoadConnSettings(cbConnection.Items[cbConnection.ItemIndex]);
if ActiveConnection = '' then
ActiveConnection:=FCurConn;
end
else begin
FCurConn:='';
btNewClick(nil);
end;
SaveConnectionsList;
end;
procedure TConnOptionsForm.cbUseProxyClick(Sender: TObject);
begin
EnableControls(cbUseProxy.Checked, [txProxy, edProxy, txProxyPort, edProxyPort, cbUseSocks5, cbProxyAuth]);
cbProxyAuthClick(nil);
end;
procedure TConnOptionsForm.edHostChange(Sender: TObject);
begin
if edConnection.Visible and (edConnection.Text = FCurHost) then
edConnection.Text:=edHost.Text;
FCurHost:=edHost.Text;
end;
procedure TConnOptionsForm.FormCreate(Sender: TObject);
var
i, cnt: integer;
s: string;
begin
Page.ActivePageIndex:=0;
txConnHelp.Caption:=Format(txConnHelp.Caption, [AppName]);
ActiveControl:=edHost;
Buttons.OKButton.ModalResult:=mrNone;
Buttons.OKButton.OnClick:=@btOKClick;
edConnection:=TEdit.Create(cbConnection.Parent);
edConnection.Visible:=False;
edConnection.BoundsRect:=cbConnection.BoundsRect;
edConnection.Parent:=cbConnection.Parent;
cnt:=Ini.ReadInteger('Hosts', 'Count', 0);
for i:=1 to cnt do begin
s:=Ini.ReadString('Hosts', Format('Host%d', [i]), '');
if s <> '' then
cbConnection.Items.Add(s);
end;
cbShowAdvanced.Top:=edRpcPath.Top;
end;
procedure TConnOptionsForm.FormShow(Sender: TObject);
begin
if edConnection.Visible then
exit;
if cbConnection.Items.Count = 0 then begin
btNewClick(nil);
exit;
end;
cbConnection.ItemIndex:=cbConnection.Items.IndexOf(ActiveConnection);
if cbConnection.ItemIndex < 0 then
cbConnection.ItemIndex:=0;
LoadConnSettings(cbConnection.Text);
end;
procedure TConnOptionsForm.tabPathsShow(Sender: TObject);
var
R: TRect;
begin
R:=edPaths.BoundsRect;
R.Top:=txPaths.BoundsRect.Bottom + 8;
edPaths.BoundsRect:=R;
end;
function TConnOptionsForm.Validate: boolean;
begin
Result:=False;
edHost.Text:=Trim(edHost.Text);
if Trim(edHost.Text) = '' then begin
Page.ActivePage:=tabConnection;
edHost.SetFocus;
MessageDlg(sNoHost, mtError, [mbOK], 0);
exit;
end;
edProxy.Text:=Trim(edProxy.Text);
if tabProxy.TabVisible and cbUseProxy.Checked and (edProxy.Text = '') then begin
Page.ActivePage:=tabProxy;
edProxy.SetFocus;
MessageDlg(sNoProxy, mtError, [mbOK], 0);
exit;
end;
Result:=True;
end;
procedure TConnOptionsForm.EndEdit;
procedure RenameSection(const OldName, NewName: string);
var
i: integer;
sl: TStringList;
begin
sl:=TStringList.Create;
with Ini do
try
ReadSectionValues(OldName, sl);
for i:=0 to sl.Count - 1 do
WriteString(NewName, sl.Names[i], sl.ValueFromIndex[i]);
EraseSection(OldName);
finally
sl.Free;
end;
end;
var
NewName, s: string;
i, p: integer;
begin
if not edConnection.Visible then exit;
NewName:=Trim(edConnection.Text);
if NewName = '' then
NewName:=Trim(edHost.Text);
if NewName <> FCurConn then begin
if FCurConn <> '' then begin
p:=cbConnection.Items.IndexOf(FCurConn);
if p >= 0 then
cbConnection.Items.Delete(p);
end
else
p:=-1;
i:=1;
s:=NewName;
while cbConnection.Items.IndexOf(NewName) >= 0 do begin
Inc(i);
NewName:=Format('%s (%d)', [s, i]);
end;
if FCurConn <> '' then begin
RenameSection('Connection.' + FCurConn, 'Connection.' + NewName);
RenameSection('AddTorrent.' + FCurConn, 'AddTorrent.' + NewName);
end;
if p >= 0 then
cbConnection.Items.Insert(p, NewName)
else
cbConnection.Items.Add(NewName);
if (FCurConn = ActiveConnection) or (FCurConn = '') then
ActiveConnection:=NewName;
FCurConn:=NewName;
SaveConnectionsList;
end;
cbConnection.ItemIndex:=cbConnection.Items.IndexOf(NewName);
cbConnection.Visible:=True;
edConnection.Visible:=False;
end;
procedure TConnOptionsForm.SaveConnectionsList;
var
i: integer;
begin
with Ini do begin
WriteString('Hosts', 'CurHost', ActiveConnection);
WriteInteger('Hosts', 'Count', cbConnection.Items.Count);
for i:=0 to cbConnection.Items.Count - 1 do
WriteString('Hosts', Format('Host%d', [i + 1]), cbConnection.Items[i]);
UpdateFile;
end;
end;
procedure TConnOptionsForm.BeginEdit;
var
i: integer;
begin
i:=cbConnection.ItemIndex;
if i >= 0 then
edConnection.Text:=cbConnection.Items[i]
else
edConnection.Text:='';
edConnection.Visible:=True;
cbConnection.Visible:=False;
end;
procedure TConnOptionsForm.LoadConnSettings(const ConnName: string);
var
Sec, s: string;
begin
with Ini do begin
Sec:='Connection.' + ConnName;
if (ConnName <> '') and not SectionExists(Sec) then
Sec:='Connection';
edHost.Text:=ReadString(Sec, 'Host', '');
FCurHost:=edHost.Text;
edPort.Value:=ReadInteger(Sec, 'Port', 9091);
cbSSL.Checked:=ReadBool(Sec, 'UseSSL', False);
edUserName.Text:=ReadString(Sec, 'UserName', '');
cbAuth.Checked:=edUserName.Text <> '';
if cbAuth.Checked then begin
s:=ReadString(Sec, 'Password', '');
cbAskPassword.Checked:=s = '-';
if not cbAskPassword.Checked then
if s <> '' then
edPassword.Text:='******'
else
edPassword.Text:='';
end;
cbAuthClick(nil);
edRpcPath.Text:=ReadString(Sec, 'RpcPath', DefaultRpcPath);
cbUseProxy.Checked:=ReadBool(Sec, 'UseProxy', False);
cbUseSocks5.Checked:=ReadBool(Sec, 'UseSockProxy', False);
edProxy.Text:=ReadString(Sec, 'ProxyHost', '');
edProxyPort.Value:=ReadInteger(Sec, 'ProxyPort', 8080);
edProxyUserName.Text:=ReadString(Sec, 'ProxyUser', '');
cbProxyAuth.Checked:=edProxyUserName.Text <> '';
if cbProxyAuth.Checked then
if ReadString(Sec, 'ProxyPass', '') <> '' then
edProxyPassword.Text:='******'
else
edProxyPassword.Text:='';
edPaths.Text:=StringReplace(ReadString(Sec, 'PathMap', ''), '|', LineEnding, [rfReplaceAll]);
edDownSpeeds.Text:=ReadString(Sec, 'DownSpeeds', DefSpeeds);
edUpSpeeds.Text:=ReadString(Sec, 'UpSpeeds', DefSpeeds);
cbUseProxyClick(nil);
end;
FCurConn:=ConnName;
FCurHost:=edHost.Text;
end;
procedure TConnOptionsForm.SaveConnSettings(const ConnName: string);
var
Sec: string;
i: integer;
s: string;
begin
if ConnName = '' then
exit;
if ConnName = ActiveConnection then
if IsConnSettingsChanged(ConnName) then
ActiveSettingChanged:=True;
with Ini do begin
Sec:='Connection.' + ConnName;
WriteString(Sec, 'Host', Trim(edHost.Text));
WriteBool(Sec, 'UseSSL', cbSSL.Checked);
WriteInteger(Sec, 'Port', edPort.Value);
if not cbAuth.Checked then begin
edUserName.Text:='';
edPassword.Text:='';
cbAskPassword.Checked:=False;
end;
WriteString(Sec, 'UserName', edUserName.Text);
if cbAskPassword.Checked then
WriteString(Sec, 'Password', '-')
else
if edPassword.Text <> '******' then begin
if edPassword.Text = '' then
s:=''
else
s:=EncodeBase64(edPassword.Text);
WriteString(Sec, 'Password', s);
end;
if (edRpcPath.Text = DefaultRpcPath) or (edRpcPath.Text = '') then
DeleteKey(Sec, 'RpcPath')
else
WriteString(Sec, 'RpcPath', edRpcPath.Text);
WriteBool(Sec, 'UseProxy', cbUseProxy.Checked);
WriteBool(Sec, 'UseSockProxy', cbUseSocks5.Checked);
WriteString(Sec, 'ProxyHost', Trim(edProxy.Text));
WriteInteger(Sec, 'ProxyPort', edProxyPort.Value);
if cbProxyAuth.Checked then begin
edProxyUserName.Text:='';
edProxyPassword.Text:='';
end;
WriteString(Sec, 'ProxyUser', edProxyUserName.Text);
if edProxyPassword.Text <> '******' then begin
if edProxyPassword.Text = '' then
s:=''
else
s:=EncodeBase64(edProxyPassword.Text);
WriteString(Sec, 'ProxyPass', s);
end;
WriteString(Sec, 'PathMap', StringReplace(edPaths.Text, LineEnding, '|', [rfReplaceAll]));
WriteString(Sec, 'DownSpeeds', Trim(edDownSpeeds.Text));
WriteString(Sec, 'UpSpeeds', Trim(edUpSpeeds.Text));
i:=cbConnection.Items.IndexOf(ConnName);
if i < 0 then
cbConnection.Items.Insert(0, ConnName);
UpdateFile;
end;
end;
function TConnOptionsForm.IsConnSettingsChanged(const ConnName: string): boolean;
var
Sec: string;
begin
with Ini do begin
Sec:='Connection.' + ConnName;
if not SectionExists(Sec) then
Sec:='Connection';
Result:=(edPort.Value <> ReadInteger(Sec, 'Port', 9091)) or
(edHost.Text <> ReadString(Sec, 'Host', '')) or
(cbSSL.Checked <> ReadBool(Sec, 'UseSSL', False)) or
(edUserName.Text <> ReadString(Sec, 'UserName', '')) or
((ReadString(Sec, 'Password', '') = '') and (edPassword.Text <> '')) or
((ReadString(Sec, 'Password', '') <> '') and (edPassword.Text <> '******')) or
(edRpcPath.Text <> ReadString(Sec, 'RpcPath', DefaultRpcPath)) or
(cbUseProxy.Checked <> ReadBool(Sec, 'UseProxy', False)) or
(edProxy.Text <> ReadString(Sec, 'ProxyHost', '')) or
(edProxyPort.Value <> ReadInteger(Sec, 'ProxyPort', 8080)) or
(edProxyUserName.Text <> ReadString(Sec, 'ProxyUser', '')) or
((ReadString(Sec, 'ProxyPass', '') = '') and (edProxyPassword.Text <> '')) or
((ReadString(Sec, 'ProxyPass', '') <> '') and (edProxyPassword.Text <> '******')) or
(edPaths.Text <> StringReplace(ReadString(Sec, 'PathMap', ''), '|', LineEnding, [rfReplaceAll])) or
(edDownSpeeds.Text <> ReadString(Sec, 'DownSpeeds', '')) or
(edUpSpeeds.Text <> ReadString(Sec, 'UpSpeeds', ''))
;
end;
end;
initialization
{$I connoptions.lrs}
end.
TransGUI/trcomp.pas 0000644 0000000 0000000 00000000537 11427210747 013233 0 ustar root root { This file was automatically created by Lazarus. do not edit!
This source is only used to compile and install the package.
}
unit trcomp;
interface
uses
VarGrid, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('VarGrid', @VarGrid.Register);
end;
initialization
RegisterPackage('trcomp', @Register);
end.
TransGUI/restranslator.pas 0000644 0000000 0000000 00000055522 12230561601 014625 0 ustar root root {************************************************************
Copyright (c) 2010 Alex Cherednichenko, aka Alex7Che.
Copyright (c) 2011-2013 Yury Sidorov.
Published at GNU General Public License as Free Software.
************************************************************}
unit ResTranslator;
{$MODE objfpc}{$H+}
interface
uses
Classes, StrUtils, SysUtils, FileUtil, LResources, TypInfo, LCLProc;
type
TWordDelimitersOptions = set of (wdIgnoreLeading, wdIgnoreTrailing);
TResTranslator = class;
TTranslateStringEvent = procedure(Sender: TResTranslator; const ResourceName: AnsiString; var Accept: boolean);
TTranslateStringOption = (tsoNew, tsoUsed, tsoExternal);
TTranslateStringOptions = set of TTranslateStringOption;
{ TTranslateStringList }
TTranslateStringList = class(TStringList)
private
function CorrectGetName(Index: integer): string;
function CorrectGetValue(const Name: string): string;
function GetOptions(Index: integer): TTranslateStringOptions;
function NormaliseQuotedStr(const S: string): string;
function ScanQuotSep(P: PChar):integer;
procedure SetOptions(Index: integer; const AValue: TTranslateStringOptions);
protected
function DoCompareText(const s1,s2 : string) : PtrInt; override;
public
constructor Create(const FileName: string); overload;
function IndexOfName(const Name: string; var Offset: integer): integer;
function IndexOfName(const Name: string): integer; override;
procedure LoadFromFile(const FileName: string); override;
procedure SaveToFile(const FileName: string); override;
procedure Merge(Source: TTranslateStringList; const NamesOnly: boolean = false);
property CValues[const Name: string]: string read CorrectGetValue;
property CNames[Index: integer]: string read CorrectGetName;
property Options[Index: integer]: TTranslateStringOptions read GetOptions write SetOptions;
end;
{ TResTranslator }
TResTranslator = class(TAbstractTranslator)
private
FIgnoreDelimiters: TWordDelimitersOptions;
FOnTranslateString: TTranslateStringEvent;
FStrResLst: TTranslateStringList;
FTranslationFile: string;
FModified: boolean;
FTranslationLanguage: AnsiString;
FWordDelims: TSysCharset;
function GetStrings: TStringList;
procedure SetIgnoreDelimiters(const AValue: TWordDelimitersOptions);
procedure SetOnTranslateString(const AValue: TTranslateStringEvent);
procedure SetWordDelims(const AValue: TSysCharset);
function InternalTranslateString(const Value: AnsiString; IsExternal: boolean = False): AnsiString;
public
constructor Create(TranslationFile: AnsiString);
destructor Destroy; override;
procedure TranslateStringProperty(Sender: TObject; const Instance: TPersistent; PropInfo: PPropInfo; var Content: string); override;
procedure SaveFile; overload;
procedure SaveFile(const aFileName: string); overload;
property Modified: boolean Read FModified;
property Strings: TStringList Read GetStrings;
property IgnoreDelimiters: TWordDelimitersOptions Read FIgnoreDelimiters Write SetIgnoreDelimiters;
property WordDelims: TSysCharset Read FWordDelims Write SetWordDelims;
property TranslationLanguage: AnsiString read FTranslationLanguage;
property OnTranslateString: TTranslateStringEvent Read FOnTranslateString Write SetOnTranslateString;
end;
function LoadTranslationFile(const TranslationFile: AnsiString; const OnTranslate: TTranslateStringEvent = nil): AnsiString;
procedure SaveTranslationFile; overload;
procedure SaveTranslationFile(const FileName: AnsiString); overload;
procedure MakeTranslationFile; overload;
procedure MakeTranslationFile(Language: AnsiString); overload;
procedure MakeTranslationFile(const FileName, Language: AnsiString); overload;
procedure SupplementTranslationFile(const FileName: AnsiString);
procedure SupplementTranslationFiles; overload;
procedure SupplementTranslationFiles(const TranslationFilesPath: AnsiString); overload;
function LoadDefaultTranslationFile(const OnTranslate: TTranslateStringEvent = nil): TFileName;
function LoadDefaultTranslationFile(const TranslationFilesPath: AnsiString; const OnTranslate: TTranslateStringEvent = nil): TFileName;
function LoadLanguageTranslation(const Language: AnsiString; const OnTranslate: TTranslateStringEvent = nil): TFileName;
function LoadLanguageTranslation(const Language, TranslationFilesPath: AnsiString; const OnTranslate: TTranslateStringEvent = nil): TFileName;
function TranslateString(const Value: AnsiString; IsExternal: boolean = False): AnsiString;
function ExtractLangName(const FileName: TFilename): AnsiString;
function GetAvailableTranslations: TStringList;
function GetAvailableTranslations(const SearchPath: AnsiString): TStringList;
function GetTranslationFileName(const Language: AnsiString; AvailableTranslations: TStringList): AnsiString;
function DefaultLangDir: AnsiString;
function IsTranslationFileValid(const TranslationFile: AnsiString): boolean;
const
sLanguageIDName = 'TranslationLanguage';
implementation
uses
Forms, utils;
const
LineSeparator = '###################';
{ procedures and functions }
function IsQuoted(const S: AnsiString; QuoteChar: char): boolean; inline;
var
L: integer;
begin
L:= Length(S);
if L > 1 then
Result := (S[1] = QuoteChar) and (S[L] = QuoteChar)
else
Result := false;
end;
function HasSeparator(const S: AnsiString; Separator: char): boolean; inline;
begin
Result := Pos(Separator, S) > 0;
end;
function ExtractLangName(const FileName: TFilename): AnsiString;
begin
with TTranslateStringList.Create(FileName) do
try
Result := AnsiDequotedStr(CValues[sLanguageIDName], QuoteChar);
finally
Free;
end;
end;
function GetAvailableTranslations: TStringList;
begin
Result:= GetAvailableTranslations(DefaultLangDir);
end;
function GetAvailableTranslations(const SearchPath: AnsiString): TStringList;
var
Sr: TSearchRec;
LangName, s: AnsiString;
begin
Result:= TStringList.Create;
if FindFirstUTF8(IncludeTrailingPathDelimiter(SearchPath) + '*', faArchive or faReadOnly, Sr) = 0 then
with Result do begin
NameValueSeparator:= '=';
QuoteChar:= '"';
repeat
if ExtractFileExt(Sr.Name) = '.template' then
continue;
s:=IncludeTrailingPathDelimiter(ExtractFilePath(SearchPath)) + Sr.Name;
if IsTranslationFileValid(s) then begin
LangName:= ExtractLangName(s);
if LangName <> '' then
Add(LangName + NameValueSeparator + Sr.Name);
end;
until FindNextUTF8(Sr) <> 0;
FindClose(Sr);
end;
end;
var
FDefaultLangDir: AnsiString;
function DefaultLangDir: AnsiString;
{$ifdef unix}
function _IsLangDir(const dir: string): boolean;
var
sr: TSearchRec;
begin
Result:=FindFirstUtf8(dir + ExtractFileNameOnly(ParamStrUtf8(0)) + '.*', faAnyFile, sr) = 0;
FindClose(sr);
end;
var
s: string;
{$endif unix}
begin
if FDefaultLangDir = '' then begin
FDefaultLangDir:=ExtractFilePath(ParamStrUtf8(0)) + 'lang' + DirectorySeparator;
{$ifdef unix}
if not _IsLangDir(FDefaultLangDir) then begin
s:='/usr/share/' + ExtractFileNameOnly(ParamStrUtf8(0)) + '/lang/';
if _IsLangDir(s) then
FDefaultLangDir:=s
else begin
s:='/usr/local/share/' + ExtractFileNameOnly(ParamStrUtf8(0)) + '/lang/';
if _IsLangDir(s) then
FDefaultLangDir:=s;
end;
end;
{$endif unix}
end;
Result:=FDefaultLangDir;
end;
function GetResStrings(Name, Value: AnsiString; Hash: longint; P: pointer): AnsiString;
var
Accept: boolean;
begin
with TResTranslator(P) do begin
Accept := True;
if Assigned(OnTranslateString) then
OnTranslateString(TResTranslator(P), Name, Accept);
if Accept then
Result := InternalTranslateString(Value)
else
Result := Value;
end;
end;
function LoadTranslationFile(const TranslationFile: AnsiString; const OnTranslate: TTranslateStringEvent = nil): AnsiString;
begin
LRSTranslator := TResTranslator.Create(TranslationFile);
TResTranslator(LRSTranslator).OnTranslateString := OnTranslate;
SetResourceStrings(@GetResStrings, LRSTranslator);
Result := TResTranslator(LRSTranslator).TranslationLanguage;
end;
procedure SupplementTranslationFiles; overload;
begin
SupplementTranslationFiles(DefaultLangDir);
end;
procedure MakeTranslationFile; overload;
begin
MakeTranslationFile('???');
end;
procedure MakeTranslationFile(Language: AnsiString); overload;
var
lLang, sLang, s: string;
begin
LCLGetLanguageIDs(lLang, sLang);
sLang:=AnsiLowerCase(sLang);
s:=ExtractFileNameOnly(ParamStrUtf8(0));
if (sLang <> '') and not FileExistsUTF8(DefaultLangDir + s + '.' + sLang) then
s:=s + '.' + sLang
else
s:=s + '.lng';
MakeTranslationFile(DefaultLangDir + s, Language);
end;
procedure MakeTranslationFile(const FileName, Language: AnsiString);
var
Dst: TTranslateStringList;
begin
if Assigned(LRSTranslator) and (LRSTranslator is TResTranslator) then begin
Dst := TTranslateStringList.Create;
try
Dst.Values[sLanguageIDName]:= Language;
with LRSTranslator as TResTranslator do
Dst.Merge(Strings as TTranslateStringList, true);
ForceDirectories(ExtractFilePath(FileName));
Dst.SaveToFile(FileName);
finally
Dst.Free;
end;
end;
end;
procedure SupplementTranslationFile(const FileName: AnsiString);
var
Dst: TTranslateStringList;
begin
if Assigned(LRSTranslator) and (LRSTranslator is TResTranslator) then begin
Dst := TTranslateStringList.Create(FileName);
try
with LRSTranslator as TResTranslator do
Dst.Merge(Strings as TTranslateStringList, true);
Dst.SaveToFile(FileName);
finally
Dst.Free;
end;
end;
end;
procedure SupplementTranslationFiles(const TranslationFilesPath: AnsiString);
var
Sl: TStringList;
i: integer;
s: string;
begin
if Assigned(LRSTranslator) and (LRSTranslator is TResTranslator) then begin
Sl := GetAvailableTranslations(TranslationFilesPath);
with Sl do
for i := 0 to Count - 1 do
SupplementTranslationFile(IncludeTrailingPathDelimiter(TranslationFilesPath) + ValueFromIndex[i]);
// Supplement template file
s:=IncludeTrailingPathDelimiter(TranslationFilesPath) + ExtractFileNameOnly(ParamStrUtf8(0)) + '.template';
if FileExistsUTF8(s) then
SupplementTranslationFile(s);
end;
end;
const
InvalidLangExt: array[1..6] of string = ('ua', 'by', 'cn', 'cz', 'se', 'tw');
function IsTranslationFileValid(const TranslationFile: AnsiString): boolean;
var
s: string;
i: integer;
begin
Result:=FileExistsUTF8(TranslationFile);
if not Result then
exit;
s:=LowerCase(ExtractFileExt(TranslationFile));
Delete(s, 1, 1);
for i:=Low(InvalidLangExt) to High(InvalidLangExt) do
if s = InvalidLangExt[i] then begin
Result:=False;
exit;
end;
end;
function LoadDefaultTranslationFile(const OnTranslate: TTranslateStringEvent): TFileName;
begin
Result := LoadDefaultTranslationFile(DefaultLangDir, OnTranslate);
end;
function LoadDefaultTranslationFile(const TranslationFilesPath: AnsiString; const OnTranslate: TTranslateStringEvent): TFileName;
var
lLang, sLang, s: string;
i: integer;
begin
LCLGetLanguageIDs(lLang, sLang);
lLang:=LowerCase(lLang);
sLang:=LowerCase(sLang);
{$ifdef windows}
if sLang = 'ch' then begin
sLang:='zh';
lLang:=StringReplace(lLang, 'ch_', 'zh_', []);
end;
{$endif windows}
i:=Pos('.', lLang);
if i > 0 then
SetLength(lLang, i - 1);
s:=IncludeTrailingPathDelimiter(TranslationFilesPath) + ExtractFileNameOnly(ParamStrUtf8(0))+ '.';
Result := s + lLang;
// First check full language name (uk_ua)
if not IsTranslationFileValid(Result) then begin
Result := s + sLang;
// Check fallback language name (uk)
if not IsTranslationFileValid(Result) then begin
// Finally use country name (ua)
i:=Pos('_', lLang);
if i > 0 then
lLang:=Copy(lLang, i + 1, MaxInt);
Result := s + lLang;
if not IsTranslationFileValid(Result) then begin
Result:='';
exit;
end;
end;
end;
Result := LoadTranslationFile(Result, OnTranslate);
end;
function LoadLanguageTranslation(const Language: AnsiString; const OnTranslate: TTranslateStringEvent): TFileName;
begin
Result := LoadLanguageTranslation(Language, DefaultLangDir, OnTranslate);
end;
function LoadLanguageTranslation(const Language, TranslationFilesPath: AnsiString; const OnTranslate: TTranslateStringEvent): TFileName;
var
Sl: TStringList;
begin
Sl:= GetAvailableTranslations(TranslationFilesPath);
Result:= GetTranslationFileName(Language, Sl);
if Result <> '' then
Result := IncludeTrailingPathDelimiter(TranslationFilesPath) + Result;
if FileExistsUTF8(Result) then
LoadTranslationFile(Result, OnTranslate);
end;
function GetTranslationFileName(const Language: AnsiString; AvailableTranslations: TStringList): AnsiString;
var
i: integer;
aName, aValue: string;
begin
Result := '';
if Assigned(AvailableTranslations) then
with AvailableTranslations do
for i := 0 to Count - 1 do begin
GetNameValue(i, aName, aValue);
if AnsiSameText(AnsiDequotedStr(Language, QuoteChar), AnsiDequotedStr(aName, QuoteChar)) then begin
Result:= AnsiDequotedStr(aValue, QuoteChar);
Break;
end;
end;
end;
procedure SaveTranslationFile; overload;
begin
if Assigned(LRSTranslator) and (LRSTranslator is TResTranslator) then
with LRSTranslator as TResTranslator do
if Modified then
SaveFile;
end;
procedure SaveTranslationFile(const FileName: AnsiString); overload;
begin
if Assigned(LRSTranslator) and (LRSTranslator is TResTranslator) then
with LRSTranslator as TResTranslator do
if Modified then
SaveFile(FileName);
end;
function TranslateString(const Value: AnsiString; IsExternal: boolean): AnsiString;
begin
if Assigned(LRSTranslator) and (LRSTranslator is TResTranslator) then
with LRSTranslator as TResTranslator do
result := InternalTranslateString(Value, IsExternal)
else
result := Value;
end;
{ TTranslateStringList }
function TTranslateStringList.CorrectGetValue(const Name: string): string;
var
Index: integer;
offset: integer;
begin
Index := IndexOfName(Name, offset);
if Index >= 0 then begin
Result := Copy(Strings[Index], offset, MaxInt);
Options[Index]:=Options[Index] + [tsoUsed];
end
else
result := '';
end;
function TTranslateStringList.GetOptions(Index: integer): TTranslateStringOptions;
begin
Result:=TTranslateStringOptions(cardinal(ptruint(Objects[Index])));
end;
function TTranslateStringList.CorrectGetName(Index: integer): string;
var
Offset: integer;
s: string;
begin
CheckSpecialChars;
Result := '';
s := Strings[Index];
Offset := ScanQuotSep(PChar(s));
if (Offset > 0) then
Result := NormaliseQuotedStr(LeftStr(s, offset));
end;
function TTranslateStringList.ScanQuotSep(P: PChar): integer;
var
i, len: integer;
QuoteCount: integer;
begin
result := 0;
QuoteCount := 0;
i := 0;
len:=strlen(P);
while (i < len) and (result = 0) do begin
if P[i] = QuoteChar then
inc(QuoteCount)
else if (P[i] = NameValueSeparator) and not odd(QuoteCount) then
result := i;
inc(i);
end;
end;
procedure TTranslateStringList.SetOptions(Index: integer; const AValue: TTranslateStringOptions);
begin
Objects[Index]:=TObject(ptruint(cardinal(AValue)));
end;
function TTranslateStringList.DoCompareText(const s1, s2: string): PtrInt;
begin
if CaseSensitive then
result:=AnsiCompareText(s1,s2)
else
result:=AnsiCompareText(UTF8UpperCase(s1),UTF8UpperCase(s2));
end;
constructor TTranslateStringList.Create(const FileName: string);
begin
inherited Create;
CheckSpecialChars;
LoadFromFile(FileName);
end;
function TTranslateStringList.NormaliseQuotedStr(const S: string): string;
begin
if not HasSeparator(S, NameValueSeparator) then
Result := AnsiDequotedStr(S, QuoteChar)
else if not IsQuoted(S, QuoteChar) then
Result := AnsiQuotedStr(S, QuoteChar)
else
Result := S;
end;
function TTranslateStringList.IndexOfName(const Name: string; var Offset: integer): integer;
var
s, n: string;
begin
CheckSpecialChars;
result := 0;
n:=NormaliseQuotedStr(Name);
while (result < Count) do begin
s:=Strings[result];
Offset := ScanQuotSep(PChar(s));
if (Offset > 0) and (n = Copy(s, 1, Offset)) then begin
inc(Offset, 2);
exit;
end;
inc(result);
end;
result := -1;
end;
function TTranslateStringList.IndexOfName(const Name: string): integer;
var
i: integer;
begin
Result:=IndexOfName(Name, i);
end;
procedure TTranslateStringList.LoadFromFile(const FileName: string);
var
FS: TFileStreamUTF8;
buff: array[1..3] of char;
i, j, k: integer;
s, esep: string;
begin
FS:= TFileStreamUTF8.Create(FileName, fmOpenRead);
try
// Skip UTF8 header
buff := '';
FS.Read(buff, SizeOf(UTF8FileHeader));
if buff <> UTF8FileHeader then
FS.Position:=0;
LoadFromStream(FS);
finally
FS.Free;
end;
i:=IndexOf(LineSeparator);
if i >= 0 then
Delete(i);
// Normalize quotations
esep:=NameValueSeparator + NameValueSeparator;
for i:=0 to Count - 1 do begin
s:=Strings[i];
j:=ScanQuotSep(PChar(s));
if j > 0 then begin
k:=j + 2;
if Copy(s, j + 1, 2) = esep then begin
Options[i]:=[tsoExternal];
Inc(k);
end;
Strings[i]:=NormaliseQuotedStr(Copy(s, 1, j)) + NameValueSeparator + NormaliseQuotedStr(Copy(s, k, MaxInt));
end;
end;
end;
procedure TTranslateStringList.SaveToFile(const FileName: string);
var
FS: TFileStreamUTF8;
i, j: integer;
s, esep: string;
begin
ForceDirectories(ExtractFilePath(FileName));
FS := TFileStreamUTF8.Create(FileName, fmCreate);
try
FS.WriteBuffer(UTF8FileHeader, SizeOf(UTF8FileHeader));
esep:=NameValueSeparator + NameValueSeparator;
for i:=0 to Count - 1 do begin
s:=Strings[i];
if tsoExternal in Options[i] then begin
j:=ScanQuotSep(PChar(s));
if j > 0 then
s:=NormaliseQuotedStr(Copy(s, 1, j)) + esep + NormaliseQuotedStr(Copy(s, j + 2, MaxInt));
end;
if s <> '' then
FS.WriteBuffer(s[1], Length(s));
s:=LineEnding;
FS.WriteBuffer(s[1], Length(s));
end;
finally
FS.Free;
end;
end;
procedure TTranslateStringList.Merge(Source: TTranslateStringList; const NamesOnly: boolean = false);
var
i, j: integer;
n: string;
begin
CheckSpecialChars;
Source.Sort;
for i:=0 to Count - 1 do
Options[i]:=[];
for i:=0 to Source.Count - 1 do begin
if Source.Options[i]*[tsoUsed, tsoExternal] = [] then
continue;
n:=Source.CNames[i];
if n <> '' then begin
j:=IndexOfName(n);
if j < 0 then begin
// New string
if NamesOnly then
j:=Add(n + NameValueSeparator + n)
else
j:=Add(Source.Strings[i]);
end;
Options[j]:=Source.Options[i] + [tsoUsed];
end;
end;
// Delete unused strings
i:=0;
while i < Count do begin
n:=CNames[i];
if (Options[i] = []) and (n <> '') and (CompareText(n, sLanguageIDName) <> 0) then
Delete(i)
else
Inc(i);
end;
end;
{ TResTranslator }
constructor TResTranslator.Create(TranslationFile: AnsiString);
begin
inherited Create;
FTranslationFile := TranslationFile;
FIgnoreDelimiters := [wdIgnoreTrailing];
FWordDelims := ['.', ',', ':'];
FStrResLst := TTranslateStringList.Create;
with FStrResLst do begin
Duplicates := dupIgnore;
CaseSensitive := False;
CheckSpecialChars;
if FileExistsUTF8(FTranslationFile) then begin
LoadFromFile(FTranslationFile);
FTranslationLanguage := AnsiDequotedStr(CValues[AnsiQuotedStr(sLanguageIDName, QuoteChar)], QuoteChar);
end;
end;
end;
destructor TResTranslator.Destroy;
begin
FStrResLst.Free;
inherited Destroy;
end;
function TResTranslator.InternalTranslateString(const Value: AnsiString; IsExternal: boolean): AnsiString;
function IsAlpha(Ch: char): boolean; inline;
begin
Result := Ch in ['A'..'Z', 'a'..'z'];
end;
function HasAlpha: boolean;
var
i: integer;
begin
Result := False;
i := 1;
while not Result and (i <= Length(Value)) do begin
Result := IsAlpha(Value[i]);
Inc(i);
end;
end;
var
ClearValue: AnsiString;
Original, s, n: AnsiString;
i: integer;
begin
Original := Value;
ClearValue := StringReplace(AdjustLineBreaks(Value), LineEnding, '~', [rfReplaceAll]);
Result := ClearValue;
if wdIgnoreLeading in IgnoreDelimiters then
RemoveLeadingChars(ClearValue, FWordDelims);
if wdIgnoreTrailing in IgnoreDelimiters then
RemoveTrailingChars(ClearValue, FWordDelims);
if HasAlpha then
begin
with FStrResLst do begin
if HasSeparator(ClearValue, NameValueSeparator) then
n := AnsiQuotedStr(ClearValue, QuoteChar)
else
n := ClearValue;
s:=CValues[n];
if (s = '') then begin
i:=Add(n + NameValueSeparator + n);
Options[i]:=[tsoNew, tsoUsed];
FModified := True;
Result := Original;
end
else begin
Result := StringReplace(Result, ClearValue, AnsiDequotedStr(s, QuoteChar), [rfReplaceAll]);
Result := StringReplace(Result, '~', LineEnding, [rfReplaceAll]);
end;
if IsExternal then begin
i:=IndexOfName(n);
if i >= 0 then
Options[i]:=Options[i] + [tsoExternal];
end;
end;
end;
end;
procedure TResTranslator.SetIgnoreDelimiters(const AValue: TWordDelimitersOptions);
begin
if FIgnoreDelimiters = AValue then
exit;
FIgnoreDelimiters := AValue;
end;
function TResTranslator.GetStrings: TStringList;
begin
Result := FStrResLst;
end;
procedure TResTranslator.SetOnTranslateString(const AValue: TTranslateStringEvent);
begin
if FOnTranslateString = AValue then
exit;
FOnTranslateString := AValue;
end;
procedure TResTranslator.SetWordDelims(const AValue: TSysCharset);
begin
if FWordDelims = AValue then
exit;
FWordDelims := AValue;
end;
procedure TResTranslator.TranslateStringProperty(Sender: TObject; const Instance: TPersistent; PropInfo: PPropInfo; var Content: string);
var
Accept: boolean;
ResourceName: AnsiString;
OwnerName: AnsiString;
begin
if Sender is TReader and Assigned(TReader(Sender).Owner) then
OwnerName := TReader(Sender).Owner.GetNamePath;
if Instance.InheritsFrom(TForm) then
ResourceName := OwnerName + '.' + PropInfo^.Name
else
ResourceName := OwnerName + '.' + Instance.GetNamePath + '.' + PropInfo^.Name;
Accept := True;
if Assigned(OnTranslateString) then
OnTranslateString(Self, ResourceName, Accept);
if (PropInfo^.Name = 'Caption') and (Instance.GetNamePath = Content) then
Accept:=False
else
if PropInfo^.Name = 'Name' then
Accept:=False;
if Accept then
Content := InternalTranslateString(Content);
end;
procedure TResTranslator.SaveFile;
begin
SaveTranslationFile(FTranslationFile);
end;
procedure TResTranslator.SaveFile(const aFileName: string);
begin
FStrResLst.SaveToFile(aFileName);
end;
finalization
FreeAndNil(LRSTranslator);
end.
TransGUI/baseform.lfm 0000644 0000000 0000000 00000000157 12256577645 013534 0 ustar root root object BaseForm: TBaseForm
Left = 234
Height = 240
Top = 132
Width = 320
LCLVersion = '1.0.15.0'
end
TransGUI/about.lfm 0000644 0000000 0000000 00000164644 12261763702 013047 0 ustar root root inherited AboutForm: TAboutForm
Left = 421
Height = 349
Top = 188
Width = 451
HorzScrollBar.Page = 423
VertScrollBar.Page = 316
AutoSize = True
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
BorderWidth = 8
Caption = 'About'
ClientHeight = 349
ClientWidth = 451
Constraints.MinHeight = 330
Constraints.MinWidth = 350
OnCreate = FormCreate
Position = poMainFormCenter
object Page: TPageControl[0]
Left = 8
Height = 299
Top = 8
Width = 435
ActivePage = tabAbout
Align = alClient
TabIndex = 0
TabOrder = 0
object tabAbout: TTabSheet
Caption = 'About'
ClientHeight = 273
ClientWidth = 427
object imgTransmission: TImage
Left = 10
Height = 48
Top = 14
Width = 48
AutoSize = True
Picture.Data = {
1754506F727461626C654E6574776F726B477261706869637D0B000089504E47
0D0A1A0A0000000D49484452000000300000003008060000005702F987000000
0473424954080808087C086488000000097048597300000DD700000DD7014228
9B780000001974455874536F667477617265007777772E696E6B73636170652E
6F72679BEE3C1A00000AFA494441546881D599EB6F5CC775C07F6766F6FD2497
942891122D8512E9C88AAD872D288E51C44E1CA44DBE0432ADA04D931645D104
4180C4823F150554D4FDE0A62860C429907FA0962A1445BE2406DAD46E6238AA
CBC4B2AA476C29922D4B862C71C97D2FF73E4E3FEC92E26B9794642BC80148DE
CB7BE7CCF9CD9C39E7CC5C51557E9FC5FCAE0DB85BF9BD07701FB5C2EF7FFFF9
3FC384CF01A9C5FF57A421C8DF1FF9DEB32F7C94FDC97AD6C08B2207813FB4F0
30F0C900362BD895DA84C67347D9F3C823E4725910E958AF54AA55A67E7992F8
DFFC2DE2792B9B42E0E00381F31E4C05F0F27754FFEBAE01FE59E4B9F4D6ADDF
DBF5F8E3B1DCD6AD1211E93A6D01702C1DE3F057FF18CF6B31AF5B448844A2FC
DBBF1EE38F4A75125DFAF4014F95F2D5ABFA9B575E69CC5CBCF82FDF54FD8B5E
F6ADE942013CFBE4638F39999AC23F760C82A08736871CFD6B32E92CBEEF2D7B
E43061082FBC00D56A57639CB5A4474765CBA38F264F5CBAF4273F1279E62F55
4B770C00B8607696DAE9D36BBE188461E7AF8F1FF84B9E891114A5EE7984AD56
6F45E7CF931C19C14622A137379700EE0A20BC78F1A2F1F379FC52097AB85C08
28100401BEBF14C0884115AE00915EBD896053296257AFD26AB56C0B7AD2AE09
60E047672F5CF85A261E4FB96C1647F7D8ABAEAD2EF00382650081B1A8088D6C
9696595D83021EE00701B50B176AA2FA1FDF552DDE15C0B754BFF903919FCC54
AB87041E0C61BB408CF680AF06100BC260850BD9D0A1AA7C502EB7A45259318D
0A46C013B824703A807FFFB6EAB1B5EC5B571EF8B6EA8F811FCFDFFF5024DD5A
A5AD373E1E1323578320B0CB5DC8B9002291E6DC17BFF8A03D7EFCC3E56D5B10
3CAB5A598F3DB70DB05CBEA5BA6A18397AF4683C85ACBA0682C047510DF7EF2F
3F73ECD8EC9DF4BB9A7CE499183A8B38580E10B49DFC23968F09C05F31037EAF
FC7117F2F1CDC00A17FA1D004C1E3E6480AF1963BEA3AA636B291311F6EDDB6B
BB018461903875FAD4DB4F7FF5A99ECE24224D557D5E555F3CFED289E61D0300
4FC762B11747464652996C16992FCED680F0431F3F585A4A04818F18C3AE071E
C82C5F0C8BD5AA42B3D1C85E79FFFDA3B56AEDC8E4E14363C75F3A51BB230063
CCF3DBB76D4F45A211EAF51A61B822F4AF90BE7CBEAB0B69A8D4AA5542EDAE47
4448C4E34C4C4CA4DE7EFB6DA9942BDF05FEEEB601260F1FEA8B44221B53E914
33B333A82AA5D912E57209CFF3576D2322ECDFBF8F300857F87C1006A82A972E
5DC25BA59C06C8A4D3A4D269C2304415B66CD9923C7BE6EC913B0200B6259289
A61FF8118072B94C241AE1C92F7C1E63572F059A8D2633C5AE751761A87CFAD1
83EDBDC28A6721B3A559DE383985751611A150282022C9C9C387FA8FBF7462D5
92A217C0F644228948BB142E972A3CF5F457E8EBCB776D70E1E2657A2D1311B0
36CAD6D12D5DDE1825E2229C7AF334E9741A630CF178BC51AFD77702BFBC6D80
54229900692FCCC0636464B8E7429E9D29F750D79672B5423A9DEEFA7CD3A621
A6DEF835D6B6377CA954CAD6EBF51DB70D608CF964329572460C61A82493A935
A3D0952B57C8673354AA55664BB75C4915442CF5468399D2EA9B9979E92FF4D3
683670D62108E9743A71F3E6CD896EEFF7029848A552F881471004E47259CC7C
19ACF381F056385485F7DEBF861D1DA154AE303D3DB3B4231BA15E6B70E3C39B
3D01DAB3A36DCDA2A4D36963ACD973DB0022725F2291A05A0BF0FD807C5F1E67
DD32B359D8E02850AFD6A9D6EA944B158ACB0062D138956A8D7ABDDE732050C8
E573789E87AA2193C902327E5B0093870F99783C5E8846A3B8A625F03D060706
702E72ABC3257D2AD54A95582C42BD56A7542E335D9CE9F0B55F4C2653546B35
C418023F24168B761D88814201AFD5C208A4D319C22018EE06D06D7335128BC5
3D630CD639020DE9EFEFC73A87B30E672338E770CE75FE17617A7A864C264DA9
5C69CFC0CC2C37A78B4C176798992D51AE5429976B64D249664B25ACEBE8B09D
1F1769EB728EA14D9B68B53C10211E8FE39C0B270F1FDABCEE1900B6A752294F
4412CE5A3CCFA3D05F5870A15B83766B0C67674B583154AA352EBFFB1E85FE81
794F46102EBF778552A542A190A754AEB275ABEBCCE232275265707090F3E7CE
E33A912893C978C5627127706DBD00DB72B9AC13C05ACB5CA349A1E342F3EEB3
68F902509C2EA21A6080D367CE608C69472D6D838661482A9940439F6AA5B264
3074994B0E6D1CA2D198C35A8B00F97C9F2B168B3B8057D605202263996C2E81
08C65AEAF53A8383838B3AD54523D6FE552AB737599F7A601CEB1CCB03AE02BE
E7512A9529CD968844220B80A12ABAA83EDAB871884AA58C750E15C8E7F30963
CCAED56C5D15C039B72B9BC988088441403C16271E8B2F3166A06F70219AF881
8FD7F2A8D56AB49A73744DC7AA8815E69A0D86068717DA8761C8F59B1F201DDD
A9B4239948E2792D0C2972B9AC586B1F5C37803166473A93C6F77D5A2D8F7C5F
DF82FBA8B63B7CF5E7AF3035F5064110748E0E1D20A433DDB32CC0CCEC2CBE1F
F08FFFF40F80128D46D9B3670F1313F7638C5998DB810D051A8D26B99C92CFF7
01EC583780B5764B221EA7D168D06A35290C166EC5EEF673F6EEDDCBD8D8182F
BFFC53AE5DBBC6FFFEEA4D6AB53A73ADD52BCD7969369BFCE69D0B4CEC1C636C
6C07070F1E241E6FCFEEA235CDE64D2354AB158C08B96C16DFF7374E1E3E648F
BF74624999BB0260F2F0A16426934944A3315A2D8F66738E8D1B36AE6A4C369B
E5A9A726397FEE1C89449C772E5EE2DCF977BAEE1B360C16F883471E65686888
271E7F82FE42A12BE8F0F0664E9D3A853116E7222493C9B95AAD360AFCB62700
B02D9BCB3545246D9DA5E5791406BA77043071FFFD6C1D1DE5673FFB4FB68C0C
F3DAEB6F7073FA56F59B49A738F0F05E86360CF0D9CF3EC17DDBB6F5D407B071
6813F5D75FC73A0B06FAFBFA835AADB6633D00DBF3B99C1A6370D631D798A3D0
DF1B0020994CF2A52F7D99772F5F26994870F1D265DE3C759607768DF389EDA3
3CBCFF111E7AE8A1852A732D19DAB88172A5DC2EEA5418181C885D79FFCA4EE0
E5B500B6F5F7F74755156B2D2DBF85ACB35380D1FBEEE34FBFFE75FEFBD55719
DD32CCF6ED9FE0339F798C6432B96E1D00896412AFE5B5810506060662CEB9DD
CBDF5B524A8888B1D6EEEACBF7C58C3138E7D834B489D75EFB05737373EBEE3C
1A89F2B9CF7D9E6F7CE3CF79F2C92FDCB6F1AACAFF9C3CC9E0E0065CE7C0B82F
DF8FB5F6415956D32FCC8088C8EEDDBB73C6D8BDF32710D65AC6C77772F2E449
8E1C7986443C8112A22AA08A8AB2907F3AF7289D0D407B0BB958C23044DA4D3B
D7C2F22F44F3597B707003FBF73FDCCEC662C8F7F51184E1D8D881031911A968
A7E102C0AE5DBB22128B0DAB865BC25029168B0BCA77EFFE14E3E313EDE34215
44B49DAC165F03CC5F7632EC7CA69D4FCB8BEF975FCF7348E77E3E6C4F4F4F63
AD259BCD12F87E3E1B8B8EECDBB7EF1DDA27F1B700B2D9ACAD05415F1886914A
A5CCCC4C1B60E7CE7152C9251F1CEF99349B4DCE9D3F8BB36EE17B4324D4C2F5
4CE6B72B000054D5A82AE55289EB1F5E4755B9FEE1F57B6FF93271CEB53F51A9
12FABEC3DD327BB5FD40D8F25A44A3B17B67E11AD26B2FBE02C0F383B76EDCBC
A1F97C7EDD31FBE31411219D4E53ABB54F17435D9AE617E622168B693D0C8372
A5FAD3772FBFFBE94422111FDE3CBC224ADC7311A1D59AE3C2850BA8EA294FCC
92C3DE05801B376E84D174BA7863A634158D447E70E6FFCEFC95B53662BA7C90
BB57A2AAF8BE6F55F5F27471F68746B558A854160A3A59F4355DC60E1CC8E49D
DB14FA7E9F15494463D1DEB5F13D923008BC7A1016250C67C246E3DA5B6FBD55
9FCF03FF0F6EF4D8137C7F96BD0000000049454E44AE426082
}
end
object imgSynapse: TImage
Cursor = crHandPoint
Left = 124
Height = 42
Top = 215
Width = 102
Anchors = [akLeft, akBottom]
AutoSize = True
OnClick = imgSynapseClick
Picture.Data = {
1754506F727461626C654E6574776F726B477261706869633E10000089504E47
0D0A1A0A0000000D49484452000000660000002A0803000000769BDE47000003
00504C5445B0191AB73639BE181EB51F29D058609A6366F8E7E8D16770DA7E85
C7787FFAEDEEBA2233BE3849DA8994F8E8EAC02840CE495EDB7182D1717FD47E
8CE29BA6E5A3ADF3D9DDF4DBDFF8DFE3B91C38CF204082172B5B101DAA1F3972
1626D12B4951141FD53C58AC3148C13850C14A6059232DE08D9BE8B4BDEFC7CE
F1CDD3F1D0D6BE2040812336581824CB5269D15870803E4BD2677CE1758BCF6C
80D57386D87689D9798CD07486DE92A2E6A8B5ECBCC5EDC3CBF2D3D9F6DDE2F4
DCE1F6E2E6F7E4E8CF284FC0304F43121D662131842D41AB3C55CE5F78D76B82
DA8095EFC8D1F5DFE4C018405B1224C0284FAB2446581D2CC0405ECB5674F3D6
DDF6DAE1F8E0E6811835C73E63D5758EAB1C46C0204FC32A57D5BFC6E1D1D6DC
CAD0560B2B580C423A2C378F38809A4C8CDED6DE5B0E5D8F5790AA82AC98679D
B692BBC3B3C5652A6F5D0F726F2F807C418B7D438C7E448D814990844D938650
94885396A177ACB08CB9C0A4C7DBCBDFE4D8E7EEE6F04A2056733A837F478F88
54978D5B9BAA83B6BA9AC4CCB5D3D8C7DDE2D4E6E9DFECE7DDEA2D093A996AA9
C6ABCFD5C1DCD1BDD8DCCBE2DFD0E4E8DCECEBE2EEF3EDF5560E715F107F5F10
7D400B556F278C732D8F7936938041998E56A4D9C6E0671C866F288C83469C87
4C9FE6DAEBE3D6E99C93B77A6F9E6059933D3975403F8F2B2A6053529AACADCC
8285B7F4F5F9BCC4DE6C7FB33F5B9F8B9CC53A548D4D54606C8BB64F77A76392
C21F69AE387EB7244D708BB4D774AAD2C1D8EA1F7EBE4698CF5EA0D09BC3DF84
BBDFCFE3F0185A8006415E108FCF1F95CF2899D247AADB53B0DF67B6DF92CFED
AAD6ECD6ECF7EAF6FC0F90CF0F8EC934A3D9297496BBE1F20087C107648C0C82
B419A8E21CA1DA3AB5E73FB0DE5DBDE575C4E3C9E8F5DEF1F90098D214516661
B2C317666A8AB6B4056548206249244C3C36614F8BA7876F8C5FB2B499C4C6A9
F4E9DAFAF2E8ECDCCBF4DFCEE5C8B5E8B89ED9906ECBA798E2A791C85B37DD98
81D8B5ABCC664CD17962BD948AF3DAD4BF4630A7817AAF3421BB3726AF231CB0
2B23000000B29299E7000000097048597300000B1200000B1201D2DD7EFC0000
000974455874436F6D6D656E740000892A8D0600000CCF49444154789CBD977D
5C53F7BDC753488D570A8110509CECAE3DC73C0A478A55C803818C1642309804
1573EF6E5C379EAC67C3873C31539290702121E03DCED5BA4B655AEF552FD4AD
6AC10758071A0243C0B64E82AC4E3729950407D5B6A968F73D49B46EBD7FEF73
7EE7F0E39CD72BEFD7E7FBF0FB9D43F9FA9F22CAD7BF3D1BD2364335C8DA0BF2
F5FA7CBEAE5F750F80C6C7C90B8C6E5D6348C73DC7DF79A75137E039DEED1B1C
FC4180C94C642526B25E4C6495B1CAB2620BB3625FCC5ACBCCCA4A6096AD95AD
892D4B94956D7E2184E9E9E93966AD24A5FBD5C0808FFCF5E3DD1ECF80E7D237
BA76E1AD882E5C3BDF01D73FFCE6D4B877F03F92626333166766C8B00C59C162
4CB60E46416C4156A20CCBCA285887251664AE2B50AC02CCD9B33D5D5D5DC7AB
407555A73C9E0BA73A8E1CFE51C7C8C8C845525761F45FBD7AF5CCFE9FEC0FE9
7FAF9EA9D95F73E6A377CF787CDE7F673116A32A0CC390F842A4104B4091421A
9291C1484FA431949B55884AA5429197F349CC6057F7C79E8EC315A08E4BE7DF
359BCD3BCC35E68BFDFD97FB868727872749751EC50982D8B7BDBC7C3B71E528
4CCF4D769E19F179EFC5D2A8D23C145568A44A0D8229E9C54AA418C1103E0AA7
0206AAE497AC5A19C678BABB2F8089F397AE9D3A52610EE9DDFEFEFEBEBE61F8
FDCECECEA36FE76BF3CBB76FDF9AFFECB3DAF2F2ADE5C4C9D10F4F8F8E4E4DDD
BF1F5C88A244A5D0632851D1D1D114500C5DC3877F290F6362A261121D9DFA9D
F580E9190408602E749C3AD51181986B8E9C3F730E28E7F090F2EFFC75FA0BAD
F65EE0AB2F025F693FD59EBCF5C9CDD3B7A66FDF999D9D7B78672E703F260AA6
B3943B73B38185187E319F42DEA40482D1147FCC9630A6274C395551F16A0D10
C2A41A7C077E06A24542F6E1DA19AD7626FFAF5F68B76ED5069EFDE2AB1B37EF
DCBEF167FF947F7E7E61C11FF5708642F13FA0443DF25328F31CCA739894E27F
B430F3687E9632F77974EAA63412D3D515C21C364372CC8FEDE0E471E46867C4
CD4CBE76E6CF01ED7682285F1DC80FDCBA7D1BCEE9A94FEFDEFD3CE87F743FF0
68E1D3BB9FC3348A169CBB8BD0680FFDF39FCD0583B377030F9E2B797965D84D
88028C279030272202272068F7A66E7EA985DC6FD77EA90DDC9ABE39FD97E9A9
A94F21520B77FC8160FC02390DFA1F32A23E9F0D2A180FC970069F0BDE093E83
864B208CE9200B8D3453118184FD440441DBFAF6CD1970B3AF7CF53DED27B7A7
6F4E7D320398F9FBCF2FF867EF3FA22EF81F227CB8D028B39FCD4B19147FF0E1
ECBC12B85234755308D31B3663AE78DACC530C480E048D206EDC0E68B5DA7CFF
EAAD7F3931357A6B06DC406E9E59F02F0482CF3FF03F084605FD94E0C2CC8374
348409DC471FF81F2995A961375DBDE1983D1D3412627E12345CEB87781DBD31
35732F10585DDE7973FAE6951BD3531F4F41683E8312B81F202B6DEEB305A8AF
C07C8A9281923537F70C150A0355A46EDAF08D9B9D55BA4A9D4EB7FBFFE5946F
7D8DD8B7EFF4FB3FD46AB7966F3FF7E1E887C370FAFE343F1F5C88894E4989A1
A7502851312951D037291ABAA698EC9BE8187E4C740C9D1EE99B2EB237ABF4B0
6E1A40969D91B43C6506C63E58033A27CF410D10A393972F5F1EBE3C79C9D733
C7A022F4E574188AE5F0EBA1834EE7F3A143F93051D0151ABEA6248C01371D55
D57A83C11652F5B75243900B0DE8282C3AF0E7CA24B9065DBEEAF11D9B63C44B
11854623D52C47107A1E9247E72BA49A3CA5869FA754C09CCE47A4E0262D8C39
5CA1AB36185CAEA61F1B8D4E5755C48BF909E431A873F23409EB1BEE1F1EEE1F
19F76E9BA329A9F1A8944AE52B314C49C5680A25239E8F3130298386295094AF
445124D237BDD0FFFAEA6DAEFACA1D2ED32193DBA2D3D535EE36E33FD9B96BD7
AE3DBB77BDB1EB8D3DFBDBDE6CDB0F84D3C41BE72F79AE5DEAEBBBFA91CFCB9E
5D0C51CBCC4CA015539548C19A02D9DA82445481210C8CB63936333153894995
68C9CB640978BBAA2A2AAA0DB61FD875669BC3D160B2189A9AAAAD7BF0D72B2D
160B6ED1EB2DFAB72CA47E419C3EF366776F97CFE7F58D5C1DF18D0560534B90
315959499B312483C9946527B1B26508A66014B2D664B3629358599B113452D0
EF90986D2EBB4357616B68004CA5ABC966D869AED3575BADB8D56A3558C36A24
7E71EC1DDFB11EEFE0A0D77BED9AEFAC40989DCDCE662765B35FA46666656733
05EC6C015B8621EB8040DE4E623395114C572560AC867A7BAB717715B90DFF54
E7AC77D91A718BC1D064256C4D2E9BABF14D97CB656B221AADDE1EEBC5C1B1B1
B1C1718FF7C71C8E40C0920905420E1BC966B3D9021953C015B2698CC42CF827
A3AC4828142622E1BEB102E648A5C1696AAD755BC822DBB1D3E932D6EBF06A9B
CD65C58DCE83CDCD6FB6C1A5D9493435FD9F4D3F393E01F279BCC95C21A70853
F1B8221E572310B085498A35225E91205D11CBCC660BD25570BF288B5F12AAB4
6AD24DD53697C9515BEB68AA238BCCE5AA77EB71ABABDEA8C39BDDEE43A6B6B6
F6F696F676C2E9723A8F4D0E0C0D0D4D0C8E77F9391C9E1A53A9D539A5C90A6E
5111974D2F538B789C743AC452C04BC7727272D402456A045307AB99CE666CA8
AD6D6D0043B8596F73BB0DB8D3E876EB7093FD504B6B08D3DA42B8C1DAB149DF
D0D0F5EB83BE6D222E4F2D5661A54B37E66E5C0EF3527156BC0A53A5FF9B82A4
A85F924924B972353DBCDF54EBAA6A2ACC3B2A9D6ED28EA95E8F9B1BC18D11B7
BBEDEE2AC2ED6E7038DADE6A6F6F753888B603070E9C1A9F00CAF531EF36112F
39676341424E695CDC4684BDB1541217C75D43438BA999023657228F5BB22437
2E4ECE7F21D43716081AB966D619203BAD0EB771B7B9AAC96934E12668A23ADC
DEDCDED2D2D666B7B7B438A0430FE8C7203143BFFFFD84772E99C713CBD7C992
9317C549A8055C39FCF2C665BC423AA6E408D471B94B96C42DCA8DCBE1BFB26A
43D84D64B9B4B85B5B6B1D6E2B6E76399BDB2B1D0D871AFE9B701F341D020C64
A8A585F865B5EBECD8C4D85018C3E3F2C462D5E264917C91848AA4172D55E7E6
262F136562520EBB2857C266B2982FC5C6F25F791C34738D4E67D15B7575F5A4
1F176EB6398D767D6B6BAB03C70F1E747F83A976BAC6C606C687AE03E6582C17
30CB54096AC02C8355006309E512716EB23003E108B88B72D761EB16A7676682
9BB450D0EACC158D7AABC15669B690716BC0712B04CD565B5BEB24C842683FF4
1863779E1D1B1C1E0861B631385C91585CB0582D922C92A36BD71626AC65E7E4
E42E2B6231386CDE1249014D22E289B891DCE8C9A0C1D2697359F046BB09EC98
711DB831EEDD5B6B030CC4EF09A6FDE0C484378439313447130A45C96255815A
24962CA38BA0556311D652B95C94880A84BC1C098688A0CA85F492486EEA2068
D54DAE7A8BB9D108DD0391AA72C1A2507B62AF1E8756798271102D90FEB09B13
0DB154A180AB1663985A2DDF28D788840241E1F232B558BEF4453E60968A551A
5E118FCB51840BDA42BAA9B23639DD06B3C56E6F6DADC7F11D3628EFBD27F65A
08C2E66AB63FC1405F5E1F1CF65D87A07DC9500A84DCD26519D09E1289842EE4
088532BA0C9CC90BE94C0EAFB43403DCF078CCC87E036E6ACCAF5B6DF5F60693
C96D72B45A6193B1B90E92181D81DB6C071F635A8909B231C72680728247038C
7AE9329E485C9A1B27C84B52177193D93CB524B75495B946A896E4088B4A79EA
A5898AF0466081A041726CF5C6860687C9E130FD14307A9B91C4B41144930D92
D3D6D6DC6C6F3F741AFA1F3406983B5CC070786209370EDA65D14B2826148978
4BD5E22512194665648944F2D24562919C892AC37DD315C298EB6C46B0D36032
D4C0BEB9CB6A331E020CEC9A4D24E7C001A88466F7647F2F24A7D707A9891350
A5103471EE3A96A4542EF8570C5132391C75B288CB92628A4C4C96942C4ACE29
624A11345CD0BDDD21CC0EBC4A076922ADC01660B5391B6AF756137F2778A51E
BE3872F1238FAF3729961A2F650B3862498246958E52355404C1A8CFBF9420C5
60F79432308C9F08DF36C5D813CCC0C0EB4F5E9AC9F7E6CE4E5C074D04A5D6F4
4BFC690AF912303CDCD737E2F11E839700A5345BC011252F56C66B102A3F9E4A
A562280329A6C5D3691843C9A066D21568318AA2CA1742B9F1793A8EBC1A7E99
7D15C73B2727FB8E1EF9CDE1B7748D3BFFDE0B7C39F50DC3D1FF07F87A62509F
93E6A932CAD624C4C723CBA5CAE58A78340FC150BA063EA394344483D2429F51
79A832D2370397FACF8DEE796DCFC993A3F07174E54352574EBEF65FE4F1B4DE
8647E4B8F8F1C795FF82BE02AF792529FC2D255B52E14C2929494D8159E82C49
D992929A9A9A5202972D70A67EF77B80193937FAC107EFBFF7FE074FEB7F7EFE
B39FFF83DE0B3F797FF4DDC3CFAE7E79D5A6EF6C82014778FCC33C3C0D69D577
577C1F30E73EF8E3EFBEA5FFFCB6224FFEF8DEAF7FBD323F2D6DC5FAF52BD2D2
D6AF589FB67EFD860DEB576C580967DA8AB4951BE084A7E4AD0DF0286DC5F7BE
4F62FE29FA1B8C064B4CAD4156FE0000000049454E44AE426082
}
end
object imgLazarus: TImage
Cursor = crHandPoint
Left = 6
Height = 47
Top = 210
Width = 102
Anchors = [akLeft, akBottom]
AutoSize = True
OnClick = imgLazarusClick
Picture.Data = {
1754506F727461626C654E6574776F726B477261706869635917000089504E47
0D0A1A0A0000000D49484452000000660000002F08060000001188BFC6000000
0473424954080808087C0864880000000970485973000002A2000002A201B69B
BD6D0000001974455874536F667477617265007777772E696E6B73636170652E
6F72679BEE3C1A000016D649444154789CED5C795C1457B6FE7AA14168D92142
8B202222A8114450594451518CBB463413B74932C6306E8979D1319A4CE2324E
342E8986E4E9689291108321E20E068D0AA2A80415D9646941F6ADA11B9AEEAA
F3FE682929AB414CF2E6CDE4F9FD7E05DC73CF3DE7D43D773D752FA21EE6F2F5
62B168ADB39393140F41F85F047599EC9AF957EAFAD7807EB16A22426969999E
61B04524EF69A9292BAFEC616961F6DBDAF70CBF0825A5B5E8D7D7B9456C636D
2D79E6947F1FB8F6B6834C26134B1FCF983973262A2B2BD1BF7F7F884422E8F5
7A545454C0CBCB0B9B366D82A5A5251886C1810307101B1B0B33333328140AB0
2C0BB55A8DE8E868040707A3BEBE1E7E7E7E387CF830468E1C0900A8ABAB4350
5010A45229323232606A6A0A00888D8DC5AE5DBB909A9A8AC58B17E3EEDDBBF0
F6F61618BD6EDD3A787A7A62F6ECD9A8A9A98197971700C31050535383B6B636
6CDCB811FEFEFE686E6E86878707468C18016B6B6B9E1C3B3B3B6CDFBE1D4AA5
12010101080D0D85B9B9391886417373334422115E7DF5554C9A34E98915D9D8
D88801030660E4C891B0B2B202117136BDFFFEFBE8DBB72FB66DDB86B8B8381C
397204EEEEEE5CD9E4E464AC5AB50AFBF6ED437070305FB08B4B1F2D75406868
28AD5DBBB62389743A1DB9BABAD2B66DDB888868FEFCF9347DFA7452A9543CBE
BCBC3CF2F6F6A69D3B771211D1B265CB68FEFCF95CFEBA75EB68E5CA95141111
41BB77EFE6E8C3860DA37DFBF61111D194295368D9B265D415C68C19431B366C
10D0972F5F4EA3468D222222954A4500E8F2E5CB9DCA292C2C2400949B9BCBA3
DFB87183ACADADE9F0E1C35DDA41445457574700283D3D9D478F8A8AA2A54B97
72E9CF3FFF9C9C9D9DE9CA952B444474E0C001F2F2F2A2DBB76F0B64F63097B7
8A5C5CFA6895CA1259BBA3468F1E0D1B1B1B44454571AD3C2B2B0B172E5C404A
4A0A4C4C4CE0E0E080D4D4548C183142D0823EFDF453ECDCB913F9F9F9282E2E
868F8F0F8A8A8A209148E0E5E585ACAC2C14151561F6ECD9282C2CC48D1B3730
67CE1C141616C2D4D41453A74E455E5E9E40B6A3A323B66DDB0600183B762CDA
DADAB856A6D7EBD1DCDC8CEAEA6AAC5CB912212121686A6A82A5A525222323E1
E0E0C093356DDA34CC983103454545707777476E6E2E3C3D3D793C4B962C4179
79394E9D3AD5658FA9AFAF87ADAD2DC68F1F0F5B5B5B300C83AAAA2AD4D6D622
3131117DFBF6E578535252B070E1428C1F3F1E4AA512717171B0B5B515C834B7
E8A9150C650020954A616666069148045F5F5F2C58B00072B99CAB044747479C
3C79D2A8634E9C38817EFDFA0100DCDCDC3073E64CECDFBF1F2A950A51515170
727282939313BCBDBD111F1F8FC4C444AC59B3861BD600202C2C0C3B77EEE4C9
158BC5BC7460602056AE5C09AD568BA4A424ECDDBB176BD7AE454848088F6FCD
9A35023BA552A3AFCD435555151C1D1D9FC8D78E0F3FFC10010101605916F5F5
F5D8B76F1F424343919B9B0B73737300C0983163B065CB16444747A3A6A60612
89A45379462DF4F4F4C4F4E9D38D17904AF1E5975F62F9F2E590C964080D0DC5
800103909191813367CEA0B2B212070E1CE0F8DF79E71DCC9C39134D4D4DB87A
F52A47DFB0610356AD5A85AAAA2A1E3F0068341A5454540874DBDADAC2D2D212
002097CBD1AB572F00C02BAFBC82909010444646223535153B76ECE0CAD4D5D5
1995E5E2E2C2FD5D565606994C06AD568B8A8A0A1C397204F9F9F9D8B76F9FD1
3A3086070F1EA0B8B81800A052A9505D5D0D53535341E59B9A9A422A9576E914
00100C65070F1E848B8B0BC2C3C3BB2CA8D168F0E38F3F223737176565657073
7383B7B737C68E1D2B68DD31313190CBE578E9A59778F45DBB76C1C3C3039327
4FE668B1B1B1C8CDCD35AA73C2840918356A140E1D3A04575757848585F1F22B
2B2B11131383C8C8480C1932049B376FEED4FE37DF7C130CC3F07AA6542A8595
9515060F1E8CE0E0E06EF5ACD6D6566CDDBA954B8BC562C8E572B8B9B961DCB8
715C436A477676364E9C3881356BD6742AD3DCA2A756A450F4D69696DE9775CA
F50CFF72F430976BA555555574E58E12BD6C7B7219DCAE951EDBC51240861F02
3A40EDECC6CB53873DB1113EEA4010D03BEAE68B78A4FBF1F21DE94FB05D2857
C847649CDEB95CEAF8CBB8DCC77513E1EACF4A68B55AC31C73F956093A82650D
954C440F9F477F779D679C4ED42EF34979DDA31BB7A3ABBCEED8D85DFBBB63CB
AFAB2F00E04F064F81BB372FFFD2A2CFD00D3C7976EB04595792515E928FB0A9
0B7F95013213096452295ADB7468D5EABBE415894470E9650D22C283AA4668DB
185EBEABB30D0043EB6E1F26DA5B634DBD1A8D4D2D1DF44AA178CE0A00E19EB2
966BA9EDE8E36C0313A9D8402740A7675153DF8C06552B8FCFC9C11216E63254
5437A141D5C2A35BCA4D515EAD425DC323BAADB539FA38DBC0DCCC049535CDC8
2DACC463AA0174C331B19FFE15D316AE8299B99CA335D45642AD6AC0DD1B9740
44BFCA3963033C3039642092AEE4E168F2ED2E79FD062AF0E7970C9BCAB85399
389692CDCBDFB27A32246291D1B29F7F7B05C753EE70E969E13E583C2B0000F0
D74FCFE25246218F7FD3EA49E8DD8B1FCA018056AD1EFB8F5CC157DF67000096
2F0A41F8284F7CF869128E9ECEE2F8A21706E385B13ED8B237195F275C87A94C
8A756F8CC39CC8A13C7905253578FD2F4750505CC3A33FD13165C5793811BB17
7D3C7CE0171C01408CA4EFBE80B2C05089174F1E86D44486A089514F12F5AB31
29E4516C6C62B0174E5DCC459BEE512FDBFAC58F10015C2F891C3D107EDE0AA8
5BDA703BAF9CE3934AC5981A3E084404914884A8485F8163DAB1E3C0799457A9
201289E0E46889A5F347E18D3F04233D5389DCC2AA6EDB3E71B417E6440E45EA
8D62C4FC33156A8D160B6707604AB80F36AF998C17DF38C4E3EFD2312CC3A0BE
A602B59565B871F1B421121034112E1E3EB87DED3CC797F2C3415858DA60C888
085E79755303CCE556DD36BE2B78F4B183471F7B14286B50D7A841C0E03E08F5
EF8BE4B47C8E272BF70137E146040F809FB702AD6D7A7CB03709250FEA39BED1
C3FBC1CEDA1CC9A979E8DBDB0E9E7D1D3074A00237EE9409F4DECE2B4741492D
37F987057AC0D75B01473BF9533986610DE39589440C9D9EC1EDDC72BCBBFD14
5252F3A1D6B409F8BB9CFCAB2BEE83651E8DE3E713BF06CB32F0F0F117F0DEBA
922CA09D8EDD09B5AAAEDBC6778589C186DE92949A87B3A9790080C9A3BD2136
32748D1EDE0FAFCC1E019D9EC1969864E43C568133270C06001C3B7707C7CE19
7AFEDCC78698764C1B37188B670720FAE5606C7A3312CF0F744679950A69378B
9FCAFE933F66E3566E39863FDF078777BD8CD4A32BF1FECA89D0332C922F0B37
D45D3AA6B4308797AEAFAEC0CD4B6720919A0878ADED7BF1D2377E4A44555911
2E241E7CAA173006475B39FC062AD0D0D4826B774A91575C8D9207F578CE4E8E
C0C17D78BC0183FBE08DF9416089F0D181F3C8CA2DE7E5FBF9F4869BC21677EF
5522BFA40629E9055035B762D8201778B8DA0B7487F8BB63DE0B7E887AC117A3
FCFA62CBBE7398B7F22B300C0B00D033869E2002BF81B4A7F50FF9582244451F
C2A2B70E23FE74165AB43A4C9B3008BBDF9B89CF36BF28D0DBA563B4AD2D02DA
8F09076165EB00B9D5A3A8A8582C817FD8542E9D9F750549DFED4353430DEE5E
BF004D7363576A9E8809419E108944E86961864FFF32039F6D9CFD7045054C19
E3C3F10D19E08C950B43211201BBBFBA886BB7EE0B64CD1C6FE82D1EAEF6F86E
CF42C47EFC322CCC0D818F792FF80AF8DFDAFA0326BFFA05CEFC9403998904B3
260E81CCE4519CABAE410D003033E5CF0AE60F65B6AFD426840CC08259C3915F
5C8375DB8E634CD42798FACA7E3436B5627CF000F47BAC517439C77878FB4222
9182611E4DB0DA560DC4620996BCFD316E5F3B0F9661E0313810BD5CFA813534
0EA49EFD86E3675906C539D7E1E537A62B559D426E2E43B06F5FE81916672EE7
76580603A1FEEE7053D86088A7135AB43ABCB57834A4123162E2D270E97A9140
967B6F3B0C1DE88C06550B9252F3783BEF99E38720C4DF1DCE8E9628ABE43724
9D8EC196CFCEC1D1BE277CBD15D8B2E6052CFFEB51E8F52CCAAB540080A9E37C
70EAFC5DD436A8E1E2640D5F6F0500A0ACC2206BDAF8411833B23F067A3C870D
3B4E41D3D20686612133918008D0B4F0E7992E1DE3A87043D4B27771FADB2FA0
696E8495AD03A62F7E0B0060EBE88C90C879821D6B696136CA4BF278720AEF3E
D931E181FD3166B8078F76E5E712D436A8213391202DB30447CEFCCCDB6DAB35
6D888A1C8AA96307A1B4A201A632C3EB2C991580250F97C2EDF829A3905B4A1F
3F9F8DC3893778B65BC9CD1011E285B9937DB1E3C079817D7A86C5FA1D27F18F
BFCDC3B041BDF15AD448ECFDFA328E9DBB83E91306A3BF9B0392BE7A1D750D6A
D8D958000052D2F2B9D5E0DF3F4FC190810A4C1D370893C206A2AE4183E7EC0D
61B0FFFEE60AE7E076F01C73F372327C83C6F118060D0F858F7FA820C4D0196E
A52709682CD3F9C6B1405983931773B8789321866468C7F7CB1B602937C30F29
77909EA514943D77251F2626121011940FEAD1A4D672BDA9630C8B009494D5C1
D9D112878FDFC4C90B7705B20E27DE40656D33DADAF4108980A3676EC1B2A719
EA1A1F0DE70DAA16BCFDB74484F8BB83615998994AA16969C34B2BBF4644A817
5C1536B0B33647654D336EE79523A5C38AB1B8B40E13177C8617C27DD0CFD50E
A632294ACAEA91F1F37D5CFDB944608FC8C444D6BAE5CB645300F864E33298CB
AD505A9883A1A3C661CCB49761D6C3E2A9623F293F1C40DAD96F794AA62F590F
779FC067B1B26EDA723FFD43FE174C977E5EB878EA3B00C04F27E370333519B3
5FFD2FF41F349CDF03581685D937909B7505AD1A35F43A2D7ABB0F847FD80C84
4D5D8C1E165628CAB901B15882E16366A077BFC18630C933741B3CC70C1812C0
3906009A1A6A7168FB3B78E1A53F23307C1A0040555F8D7FFC7D0D6A2B4B7982
B2AFFF84EAF2FB88981B8D80B133307CCC0C5E6B7886A703CF319E43026065EB
80C6BA6A8EC6B22C8E7DB50BCF8F1A075333739C8CDD2B704A3B6E5E3A0946AF
43E89485B0E8293C64F07B837BEF9E18D2DF0EA93F57A0A2BA05D3C3FB72DF63
743A062A751BD2B32AD1D8645871393B5820C45FC1CDA1F4F00701389A5400B5
46C7C9E639462C1663FCCC8588DFBF9D176DEDEDEE055333C38182CA52E331A5
76645D4942567A32DC3C872238F20F70721DF0AB2BE0DF15AECE969830CA05F7
4A55A8AC69C1C4E03E6852B7E15E6913645231FA2A7A62F6F87ED8F575166EE7
D7C2D1CE1C53C2DC505AD98C8A1A4D878F662408BE0A96CB23C2A7426E658B0B
27E2C0B20CAC6C1C3029EA75884422300C83FA6AE1C1060188509C7B133A9D16
F3976FFB4D2AE13F05F72BD4D8F3CF2C10112C7A48B179C508BC36C7072BB6FC
C4F1FC74AD0C89E78B04937F4718DDC778FB0561A06F9060C570F6C8E76059C6
5811A3A850E683581610FDE2EF71FFD168D6E89053D480E1831C616BF5E81872
E870053CFBDA703DA6BC5A8D4309FC257CB73F94655FBF844BA78F3C95616E03
86422416FFBF9EFC757A4338A463C846D5DC8607556A6E8EA9691086BEBAED98
3BD72F3E954166E63D113076D65395F9BD412C12C1BDB7255AB57A9457AB616F
6DE8359977AB0543D9E3E8B6637C8326203355B8AB7F1C66E6720C0A0847D0C4
9760DAC3C2A8D2DF33EC6DCC1019E20A998918FD5DADD0CBDE1C078EDEE5EDE3
BC3DEC20168B1E6D2A01A4DD2C4779B59AE3E9B6633C7C8661F4E4F9B874E65B
30FA47211699590FB8F61F0C57CFE7D1A7FFF37054184EB3B72BFD3DA35ED58A
7C65239A353A1080BC92460084C1FD6DD1A663505DDF8A8473D7917DCFF091AE
59A3434E613D4C65123CEFE5C00BA26617D4F11CC30BC9B4A3AB30426DE50354
DC2F0411416E6507A73EFD0191E829421ACF42324F1D92E90E6C1C9C606DEF24
10F80CBF2DA400A02CC88646DDC41189ED10E5E576A986302DFBF0B781DE2192
CBF3BA91F2ED2D071DCB1BCAB22C09E8440FCB707474D0471DEC78744C894B13
19A7830CEFD64177FB7BA0BD057376F3CBB3F438BDE37B77426FD7C7D51FBF0E
0CFA3AD201B1C43078892412898E61985F7CBEEC197E7B884462BD9488FFB1DA
C4C40423478EE4EE74B4A3B1B111696969108BC5F0F7F7E72EDC1011777D2137
37971BD66C6C6CE0E7E7071313FEF9009D4E87AB57AFA2A9A909767676F0F5F5
159CAA6F6B6B437A7A3AD46A358F2E954AE1EFEFCF5DDDD3E974A8ADAD454E4E
0E5A5BF907F10060D8B061707373C3A953A7A0D16804F9F6F6F6F0F1F1819393
131A1A1A90999969F4CA86ABAB2BBCBCBC60696989828202E4E4E4A0A545B8F7
B0B0B0C0A44993B80B591D616A6A8A8888085CBE7C19B5B5B582B21D41800862
B1448F87BD0D00AD5EBD9A8888727272E8F4E9D3DC131717475656563475EA54
2222BA77EF1E25242450626222A5A5A511CBB2949999498E8E8E0480BEFDF65B
22224A4F4FE7C9494C4CA4B0B0300240274F9E2422A2D4D4541ECFB163C768E4
C891D4D12E00B468D122CEB6848404CAC8C820B55A4D2A958AE6CC99C3E30D0B
0B2386618888E8F4E9D30259AB57AF268D4643494949B47BF76E4A4E4E268661
68C78E1D1C8F42A1A053A74E11CBB254545444DF7FFF3D29954AAAADADA5E8E8
6881CC3367CE101111C330347AF4685EDEBC79F38888E8830F3E1094133C22B1
5EE098F5EBD71311D19B6FBE69B4D0CB2FBF4C4444BB77EFE6D10F1D3A444444
2FBEF82201A063C78E111151484848A7069C3B778E8888FCFCFC9E6C2C402B56
AC2022A2F7DE7B8FA30505051111515A5A1A47333131A1ECEC6C522A95B479F3
662232DC1BED28ABB8B8986A6A6AC8C7C787A3AD5AB58A626262080089C562CA
CECEE6BD130092C964B47FFF7ED2E974E4E4E4C4D1A3A2A2888868C3860D5455
554577EFDE25994CC6E5FFF18F7F2422A28F3EFAE8D739E6F6EDDB9490904009
0909141F1F4FE1E1E13CC7DCBA758B3EFBEC33FAE28B2FE8D8B1635457574771
7171646262C273CCCD9B37E9FCF9F3DCF3C30F3F90999919CF311919193C9EF8
F878924AA59D3AE6F8F1E3B474E9527AFBEDB729353595888866CD9AC5F1AD59
B3868888162D5A443D7AF420A55249151515646D6DCDF1444444701753EBEBEB
E9C2850BB475EB56CE51BEBEBE5CEF148944025B3ADA2797CBA9ACAC8C0A0B0B
492693719762DF7DF7DD5FEC984E27FDD4D4541C3D7A1480E1DEE5B56BD778F9
252525484949C1F8F1E33165CA141C3C78102B56AC804EA7E3F1C5C4C4203333
934BD7D7D70BE6833D7BF6F06E91D5D4D440AFEFFC9C80BDBD3DBCBCBCD0D4D4
849D3B7762D1A245C8CB331C00512814D8B061035A5A5A606B6B8B3FFDE94FB8
75EB16222323B165CB16BCFEFAEB000C5700030303616A6A0A5F5F5F04040460
D5AA5558BD7A35424242D0DCDC0CC0308F3DBE1D707575C5DCB973B177EF5E34
373763E3C68D707676C6F1E3C7B16CD932482412B4B6B662DDBA75888D8D4541
4141A7EFD2297E8BA12C3A3A9A8888323333C9D2D2F25F3A943DFE7CF3CD3744
44B46BD72E7AEFBDF7B8273B3B9B5896A5C0C040B2B2B2A2969616BA78F122D9
D8D87043D4E9D3A7898868DCB87104801213138988E89D77DE21B95C4E62B198
860D1B46F7EEDDA3E6E666522814E4EDED4D6D6D6D74EBD62D9EBE4F3EF98488
88CE9E3DCBEB311F7FFC31999999718FB191C1E850B660C102625996E6CE9D6B
F4C5C3C3C38961187AFBEDB779F4B56BD712CBB2B47EFD7A02401F7CF00169B5
BC7F21C04D8CED65B76FDF4E6D6D6D021EBD5E6F74729D356B16B12C4B4B962C
316A9BB5B53569B55A8A8F8F17E40506069256ABA53D7BF670EF71F1E2457AF0
E001E5E7E753535313E5E4E4D06BAFBDC695313737A7CD9B379352A924966549
A3D1504B4B0B9D397386860D1B460068D3A64DA4D56A29303050A0333E3E9E18
86216767670A0A0AA2FAFA7AC1BBB6B4B450444484C03122B158A263D967FB98
7F2B88C47AA9D4C42446A7A3A520327EB1E477047A32CBFFBD7011482492C6FC
0FD2F4EAAD4CE1114F0000000049454E44AE426082
}
end
object txAppName: TLabel
Left = 86
Height = 17
Top = 14
Width = 75
Caption = 'txAppName'
Font.Height = -13
Font.Style = [fsBold]
ParentColor = False
ParentFont = False
end
object txAuthor: TLabel
Left = 86
Height = 14
Top = 66
Width = 198
Caption = 'Copyright (c) 2008-2014 by Yury Sidorov'
ParentColor = False
end
object txVersion: TLabel
Left = 86
Height = 14
Top = 38
Width = 55
Caption = 'Version %s'
ParentColor = False
end
object Bevel1: TBevel
Left = 6
Height = 7
Top = 189
Width = 416
Anchors = [akLeft, akRight, akBottom]
Shape = bsTopLine
end
object imgDonate: TImage
Cursor = crHandPoint
Left = 86
Height = 26
Hint = 'Donate via PayPal,WebMoney,Credit card'
Top = 138
Width = 92
AutoSize = True
OnClick = imgDonateClick
ParentShowHint = False
Picture.Data = {
1754506F727461626C654E6574776F726B477261706869638404000089504E47
0D0A1A0A0000000D494844520000005C0000001A08030000000D30CB1B000001
80504C5445909187EC8B35F4AA9EFFCA782F6CB3D7DADC2399D5FFBE5AE53632
FFAC2C81ABD1FEE1A8E2E3E4284A6C5E7287D5E7F4B6B9BA7A8785B7D2E68A6D
4DF9D4D1FFEFD3FFB23C49B2E3FFF6E5E75B35777063D6C9A8D89A376AC4EF8D
CCEC4853543F5577FEE9C0CADDEEBBB0922F3C726193C7E5F4FB6D3A5C49647C
B83741B88B3EEC625FB97A46A17E49153A67CF87454083BCFFECC9FEDE9EF2A9
76FED287686451F7C0BF8D9AAFF1E6E5ADAA9EEC9842B5BDC9FEB745528ABF2B
200C5EA4D5A4ACB6403727ABB2B8BEC1C1FEF5F2F5C6A8F29C6AE2EDF6F6C298
F3FAFDCACED378879FF1F6FA2B7DC15EBDEBFFA926FFF3DCFFD696FFE2B4FFF9
EEFEE7BAFFFDF8FEE6B5FFAF34FEE4B0FEDFA20057A0C9C6C1C8CCCDC3C7C8C7
CACCBD6728C5BB9E4E4535F2F3F6EFA635EED8A8EEDCB297BBDAF1F1EF70A1CA
9B9D9C847E73EED39AFEDA981062A6FBE4D0BA4E41FFE0B0A69D8DE7DBD7D1D2
D3DCCDCF9DA6B3DECA9D5E5163F9D1B7AEB0A4EAA121003366000000FF9933FF
FFFFFFFFFF7B0ABBB20000008074524E53FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0038054B67000000097048597300000B
1200000B1201D2DD7EFC0000000974455874436F6D6D656E740000892A8D0600
00020949444154789CB5964D8BA34010861B3C4810031246161474F1D208D310
D143C0FF904C7657939BA01EC2E4305E02CB4B337F7DABFD984DA2CC491FB0AC
AED2A789C16ED9678F9C91C1C906B5763CFC9987EDDBA0EFE4323EFC9A930FF9
5F2E8F3F66E62007B9DC1E66E745767219BD2C816CE5E976112A2597F1CF3117
10C2AA275AF7387FBF694A92DBDAEF31164CCE05F844EB8E8B28BEE9DA9F4CA6
7A3686A3C8B25AC0A1BC2E8AA1EC1475765711A8DBA23361C8AEA924791A9F46
0015450B4C057A4097D3A980B9A6CCE92BCEC9518FEE525111BC1A2BF44E9E5E
8D270AF8EA64C132D6F0778DC0CD60E4087CAAECE00716B811709856C5B1A62A
7B36185ADACBD3F8A9C3B0EEE537884A258C66E10685A6BDA051033537FD1EC3
08D4E881484F5BB9ADD0E3F33D6B30753251D03494908606415B3917F44F830A
671FBB3383F0B90FFFE1F6484B957490DB76AAC77134E023A0C86046A4A58CA3
7907A248857701AB206F1499B851DFB788E6EBD66BACE9BD92E4F904409E971B
20CC5FE1E5B90B51862A51411DA580ABAA39F5132ABB53929CE4AB31213A5E57
2BD22489A06C8364D50617484C405D25366E69521F66396159497A4327E49E62
E3AADCF5003324AF17EEFB4063CFA31675DCB69FB8936EF5FAEF1742B6ABA2BD
08DDAA480BC012C87EB3D016407E6D73F1DBDCC8FB0DFA382B917CFCB488B7B3
6D701F72FFF0DDB2CC47D13F947E4C789D660D2C0000000049454E44AE426082
}
ShowHint = True
Transparent = True
end
object txHomePage: TLabel
Cursor = crHandPoint
Left = 86
Height = 14
Top = 86
Width = 55
Caption = 'Home page'
Font.Color = clBlue
Font.Style = [fsUnderline]
ParentColor = False
ParentFont = False
OnClick = txHomePageClick
end
object txDonate: TLabel
Left = 86
Height = 14
Top = 118
Width = 195
Caption = 'Donate to support further development:'
ParentColor = False
end
end
object tabLicense: TTabSheet
Caption = 'License'
ClientHeight = 273
ClientWidth = 427
object edLicense: TMemo
Left = 4
Height = 265
Top = 4
Width = 419
Align = alClient
BorderSpacing.Around = 4
Lines.Strings = (
#9#9' GNU GENERAL PUBLIC LICENSE'
#9#9' Version 2, June 1991'
''
' Copyright (C) 1989, 1991 Free Software Foundation, Inc.,'
' 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA'
' Everyone is permitted to copy and distribute verbatim copies'
' of this license document, but changing it is not allowed.'
''
#9#9#9' Preamble'
''
' The licenses for most software are designed to take away your'
'freedom to share and change it. By contrast, the GNU General Public'
'License is intended to guarantee your freedom to share and change free'
'software--to make sure the software is free for all its users. This'
'General Public License applies to most of the Free Software'
'Foundation''s software and to any other program whose authors commit to'
'using it. (Some other Free Software Foundation software is covered by'
'the GNU Lesser General Public License instead.) You can apply it to'
'your programs, too.'
''
' When we speak of free software, we are referring to freedom, not'
'price. Our General Public Licenses are designed to make sure that you'
'have the freedom to distribute copies of free software (and charge for'
'this service if you wish), that you receive source code or can get it'
'if you want it, that you can change the software or use pieces of it'
'in new free programs; and that you know you can do these things.'
''
' To protect your rights, we need to make restrictions that forbid'
'anyone to deny you these rights or to ask you to surrender the rights.'
'These restrictions translate to certain responsibilities for you if you'
'distribute copies of the software, or if you modify it.'
''
' For example, if you distribute copies of such a program, whether'
'gratis or for a fee, you must give the recipients all the rights that'
'you have. You must make sure that they, too, receive or can get the'
'source code. And you must show them these terms so they know their'
'rights.'
''
' We protect your rights with two steps: (1) copyright the software, and'
'(2) offer you this license which gives you legal permission to copy,'
'distribute and/or modify the software.'
''
' Also, for each author''s protection and ours, we want to make certain'
'that everyone understands that there is no warranty for this free'
'software. If the software is modified by someone else and passed on, we'
'want its recipients to know that what they have is not the original, so'
'that any problems introduced by others will not reflect on the original'
'authors'' reputations.'
''
' Finally, any free program is threatened constantly by software'
'patents. We wish to avoid the danger that redistributors of a free'
'program will individually obtain patent licenses, in effect making the'
'program proprietary. To prevent this, we have made it clear that any'
'patent must be licensed for everyone''s free use or not licensed at all.'
''
' The precise terms and conditions for copying, distribution and'
'modification follow.'
''
#9#9' GNU GENERAL PUBLIC LICENSE'
' TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION'
''
' 0. This License applies to any program or other work which contains'
'a notice placed by the copyright holder saying it may be distributed'
'under the terms of this General Public License. The "Program", below,'
'refers to any such program or work, and a "work based on the Program"'
'means either the Program or any derivative work under copyright law:'
'that is to say, a work containing the Program or a portion of it,'
'either verbatim or with modifications and/or translated into another'
'language. (Hereinafter, translation is included without limitation in'
'the term "modification".) Each licensee is addressed as "you".'
''
'Activities other than copying, distribution and modification are not'
'covered by this License; they are outside its scope. The act of'
'running the Program is not restricted, and the output from the Program'
'is covered only if its contents constitute a work based on the'
'Program (independent of having been made by running the Program).'
'Whether that is true depends on what the Program does.'
''
' 1. You may copy and distribute verbatim copies of the Program''s'
'source code as you receive it, in any medium, provided that you'
'conspicuously and appropriately publish on each copy an appropriate'
'copyright notice and disclaimer of warranty; keep intact all the'
'notices that refer to this License and to the absence of any warranty;'
'and give any other recipients of the Program a copy of this License'
'along with the Program.'
''
'You may charge a fee for the physical act of transferring a copy, and'
'you may at your option offer warranty protection in exchange for a fee.'
''
' 2. You may modify your copy or copies of the Program or any portion'
'of it, thus forming a work based on the Program, and copy and'
'distribute such modifications or work under the terms of Section 1'
'above, provided that you also meet all of these conditions:'
''
' a) You must cause the modified files to carry prominent notices'
' stating that you changed the files and the date of any change.'
''
' b) You must cause any work that you distribute or publish, that in'
' whole or in part contains or is derived from the Program or any'
' part thereof, to be licensed as a whole at no charge to all third'
' parties under the terms of this License.'
''
' c) If the modified program normally reads commands interactively'
' when run, you must cause it, when started running for such'
' interactive use in the most ordinary way, to print or display an'
' announcement including an appropriate copyright notice and a'
' notice that there is no warranty (or else, saying that you provide'
' a warranty) and that users may redistribute the program under'
' these conditions, and telling the user how to view a copy of this'
' License. (Exception: if the Program itself is interactive but'
' does not normally print such an announcement, your work based on'
' the Program is not required to print an announcement.)'
''
'These requirements apply to the modified work as a whole. If'
'identifiable sections of that work are not derived from the Program,'
'and can be reasonably considered independent and separate works in'
'themselves, then this License, and its terms, do not apply to those'
'sections when you distribute them as separate works. But when you'
'distribute the same sections as part of a whole which is a work based'
'on the Program, the distribution of the whole must be on the terms of'
'this License, whose permissions for other licensees extend to the'
'entire whole, and thus to each and every part regardless of who wrote it.'
''
'Thus, it is not the intent of this section to claim rights or contest'
'your rights to work written entirely by you; rather, the intent is to'
'exercise the right to control the distribution of derivative or'
'collective works based on the Program.'
''
'In addition, mere aggregation of another work not based on the Program'
'with the Program (or with a work based on the Program) on a volume of'
'a storage or distribution medium does not bring the other work under'
'the scope of this License.'
''
' 3. You may copy and distribute the Program (or a work based on it,'
'under Section 2) in object code or executable form under the terms of'
'Sections 1 and 2 above provided that you also do one of the following:'
''
' a) Accompany it with the complete corresponding machine-readable'
' source code, which must be distributed under the terms of Sections'
' 1 and 2 above on a medium customarily used for software interchange; or,'
''
' b) Accompany it with a written offer, valid for at least three'
' years, to give any third party, for a charge no more than your'
' cost of physically performing source distribution, a complete'
' machine-readable copy of the corresponding source code, to be'
' distributed under the terms of Sections 1 and 2 above on a medium'
' customarily used for software interchange; or,'
''
' c) Accompany it with the information you received as to the offer'
' to distribute corresponding source code. (This alternative is'
' allowed only for noncommercial distribution and only if you'
' received the program in object code or executable form with such'
' an offer, in accord with Subsection b above.)'
''
'The source code for a work means the preferred form of the work for'
'making modifications to it. For an executable work, complete source'
'code means all the source code for all modules it contains, plus any'
'associated interface definition files, plus the scripts used to'
'control compilation and installation of the executable. However, as a'
'special exception, the source code distributed need not include'
'anything that is normally distributed (in either source or binary'
'form) with the major components (compiler, kernel, and so on) of the'
'operating system on which the executable runs, unless that component'
'itself accompanies the executable.'
''
'If distribution of executable or object code is made by offering'
'access to copy from a designated place, then offering equivalent'
'access to copy the source code from the same place counts as'
'distribution of the source code, even though third parties are not'
'compelled to copy the source along with the object code.'
''
' 4. You may not copy, modify, sublicense, or distribute the Program'
'except as expressly provided under this License. Any attempt'
'otherwise to copy, modify, sublicense or distribute the Program is'
'void, and will automatically terminate your rights under this License.'
'However, parties who have received copies, or rights, from you under'
'this License will not have their licenses terminated so long as such'
'parties remain in full compliance.'
''
' 5. You are not required to accept this License, since you have not'
'signed it. However, nothing else grants you permission to modify or'
'distribute the Program or its derivative works. These actions are'
'prohibited by law if you do not accept this License. Therefore, by'
'modifying or distributing the Program (or any work based on the'
'Program), you indicate your acceptance of this License to do so, and'
'all its terms and conditions for copying, distributing or modifying'
'the Program or works based on it.'
''
' 6. Each time you redistribute the Program (or any work based on the'
'Program), the recipient automatically receives a license from the'
'original licensor to copy, distribute or modify the Program subject to'
'these terms and conditions. You may not impose any further'
'restrictions on the recipients'' exercise of the rights granted herein.'
'You are not responsible for enforcing compliance by third parties to'
'this License.'
''
' 7. If, as a consequence of a court judgment or allegation of patent'
'infringement or for any other reason (not limited to patent issues),'
'conditions are imposed on you (whether by court order, agreement or'
'otherwise) that contradict the conditions of this License, they do not'
'excuse you from the conditions of this License. If you cannot'
'distribute so as to satisfy simultaneously your obligations under this'
'License and any other pertinent obligations, then as a consequence you'
'may not distribute the Program at all. For example, if a patent'
'license would not permit royalty-free redistribution of the Program by'
'all those who receive copies directly or indirectly through you, then'
'the only way you could satisfy both it and this License would be to'
'refrain entirely from distribution of the Program.'
''
'If any portion of this section is held invalid or unenforceable under'
'any particular circumstance, the balance of the section is intended to'
'apply and the section as a whole is intended to apply in other'
'circumstances.'
''
'It is not the purpose of this section to induce you to infringe any'
'patents or other property right claims or to contest validity of any'
'such claims; this section has the sole purpose of protecting the'
'integrity of the free software distribution system, which is'
'implemented by public license practices. Many people have made'
'generous contributions to the wide range of software distributed'
'through that system in reliance on consistent application of that'
'system; it is up to the author/donor to decide if he or she is willing'
'to distribute software through any other system and a licensee cannot'
'impose that choice.'
''
'This section is intended to make thoroughly clear what is believed to'
'be a consequence of the rest of this License.'
''
' 8. If the distribution and/or use of the Program is restricted in'
'certain countries either by patents or by copyrighted interfaces, the'
'original copyright holder who places the Program under this License'
'may add an explicit geographical distribution limitation excluding'
'those countries, so that distribution is permitted only in or among'
'countries not thus excluded. In such case, this License incorporates'
'the limitation as if written in the body of this License.'
''
' 9. The Free Software Foundation may publish revised and/or new versions'
'of the General Public License from time to time. Such new versions will'
'be similar in spirit to the present version, but may differ in detail to'
'address new problems or concerns.'
''
'Each version is given a distinguishing version number. If the Program'
'specifies a version number of this License which applies to it and "any'
'later version", you have the option of following the terms and conditions'
'either of that version or of any later version published by the Free'
'Software Foundation. If the Program does not specify a version number of'
'this License, you may choose any version ever published by the Free Software'
'Foundation.'
''
' 10. If you wish to incorporate parts of the Program into other free'
'programs whose distribution conditions are different, write to the author'
'to ask for permission. For software which is copyrighted by the Free'
'Software Foundation, write to the Free Software Foundation; we sometimes'
'make exceptions for this. Our decision will be guided by the two goals'
'of preserving the free status of all derivatives of our free software and'
'of promoting the sharing and reuse of software generally.'
''
#9#9#9' NO WARRANTY'
''
' 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY'
'FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN'
'OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES'
'PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED'
'OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF'
'MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS'
'TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE'
'PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,'
'REPAIR OR CORRECTION.'
''
' 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING'
'WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR'
'REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,'
'INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING'
'OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED'
'TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY'
'YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER'
'PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE'
'POSSIBILITY OF SUCH DAMAGES.'
''
#9#9' END OF TERMS AND CONDITIONS'
''
#9' How to Apply These Terms to Your New Programs'
''
' If you develop a new program, and you want it to be of the greatest'
'possible use to the public, the best way to achieve this is to make it'
'free software which everyone can redistribute and change under these terms.'
''
' To do so, attach the following notices to the program. It is safest'
'to attach them to the start of each source file to most effectively'
'convey the exclusion of warranty; and each file should have at least'
'the "copyright" line and a pointer to where the full notice is found.'
''
' '
' Copyright (C) '
''
' This program is free software; you can redistribute it and/or modify'
' it under the terms of the GNU General Public License as published by'
' the Free Software Foundation; either version 2 of the License, or'
' (at your option) any later version.'
''
' This program is distributed in the hope that it will be useful,'
' but WITHOUT ANY WARRANTY; without even the implied warranty of'
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the'
' GNU General Public License for more details.'
''
' You should have received a copy of the GNU General Public License along'
' with this program; if not, write to the Free Software Foundation, Inc.,'
' 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.'
''
'Also add information on how to contact you by electronic and paper mail.'
''
'If the program is interactive, make it output a short notice like this'
'when it starts in an interactive mode:'
''
' Gnomovision version 69, Copyright (C) year name of author'
' Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w''.'
' This is free software, and you are welcome to redistribute it'
' under certain conditions; type `show c'' for details.'
''
'The hypothetical commands `show w'' and `show c'' should show the appropriate'
'parts of the General Public License. Of course, the commands you use may'
'be called something other than `show w'' and `show c''; they could even be'
'mouse-clicks or menu items--whatever suits your program.'
''
'You should also get your employer (if you work as a programmer) or your'
'school, if any, to sign a "copyright disclaimer" for the program, if'
'necessary. Here is a sample; alter the names:'
''
' Yoyodyne, Inc., hereby disclaims all copyright interest in the program'
' `Gnomovision'' (which makes passes at compilers) written by James Hacker.'
''
' , 1 April 1989'
' Ty Coon, President of Vice'
''
'This General Public License does not permit incorporating your program into'
'proprietary programs. If your program is a subroutine library, you may'
'consider it more useful to permit linking proprietary applications with the'
'library. If this is what you want to do, use the GNU Lesser General'
'Public License instead of this License.'
)
ReadOnly = True
ScrollBars = ssBoth
TabOrder = 0
WordWrap = False
end
end
end
object Buttons: TButtonPanel[1]
Left = 8
Height = 26
Top = 315
Width = 435
BorderSpacing.Top = 8
BorderSpacing.Around = 0
OKButton.Name = 'OKButton'
OKButton.DefaultCaption = True
HelpButton.Name = 'HelpButton'
HelpButton.DefaultCaption = True
CloseButton.Name = 'CloseButton'
CloseButton.DefaultCaption = True
CancelButton.Name = 'CancelButton'
CancelButton.DefaultCaption = True
TabOrder = 1
Spacing = 0
ShowButtons = [pbOK]
ShowBevel = False
end
end
TransGUI/about.pas 0000644 0000000 0000000 00000015254 12261763702 013044 0 ustar root root {*************************************************************************************
This file is part of Transmission Remote GUI.
Copyright (c) 2008-2014 by Yury Sidorov.
Transmission Remote GUI is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
Transmission Remote GUI is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Transmission Remote GUI; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*************************************************************************************}
unit About;
{$mode objfpc}{$H+}
interface
uses
BaseForm, Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, ComCtrls, ExtCtrls, ButtonPanel;
resourcestring
SErrorCheckingVersion = 'Error checking for new version.';
SNewVersionFound = 'A new version of %s is available.' + LineEnding +
'Your current version: %s' + LineEnding +
'The new version: %s' + LineEnding + LineEnding +
'Do you wish to open the Downloads web page?';
SLatestVersion = 'No updates have been found.' + LineEnding + 'You are running the latest version of %s.';
type
{ TAboutForm }
TAboutForm = class(TBaseForm)
Bevel1: TBevel;
Buttons: TButtonPanel;
edLicense: TMemo;
imgDonate: TImage;
imgTransmission: TImage;
imgSynapse: TImage;
imgLazarus: TImage;
txDonate: TLabel;
txHomePage: TLabel;
txAuthor: TLabel;
txVersion: TLabel;
txAppName: TLabel;
Page: TPageControl;
tabAbout: TTabSheet;
tabLicense: TTabSheet;
procedure FormCreate(Sender: TObject);
procedure imgDonateClick(Sender: TObject);
procedure imgLazarusClick(Sender: TObject);
procedure imgSynapseClick(Sender: TObject);
procedure txHomePageClick(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
procedure CheckNewVersion(Async: boolean = True);
procedure GoHomePage;
procedure GoDonate;
implementation
uses Main, utils, httpsend;
type
{ TCheckVersionThread }
TCheckVersionThread = class(TThread)
private
FHttp: THTTPSend;
FError: string;
FVersion: string;
FExit: boolean;
procedure CheckResult;
function GetIntVersion(const Ver: string): integer;
protected
procedure Execute; override;
end;
var
CheckVersionThread: TCheckVersionThread;
procedure CheckNewVersion(Async: boolean);
begin
if CheckVersionThread <> nil then
exit;
Ini.WriteInteger('Interface', 'LastNewVersionCheck', Trunc(Now));
CheckVersionThread:=TCheckVersionThread.Create(True);
CheckVersionThread.FreeOnTerminate:=True;
if Async then
CheckVersionThread.Suspended:=False
else begin
CheckVersionThread.Execute;
CheckVersionThread.FExit:=True;
CheckVersionThread.Suspended:=False;
end;
end;
procedure GoHomePage;
begin
AppBusy;
OpenURL('http://code.google.com/p/transmisson-remote-gui');
AppNormal;
end;
procedure GoDonate;
begin
AppBusy;
OpenURL('http://code.google.com/p/transmisson-remote-gui/wiki/Donate');
AppNormal;
end;
{ TCheckVersionThread }
procedure TCheckVersionThread.CheckResult;
begin
ForceAppNormal;
if FError <> '' then begin
MessageDlg(SErrorCheckingVersion + LineEnding + FError, mtError, [mbOK], 0);
exit;
end;
if GetIntVersion(AppVersion) >= GetIntVersion(FVersion) then begin
MessageDlg(Format(SLatestVersion, [AppName]), mtInformation, [mbOK], 0);
exit;
end;
if MessageDlg(Format(SNewVersionFound, [AppName, AppVersion, FVersion]), mtConfirmation, mbYesNo, 0) <> mrYes then
exit;
Application.ProcessMessages;
AppBusy;
OpenURL('http://code.google.com/p/transmisson-remote-gui/wiki/Download?tm=2');
AppNormal;
end;
function TCheckVersionThread.GetIntVersion(const Ver: string): integer;
var
v: string;
vi, i, j: integer;
begin
Result:=0;
v:=Ver;
for i:=1 to 3 do begin
if v = '' then
vi:=0
else begin
j:=Pos('.', v);
if j = 0 then
j:=MaxInt;
vi:=StrToIntDef(Copy(v, 1, j - 1), 0);
Delete(v, 1, j);
end;
Result:=Result shl 8 or vi;
end;
end;
procedure TCheckVersionThread.Execute;
begin
if not FExit then begin
try
FHttp:=THTTPSend.Create;
try
if RpcObj.Http.ProxyHost <> '' then begin
FHttp.ProxyHost:=RpcObj.Http.ProxyHost;
FHttp.ProxyPort:=RpcObj.Http.ProxyPort;
FHttp.ProxyUser:=RpcObj.Http.ProxyUser;
FHttp.ProxyPass:=RpcObj.Http.ProxyPass;
end;
if FHttp.HTTPMethod('GET', 'http://transmisson-remote-gui.googlecode.com/svn/wiki/version.txt') then begin
if FHttp.ResultCode = 200 then begin
SetString(FVersion, FHttp.Document.Memory, FHttp.Document.Size);
FVersion:=Trim(FVersion);
end
else
FError:=Format('HTTP error: %d', [FHttp.ResultCode]);
end
else
FError:=FHttp.Sock.LastErrorDesc;
finally
FHttp.Free;
end;
except
FError:=Exception(ExceptObject).Message;
end;
if (FError <> '') or (GetIntVersion(FVersion) > GetIntVersion(AppVersion)) or Suspended then
if Suspended then
CheckResult
else
Synchronize(@CheckResult);
end;
if not Suspended then
CheckVersionThread:=nil;
end;
{ TAboutForm }
procedure TAboutForm.imgSynapseClick(Sender: TObject);
begin
AppBusy;
OpenURL('http://synapse.ararat.cz');
AppNormal;
end;
procedure TAboutForm.txHomePageClick(Sender: TObject);
begin
GoHomePage;
end;
procedure TAboutForm.FormCreate(Sender: TObject);
{$ifdef lclcarbon}
var
s: string;
{$endif lclcarbon}
begin
txAppName.Font.Size:=Font.Size + 2;
txHomePage.Font.Size:=Font.Size;
BorderStyle:=bsSizeable;
txAppName.Caption:=AppName;
txVersion.Caption:=Format(txVersion.Caption, [AppVersion]);
Page.ActivePageIndex:=0;
{$ifdef lclcarbon}
s:=edLicense.Text;
edLicense.Text:='';
edLicense.HandleNeeded;
edLicense.Text:=s;
Buttons.BorderSpacing.Right:=Buttons.BorderSpacing.Right + ScaleInt(12);
{$endif lclcarbon}
end;
procedure TAboutForm.imgDonateClick(Sender: TObject);
begin
GoDonate;
end;
procedure TAboutForm.imgLazarusClick(Sender: TObject);
begin
AppBusy;
OpenURL('http://www.lazarus.freepascal.org');
AppNormal;
end;
initialization
{$I about.lrs}
end.
TransGUI/colsetup.lfm 0000644 0000000 0000000 00000003533 12256577645 013575 0 ustar root root inherited ColSetupForm: TColSetupForm
Left = 401
Height = 326
Top = 193
Width = 355
HorzScrollBar.Page = 399
VertScrollBar.Page = 299
AutoSize = True
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Columns setup'
ClientHeight = 326
ClientWidth = 355
Constraints.MinHeight = 200
Constraints.MinWidth = 260
OnCreate = FormCreate
Position = poMainFormCenter
object Buttons: TButtonPanel[0]
Left = 8
Height = 36
Top = 282
Width = 339
BorderSpacing.Left = 8
BorderSpacing.Right = 8
BorderSpacing.Bottom = 8
BorderSpacing.Around = 0
OKButton.Name = 'OKButton'
OKButton.DefaultCaption = True
HelpButton.Name = 'HelpButton'
HelpButton.DefaultCaption = True
CloseButton.Name = 'CloseButton'
CloseButton.DefaultCaption = True
CancelButton.Name = 'CancelButton'
CancelButton.DefaultCaption = True
TabOrder = 1
Spacing = 8
ShowButtons = [pbOK, pbCancel]
end
object Panel1: TPanel[1]
Left = 8
Height = 266
Top = 8
Width = 339
Align = alClient
BorderSpacing.Around = 8
BevelOuter = bvNone
ClientHeight = 266
ClientWidth = 339
TabOrder = 0
object lstColumns: TCheckListBox
Left = 0
Height = 266
Top = 0
Width = 256
Anchors = [akTop, akLeft, akRight, akBottom]
ItemHeight = 0
OnClick = lstColumnsClick
OnClickCheck = lstColumnsClickCheck
TabOrder = 0
end
object btUp: TButton
Left = 264
Height = 23
Top = 0
Width = 75
Anchors = [akTop, akRight]
Caption = 'Up'
OnClick = btUpClick
TabOrder = 1
end
object btDown: TButton
Left = 264
Height = 23
Top = 28
Width = 75
Anchors = [akTop, akRight]
Caption = 'Down'
OnClick = btDownClick
TabOrder = 2
end
end
end
TransGUI/torrprops.pas 0000644 0000000 0000000 00000005270 12261763702 014001 0 ustar root root {*************************************************************************************
This file is part of Transmission Remote GUI.
Copyright (c) 2008-2014 by Yury Sidorov.
Transmission Remote GUI is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
Transmission Remote GUI is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Transmission Remote GUI; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*************************************************************************************}
unit TorrProps;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, Spin, ButtonPanel, ComCtrls, BaseForm;
type
{ TTorrPropsForm }
TTorrPropsForm = class(TBaseForm)
Buttons: TButtonPanel;
cbIdleSeedLimit: TCheckBox;
cbMaxDown: TCheckBox;
cbMaxUp: TCheckBox;
cbSeedRatio: TCheckBox;
edIdleSeedLimit: TSpinEdit;
edMaxUp: TSpinEdit;
edPeerLimit: TSpinEdit;
edSeedRatio: TFloatSpinEdit;
edMaxDown: TSpinEdit;
edTrackers: TMemo;
txTrackers: TLabel;
Page: TPageControl;
tabGeneral: TTabSheet;
tabAdvanced: TTabSheet;
txKbs1: TLabel;
txKbs2: TLabel;
txMinutes: TLabel;
txName: TLabel;
txPeerLimit: TLabel;
procedure cbIdleSeedLimitClick(Sender: TObject);
procedure cbMaxDownClick(Sender: TObject);
procedure cbMaxUpClick(Sender: TObject);
procedure cbSeedRatioClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
implementation
uses main;
{ TTorrPropsForm }
procedure TTorrPropsForm.cbMaxDownClick(Sender: TObject);
begin
edMaxDown.Enabled:=cbMaxDown.Checked;
end;
procedure TTorrPropsForm.cbIdleSeedLimitClick(Sender: TObject);
begin
edIdleSeedLimit.Enabled:=cbIdleSeedLimit.State = cbChecked;
end;
procedure TTorrPropsForm.cbMaxUpClick(Sender: TObject);
begin
edMaxUp.Enabled:=cbMaxUp.Checked;
end;
procedure TTorrPropsForm.cbSeedRatioClick(Sender: TObject);
begin
edSeedRatio.Enabled:=cbSeedRatio.State = cbChecked;
end;
procedure TTorrPropsForm.FormCreate(Sender: TObject);
begin
Page.ActivePageIndex:=0;
end;
initialization
{$I torrprops.lrs}
end.
TransGUI/LICENSE.txt 0000644 0000000 0000000 00000043103 11366572451 013046 0 ustar root root GNU GENERAL PUBLIC LICENSE
Version 2, June 1991
Copyright (C) 1989, 1991 Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users. This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it. (Some other Free Software Foundation software is covered by
the GNU Lesser General Public License instead.) You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.
To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have. You must make sure that they, too, receive or can get the
source code. And you must show them these terms so they know their
rights.
We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.
Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software. If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.
Finally, any free program is threatened constantly by software
patents. We wish to avoid the danger that redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary. To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at all.
The precise terms and conditions for copying, distribution and
modification follow.
GNU GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License applies to any program or other work which contains
a notice placed by the copyright holder saying it may be distributed
under the terms of this General Public License. The "Program", below,
refers to any such program or work, and a "work based on the Program"
means either the Program or any derivative work under copyright law:
that is to say, a work containing the Program or a portion of it,
either verbatim or with modifications and/or translated into another
language. (Hereinafter, translation is included without limitation in
the term "modification".) Each licensee is addressed as "you".
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the
Program (independent of having been made by running the Program).
Whether that is true depends on what the Program does.
1. You may copy and distribute verbatim copies of the Program's
source code as you receive it, in any medium, provided that you
conspicuously and appropriately publish on each copy an appropriate
copyright notice and disclaimer of warranty; keep intact all the
notices that refer to this License and to the absence of any warranty;
and give any other recipients of the Program a copy of this License
along with the Program.
You may charge a fee for the physical act of transferring a copy, and
you may at your option offer warranty protection in exchange for a fee.
2. You may modify your copy or copies of the Program or any portion
of it, thus forming a work based on the Program, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:
a) You must cause the modified files to carry prominent notices
stating that you changed the files and the date of any change.
b) You must cause any work that you distribute or publish, that in
whole or in part contains or is derived from the Program or any
part thereof, to be licensed as a whole at no charge to all third
parties under the terms of this License.
c) If the modified program normally reads commands interactively
when run, you must cause it, when started running for such
interactive use in the most ordinary way, to print or display an
announcement including an appropriate copyright notice and a
notice that there is no warranty (or else, saying that you provide
a warranty) and that users may redistribute the program under
these conditions, and telling the user how to view a copy of this
License. (Exception: if the Program itself is interactive but
does not normally print such an announcement, your work based on
the Program is not required to print an announcement.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Program,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works. But when you
distribute the same sections as part of a whole which is a work based
on the Program, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote it.
Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Program.
In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:
a) Accompany it with the complete corresponding machine-readable
source code, which must be distributed under the terms of Sections
1 and 2 above on a medium customarily used for software interchange; or,
b) Accompany it with a written offer, valid for at least three
years, to give any third party, for a charge no more than your
cost of physically performing source distribution, a complete
machine-readable copy of the corresponding source code, to be
distributed under the terms of Sections 1 and 2 above on a medium
customarily used for software interchange; or,
c) Accompany it with the information you received as to the offer
to distribute corresponding source code. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form with such
an offer, in accord with Subsection b above.)
The source code for a work means the preferred form of the work for
making modifications to it. For an executable work, complete source
code means all the source code for all modules it contains, plus any
associated interface definition files, plus the scripts used to
control compilation and installation of the executable. However, as a
special exception, the source code distributed need not include
anything that is normally distributed (in either source or binary
form) with the major components (compiler, kernel, and so on) of the
operating system on which the executable runs, unless that component
itself accompanies the executable.
If distribution of executable or object code is made by offering
access to copy from a designated place, then offering equivalent
access to copy the source code from the same place counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.
4. You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License. Any attempt
otherwise to copy, modify, sublicense or distribute the Program is
void, and will automatically terminate your rights under this License.
However, parties who have received copies, or rights, from you under
this License will not have their licenses terminated so long as such
parties remain in full compliance.
5. You are not required to accept this License, since you have not
signed it. However, nothing else grants you permission to modify or
distribute the Program or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.
6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program subject to
these terms and conditions. You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.
7. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Program at all. For example, if a patent
license would not permit royalty-free redistribution of the Program by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Program.
If any portion of this section is held invalid or unenforceable under
any particular circumstance, the balance of the section is intended to
apply and the section as a whole is intended to apply in other
circumstances.
It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system, which is
implemented by public license practices. Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.
This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.
8. If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program under this License
may add an explicit geographical distribution limitation excluding
those countries, so that distribution is permitted only in or among
countries not thus excluded. In such case, this License incorporates
the limitation as if written in the body of this License.
9. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the Program
specifies a version number of this License which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation. If the Program does not specify a version number of
this License, you may choose any version ever published by the Free Software
Foundation.
10. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission. For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this. Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.
NO WARRANTY
11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.
12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.
Copyright (C)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License along
with this program; if not, write to the Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
Also add information on how to contact you by electronic and paper mail.
If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:
Gnomovision version 69, Copyright (C) year name of author
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, the commands you use may
be called something other than `show w' and `show c'; they could even be
mouse-clicks or menu items--whatever suits your program.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the program
`Gnomovision' (which makes passes at compilers) written by James Hacker.
, 1 April 1989
Ty Coon, President of Vice
This General Public License does not permit incorporating your program into
proprietary programs. If your program is a subroutine library, you may
consider it more useful to permit linking proprietary applications with the
library. If this is what you want to do, use the GNU Lesser General
Public License instead of this License.
TransGUI/varlist.pas 0000644 0000000 0000000 00000022763 12261763702 013421 0 ustar root root {*************************************************************************************
This file is part of Transmission Remote GUI.
Copyright (c) 2008-2014 by Yury Sidorov.
Transmission Remote GUI is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
Transmission Remote GUI is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Transmission Remote GUI; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*************************************************************************************}
unit varlist;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, variants;
type
TVarList = class;
TCompareVarRowsEvent = function(Sender: TVarList; Row1, Row2: PVariant; DescendingSort: boolean): integer of object;
{ TVarList }
TVarList = class(TList)
private
FColCnt: integer;
FExtraColumns: integer;
FOnCompareVarRows: TCompareVarRowsEvent;
FOnDataChanged: TNotifyEvent;
FUpdateLockCnt: integer;
function GetItemPtr(ACol, ARow: integer): PVariant;
function GetItems(ACol, ARow: integer): variant;
function GetRowCnt: integer;
function GetRowOptions(ARow: integer): integer;
function GetRows(ARow: integer): PVariant;
function GetRow(ARow: integer): PVariant;
procedure SetColCnt(const AValue: integer);
procedure SetExtraColumns(const AValue: integer);
procedure SetItems(ACol, ARow: integer; const AValue: variant);
procedure SetRowCnt(const AValue: integer);
procedure SetRowOptions(ARow: integer; const AValue: integer);
function IntCols: integer;
procedure CheckColIndex(ColIndex: integer);
protected
procedure DoDataChanged; virtual;
public
constructor Create(AColCnt, ARowCnt: integer);
destructor Destroy; override;
procedure Clear; override;
procedure Delete(Index: Integer);
procedure Sort(ACol: integer; Descending: boolean = False); reintroduce;
function IndexOf(ACol: integer; const Value: variant): integer;
function SortedIndexOf(ACol: integer; const Value: variant): integer;
function Find(ACol: integer; const Value: variant; var Index: Integer): Boolean;
procedure BeginUpdate;
procedure EndUpdate;
procedure InsertRow(ARow: integer);
function IsUpdating: boolean;
function GetRowItem(ARow: PVariant; ACol: integer): variant;
property Items[ACol, ARow: integer]: variant read GetItems write SetItems; default;
property ItemPtrs[ACol, ARow: integer]: PVariant read GetItemPtr;
property Rows[ARow: integer]: PVariant read GetRows;
property RowOptions[ARow: integer]: integer read GetRowOptions write SetRowOptions;
property ColCnt: integer read FColCnt write SetColCnt;
property RowCnt: integer read GetRowCnt write SetRowCnt;
property Count: integer read GetRowCnt;
property OnDataChanged: TNotifyEvent read FOnDataChanged write FOnDataChanged;
property OnCompareVarRows: TCompareVarRowsEvent read FOnCompareVarRows write FOnCompareVarRows;
property ExtraColumns: integer read FExtraColumns write SetExtraColumns;
end;
function CompareVariants(const v1, v2: variant): integer;
implementation
uses Math;
{ TVarList }
function TVarList.GetItems(ACol, ARow: integer): variant;
begin
CheckColIndex(ACol);
Result:=GetRow(ARow)[ACol + IntCols];
end;
function TVarList.GetItemPtr(ACol, ARow: integer): PVariant;
begin
CheckColIndex(ACol);
Result:=GetRow(ARow) + (ACol + IntCols);
end;
function TVarList.GetRowCnt: integer;
begin
Result:=inherited GetCount;
end;
function TVarList.GetRowOptions(ARow: integer): integer;
begin
Result:=GetRow(ARow)[0];
end;
function TVarList.GetRows(ARow: integer): PVariant;
begin
Result:=GetRow(ARow);
end;
function TVarList.GetRow(ARow: integer): PVariant;
var
v: PVariant;
sz: integer;
begin
if ARow >= Count then
SetRowCnt(ARow + 1);
v:=Get(ARow);
if v = nil then begin
sz:=SizeOf(variant)*(FColCnt + IntCols);
v:=GetMem(sz);
FillChar(v^, sz, 0);
v[0]:=0;
Put(ARow, v);
end;
Result:=v;
end;
procedure TVarList.SetColCnt(const AValue: integer);
var
i, j, ocnt, ncnt: integer;
p: PVariant;
begin
if FColCnt = AValue then exit;
ocnt:=FColCnt + IntCols;
FColCnt:=AValue;
ncnt:=FColCnt + IntCols;
for i:=0 to Count - 1 do begin
p:=GetRow(i);
for j:=ncnt to ocnt - 1 do
VarClear(p[j]);
ReAllocMem(p, ncnt*SizeOf(variant));
if ncnt > ocnt then
FillChar(p[ocnt], (ncnt - ocnt)*SizeOf(variant), 0);
end;
end;
procedure TVarList.SetExtraColumns(const AValue: integer);
begin
if FExtraColumns=AValue then exit;
if RowCnt <> 0 then
raise Exception.Create('Unable to set extra columns.');
FExtraColumns:=AValue;
end;
procedure TVarList.SetItems(ACol, ARow: integer; const AValue: variant);
begin
GetRow(ARow)[ACol + IntCols]:=AValue;
DoDataChanged;
end;
procedure TVarList.SetRowCnt(const AValue: integer);
begin
BeginUpdate;
try
while Count > AValue do
Delete(Count - 1);
SetCount(AValue);
finally
EndUpdate;
end;
end;
procedure TVarList.SetRowOptions(ARow: integer; const AValue: integer);
begin
GetRow(ARow)[0]:=AValue;
end;
function TVarList.IntCols: integer;
begin
Result:=FExtraColumns + 1;
end;
procedure TVarList.CheckColIndex(ColIndex: integer);
begin
if (ColIndex + IntCols < 0) or (ColIndex >= ColCnt) then
raise Exception.CreateFmt('Invalid column index (%d).', [ColIndex]);
end;
procedure TVarList.DoDataChanged;
begin
if Assigned(FOnDataChanged) and (FUpdateLockCnt = 0) then
FOnDataChanged(Self);
end;
constructor TVarList.Create(AColCnt, ARowCnt: integer);
begin
inherited Create;
FColCnt:=AColCnt;
RowCnt:=ARowCnt;
end;
destructor TVarList.Destroy;
begin
FOnDataChanged:=nil;
inherited Destroy;
end;
procedure TVarList.Clear;
var
i: integer;
v: PVariant;
begin
for i:=0 to Count - 1 do begin
v:=inherited Get(i);
if v <> nil then begin
VarClear(v^);
FreeMem(v);
end;
end;
inherited Clear;
DoDataChanged;
end;
procedure TVarList.Delete(Index: Integer);
var
v: PVariant;
i: integer;
begin
v:=inherited Get(Index);
if v <> nil then begin
for i:=0 to ColCnt + IntCols - 1 do
VarClear(v[i]);
FreeMem(v);
end;
inherited Delete(Index);
DoDataChanged;
end;
function CompareVariants(const v1, v2: variant): integer;
var
v1e, v2e: boolean;
begin
v1e:=VarIsNull(v1) or VarIsEmpty(v1);
v2e:=VarIsNull(v2) or VarIsEmpty(v2);
if v1e and v2e then
Result:=0
else
if v1e and not v2e then
Result:=-1
else
if not v1e and v2e then
Result:=1
else
case VarType(v1) of
varInteger,varsmallint,varshortint,varbyte,varword,varlongword,varint64,varqword:
Result:=Int64(v1) - Int64(v2);
varDouble,varSingle,varDate:
Result:=Sign(double(v1) - double(v2));
else
Result:=AnsiCompareText(v1, v2);
end;
end;
var
_SortColumn: integer;
_SortDesc: boolean;
_IntCols: integer;
_List: TVarList;
function CompareItems(Item1, Item2: Pointer): Integer;
var
v1, v2: PVariant;
i: integer;
begin
if Item1 = Item2 then begin
Result:=0;
exit;
end;
v1:=Item1;
v2:=Item2;
if Assigned(_List.OnCompareVarRows) then
Result:=_List.OnCompareVarRows(_List, v1, v2, _SortDesc)
else
Result:=0;
if Result = 0 then begin
Result:=CompareVariants(v1[_SortColumn], v2[_SortColumn]);
i:=_IntCols;
while (Result = 0) and (i < _List.ColCnt + _IntCols) do begin
if i <> _SortColumn then
Result:=CompareVariants(v1[i], v2[i]);
Inc(i);
end;
if _SortDesc then
Result:=-Result;
end;
end;
procedure TVarList.Sort(ACol: integer; Descending: boolean);
begin
_SortColumn:=ACol + IntCols;
_SortDesc:=Descending;
_IntCols:=IntCols;
_List:=Self;
inherited Sort(@CompareItems);
DoDataChanged;
end;
function TVarList.IndexOf(ACol: integer; const Value: variant): integer;
var
i: integer;
begin
for i:=0 to RowCnt - 1 do
if CompareVariants(Items[ACol, i], Value) = 0 then begin
Result:=i;
exit;
end;
Result:=-1;
end;
function TVarList.SortedIndexOf(ACol: integer; const Value: variant): integer;
begin
Result:=-1;
if not Find(ACol, Value, Result) then
Result:=-1;
end;
function TVarList.Find(ACol: integer; const Value: variant; var Index: Integer): Boolean;
var
L, R, I: Integer;
CompareRes: PtrInt;
begin
Result := false;
L := 0;
R := Count - 1;
while (L<=R) do
begin
I := L + (R - L) div 2;
CompareRes := CompareVariants(Value, Items[ACol, I]);
if (CompareRes>0) then
L := I+1
else begin
R := I-1;
if (CompareRes=0) then begin
Result := true;
L := I; // forces end of while loop
end;
end;
end;
Index := L;
end;
procedure TVarList.BeginUpdate;
begin
Inc(FUpdateLockCnt);
end;
procedure TVarList.EndUpdate;
begin
Dec(FUpdateLockCnt);
if FUpdateLockCnt = 0 then
DoDataChanged;
end;
procedure TVarList.InsertRow(ARow: integer);
begin
inherited Insert(ARow, nil);
end;
function TVarList.IsUpdating: boolean;
begin
Result:=FUpdateLockCnt > 0;
end;
function TVarList.GetRowItem(ARow: PVariant; ACol: integer): variant;
begin
CheckColIndex(ACol);
Result:=ARow[ACol + IntCols];
end;
end.
TransGUI/download.lfm 0000644 0000000 0000000 00000002760 12226736740 013535 0 ustar root root inherited DownloadForm: TDownloadForm
Left = 390
Height = 106
Top = 278
Width = 404
HorzScrollBar.Page = 403
HorzScrollBar.Range = 392
VertScrollBar.Page = 105
VertScrollBar.Range = 95
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Downloading'
ClientHeight = 106
ClientWidth = 404
OnClose = FormClose
OnCreate = FormCreate
OnDestroy = FormDestroy
OnResize = FormResize
OnShow = FormShow
Position = poMainFormCenter
object txFileName: TLabel[0]
Left = 12
Height = 14
Top = 8
Width = 54
Caption = 'txFileName'
ParentColor = False
end
object txBytes: TLabel[1]
Left = 12
Height = 14
Top = 28
Width = 38
Caption = 'txBytes'
ParentColor = False
end
object txPercent: TLabel[2]
Left = 344
Height = 14
Top = 28
Width = 48
Alignment = taRightJustify
Anchors = [akTop, akRight]
Caption = 'txPercent'
ParentColor = False
end
object btCancel: TButton[3]
Left = 160
Height = 23
Top = 72
Width = 75
AutoSize = True
Cancel = True
Caption = 'Cancel'
Constraints.MinWidth = 75
Default = True
OnClick = btCancelClick
TabOrder = 0
end
object pbDownload: TProgressBar[4]
Left = 12
Height = 16
Top = 44
Width = 380
Anchors = [akTop, akLeft, akRight]
Smooth = True
Step = 1
TabOrder = 1
end
object UpdateTimer: TTimer[5]
Interval = 300
OnTimer = UpdateTimerTimer
left = 36
top = 68
end
end
TransGUI/addtorrent.pas 0000644 0000000 0000000 00000062541 12261763702 014101 0 ustar root root {*************************************************************************************
This file is part of Transmission Remote GUI.
Copyright (c) 2008-2014 by Yury Sidorov.
Transmission Remote GUI is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
Transmission Remote GUI is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Transmission Remote GUI; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*************************************************************************************}
unit AddTorrent;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, Spin, VarGrid, Grids,
ButtonPanel, ExtCtrls, BaseForm, varlist, fpjson;
resourcestring
SSize = 'Size';
SSelectDownloadFolder = 'Select a folder for download';
SInvalidName = 'Invalid name specified.';
type
TFilesTree = class;
{ TAddTorrentForm }
TAddTorrentForm = class(TBaseForm)
btSelectAll: TButton;
btSelectNone: TButton;
btBrowse: TButton;
Buttons: TButtonPanel;
cbStartTorrent: TCheckBox;
cbDestFolder: TComboBox;
edSaveAs: TEdit;
gbSaveAs: TGroupBox;
gbContents: TGroupBox;
edPeerLimit: TSpinEdit;
DiskSpaceTimer: TTimer;
txSaveAs: TLabel;
txSize: TLabel;
txDiskSpace: TLabel;
txPeerLimit: TLabel;
lvFiles: TVarGrid;
txDestFolder: TLabel;
procedure btBrowseClick(Sender: TObject);
procedure btSelectAllClick(Sender: TObject);
procedure btSelectNoneClick(Sender: TObject);
procedure cbDestFolderChange(Sender: TObject);
procedure DiskSpaceTimerTimer(Sender: TObject);
procedure edSaveAsChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure OKButtonClick(Sender: TObject);
private
FDiskSpaceCaption: string;
FTree: TFilesTree;
procedure TreeStateChanged(Sender: TObject);
procedure UpdateSize;
public
OrigCaption: string;
property FilesTree: TFilesTree read FTree;
end;
TFolderInfo = record
Size: double;
DoneSize: double;
Priority: integer;
chk: TCheckBoxState;
end;
{ TFilesTree }
TFilesTree = class(TComponent)
private
FCheckboxes: boolean;
FDownloadDir: string;
FGrid: TVarGrid;
FHasFolders: boolean;
FIsPlain: boolean;
FOnStateChange: TNotifyEvent;
FFiles: TVarList;
FTorrentId: integer;
FLastFileCount: integer;
FCommonPathLen: integer;
FHasDone: boolean;
FHasPriority: boolean;
procedure CollapseFolder(ARow: integer);
procedure DoCellAttributes(Sender: TVarGrid; ACol, ARow, ADataCol: integer; AState: TGridDrawState; var CellAttribs: TCellAttributes);
procedure DoCheckBoxClick(Sender: TVarGrid; ACol, ARow, ADataCol: integer);
procedure DoDrawCell(Sender: TVarGrid; ACol, ARow, ADataCol: integer; AState: TGridDrawState; const R: TRect; var ADefaultDrawing: boolean);
procedure DoQuickSearch(Sender: TVarGrid; var SearchText: string; var ARow: integer);
procedure DoTreeButtonClick(Sender: TVarGrid; ACol, ARow, ADataCol: integer);
procedure DoAfterSort(Sender: TObject);
procedure ExpandFolder(ARow: integer);
function GetChecked(ARow: integer): TCheckBoxState;
function GetExpanded(ARow: integer): boolean;
function GetLevel(ARow: integer): integer;
procedure SetCheckboxes(const AValue: boolean);
procedure IntSetChecked(ARow: integer; const AValue: TCheckBoxState);
procedure SetChecked(ARow: integer; const AValue: TCheckBoxState);
procedure SetExpanded(ARow: integer; const AValue: boolean);
procedure SetIsPlain(const AValue: boolean);
procedure TreeChanged;
procedure DoOnStateChange;
function DoCompareVarRows(Sender: TVarList; Row1, Row2: PVariant; DescendingSort: boolean): integer;
procedure SetRowOption(ARow, AOption: integer; DoSet: boolean);
public
constructor Create(AGrid: TVarGrid); reintroduce;
destructor Destroy; override;
function IsFolder(ARow: integer): boolean;
procedure CollapseAll;
procedure FillTree(ATorrentId: integer; files, priorities, wanted: TJSONArray);
procedure SetStateAll(AState: TCheckBoxState);
procedure EnsureRowVisible(ARow: integer);
function GetFullPath(ARow: integer; AbsolutePath: boolean = True): string;
function UpdateSummary: TFolderInfo;
procedure Clear;
property Grid: TVarGrid read FGrid;
property HasFolders: boolean read FHasFolders;
property Checkboxes: boolean read FCheckboxes write SetCheckboxes;
property IsPlain: boolean read FIsPlain write SetIsPlain;
property DownloadDir: string read FDownloadDir write FDownloadDir;
property Expanded[ARow: integer]: boolean read GetExpanded write SetExpanded;
property Checked[ARow: integer]: TCheckBoxState read GetChecked write SetChecked;
property RowLevel[ARow: integer]: integer read GetLevel;
property OnStateChange: TNotifyEvent read FOnStateChange write FOnStateChange;
end;
const
// Files list columns
idxFileName = 0;
idxFileSize = 1;
idxFileDone = 2;
idxFileProgress = 3;
idxFilePriority = 4;
idxFileId = -1;
idxFileFullPath = -2;
idxFileLevel = -3;
idxFileIndex = -4;
FilesExtraColumns = 4;
implementation
uses lclintf, lcltype, main, variants, Utils, rpc, lclproc;
const
roChecked = $030000;
roCollapsed = $040000;
roHidden = $080000;
roTag = $100000;
roCheckedShift = 16;
TR_PRI_MIXED = -1001; // psedudo priority
{ TFilesTree }
constructor TFilesTree.Create(AGrid: TVarGrid);
begin
inherited Create(AGrid);
FGrid:=AGrid;
FFiles:=FGrid.Items;
FGrid.OnCheckBoxClick:=@DoCheckBoxClick;
FGrid.OnTreeButtonClick:=@DoTreeButtonClick;
FGrid.OnCellAttributes:=@DoCellAttributes;
FGrid.OnAfterSort:=@DoAfterSort;
FGrid.OnQuickSearch:=@DoQuickSearch;
FGrid.OnDrawCell:=@DoDrawCell;
end;
destructor TFilesTree.Destroy;
begin
inherited Destroy;
end;
function TFilesTree.IsFolder(ARow: integer): boolean;
begin
Result:=VarIsEmpty(FGrid.Items[idxFileId, ARow]);
end;
procedure TFilesTree.CollapseAll;
var
i: integer;
begin
FGrid.BeginUpdate;
try
for i:=0 to FGrid.Items.Count - 1 do begin
if IsFolder(i) then
SetRowOption(i, roCollapsed, True);
if integer(FGrid.Items[idxFileLevel, i]) > 0 then begin
FGrid.RowVisible[i]:=False;
FGrid.RowSelected[i]:=False;
SetRowOption(i, roHidden, True);
end;
end;
TreeChanged;
finally
FGrid.EndUpdate;
end;
end;
procedure TFilesTree.FillTree(ATorrentId: integer; files, priorities, wanted: TJSONArray);
procedure _AddFolders(list: TVarList; const path: string; var idx: integer; cnt, level: integer);
var
s, ss: string;
j: integer;
p: PChar;
begin
while idx < cnt do begin
s:=ExtractFilePath(UTF8Encode(widestring(list[idxFileFullPath, idx])));
if s = '' then begin
Inc(idx);
continue;
end;
if (path <> '') and (Pos(path, s) <> 1) then
break;
if s = path then begin
list[idxFileLevel, idx]:=level;
Inc(idx);
end
else begin
ss:=Copy(s, Length(path) + 1, MaxInt);
p:=PChar(ss);
while (p^ <> #0) and not (p^ in ['/','\']) do
Inc(p);
if p^ <> #0 then begin
SetLength(ss, p - PChar(ss) + 1);
j:=list.Count;
list[idxFileLevel, j]:=level;
list[idxFileFullPath, j]:=UTF8Decode(path + ss);
_AddFolders(list, path + ss, idx, cnt, level + 1);
ss:=ExcludeTrailingPathDelimiter(ss);
list[idxFileName, j]:=UTF8Decode(ExtractFileName(ss));
end;
end;
end;
end;
var
i, row: integer;
FullRefresh: boolean;
f: TJSONObject;
s, ss, path: string;
ff: double;
begin
if files = nil then begin
FGrid.Items.Clear;
exit;
end;
FHasDone:=FGrid.Columns.Count > idxFileDone;
FHasPriority:=FHasDone and (priorities <> nil) and (wanted <> nil);
FullRefresh:=(FTorrentId <> ATorrentId) or (FLastFileCount <> files.Count);
FLastFileCount:=files.Count;
FTorrentId:=ATorrentId;
FIsPlain:=FGrid.SortColumn <> idxFileName;
FFiles.BeginUpdate;
try
FFiles.OnCompareVarRows:=nil;
if FullRefresh then
FFiles.Clear
else begin
for i:=0 to FFiles.Count - 1 do
SetRowOption(i, roTag, False);
FFiles.Sort(idxFileId);
end;
// Detecting top level folder to be removed
FCommonPathLen:=0;
path:='';
if files.Count > 0 then begin
s:=UTF8Encode(files.Objects[0].Strings['name']);
FCommonPathLen:=Pos(RemotePathDelimiter, s);
if FCommonPathLen > 0 then
path:=Copy(s, 1, FCommonPathLen);
end;
FHasFolders:=False;
for i:=0 to files.Count - 1 do begin
f:=files.Objects[i];
if FullRefresh then begin
row:=i;
FFiles[idxFileLevel, row]:=0;
end
else
if not FFiles.Find(idxFileId, i, row) then begin
FFiles.InsertRow(row);
FFiles[idxFileLevel, row]:=0;
end;
SetRowOption(row, roTag, True);
FFiles[idxFileId, row]:=i;
s:=UTF8Encode(f.Strings['name']);
FFiles[idxFileFullPath, row]:=UTF8Decode(ExtractFilePath(s));
if FCommonPathLen > 0 then
s:=Copy(s, FCommonPathLen + 1, MaxInt);
ss:=ExtractFileName(s);
if ss <> s then
FHasFolders:=True;
FFiles[idxFileName, row]:=UTF8Decode(ss);
ff:=f.Floats['length'];
FFiles[idxFileSize, row]:=ff;
if FHasDone then begin
FFiles[idxFileDone, row]:=f.Floats['bytesCompleted'];
if ff = 0 then
ff:=100.0
else
ff:=double(FFiles[idxFileDone, row])*100.0/ff;
FFiles[idxFileProgress, row]:=Int(ff*10.0)/10.0;
if FHasPriority then begin
if wanted.Integers[i] = 0 then begin
FFiles[idxFilePriority, row]:=TR_PRI_SKIP;
IntSetChecked(row, cbUnchecked);
end
else begin
FFiles[idxFilePriority, row]:=priorities.Integers[i];
IntSetChecked(row, cbChecked);
end;
end;
end;
end;
if not FullRefresh then begin
i:=0;
while i < FFiles.Count do
if not IsFolder(i) and not LongBool(FFiles.RowOptions[i] and roTag) then
FFiles.Delete(i)
else
Inc(i);
end;
if HasFolders and FullRefresh then begin
FFiles.Sort(idxFileFullPath);
i:=0;
_AddFolders(FFiles, path, i, FFiles.Count, 0);
end;
FFiles.OnCompareVarRows:=@DoCompareVarRows;
FGrid.Sort;
if FullRefresh and (FFiles.Count > 0) then begin
FGrid.Row:=0;
if HasFolders then begin
i:=FFiles.RowCnt + FGrid.FixedRows;
if FGrid.RowCount <> i then
FGrid.RowCount:=i;
CollapseAll;
end
else
TreeChanged;
end
else
TreeChanged;
if not IsPlain then
UpdateSummary;
finally
FFiles.EndUpdate;
end;
end;
procedure TFilesTree.SetStateAll(AState: TCheckBoxState);
var
i: integer;
begin
FFiles.BeginUpdate;
try
for i:=0 to FFiles.Count - 1 do
IntSetChecked(i, AState);
finally
FFiles.EndUpdate;
end;
DoOnStateChange;
end;
procedure TFilesTree.EnsureRowVisible(ARow: integer);
var
i, level: integer;
begin
if not FGrid.RowVisible[ARow] then begin
FGrid.BeginUpdate;
try
level:=FFiles[idxFileLevel, ARow] - 1;
for i:=ARow downto 0 do begin
if IsFolder(i) and (FFiles[idxFileLevel, i] = level) then begin
ExpandFolder(i);
if level = 0 then
break;
Dec(level);
end;
end;
finally
FGrid.EndUpdate;
end;
end;
FGrid.EnsureRowVisible(ARow);
end;
function TFilesTree.GetFullPath(ARow: integer; AbsolutePath: boolean): string;
begin
if AbsolutePath then begin
Result:=FDownloadDir;
if Copy(Result, Length(Result), 1) <> RemotePathDelimiter then
Result:=Result + RemotePathDelimiter;
end
else
Result:='';
Result:=Result + UTF8Encode(widestring(FFiles[idxFileFullPath, ARow]));
if IsFolder(ARow) then
Result:=Copy(Result, 1, Length(Result) - 1)
else
Result:=Result + UTF8Encode(widestring(FFiles[idxFileName, ARow]));
end;
function TFilesTree.UpdateSummary: TFolderInfo;
function _UpdateSummary(var idx: integer; cnt, level: integer): TFolderInfo;
var
i, j: integer;
IsFirst: boolean;
begin
FillChar(Result, SizeOf(Result), 0);
IsFirst:=True;
while idx < cnt do begin
if FFiles[idxFileLevel, idx] <> level then
break;
i:=idx;
Inc(idx);
if IsFolder(i) then begin
with _UpdateSummary(idx, cnt, level + 1) do begin
FFiles[idxFileSize, i]:=Size;
if FHasDone then begin
FFiles[idxFileDone, i]:=DoneSize;
if Size = 0 then
DoneSize:=100.0
else
DoneSize:=DoneSize*100.0/Size;
FFiles[idxFileProgress, i]:=Int(DoneSize*10.0)/10.0;
end;
if FHasPriority then begin
FFiles[idxFilePriority, i]:=Priority;
IntSetChecked(i, chk);
end;
end;
end;
with Result do begin
Size:=Size + FFiles[idxFileSize, i];
if FHasDone then
DoneSize:=DoneSize + FFiles[idxFileDone, i];
if FHasPriority then begin
j:=FFiles[idxFilePriority, i];
if IsFirst then begin
IsFirst:=False;
Priority:=j;
chk:=Checked[i];
end
else begin
if Priority <> j then
Priority:=TR_PRI_MIXED;
if chk <> Checked[i] then
chk:=cbGrayed;
end;
end;
end;
end;
end;
var
i: integer;
begin
FFiles.BeginUpdate;
try
i:=0;
Result:=_UpdateSummary(i, FFiles.Count, 0);
finally
FFiles.EndUpdate;
end;
end;
procedure TFilesTree.Clear;
begin
FLastFileCount:=0;
FTorrentId:=0;
FFiles.Clear;
end;
procedure TFilesTree.DoCheckBoxClick(Sender: TVarGrid; ACol, ARow, ADataCol: integer);
begin
if Checked[ARow] = cbChecked then
Checked[ARow]:=cbUnchecked
else
Checked[ARow]:=cbChecked;
end;
procedure TFilesTree.DoTreeButtonClick(Sender: TVarGrid; ACol, ARow, ADataCol: integer);
begin
Expanded[ARow]:=not Expanded[ARow];
end;
procedure TFilesTree.DoAfterSort(Sender: TObject);
var
p: boolean;
begin
p:=FGrid.SortColumn <> idxFileName;
if p <> IsPlain then
IsPlain:=p
else
TreeChanged;
end;
procedure TFilesTree.CollapseFolder(ARow: integer);
var
i, lev: integer;
begin
AppBusy;
FGrid.BeginUpdate;
try
lev:=FGrid.Items[idxFileLevel, ARow];
SetRowOption(ARow, roCollapsed, True);
for i:=ARow + 1 to FGrid.Items.Count - 1 do
if integer(FGrid.Items[idxFileLevel, i]) > lev then begin
FGrid.RowVisible[i]:=False;
FGrid.RowSelected[i]:=False;
SetRowOption(i, roHidden, True);
end
else
break;
TreeChanged;
finally
FGrid.EndUpdate;
end;
AppNormal;
end;
procedure TFilesTree.ExpandFolder(ARow: integer);
var
i, j, lev: integer;
begin
AppBusy;
FGrid.BeginUpdate;
try
lev:=FGrid.Items[idxFileLevel, ARow] + 1;
SetRowOption(ARow, roCollapsed, False);
for i:=ARow + 1 to FGrid.Items.Count - 1 do begin
j:=integer(FGrid.Items[idxFileLevel, i]);
if j = lev then begin
FGrid.RowVisible[i]:=True;
SetRowOption(i, roHidden, False);
if IsFolder(i) and Expanded[i] then
ExpandFolder(i);
end
else
if j <= lev then
break;
end;
TreeChanged;
finally
FGrid.EndUpdate;
end;
AppNormal;
end;
function TFilesTree.GetChecked(ARow: integer): TCheckBoxState;
begin
Result:=TCheckBoxState((FFiles.RowOptions[ARow] and roChecked) shr roCheckedShift);
end;
function TFilesTree.GetExpanded(ARow: integer): boolean;
begin
Result:=not LongBool(FFiles.RowOptions[ARow] and roCollapsed);
end;
function TFilesTree.GetLevel(ARow: integer): integer;
begin
Result:=FFiles[idxFileLevel, ARow];
end;
procedure TFilesTree.SetCheckboxes(const AValue: boolean);
begin
if FCheckboxes = AValue then exit;
FCheckboxes:=AValue;
end;
procedure TFilesTree.IntSetChecked(ARow: integer; const AValue: TCheckBoxState);
begin
FFiles.RowOptions[ARow]:=(FFiles.RowOptions[ARow] and not roChecked) or (integer(AValue) shl roCheckedShift);
end;
procedure TFilesTree.SetChecked(ARow: integer; const AValue: TCheckBoxState);
var
i, lev: integer;
st: TCheckBoxState;
begin
st:=AValue;
if st = cbGrayed then
st:=cbUnchecked;
if Checked[ARow] = st then
exit;
IntSetChecked(ARow, st);
FGrid.InvalidateRow(ARow + FGrid.FixedRows);
if not IsPlain then begin
lev:=integer(FFiles[idxFileLevel, ARow]);
if IsFolder(ARow) then begin
FFiles.BeginUpdate;
for i:=ARow + 1 to FFiles.Count - 1 do
if integer(FFiles[idxFileLevel, i]) <= lev then
break
else
IntSetChecked(i, st);
FFiles.EndUpdate;
end;
if lev > 0 then begin
i:=ARow + 1;
while (i < FFiles.Count) and (integer(FFiles[idxFileLevel, i]) >= lev) do
Inc(i);
for i:=i - 1 downto 0 do begin
if IsFolder(i) and (integer(FFiles[idxFileLevel, i]) < lev) then begin
IntSetChecked(i, st);
FGrid.InvalidateRow(i + FGrid.FixedRows);
Dec(lev);
if lev = 0 then
break;
end
else
if Checked[i] <> st then
st:=cbGrayed;
end;
end;
end;
DoOnStateChange;
end;
procedure TFilesTree.SetExpanded(ARow: integer; const AValue: boolean);
begin
if GetExpanded(ARow) <> AValue then
if AValue then
ExpandFolder(ARow)
else
CollapseFolder(ARow);
end;
procedure TFilesTree.SetIsPlain(const AValue: boolean);
begin
if FIsPlain = AValue then exit;
FIsPlain:=AValue;
FFiles.BeginUpdate;
try
TreeChanged;
if not FIsPlain then
UpdateSummary;
finally
FFiles.EndUpdate;
end;
if FFiles.Count > 0 then
FGrid.Row:=0;
end;
procedure TFilesTree.TreeChanged;
var
i, j: integer;
f: boolean;
begin
FGrid.Items.BeginUpdate;
try
FGrid.RowCount:=FFiles.RowCnt + FGrid.FixedRows;
j:=0;
for i:=0 to FGrid.Items.Count - 1 do begin
if IsPlain then
f:=not IsFolder(i)
else
f:=not LongBool(FFiles.RowOptions[i] and roHidden);
FGrid.RowVisible[i]:=f;
if f then begin
FGrid.Items[idxFileIndex, i]:=j;
Inc(j);
end;
end;
finally
FGrid.Items.EndUpdate;
end;
end;
procedure TFilesTree.DoOnStateChange;
begin
if Assigned(FOnStateChange) then
FOnStateChange(Self);
end;
function TFilesTree.DoCompareVarRows(Sender: TVarList; Row1, Row2: PVariant; DescendingSort: boolean): integer;
begin
if FGrid.SortColumn <> idxFileName then begin
Result:=(integer(VarIsEmpty(Sender.GetRowItem(Row1, idxFileId))) and 1) - (integer(VarIsEmpty(Sender.GetRowItem(Row2, idxFileId))) and 1);
exit;
end;
Result:=CompareVariants(Sender.GetRowItem(Row1, idxFileFullPath), Sender.GetRowItem(Row2, idxFileFullPath));
if Result <> 0 then
exit;
Result:=(integer(VarIsEmpty(Sender.GetRowItem(Row2, idxFileId))) and 1) - (integer(VarIsEmpty(Sender.GetRowItem(Row1, idxFileId))) and 1);
if Result <> 0 then
exit;
Result:=CompareVariants(Sender.GetRowItem(Row1, idxFileName), Sender.GetRowItem(Row2, idxFileName));
if DescendingSort then
Result:=-Result;
end;
procedure TFilesTree.SetRowOption(ARow, AOption: integer; DoSet: boolean);
var
i: integer;
begin
i:=FFiles.RowOptions[ARow];
if DoSet then
FFiles.RowOptions[ARow]:=i or AOption
else
FFiles.RowOptions[ARow]:=i and not AOption;
end;
procedure TFilesTree.DoCellAttributes(Sender: TVarGrid; ACol, ARow, ADataCol: integer; AState: TGridDrawState; var CellAttribs: TCellAttributes);
var
i: integer;
begin
if ARow < 0 then exit;
with CellAttribs do begin
if not (gdSelected in AState) and (integer(Sender.Items[idxFileIndex, ARow]) and 1 = 1) then
Sender.Canvas.Brush.Color:=FAlterColor;
if Text = '' then exit;
case ADataCol of
0:
begin
// Text:=UTF8Encode(Sender.Items[idxFileFullPath, ARow]) + ' (' + Text + ')';
if Checkboxes then begin
Options:=[coDrawCheckBox];
State:=Checked[ARow];
end;
if IsPlain then begin
Text:=Copy(UTF8Encode(widestring(Sender.Items[idxFileFullPath, ARow])), FCommonPathLen + 1, MaxInt) + Text;
end
else begin
Indent:=integer(Sender.Items[idxFileLevel, ARow])*16;
if IsFolder(ARow) then begin
Include(Options, coDrawTreeButton);
Expanded:=Self.Expanded[ARow];
ImageIndex:=22;
end
else
if HasFolders then
Inc(Indent, Sender.RowHeights[ARow + Sender.FixedRows]);
end;
end;
idxFileSize, idxFileDone:
Text:=GetHumanSize(double(Sender.Items[ADataCol, ARow]));
idxFileProgress:
Text:=Format('%.1f%%', [double(Sender.Items[ADataCol, ARow])]);
idxFilePriority:
begin
i:=Sender.Items[idxFilePriority, ARow];
if i = TR_PRI_MIXED then
Text:=''
else
Text:=PriorityToStr(i, ImageIndex);
end;
end;
end;
end;
procedure TFilesTree.DoDrawCell(Sender: TVarGrid; ACol, ARow, ADataCol: integer; AState: TGridDrawState; const R: TRect;
var ADefaultDrawing: boolean);
begin
if ARow < 0 then exit;
if ADataCol = idxFileProgress then begin
ADefaultDrawing:=False;
DrawProgressCell(Sender, ACol, ARow, ADataCol, AState, R);
end;
end;
procedure TFilesTree.DoQuickSearch(Sender: TVarGrid; var SearchText: string; var ARow: integer);
var
i: integer;
s: string;
v: variant;
begin
s:=UTF8UpperCase(SearchText);
for i:=ARow to Sender.Items.Count - 1 do begin
v:=Sender.Items[idxFileName, i];
if VarIsEmpty(v) or VarIsNull(v) or (IsPlain and IsFolder(i)) then
continue;
if Pos(s, Trim(UTF8UpperCase(UTF8Encode(widestring(v))))) > 0 then begin
ARow:=i;
EnsureRowVisible(ARow);
break;
end;
end;
end;
{ TAddTorrentForm }
procedure TAddTorrentForm.FormShow(Sender: TObject);
begin
AppBusy;
lvFiles.BeginUpdate;
try
btSelectAllClick(nil);
{
lvFiles.Sort;
if lvFiles.Items.Count > 0 then
lvFiles.Row:=0;
}
// FTree.CollapseAll;
finally
lvFiles.EndUpdate;
end;
DiskSpaceTimerTimer(nil);
AppNormal;
end;
procedure TAddTorrentForm.OKButtonClick(Sender: TObject);
begin
if edSaveAs.Enabled then begin
edSaveAs.Text:=Trim(edSaveAs.Text);
if edSaveAs.Text = '' then begin
edSaveAs.SetFocus;
MessageDlg(SInvalidName, mtError, [mbOK], 0);
exit;
end;
end;
ModalResult:=mrOK;
end;
procedure TAddTorrentForm.UpdateSize;
var
i: integer;
d, sz, tsz: double;
s: string;
begin
sz:=0;
tsz:=0;
for i:=0 to lvFiles.Items.Count - 1 do
if not FTree.IsFolder(i) then begin
d:=double(lvFiles.Items[idxFileSize, i]);
tsz:=tsz + d;
if FTree.Checked[i] = cbChecked then
sz:=sz + d;
end;
s:=GetHumanSize(sz);
if s <> GetHumanSize(tsz) then
s:=s + ' / ' + GetHumanSize(tsz);
txSize.Caption:=Format('%s: %s', [SSize, s]);
end;
procedure TAddTorrentForm.btSelectAllClick(Sender: TObject);
begin
FTree.SetStateAll(cbChecked);
end;
procedure TAddTorrentForm.btBrowseClick(Sender: TObject);
var
s: string;
begin
s:=MainForm.SelectRemoteFolder(cbDestFolder.Text, SSelectDownloadFolder);
if s <> '' then
cbDestFolder.Text:=s;
end;
procedure TAddTorrentForm.btSelectNoneClick(Sender: TObject);
begin
FTree.SetStateAll(cbUnchecked);
end;
procedure TAddTorrentForm.cbDestFolderChange(Sender: TObject);
begin
DiskSpaceTimer.Enabled:=True;
end;
procedure TAddTorrentForm.DiskSpaceTimerTimer(Sender: TObject);
var
f: double;
req, args: TJSONObject;
begin
DiskSpaceTimer.Enabled:=False;
if RpcObj.RPCVersion < 15 then
exit;
AppBusy;
f:=-1;
try
req:=TJSONObject.Create;
args:=TJSONObject.Create;
try
req.Add('method', 'free-space');
args.Add('path', UTF8Decode(cbDestFolder.Text));
req.Add('arguments', args);
args:=RpcObj.SendRequest(req);
if args <> nil then
f:=args.Floats['size-bytes'];
RpcObj.Status:='';
finally
args.Free;
req.Free;
end;
except
f:=-1;
end;
txDiskSpace.Caption:=FDiskSpaceCaption + ' ' + GetHumanSize(f);
AppNormal;
end;
procedure TAddTorrentForm.edSaveAsChange(Sender: TObject);
begin
Caption:=OrigCaption + ' - ' + edSaveAs.Text;
end;
procedure TAddTorrentForm.TreeStateChanged(Sender: TObject);
begin
UpdateSize;
end;
procedure TAddTorrentForm.FormCreate(Sender: TObject);
begin
OrigCaption:=Caption;
FDiskSpaceCaption:=txDiskSpace.Caption;
lvFiles.Items.ExtraColumns:=FilesExtraColumns;
FTree:=TFilesTree.Create(lvFiles);
FTree.Checkboxes:=True;
FTree.OnStateChange:=@TreeStateChanged;
Buttons.OKButton.ModalResult:=mrNone;
{$ifdef windows}
gbSaveAs.Caption:='';
{$endif windows}
{$ifdef darwin}
Buttons.BorderSpacing.Right:=Buttons.BorderSpacing.Right + ScaleInt(12);
{$endif darwin}
end;
initialization
{$I addtorrent.lrs}
end.
TransGUI/lineinfo2.pp 0000644 0000000 0000000 00000020040 11737136325 013442 0 ustar root root {
This file is part of the Free Pascal run time library.
Copyright (c) 2000 by Peter Vreman
Stabs Line Info Retriever
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{
This unit should not be compiled in objfpc mode, since this would make it
dependent on objpas unit.
}
unit lineinfo2;
interface
{$S-}
{$Q-}
function GetLineInfo(addr:ptruint;var func,source:string;var line:longint) : boolean;
implementation
uses
exeinfo,strings;
const
N_Function = $24;
N_TextLine = $44;
N_DataLine = $46;
N_BssLine = $48;
N_SourceFile = $64;
N_IncludeFile = $84;
maxstabs = 40; { size of the stabs buffer }
var
{ GDB after 4.18 uses offset to function begin
in text section but OS/2 version still uses 4.16 PM }
StabsFunctionRelative: boolean;
type
pstab=^tstab;
tstab=packed record
strpos : longint;
ntype : byte;
nother : byte;
ndesc : word;
nvalue : dword;
end;
{ We use static variable so almost no stack is required, and is thus
more safe when an error has occured in the program }
var
e : TExeFile;
staberr : boolean = false;
stabcnt, { amount of stabs }
stablen,
stabofs, { absolute stab section offset in executable }
stabstrlen,
stabstrofs : longint; { absolute stabstr section offset in executable }
dirlength : longint; { length of the dirctory part of the source file }
stabs : array[0..maxstabs-1] of tstab; { buffer }
funcstab, { stab with current function info }
linestab, { stab with current line info }
dirstab, { stab with current directory info }
filestab : tstab; { stab with current file info }
filename,
dbgfn : string;
function OpenStabs(addr : pointer) : boolean;
var
baseaddr : pointer;
begin
OpenStabs:=false;
if staberr then
exit;
GetModuleByAddr(addr,baseaddr,filename);
{$ifdef DEBUG_LINEINFO}
writeln(stderr,filename,' Baseaddr: ',hexstr(ptruint(baseaddr),sizeof(baseaddr)*2));
{$endif DEBUG_LINEINFO}
if not OpenExeFile(e,filename) then
exit;
if ReadDebugLink(e,dbgfn) then
begin
CloseExeFile(e);
if not OpenExeFile(e,dbgfn) then
exit;
end;
e.processaddress:=ptruint(baseaddr)-e.processaddress;
StabsFunctionRelative := E.FunctionRelative;
if FindExeSection(e,'.stab',stabofs,stablen) and
FindExeSection(e,'.stabstr',stabstrofs,stabstrlen) then
begin
stabcnt:=stablen div sizeof(tstab);
OpenStabs:=true;
end
else
begin
CloseExeFile(e);
// staberr:=true;
exit;
end;
end;
procedure CloseStabs;
begin
CloseExeFile(e);
end;
function GetLineInfo(addr:ptruint;var func,source:string;var line:longint) : boolean;
var
res,
stabsleft,
stabscnt,i : longint;
found : boolean;
lastfunc : tstab;
begin
GetLineInfo:=false;
{$ifdef DEBUG_LINEINFO}
writeln(stderr,'GetLineInfo called');
{$endif DEBUG_LINEINFO}
fillchar(func,high(func)+1,0);
fillchar(source,high(source)+1,0);
line:=0;
if staberr then
exit;
if not e.isopen then
begin
if not OpenStabs(pointer(addr)) then
exit;
end;
{ correct the value to the correct address in the file }
{ processaddress is set in OpenStabs }
addr := dword(addr - e.processaddress);
{$ifdef DEBUG_LINEINFO}
writeln(stderr,'Addr: ',hexstr(addr,sizeof(addr)*2));
{$endif DEBUG_LINEINFO}
fillchar(funcstab,sizeof(tstab),0);
fillchar(filestab,sizeof(tstab),0);
fillchar(dirstab,sizeof(tstab),0);
fillchar(linestab,sizeof(tstab),0);
fillchar(lastfunc,sizeof(tstab),0);
found:=false;
seek(e.f,stabofs);
stabsleft:=stabcnt;
repeat
if stabsleft>maxstabs then
stabscnt:=maxstabs
else
stabscnt:=stabsleft;
blockread(e.f,stabs,stabscnt*sizeof(tstab),res);
stabscnt:=res div sizeof(tstab);
for i:=0 to stabscnt-1 do
begin
case stabs[i].ntype of
N_BssLine,
N_DataLine,
N_TextLine :
begin
if (stabs[i].ntype=N_TextLine) and StabsFunctionRelative then
inc(stabs[i].nvalue,lastfunc.nvalue);
if (stabs[i].nvalue<=addr) and
(stabs[i].nvalue>linestab.nvalue) then
begin
{ if it's equal we can stop and take the last info }
if stabs[i].nvalue=addr then
found:=true
else
linestab:=stabs[i];
end;
end;
N_Function :
begin
lastfunc:=stabs[i];
if (stabs[i].nvalue<=addr) and
(stabs[i].nvalue>funcstab.nvalue) then
begin
funcstab:=stabs[i];
fillchar(linestab,sizeof(tstab),0);
end;
end;
N_SourceFile,
N_IncludeFile :
begin
if (stabs[i].nvalue<=addr) and
(stabs[i].nvalue>=filestab.nvalue) then
begin
{ if same value and type then the first one
contained the directory PM }
if (stabs[i].nvalue=filestab.nvalue) and
(stabs[i].ntype=filestab.ntype) then
dirstab:=filestab
else
fillchar(dirstab,sizeof(tstab),0);
filestab:=stabs[i];
fillchar(linestab,sizeof(tstab),0);
{ if new file then func is not valid anymore PM }
if stabs[i].ntype=N_SourceFile then
begin
fillchar(funcstab,sizeof(tstab),0);
fillchar(lastfunc,sizeof(tstab),0);
end;
end;
end;
end;
end;
dec(stabsleft,stabscnt);
until found or (stabsleft=0);
{ get the line,source,function info }
line:=linestab.ndesc;
if dirstab.ntype<>0 then
begin
seek(e.f,stabstrofs+dirstab.strpos);
blockread(e.f,source[1],high(source)-1,res);
dirlength:=strlen(@source[1]);
source[0]:=chr(dirlength);
end
else
dirlength:=0;
if filestab.ntype<>0 then
begin
seek(e.f,stabstrofs+filestab.strpos);
blockread(e.f,source[dirlength+1],high(source)-(dirlength+1),res);
source[0]:=chr(strlen(@source[1]));
end;
if funcstab.ntype<>0 then
begin
seek(e.f,stabstrofs+funcstab.strpos);
blockread(e.f,func[1],high(func)-1,res);
func[0]:=chr(strlen(@func[1]));
i:=pos(':',func);
if i>0 then
Delete(func,i,255);
end;
if e.isopen then
CloseStabs;
GetLineInfo:=true;
end;
function StabBackTraceStr(addr:Pointer):shortstring;
var
func,
source : string;
hs : string[32];
line : longint;
Store : TBackTraceStrFunc;
Success : boolean;
begin
{$ifdef DEBUG_LINEINFO}
writeln(stderr,'StabBackTraceStr called');
{$endif DEBUG_LINEINFO}
{ reset to prevent infinite recursion if problems inside the code PM }
Success:=false;
Store:=BackTraceStrFunc;
BackTraceStrFunc:=@SysBackTraceStr;
Success:=GetLineInfo(ptruint(addr),func,source,line);
{ create string }
{$ifdef netware}
{ we need addr relative to code start on netware }
dec(addr,ptruint(system.NWGetCodeStart));
StabBackTraceStr:=' CodeStart + $'+HexStr(ptruint(addr),sizeof(ptruint)*2);
{$else}
StabBackTraceStr:=' $'+HexStr(ptruint(addr),sizeof(ptruint)*2);
{$endif}
if func<>'' then
StabBackTraceStr:=StabBackTraceStr+' '+func;
if source<>'' then
begin
if func<>'' then
StabBackTraceStr:=StabBackTraceStr+', ';
if line<>0 then
begin
str(line,hs);
StabBackTraceStr:=StabBackTraceStr+' line '+hs;
end;
StabBackTraceStr:=StabBackTraceStr+' of '+source;
end;
if Success then
BackTraceStrFunc:=Store;
end;
initialization
// BackTraceStrFunc:=@StabBackTraceStr;
finalization
if e.isopen then
CloseStabs;
end.
TransGUI/daemonoptions.lfm 0000644 0000000 0000000 00000033276 12256577645 014625 0 ustar root root inherited DaemonOptionsForm: TDaemonOptionsForm
Left = 354
Height = 345
Top = 216
Width = 617
HorzScrollBar.Page = 409
VertScrollBar.Page = 302
VertScrollBar.Range = 169
AutoSize = True
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Transmission options'
ClientHeight = 345
ClientWidth = 617
Constraints.MinHeight = 340
Constraints.MinWidth = 400
OnCreate = FormCreate
Position = poMainFormCenter
object Page: TPageControl[0]
Left = 8
Height = 295
Top = 8
Width = 601
ActivePage = tabNetwork
Align = alClient
BorderSpacing.Around = 8
TabIndex = 1
TabOrder = 0
object tabDownload: TTabSheet
Caption = 'Download'
ClientHeight = 269
ClientWidth = 593
object txDownloadDir: TLabel
Left = 8
Height = 14
Top = 8
Width = 196
Caption = 'Default download folder on remote host:'
ParentColor = False
end
object txCacheSize: TLabel
Left = 8
Height = 14
Top = 191
Width = 76
Caption = 'Disk cache size:'
ParentColor = False
end
object txMB: TLabel
Left = 507
Height = 14
Top = 191
Width = 15
Anchors = [akTop, akRight]
Caption = 'MB'
ParentColor = False
end
object txMinutes: TLabel
Left = 507
Height = 14
Top = 164
Width = 38
Anchors = [akTop, akRight]
Caption = 'minutes'
ParentColor = False
end
object edDownloadDir: TEdit
Left = 8
Height = 21
Top = 28
Width = 577
Anchors = [akTop, akLeft, akRight]
TabOrder = 0
end
object cbIncompleteDir: TCheckBox
Left = 8
Height = 17
Top = 80
Width = 159
Caption = 'Directory for incomplete files:'
OnClick = cbIncompleteDirClick
TabOrder = 2
end
object edIncompleteDir: TEdit
Left = 8
Height = 21
Top = 103
Width = 577
Anchors = [akTop, akLeft, akRight]
TabOrder = 3
end
object cbPartExt: TCheckBox
Left = 8
Height = 17
Top = 56
Width = 203
Caption = 'Add .part extension to incomplete files'
TabOrder = 1
end
object cbSeedRatio: TCheckBox
Left = 8
Height = 17
Top = 134
Width = 71
Caption = 'Seed ratio:'
OnClick = cbSeedRatioClick
TabOrder = 4
end
object edSeedRatio: TFloatSpinEdit
Left = 431
Height = 21
Top = 134
Width = 66
Anchors = [akTop, akRight]
Increment = 0.1
MaxValue = 9999
MinValue = 0
TabOrder = 5
Value = 0
end
object edCacheSize: TSpinEdit
Left = 431
Height = 21
Top = 188
Width = 66
Anchors = [akTop, akRight]
MaxValue = 9999
TabOrder = 8
end
object cbIdleSeedLimit: TCheckBox
Left = 8
Height = 17
Top = 163
Width = 170
Caption = 'Stop seeding when inactive for:'
OnClick = cbIdleSeedLimitClick
TabOrder = 6
end
object edIdleSeedLimit: TSpinEdit
Left = 431
Height = 21
Top = 161
Width = 66
Anchors = [akTop, akRight]
MaxValue = 999999
MinValue = 1
TabOrder = 7
Value = 1
end
end
object tabNetwork: TTabSheet
Caption = 'Network (WAN)'
ClientHeight = 269
ClientWidth = 593
object txPort: TLabel
Left = 8
Height = 14
Top = 13
Width = 71
Caption = 'Incoming port:'
ParentColor = False
end
object txEncryption: TLabel
Left = 8
Height = 14
Top = 69
Width = 56
Caption = 'Encryption:'
ParentColor = False
end
object txPeerLimit: TLabel
Left = 8
Height = 14
Top = 99
Width = 80
Caption = 'Global peer limit:'
ParentColor = False
end
object edPort: TSpinEdit
Left = 192
Height = 21
Top = 10
Width = 90
MaxValue = 65535
MinValue = 1
TabOrder = 0
Value = 1
end
object cbEncryption: TComboBox
Left = 192
Height = 21
Top = 66
Width = 393
Anchors = [akTop, akLeft, akRight]
ItemHeight = 13
Style = csDropDownList
TabOrder = 4
end
object cbPortForwarding: TCheckBox
Left = 292
Height = 17
Top = 38
Width = 128
Caption = 'Enable port forwarding'
TabOrder = 3
end
object cbPEX: TCheckBox
Left = 192
Height = 17
Top = 126
Width = 125
Caption = 'Enable Peer Exchange'
TabOrder = 6
end
object edMaxPeers: TSpinEdit
Left = 192
Height = 21
Top = 96
Width = 66
MaxValue = 99999
MinValue = 1
TabOrder = 5
Value = 1
end
object cbDHT: TCheckBox
Left = 192
Height = 17
Top = 146
Width = 73
Caption = 'Enable DHT'
TabOrder = 7
end
object cbRandomPort: TCheckBox
Left = 292
Height = 17
Top = 13
Width = 211
Caption = 'Pick random port on Transmission launch'
OnClick = cbRandomPortClick
TabOrder = 1
end
object btTestPort: TButton
Left = 192
Height = 23
Top = 35
Width = 90
Caption = 'Test port'
OnClick = btTestPortClick
TabOrder = 2
end
object cbBlocklist: TCheckBox
Left = 8
Height = 17
Top = 210
Width = 94
Caption = 'Enable blocklist:'
OnClick = cbBlocklistClick
TabOrder = 10
end
object edBlocklistURL: TEdit
Left = 8
Height = 21
Top = 233
Width = 577
Anchors = [akTop, akLeft, akRight]
TabOrder = 11
end
object cbLPD: TCheckBox
Left = 192
Height = 17
Top = 166
Width = 152
Caption = 'Enable Local Peer Discovery'
TabOrder = 8
end
object cbUTP: TCheckBox
Left = 192
Height = 17
Top = 186
Width = 71
Caption = 'Enable µTP'
TabOrder = 9
end
end
object tabBandwidth: TTabSheet
Caption = 'Bandwidth'
ClientHeight = 269
ClientWidth = 593
object gbBandwidth: TGroupBox
Left = 8
Height = 76
Top = 6
Width = 576
Anchors = [akTop, akLeft, akRight]
Caption = 'Global bandwidth settings'
ClientHeight = 58
ClientWidth = 572
TabOrder = 0
object txKbs1: TLabel
Left = 536
Height = 14
Top = 5
Width = 22
Anchors = [akTop, akRight]
Caption = 'KB/s'
ParentColor = False
end
object txKbs2: TLabel
Left = 536
Height = 14
Top = 32
Width = 22
Anchors = [akTop, akRight]
Caption = 'KB/s'
ParentColor = False
end
object cbMaxDown: TCheckBox
Left = 8
Height = 17
Top = 4
Width = 147
Caption = 'Maximum download speed:'
OnClick = cbMaxDownClick
TabOrder = 0
end
object edMaxDown: TSpinEdit
Left = 455
Height = 21
Top = 2
Width = 66
Anchors = [akTop, akRight]
Increment = 10
MaxValue = 999999
TabOrder = 1
end
object cbMaxUp: TCheckBox
Left = 8
Height = 17
Top = 30
Width = 133
Caption = 'Maximum upload speed:'
OnClick = cbMaxUpClick
TabOrder = 2
end
object edMaxUp: TSpinEdit
Left = 455
Height = 21
Top = 28
Width = 66
Anchors = [akTop, akRight]
Increment = 10
MaxValue = 999999
TabOrder = 3
end
end
object gbAltSpeed: TGroupBox
Left = 8
Height = 175
Top = 86
Width = 576
Anchors = [akTop, akLeft, akRight]
Caption = 'Alternate bandwidth settings'
ClientHeight = 157
ClientWidth = 572
TabOrder = 1
object txKbs3: TLabel
Left = 536
Height = 14
Top = 5
Width = 22
Anchors = [akTop, akRight]
Caption = 'KB/s'
ParentColor = False
end
object txKbs4: TLabel
Left = 536
Height = 14
Top = 32
Width = 22
Anchors = [akTop, akRight]
Caption = 'KB/s'
ParentColor = False
end
object txAltDown: TLabel
Left = 8
Height = 14
Top = 5
Width = 130
Caption = 'Maximum download speed:'
ParentColor = False
end
object txAltUp: TLabel
Left = 8
Height = 14
Top = 31
Width = 116
Caption = 'Maximum upload speed:'
ParentColor = False
end
object txFrom: TLabel
Left = 26
Height = 14
Top = 103
Width = 29
Caption = 'From:'
ParentColor = False
end
object txDays: TLabel
Left = 26
Height = 14
Top = 132
Width = 29
Caption = 'Days:'
ParentColor = False
end
object txTo: TLabel
Left = 150
Height = 14
Top = 104
Width = 49
Alignment = taCenter
AutoSize = False
Caption = 'to:'
ParentColor = False
end
object edAltDown: TSpinEdit
Left = 455
Height = 21
Top = 2
Width = 66
Anchors = [akTop, akRight]
Increment = 10
MaxValue = 999999
TabOrder = 0
end
object edAltUp: TSpinEdit
Left = 455
Height = 21
Top = 28
Width = 66
Anchors = [akTop, akRight]
Increment = 10
MaxValue = 999999
TabOrder = 1
end
object cbAltEnabled: TCheckBox
Left = 8
Height = 17
Top = 54
Width = 177
Caption = 'Use alternate bandwidth settings'
TabOrder = 2
end
object cbAutoAlt: TCheckBox
Left = 8
Height = 17
Top = 76
Width = 252
Caption = 'Apply alternate bandwidth settings automatically'
OnClick = cbAutoAltClick
TabOrder = 3
end
object edAltTimeBegin: TMaskEdit
Left = 82
Height = 21
Top = 100
Width = 64
CharCase = ecNormal
MaxLength = 5
TabOrder = 4
EditMask = '!99:99;1; '
Text = ' : '
SpaceChar = ' '
end
object edAltTimeEnd: TMaskEdit
Left = 202
Height = 21
Top = 100
Width = 64
CharCase = ecNormal
MaxLength = 5
TabOrder = 5
EditMask = '!99:99;1; '
Text = ' : '
SpaceChar = ' '
end
end
end
object tabQueue: TTabSheet
Caption = 'Queue'
ClientHeight = 269
ClientWidth = 593
object cbDownQueue: TCheckBox
Left = 8
Height = 17
Top = 12
Width = 123
Caption = 'Download queue size:'
TabOrder = 0
end
object edDownQueue: TSpinEdit
Left = 431
Height = 21
Top = 10
Width = 66
Anchors = [akTop, akRight]
MaxValue = 999999
MinValue = 1
TabOrder = 1
Value = 1
end
object cbUpQueue: TCheckBox
Left = 8
Height = 17
Top = 40
Width = 109
Caption = 'Upload queue size:'
TabOrder = 2
end
object edUpQueue: TSpinEdit
Left = 431
Height = 21
Top = 38
Width = 66
Anchors = [akTop, akRight]
MaxValue = 999999
MinValue = 1
TabOrder = 3
Value = 1
end
object cbStalled: TCheckBox
Left = 8
Height = 17
Hint = 'Torrents that are idle for N minuets aren''t counted toward the Download queue or Upload queue'
Top = 68
Width = 251
Caption = 'Consider active torrents as stalled when idle for:'
ParentShowHint = False
ShowHint = True
TabOrder = 4
end
object edStalledTime: TSpinEdit
Left = 431
Height = 21
Top = 66
Width = 66
Anchors = [akTop, akRight]
MaxValue = 999999
MinValue = 1
TabOrder = 5
Value = 1
end
object txMinutes1: TLabel
Left = 507
Height = 14
Top = 69
Width = 38
Anchors = [akTop, akRight]
Caption = 'minutes'
ParentColor = False
end
end
end
object Buttons: TButtonPanel[1]
Left = 8
Height = 26
Top = 311
Width = 601
BorderSpacing.Left = 8
BorderSpacing.Right = 8
BorderSpacing.Bottom = 8
BorderSpacing.Around = 0
OKButton.Name = 'OKButton'
OKButton.DefaultCaption = True
HelpButton.Name = 'HelpButton'
HelpButton.DefaultCaption = True
CloseButton.Name = 'CloseButton'
CloseButton.DefaultCaption = True
CancelButton.Name = 'CancelButton'
CancelButton.DefaultCaption = True
TabOrder = 1
Spacing = 8
ShowButtons = [pbOK, pbCancel]
ShowBevel = False
end
end
TransGUI/addlink.lfm 0000644 0000000 0000000 00000002654 12256577645 013350 0 ustar root root inherited AddLinkForm: TAddLinkForm
Left = 354
Height = 93
Top = 193
Width = 574
AutoSize = True
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Add torrent link'
ClientHeight = 93
ClientWidth = 574
OnCreate = FormCreate
Position = poMainFormCenter
object Buttons: TButtonPanel[0]
Left = 8
Height = 26
Top = 59
Width = 558
BorderSpacing.Left = 8
BorderSpacing.Right = 8
BorderSpacing.Bottom = 8
BorderSpacing.Around = 0
OKButton.Name = 'OKButton'
OKButton.DefaultCaption = True
HelpButton.Name = 'HelpButton'
HelpButton.DefaultCaption = True
CloseButton.Name = 'CloseButton'
CloseButton.DefaultCaption = True
CancelButton.Name = 'CancelButton'
CancelButton.DefaultCaption = True
TabOrder = 1
Spacing = 8
ShowButtons = [pbOK, pbCancel]
ShowBevel = False
end
object Panel1: TPanel[1]
Left = 8
Height = 43
Top = 8
Width = 558
Align = alClient
BorderSpacing.Around = 8
BevelOuter = bvNone
ClientHeight = 43
ClientWidth = 558
TabOrder = 0
object txLink: TLabel
Left = 0
Height = 14
Top = 0
Width = 183
Caption = 'URL of a .torrent file or a magnet link:'
ParentColor = False
end
object edLink: TEdit
Left = 0
Height = 21
Top = 20
Width = 558
Anchors = [akTop, akLeft, akRight]
TabOrder = 0
end
end
end
TransGUI/urllistenerosx.pas 0000644 0000000 0000000 00000002304 12027134022 015007 0 ustar root root unit URLListenerOSX;
{$mode objfpc}{$H+}
{$modeswitch objectivec2}
interface
uses
Classes, SysUtils, CocoaAll, InternetConfig, AppleEvents;
type
THandlerProc = procedure(const url: string);
{ TAppURLHandler }
TAppURLHandler = objcclass(NSObject)
public
procedure getUrlwithReplyEvent(event: NSAppleEventDescriptor; eventReply: NSAppleEventDescriptor); message 'getUrl:withReplyEvent:';
public
callBack: THandlerProc;
end;
procedure RegisterURLHandler(HandlerProc: THandlerProc);
var
handler : TAppURLHandler;
eventManager: NSAppleEventManager;
implementation
{ TAppURLHandler }
procedure TAppURLHandler.getUrlwithReplyEvent(event: NSAppleEventDescriptor; eventReply: NSAppleEventDescriptor);
var
url : NSString;
begin
url:=event.paramDescriptorForKeyword(keyDirectObject).stringValue;
callBack(url.UTF8String);
end;
procedure RegisterURLHandler(HandlerProc: THandlerProc);
begin
handler:=TAppURLHandler.alloc.init;
handler.callBack:=HandlerProc;
eventManager:=NSAppleEventManager.sharedAppleEventManager;
eventManager.setEventHandler_andSelector_forEventClass_andEventID(handler,ObjCSelector(handler.getUrlwithReplyEvent), kInternetEventClass,kAEGetURL);
end;
end.
TransGUI/units/ 0000755 0000000 0000000 00000000000 12261774331 012360 5 ustar root root TransGUI/synapse/ 0000755 0000000 0000000 00000000000 12261774331 012700 5 ustar root root TransGUI/synapse/licence.txt 0000644 0000000 0000000 00000004154 11366572451 015053 0 ustar root root Copyright (c)1999-2002, Lukas Gebauer
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
Neither the name of Lukas Gebauer nor the names of its contributors may
be used to endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
DAMAGE.
TransGUI/synapse/source/ 0000755 0000000 0000000 00000000000 12261774331 014200 5 ustar root root TransGUI/synapse/source/lib/ 0000755 0000000 0000000 00000000000 12261774331 014746 5 ustar root root TransGUI/synapse/source/lib/ssdotnet.pas 0000644 0000000 0000000 00000104272 11366572451 017330 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.000.002 |
|==============================================================================|
| Content: Socket Independent Platform Layer - .NET definition include |
|==============================================================================|
| Copyright (c)2004, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2004. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@exclude}
{$IFDEF CIL}
interface
uses
SyncObjs, SysUtils, Classes,
System.Net,
System.Net.Sockets;
const
DLLStackName = '';
WinsockLevel = $0202;
function InitSocketInterface(stack: string): Boolean;
function DestroySocketInterface: Boolean;
type
u_char = Char;
u_short = Word;
u_int = Integer;
u_long = Longint;
pu_long = ^u_long;
pu_short = ^u_short;
PSockAddr = IPEndPoint;
DWORD = integer;
ULong = cardinal;
TMemory = Array of byte;
TLinger = LingerOption;
TSocket = socket;
TAddrFamily = AddressFamily;
const
WSADESCRIPTION_LEN = 256;
WSASYS_STATUS_LEN = 128;
type
PWSAData = ^TWSAData;
TWSAData = packed record
wVersion: Word;
wHighVersion: Word;
szDescription: array[0..WSADESCRIPTION_LEN] of Char;
szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
iMaxSockets: Word;
iMaxUdpDg: Word;
// lpVendorInfo: PChar;
end;
const
MSG_NOSIGNAL = 0;
INVALID_SOCKET = nil;
AF_UNSPEC = AddressFamily.Unspecified;
AF_INET = AddressFamily.InterNetwork;
AF_INET6 = AddressFamily.InterNetworkV6;
SOCKET_ERROR = integer(-1);
FIONREAD = integer($4004667f);
FIONBIO = integer($8004667e);
FIOASYNC = integer($8004667d);
SOMAXCONN = integer($7fffffff);
IPPROTO_IP = ProtocolType.IP;
IPPROTO_ICMP = ProtocolType.Icmp;
IPPROTO_IGMP = ProtocolType.Igmp;
IPPROTO_TCP = ProtocolType.Tcp;
IPPROTO_UDP = ProtocolType.Udp;
IPPROTO_RAW = ProtocolType.Raw;
IPPROTO_IPV6 = ProtocolType.IPV6;
//
IPPROTO_ICMPV6 = ProtocolType.Icmp; //??
SOCK_STREAM = SocketType.Stream;
SOCK_DGRAM = SocketType.Dgram;
SOCK_RAW = SocketType.Raw;
SOCK_RDM = SocketType.Rdm;
SOCK_SEQPACKET = SocketType.Seqpacket;
SOL_SOCKET = SocketOptionLevel.Socket;
SOL_IP = SocketOptionLevel.Ip;
IP_OPTIONS = SocketOptionName.IPOptions;
IP_HDRINCL = SocketOptionName.HeaderIncluded;
IP_TOS = SocketOptionName.TypeOfService; { set/get IP Type Of Service }
IP_TTL = SocketOptionName.IpTimeToLive; { set/get IP Time To Live }
IP_MULTICAST_IF = SocketOptionName.MulticastInterface; { set/get IP multicast interface }
IP_MULTICAST_TTL = SocketOptionName.MulticastTimeToLive; { set/get IP multicast timetolive }
IP_MULTICAST_LOOP = SocketOptionName.MulticastLoopback; { set/get IP multicast loopback }
IP_ADD_MEMBERSHIP = SocketOptionName.AddMembership; { add an IP group membership }
IP_DROP_MEMBERSHIP = SocketOptionName.DropMembership; { drop an IP group membership }
IP_DONTFRAGMENT = SocketOptionName.DontFragment; { set/get IP Don't Fragment flag }
IPV6_UNICAST_HOPS = 8; // TTL
IPV6_MULTICAST_IF = 9; // set/get IP multicast i/f
IPV6_MULTICAST_HOPS = 10; // set/get IP multicast ttl
IPV6_MULTICAST_LOOP = 11; // set/get IP multicast loopback
IPV6_JOIN_GROUP = 12; // add an IP group membership
IPV6_LEAVE_GROUP = 13; // drop an IP group membership
SO_DEBUG = SocketOptionName.Debug; { turn on debugging info recording }
SO_ACCEPTCONN = SocketOptionName.AcceptConnection; { socket has had listen() }
SO_REUSEADDR = SocketOptionName.ReuseAddress; { allow local address reuse }
SO_KEEPALIVE = SocketOptionName.KeepAlive; { keep connections alive }
SO_DONTROUTE = SocketOptionName.DontRoute; { just use interface addresses }
SO_BROADCAST = SocketOptionName.Broadcast; { permit sending of broadcast msgs }
SO_USELOOPBACK = SocketOptionName.UseLoopback; { bypass hardware when possible }
SO_LINGER = SocketOptionName.Linger; { linger on close if data present }
SO_OOBINLINE = SocketOptionName.OutOfBandInline; { leave received OOB data in line }
SO_DONTLINGER = SocketOptionName.DontLinger;
{ Additional options. }
SO_SNDBUF = SocketOptionName.SendBuffer; { send buffer size }
SO_RCVBUF = SocketOptionName.ReceiveBuffer; { receive buffer size }
SO_SNDLOWAT = SocketOptionName.SendLowWater; { send low-water mark }
SO_RCVLOWAT = SocketOptionName.ReceiveLowWater; { receive low-water mark }
SO_SNDTIMEO = SocketOptionName.SendTimeout; { send timeout }
SO_RCVTIMEO = SocketOptionName.ReceiveTimeout; { receive timeout }
SO_ERROR = SocketOptionName.Error; { get error status and clear }
SO_TYPE = SocketOptionName.Type; { get socket type }
{ WinSock 2 extension -- new options }
// SO_GROUP_ID = $2001; { ID of a socket group}
// SO_GROUP_PRIORITY = $2002; { the relative priority within a group}
// SO_MAX_MSG_SIZE = $2003; { maximum message size }
// SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure }
// SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure }
// SO_PROTOCOL_INFO = SO_PROTOCOL_INFOA;
// PVD_CONFIG = $3001; {configuration info for service provider }
{ Option for opening sockets for synchronous access. }
// SO_OPENTYPE = $7008;
// SO_SYNCHRONOUS_ALERT = $10;
// SO_SYNCHRONOUS_NONALERT = $20;
{ Other NT-specific options. }
// SO_MAXDG = $7009;
// SO_MAXPATHDG = $700A;
// SO_UPDATE_ACCEPT_CONTEXT = $700B;
// SO_CONNECT_TIME = $700C;
{ All Windows Sockets error constants are biased by WSABASEERR from the "normal" }
WSABASEERR = 10000;
{ Windows Sockets definitions of regular Microsoft C error constants }
WSAEINTR = (WSABASEERR+4);
WSAEBADF = (WSABASEERR+9);
WSAEACCES = (WSABASEERR+13);
WSAEFAULT = (WSABASEERR+14);
WSAEINVAL = (WSABASEERR+22);
WSAEMFILE = (WSABASEERR+24);
{ Windows Sockets definitions of regular Berkeley error constants }
WSAEWOULDBLOCK = (WSABASEERR+35);
WSAEINPROGRESS = (WSABASEERR+36);
WSAEALREADY = (WSABASEERR+37);
WSAENOTSOCK = (WSABASEERR+38);
WSAEDESTADDRREQ = (WSABASEERR+39);
WSAEMSGSIZE = (WSABASEERR+40);
WSAEPROTOTYPE = (WSABASEERR+41);
WSAENOPROTOOPT = (WSABASEERR+42);
WSAEPROTONOSUPPORT = (WSABASEERR+43);
WSAESOCKTNOSUPPORT = (WSABASEERR+44);
WSAEOPNOTSUPP = (WSABASEERR+45);
WSAEPFNOSUPPORT = (WSABASEERR+46);
WSAEAFNOSUPPORT = (WSABASEERR+47);
WSAEADDRINUSE = (WSABASEERR+48);
WSAEADDRNOTAVAIL = (WSABASEERR+49);
WSAENETDOWN = (WSABASEERR+50);
WSAENETUNREACH = (WSABASEERR+51);
WSAENETRESET = (WSABASEERR+52);
WSAECONNABORTED = (WSABASEERR+53);
WSAECONNRESET = (WSABASEERR+54);
WSAENOBUFS = (WSABASEERR+55);
WSAEISCONN = (WSABASEERR+56);
WSAENOTCONN = (WSABASEERR+57);
WSAESHUTDOWN = (WSABASEERR+58);
WSAETOOMANYREFS = (WSABASEERR+59);
WSAETIMEDOUT = (WSABASEERR+60);
WSAECONNREFUSED = (WSABASEERR+61);
WSAELOOP = (WSABASEERR+62);
WSAENAMETOOLONG = (WSABASEERR+63);
WSAEHOSTDOWN = (WSABASEERR+64);
WSAEHOSTUNREACH = (WSABASEERR+65);
WSAENOTEMPTY = (WSABASEERR+66);
WSAEPROCLIM = (WSABASEERR+67);
WSAEUSERS = (WSABASEERR+68);
WSAEDQUOT = (WSABASEERR+69);
WSAESTALE = (WSABASEERR+70);
WSAEREMOTE = (WSABASEERR+71);
{ Extended Windows Sockets error constant definitions }
WSASYSNOTREADY = (WSABASEERR+91);
WSAVERNOTSUPPORTED = (WSABASEERR+92);
WSANOTINITIALISED = (WSABASEERR+93);
WSAEDISCON = (WSABASEERR+101);
WSAENOMORE = (WSABASEERR+102);
WSAECANCELLED = (WSABASEERR+103);
WSAEEINVALIDPROCTABLE = (WSABASEERR+104);
WSAEINVALIDPROVIDER = (WSABASEERR+105);
WSAEPROVIDERFAILEDINIT = (WSABASEERR+106);
WSASYSCALLFAILURE = (WSABASEERR+107);
WSASERVICE_NOT_FOUND = (WSABASEERR+108);
WSATYPE_NOT_FOUND = (WSABASEERR+109);
WSA_E_NO_MORE = (WSABASEERR+110);
WSA_E_CANCELLED = (WSABASEERR+111);
WSAEREFUSED = (WSABASEERR+112);
{ Error return codes from gethostbyname() and gethostbyaddr()
(when using the resolver). Note that these errors are
retrieved via WSAGetLastError() and must therefore follow
the rules for avoiding clashes with error numbers from
specific implementations or language run-time systems.
For this reason the codes are based at WSABASEERR+1001.
Note also that [WSA]NO_ADDRESS is defined only for
compatibility purposes. }
{ Authoritative Answer: Host not found }
WSAHOST_NOT_FOUND = (WSABASEERR+1001);
HOST_NOT_FOUND = WSAHOST_NOT_FOUND;
{ Non-Authoritative: Host not found, or SERVERFAIL }
WSATRY_AGAIN = (WSABASEERR+1002);
TRY_AGAIN = WSATRY_AGAIN;
{ Non recoverable errors, FORMERR, REFUSED, NOTIMP }
WSANO_RECOVERY = (WSABASEERR+1003);
NO_RECOVERY = WSANO_RECOVERY;
{ Valid name, no data record of requested type }
WSANO_DATA = (WSABASEERR+1004);
NO_DATA = WSANO_DATA;
{ no address, look for MX record }
WSANO_ADDRESS = WSANO_DATA;
NO_ADDRESS = WSANO_ADDRESS;
EWOULDBLOCK = WSAEWOULDBLOCK;
EINPROGRESS = WSAEINPROGRESS;
EALREADY = WSAEALREADY;
ENOTSOCK = WSAENOTSOCK;
EDESTADDRREQ = WSAEDESTADDRREQ;
EMSGSIZE = WSAEMSGSIZE;
EPROTOTYPE = WSAEPROTOTYPE;
ENOPROTOOPT = WSAENOPROTOOPT;
EPROTONOSUPPORT = WSAEPROTONOSUPPORT;
ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT;
EOPNOTSUPP = WSAEOPNOTSUPP;
EPFNOSUPPORT = WSAEPFNOSUPPORT;
EAFNOSUPPORT = WSAEAFNOSUPPORT;
EADDRINUSE = WSAEADDRINUSE;
EADDRNOTAVAIL = WSAEADDRNOTAVAIL;
ENETDOWN = WSAENETDOWN;
ENETUNREACH = WSAENETUNREACH;
ENETRESET = WSAENETRESET;
ECONNABORTED = WSAECONNABORTED;
ECONNRESET = WSAECONNRESET;
ENOBUFS = WSAENOBUFS;
EISCONN = WSAEISCONN;
ENOTCONN = WSAENOTCONN;
ESHUTDOWN = WSAESHUTDOWN;
ETOOMANYREFS = WSAETOOMANYREFS;
ETIMEDOUT = WSAETIMEDOUT;
ECONNREFUSED = WSAECONNREFUSED;
ELOOP = WSAELOOP;
ENAMETOOLONG = WSAENAMETOOLONG;
EHOSTDOWN = WSAEHOSTDOWN;
EHOSTUNREACH = WSAEHOSTUNREACH;
ENOTEMPTY = WSAENOTEMPTY;
EPROCLIM = WSAEPROCLIM;
EUSERS = WSAEUSERS;
EDQUOT = WSAEDQUOT;
ESTALE = WSAESTALE;
EREMOTE = WSAEREMOTE;
type
TVarSin = IPEndpoint;
{ function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean;
procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
var
in6addr_any, in6addr_loopback : TInAddr6;
}
{procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
procedure FD_ZERO(var FDSet: TFDSet);
}
{=============================================================================}
function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
function WSACleanup: Integer;
function WSAGetLastError: Integer;
function WSAGetLastErrorDesc: String;
function GetHostName: string;
function Shutdown(s: TSocket; how: Integer): Integer;
// function SetSockOpt(s: TSocket; level, optname: Integer; optval: PChar;
// optlen: Integer): Integer;
function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory;
optlen: Integer): Integer;
function SetSockOptObj(s: TSocket; level, optname: Integer; optval: TObject): Integer;
function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory;
var optlen: Integer): Integer;
// function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr;
// tolen: Integer): Integer;
/// function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: TVarSin): Integer;
/// function Send(s: TSocket; const Buf; len, flags: Integer): Integer;
/// function Recv(s: TSocket; var Buf; len, flags: Integer): Integer;
// function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr;
// var fromlen: Integer): Integer;
/// function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: TVarSin): Integer;
function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
function ntohs(netshort: u_short): u_short;
function ntohl(netlong: u_long): u_long;
function Listen(s: TSocket; backlog: Integer): Integer;
function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer;
function htons(hostshort: u_short): u_short;
function htonl(hostlong: u_long): u_long;
// function GetSockName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
function GetSockName(s: TSocket; var name: TVarSin): Integer;
// function GetPeerName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
function GetPeerName(s: TSocket; var name: TVarSin): Integer;
// function Connect(s: TSocket; name: PSockAddr; namelen: Integer): Integer;
function Connect(s: TSocket; const name: TVarSin): Integer;
function CloseSocket(s: TSocket): Integer;
// function Bind(s: TSocket; addr: PSockAddr; namelen: Integer): Integer;
function Bind(s: TSocket; const addr: TVarSin): Integer;
// function Accept(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket;
function Accept(s: TSocket; var addr: TVarSin): TSocket;
function Socket(af, Struc, Protocol: Integer): TSocket;
// Select = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
// timeout: PTimeVal): Longint;
// {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};
// TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer;
// cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD;
// lpcbBytesReturned: PDWORD; lpOverlapped: Pointer;
// lpCompletionRoutine: pointer): u_int;
// stdcall;
function GetPortService(value: string): integer;
function IsNewApi(Family: TAddrFamily): Boolean;
function SetVarSin(var Sin: TVarSin; IP, Port: string; Family: TAddrFamily; SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
function GetSinIP(Sin: TVarSin): string;
function GetSinPort(Sin: TVarSin): Integer;
procedure ResolveNameToIP(Name: string; Family: TAddrFamily; SockProtocol, SockType: integer; const IPList: TStrings);
function ResolveIPToName(IP: string; Family: TAddrFamily; SockProtocol, SockType: integer): string;
function ResolvePort(Port: string; Family: TAddrFamily; SockProtocol, SockType: integer): Word;
var
SynSockCS: SyncObjs.TCriticalSection;
SockEnhancedApi: Boolean;
SockWship6Api: Boolean;
{==============================================================================}
implementation
threadvar
WSALastError: integer;
WSALastErrorDesc: string;
var
services: Array [0..139, 0..1] of string =
(
('echo', '7'),
('discard', '9'),
('sink', '9'),
('null', '9'),
('systat', '11'),
('users', '11'),
('daytime', '13'),
('qotd', '17'),
('quote', '17'),
('chargen', '19'),
('ttytst', '19'),
('source', '19'),
('ftp-data', '20'),
('ftp', '21'),
('telnet', '23'),
('smtp', '25'),
('mail', '25'),
('time', '37'),
('timeserver', '37'),
('rlp', '39'),
('nameserver', '42'),
('name', '42'),
('nickname', '43'),
('whois', '43'),
('domain', '53'),
('bootps', '67'),
('dhcps', '67'),
('bootpc', '68'),
('dhcpc', '68'),
('tftp', '69'),
('gopher', '70'),
('finger', '79'),
('http', '80'),
('www', '80'),
('www-http', '80'),
('kerberos', '88'),
('hostname', '101'),
('hostnames', '101'),
('iso-tsap', '102'),
('rtelnet', '107'),
('pop2', '109'),
('postoffice', '109'),
('pop3', '110'),
('sunrpc', '111'),
('rpcbind', '111'),
('portmap', '111'),
('auth', '113'),
('ident', '113'),
('tap', '113'),
('uucp-path', '117'),
('nntp', '119'),
('usenet', '119'),
('ntp', '123'),
('epmap', '135'),
('loc-srv', '135'),
('netbios-ns', '137'),
('nbname', '137'),
('netbios-dgm', '138'),
('nbdatagram', '138'),
('netbios-ssn', '139'),
('nbsession', '139'),
('imap', '143'),
('imap4', '143'),
('pcmail-srv', '158'),
('snmp', '161'),
('snmptrap', '162'),
('snmp-trap', '162'),
('print-srv', '170'),
('bgp', '179'),
('irc', '194'),
('ipx', '213'),
('ldap', '389'),
('https', '443'),
('mcom', '443'),
('microsoft-ds', '445'),
('kpasswd', '464'),
('isakmp', '500'),
('ike', '500'),
('exec', '512'),
('biff', '512'),
('comsat', '512'),
('login', '513'),
('who', '513'),
('whod', '513'),
('cmd', '514'),
('shell', '514'),
('syslog', '514'),
('printer', '515'),
('spooler', '515'),
('talk', '517'),
('ntalk', '517'),
('efs', '520'),
('router', '520'),
('route', '520'),
('routed', '520'),
('timed', '525'),
('timeserver', '525'),
('tempo', '526'),
('newdate', '526'),
('courier', '530'),
('rpc', '530'),
('conference', '531'),
('chat', '531'),
('netnews', '532'),
('readnews', '532'),
('netwall', '533'),
('uucp', '540'),
('uucpd', '540'),
('klogin', '543'),
('kshell', '544'),
('krcmd', '544'),
('new-rwho', '550'),
('new-who', '550'),
('remotefs', '556'),
('rfs', '556'),
('rfs_server', '556'),
('rmonitor', '560'),
('rmonitord', '560'),
('monitor', '561'),
('ldaps', '636'),
('sldap', '636'),
('doom', '666'),
('kerberos-adm', '749'),
('kerberos-iv', '750'),
('kpop', '1109'),
('phone', '1167'),
('ms-sql-s', '1433'),
('ms-sql-m', '1434'),
('wins', '1512'),
('ingreslock', '1524'),
('ingres', '1524'),
('l2tp', '1701'),
('pptp', '1723'),
('radius', '1812'),
('radacct', '1813'),
('nfsd', '2049'),
('nfs', '2049'),
('knetd', '2053'),
('gds_db', '3050'),
('man', '9535')
);
{function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
begin
Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and
(a^.s_un_dw.s_dw3 = 0) and (a^.s_un_dw.s_dw4 = 0));
end;
function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
begin
Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and
(a^.s_un_dw.s_dw3 = 0) and
(a^.s_un_b.s_b13 = char(0)) and (a^.s_un_b.s_b14 = char(0)) and
(a^.s_un_b.s_b15 = char(0)) and (a^.s_un_b.s_b16 = char(1)));
end;
function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
begin
Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($80)));
end;
function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
begin
Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($C0)));
end;
function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
begin
Result := (a^.s_un_b.s_b1 = char($FF));
end;
function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean;
begin
Result := (CompareMem( a, b, sizeof(TInAddr6)));
end;
procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
begin
FillChar(a^, sizeof(TInAddr6), 0);
end;
procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
begin
FillChar(a^, sizeof(TInAddr6), 0);
a^.s_un_b.s_b16 := char(1);
end;
}
{=============================================================================}
procedure NullErr;
begin
WSALastError := 0;
WSALastErrorDesc := '';
end;
procedure GetErrCode(E: System.Exception);
var
SE: System.Net.Sockets.SocketException;
begin
if E is System.Net.Sockets.SocketException then
begin
SE := E as System.Net.Sockets.SocketException;
WSALastError := SE.ErrorCode;
WSALastErrorDesc := SE.Message;
end
end;
function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
begin
NullErr;
with WSData do
begin
wVersion := wVersionRequired;
wHighVersion := $202;
szDescription := 'Synsock - Synapse Platform Independent Socket Layer';
szSystemStatus := 'Running on .NET';
iMaxSockets := 32768;
iMaxUdpDg := 8192;
end;
Result := 0;
end;
function WSACleanup: Integer;
begin
NullErr;
Result := 0;
end;
function WSAGetLastError: Integer;
begin
Result := WSALastError;
end;
function WSAGetLastErrorDesc: String;
begin
Result := WSALastErrorDesc;
end;
function GetHostName: string;
begin
Result := System.Net.DNS.GetHostName;
end;
function Shutdown(s: TSocket; how: Integer): Integer;
begin
Result := 0;
NullErr;
try
s.ShutDown(SocketShutdown(how));
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := integer(SOCKET_ERROR);
end;
end;
end;
function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory;
optlen: Integer): Integer;
begin
Result := 0;
NullErr;
try
s.SetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval);
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := integer(SOCKET_ERROR);
end;
end;
end;
function SetSockOptObj(s: TSocket; level, optname: Integer; optval: TObject): Integer;
begin
Result := 0;
NullErr;
try
s.SetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval);
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := integer(SOCKET_ERROR);
end;
end;
end;
function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory;
var optlen: Integer): Integer;
begin
Result := 0;
NullErr;
try
s.GetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval);
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := integer(SOCKET_ERROR);
end;
end;
end;
function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
//function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: TVarSin): Integer;
begin
NullErr;
try
result := s.SendTo(Buf, len, SocketFlags(flags), addrto);
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := integer(SOCKET_ERROR);
end;
end;
end;
function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
//function Send(s: TSocket; const Buf; len, flags: Integer): Integer;
begin
NullErr;
try
result := s.Send(Buf, len, SocketFlags(flags));
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := integer(SOCKET_ERROR);
end;
end;
end;
function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
//function Recv(s: TSocket; var Buf; len, flags: Integer): Integer;
begin
NullErr;
try
result := s.Receive(Buf, len, SocketFlags(flags));
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := integer(SOCKET_ERROR);
end;
end;
end;
//function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr;
// var fromlen: Integer): Integer;
function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
//function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: TVarSin): Integer;
var
EP: EndPoint;
begin
NullErr;
try
EP := from;
result := s.ReceiveFrom(Buf, len, SocketFlags(flags), EndPoint(EP));
from := EP as IPEndPoint;
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := integer(SOCKET_ERROR);
end;
end;
end;
function ntohs(netshort: u_short): u_short;
begin
Result := IPAddress.NetworkToHostOrder(NetShort);
end;
function ntohl(netlong: u_long): u_long;
begin
Result := IPAddress.NetworkToHostOrder(NetLong);
end;
function Listen(s: TSocket; backlog: Integer): Integer;
begin
Result := 0;
NullErr;
try
s.Listen(backlog);
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := integer(SOCKET_ERROR);
end;
end;
end;
function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer;
var
inv, outv: TMemory;
begin
Result := 0;
NullErr;
try
if cmd = DWORD(FIONBIO) then
s.Blocking := arg = 0
else
begin
inv := BitConverter.GetBytes(arg);
outv := BitConverter.GetBytes(integer(0));
s.IOControl(cmd, inv, outv);
arg := BitConverter.ToInt32(outv, 0);
end;
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := integer(SOCKET_ERROR);
end;
end;
end;
function htons(hostshort: u_short): u_short;
begin
Result := IPAddress.HostToNetworkOrder(Hostshort);
end;
function htonl(hostlong: u_long): u_long;
begin
Result := IPAddress.HostToNetworkOrder(HostLong);
end;
//function GetSockName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
function GetSockName(s: TSocket; var name: TVarSin): Integer;
begin
Result := 0;
NullErr;
try
Name := s.localEndPoint as IPEndpoint;
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := integer(SOCKET_ERROR);
end;
end;
end;
//function GetPeerName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
function GetPeerName(s: TSocket; var name: TVarSin): Integer;
begin
Result := 0;
NullErr;
try
Name := s.RemoteEndPoint as IPEndpoint;
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := integer(SOCKET_ERROR);
end;
end;
end;
//function Connect(s: TSocket; name: PSockAddr; namelen: Integer): Integer;
function Connect(s: TSocket; const name: TVarSin): Integer;
begin
Result := 0;
NullErr;
try
s.Connect(name);
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := integer(SOCKET_ERROR);
end;
end;
end;
function CloseSocket(s: TSocket): Integer;
begin
Result := 0;
NullErr;
try
s.Close;
except
on e: System.Net.Sockets.SocketException do
begin
Result := integer(SOCKET_ERROR);
end;
end;
end;
//function Bind(s: TSocket; addr: PSockAddr; namelen: Integer): Integer;
function Bind(s: TSocket; const addr: TVarSin): Integer;
begin
Result := 0;
NullErr;
try
s.Bind(addr);
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := integer(SOCKET_ERROR);
end;
end;
end;
//function Accept(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket;
function Accept(s: TSocket; var addr: TVarSin): TSocket;
begin
NullErr;
try
result := s.Accept();
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := nil;
end;
end;
end;
function Socket(af, Struc, Protocol: Integer): TSocket;
begin
NullErr;
try
result := TSocket.Create(AddressFamily(af), SocketType(Struc), ProtocolType(Protocol));
except
on e: System.Net.Sockets.SocketException do
begin
GetErrCode(e);
Result := nil;
end;
end;
end;
{=============================================================================}
function GetPortService(value: string): integer;
var
n: integer;
begin
Result := 0;
value := Lowercase(value);
for n := 0 to High(Services) do
if services[n, 0] = value then
begin
Result := strtointdef(services[n, 1], 0);
break;
end;
if Result = 0 then
Result := StrToIntDef(value, 0);
end;
{=============================================================================}
function IsNewApi(Family: TAddrFamily): Boolean;
begin
Result := true;
end;
function SetVarSin(var Sin: TVarSin; IP, Port: string; Family: TAddrFamily; SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
var
IPs: array of IPAddress;
n: integer;
ip4, ip6: string;
sip: string;
begin
sip := '';
ip4 := '';
ip6 := '';
IPs := Dns.Resolve(IP).AddressList;
for n :=low(IPs) to high(IPs) do begin
if (ip4 = '') and (IPs[n].AddressFamily = AF_INET) then
ip4 := IPs[n].toString;
if (ip6 = '') and (IPs[n].AddressFamily = AF_INET6) then
ip6 := IPs[n].toString;
if (ip4 <> '') and (ip6 <> '') then
break;
end;
case Family of
AF_UNSPEC:
begin
if (ip4 <> '') and (ip6 <> '') then
begin
if PreferIP4 then
sip := ip4
else
Sip := ip6;
end
else
begin
sip := ip4;
if (ip6 <> '') then
sip := ip6;
end;
end;
AF_INET:
sip := ip4;
AF_INET6:
sip := ip6;
end;
sin := TVarSin.Create(IPAddress.Parse(sip), GetPortService(Port));
end;
function GetSinIP(Sin: TVarSin): string;
begin
Result := Sin.Address.ToString;
end;
function GetSinPort(Sin: TVarSin): Integer;
begin
Result := Sin.Port;
end;
procedure ResolveNameToIP(Name: string; Family: TAddrFamily; SockProtocol, SockType: integer; const IPList: TStrings);
var
IPs :array of IPAddress;
n: integer;
begin
IPList.Clear;
IPs := Dns.Resolve(Name).AddressList;
for n := low(IPs) to high(IPs) do
begin
if not(((Family = AF_INET6) and (IPs[n].AddressFamily = AF_INET))
or ((Family = AF_INET) and (IPs[n].AddressFamily = AF_INET6))) then
begin
IPList.Add(IPs[n].toString);
end;
end;
end;
function ResolvePort(Port: string; Family: TAddrFamily; SockProtocol, SockType: integer): Word;
var
n: integer;
begin
Result := StrToIntDef(port, 0);
if Result = 0 then
begin
port := Lowercase(port);
for n := 0 to High(Services) do
if services[n, 0] = port then
begin
Result := strtointdef(services[n, 1], 0);
break;
end;
end;
end;
function ResolveIPToName(IP: string; Family: TAddrFamily; SockProtocol, SockType: integer): string;
begin
Result := Dns.GetHostByAddress(IP).HostName;
end;
{=============================================================================}
function InitSocketInterface(stack: string): Boolean;
begin
Result := True;
end;
function DestroySocketInterface: Boolean;
begin
NullErr;
Result := True;
end;
initialization
begin
SynSockCS := SyncObjs.TCriticalSection.Create;
// SET_IN6_IF_ADDR_ANY (@in6addr_any);
// SET_LOOPBACK_ADDR6 (@in6addr_loopback);
end;
finalization
begin
NullErr;
SynSockCS.Free;
end;
{$ENDIF}
TransGUI/synapse/source/lib/sswin32.pas 0000644 0000000 0000000 00000151614 11366572451 016777 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 002.002.003 |
|==============================================================================|
| Content: Socket Independent Platform Layer - Win32 definition include |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@exclude}
//{$DEFINE WINSOCK1}
{Note about define WINSOCK1:
If you activate this compiler directive, then socket interface level 1.1 is
used instead default level 2.2. Level 2.2 is not available on old W95, however
you can install update.
}
//{$DEFINE FORCEOLDAPI}
{Note about define FORCEOLDAPI:
If you activate this compiler directive, then is allways used old socket API
for name resolution. If you leave this directive inactive, then the new API
is used, when running system allows it.
For IPv6 support you must have new API!
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF VER125}
{$DEFINE BCB}
{$ENDIF}
{$IFDEF BCB}
{$ObjExportAll On}
(*$HPPEMIT '/* EDE 2003-02-19 */' *)
(*$HPPEMIT 'namespace Synsock { using System::Shortint; }' *)
(*$HPPEMIT '#undef h_addr' *)
(*$HPPEMIT '#undef IOCPARM_MASK' *)
(*$HPPEMIT '#undef FD_SETSIZE' *)
(*$HPPEMIT '#undef IOC_VOID' *)
(*$HPPEMIT '#undef IOC_OUT' *)
(*$HPPEMIT '#undef IOC_IN' *)
(*$HPPEMIT '#undef IOC_INOUT' *)
(*$HPPEMIT '#undef FIONREAD' *)
(*$HPPEMIT '#undef FIONBIO' *)
(*$HPPEMIT '#undef FIOASYNC' *)
(*$HPPEMIT '#undef IPPROTO_IP' *)
(*$HPPEMIT '#undef IPPROTO_ICMP' *)
(*$HPPEMIT '#undef IPPROTO_IGMP' *)
(*$HPPEMIT '#undef IPPROTO_TCP' *)
(*$HPPEMIT '#undef IPPROTO_UDP' *)
(*$HPPEMIT '#undef IPPROTO_RAW' *)
(*$HPPEMIT '#undef IPPROTO_MAX' *)
(*$HPPEMIT '#undef INADDR_ANY' *)
(*$HPPEMIT '#undef INADDR_LOOPBACK' *)
(*$HPPEMIT '#undef INADDR_BROADCAST' *)
(*$HPPEMIT '#undef INADDR_NONE' *)
(*$HPPEMIT '#undef INVALID_SOCKET' *)
(*$HPPEMIT '#undef SOCKET_ERROR' *)
(*$HPPEMIT '#undef WSADESCRIPTION_LEN' *)
(*$HPPEMIT '#undef WSASYS_STATUS_LEN' *)
(*$HPPEMIT '#undef IP_OPTIONS' *)
(*$HPPEMIT '#undef IP_TOS' *)
(*$HPPEMIT '#undef IP_TTL' *)
(*$HPPEMIT '#undef IP_MULTICAST_IF' *)
(*$HPPEMIT '#undef IP_MULTICAST_TTL' *)
(*$HPPEMIT '#undef IP_MULTICAST_LOOP' *)
(*$HPPEMIT '#undef IP_ADD_MEMBERSHIP' *)
(*$HPPEMIT '#undef IP_DROP_MEMBERSHIP' *)
(*$HPPEMIT '#undef IP_DONTFRAGMENT' *)
(*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_TTL' *)
(*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_LOOP' *)
(*$HPPEMIT '#undef IP_MAX_MEMBERSHIPS' *)
(*$HPPEMIT '#undef SOL_SOCKET' *)
(*$HPPEMIT '#undef SO_DEBUG' *)
(*$HPPEMIT '#undef SO_ACCEPTCONN' *)
(*$HPPEMIT '#undef SO_REUSEADDR' *)
(*$HPPEMIT '#undef SO_KEEPALIVE' *)
(*$HPPEMIT '#undef SO_DONTROUTE' *)
(*$HPPEMIT '#undef SO_BROADCAST' *)
(*$HPPEMIT '#undef SO_USELOOPBACK' *)
(*$HPPEMIT '#undef SO_LINGER' *)
(*$HPPEMIT '#undef SO_OOBINLINE' *)
(*$HPPEMIT '#undef SO_DONTLINGER' *)
(*$HPPEMIT '#undef SO_SNDBUF' *)
(*$HPPEMIT '#undef SO_RCVBUF' *)
(*$HPPEMIT '#undef SO_SNDLOWAT' *)
(*$HPPEMIT '#undef SO_RCVLOWAT' *)
(*$HPPEMIT '#undef SO_SNDTIMEO' *)
(*$HPPEMIT '#undef SO_RCVTIMEO' *)
(*$HPPEMIT '#undef SO_ERROR' *)
(*$HPPEMIT '#undef SO_OPENTYPE' *)
(*$HPPEMIT '#undef SO_SYNCHRONOUS_ALERT' *)
(*$HPPEMIT '#undef SO_SYNCHRONOUS_NONALERT' *)
(*$HPPEMIT '#undef SO_MAXDG' *)
(*$HPPEMIT '#undef SO_MAXPATHDG' *)
(*$HPPEMIT '#undef SO_UPDATE_ACCEPT_CONTEXT' *)
(*$HPPEMIT '#undef SO_CONNECT_TIME' *)
(*$HPPEMIT '#undef SO_TYPE' *)
(*$HPPEMIT '#undef SOCK_STREAM' *)
(*$HPPEMIT '#undef SOCK_DGRAM' *)
(*$HPPEMIT '#undef SOCK_RAW' *)
(*$HPPEMIT '#undef SOCK_RDM' *)
(*$HPPEMIT '#undef SOCK_SEQPACKET' *)
(*$HPPEMIT '#undef TCP_NODELAY' *)
(*$HPPEMIT '#undef AF_UNSPEC' *)
(*$HPPEMIT '#undef SOMAXCONN' *)
(*$HPPEMIT '#undef AF_INET' *)
(*$HPPEMIT '#undef AF_MAX' *)
(*$HPPEMIT '#undef PF_UNSPEC' *)
(*$HPPEMIT '#undef PF_INET' *)
(*$HPPEMIT '#undef PF_MAX' *)
(*$HPPEMIT '#undef MSG_OOB' *)
(*$HPPEMIT '#undef MSG_PEEK' *)
(*$HPPEMIT '#undef WSABASEERR' *)
(*$HPPEMIT '#undef WSAEINTR' *)
(*$HPPEMIT '#undef WSAEBADF' *)
(*$HPPEMIT '#undef WSAEACCES' *)
(*$HPPEMIT '#undef WSAEFAULT' *)
(*$HPPEMIT '#undef WSAEINVAL' *)
(*$HPPEMIT '#undef WSAEMFILE' *)
(*$HPPEMIT '#undef WSAEWOULDBLOCK' *)
(*$HPPEMIT '#undef WSAEINPROGRESS' *)
(*$HPPEMIT '#undef WSAEALREADY' *)
(*$HPPEMIT '#undef WSAENOTSOCK' *)
(*$HPPEMIT '#undef WSAEDESTADDRREQ' *)
(*$HPPEMIT '#undef WSAEMSGSIZE' *)
(*$HPPEMIT '#undef WSAEPROTOTYPE' *)
(*$HPPEMIT '#undef WSAENOPROTOOPT' *)
(*$HPPEMIT '#undef WSAEPROTONOSUPPORT' *)
(*$HPPEMIT '#undef WSAESOCKTNOSUPPORT' *)
(*$HPPEMIT '#undef WSAEOPNOTSUPP' *)
(*$HPPEMIT '#undef WSAEPFNOSUPPORT' *)
(*$HPPEMIT '#undef WSAEAFNOSUPPORT' *)
(*$HPPEMIT '#undef WSAEADDRINUSE' *)
(*$HPPEMIT '#undef WSAEADDRNOTAVAIL' *)
(*$HPPEMIT '#undef WSAENETDOWN' *)
(*$HPPEMIT '#undef WSAENETUNREACH' *)
(*$HPPEMIT '#undef WSAENETRESET' *)
(*$HPPEMIT '#undef WSAECONNABORTED' *)
(*$HPPEMIT '#undef WSAECONNRESET' *)
(*$HPPEMIT '#undef WSAENOBUFS' *)
(*$HPPEMIT '#undef WSAEISCONN' *)
(*$HPPEMIT '#undef WSAENOTCONN' *)
(*$HPPEMIT '#undef WSAESHUTDOWN' *)
(*$HPPEMIT '#undef WSAETOOMANYREFS' *)
(*$HPPEMIT '#undef WSAETIMEDOUT' *)
(*$HPPEMIT '#undef WSAECONNREFUSED' *)
(*$HPPEMIT '#undef WSAELOOP' *)
(*$HPPEMIT '#undef WSAENAMETOOLONG' *)
(*$HPPEMIT '#undef WSAEHOSTDOWN' *)
(*$HPPEMIT '#undef WSAEHOSTUNREACH' *)
(*$HPPEMIT '#undef WSAENOTEMPTY' *)
(*$HPPEMIT '#undef WSAEPROCLIM' *)
(*$HPPEMIT '#undef WSAEUSERS' *)
(*$HPPEMIT '#undef WSAEDQUOT' *)
(*$HPPEMIT '#undef WSAESTALE' *)
(*$HPPEMIT '#undef WSAEREMOTE' *)
(*$HPPEMIT '#undef WSASYSNOTREADY' *)
(*$HPPEMIT '#undef WSAVERNOTSUPPORTED' *)
(*$HPPEMIT '#undef WSANOTINITIALISED' *)
(*$HPPEMIT '#undef WSAEDISCON' *)
(*$HPPEMIT '#undef WSAENOMORE' *)
(*$HPPEMIT '#undef WSAECANCELLED' *)
(*$HPPEMIT '#undef WSAEEINVALIDPROCTABLE' *)
(*$HPPEMIT '#undef WSAEINVALIDPROVIDER' *)
(*$HPPEMIT '#undef WSAEPROVIDERFAILEDINIT' *)
(*$HPPEMIT '#undef WSASYSCALLFAILURE' *)
(*$HPPEMIT '#undef WSASERVICE_NOT_FOUND' *)
(*$HPPEMIT '#undef WSATYPE_NOT_FOUND' *)
(*$HPPEMIT '#undef WSA_E_NO_MORE' *)
(*$HPPEMIT '#undef WSA_E_CANCELLED' *)
(*$HPPEMIT '#undef WSAEREFUSED' *)
(*$HPPEMIT '#undef WSAHOST_NOT_FOUND' *)
(*$HPPEMIT '#undef HOST_NOT_FOUND' *)
(*$HPPEMIT '#undef WSATRY_AGAIN' *)
(*$HPPEMIT '#undef TRY_AGAIN' *)
(*$HPPEMIT '#undef WSANO_RECOVERY' *)
(*$HPPEMIT '#undef NO_RECOVERY' *)
(*$HPPEMIT '#undef WSANO_DATA' *)
(*$HPPEMIT '#undef NO_DATA' *)
(*$HPPEMIT '#undef WSANO_ADDRESS' *)
(*$HPPEMIT '#undef ENAMETOOLONG' *)
(*$HPPEMIT '#undef ENOTEMPTY' *)
(*$HPPEMIT '#undef FD_CLR' *)
(*$HPPEMIT '#undef FD_ISSET' *)
(*$HPPEMIT '#undef FD_SET' *)
(*$HPPEMIT '#undef FD_ZERO' *)
(*$HPPEMIT '#undef NO_ADDRESS' *)
(*$HPPEMIT '#undef ADDR_ANY' *)
(*$HPPEMIT '#undef SO_GROUP_ID' *)
(*$HPPEMIT '#undef SO_GROUP_PRIORITY' *)
(*$HPPEMIT '#undef SO_MAX_MSG_SIZE' *)
(*$HPPEMIT '#undef SO_PROTOCOL_INFOA' *)
(*$HPPEMIT '#undef SO_PROTOCOL_INFOW' *)
(*$HPPEMIT '#undef SO_PROTOCOL_INFO' *)
(*$HPPEMIT '#undef PVD_CONFIG' *)
(*$HPPEMIT '#undef AF_INET6' *)
(*$HPPEMIT '#undef PF_INET6' *)
{$ENDIF}
interface
uses
SyncObjs, SysUtils, Classes,
Windows;
function InitSocketInterface(stack: String): Boolean;
function DestroySocketInterface: Boolean;
const
{$IFDEF WINSOCK1}
WinsockLevel = $0101;
{$ELSE}
WinsockLevel = $0202;
{$ENDIF}
type
u_short = Word;
u_int = Integer;
u_long = Longint;
pu_long = ^u_long;
pu_short = ^u_short;
{$IFDEF FPC}
TSocket = ptruint;
{$ELSE}
TSocket = u_int;
{$ENDIF}
TAddrFamily = integer;
TMemory = pointer;
const
{$IFDEF WINSOCK1}
DLLStackName = 'wsock32.dll';
{$ELSE}
DLLStackName = 'ws2_32.dll';
{$ENDIF}
DLLwship6 = 'wship6.dll';
cLocalhost = '127.0.0.1';
cAnyHost = '0.0.0.0';
cBroadcast = '255.255.255.255';
c6Localhost = '::1';
c6AnyHost = '::0';
c6Broadcast = 'ffff::1';
cAnyPort = '0';
const
FD_SETSIZE = 64;
type
PFDSet = ^TFDSet;
TFDSet = record
fd_count: u_int;
fd_array: array[0..FD_SETSIZE-1] of TSocket;
end;
const
FIONREAD = $4004667f;
FIONBIO = $8004667e;
FIOASYNC = $8004667d;
type
PTimeVal = ^TTimeVal;
TTimeVal = record
tv_sec: Longint;
tv_usec: Longint;
end;
const
IPPROTO_IP = 0; { Dummy }
IPPROTO_ICMP = 1; { Internet Control Message Protocol }
IPPROTO_IGMP = 2; { Internet Group Management Protocol}
IPPROTO_TCP = 6; { TCP }
IPPROTO_UDP = 17; { User Datagram Protocol }
IPPROTO_IPV6 = 41;
IPPROTO_ICMPV6 = 58;
IPPROTO_RM = 113;
IPPROTO_RAW = 255;
IPPROTO_MAX = 256;
type
PInAddr = ^TInAddr;
TInAddr = record
case integer of
0: (S_bytes: packed array [0..3] of byte);
1: (S_addr: u_long);
end;
PSockAddrIn = ^TSockAddrIn;
TSockAddrIn = record
case Integer of
0: (sin_family: u_short;
sin_port: u_short;
sin_addr: TInAddr;
sin_zero: array[0..7] of byte);
1: (sa_family: u_short;
sa_data: array[0..13] of byte)
end;
TIP_mreq = record
imr_multiaddr: TInAddr; { IP multicast address of group }
imr_interface: TInAddr; { local IP address of interface }
end;
PInAddr6 = ^TInAddr6;
TInAddr6 = record
case integer of
0: (S6_addr: packed array [0..15] of byte);
1: (u6_addr8: packed array [0..15] of byte);
2: (u6_addr16: packed array [0..7] of word);
3: (u6_addr32: packed array [0..3] of integer);
end;
PSockAddrIn6 = ^TSockAddrIn6;
TSockAddrIn6 = record
sin6_family: u_short; // AF_INET6
sin6_port: u_short; // Transport level port number
sin6_flowinfo: u_long; // IPv6 flow information
sin6_addr: TInAddr6; // IPv6 address
sin6_scope_id: u_long; // Scope Id: IF number for link-local
// SITE id for site-local
end;
TIPv6_mreq = record
ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address.
ipv6mr_interface: integer; // Interface index.
padding: integer;
end;
PHostEnt = ^THostEnt;
THostEnt = record
h_name: PAnsiChar;
h_aliases: ^PAnsiChar;
h_addrtype: Smallint;
h_length: Smallint;
case integer of
0: (h_addr_list: ^PAnsiChar);
1: (h_addr: ^PInAddr);
end;
PNetEnt = ^TNetEnt;
TNetEnt = record
n_name: PAnsiChar;
n_aliases: ^PAnsiChar;
n_addrtype: Smallint;
n_net: u_long;
end;
PServEnt = ^TServEnt;
TServEnt = record
s_name: PAnsiChar;
s_aliases: ^PAnsiChar;
{$ifdef WIN64}
s_proto: PAnsiChar;
s_port: Smallint;
{$else}
s_port: Smallint;
s_proto: PAnsiChar;
{$endif}
end;
PProtoEnt = ^TProtoEnt;
TProtoEnt = record
p_name: PAnsiChar;
p_aliases: ^PAnsichar;
p_proto: Smallint;
end;
const
INADDR_ANY = $00000000;
INADDR_LOOPBACK = $7F000001;
INADDR_BROADCAST = $FFFFFFFF;
INADDR_NONE = $FFFFFFFF;
ADDR_ANY = INADDR_ANY;
INVALID_SOCKET = TSocket(NOT(0));
SOCKET_ERROR = -1;
Const
{$IFDEF WINSOCK1}
IP_OPTIONS = 1;
IP_MULTICAST_IF = 2; { set/get IP multicast interface }
IP_MULTICAST_TTL = 3; { set/get IP multicast timetolive }
IP_MULTICAST_LOOP = 4; { set/get IP multicast loopback }
IP_ADD_MEMBERSHIP = 5; { add an IP group membership }
IP_DROP_MEMBERSHIP = 6; { drop an IP group membership }
IP_TTL = 7; { set/get IP Time To Live }
IP_TOS = 8; { set/get IP Type Of Service }
IP_DONTFRAGMENT = 9; { set/get IP Don't Fragment flag }
{$ELSE}
IP_OPTIONS = 1;
IP_HDRINCL = 2;
IP_TOS = 3; { set/get IP Type Of Service }
IP_TTL = 4; { set/get IP Time To Live }
IP_MULTICAST_IF = 9; { set/get IP multicast interface }
IP_MULTICAST_TTL = 10; { set/get IP multicast timetolive }
IP_MULTICAST_LOOP = 11; { set/get IP multicast loopback }
IP_ADD_MEMBERSHIP = 12; { add an IP group membership }
IP_DROP_MEMBERSHIP = 13; { drop an IP group membership }
IP_DONTFRAGMENT = 14; { set/get IP Don't Fragment flag }
{$ENDIF}
IP_DEFAULT_MULTICAST_TTL = 1; { normally limit m'casts to 1 hop }
IP_DEFAULT_MULTICAST_LOOP = 1; { normally hear sends if a member }
IP_MAX_MEMBERSHIPS = 20; { per socket; must fit in one mbuf }
SOL_SOCKET = $ffff; {options for socket level }
{ Option flags per-socket. }
SO_DEBUG = $0001; { turn on debugging info recording }
SO_ACCEPTCONN = $0002; { socket has had listen() }
SO_REUSEADDR = $0004; { allow local address reuse }
SO_KEEPALIVE = $0008; { keep connections alive }
SO_DONTROUTE = $0010; { just use interface addresses }
SO_BROADCAST = $0020; { permit sending of broadcast msgs }
SO_USELOOPBACK = $0040; { bypass hardware when possible }
SO_LINGER = $0080; { linger on close if data present }
SO_OOBINLINE = $0100; { leave received OOB data in line }
SO_DONTLINGER = $ff7f;
{ Additional options. }
SO_SNDBUF = $1001; { send buffer size }
SO_RCVBUF = $1002; { receive buffer size }
SO_SNDLOWAT = $1003; { send low-water mark }
SO_RCVLOWAT = $1004; { receive low-water mark }
SO_SNDTIMEO = $1005; { send timeout }
SO_RCVTIMEO = $1006; { receive timeout }
SO_ERROR = $1007; { get error status and clear }
SO_TYPE = $1008; { get socket type }
{ WinSock 2 extension -- new options }
SO_GROUP_ID = $2001; { ID of a socket group}
SO_GROUP_PRIORITY = $2002; { the relative priority within a group}
SO_MAX_MSG_SIZE = $2003; { maximum message size }
SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure }
SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure }
SO_PROTOCOL_INFO = SO_PROTOCOL_INFOA;
PVD_CONFIG = $3001; {configuration info for service provider }
{ Option for opening sockets for synchronous access. }
SO_OPENTYPE = $7008;
SO_SYNCHRONOUS_ALERT = $10;
SO_SYNCHRONOUS_NONALERT = $20;
{ Other NT-specific options. }
SO_MAXDG = $7009;
SO_MAXPATHDG = $700A;
SO_UPDATE_ACCEPT_CONTEXT = $700B;
SO_CONNECT_TIME = $700C;
SOMAXCONN = $7fffffff;
IPV6_UNICAST_HOPS = 8; // ???
IPV6_MULTICAST_IF = 9; // set/get IP multicast i/f
IPV6_MULTICAST_HOPS = 10; // set/get IP multicast ttl
IPV6_MULTICAST_LOOP = 11; // set/get IP multicast loopback
IPV6_JOIN_GROUP = 12; // add an IP group membership
IPV6_LEAVE_GROUP = 13; // drop an IP group membership
MSG_NOSIGNAL = 0;
// getnameinfo constants
NI_MAXHOST = 1025;
NI_MAXSERV = 32;
NI_NOFQDN = $1;
NI_NUMERICHOST = $2;
NI_NAMEREQD = $4;
NI_NUMERICSERV = $8;
NI_DGRAM = $10;
const
SOCK_STREAM = 1; { stream socket }
SOCK_DGRAM = 2; { datagram socket }
SOCK_RAW = 3; { raw-protocol interface }
SOCK_RDM = 4; { reliably-delivered message }
SOCK_SEQPACKET = 5; { sequenced packet stream }
{ TCP options. }
TCP_NODELAY = $0001;
{ Address families. }
AF_UNSPEC = 0; { unspecified }
AF_INET = 2; { internetwork: UDP, TCP, etc. }
AF_INET6 = 23; { Internetwork Version 6 }
AF_MAX = 24;
{ Protocol families, same as address families for now. }
PF_UNSPEC = AF_UNSPEC;
PF_INET = AF_INET;
PF_INET6 = AF_INET6;
PF_MAX = AF_MAX;
type
{ Structure used by kernel to store most addresses. }
PSockAddr = ^TSockAddr;
TSockAddr = TSockAddrIn;
{ Structure used by kernel to pass protocol information in raw sockets. }
PSockProto = ^TSockProto;
TSockProto = record
sp_family: u_short;
sp_protocol: u_short;
end;
type
PAddrInfo = ^TAddrInfo;
TAddrInfo = record
ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST.
ai_family: integer; // PF_xxx.
ai_socktype: integer; // SOCK_xxx.
ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6.
ai_addrlen: u_int; // Length of ai_addr.
ai_canonname: PAnsiChar; // Canonical name for nodename.
ai_addr: PSockAddr; // Binary address.
ai_next: PAddrInfo; // Next structure in linked list.
end;
const
// Flags used in "hints" argument to getaddrinfo().
AI_PASSIVE = $1; // Socket address will be used in bind() call.
AI_CANONNAME = $2; // Return canonical name in first ai_canonname.
AI_NUMERICHOST = $4; // Nodename must be a numeric address string.
type
{ Structure used for manipulating linger option. }
PLinger = ^TLinger;
TLinger = record
l_onoff: u_short;
l_linger: u_short;
end;
const
MSG_OOB = $01; // Process out-of-band data.
MSG_PEEK = $02; // Peek at incoming messages.
const
{ All Windows Sockets error constants are biased by WSABASEERR from the "normal" }
WSABASEERR = 10000;
{ Windows Sockets definitions of regular Microsoft C error constants }
WSAEINTR = (WSABASEERR+4);
WSAEBADF = (WSABASEERR+9);
WSAEACCES = (WSABASEERR+13);
WSAEFAULT = (WSABASEERR+14);
WSAEINVAL = (WSABASEERR+22);
WSAEMFILE = (WSABASEERR+24);
{ Windows Sockets definitions of regular Berkeley error constants }
WSAEWOULDBLOCK = (WSABASEERR+35);
WSAEINPROGRESS = (WSABASEERR+36);
WSAEALREADY = (WSABASEERR+37);
WSAENOTSOCK = (WSABASEERR+38);
WSAEDESTADDRREQ = (WSABASEERR+39);
WSAEMSGSIZE = (WSABASEERR+40);
WSAEPROTOTYPE = (WSABASEERR+41);
WSAENOPROTOOPT = (WSABASEERR+42);
WSAEPROTONOSUPPORT = (WSABASEERR+43);
WSAESOCKTNOSUPPORT = (WSABASEERR+44);
WSAEOPNOTSUPP = (WSABASEERR+45);
WSAEPFNOSUPPORT = (WSABASEERR+46);
WSAEAFNOSUPPORT = (WSABASEERR+47);
WSAEADDRINUSE = (WSABASEERR+48);
WSAEADDRNOTAVAIL = (WSABASEERR+49);
WSAENETDOWN = (WSABASEERR+50);
WSAENETUNREACH = (WSABASEERR+51);
WSAENETRESET = (WSABASEERR+52);
WSAECONNABORTED = (WSABASEERR+53);
WSAECONNRESET = (WSABASEERR+54);
WSAENOBUFS = (WSABASEERR+55);
WSAEISCONN = (WSABASEERR+56);
WSAENOTCONN = (WSABASEERR+57);
WSAESHUTDOWN = (WSABASEERR+58);
WSAETOOMANYREFS = (WSABASEERR+59);
WSAETIMEDOUT = (WSABASEERR+60);
WSAECONNREFUSED = (WSABASEERR+61);
WSAELOOP = (WSABASEERR+62);
WSAENAMETOOLONG = (WSABASEERR+63);
WSAEHOSTDOWN = (WSABASEERR+64);
WSAEHOSTUNREACH = (WSABASEERR+65);
WSAENOTEMPTY = (WSABASEERR+66);
WSAEPROCLIM = (WSABASEERR+67);
WSAEUSERS = (WSABASEERR+68);
WSAEDQUOT = (WSABASEERR+69);
WSAESTALE = (WSABASEERR+70);
WSAEREMOTE = (WSABASEERR+71);
{ Extended Windows Sockets error constant definitions }
WSASYSNOTREADY = (WSABASEERR+91);
WSAVERNOTSUPPORTED = (WSABASEERR+92);
WSANOTINITIALISED = (WSABASEERR+93);
WSAEDISCON = (WSABASEERR+101);
WSAENOMORE = (WSABASEERR+102);
WSAECANCELLED = (WSABASEERR+103);
WSAEEINVALIDPROCTABLE = (WSABASEERR+104);
WSAEINVALIDPROVIDER = (WSABASEERR+105);
WSAEPROVIDERFAILEDINIT = (WSABASEERR+106);
WSASYSCALLFAILURE = (WSABASEERR+107);
WSASERVICE_NOT_FOUND = (WSABASEERR+108);
WSATYPE_NOT_FOUND = (WSABASEERR+109);
WSA_E_NO_MORE = (WSABASEERR+110);
WSA_E_CANCELLED = (WSABASEERR+111);
WSAEREFUSED = (WSABASEERR+112);
{ Error return codes from gethostbyname() and gethostbyaddr()
(when using the resolver). Note that these errors are
retrieved via WSAGetLastError() and must therefore follow
the rules for avoiding clashes with error numbers from
specific implementations or language run-time systems.
For this reason the codes are based at WSABASEERR+1001.
Note also that [WSA]NO_ADDRESS is defined only for
compatibility purposes. }
{ Authoritative Answer: Host not found }
WSAHOST_NOT_FOUND = (WSABASEERR+1001);
HOST_NOT_FOUND = WSAHOST_NOT_FOUND;
{ Non-Authoritative: Host not found, or SERVERFAIL }
WSATRY_AGAIN = (WSABASEERR+1002);
TRY_AGAIN = WSATRY_AGAIN;
{ Non recoverable errors, FORMERR, REFUSED, NOTIMP }
WSANO_RECOVERY = (WSABASEERR+1003);
NO_RECOVERY = WSANO_RECOVERY;
{ Valid name, no data record of requested type }
WSANO_DATA = (WSABASEERR+1004);
NO_DATA = WSANO_DATA;
{ no address, look for MX record }
WSANO_ADDRESS = WSANO_DATA;
NO_ADDRESS = WSANO_ADDRESS;
EWOULDBLOCK = WSAEWOULDBLOCK;
EINPROGRESS = WSAEINPROGRESS;
EALREADY = WSAEALREADY;
ENOTSOCK = WSAENOTSOCK;
EDESTADDRREQ = WSAEDESTADDRREQ;
EMSGSIZE = WSAEMSGSIZE;
EPROTOTYPE = WSAEPROTOTYPE;
ENOPROTOOPT = WSAENOPROTOOPT;
EPROTONOSUPPORT = WSAEPROTONOSUPPORT;
ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT;
EOPNOTSUPP = WSAEOPNOTSUPP;
EPFNOSUPPORT = WSAEPFNOSUPPORT;
EAFNOSUPPORT = WSAEAFNOSUPPORT;
EADDRINUSE = WSAEADDRINUSE;
EADDRNOTAVAIL = WSAEADDRNOTAVAIL;
ENETDOWN = WSAENETDOWN;
ENETUNREACH = WSAENETUNREACH;
ENETRESET = WSAENETRESET;
ECONNABORTED = WSAECONNABORTED;
ECONNRESET = WSAECONNRESET;
ENOBUFS = WSAENOBUFS;
EISCONN = WSAEISCONN;
ENOTCONN = WSAENOTCONN;
ESHUTDOWN = WSAESHUTDOWN;
ETOOMANYREFS = WSAETOOMANYREFS;
ETIMEDOUT = WSAETIMEDOUT;
ECONNREFUSED = WSAECONNREFUSED;
ELOOP = WSAELOOP;
ENAMETOOLONG = WSAENAMETOOLONG;
EHOSTDOWN = WSAEHOSTDOWN;
EHOSTUNREACH = WSAEHOSTUNREACH;
ENOTEMPTY = WSAENOTEMPTY;
EPROCLIM = WSAEPROCLIM;
EUSERS = WSAEUSERS;
EDQUOT = WSAEDQUOT;
ESTALE = WSAESTALE;
EREMOTE = WSAEREMOTE;
EAI_ADDRFAMILY = 1; // Address family for nodename not supported.
EAI_AGAIN = 2; // Temporary failure in name resolution.
EAI_BADFLAGS = 3; // Invalid value for ai_flags.
EAI_FAIL = 4; // Non-recoverable failure in name resolution.
EAI_FAMILY = 5; // Address family ai_family not supported.
EAI_MEMORY = 6; // Memory allocation failure.
EAI_NODATA = 7; // No address associated with nodename.
EAI_NONAME = 8; // Nodename nor servname provided, or not known.
EAI_SERVICE = 9; // Servname not supported for ai_socktype.
EAI_SOCKTYPE = 10; // Socket type ai_socktype not supported.
EAI_SYSTEM = 11; // System error returned in errno.
const
WSADESCRIPTION_LEN = 256;
WSASYS_STATUS_LEN = 128;
type
PWSAData = ^TWSAData;
TWSAData = record
wVersion: Word;
wHighVersion: Word;
{$ifdef win64}
iMaxSockets : Word;
iMaxUdpDg : Word;
lpVendorInfo : PAnsiChar;
szDescription : array[0..WSADESCRIPTION_LEN] of AnsiChar;
szSystemStatus : array[0..WSASYS_STATUS_LEN] of AnsiChar;
{$else}
szDescription: array[0..WSADESCRIPTION_LEN] of AnsiChar;
szSystemStatus: array[0..WSASYS_STATUS_LEN] of AnsiChar;
iMaxSockets: Word;
iMaxUdpDg: Word;
lpVendorInfo: PAnsiChar;
{$endif}
end;
function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean;
procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
var
in6addr_any, in6addr_loopback : TInAddr6;
procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
procedure FD_ZERO(var FDSet: TFDSet);
{=============================================================================}
type
TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer;
stdcall;
TWSACleanup = function: Integer;
stdcall;
TWSAGetLastError = function: Integer;
stdcall;
TGetServByName = function(name, proto: PAnsiChar): PServEnt;
stdcall;
TGetServByPort = function(port: Integer; proto: PAnsiChar): PServEnt;
stdcall;
TGetProtoByName = function(name: PAnsiChar): PProtoEnt;
stdcall;
TGetProtoByNumber = function(proto: Integer): PProtoEnt;
stdcall;
TGetHostByName = function(name: PAnsiChar): PHostEnt;
stdcall;
TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt;
stdcall;
TGetHostName = function(name: PAnsiChar; len: Integer): Integer;
stdcall;
TShutdown = function(s: TSocket; how: Integer): Integer;
stdcall;
TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar;
optlen: Integer): Integer;
stdcall;
TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar;
var optlen: Integer): Integer;
stdcall;
TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr;
tolen: Integer): Integer;
stdcall;
TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer;
stdcall;
TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer;
stdcall;
TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr;
var fromlen: Integer): Integer;
stdcall;
Tntohs = function(netshort: u_short): u_short;
stdcall;
Tntohl = function(netlong: u_long): u_long;
stdcall;
TListen = function(s: TSocket; backlog: Integer): Integer;
stdcall;
TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: Integer): Integer;
stdcall;
TInet_ntoa = function(inaddr: TInAddr): PAnsiChar;
stdcall;
TInet_addr = function(cp: PAnsiChar): u_long;
stdcall;
Thtons = function(hostshort: u_short): u_short;
stdcall;
Thtonl = function(hostlong: u_long): u_long;
stdcall;
TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
stdcall;
TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
stdcall;
TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer;
stdcall;
TCloseSocket = function(s: TSocket): Integer;
stdcall;
TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer;
stdcall;
TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket;
stdcall;
TTSocket = function(af, Struc, Protocol: Integer): TSocket;
stdcall;
TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint;
stdcall;
TGetAddrInfo = function(NodeName: PAnsiChar; ServName: PAnsiChar; Hints: PAddrInfo;
var Addrinfo: PAddrInfo): integer;
stdcall;
TFreeAddrInfo = procedure(ai: PAddrInfo);
stdcall;
TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PAnsiChar;
hostlen: DWORD; serv: PAnsiChar; servlen: DWORD; flags: integer): integer;
stdcall;
T__WSAFDIsSet = function (s: TSocket; var FDSet: TFDSet): Bool;
stdcall;
TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer;
cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD;
lpcbBytesReturned: PDWORD; lpOverlapped: Pointer;
lpCompletionRoutine: pointer): u_int;
stdcall;
var
WSAStartup: TWSAStartup = nil;
WSACleanup: TWSACleanup = nil;
WSAGetLastError: TWSAGetLastError = nil;
GetServByName: TGetServByName = nil;
GetServByPort: TGetServByPort = nil;
GetProtoByName: TGetProtoByName = nil;
GetProtoByNumber: TGetProtoByNumber = nil;
GetHostByName: TGetHostByName = nil;
GetHostByAddr: TGetHostByAddr = nil;
ssGetHostName: TGetHostName = nil;
Shutdown: TShutdown = nil;
SetSockOpt: TSetSockOpt = nil;
GetSockOpt: TGetSockOpt = nil;
ssSendTo: TSendTo = nil;
ssSend: TSend = nil;
ssRecv: TRecv = nil;
ssRecvFrom: TRecvFrom = nil;
ntohs: Tntohs = nil;
ntohl: Tntohl = nil;
Listen: TListen = nil;
IoctlSocket: TIoctlSocket = nil;
Inet_ntoa: TInet_ntoa = nil;
Inet_addr: TInet_addr = nil;
htons: Thtons = nil;
htonl: Thtonl = nil;
ssGetSockName: TGetSockName = nil;
ssGetPeerName: TGetPeerName = nil;
ssConnect: TConnect = nil;
CloseSocket: TCloseSocket = nil;
ssBind: TBind = nil;
ssAccept: TAccept = nil;
Socket: TTSocket = nil;
Select: TSelect = nil;
GetAddrInfo: TGetAddrInfo = nil;
FreeAddrInfo: TFreeAddrInfo = nil;
GetNameInfo: TGetNameInfo = nil;
__WSAFDIsSet: T__WSAFDIsSet = nil;
WSAIoctl: TWSAIoctl = nil;
var
SynSockCS: SyncObjs.TCriticalSection;
SockEnhancedApi: Boolean;
SockWship6Api: Boolean;
type
TVarSin = packed record
case integer of
0: (AddressFamily: u_short);
1: (
case sin_family: u_short of
AF_INET: (sin_port: u_short;
sin_addr: TInAddr;
sin_zero: array[0..7] of byte);
AF_INET6: (sin6_port: u_short;
sin6_flowinfo: u_long;
sin6_addr: TInAddr6;
sin6_scope_id: u_long);
);
end;
function SizeOfVarSin(sin: TVarSin): integer;
function Bind(s: TSocket; const addr: TVarSin): Integer;
function Connect(s: TSocket; const name: TVarSin): Integer;
function GetSockName(s: TSocket; var name: TVarSin): Integer;
function GetPeerName(s: TSocket; var name: TVarSin): Integer;
function GetHostName: AnsiString;
function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
function Accept(s: TSocket; var addr: TVarSin): TSocket;
function IsNewApi(Family: integer): Boolean;
function SetVarSin(var Sin: TVarSin; IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
function GetSinIP(Sin: TVarSin): AnsiString;
function GetSinPort(Sin: TVarSin): Integer;
procedure ResolveNameToIP(Name: AnsiString; Family, SockProtocol, SockType: integer; const IPList: TStrings);
function ResolveIPToName(IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString;
function ResolvePort(Port: AnsiString; Family, SockProtocol, SockType: integer): Word;
{==============================================================================}
implementation
var
SynSockCount: Integer = 0;
LibHandle: THandle = 0;
Libwship6Handle: THandle = 0;
function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
(a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0));
end;
function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
(a^.u6_addr32[2] = 0) and
(a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and
(a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1));
end;
function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80));
end;
function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0));
end;
function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
begin
Result := (a^.u6_addr8[0] = $FF);
end;
function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean;
begin
Result := (CompareMem( a, b, sizeof(TInAddr6)));
end;
procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
begin
FillChar(a^, sizeof(TInAddr6), 0);
end;
procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
begin
FillChar(a^, sizeof(TInAddr6), 0);
a^.u6_addr8[15] := 1;
end;
{=============================================================================}
procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
var
I: Integer;
begin
I := 0;
while I < FDSet.fd_count do
begin
if FDSet.fd_array[I] = Socket then
begin
while I < FDSet.fd_count - 1 do
begin
FDSet.fd_array[I] := FDSet.fd_array[I + 1];
Inc(I);
end;
Dec(FDSet.fd_count);
Break;
end;
Inc(I);
end;
end;
function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
begin
Result := __WSAFDIsSet(Socket, FDSet);
end;
procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
begin
if FDSet.fd_count < FD_SETSIZE then
begin
FDSet.fd_array[FDSet.fd_count] := Socket;
Inc(FDSet.fd_count);
end;
end;
procedure FD_ZERO(var FDSet: TFDSet);
begin
FDSet.fd_count := 0;
end;
{=============================================================================}
function SizeOfVarSin(sin: TVarSin): integer;
begin
case sin.sin_family of
AF_INET:
Result := SizeOf(TSockAddrIn);
AF_INET6:
Result := SizeOf(TSockAddrIn6);
else
Result := 0;
end;
end;
{=============================================================================}
function Bind(s: TSocket; const addr: TVarSin): Integer;
begin
Result := ssBind(s, @addr, SizeOfVarSin(addr));
end;
function Connect(s: TSocket; const name: TVarSin): Integer;
begin
Result := ssConnect(s, @name, SizeOfVarSin(name));
end;
function GetSockName(s: TSocket; var name: TVarSin): Integer;
var
len: integer;
begin
len := SizeOf(name);
FillChar(name, len, 0);
Result := ssGetSockName(s, @name, Len);
end;
function GetPeerName(s: TSocket; var name: TVarSin): Integer;
var
len: integer;
begin
len := SizeOf(name);
FillChar(name, len, 0);
Result := ssGetPeerName(s, @name, Len);
end;
function GetHostName: AnsiString;
var
s: AnsiString;
begin
Result := '';
setlength(s, 255);
ssGetHostName(pAnsichar(s), Length(s) - 1);
Result := PAnsichar(s);
end;
function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
begin
Result := ssSend(s, Buf^, len, flags);
end;
function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
begin
Result := ssRecv(s, Buf^, len, flags);
end;
function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
begin
Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto));
end;
function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
var
x: integer;
begin
x := SizeOf(from);
Result := ssRecvFrom(s, Buf^, len, flags, @from, x);
end;
function Accept(s: TSocket; var addr: TVarSin): TSocket;
var
x: integer;
begin
x := SizeOf(addr);
Result := ssAccept(s, @addr, x);
end;
{=============================================================================}
function IsNewApi(Family: integer): Boolean;
begin
Result := SockEnhancedApi;
if not Result then
Result := (Family = AF_INET6) and SockWship6Api;
end;
function SetVarSin(var Sin: TVarSin; IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
type
pu_long = ^u_long;
var
ProtoEnt: PProtoEnt;
ServEnt: PServEnt;
HostEnt: PHostEnt;
r: integer;
Hints1, Hints2: TAddrInfo;
Sin1, Sin2: TVarSin;
TwoPass: boolean;
function GetAddr(const IP, port: AnsiString; Hints: TAddrInfo; var Sin: TVarSin): integer;
var
Addr: PAddrInfo;
begin
Addr := nil;
try
FillChar(Sin, Sizeof(Sin), 0);
if Hints.ai_socktype = SOCK_RAW then
begin
Hints.ai_socktype := 0;
Hints.ai_protocol := 0;
Result := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr);
end
else
begin
if (IP = cAnyHost) or (IP = c6AnyHost) then
begin
Hints.ai_flags := AI_PASSIVE;
Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr);
end
else
if (IP = cLocalhost) or (IP = c6Localhost) then
begin
Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr);
end
else
begin
Result := synsock.GetAddrInfo(PAnsiChar(IP), PAnsiChar(Port), @Hints, Addr);
end;
end;
if Result = 0 then
if (Addr <> nil) then
Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen);
finally
if Assigned(Addr) then
synsock.FreeAddrInfo(Addr);
end;
end;
begin
Result := 0;
FillChar(Sin, Sizeof(Sin), 0);
if not IsNewApi(family) then
begin
SynSockCS.Enter;
try
Sin.sin_family := AF_INET;
ProtoEnt := synsock.GetProtoByNumber(SockProtocol);
ServEnt := nil;
if (ProtoEnt <> nil) and (StrToIntDef(string(Port),-1) =-1) then
ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name);
if ServEnt = nil then
Sin.sin_port := synsock.htons(StrToIntDef(string(Port), 0))
else
Sin.sin_port := ServEnt^.s_port;
if IP = cBroadcast then
Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST)
else
begin
Sin.sin_addr.s_addr := synsock.inet_addr(PAnsiChar(IP));
if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then
begin
HostEnt := synsock.GetHostByName(PAnsiChar(IP));
Result := synsock.WSAGetLastError;
if HostEnt <> nil then
Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^);
end;
end;
finally
SynSockCS.Leave;
end;
end
else
begin
FillChar(Hints1, Sizeof(Hints1), 0);
FillChar(Hints2, Sizeof(Hints2), 0);
TwoPass := False;
if Family = AF_UNSPEC then
begin
if PreferIP4 then
begin
Hints1.ai_family := AF_INET;
Hints2.ai_family := AF_INET6;
TwoPass := True;
end
else
begin
Hints2.ai_family := AF_INET;
Hints1.ai_family := AF_INET6;
TwoPass := True;
end;
end
else
Hints1.ai_family := Family;
Hints1.ai_socktype := SockType;
Hints1.ai_protocol := SockProtocol;
Hints2.ai_socktype := Hints1.ai_socktype;
Hints2.ai_protocol := Hints1.ai_protocol;
r := GetAddr(IP, Port, Hints1, Sin1);
Result := r;
sin := sin1;
if r <> 0 then
if TwoPass then
begin
r := GetAddr(IP, Port, Hints2, Sin2);
Result := r;
if r = 0 then
sin := sin2;
end;
end;
end;
function GetSinIP(Sin: TVarSin): AnsiString;
var
p: PAnsiChar;
host, serv: AnsiString;
hostlen, servlen: integer;
r: integer;
begin
Result := '';
if not IsNewApi(Sin.AddressFamily) then
begin
p := synsock.inet_ntoa(Sin.sin_addr);
if p <> nil then
Result := p;
end
else
begin
hostlen := NI_MAXHOST;
servlen := NI_MAXSERV;
setlength(host, hostlen);
setlength(serv, servlen);
r := getnameinfo(@sin, SizeOfVarSin(sin), PAnsiChar(host), hostlen,
PAnsiChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV);
if r = 0 then
Result := PAnsiChar(host);
end;
end;
function GetSinPort(Sin: TVarSin): Integer;
begin
if (Sin.sin_family = AF_INET6) then
Result := synsock.ntohs(Sin.sin6_port)
else
Result := synsock.ntohs(Sin.sin_port);
end;
procedure ResolveNameToIP(Name: AnsiString; Family, SockProtocol, SockType: integer; const IPList: TStrings);
type
TaPInAddr = array[0..250] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
Hints: TAddrInfo;
Addr: PAddrInfo;
AddrNext: PAddrInfo;
r: integer;
host, serv: AnsiString;
hostlen, servlen: integer;
RemoteHost: PHostEnt;
IP: u_long;
PAdrPtr: PaPInAddr;
i: Integer;
s: String;
InAddr: TInAddr;
begin
IPList.Clear;
if not IsNewApi(Family) then
begin
IP := synsock.inet_addr(PAnsiChar(Name));
if IP = u_long(INADDR_NONE) then
begin
SynSockCS.Enter;
try
RemoteHost := synsock.GetHostByName(PAnsiChar(Name));
if RemoteHost <> nil then
begin
PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list);
i := 0;
while PAdrPtr^[i] <> nil do
begin
InAddr := PAdrPtr^[i]^;
s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1],
InAddr.S_bytes[2], InAddr.S_bytes[3]]);
IPList.Add(s);
Inc(i);
end;
end;
finally
SynSockCS.Leave;
end;
end
else
IPList.Add(string(Name));
end
else
begin
Addr := nil;
try
FillChar(Hints, Sizeof(Hints), 0);
Hints.ai_family := AF_UNSPEC;
Hints.ai_socktype := SockType;
Hints.ai_protocol := SockProtocol;
Hints.ai_flags := 0;
r := synsock.GetAddrInfo(PAnsiChar(Name), nil, @Hints, Addr);
if r = 0 then
begin
AddrNext := Addr;
while not(AddrNext = nil) do
begin
if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET))
or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then
begin
hostlen := NI_MAXHOST;
servlen := NI_MAXSERV;
setlength(host, hostlen);
setlength(serv, servlen);
r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen,
PAnsiChar(host), hostlen, PAnsiChar(serv), servlen,
NI_NUMERICHOST + NI_NUMERICSERV);
if r = 0 then
begin
host := PAnsiChar(host);
IPList.Add(string(host));
end;
end;
AddrNext := AddrNext^.ai_next;
end;
end;
finally
if Assigned(Addr) then
synsock.FreeAddrInfo(Addr);
end;
end;
if IPList.Count = 0 then
IPList.Add(cAnyHost);
end;
function ResolvePort(Port: AnsiString; Family, SockProtocol, SockType: integer): Word;
var
ProtoEnt: PProtoEnt;
ServEnt: PServEnt;
Hints: TAddrInfo;
Addr: PAddrInfo;
r: integer;
begin
Result := 0;
if not IsNewApi(Family) then
begin
SynSockCS.Enter;
try
ProtoEnt := synsock.GetProtoByNumber(SockProtocol);
ServEnt := nil;
if ProtoEnt <> nil then
ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name);
if ServEnt = nil then
Result := StrToIntDef(string(Port), 0)
else
Result := synsock.htons(ServEnt^.s_port);
finally
SynSockCS.Leave;
end;
end
else
begin
Addr := nil;
try
FillChar(Hints, Sizeof(Hints), 0);
Hints.ai_family := AF_UNSPEC;
Hints.ai_socktype := SockType;
Hints.ai_protocol := Sockprotocol;
Hints.ai_flags := AI_PASSIVE;
r := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr);
if (r = 0) and Assigned(Addr) then
begin
if Addr^.ai_family = AF_INET then
Result := synsock.htons(Addr^.ai_addr^.sin_port);
if Addr^.ai_family = AF_INET6 then
Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port);
end;
finally
if Assigned(Addr) then
synsock.FreeAddrInfo(Addr);
end;
end;
end;
function ResolveIPToName(IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString;
var
Hints: TAddrInfo;
Addr: PAddrInfo;
r: integer;
host, serv: AnsiString;
hostlen, servlen: integer;
RemoteHost: PHostEnt;
IPn: u_long;
begin
Result := IP;
if not IsNewApi(Family) then
begin
IPn := synsock.inet_addr(PAnsiChar(IP));
if IPn <> u_long(INADDR_NONE) then
begin
SynSockCS.Enter;
try
RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET);
if RemoteHost <> nil then
Result := RemoteHost^.h_name;
finally
SynSockCS.Leave;
end;
end;
end
else
begin
Addr := nil;
try
FillChar(Hints, Sizeof(Hints), 0);
Hints.ai_family := AF_UNSPEC;
Hints.ai_socktype := SockType;
Hints.ai_protocol := SockProtocol;
Hints.ai_flags := 0;
r := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr);
if (r = 0) and Assigned(Addr)then
begin
hostlen := NI_MAXHOST;
servlen := NI_MAXSERV;
setlength(host, hostlen);
setlength(serv, servlen);
r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen,
PAnsiChar(host), hostlen, PAnsiChar(serv), servlen,
NI_NUMERICSERV);
if r = 0 then
Result := PAnsiChar(host);
end;
finally
if Assigned(Addr) then
synsock.FreeAddrInfo(Addr);
end;
end;
end;
{=============================================================================}
function InitSocketInterface(stack: String): Boolean;
begin
Result := False;
SockEnhancedApi := False;
if stack = '' then
stack := DLLStackName;
SynSockCS.Enter;
try
if SynSockCount = 0 then
begin
SockEnhancedApi := False;
SockWship6Api := False;
LibHandle := LoadLibrary(PChar(Stack));
if LibHandle <> 0 then
begin
WSAIoctl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAIoctl')));
__WSAFDIsSet := GetProcAddress(LibHandle, PAnsiChar(AnsiString('__WSAFDIsSet')));
CloseSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('closesocket')));
IoctlSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ioctlsocket')));
WSAGetLastError := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAGetLastError')));
WSAStartup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAStartup')));
WSACleanup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSACleanup')));
ssAccept := GetProcAddress(LibHandle, PAnsiChar(AnsiString('accept')));
ssBind := GetProcAddress(LibHandle, PAnsiChar(AnsiString('bind')));
ssConnect := GetProcAddress(LibHandle, PAnsiChar(AnsiString('connect')));
ssGetPeerName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getpeername')));
ssGetSockName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockname')));
GetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockopt')));
Htonl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htonl')));
Htons := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htons')));
Inet_Addr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_addr')));
Inet_Ntoa := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_ntoa')));
Listen := GetProcAddress(LibHandle, PAnsiChar(AnsiString('listen')));
Ntohl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohl')));
Ntohs := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohs')));
ssRecv := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recv')));
ssRecvFrom := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recvfrom')));
Select := GetProcAddress(LibHandle, PAnsiChar(AnsiString('select')));
ssSend := GetProcAddress(LibHandle, PAnsiChar(AnsiString('send')));
ssSendTo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('sendto')));
SetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('setsockopt')));
ShutDown := GetProcAddress(LibHandle, PAnsiChar(AnsiString('shutdown')));
Socket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('socket')));
GetHostByAddr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyaddr')));
GetHostByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyname')));
GetProtoByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobyname')));
GetProtoByNumber := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobynumber')));
GetServByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyname')));
GetServByPort := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyport')));
ssGetHostName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostname')));
{$IFNDEF FORCEOLDAPI}
GetAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getaddrinfo')));
FreeAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('freeaddrinfo')));
GetNameInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getnameinfo')));
SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo)
and Assigned(GetNameInfo);
if not SockEnhancedApi then
begin
LibWship6Handle := LoadLibrary(PChar(DLLWship6));
if LibWship6Handle <> 0 then
begin
GetAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getaddrinfo')));
FreeAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('freeaddrinfo')));
GetNameInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getnameinfo')));
SockWship6Api := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo)
and Assigned(GetNameInfo);
end;
end;
{$ENDIF}
Result := True;
end;
end
else Result := True;
if Result then
Inc(SynSockCount);
finally
SynSockCS.Leave;
end;
end;
function DestroySocketInterface: Boolean;
begin
SynSockCS.Enter;
try
Dec(SynSockCount);
if SynSockCount < 0 then
SynSockCount := 0;
if SynSockCount = 0 then
begin
if LibHandle <> 0 then
begin
FreeLibrary(libHandle);
LibHandle := 0;
end;
if LibWship6Handle <> 0 then
begin
FreeLibrary(LibWship6Handle);
LibWship6Handle := 0;
end;
end;
finally
SynSockCS.Leave;
end;
Result := True;
end;
initialization
begin
SynSockCS := SyncObjs.TCriticalSection.Create;
SET_IN6_IF_ADDR_ANY (@in6addr_any);
SET_LOOPBACK_ADDR6 (@in6addr_loopback);
end;
finalization
begin
SynSockCS.Free;
end; TransGUI/synapse/source/lib/pingsend.pas 0000644 0000000 0000000 00000051045 11366572451 017273 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 004.000.002 |
|==============================================================================|
| Content: PING sender |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(ICMP PING implementation.)
Allows create PING and TRACEROUTE. Or you can diagnose your network.
This unit using IpHlpApi (on WinXP or higher) if available. Otherwise it trying
to use RAW sockets.
Warning: For use of RAW sockets you must have some special rights on some
systems. So, it working allways when you have administator/root rights.
Otherwise you can have problems!
Note: This unit is NOT portable to .NET!
Use native .NET classes for Ping instead.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$R-}
{$H+}
{$IFDEF CIL}
Sorry, this unit is not for .NET!
{$ENDIF}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit pingsend;
interface
uses
SysUtils,
synsock, blcksock, synautil, synafpc, synaip
{$IFDEF MSWINDOWS}
, windows
{$ENDIF}
;
const
ICMP_ECHO = 8;
ICMP_ECHOREPLY = 0;
ICMP_UNREACH = 3;
ICMP_TIME_EXCEEDED = 11;
//rfc-2292
ICMP6_ECHO = 128;
ICMP6_ECHOREPLY = 129;
ICMP6_UNREACH = 1;
ICMP6_TIME_EXCEEDED = 3;
type
{:List of possible ICMP reply packet types.}
TICMPError = (
IE_NoError,
IE_Other,
IE_TTLExceed,
IE_UnreachOther,
IE_UnreachRoute,
IE_UnreachAdmin,
IE_UnreachAddr,
IE_UnreachPort
);
{:@abstract(Implementation of ICMP PING and ICMPv6 PING.)}
TPINGSend = class(TSynaClient)
private
FSock: TICMPBlockSocket;
FBuffer: Ansistring;
FSeq: Integer;
FId: Integer;
FPacketSize: Integer;
FPingTime: Integer;
FIcmpEcho: Byte;
FIcmpEchoReply: Byte;
FIcmpUnreach: Byte;
FReplyFrom: string;
FReplyType: byte;
FReplyCode: byte;
FReplyError: TICMPError;
FReplyErrorDesc: string;
FTTL: Byte;
Fsin: TVarSin;
function Checksum(Value: AnsiString): Word;
function Checksum6(Value: AnsiString): Word;
function ReadPacket: Boolean;
procedure TranslateError;
procedure TranslateErrorIpHlp(value: integer);
function InternalPing(const Host: string): Boolean;
function InternalPingIpHlp(const Host: string): Boolean;
function IsHostIP6(const Host: string): Boolean;
procedure GenErrorDesc;
public
{:Send ICMP ping to host and count @link(pingtime). If ping OK, result is
@true.}
function Ping(const Host: string): Boolean;
constructor Create;
destructor Destroy; override;
published
{:Size of PING packet. Default size is 32 bytes.}
property PacketSize: Integer read FPacketSize Write FPacketSize;
{:Time between request and reply.}
property PingTime: Integer read FPingTime;
{:From this address is sended reply for your PING request. It maybe not your
requested destination, when some error occured!}
property ReplyFrom: string read FReplyFrom;
{:ICMP type of PING reply. Each protocol using another values! For IPv4 and
IPv6 are used different values!}
property ReplyType: byte read FReplyType;
{:ICMP code of PING reply. Each protocol using another values! For IPv4 and
IPv6 are used different values! For protocol independent value look to
@link(ReplyError)}
property ReplyCode: byte read FReplyCode;
{:Return type of returned ICMP message. This value is independent on used
protocol!}
property ReplyError: TICMPError read FReplyError;
{:Return human readable description of returned packet type.}
property ReplyErrorDesc: string read FReplyErrorDesc;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TICMPBlockSocket read FSock;
{:TTL value for ICMP query}
property TTL: byte read FTTL write FTTL;
end;
{:A very useful function and example of its use would be found in the TPINGSend
object. Use it to ping to any host. If successful, returns the ping time in
milliseconds. Returns -1 if an error occurred.}
function PingHost(const Host: string): Integer;
{:A very useful function and example of its use would be found in the TPINGSend
object. Use it to TraceRoute to any host.}
function TraceRouteHost(const Host: string): string;
implementation
type
{:Record for ICMP ECHO packet header.}
TIcmpEchoHeader = packed record
i_type: Byte;
i_code: Byte;
i_checkSum: Word;
i_Id: Word;
i_seq: Word;
TimeStamp: integer;
end;
{:record used internally by TPingSend for compute checksum of ICMPv6 packet
pseudoheader.}
TICMP6Packet = packed record
in_source: TInAddr6;
in_dest: TInAddr6;
Length: integer;
free0: Byte;
free1: Byte;
free2: Byte;
proto: Byte;
end;
{$IFDEF MSWINDOWS}
const
DLLIcmpName = 'iphlpapi.dll';
type
TIP_OPTION_INFORMATION = record
TTL: Byte;
TOS: Byte;
Flags: Byte;
OptionsSize: Byte;
OptionsData: PAnsiChar;
end;
PIP_OPTION_INFORMATION = ^TIP_OPTION_INFORMATION;
TICMP_ECHO_REPLY = record
Address: TInAddr;
Status: integer;
RoundTripTime: integer;
DataSize: Word;
Reserved: Word;
Data: pointer;
Options: TIP_OPTION_INFORMATION;
end;
PICMP_ECHO_REPLY = ^TICMP_ECHO_REPLY;
TICMPV6_ECHO_REPLY = record
Address: TSockAddrIn6;
Status: integer;
RoundTripTime: integer;
end;
PICMPV6_ECHO_REPLY = ^TICMPV6_ECHO_REPLY;
TIcmpCreateFile = function: integer; stdcall;
TIcmpCloseHandle = function(handle: integer): boolean; stdcall;
TIcmpSendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
ApcContext: pointer; DestinationAddress: TInAddr; RequestData: pointer;
RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
TIcmp6CreateFile = function: integer; stdcall;
TIcmp6SendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
ApcContext: pointer; SourceAddress: PSockAddrIn6; DestinationAddress: PSockAddrIn6;
RequestData: pointer; RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
var
IcmpDllHandle: TLibHandle = 0;
IcmpHelper4: boolean = false;
IcmpHelper6: boolean = false;
IcmpCreateFile: TIcmpCreateFile = nil;
IcmpCloseHandle: TIcmpCloseHandle = nil;
IcmpSendEcho2: TIcmpSendEcho2 = nil;
Icmp6CreateFile: TIcmp6CreateFile = nil;
Icmp6SendEcho2: TIcmp6SendEcho2 = nil;
{$ENDIF}
{==============================================================================}
constructor TPINGSend.Create;
begin
inherited Create;
FSock := TICMPBlockSocket.Create;
FSock.Owner := self;
FTimeout := 5000;
FPacketSize := 32;
FSeq := 0;
Randomize;
FTTL := 128;
end;
destructor TPINGSend.Destroy;
begin
FSock.Free;
inherited Destroy;
end;
function TPINGSend.ReadPacket: Boolean;
begin
FBuffer := FSock.RecvPacket(Ftimeout);
Result := FSock.LastError = 0;
end;
procedure TPINGSend.GenErrorDesc;
begin
case FReplyError of
IE_NoError:
FReplyErrorDesc := '';
IE_Other:
FReplyErrorDesc := 'Unknown error';
IE_TTLExceed:
FReplyErrorDesc := 'TTL Exceeded';
IE_UnreachOther:
FReplyErrorDesc := 'Unknown unreachable';
IE_UnreachRoute:
FReplyErrorDesc := 'No route to destination';
IE_UnreachAdmin:
FReplyErrorDesc := 'Administratively prohibited';
IE_UnreachAddr:
FReplyErrorDesc := 'Address unreachable';
IE_UnreachPort:
FReplyErrorDesc := 'Port unreachable';
end;
end;
function TPINGSend.IsHostIP6(const Host: string): Boolean;
var
f: integer;
begin
f := AF_UNSPEC;
if IsIp(Host) then
f := AF_INET
else
if IsIp6(Host) then
f := AF_INET6;
synsock.SetVarSin(Fsin, host, '0', f,
IPPROTO_UDP, SOCK_DGRAM, Fsock.PreferIP4);
result := Fsin.sin_family = AF_INET6;
end;
function TPINGSend.Ping(const Host: string): Boolean;
var
b: boolean;
begin
FPingTime := -1;
FReplyFrom := '';
FReplyType := 0;
FReplyCode := 0;
FReplyError := IE_Other;
GenErrorDesc;
FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize);
{$IFDEF MSWINDOWS}
b := IsHostIP6(host);
if not(b) and IcmpHelper4 then
result := InternalPingIpHlp(host)
else
if b and IcmpHelper6 then
result := InternalPingIpHlp(host)
else
result := InternalPing(host);
{$ELSE}
result := InternalPing(host);
{$ENDIF}
end;
function TPINGSend.InternalPing(const Host: string): Boolean;
var
IPHeadPtr: ^TIPHeader;
IpHdrLen: Integer;
IcmpEchoHeaderPtr: ^TICMPEchoHeader;
t: Boolean;
x: cardinal;
IcmpReqHead: string;
begin
Result := False;
FSock.TTL := FTTL;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(Host, '0');
if FSock.LastError <> 0 then
Exit;
FSock.SizeRecvBuffer := 60 * 1024;
if FSock.IP6used then
begin
FIcmpEcho := ICMP6_ECHO;
FIcmpEchoReply := ICMP6_ECHOREPLY;
FIcmpUnreach := ICMP6_UNREACH;
end
else
begin
FIcmpEcho := ICMP_ECHO;
FIcmpEchoReply := ICMP_ECHOREPLY;
FIcmpUnreach := ICMP_UNREACH;
end;
IcmpEchoHeaderPtr := Pointer(FBuffer);
with IcmpEchoHeaderPtr^ do
begin
i_type := FIcmpEcho;
i_code := 0;
i_CheckSum := 0;
FId := System.Random(32767);
i_Id := FId;
TimeStamp := GetTick;
Inc(FSeq);
i_Seq := FSeq;
if fSock.IP6used then
i_CheckSum := CheckSum6(FBuffer)
else
i_CheckSum := CheckSum(FBuffer);
end;
FSock.SendString(FBuffer);
// remember first 8 bytes of ICMP packet
IcmpReqHead := Copy(FBuffer, 1, 8);
x := GetTick;
repeat
t := ReadPacket;
if not t then
break;
if fSock.IP6used then
begin
{$IFNDEF MSWINDOWS}
IcmpEchoHeaderPtr := Pointer(FBuffer);
{$ELSE}
//WinXP SP1 with networking update doing this think by another way ;-O
// FBuffer := StringOfChar(#0, 4) + FBuffer;
IcmpEchoHeaderPtr := Pointer(FBuffer);
// IcmpEchoHeaderPtr^.i_type := FIcmpEchoReply;
{$ENDIF}
end
else
begin
IPHeadPtr := Pointer(FBuffer);
IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4;
IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1];
end;
//check for timeout
if TickDelta(x, GetTick) > FTimeout then
begin
t := false;
Break;
end;
//it discard sometimes possible 'echoes' of previosly sended packet
//or other unwanted ICMP packets...
until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho)
and ((IcmpEchoHeaderPtr^.i_id = FId)
or (Pos(IcmpReqHead, FBuffer) > 0));
if t then
begin
FPingTime := TickDelta(x, GetTick);
FReplyFrom := FSock.GetRemoteSinIP;
FReplyType := IcmpEchoHeaderPtr^.i_type;
FReplyCode := IcmpEchoHeaderPtr^.i_code;
TranslateError;
Result := True;
end;
end;
function TPINGSend.Checksum(Value: AnsiString): Word;
var
CkSum: integer;
Num, Remain: Integer;
n, i: Integer;
begin
Num := Length(Value) div 2;
Remain := Length(Value) mod 2;
CkSum := 0;
i := 1;
for n := 0 to Num - 1 do
begin
CkSum := CkSum + Synsock.HtoNs(DecodeInt(Value, i));
inc(i, 2);
end;
if Remain <> 0 then
CkSum := CkSum + Ord(Value[Length(Value)]);
CkSum := (CkSum shr 16) + (CkSum and $FFFF);
CkSum := CkSum + (CkSum shr 16);
Result := Word(not CkSum);
end;
function TPINGSend.Checksum6(Value: AnsiString): Word;
const
IOC_OUT = $40000000;
IOC_IN = $80000000;
IOC_INOUT = (IOC_IN or IOC_OUT);
IOC_WS2 = $08000000;
SIO_ROUTING_INTERFACE_QUERY = 20 or IOC_WS2 or IOC_INOUT;
var
ICMP6Ptr: ^TICMP6Packet;
s: AnsiString;
b: integer;
ip6: TSockAddrIn6;
x: integer;
begin
Result := 0;
{$IFDEF MSWINDOWS}
s := StringOfChar(#0, SizeOf(TICMP6Packet)) + Value;
ICMP6Ptr := Pointer(s);
x := synsock.WSAIoctl(FSock.Socket, SIO_ROUTING_INTERFACE_QUERY,
@FSock.RemoteSin, SizeOf(FSock.RemoteSin),
@ip6, SizeOf(ip6), @b, nil, nil);
if x <> -1 then
ICMP6Ptr^.in_dest := ip6.sin6_addr
else
ICMP6Ptr^.in_dest := FSock.LocalSin.sin6_addr;
ICMP6Ptr^.in_source := FSock.RemoteSin.sin6_addr;
ICMP6Ptr^.Length := synsock.htonl(Length(Value));
ICMP6Ptr^.proto := IPPROTO_ICMPV6;
Result := Checksum(s);
{$ENDIF}
end;
procedure TPINGSend.TranslateError;
begin
if fSock.IP6used then
begin
case FReplyType of
ICMP6_ECHOREPLY:
FReplyError := IE_NoError;
ICMP6_TIME_EXCEEDED:
FReplyError := IE_TTLExceed;
ICMP6_UNREACH:
case FReplyCode of
0:
FReplyError := IE_UnreachRoute;
3:
FReplyError := IE_UnreachAddr;
4:
FReplyError := IE_UnreachPort;
1:
FReplyError := IE_UnreachAdmin;
else
FReplyError := IE_UnreachOther;
end;
else
FReplyError := IE_Other;
end;
end
else
begin
case FReplyType of
ICMP_ECHOREPLY:
FReplyError := IE_NoError;
ICMP_TIME_EXCEEDED:
FReplyError := IE_TTLExceed;
ICMP_UNREACH:
case FReplyCode of
0:
FReplyError := IE_UnreachRoute;
1:
FReplyError := IE_UnreachAddr;
3:
FReplyError := IE_UnreachPort;
13:
FReplyError := IE_UnreachAdmin;
else
FReplyError := IE_UnreachOther;
end;
else
FReplyError := IE_Other;
end;
end;
GenErrorDesc;
end;
procedure TPINGSend.TranslateErrorIpHlp(value: integer);
begin
case value of
11000, 0:
FReplyError := IE_NoError;
11013:
FReplyError := IE_TTLExceed;
11002:
FReplyError := IE_UnreachRoute;
11003:
FReplyError := IE_UnreachAddr;
11005:
FReplyError := IE_UnreachPort;
11004:
FReplyError := IE_UnreachAdmin;
else
FReplyError := IE_Other;
end;
GenErrorDesc;
end;
function TPINGSend.InternalPingIpHlp(const Host: string): Boolean;
{$IFDEF MSWINDOWS}
var
PingIp6: boolean;
PingHandle: integer;
r: integer;
ipo: TIP_OPTION_INFORMATION;
RBuff: Ansistring;
ip4reply: PICMP_ECHO_REPLY;
ip6reply: PICMPV6_ECHO_REPLY;
ip6: TSockAddrIn6;
begin
Result := False;
PingIp6 := Fsin.sin_family = AF_INET6;
if pingIp6 then
PingHandle := Icmp6CreateFile
else
PingHandle := IcmpCreateFile;
if PingHandle <> -1 then
begin
try
ipo.TTL := FTTL;
ipo.TOS := 0;
ipo.Flags := 0;
ipo.OptionsSize := 0;
ipo.OptionsData := nil;
setlength(RBuff, 4096);
if pingIp6 then
begin
FillChar(ip6, sizeof(ip6), 0);
r := Icmp6SendEcho2(PingHandle, nil, nil, nil, @ip6, @Fsin,
PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout);
if r > 0 then
begin
RBuff := #0 + #0 + RBuff;
ip6reply := PICMPV6_ECHO_REPLY(pointer(RBuff));
FPingTime := ip6reply^.RoundTripTime;
ip6reply^.Address.sin6_family := AF_INET6;
FReplyFrom := GetSinIp(TVarSin(ip6reply^.Address));
TranslateErrorIpHlp(ip6reply^.Status);
Result := True;
end;
end
else
begin
r := IcmpSendEcho2(PingHandle, nil, nil, nil, Fsin.sin_addr,
PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout);
if r > 0 then
begin
ip4reply := PICMP_ECHO_REPLY(pointer(RBuff));
FPingTime := ip4reply^.RoundTripTime;
FReplyFrom := IpToStr(swapbytes(ip4reply^.Address.S_addr));
TranslateErrorIpHlp(ip4reply^.Status);
Result := True;
end;
end
finally
IcmpCloseHandle(PingHandle);
end;
end;
end;
{$ELSE}
begin
result := false;
end;
{$ENDIF}
{==============================================================================}
function PingHost(const Host: string): Integer;
begin
with TPINGSend.Create do
try
Result := -1;
if Ping(Host) then
if ReplyError = IE_NoError then
Result := PingTime;
finally
Free;
end;
end;
function TraceRouteHost(const Host: string): string;
var
Ping: TPingSend;
ttl : byte;
begin
Result := '';
Ping := TPINGSend.Create;
try
ttl := 1;
repeat
ping.TTL := ttl;
inc(ttl);
if ttl > 30 then
Break;
if not ping.Ping(Host) then
begin
Result := Result + cAnyHost+ ' Timeout' + CRLF;
continue;
end;
if (ping.ReplyError <> IE_NoError)
and (ping.ReplyError <> IE_TTLExceed) then
begin
Result := Result + Ping.ReplyFrom + ' ' + Ping.ReplyErrorDesc + CRLF;
break;
end;
Result := Result + Ping.ReplyFrom + ' ' + IntToStr(Ping.PingTime) + CRLF;
until ping.ReplyError = IE_NoError;
finally
Ping.Free;
end;
end;
{$IFDEF MSWINDOWS}
initialization
begin
IcmpHelper4 := false;
IcmpHelper6 := false;
IcmpDllHandle := LoadLibrary(DLLIcmpName);
if IcmpDllHandle <> 0 then
begin
IcmpCreateFile := GetProcAddress(IcmpDLLHandle, 'IcmpCreateFile');
IcmpCloseHandle := GetProcAddress(IcmpDLLHandle, 'IcmpCloseHandle');
IcmpSendEcho2 := GetProcAddress(IcmpDLLHandle, 'IcmpSendEcho2');
Icmp6CreateFile := GetProcAddress(IcmpDLLHandle, 'Icmp6CreateFile');
Icmp6SendEcho2 := GetProcAddress(IcmpDLLHandle, 'Icmp6SendEcho2');
IcmpHelper4 := assigned(IcmpCreateFile)
and assigned(IcmpCloseHandle)
and assigned(IcmpSendEcho2);
IcmpHelper6 := assigned(Icmp6CreateFile)
and assigned(Icmp6SendEcho2);
end;
end;
finalization
begin
FreeLibrary(IcmpDllHandle);
end;
{$ENDIF}
end.
TransGUI/synapse/source/lib/ftptsend.pas 0000644 0000000 0000000 00000027513 11366572451 017316 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.001.001 |
|==============================================================================|
| Content: Trivial FTP (TFTP) client and server |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{: @abstract(TFTP client and server protocol)
Used RFC: RFC-1350
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit ftptsend;
interface
uses
SysUtils, Classes,
blcksock, synautil;
const
cTFTPProtocol = '69';
cTFTP_RRQ = word(1);
cTFTP_WRQ = word(2);
cTFTP_DTA = word(3);
cTFTP_ACK = word(4);
cTFTP_ERR = word(5);
type
{:@abstract(Implementation of TFTP client and server)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TTFTPSend = class(TSynaClient)
private
FSock: TUDPBlockSocket;
FErrorCode: integer;
FErrorString: string;
FData: TMemoryStream;
FRequestIP: string;
FRequestPort: string;
function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
function RecvPacket(Serial: word; var Value: string): Boolean;
public
constructor Create;
destructor Destroy; override;
{:Upload @link(data) as file to TFTP server.}
function SendFile(const Filename: string): Boolean;
{:Download file from TFTP server to @link(data).}
function RecvFile(const Filename: string): Boolean;
{:Acts as TFTP server and wait for client request. When some request
incoming within Timeout, result is @true and parametres is filled with
information from request. You must handle this request, validate it, and
call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply
to TFTP Client.}
function WaitForRequest(var Req: word; var filename: string): Boolean;
{:send error to TFTP client, when you acts as TFTP server.}
procedure ReplyError(Error: word; Description: string);
{:Accept uploaded file from TFTP client to @link(data), when you acts as
TFTP server.}
function ReplyRecv: Boolean;
{:Accept download request file from TFTP client and send content of
@link(data), when you acts as TFTP server.}
function ReplySend: Boolean;
published
{:Code of TFTP error.}
property ErrorCode: integer read FErrorCode;
{:Human readable decription of TFTP error. (if is sended by remote side)}
property ErrorString: string read FErrorString;
{:MemoryStream with datas for sending or receiving}
property Data: TMemoryStream read FData;
{:Address of TFTP remote side.}
property RequestIP: string read FRequestIP write FRequestIP;
{:Port of TFTP remote side.}
property RequestPort: string read FRequestPort write FRequestPort;
end;
implementation
constructor TTFTPSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FTargetPort := cTFTPProtocol;
FData := TMemoryStream.Create;
FErrorCode := 0;
FErrorString := '';
end;
destructor TTFTPSend.Destroy;
begin
FSock.Free;
FData.Free;
inherited Destroy;
end;
function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
var
s, sh: string;
begin
FErrorCode := 0;
FErrorString := '';
Result := false;
if Cmd <> 2 then
s := CodeInt(Cmd) + CodeInt(Serial) + Value
else
s := CodeInt(Cmd) + Value;
FSock.SendString(s);
s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
if length(s) >= 4 then
begin
sh := CodeInt(4) + CodeInt(Serial);
if Pos(sh, s) = 1 then
Result := True
else
if s[1] = #5 then
begin
FErrorCode := DecodeInt(s, 3);
Delete(s, 1, 4);
FErrorString := SeparateLeft(s, #0);
end;
end;
end;
function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean;
var
s: string;
ser: word;
begin
FErrorCode := 0;
FErrorString := '';
Result := False;
Value := '';
s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
if length(s) >= 4 then
if DecodeInt(s, 1) = 3 then
begin
ser := DecodeInt(s, 3);
if ser = Serial then
begin
Delete(s, 1, 4);
Value := s;
S := CodeInt(4) + CodeInt(ser);
FSock.SendString(s);
Result := FSock.LastError = 0;
end
else
begin
S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0;
FSock.SendString(s);
end;
end;
if DecodeInt(s, 1) = 5 then
begin
FErrorCode := DecodeInt(s, 3);
Delete(s, 1, 4);
FErrorString := SeparateLeft(s, #0);
end;
end;
function TTFTPSend.SendFile(const Filename: string): Boolean;
var
s: string;
ser: word;
n, n1, n2: integer;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Connect(FTargetHost, FTargetPort);
try
if FSock.LastError = 0 then
begin
s := Filename + #0 + 'octet' + #0;
if not Sendpacket(2, 0, s) then
Exit;
ser := 1;
FData.Position := 0;
n1 := FData.Size div 512;
n2 := FData.Size mod 512;
for n := 1 to n1 do
begin
s := ReadStrFromStream(FData, 512);
// SetLength(s, 512);
// FData.Read(pointer(s)^, 512);
if not Sendpacket(3, ser, s) then
Exit;
inc(ser);
end;
s := ReadStrFromStream(FData, n2);
// SetLength(s, n2);
// FData.Read(pointer(s)^, n2);
if not Sendpacket(3, ser, s) then
Exit;
Result := True;
end;
finally
FSock.CloseSocket;
end;
end;
function TTFTPSend.RecvFile(const Filename: string): Boolean;
var
s: string;
ser: word;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Connect(FTargetHost, FTargetPort);
try
if FSock.LastError = 0 then
begin
s := CodeInt(1) + Filename + #0 + 'octet' + #0;
FSock.SendString(s);
if FSock.LastError <> 0 then
Exit;
FData.Clear;
ser := 1;
repeat
if not RecvPacket(ser, s) then
Exit;
inc(ser);
WriteStrToStream(FData, s);
// FData.Write(pointer(s)^, length(s));
until length(s) <> 512;
FData.Position := 0;
Result := true;
end;
finally
FSock.CloseSocket;
end;
end;
function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean;
var
s: string;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Bind('0.0.0.0', FTargetPort);
if FSock.LastError = 0 then
begin
s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
if Length(s) >= 4 then
begin
FRequestIP := FSock.GetRemoteSinIP;
FRequestPort := IntToStr(FSock.GetRemoteSinPort);
Req := DecodeInt(s, 1);
delete(s, 1, 2);
filename := Trim(SeparateLeft(s, #0));
s := SeparateRight(s, #0);
s := SeparateLeft(s, #0);
Result := lowercase(trim(s)) = 'octet';
end;
end;
end;
procedure TTFTPSend.ReplyError(Error: word; Description: string);
var
s: string;
begin
FSock.CloseSocket;
FSock.Connect(FRequestIP, FRequestPort);
s := CodeInt(5) + CodeInt(Error) + Description + #0;
FSock.SendString(s);
FSock.CloseSocket;
end;
function TTFTPSend.ReplyRecv: Boolean;
var
s: string;
ser: integer;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Connect(FRequestIP, FRequestPort);
try
s := CodeInt(4) + CodeInt(0);
FSock.SendString(s);
FData.Clear;
ser := 1;
repeat
if not RecvPacket(ser, s) then
Exit;
inc(ser);
WriteStrToStream(FData, s);
// FData.Write(pointer(s)^, length(s));
until length(s) <> 512;
FData.Position := 0;
Result := true;
finally
FSock.CloseSocket;
end;
end;
function TTFTPSend.ReplySend: Boolean;
var
s: string;
ser: word;
n, n1, n2: integer;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Connect(FRequestIP, FRequestPort);
try
ser := 1;
FData.Position := 0;
n1 := FData.Size div 512;
n2 := FData.Size mod 512;
for n := 1 to n1 do
begin
s := ReadStrFromStream(FData, 512);
// SetLength(s, 512);
// FData.Read(pointer(s)^, 512);
if not Sendpacket(3, ser, s) then
Exit;
inc(ser);
end;
s := ReadStrFromStream(FData, n2);
// SetLength(s, n2);
// FData.Read(pointer(s)^, n2);
if not Sendpacket(3, ser, s) then
Exit;
Result := True;
finally
FSock.CloseSocket;
end;
end;
{==============================================================================}
end.
TransGUI/synapse/source/lib/synafpc.pas 0000644 0000000 0000000 00000012042 11366572451 017121 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.001.002 |
|==============================================================================|
| Content: Utils for FreePascal compatibility |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@exclude}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
unit synafpc;
interface
uses
{$IFDEF FPC}
dynlibs, sysutils;
{$ELSE}
{$IFDEF MSWINDOWS}
Windows;
{$ELSE}
SysUtils;
{$ENDIF}
{$ENDIF}
{$IFDEF FPC}
type
TLibHandle = dynlibs.TLibHandle;
function LoadLibrary(ModuleName: PChar): TLibHandle;
function FreeLibrary(Module: TLibHandle): LongBool;
function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;
{$ELSE}
type
{$IFDEF CIL}
TLibHandle = Integer;
{$ELSE}
TLibHandle = HModule;
{$ENDIF}
{$IFDEF VER100}
LongWord = DWord;
{$ENDIF}
{$ENDIF}
procedure Sleep(milliseconds: Cardinal);
implementation
{==============================================================================}
{$IFDEF FPC}
function LoadLibrary(ModuleName: PChar): TLibHandle;
begin
Result := dynlibs.LoadLibrary(Modulename);
end;
function FreeLibrary(Module: TLibHandle): LongBool;
begin
Result := dynlibs.UnloadLibrary(Module);
end;
function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
begin
Result := dynlibs.GetProcedureAddress(Module, Proc);
end;
function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;
begin
Result := 0;
end;
{$ELSE}
{$ENDIF}
procedure Sleep(milliseconds: Cardinal);
begin
{$IFDEF MSWINDOWS}
{$IFDEF FPC}
sysutils.sleep(milliseconds);
{$ELSE}
windows.sleep(milliseconds);
{$ENDIF}
{$ELSE}
sysutils.sleep(milliseconds);
{$ENDIF}
end;
end.
TransGUI/synapse/source/lib/synsock.pas 0000644 0000000 0000000 00000007572 11366572451 017163 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 005.002.000 |
|==============================================================================|
| Content: Socket Independent Platform Layer |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-20010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@exclude}
unit synsock;
{$MINENUMSIZE 4}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{$IFDEF CIL}
{$I ssdotnet.pas}
{$ELSE}
{$IFDEF MSWINDOWS}
{$I sswin32.pas}
{$ELSE}
{$IFDEF WINCE}
{$I sswin32.pas} //not complete yet!
{$ELSE}
{$IFDEF FPC}
{$I ssfpc.pas}
{$ELSE}
{$I sslinux.pas}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
end.
TransGUI/synapse/source/lib/laz_synapse.lpk 0000644 0000000 0000000 00000010710 11466757142 020014 0 ustar root root
TransGUI/synapse/source/lib/dnssend.pas 0000644 0000000 0000000 00000045463 11366572451 017131 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 002.007.006 |
|==============================================================================|
| Content: DNS client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{: @abstract(DNS client by UDP or TCP)
Support for sending DNS queries by UDP or TCP protocol. It can retrieve zone
transfers too!
Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit dnssend;
interface
uses
SysUtils, Classes,
blcksock, synautil, synaip, synsock;
const
cDnsProtocol = '53';
QTYPE_A = 1;
QTYPE_NS = 2;
QTYPE_MD = 3;
QTYPE_MF = 4;
QTYPE_CNAME = 5;
QTYPE_SOA = 6;
QTYPE_MB = 7;
QTYPE_MG = 8;
QTYPE_MR = 9;
QTYPE_NULL = 10;
QTYPE_WKS = 11; //
QTYPE_PTR = 12;
QTYPE_HINFO = 13;
QTYPE_MINFO = 14;
QTYPE_MX = 15;
QTYPE_TXT = 16;
QTYPE_RP = 17;
QTYPE_AFSDB = 18;
QTYPE_X25 = 19;
QTYPE_ISDN = 20;
QTYPE_RT = 21;
QTYPE_NSAP = 22;
QTYPE_NSAPPTR = 23;
QTYPE_SIG = 24; // RFC-2065
QTYPE_KEY = 25; // RFC-2065
QTYPE_PX = 26;
QTYPE_GPOS = 27;
QTYPE_AAAA = 28;
QTYPE_LOC = 29; // RFC-1876
QTYPE_NXT = 30; // RFC-2065
QTYPE_SRV = 33;
QTYPE_NAPTR = 35; // RFC-2168
QTYPE_KX = 36;
QTYPE_SPF = 99;
QTYPE_AXFR = 252;
QTYPE_MAILB = 253; //
QTYPE_MAILA = 254; //
QTYPE_ALL = 255;
type
{:@abstract(Implementation of DNS protocol by UDP or TCP protocol.)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TDNSSend = class(TSynaClient)
private
FID: Word;
FRCode: Integer;
FBuffer: AnsiString;
FSock: TUDPBlockSocket;
FTCPSock: TTCPBlockSocket;
FUseTCP: Boolean;
FAnswerInfo: TStringList;
FNameserverInfo: TStringList;
FAdditionalInfo: TStringList;
FAuthoritative: Boolean;
FTruncated: Boolean;
function CompressName(const Value: AnsiString): AnsiString;
function CodeHeader: AnsiString;
function CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
function DecodeLabels(var From: Integer): AnsiString;
function DecodeString(var From: Integer): AnsiString;
function DecodeResource(var i: Integer; const Info: TStringList;
QType: Integer): AnsiString;
function RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
function DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
QType: Integer):boolean;
public
constructor Create;
destructor Destroy; override;
{:Query a DNSHost for QType resources correspond to a name. Supported QType
values are: Qtype_A, Qtype_NS, Qtype_MD, Qtype_MF, Qtype_CNAME, Qtype_SOA,
Qtype_MB, Qtype_MG, Qtype_MR, Qtype_NULL, Qtype_PTR, Qtype_HINFO,
Qtype_MINFO, Qtype_MX, Qtype_TXT, Qtype_RP, Qtype_AFSDB, Qtype_X25,
Qtype_ISDN, Qtype_RT, Qtype_NSAP, Qtype_NSAPPTR, Qtype_PX, Qtype_GPOS,
Qtype_KX.
Type for zone transfers QTYPE_AXFR is supported too, but only in TCP mode!
"Name" is domain name or host name for queried resource. If "name" is
IP address, automatically convert to reverse domain form (.in-addr.arpa).
If result is @true, Reply contains resource records. One record on one line.
If Resource record have multiple fields, they are stored on line divided by
comma. (example: MX record contains value 'rs.cesnet.cz' with preference
number 10, string in Reply is: '10,rs.cesnet.cz'). All numbers or IP address
in resource are converted to string form.}
function DNSQuery(Name: AnsiString; QType: Integer;
const Reply: TStrings): Boolean;
published
{:Socket object used for UDP operation. Good for seting OnStatus hook, etc.}
property Sock: TUDPBlockSocket read FSock;
{:Socket object used for TCP operation. Good for seting OnStatus hook, etc.}
property TCPSock: TTCPBlockSocket read FTCPSock;
{:if @true, then is used TCP protocol instead UDP. It is needed for zone
transfers, etc.}
property UseTCP: Boolean read FUseTCP Write FUseTCP;
{:After DNS operation contains ResultCode of DNS operation.
Values are: 0-no error, 1-format error, 2-server failure, 3-name error,
4-not implemented, 5-refused.}
property RCode: Integer read FRCode;
{:@True, if answer is authoritative.}
property Authoritative: Boolean read FAuthoritative;
{:@True, if answer is truncated to 512 bytes.}
property Truncated: Boolean read FTRuncated;
{:Detailed informations from name server reply. One record per line. Record
have comma delimited entries with type number, TTL and data filelds.
This information contains detailed information about query reply.}
property AnswerInfo: TStringList read FAnswerInfo;
{:Detailed informations from name server reply. One record per line. Record
have comma delimited entries with type number, TTL and data filelds.
This information contains detailed information about nameserver.}
property NameserverInfo: TStringList read FNameserverInfo;
{:Detailed informations from name server reply. One record per line. Record
have comma delimited entries with type number, TTL and data filelds.
This information contains detailed additional information.}
property AdditionalInfo: TStringList read FAdditionalInfo;
end;
{:A very useful function, and example of it's use is found in the TDNSSend object.
This function is used to get mail servers for a domain and sort them by
preference numbers. "Servers" contains only the domain names of the mail
servers in the right order (without preference number!). The first domain name
will always be the highest preferenced mail server. Returns boolean @TRUE if
all went well.}
function GetMailServers(const DNSHost, Domain: AnsiString;
const Servers: TStrings): Boolean;
implementation
constructor TDNSSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FTCPSock := TTCPBlockSocket.Create;
FTCPSock.Owner := self;
FUseTCP := False;
FTimeout := 10000;
FTargetPort := cDnsProtocol;
FAnswerInfo := TStringList.Create;
FNameserverInfo := TStringList.Create;
FAdditionalInfo := TStringList.Create;
Randomize;
end;
destructor TDNSSend.Destroy;
begin
FAnswerInfo.Free;
FNameserverInfo.Free;
FAdditionalInfo.Free;
FTCPSock.Free;
FSock.Free;
inherited Destroy;
end;
function TDNSSend.CompressName(const Value: AnsiString): AnsiString;
var
n: Integer;
s: AnsiString;
begin
Result := '';
if Value = '' then
Result := #0
else
begin
s := '';
for n := 1 to Length(Value) do
if Value[n] = '.' then
begin
Result := Result + AnsiChar(Length(s)) + s;
s := '';
end
else
s := s + Value[n];
if s <> '' then
Result := Result + AnsiChar(Length(s)) + s;
Result := Result + #0;
end;
end;
function TDNSSend.CodeHeader: AnsiString;
begin
FID := Random(32767);
Result := CodeInt(FID); // ID
Result := Result + CodeInt($0100); // flags
Result := Result + CodeInt(1); // QDCount
Result := Result + CodeInt(0); // ANCount
Result := Result + CodeInt(0); // NSCount
Result := Result + CodeInt(0); // ARCount
end;
function TDNSSend.CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
begin
Result := CompressName(Name);
Result := Result + CodeInt(QType);
Result := Result + CodeInt(1); // Type INTERNET
end;
function TDNSSend.DecodeString(var From: Integer): AnsiString;
var
Len: integer;
begin
Len := Ord(FBuffer[From]);
Inc(From);
Result := Copy(FBuffer, From, Len);
Inc(From, Len);
end;
function TDNSSend.DecodeLabels(var From: Integer): AnsiString;
var
l, f: Integer;
begin
Result := '';
while True do
begin
if From >= Length(FBuffer) then
Break;
l := Ord(FBuffer[From]);
Inc(From);
if l = 0 then
Break;
if Result <> '' then
Result := Result + '.';
if (l and $C0) = $C0 then
begin
f := l and $3F;
f := f * 256 + Ord(FBuffer[From]) + 1;
Inc(From);
Result := Result + DecodeLabels(f);
Break;
end
else
begin
Result := Result + Copy(FBuffer, From, l);
Inc(From, l);
end;
end;
end;
function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList;
QType: Integer): AnsiString;
var
Rname: AnsiString;
RType, Len, j, x, y, z, n: Integer;
R: AnsiString;
t1, t2, ttl: integer;
ip6: TIp6bytes;
begin
Result := '';
R := '';
Rname := DecodeLabels(i);
RType := DecodeInt(FBuffer, i);
Inc(i, 4);
t1 := DecodeInt(FBuffer, i);
Inc(i, 2);
t2 := DecodeInt(FBuffer, i);
Inc(i, 2);
ttl := t1 * 65536 + t2;
Len := DecodeInt(FBuffer, i);
Inc(i, 2); // i point to begin of data
j := i;
i := i + len; // i point to next record
if Length(FBuffer) >= (i - 1) then
case RType of
QTYPE_A:
begin
R := IntToStr(Ord(FBuffer[j]));
Inc(j);
R := R + '.' + IntToStr(Ord(FBuffer[j]));
Inc(j);
R := R + '.' + IntToStr(Ord(FBuffer[j]));
Inc(j);
R := R + '.' + IntToStr(Ord(FBuffer[j]));
end;
QTYPE_AAAA:
begin
for n := 0 to 15 do
ip6[n] := ord(FBuffer[j + n]);
R := IP6ToStr(ip6);
end;
QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB,
QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP,
QTYPE_NSAPPTR:
R := DecodeLabels(j);
QTYPE_SOA:
begin
R := DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
for n := 1 to 5 do
begin
x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2);
Inc(j, 4);
R := R + ',' + IntToStr(x);
end;
end;
QTYPE_NULL:
begin
end;
QTYPE_WKS:
begin
end;
QTYPE_HINFO:
begin
R := DecodeString(j);
R := R + ',' + DecodeString(j);
end;
QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN:
begin
R := DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
end;
QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX:
begin
x := DecodeInt(FBuffer, j);
Inc(j, 2);
R := IntToStr(x);
R := R + ',' + DecodeLabels(j);
end;
QTYPE_TXT, QTYPE_SPF:
begin
R := '';
while j < i do
R := R + DecodeString(j);
end;
QTYPE_GPOS:
begin
R := DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
end;
QTYPE_PX:
begin
x := DecodeInt(FBuffer, j);
Inc(j, 2);
R := IntToStr(x);
R := R + ',' + DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
end;
QTYPE_SRV:
// Author: Dan
begin
x := DecodeInt(FBuffer, j);
Inc(j, 2);
y := DecodeInt(FBuffer, j);
Inc(j, 2);
z := DecodeInt(FBuffer, j);
Inc(j, 2);
R := IntToStr(x); // Priority
R := R + ',' + IntToStr(y); // Weight
R := R + ',' + IntToStr(z); // Port
R := R + ',' + DecodeLabels(j); // Server DNS Name
end;
end;
if R <> '' then
Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R);
if QType = RType then
Result := R;
end;
function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
var
l: integer;
begin
Result := '';
l := WorkSock.recvbyte(FTimeout) * 256 + WorkSock.recvbyte(FTimeout);
if l > 0 then
Result := WorkSock.RecvBufferStr(l, FTimeout);
end;
function TDNSSend.DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
QType: Integer):boolean;
var
n, i: Integer;
flag, qdcount, ancount, nscount, arcount: Integer;
s: AnsiString;
begin
Result := False;
Reply.Clear;
FAnswerInfo.Clear;
FNameserverInfo.Clear;
FAdditionalInfo.Clear;
FAuthoritative := False;
if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then
begin
Result := True;
flag := DecodeInt(Buf, 3);
FRCode := Flag and $000F;
FAuthoritative := (Flag and $0400) > 0;
FTruncated := (Flag and $0200) > 0;
if FRCode = 0 then
begin
qdcount := DecodeInt(Buf, 5);
ancount := DecodeInt(Buf, 7);
nscount := DecodeInt(Buf, 9);
arcount := DecodeInt(Buf, 11);
i := 13; //begin of body
if (qdcount > 0) and (Length(Buf) > i) then //skip questions
for n := 1 to qdcount do
begin
while (Buf[i] <> #0) and ((Ord(Buf[i]) and $C0) <> $C0) do
Inc(i);
Inc(i, 5);
end;
if (ancount > 0) and (Length(Buf) > i) then // decode reply
for n := 1 to ancount do
begin
s := DecodeResource(i, FAnswerInfo, QType);
if s <> '' then
Reply.Add(s);
end;
if (nscount > 0) and (Length(Buf) > i) then // decode nameserver info
for n := 1 to nscount do
DecodeResource(i, FNameserverInfo, QType);
if (arcount > 0) and (Length(Buf) > i) then // decode additional info
for n := 1 to arcount do
DecodeResource(i, FAdditionalInfo, QType);
end;
end;
end;
function TDNSSend.DNSQuery(Name: AnsiString; QType: Integer;
const Reply: TStrings): Boolean;
var
WorkSock: TBlockSocket;
t: TStringList;
b: boolean;
begin
Result := False;
if IsIP(Name) then
Name := ReverseIP(Name) + '.in-addr.arpa';
if IsIP6(Name) then
Name := ReverseIP6(Name) + '.ip6.arpa';
FBuffer := CodeHeader + CodeQuery(Name, QType);
if FUseTCP then
WorkSock := FTCPSock
else
WorkSock := FSock;
WorkSock.Bind(FIPInterface, cAnyPort);
WorkSock.Connect(FTargetHost, FTargetPort);
if FUseTCP then
FBuffer := Codeint(length(FBuffer)) + FBuffer;
WorkSock.SendString(FBuffer);
if FUseTCP then
FBuffer := RecvTCPResponse(WorkSock)
else
FBuffer := WorkSock.RecvPacket(FTimeout);
if FUseTCP and (QType = QTYPE_AXFR) then //zone transfer
begin
t := TStringList.Create;
try
repeat
b := DecodeResponse(FBuffer, Reply, QType);
if (t.Count > 1) and (AnswerInfo.Count > 0) then //find end of transfer
b := b and (t[0] <> AnswerInfo[AnswerInfo.count - 1]);
if b then
begin
t.AddStrings(AnswerInfo);
FBuffer := RecvTCPResponse(WorkSock);
if FBuffer = '' then
Break;
if WorkSock.LastError <> 0 then
Break;
end;
until not b;
Reply.Assign(t);
Result := True;
finally
t.free;
end;
end
else //normal query
if WorkSock.LastError = 0 then
Result := DecodeResponse(FBuffer, Reply, QType);
end;
{==============================================================================}
function GetMailServers(const DNSHost, Domain: AnsiString;
const Servers: TStrings): Boolean;
var
DNS: TDNSSend;
t: TStringList;
n, m, x: Integer;
begin
Result := False;
Servers.Clear;
t := TStringList.Create;
DNS := TDNSSend.Create;
try
DNS.TargetHost := DNSHost;
if DNS.DNSQuery(Domain, QType_MX, t) then
begin
{ normalize preference number to 5 digits }
for n := 0 to t.Count - 1 do
begin
x := Pos(',', t[n]);
if x > 0 then
for m := 1 to 6 - x do
t[n] := '0' + t[n];
end;
{ sort server list }
t.Sorted := True;
{ result is sorted list without preference numbers }
for n := 0 to t.Count - 1 do
begin
x := Pos(',', t[n]);
Servers.Add(Copy(t[n], x + 1, Length(t[n]) - x));
end;
Result := True;
end;
finally
DNS.Free;
t.Free;
end;
end;
end.
TransGUI/synapse/source/lib/httpsend.pas 0000644 0000000 0000000 00000064570 11466757142 017327 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 003.012.004 |
|==============================================================================|
| Content: HTTP client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(HTTP protocol client)
Used RFC: RFC-1867, RFC-1947, RFC-2388, RFC-2616
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit httpsend;
interface
uses
SysUtils, Classes,
blcksock, synautil, synaip, synacode, synsock;
const
cHttpProtocol = '80';
type
{:These encoding types are used internally by the THTTPSend object to identify
the transfer data types.}
TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED);
{:abstract(Implementation of HTTP protocol.)}
THTTPSend = class(TSynaClient)
protected
FSock: TTCPBlockSocket;
FTransferEncoding: TTransferEncoding;
FAliveHost: string;
FAlivePort: string;
FHeaders: TStringList;
FDocument: TMemoryStream;
FMimeType: string;
FProtocol: string;
FKeepAlive: Boolean;
FKeepAliveTimeout: integer;
FStatus100: Boolean;
FProxyHost: string;
FProxyPort: string;
FProxyUser: string;
FProxyPass: string;
FResultCode: Integer;
FResultString: string;
FUserAgent: string;
FCookies: TStringList;
FDownloadSize: integer;
FUploadSize: integer;
FRangeStart: integer;
FRangeEnd: integer;
FAddPortNumberToHost: Boolean;
function ReadUnknown: Boolean;
function ReadIdentity(Size: Integer): Boolean;
function ReadChunked: Boolean;
procedure ParseCookies;
function PrepareHeaders: AnsiString;
function InternalDoConnect(needssl: Boolean): Boolean;
function InternalConnect(needssl: Boolean): Boolean;
public
constructor Create;
destructor Destroy; override;
{:Reset headers and document and Mimetype.}
procedure Clear;
{:Decode ResultCode and ResultString from Value.}
procedure DecodeStatus(const Value: string);
{:Connects to host define in URL and access to resource defined in URL by
method. If Document is not empty, send it to server as part of HTTP request.
Server response is in Document and headers. Connection may be authorised
by username and password in URL. If you define proxy properties, connection
is made by this proxy. If all OK, result is @true, else result is @false.
If you use in URL 'https:' instead only 'http:', then your request is made
by SSL/TLS connection (if you not specify port, then port 443 is used
instead standard port 80). If you use SSL/TLS request and you have defined
HTTP proxy, then HTTP-tunnel mode is automaticly used .}
function HTTPMethod(const Method, URL: string): Boolean;
{:You can call this method from OnStatus event for break current data
transfer. (or from another thread.)}
procedure Abort;
published
{:Before HTTP operation you may define any non-standard headers for HTTP
request, except of: 'Expect: 100-continue', 'Content-Length', 'Content-Type',
'Connection', 'Authorization', 'Proxy-Authorization' and 'Host' headers.
After HTTP operation contains full headers of returned document.}
property Headers: TStringList read FHeaders;
{:This is stringlist with name-value stringlist pairs. Each this pair is one
cookie. After HTTP request is returned cookies parsed to this stringlist.
You can leave this cookies untouched for next HTTP request. You can also
save this stringlist for later use.}
property Cookies: TStringList read FCookies;
{:Stream with document to send (before request, or with document received
from HTTP server (after request).}
property Document: TMemoryStream read FDocument;
{:If you need download only part of requested document, here specify
possition of subpart begin. If here 0, then is requested full document.}
property RangeStart: integer read FRangeStart Write FRangeStart;
{:If you need download only part of requested document, here specify
possition of subpart end. If here 0, then is requested document from
rangeStart to end of document. (for broken download restoration,
for example.)}
property RangeEnd: integer read FRangeEnd Write FRangeEnd;
{:Mime type of sending data. Default is: 'text/html'.}
property MimeType: string read FMimeType Write FMimeType;
{:Define protocol version. Possible values are: '1.1', '1.0' (default)
and '0.9'.}
property Protocol: string read FProtocol Write FProtocol;
{:If @true (default value), keepalives in HTTP protocol 1.1 is enabled.}
property KeepAlive: Boolean read FKeepAlive Write FKeepAlive;
{:Define timeout for keepalives in seconds!}
property KeepAliveTimeout: integer read FKeepAliveTimeout Write FKeepAliveTimeout;
{:if @true, then server is requested for 100status capability when uploading
data. Default is @false (off).}
property Status100: Boolean read FStatus100 Write FStatus100;
{:Address of proxy server (IP address or domain name) where you want to
connect in @link(HTTPMethod) method.}
property ProxyHost: string read FProxyHost Write FProxyHost;
{:Port number for proxy connection. Default value is 8080.}
property ProxyPort: string read FProxyPort Write FProxyPort;
{:Username for connect to proxy server where you want to connect in
HTTPMethod method.}
property ProxyUser: string read FProxyUser Write FProxyUser;
{:Password for connect to proxy server where you want to connect in
HTTPMethod method.}
property ProxyPass: string read FProxyPass Write FProxyPass;
{:Here you can specify custom User-Agent indentification. By default is
used: 'Mozilla/4.0 (compatible; Synapse)'}
property UserAgent: string read FUserAgent Write FUserAgent;
{:After successful @link(HTTPMethod) method contains result code of
operation.}
property ResultCode: Integer read FResultCode;
{:After successful @link(HTTPMethod) method contains string after result code.}
property ResultString: string read FResultString;
{:if this value is not 0, then data download pending. In this case you have
here total sice of downloaded data. It is good for draw download
progressbar from OnStatus event.}
property DownloadSize: integer read FDownloadSize;
{:if this value is not 0, then data upload pending. In this case you have
here total sice of uploaded data. It is good for draw upload progressbar
from OnStatus event.}
property UploadSize: integer read FUploadSize;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
{:To have possibility to switch off port number in 'Host:' HTTP header, by
default @TRUE. Some buggy servers not like port informations in this header.}
property AddPortNumberToHost: Boolean read FAddPortNumberToHost write FAddPortNumberToHost;
end;
{:A very usefull function, and example of use can be found in the THTTPSend
object. It implements the GET method of the HTTP protocol. This function sends
the GET method for URL document to an HTTP server. Returned document is in the
"Response" stringlist (without any headers). Returns boolean TRUE if all went
well.}
function HttpGetText(const URL: string; const Response: TStrings): Boolean;
{:A very usefull function, and example of use can be found in the THTTPSend
object. It implements the GET method of the HTTP protocol. This function sends
the GET method for URL document to an HTTP server. Returned document is in the
"Response" stream. Returns boolean TRUE if all went well.}
function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
{:A very useful function, and example of use can be found in the THTTPSend
object. It implements the POST method of the HTTP protocol. This function sends
the SEND method for a URL document to an HTTP server. The document to be sent
is located in "Data" stream. The returned document is in the "Data" stream.
Returns boolean TRUE if all went well.}
function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
{:A very useful function, and example of use can be found in the THTTPSend
object. It implements the POST method of the HTTP protocol. This function is
good for POSTing form data. It sends the POST method for a URL document to
an HTTP server. You must prepare the form data in the same manner as you would
the URL data, and pass this prepared data to "URLdata". The following is
a sample of how the data would appear: 'name=Lukas&field1=some%20data'.
The information in the field must be encoded by EncodeURLElement function.
The returned document is in the "Data" stream. Returns boolean TRUE if all
went well.}
function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
{:A very useful function, and example of use can be found in the THTTPSend
object. It implements the POST method of the HTTP protocol. This function sends
the POST method for a URL document to an HTTP server. This function simulate
posting of file by HTML form used method 'multipart/form-data'. Posting file
is in DATA stream. Its name is Filename string. Fieldname is for name of
formular field with file. (simulate HTML INPUT FILE) The returned document is
in the ResultData Stringlist. Returns boolean TRUE if all went well.}
function HttpPostFile(const URL, FieldName, FileName: string;
const Data: TStream; const ResultData: TStrings): Boolean;
implementation
constructor THTTPSend.Create;
begin
inherited Create;
FHeaders := TStringList.Create;
FCookies := TStringList.Create;
FDocument := TMemoryStream.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := True;
FSock.SizeRecvBuffer := c64k;
FSock.SizeSendBuffer := c64k;
FTimeout := 90000;
FTargetPort := cHttpProtocol;
FProxyHost := '';
FProxyPort := '8080';
FProxyUser := '';
FProxyPass := '';
FAliveHost := '';
FAlivePort := '';
FProtocol := '1.0';
FKeepAlive := True;
FStatus100 := False;
FUserAgent := 'Mozilla/4.0 (compatible; Synapse)';
FDownloadSize := 0;
FUploadSize := 0;
FAddPortNumberToHost := true;
FKeepAliveTimeout := 300;
Clear;
end;
destructor THTTPSend.Destroy;
begin
FSock.Free;
FDocument.Free;
FCookies.Free;
FHeaders.Free;
inherited Destroy;
end;
procedure THTTPSend.Clear;
begin
FRangeStart := 0;
FRangeEnd := 0;
FDocument.Clear;
FHeaders.Clear;
FMimeType := 'text/html';
end;
procedure THTTPSend.DecodeStatus(const Value: string);
var
s, su: string;
begin
s := Trim(SeparateRight(Value, ' '));
su := Trim(SeparateLeft(s, ' '));
FResultCode := StrToIntDef(su, 0);
FResultString := Trim(SeparateRight(s, ' '));
if FResultString = s then
FResultString := '';
end;
function THTTPSend.PrepareHeaders: AnsiString;
begin
if FProtocol = '0.9' then
Result := FHeaders[0] + CRLF
else
{$IFNDEF MSWINDOWS}
Result := {$IFDEF UNICODE}AnsiString{$ENDIF}(AdjustLineBreaks(FHeaders.Text, tlbsCRLF));
{$ELSE}
Result := FHeaders.Text;
{$ENDIF}
end;
function THTTPSend.InternalDoConnect(needssl: Boolean): Boolean;
begin
Result := False;
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError <> 0 then
Exit;
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError <> 0 then
Exit;
if needssl then
begin
FSock.SSLDoConnect;
if FSock.LastError <> 0 then
Exit;
end;
FAliveHost := FTargetHost;
FAlivePort := FTargetPort;
Result := True;
end;
function THTTPSend.InternalConnect(needssl: Boolean): Boolean;
begin
if FSock.Socket = INVALID_SOCKET then
Result := InternalDoConnect(needssl)
else
if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort)
or FSock.CanRead(0) then
Result := InternalDoConnect(needssl)
else
Result := True;
end;
function THTTPSend.HTTPMethod(const Method, URL: string): Boolean;
var
Sending, Receiving: Boolean;
status100: Boolean;
status100error: string;
ToClose: Boolean;
Size: Integer;
Prot, User, Pass, Host, Port, Path, Para, URI: string;
s, su: AnsiString;
HttpTunnel: Boolean;
n: integer;
pp: string;
UsingProxy: boolean;
l: TStringList;
x: integer;
begin
{initial values}
Result := False;
FResultCode := 500;
FResultString := '';
FDownloadSize := 0;
FUploadSize := 0;
URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para);
if User = '' then
begin
User := FUsername;
Pass := FPassword;
end;
if UpperCase(Prot) = 'HTTPS' then
begin
HttpTunnel := FProxyHost <> '';
FSock.HTTPTunnelIP := FProxyHost;
FSock.HTTPTunnelPort := FProxyPort;
FSock.HTTPTunnelUser := FProxyUser;
FSock.HTTPTunnelPass := FProxyPass;
end
else
begin
HttpTunnel := False;
FSock.HTTPTunnelIP := '';
FSock.HTTPTunnelPort := '';
FSock.HTTPTunnelUser := '';
FSock.HTTPTunnelPass := '';
end;
UsingProxy := (FProxyHost <> '') and not(HttpTunnel);
Sending := FDocument.Size > 0;
{Headers for Sending data}
status100 := FStatus100 and Sending and (FProtocol = '1.1');
if status100 then
FHeaders.Insert(0, 'Expect: 100-continue');
if Sending then
begin
FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
if FMimeType <> '' then
FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
end;
{ setting User-agent }
if FUserAgent <> '' then
FHeaders.Insert(0, 'User-Agent: ' + FUserAgent);
{ setting Ranges }
if (FRangeStart > 0) or (FRangeEnd > 0) then
begin
if FRangeEnd >= FRangeStart then
FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd))
else
FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-');
end;
{ setting Cookies }
s := '';
for n := 0 to FCookies.Count - 1 do
begin
if s <> '' then
s := s + '; ';
s := s + FCookies[n];
end;
if s <> '' then
FHeaders.Insert(0, 'Cookie: ' + s);
{ setting KeepAlives }
pp := '';
if UsingProxy then
pp := 'Proxy-';
if FKeepAlive then
begin
FHeaders.Insert(0, pp + 'Connection: keep-alive');
FHeaders.Insert(0, 'Keep-Alive: ' + IntToStr(FKeepAliveTimeout));
end
else
FHeaders.Insert(0, pp + 'Connection: close');
{ set target servers/proxy, authorizations, etc... }
if User <> '' then
FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(User + ':' + Pass));
if UsingProxy and (FProxyUser <> '') then
FHeaders.Insert(0, 'Proxy-Authorization: Basic ' +
EncodeBase64(FProxyUser + ':' + FProxyPass));
if isIP6(Host) then
s := '[' + Host + ']'
else
s := Host;
if FAddPortNumberToHost and (Port <> '80') then
FHeaders.Insert(0, 'Host: ' + s + ':' + Port)
else
FHeaders.Insert(0, 'Host: ' + s);
if UsingProxy then
URI := Prot + '://' + s + ':' + Port + URI;
if URI = '/*' then
URI := '*';
if FProtocol = '0.9' then
FHeaders.Insert(0, UpperCase(Method) + ' ' + URI)
else
FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol);
if UsingProxy then
begin
FTargetHost := FProxyHost;
FTargetPort := FProxyPort;
end
else
begin
FTargetHost := Host;
FTargetPort := Port;
end;
if FHeaders[FHeaders.Count - 1] <> '' then
FHeaders.Add('');
{ connect }
if not InternalConnect(UpperCase(Prot) = 'HTTPS') then
begin
FAliveHost := '';
FAlivePort := '';
Exit;
end;
{ reading Status }
FDocument.Position := 0;
Status100Error := '';
if status100 then
begin
{ send Headers }
FSock.SendString(PrepareHeaders);
if FSock.LastError <> 0 then
Exit;
repeat
s := FSock.RecvString(FTimeout);
if s <> '' then
Break;
until FSock.LastError <> 0;
DecodeStatus(s);
Status100Error := s;
repeat
s := FSock.recvstring(FTimeout);
if s = '' then
Break;
until FSock.LastError <> 0;
if (FResultCode >= 100) and (FResultCode < 200) then
begin
{ we can upload content }
Status100Error := '';
FUploadSize := FDocument.Size;
FSock.SendBuffer(FDocument.Memory, FDocument.Size);
end;
end
else
{ upload content }
if sending then
begin
if FDocument.Size >= c64k then
begin
FSock.SendString(PrepareHeaders);
FUploadSize := FDocument.Size;
FSock.SendBuffer(FDocument.Memory, FDocument.Size);
end
else
begin
s := PrepareHeaders + ReadStrFromStream(FDocument, FDocument.Size);
FUploadSize := Length(s);
FSock.SendString(s);
end;
end
else
begin
{ we not need to upload document, send headers only }
FSock.SendString(PrepareHeaders);
end;
if FSock.LastError <> 0 then
Exit;
Clear;
Size := -1;
FTransferEncoding := TE_UNKNOWN;
{ read status }
if Status100Error = '' then
begin
repeat
repeat
s := FSock.RecvString(FTimeout);
if s <> '' then
Break;
until FSock.LastError <> 0;
if Pos('HTTP/', UpperCase(s)) = 1 then
begin
FHeaders.Add(s);
DecodeStatus(s);
end
else
begin
{ old HTTP 0.9 and some buggy servers not send result }
s := s + CRLF;
WriteStrToStream(FDocument, s);
FResultCode := 0;
end;
until (FSock.LastError <> 0) or (FResultCode <> 100);
end
else
FHeaders.Add(Status100Error);
{ if need receive headers, receive and parse it }
ToClose := FProtocol <> '1.1';
if FHeaders.Count > 0 then
begin
l := TStringList.Create;
try
repeat
s := FSock.RecvString(FTimeout);
l.Add(s);
if s = '' then
Break;
until FSock.LastError <> 0;
x := 0;
while l.Count > x do
begin
s := NormalizeHeader(l, x);
FHeaders.Add(s);
su := UpperCase(s);
if Pos('CONTENT-LENGTH:', su) = 1 then
begin
Size := StrToIntDef(Trim(SeparateRight(s, ' ')), -1);
if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then
FTransferEncoding := TE_IDENTITY;
end;
if Pos('CONTENT-TYPE:', su) = 1 then
FMimeType := Trim(SeparateRight(s, ' '));
if Pos('TRANSFER-ENCODING:', su) = 1 then
begin
s := Trim(SeparateRight(su, ' '));
if Pos('CHUNKED', s) > 0 then
FTransferEncoding := TE_CHUNKED;
end;
if UsingProxy then
begin
if Pos('PROXY-CONNECTION:', su) = 1 then
if Pos('CLOSE', su) > 0 then
ToClose := True;
end
else
begin
if Pos('CONNECTION:', su) = 1 then
if Pos('CLOSE', su) > 0 then
ToClose := True;
end;
end;
finally
l.free;
end;
end;
Result := FSock.LastError = 0;
if not Result then
Exit;
{if need receive response body, read it}
Receiving := Method <> 'HEAD';
Receiving := Receiving and (FResultCode <> 204);
Receiving := Receiving and (FResultCode <> 304);
if Receiving then
case FTransferEncoding of
TE_UNKNOWN:
Result := ReadUnknown;
TE_IDENTITY:
Result := ReadIdentity(Size);
TE_CHUNKED:
Result := ReadChunked;
end;
FDocument.Seek(0, soFromBeginning);
if ToClose then
begin
FSock.CloseSocket;
FAliveHost := '';
FAlivePort := '';
end;
ParseCookies;
end;
function THTTPSend.ReadUnknown: Boolean;
var
s: string;
begin
Result := false;
repeat
s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
WriteStrToStream(FDocument, s);
until FSock.LastError <> 0;
if FSock.LastError = WSAECONNRESET then
begin
Result := true;
FSock.ResetLastError;
end;
end;
function THTTPSend.ReadIdentity(Size: Integer): Boolean;
begin
if Size > 0 then
begin
FDownloadSize := Size;
FSock.RecvStreamSize(FDocument, FTimeout, Size);
FDocument.Position := FDocument.Size;
Result := FSock.LastError = 0;
end
else
Result := true;
end;
function THTTPSend.ReadChunked: Boolean;
var
s: string;
Size: Integer;
begin
repeat
repeat
s := FSock.RecvString(FTimeout);
until (s <> '') or (FSock.LastError <> 0);
if FSock.LastError <> 0 then
Break;
s := Trim(SeparateLeft(s, ' '));
s := Trim(SeparateLeft(s, ';'));
Size := StrToIntDef('$' + s, 0);
if Size = 0 then
Break;
if not ReadIdentity(Size) then
break;
until False;
Result := FSock.LastError = 0;
end;
procedure THTTPSend.ParseCookies;
var
n: integer;
s: string;
sn, sv: string;
begin
for n := 0 to FHeaders.Count - 1 do
if Pos('set-cookie:', lowercase(FHeaders[n])) = 1 then
begin
s := SeparateRight(FHeaders[n], ':');
s := trim(SeparateLeft(s, ';'));
sn := trim(SeparateLeft(s, '='));
sv := trim(SeparateRight(s, '='));
FCookies.Values[sn] := sv;
end;
end;
procedure THTTPSend.Abort;
begin
FSock.StopFlag := True;
end;
{==============================================================================}
function HttpGetText(const URL: string; const Response: TStrings): Boolean;
var
HTTP: THTTPSend;
begin
HTTP := THTTPSend.Create;
try
Result := HTTP.HTTPMethod('GET', URL);
if Result then
Response.LoadFromStream(HTTP.Document);
finally
HTTP.Free;
end;
end;
function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
var
HTTP: THTTPSend;
begin
HTTP := THTTPSend.Create;
try
Result := HTTP.HTTPMethod('GET', URL);
if Result then
begin
Response.Seek(0, soFromBeginning);
Response.CopyFrom(HTTP.Document, 0);
end;
finally
HTTP.Free;
end;
end;
function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
var
HTTP: THTTPSend;
begin
HTTP := THTTPSend.Create;
try
HTTP.Document.CopyFrom(Data, 0);
HTTP.MimeType := 'Application/octet-stream';
Result := HTTP.HTTPMethod('POST', URL);
Data.Size := 0;
if Result then
begin
Data.Seek(0, soFromBeginning);
Data.CopyFrom(HTTP.Document, 0);
end;
finally
HTTP.Free;
end;
end;
function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
var
HTTP: THTTPSend;
begin
HTTP := THTTPSend.Create;
try
WriteStrToStream(HTTP.Document, URLData);
HTTP.MimeType := 'application/x-www-form-urlencoded';
Result := HTTP.HTTPMethod('POST', URL);
if Result then
Data.CopyFrom(HTTP.Document, 0);
finally
HTTP.Free;
end;
end;
function HttpPostFile(const URL, FieldName, FileName: string;
const Data: TStream; const ResultData: TStrings): Boolean;
var
HTTP: THTTPSend;
Bound, s: string;
begin
Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary';
HTTP := THTTPSend.Create;
try
s := '--' + Bound + CRLF;
s := s + 'content-disposition: form-data; name="' + FieldName + '";';
s := s + ' filename="' + FileName +'"' + CRLF;
s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF;
WriteStrToStream(HTTP.Document, s);
HTTP.Document.CopyFrom(Data, 0);
s := CRLF + '--' + Bound + '--' + CRLF;
WriteStrToStream(HTTP.Document, s);
HTTP.MimeType := 'multipart/form-data; boundary=' + Bound;
Result := HTTP.HTTPMethod('POST', URL);
if Result then
ResultData.LoadFromStream(HTTP.Document);
finally
HTTP.Free;
end;
end;
end.
TransGUI/synapse/source/lib/ssfpc.pas 0000644 0000000 0000000 00000066217 11466757142 016614 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.001.003 |
|==============================================================================|
| Content: Socket Independent Platform Layer - FreePascal definition include |
|==============================================================================|
| Copyright (c)2006-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2006-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@exclude}
{$IFDEF FPC}
{For FreePascal 2.x.x}
//{$DEFINE FORCEOLDAPI}
{Note about define FORCEOLDAPI:
If you activate this compiler directive, then is allways used old socket API
for name resolution. If you leave this directive inactive, then the new API
is used, when running system allows it.
For IPv6 support you must have new API!
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$ifdef FreeBSD}
{$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr
{$endif}
{$ifdef darwin}
{$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr
{$endif}
interface
uses
SyncObjs, SysUtils, Classes,
synafpc, BaseUnix, Unix, termio, sockets, netdb;
function InitSocketInterface(stack: string): Boolean;
function DestroySocketInterface: Boolean;
const
DLLStackName = '';
WinsockLevel = $0202;
cLocalHost = '127.0.0.1';
cAnyHost = '0.0.0.0';
c6AnyHost = '::0';
c6Localhost = '::1';
cLocalHostStr = 'localhost';
type
TSocket = longint;
TAddrFamily = integer;
TMemory = pointer;
type
TFDSet = Baseunix.TFDSet;
PFDSet = ^TFDSet;
Ptimeval = Baseunix.ptimeval;
Ttimeval = Baseunix.ttimeval;
const
FIONREAD = termio.FIONREAD;
FIONBIO = termio.FIONBIO;
FIOASYNC = termio.FIOASYNC;
const
IPPROTO_IP = 0; { Dummy }
IPPROTO_ICMP = 1; { Internet Control Message Protocol }
IPPROTO_IGMP = 2; { Internet Group Management Protocol}
IPPROTO_TCP = 6; { TCP }
IPPROTO_UDP = 17; { User Datagram Protocol }
IPPROTO_IPV6 = 41;
IPPROTO_ICMPV6 = 58;
IPPROTO_RM = 113;
IPPROTO_RAW = 255;
IPPROTO_MAX = 256;
type
PInAddr = ^TInAddr;
TInAddr = sockets.in_addr;
PSockAddrIn = ^TSockAddrIn;
TSockAddrIn = sockets.TInetSockAddr;
TIP_mreq = record
imr_multiaddr: TInAddr; // IP multicast address of group
imr_interface: TInAddr; // local IP address of interface
end;
PInAddr6 = ^TInAddr6;
TInAddr6 = sockets.Tin6_addr;
PSockAddrIn6 = ^TSockAddrIn6;
TSockAddrIn6 = sockets.TInetSockAddr6;
TIPv6_mreq = record
ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address.
ipv6mr_interface: integer; // Interface index.
end;
const
INADDR_ANY = $00000000;
INADDR_LOOPBACK = $7F000001;
INADDR_BROADCAST = $FFFFFFFF;
INADDR_NONE = $FFFFFFFF;
ADDR_ANY = INADDR_ANY;
INVALID_SOCKET = TSocket(NOT(0));
SOCKET_ERROR = -1;
Const
IP_TOS = sockets.IP_TOS; { int; IP type of service and precedence. }
IP_TTL = sockets.IP_TTL; { int; IP time to live. }
IP_HDRINCL = sockets.IP_HDRINCL; { int; Header is included with data. }
IP_OPTIONS = sockets.IP_OPTIONS; { ip_opts; IP per-packet options. }
// IP_ROUTER_ALERT = sockets.IP_ROUTER_ALERT; { bool }
IP_RECVOPTS = sockets.IP_RECVOPTS; { bool }
IP_RETOPTS = sockets.IP_RETOPTS; { bool }
// IP_PKTINFO = sockets.IP_PKTINFO; { bool }
// IP_PKTOPTIONS = sockets.IP_PKTOPTIONS;
// IP_PMTUDISC = sockets.IP_PMTUDISC; { obsolete name? }
// IP_MTU_DISCOVER = sockets.IP_MTU_DISCOVER; { int; see below }
// IP_RECVERR = sockets.IP_RECVERR; { bool }
// IP_RECVTTL = sockets.IP_RECVTTL; { bool }
// IP_RECVTOS = sockets.IP_RECVTOS; { bool }
IP_MULTICAST_IF = sockets.IP_MULTICAST_IF; { in_addr; set/get IP multicast i/f }
IP_MULTICAST_TTL = sockets.IP_MULTICAST_TTL; { u_char; set/get IP multicast ttl }
IP_MULTICAST_LOOP = sockets.IP_MULTICAST_LOOP; { i_char; set/get IP multicast loopback }
IP_ADD_MEMBERSHIP = sockets.IP_ADD_MEMBERSHIP; { ip_mreq; add an IP group membership }
IP_DROP_MEMBERSHIP = sockets.IP_DROP_MEMBERSHIP; { ip_mreq; drop an IP group membership }
SOL_SOCKET = sockets.SOL_SOCKET;
SO_DEBUG = sockets.SO_DEBUG;
SO_REUSEADDR = sockets.SO_REUSEADDR;
SO_TYPE = sockets.SO_TYPE;
SO_ERROR = sockets.SO_ERROR;
SO_DONTROUTE = sockets.SO_DONTROUTE;
SO_BROADCAST = sockets.SO_BROADCAST;
SO_SNDBUF = sockets.SO_SNDBUF;
SO_RCVBUF = sockets.SO_RCVBUF;
SO_KEEPALIVE = sockets.SO_KEEPALIVE;
SO_OOBINLINE = sockets.SO_OOBINLINE;
// SO_NO_CHECK = sockets.SO_NO_CHECK;
// SO_PRIORITY = sockets.SO_PRIORITY;
SO_LINGER = sockets.SO_LINGER;
// SO_BSDCOMPAT = sockets.SO_BSDCOMPAT;
// SO_REUSEPORT = sockets.SO_REUSEPORT;
// SO_PASSCRED = sockets.SO_PASSCRED;
// SO_PEERCRED = sockets.SO_PEERCRED;
SO_RCVLOWAT = sockets.SO_RCVLOWAT;
SO_SNDLOWAT = sockets.SO_SNDLOWAT;
SO_RCVTIMEO = sockets.SO_RCVTIMEO;
SO_SNDTIMEO = sockets.SO_SNDTIMEO;
{ Security levels - as per NRL IPv6 - don't actually do anything }
// SO_SECURITY_AUTHENTICATION = sockets.SO_SECURITY_AUTHENTICATION;
// SO_SECURITY_ENCRYPTION_TRANSPORT = sockets.SO_SECURITY_ENCRYPTION_TRANSPORT;
// SO_SECURITY_ENCRYPTION_NETWORK = sockets.SO_SECURITY_ENCRYPTION_NETWORK;
// SO_BINDTODEVICE = sockets.SO_BINDTODEVICE;
{ Socket filtering }
// SO_ATTACH_FILTER = sockets.SO_ATTACH_FILTER;
// SO_DETACH_FILTER = sockets.SO_DETACH_FILTER;
SOMAXCONN = 1024;
IPV6_UNICAST_HOPS = sockets.IPV6_UNICAST_HOPS;
IPV6_MULTICAST_IF = sockets.IPV6_MULTICAST_IF;
IPV6_MULTICAST_HOPS = sockets.IPV6_MULTICAST_HOPS;
IPV6_MULTICAST_LOOP = sockets.IPV6_MULTICAST_LOOP;
IPV6_JOIN_GROUP = sockets.IPV6_JOIN_GROUP;
IPV6_LEAVE_GROUP = sockets.IPV6_LEAVE_GROUP;
const
SOCK_STREAM = 1; { stream socket }
SOCK_DGRAM = 2; { datagram socket }
SOCK_RAW = 3; { raw-protocol interface }
SOCK_RDM = 4; { reliably-delivered message }
SOCK_SEQPACKET = 5; { sequenced packet stream }
{ TCP options. }
TCP_NODELAY = $0001;
{ Address families. }
AF_UNSPEC = 0; { unspecified }
AF_INET = 2; { internetwork: UDP, TCP, etc. }
AF_INET6 = 10; { Internetwork Version 6 }
AF_MAX = 24;
{ Protocol families, same as address families for now. }
PF_UNSPEC = AF_UNSPEC;
PF_INET = AF_INET;
PF_INET6 = AF_INET6;
PF_MAX = AF_MAX;
type
{ Structure used for manipulating linger option. }
PLinger = ^TLinger;
TLinger = packed record
l_onoff: integer;
l_linger: integer;
end;
const
MSG_OOB = sockets.MSG_OOB; // Process out-of-band data.
MSG_PEEK = sockets.MSG_PEEK; // Peek at incoming messages.
{$ifdef DARWIN}
MSG_NOSIGNAL = $20000; // Do not generate SIGPIPE.
// Works under MAC OS X, but is undocumented,
// So FPC doesn't include it
{$else}
MSG_NOSIGNAL = sockets.MSG_NOSIGNAL; // Do not generate SIGPIPE.
{$endif}
const
WSAEINTR = ESysEINTR;
WSAEBADF = ESysEBADF;
WSAEACCES = ESysEACCES;
WSAEFAULT = ESysEFAULT;
WSAEINVAL = ESysEINVAL;
WSAEMFILE = ESysEMFILE;
WSAEWOULDBLOCK = ESysEWOULDBLOCK;
WSAEINPROGRESS = ESysEINPROGRESS;
WSAEALREADY = ESysEALREADY;
WSAENOTSOCK = ESysENOTSOCK;
WSAEDESTADDRREQ = ESysEDESTADDRREQ;
WSAEMSGSIZE = ESysEMSGSIZE;
WSAEPROTOTYPE = ESysEPROTOTYPE;
WSAENOPROTOOPT = ESysENOPROTOOPT;
WSAEPROTONOSUPPORT = ESysEPROTONOSUPPORT;
WSAESOCKTNOSUPPORT = ESysESOCKTNOSUPPORT;
WSAEOPNOTSUPP = ESysEOPNOTSUPP;
WSAEPFNOSUPPORT = ESysEPFNOSUPPORT;
WSAEAFNOSUPPORT = ESysEAFNOSUPPORT;
WSAEADDRINUSE = ESysEADDRINUSE;
WSAEADDRNOTAVAIL = ESysEADDRNOTAVAIL;
WSAENETDOWN = ESysENETDOWN;
WSAENETUNREACH = ESysENETUNREACH;
WSAENETRESET = ESysENETRESET;
WSAECONNABORTED = ESysECONNABORTED;
WSAECONNRESET = ESysECONNRESET;
WSAENOBUFS = ESysENOBUFS;
WSAEISCONN = ESysEISCONN;
WSAENOTCONN = ESysENOTCONN;
WSAESHUTDOWN = ESysESHUTDOWN;
WSAETOOMANYREFS = ESysETOOMANYREFS;
WSAETIMEDOUT = ESysETIMEDOUT;
WSAECONNREFUSED = ESysECONNREFUSED;
WSAELOOP = ESysELOOP;
WSAENAMETOOLONG = ESysENAMETOOLONG;
WSAEHOSTDOWN = ESysEHOSTDOWN;
WSAEHOSTUNREACH = ESysEHOSTUNREACH;
WSAENOTEMPTY = ESysENOTEMPTY;
WSAEPROCLIM = -1;
WSAEUSERS = ESysEUSERS;
WSAEDQUOT = ESysEDQUOT;
WSAESTALE = ESysESTALE;
WSAEREMOTE = ESysEREMOTE;
WSASYSNOTREADY = -2;
WSAVERNOTSUPPORTED = -3;
WSANOTINITIALISED = -4;
WSAEDISCON = -5;
WSAHOST_NOT_FOUND = 1;
WSATRY_AGAIN = 2;
WSANO_RECOVERY = 3;
WSANO_DATA = -6;
const
WSADESCRIPTION_LEN = 256;
WSASYS_STATUS_LEN = 128;
type
PWSAData = ^TWSAData;
TWSAData = packed record
wVersion: Word;
wHighVersion: Word;
szDescription: array[0..WSADESCRIPTION_LEN] of Char;
szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
iMaxSockets: Word;
iMaxUdpDg: Word;
lpVendorInfo: PChar;
end;
function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean;
procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
var
in6addr_any, in6addr_loopback : TInAddr6;
procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
procedure FD_ZERO(var FDSet: TFDSet);
{=============================================================================}
var
SynSockCS: SyncObjs.TCriticalSection;
SockEnhancedApi: Boolean;
SockWship6Api: Boolean;
type
TVarSin = packed record
{$ifdef SOCK_HAS_SINLEN}
sin_len : cuchar;
{$endif}
case integer of
0: (AddressFamily: sa_family_t);
1: (
case sin_family: sa_family_t of
AF_INET: (sin_port: word;
sin_addr: TInAddr;
sin_zero: array[0..7] of Char);
AF_INET6: (sin6_port: word;
sin6_flowinfo: longword;
sin6_addr: TInAddr6;
sin6_scope_id: longword);
);
end;
function SizeOfVarSin(sin: TVarSin): integer;
function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
function WSACleanup: Integer;
function WSAGetLastError: Integer;
function GetHostName: string;
function Shutdown(s: TSocket; how: Integer): Integer;
function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory;
optlen: Integer): Integer;
function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory;
var optlen: Integer): Integer;
function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
function ntohs(netshort: word): word;
function ntohl(netlong: longword): longword;
function Listen(s: TSocket; backlog: Integer): Integer;
function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer;
function htons(hostshort: word): word;
function htonl(hostlong: longword): longword;
function GetSockName(s: TSocket; var name: TVarSin): Integer;
function GetPeerName(s: TSocket; var name: TVarSin): Integer;
function Connect(s: TSocket; const name: TVarSin): Integer;
function CloseSocket(s: TSocket): Integer;
function Bind(s: TSocket; const addr: TVarSin): Integer;
function Accept(s: TSocket; var addr: TVarSin): TSocket;
function Socket(af, Struc, Protocol: Integer): TSocket;
function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint;
function IsNewApi(Family: integer): Boolean;
function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
function GetSinIP(Sin: TVarSin): string;
function GetSinPort(Sin: TVarSin): Integer;
procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings);
function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string;
function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
{==============================================================================}
implementation
function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
(a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0));
end;
function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
(a^.u6_addr32[2] = 0) and
(a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and
(a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1));
end;
function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80));
end;
function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0));
end;
function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
begin
Result := (a^.u6_addr8[0] = $FF);
end;
function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean;
begin
Result := (CompareMem( a, b, sizeof(TInAddr6)));
end;
procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
begin
FillChar(a^, sizeof(TInAddr6), 0);
end;
procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
begin
FillChar(a^, sizeof(TInAddr6), 0);
a^.u6_addr8[15] := 1;
end;
{=============================================================================}
function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
begin
with WSData do
begin
wVersion := wVersionRequired;
wHighVersion := $202;
szDescription := 'Synsock - Synapse Platform Independent Socket Layer';
szSystemStatus := 'Running on Unix/Linux by FreePascal';
iMaxSockets := 32768;
iMaxUdpDg := 8192;
end;
Result := 0;
end;
function WSACleanup: Integer;
begin
Result := 0;
end;
function WSAGetLastError: Integer;
begin
Result := fpGetErrno;
end;
function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean;
begin
Result := fpFD_ISSET(socket, fdset) <> 0;
end;
procedure FD_SET(Socket: TSocket; var fdset: TFDSet);
begin
fpFD_SET(Socket, fdset);
end;
procedure FD_CLR(Socket: TSocket; var fdset: TFDSet);
begin
fpFD_CLR(Socket, fdset);
end;
procedure FD_ZERO(var fdset: TFDSet);
begin
fpFD_ZERO(fdset);
end;
{=============================================================================}
function SizeOfVarSin(sin: TVarSin): integer;
begin
case sin.sin_family of
AF_INET:
Result := SizeOf(TSockAddrIn);
AF_INET6:
Result := SizeOf(TSockAddrIn6);
else
Result := 0;
end;
end;
{=============================================================================}
function Bind(s: TSocket; const addr: TVarSin): Integer;
begin
if fpBind(s, @addr, SizeOfVarSin(addr)) = 0 then
Result := 0
else
Result := SOCKET_ERROR;
end;
function Connect(s: TSocket; const name: TVarSin): Integer;
begin
if fpConnect(s, @name, SizeOfVarSin(name)) = 0 then
Result := 0
else
Result := SOCKET_ERROR;
end;
function GetSockName(s: TSocket; var name: TVarSin): Integer;
var
len: integer;
begin
len := SizeOf(name);
FillChar(name, len, 0);
Result := fpGetSockName(s, @name, @Len);
end;
function GetPeerName(s: TSocket; var name: TVarSin): Integer;
var
len: integer;
begin
len := SizeOf(name);
FillChar(name, len, 0);
Result := fpGetPeerName(s, @name, @Len);
end;
function GetHostName: string;
begin
Result := unix.GetHostName;
end;
function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
begin
Result := fpSend(s, pointer(Buf), len, flags);
end;
function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
begin
Result := fpRecv(s, pointer(Buf), len, flags);
end;
function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
begin
Result := fpSendTo(s, pointer(Buf), len, flags, @addrto, SizeOfVarSin(addrto));
end;
function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
var
x: integer;
begin
x := SizeOf(from);
Result := fpRecvFrom(s, pointer(Buf), len, flags, @from, @x);
end;
function Accept(s: TSocket; var addr: TVarSin): TSocket;
var
x: integer;
begin
x := SizeOf(addr);
Result := fpAccept(s, @addr, @x);
end;
function Shutdown(s: TSocket; how: Integer): Integer;
begin
Result := fpShutdown(s, how);
end;
function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory;
optlen: Integer): Integer;
begin
Result := fpsetsockopt(s, level, optname, pointer(optval), optlen);
end;
function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory;
var optlen: Integer): Integer;
begin
Result := fpgetsockopt(s, level, optname, pointer(optval), @optlen);
end;
function ntohs(netshort: word): word;
begin
Result := sockets.ntohs(NetShort);
end;
function ntohl(netlong: longword): longword;
begin
Result := sockets.ntohl(NetLong);
end;
function Listen(s: TSocket; backlog: Integer): Integer;
begin
if fpListen(s, backlog) = 0 then
Result := 0
else
Result := SOCKET_ERROR;
end;
function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer;
begin
Result := fpIoctl(s, cmd, @arg);
end;
function htons(hostshort: word): word;
begin
Result := sockets.htons(Hostshort);
end;
function htonl(hostlong: longword): longword;
begin
Result := sockets.htonl(HostLong);
end;
function CloseSocket(s: TSocket): Integer;
begin
Result := sockets.CloseSocket(s);
end;
function Socket(af, Struc, Protocol: Integer): TSocket;
begin
Result := fpSocket(af, struc, protocol);
end;
function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint;
begin
Result := fpSelect(nfds, readfds, writefds, exceptfds, timeout);
end;
{=============================================================================}
function IsNewApi(Family: integer): Boolean;
begin
Result := SockEnhancedApi;
if not Result then
Result := (Family = AF_INET6) and SockWship6Api;
end;
function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
var
TwoPass: boolean;
f1, f2: integer;
function GetAddr(f:integer): integer;
var
a4: array [1..1] of in_addr;
a6: array [1..1] of Tin6_addr;
he: THostEntry;
begin
Result := WSAEPROTONOSUPPORT;
case f of
AF_INET:
begin
if IP = cAnyHost then
begin
Sin.sin_family := AF_INET;
Result := 0;
end
else
begin
if lowercase(IP) = cLocalHostStr then
a4[1].s_addr := htonl(INADDR_LOOPBACK)
else
begin
a4[1].s_addr := 0;
Result := WSAHOST_NOT_FOUND;
a4[1] := StrTonetAddr(IP);
if a4[1].s_addr = INADDR_ANY then
if GetHostByName(ip, he) then
a4[1]:=HostToNet(he.Addr)
else
Resolvename(ip, a4);
end;
if a4[1].s_addr <> INADDR_ANY then
begin
Sin.sin_family := AF_INET;
sin.sin_addr := a4[1];
Result := 0;
end;
end;
end;
AF_INET6:
begin
if IP = c6AnyHost then
begin
Sin.sin_family := AF_INET6;
Result := 0;
end
else
begin
if lowercase(IP) = cLocalHostStr then
SET_LOOPBACK_ADDR6(@a6[1])
else
begin
Result := WSAHOST_NOT_FOUND;
SET_IN6_IF_ADDR_ANY(@a6[1]);
a6[1] := StrTonetAddr6(IP);
if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
Resolvename6(ip, a6);
end;
if not IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
begin
Sin.sin_family := AF_INET6;
sin.sin6_addr := a6[1];
Result := 0;
end;
end;
end;
end;
end;
begin
Result := 0;
FillChar(Sin, Sizeof(Sin), 0);
Sin.sin_port := Resolveport(port, family, SockProtocol, SockType);
TwoPass := False;
if Family = AF_UNSPEC then
begin
if PreferIP4 then
begin
f1 := AF_INET;
f2 := AF_INET6;
TwoPass := True;
end
else
begin
f2 := AF_INET;
f1 := AF_INET6;
TwoPass := True;
end;
end
else
f1 := Family;
Result := GetAddr(f1);
if Result <> 0 then
if TwoPass then
Result := GetAddr(f2);
end;
function GetSinIP(Sin: TVarSin): string;
begin
Result := '';
case sin.AddressFamily of
AF_INET:
begin
result := NetAddrToStr(sin.sin_addr);
end;
AF_INET6:
begin
result := NetAddrToStr6(sin.sin6_addr);
end;
end;
end;
function GetSinPort(Sin: TVarSin): Integer;
begin
if (Sin.sin_family = AF_INET6) then
Result := synsock.ntohs(Sin.sin6_port)
else
Result := synsock.ntohs(Sin.sin_port);
end;
procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings);
var
x, n: integer;
a4: array [1..255] of in_addr;
a6: array [1..255] of Tin6_addr;
he: THostEntry;
begin
IPList.Clear;
if (family = AF_INET) or (family = AF_UNSPEC) then
begin
if lowercase(name) = cLocalHostStr then
IpList.Add(cLocalHost)
else
begin
a4[1] := StrTonetAddr(name);
if a4[1].s_addr = INADDR_ANY then
if GetHostByName(name, he) then
begin
a4[1]:=HostToNet(he.Addr);
x := 1;
end
else
x := Resolvename(name, a4)
else
x := 1;
for n := 1 to x do
IpList.Add(netaddrToStr(a4[n]));
end;
end;
if (family = AF_INET6) or (family = AF_UNSPEC) then
begin
if lowercase(name) = cLocalHostStr then
IpList.Add(c6LocalHost)
else
begin
a6[1] := StrTonetAddr6(name);
if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
x := Resolvename6(name, a6)
else
x := 1;
for n := 1 to x do
IpList.Add(netaddrToStr6(a6[n]));
end;
end;
if IPList.Count = 0 then
IPList.Add(cLocalHost);
end;
function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
var
ProtoEnt: TProtocolEntry;
ServEnt: TServiceEntry;
begin
Result := synsock.htons(StrToIntDef(Port, 0));
if Result = 0 then
begin
ProtoEnt.Name := '';
GetProtocolByNumber(SockProtocol, ProtoEnt);
ServEnt.port := 0;
GetServiceByName(Port, ProtoEnt.Name, ServEnt);
Result := ServEnt.port;
end;
end;
function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string;
var
n: integer;
a4: array [1..1] of in_addr;
a6: array [1..1] of Tin6_addr;
a: array [1..1] of string;
begin
Result := IP;
a4[1] := StrToNetAddr(IP);
if a4[1].s_addr <> INADDR_ANY then
begin
//why ResolveAddress need address in HOST order? :-O
n := ResolveAddress(nettohost(a4[1]), a);
if n > 0 then
Result := a[1];
end
else
begin
a6[1] := StrToNetAddr6(IP);
n := ResolveAddress6(a6[1], a);
if n > 0 then
Result := a[1];
end;
end;
{=============================================================================}
function InitSocketInterface(stack: string): Boolean;
begin
SockEnhancedApi := False;
SockWship6Api := False;
// Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN));
Result := True;
end;
function DestroySocketInterface: Boolean;
begin
Result := True;
end;
initialization
begin
SynSockCS := SyncObjs.TCriticalSection.Create;
SET_IN6_IF_ADDR_ANY (@in6addr_any);
SET_LOOPBACK_ADDR6 (@in6addr_loopback);
end;
finalization
begin
SynSockCS.Free;
end;
{$ENDIF}
TransGUI/synapse/source/lib/synachar.pas 0000644 0000000 0000000 00000214532 11366572451 017276 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 005.002.002 |
|==============================================================================|
| Content: Charset conversion support |
|==============================================================================|
| Copyright (c)1999-2004, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2004. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{: @abstract(Charset conversion support)
This unit contains a routines for lot of charset conversions.
It using built-in conversion tables or external Iconv library. Iconv is used
when needed conversion is known by Iconv library. When Iconv library is not
found or Iconv not know requested conversion, then are internal routines used
for conversion. (You can disable Iconv support from your program too!)
Internal routines knows all major charsets for Europe or America. For East-Asian
charsets you must use Iconv library!
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit synachar;
interface
uses
{$IFNDEF WIN32}
{$IFNDEF FPC}
Libc,
{$ELSE}
{$IFDEF FPC_USE_LIBC}
Libc,
{$ENDIF}
{$ENDIF}
{$ELSE}
Windows,
{$ENDIF}
SysUtils,
synautil, synacode, synaicnv;
type
{:Type with all supported charsets.}
TMimeChar = (ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10, ISO_8859_13,
ISO_8859_14, ISO_8859_15, CP1250, CP1251, CP1252, CP1253, CP1254, CP1255,
CP1256, CP1257, CP1258, KOI8_R, CP895, CP852, UCS_2, UCS_4, UTF_8, UTF_7,
UTF_7mod, UCS_2LE, UCS_4LE,
//next is supported by Iconv only...
UTF_16, UTF_16LE, UTF_32, UTF_32LE, C99, JAVA, ISO_8859_16, KOI8_U, KOI8_RU,
CP862, CP866, MAC, MACCE, MACICE, MACCRO, MACRO, MACCYR, MACUK, MACGR, MACTU,
MACHEB, MACAR, MACTH, ROMAN8, NEXTSTEP, ARMASCII, GEORGIAN_AC, GEORGIAN_PS,
KOI8_T, MULELAO, CP1133, TIS620, CP874, VISCII, TCVN, ISO_IR_14, JIS_X0201,
JIS_X0208, JIS_X0212, GB1988_80, GB2312_80, ISO_IR_165, ISO_IR_149, EUC_JP,
SHIFT_JIS, CP932, ISO_2022_JP, ISO_2022_JP1, ISO_2022_JP2, GB2312, CP936,
GB18030, ISO_2022_CN, ISO_2022_CNE, HZ, EUC_TW, BIG5, CP950, BIG5_HKSCS,
EUC_KR, CP949, CP1361, ISO_2022_KR, CP737, CP775, CP853, CP855, CP857,
CP858, CP860, CP861, CP863, CP864, CP865, CP869, CP1125);
{:Set of any charsets.}
TMimeSetChar = set of TMimeChar;
const
{:Set of charsets supported by Iconv library only.}
IconvOnlyChars: set of TMimeChar = [UTF_16, UTF_16LE, UTF_32, UTF_32LE,
C99, JAVA, ISO_8859_16, KOI8_U, KOI8_RU, CP862, CP866, MAC, MACCE, MACICE,
MACCRO, MACRO, MACCYR, MACUK, MACGR, MACTU, MACHEB, MACAR, MACTH, ROMAN8,
NEXTSTEP, ARMASCII, GEORGIAN_AC, GEORGIAN_PS, KOI8_T, MULELAO, CP1133,
TIS620, CP874, VISCII, TCVN, ISO_IR_14, JIS_X0201, JIS_X0208, JIS_X0212,
GB1988_80, GB2312_80, ISO_IR_165, ISO_IR_149, EUC_JP, SHIFT_JIS, CP932,
ISO_2022_JP, ISO_2022_JP1, ISO_2022_JP2, GB2312, CP936, GB18030,
ISO_2022_CN, ISO_2022_CNE, HZ, EUC_TW, BIG5, CP950, BIG5_HKSCS, EUC_KR,
CP949, CP1361, ISO_2022_KR, CP737, CP775, CP853, CP855, CP857, CP858,
CP860, CP861, CP863, CP864, CP865, CP869, CP1125];
{:Set of charsets supported by internal routines only.}
NoIconvChars: set of TMimeChar = [CP895, UTF_7mod];
{:null character replace table. (Usable for disable charater replacing.)}
Replace_None: array[0..0] of Word =
(0);
{:Character replace table for remove Czech diakritics.}
Replace_Czech: array[0..59] of Word =
(
$00E1, $0061,
$010D, $0063,
$010F, $0064,
$010E, $0044,
$00E9, $0065,
$011B, $0065,
$00ED, $0069,
$0148, $006E,
$00F3, $006F,
$0159, $0072,
$0161, $0073,
$0165, $0074,
$00FA, $0075,
$016F, $0075,
$00FD, $0079,
$017E, $007A,
$00C1, $0041,
$010C, $0043,
$00C9, $0045,
$011A, $0045,
$00CD, $0049,
$0147, $004E,
$00D3, $004F,
$0158, $0052,
$0160, $0053,
$0164, $0054,
$00DA, $0055,
$016E, $0055,
$00DD, $0059,
$017D, $005A
);
var
{:By this you can generally disable/enable Iconv support.}
DisableIconv: Boolean = False;
{:Default set of charsets for @link(IdealCharsetCoding) function.}
IdealCharsets: TMimeSetChar =
[ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10,
KOI8_R, KOI8_U
{$IFNDEF CIL} //error URW778 ??? :-O
, GB2312, EUC_KR, ISO_2022_JP, EUC_TW
{$ENDIF}
];
{==============================================================================}
{:Convert Value from one charset to another. See: @link(CharsetConversionEx)}
function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar;
CharTo: TMimeChar): AnsiString;
{:Convert Value from one charset to another with additional character conversion.
see: @link(Replace_None) and @link(Replace_Czech)}
function CharsetConversionEx(const Value: AnsiString; CharFrom: TMimeChar;
CharTo: TMimeChar; const TransformTable: array of Word): AnsiString;
{:Convert Value from one charset to another with additional character conversion.
This funtion is similar to @link(CharsetConversionEx), but you can disable
transliteration of unconvertible characters.}
function CharsetConversionTrans(Value: AnsiString; CharFrom: TMimeChar;
CharTo: TMimeChar; const TransformTable: array of Word; Translit: Boolean): AnsiString;
{:Returns charset used by operating system.}
function GetCurCP: TMimeChar;
{:Returns charset used by operating system as OEM charset. (in Windows DOS box,
for example)}
function GetCurOEMCP: TMimeChar;
{:Converting string with charset name to TMimeChar.}
function GetCPFromID(Value: AnsiString): TMimeChar;
{:Converting TMimeChar to string with name of charset.}
function GetIDFromCP(Value: TMimeChar): AnsiString;
{:return @true when value need to be converted. (It is not 7-bit ASCII)}
function NeedCharsetConversion(const Value: AnsiString): Boolean;
{:Finding best target charset from set of TMimeChars with minimal count of
unconvertible characters.}
function IdealCharsetCoding(const Value: AnsiString; CharFrom: TMimeChar;
CharTo: TMimeSetChar): TMimeChar;
{:Return BOM (Byte Order Mark) for given unicode charset.}
function GetBOM(Value: TMimeChar): AnsiString;
{:Convert binary string with unicode content to WideString.}
function StringToWide(const Value: AnsiString): WideString;
{:Convert WideString to binary string with unicode content.}
function WideToString(const Value: WideString): AnsiString;
{==============================================================================}
implementation
//character transcoding tables X to UCS-2
{
//dummy table
$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
$00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
$00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF,
$00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
$00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF,
$00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7,
$00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
$00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7,
$00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF,
$00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7,
$00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
$00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7,
$00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF
}
const
{Latin-1
Danish, Dutch, English, Faeroese, Finnish, French, German, Icelandic,
Irish, Italian, Norwegian, Portuguese, Spanish and Swedish.
}
CharISO_8859_1: array[128..255] of Word =
(
$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
$00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
$00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF,
$00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
$00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF,
$00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7,
$00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
$00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7,
$00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF,
$00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7,
$00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
$00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7,
$00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF
);
{Latin-2
Albanian, Czech, English, German, Hungarian, Polish, Rumanian,
Serbo-Croatian, Slovak, Slovene and Swedish.
}
CharISO_8859_2: array[128..255] of Word =
(
$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
$00A0, $0104, $02D8, $0141, $00A4, $013D, $015A, $00A7,
$00A8, $0160, $015E, $0164, $0179, $00AD, $017D, $017B,
$00B0, $0105, $02DB, $0142, $00B4, $013E, $015B, $02C7,
$00B8, $0161, $015F, $0165, $017A, $02DD, $017E, $017C,
$0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7,
$010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E,
$0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7,
$0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF,
$0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7,
$010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F,
$0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7,
$0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9
);
{Latin-3
Afrikaans, Catalan, English, Esperanto, French, Galician,
German, Italian, Maltese and Turkish.
}
CharISO_8859_3: array[128..255] of Word =
(
$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
$00A0, $0126, $02D8, $00A3, $00A4, $FFFD, $0124, $00A7,
$00A8, $0130, $015E, $011E, $0134, $00AD, $FFFD, $017B,
$00B0, $0127, $00B2, $00B3, $00B4, $00B5, $0125, $00B7,
$00B8, $0131, $015F, $011F, $0135, $00BD, $FFFD, $017C,
$00C0, $00C1, $00C2, $FFFD, $00C4, $010A, $0108, $00C7,
$00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
$FFFD, $00D1, $00D2, $00D3, $00D4, $0120, $00D6, $00D7,
$011C, $00D9, $00DA, $00DB, $00DC, $016C, $015C, $00DF,
$00E0, $00E1, $00E2, $FFFD, $00E4, $010B, $0109, $00E7,
$00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
$FFFD, $00F1, $00F2, $00F3, $00F4, $0121, $00F6, $00F7,
$011D, $00F9, $00FA, $00FB, $00FC, $016D, $015D, $02D9
);
{Latin-4
Danish, English, Estonian, Finnish, German, Greenlandic,
Lappish, Latvian, Lithuanian, Norwegian and Swedish.
}
CharISO_8859_4: array[128..255] of Word =
(
$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
$00A0, $0104, $0138, $0156, $00A4, $0128, $013B, $00A7,
$00A8, $0160, $0112, $0122, $0166, $00AD, $017D, $00AF,
$00B0, $0105, $02DB, $0157, $00B4, $0129, $013C, $02C7,
$00B8, $0161, $0113, $0123, $0167, $014A, $017E, $014B,
$0100, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $012E,
$010C, $00C9, $0118, $00CB, $0116, $00CD, $00CE, $012A,
$0110, $0145, $014C, $0136, $00D4, $00D5, $00D6, $00D7,
$00D8, $0172, $00DA, $00DB, $00DC, $0168, $016A, $00DF,
$0101, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $012F,
$010D, $00E9, $0119, $00EB, $0117, $00ED, $00EE, $012B,
$0111, $0146, $014D, $0137, $00F4, $00F5, $00F6, $00F7,
$00F8, $0173, $00FA, $00FB, $00FC, $0169, $016B, $02D9
);
{CYRILLIC
Bulgarian, Bielorussian, English, Macedonian, Russian,
Serbo-Croatian and Ukrainian.
}
CharISO_8859_5: array[128..255] of Word =
(
$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
$00A0, $0401, $0402, $0403, $0404, $0405, $0406, $0407,
$0408, $0409, $040A, $040B, $040C, $00AD, $040E, $040F,
$0410, $0411, $0412, $0413, $0414, $0415, $0416, $0417,
$0418, $0419, $041A, $041B, $041C, $041D, $041E, $041F,
$0420, $0421, $0422, $0423, $0424, $0425, $0426, $0427,
$0428, $0429, $042A, $042B, $042C, $042D, $042E, $042F,
$0430, $0431, $0432, $0433, $0434, $0435, $0436, $0437,
$0438, $0439, $043A, $043B, $043C, $043D, $043E, $043F,
$0440, $0441, $0442, $0443, $0444, $0445, $0446, $0447,
$0448, $0449, $044A, $044B, $044C, $044D, $044E, $044F,
$2116, $0451, $0452, $0453, $0454, $0455, $0456, $0457,
$0458, $0459, $045A, $045B, $045C, $00A7, $045E, $045F
);
{ARABIC
}
CharISO_8859_6: array[128..255] of Word =
(
$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
$00A0, $FFFD, $FFFD, $FFFD, $00A4, $FFFD, $FFFD, $FFFD,
$FFFD, $FFFD, $FFFD, $FFFD, $060C, $00AD, $FFFD, $FFFD,
$FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD,
$FFFD, $FFFD, $FFFD, $061B, $FFFD, $FFFD, $FFFD, $061F,
$FFFD, $0621, $0622, $0623, $0624, $0625, $0626, $0627,
$0628, $0629, $062A, $062B, $062C, $062D, $062E, $062F,
$0630, $0631, $0632, $0633, $0634, $0635, $0636, $0637,
$0638, $0639, $063A, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD,
$0640, $0641, $0642, $0643, $0644, $0645, $0646, $0647,
$0648, $0649, $064A, $064B, $064C, $064D, $064E, $064F,
$0650, $0651, $0652, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD,
$FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD
);
{GREEK
}
CharISO_8859_7: array[128..255] of Word =
(
$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
$00A0, $2018, $2019, $00A3, $FFFD, $FFFD, $00A6, $00A7,
$00A8, $00A9, $FFFD, $00AB, $00AC, $00AD, $FFFD, $2015,
$00B0, $00B1, $00B2, $00B3, $0384, $0385, $0386, $00B7,
$0388, $0389, $038A, $00BB, $038C, $00BD, $038E, $038F,
$0390, $0391, $0392, $0393, $0394, $0395, $0396, $0397,
$0398, $0399, $039A, $039B, $039C, $039D, $039E, $039F,
$03A0, $03A1, $FFFD, $03A3, $03A4, $03A5, $03A6, $03A7,
$03A8, $03A9, $03AA, $03AB, $03AC, $03AD, $03AE, $03AF,
$03B0, $03B1, $03B2, $03B3, $03B4, $03B5, $03B6, $03B7,
$03B8, $03B9, $03BA, $03BB, $03BC, $03BD, $03BE, $03BF,
$03C0, $03C1, $03C2, $03C3, $03C4, $03C5, $03C6, $03C7,
$03C8, $03C9, $03CA, $03CB, $03CC, $03CD, $03CE, $FFFD
);
{HEBREW
}
CharISO_8859_8: array[128..255] of Word =
(
$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
$00A0, $FFFD, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
$00A8, $00A9, $00D7, $00AB, $00AC, $00AD, $00AE, $00AF,
$00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
$00B8, $00B9, $00F7, $00BB, $00BC, $00BD, $00BE, $FFFD,
$FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD,
$FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD,
$FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD,
$FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $2017,
$05D0, $05D1, $05D2, $05D3, $05D4, $05D5, $05D6, $05D7,
$05D8, $05D9, $05DA, $05DB, $05DC, $05DD, $05DE, $05DF,
$05E0, $05E1, $05E2, $05E3, $05E4, $05E5, $05E6, $05E7,
$05E8, $05E9, $05EA, $FFFD, $FFFD, $200E, $200F, $FFFD
);
{Latin-5
English, Finnish, French, German, Irish, Italian, Norwegian,
Portuguese, Spanish, Swedish and Turkish.
}
CharISO_8859_9: array[128..255] of Word =
(
$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
$00A0, $0104, $02D8, $0141, $00A4, $013D, $015A, $00A7,
$00A8, $0160, $015E, $0164, $0179, $00AD, $017D, $017B,
$00B0, $0105, $02DB, $0142, $00B4, $013E, $015B, $02C7,
$00B8, $0161, $015F, $0165, $017A, $02DD, $017E, $017C,
$0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7,
$010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E,
$011E, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7,
$00D8, $00D9, $00DA, $00DB, $00DC, $0130, $015E, $00DF,
$00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7,
$00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
$011F, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7,
$00F8, $00F9, $00FA, $00FB, $00FC, $0131, $015F, $00FF
);
{Latin-6
Danish, English, Estonian, Faeroese, Finnish, German, Greenlandic,
Icelandic, Lappish, Latvian, Lithuanian, Norwegian and Swedish.
}
CharISO_8859_10: array[128..255] of Word =
(
$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
$00A0, $0104, $0112, $0122, $012A, $0128, $0136, $00A7,
$013B, $0110, $0160, $0166, $017D, $00AD, $016A, $014A,
$00B0, $0105, $0113, $0123, $012B, $0129, $0137, $00B7,
$013C, $0111, $0161, $0167, $017E, $2015, $016B, $014B,
$0100, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $012E,
$010C, $00C9, $0118, $00CB, $0116, $00CD, $00CE, $00CF,
$00D0, $0145, $014C, $00D3, $00D4, $00D5, $00D6, $0168,
$00D8, $0172, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF,
$0101, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $012F,
$010D, $00E9, $0119, $00EB, $0117, $00ED, $00EE, $00EF,
$00F0, $0146, $014D, $00F3, $00F4, $00F5, $00F6, $0169,
$00F8, $0173, $00FA, $00FB, $00FC, $00FD, $00FE, $0138
);
CharISO_8859_13: array[128..255] of Word =
(
$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
$00A0, $201D, $00A2, $00A3, $00A4, $201E, $00A6, $00A7,
$00D8, $00A9, $0156, $00AB, $00AC, $00AD, $00AE, $00C6,
$00B0, $00B1, $00B2, $00B3, $201C, $00B5, $00B6, $00B7,
$00F8, $00B9, $0157, $00BB, $00BC, $00BD, $00BE, $00E6,
$0104, $012E, $0100, $0106, $00C4, $00C5, $0118, $0112,
$010C, $00C9, $0179, $0116, $0122, $0136, $012A, $013B,
$0160, $0143, $0145, $00D3, $014C, $00D5, $00D6, $00D7,
$0172, $0141, $015A, $016A, $00DC, $017B, $017D, $00DF,
$0105, $012F, $0101, $0107, $00E4, $00E5, $0119, $0113,
$010D, $00E9, $017A, $0117, $0123, $0137, $012B, $013C,
$0161, $0144, $0146, $00F3, $014D, $00F5, $00F6, $00F7,
$0173, $0142, $015B, $016B, $00FC, $017C, $017E, $2019
);
CharISO_8859_14: array[128..255] of Word =
(
$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
$00A0, $1E02, $1E03, $00A3, $010A, $010B, $1E0A, $00A7,
$1E80, $00A9, $1E82, $1E0B, $1EF2, $00AD, $00AE, $0178,
$1E1E, $1E1F, $0120, $0121, $1E40, $1E41, $00B6, $1E56,
$1E81, $1E57, $1E83, $1E60, $1EF3, $1E84, $1E85, $1E61,
$00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7,
$00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
$0174, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $1E6A,
$00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $0176, $00DF,
$00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7,
$00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
$0175, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $1E6B,
$00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $0177, $00FF
);
CharISO_8859_15: array[128..255] of Word =
(
$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
$00A0, $00A1, $00A2, $00A3, $20AC, $00A5, $0160, $00A7,
$0161, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF,
$00B0, $00B1, $00B2, $00B3, $017D, $00B5, $00B6, $00B7,
$017E, $00B9, $00BA, $00BB, $0152, $0153, $0178, $00BF,
$00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7,
$00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
$00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7,
$00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF,
$00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7,
$00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
$00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7,
$00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF
);
{Eastern European
}
CharCP_1250: array[128..255] of Word =
(
$20AC, $FFFD, $201A, $FFFD, $201E, $2026, $2020, $2021,
$FFFD, $2030, $0160, $2039, $015A, $0164, $017D, $0179,
$FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
$FFFD, $2122, $0161, $203A, $015B, $0165, $017E, $017A,
$00A0, $02C7, $02D8, $0141, $00A4, $0104, $00A6, $00A7,
$00A8, $00A9, $015E, $00AB, $00AC, $00AD, $00AE, $017B,
$00B0, $00B1, $02DB, $0142, $00B4, $00B5, $00B6, $00B7,
$00B8, $0105, $015F, $00BB, $013D, $02DD, $013E, $017C,
$0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7,
$010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E,
$0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7,
$0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF,
$0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7,
$010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F,
$0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7,
$0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9
);
{Cyrillic
}
CharCP_1251: array[128..255] of Word =
(
$0402, $0403, $201A, $0453, $201E, $2026, $2020, $2021,
$20AC, $2030, $0409, $2039, $040A, $040C, $040B, $040F,
$0452, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
$FFFD, $2122, $0459, $203A, $045A, $045C, $045B, $045F,
$00A0, $040E, $045E, $0408, $00A4, $0490, $00A6, $00A7,
$0401, $00A9, $0404, $00AB, $00AC, $00AD, $00AE, $0407,
$00B0, $00B1, $0406, $0456, $0491, $00B5, $00B6, $00B7,
$0451, $2116, $0454, $00BB, $0458, $0405, $0455, $0457,
$0410, $0411, $0412, $0413, $0414, $0415, $0416, $0417,
$0418, $0419, $041A, $041B, $041C, $041D, $041E, $041F,
$0420, $0421, $0422, $0423, $0424, $0425, $0426, $0427,
$0428, $0429, $042A, $042B, $042C, $042D, $042E, $042F,
$0430, $0431, $0432, $0433, $0434, $0435, $0436, $0437,
$0438, $0439, $043A, $043B, $043C, $043D, $043E, $043F,
$0440, $0441, $0442, $0443, $0444, $0445, $0446, $0447,
$0448, $0449, $044A, $044B, $044C, $044D, $044E, $044F
);
{Latin-1 (US, Western Europe)
}
CharCP_1252: array[128..255] of Word =
(
$20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021,
$02C6, $2030, $0160, $2039, $0152, $FFFD, $017D, $FFFD,
$FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
$02DC, $2122, $0161, $203A, $0153, $FFFD, $017E, $0178,
$00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
$00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF,
$00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
$00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF,
$00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7,
$00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
$00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7,
$00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF,
$00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7,
$00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
$00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7,
$00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF
);
{Greek
}
CharCP_1253: array[128..255] of Word =
(
$20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021,
$FFFD, $2030, $FFFD, $2039, $FFFD, $FFFD, $FFFD, $FFFD,
$FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
$FFFD, $2122, $FFFD, $203A, $FFFD, $FFFD, $FFFD, $FFFD,
$00A0, $0385, $0386, $00A3, $00A4, $00A5, $00A6, $00A7,
$00A8, $00A9, $FFFD, $00AB, $00AC, $00AD, $00AE, $2015,
$00B0, $00B1, $00B2, $00B3, $0384, $00B5, $00B6, $00B7,
$0388, $0389, $038A, $00BB, $038C, $00BD, $038E, $038F,
$0390, $0391, $0392, $0393, $0394, $0395, $0396, $0397,
$0398, $0399, $039A, $039B, $039C, $039D, $039E, $039F,
$03A0, $03A1, $FFFD, $03A3, $03A4, $03A5, $03A6, $03A7,
$03A8, $03A9, $03AA, $03AB, $03AC, $03AD, $03AE, $03AF,
$03B0, $03B1, $03B2, $03B3, $03B4, $03B5, $03B6, $03B7,
$03B8, $03B9, $03BA, $03BB, $03BC, $03BD, $03BE, $03BF,
$03C0, $03C1, $03C2, $03C3, $03C4, $03C5, $03C6, $03C7,
$03C8, $03C9, $03CA, $03CB, $03CC, $03CD, $03CE, $FFFD
);
{Turkish
}
CharCP_1254: array[128..255] of Word =
(
$20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021,
$02C6, $2030, $0160, $2039, $0152, $FFFD, $FFFD, $FFFD,
$FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
$02DC, $2122, $0161, $203A, $0153, $FFFD, $FFFD, $0178,
$00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
$00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF,
$00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
$00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF,
$00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7,
$00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
$011E, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7,
$00D8, $00D9, $00DA, $00DB, $00DC, $0130, $015E, $00DF,
$00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7,
$00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
$011F, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7,
$00F8, $00F9, $00FA, $00FB, $00FC, $0131, $015F, $00FF
);
{Hebrew
}
CharCP_1255: array[128..255] of Word =
(
$20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021,
$02C6, $2030, $FFFD, $2039, $FFFD, $FFFD, $FFFD, $FFFD,
$FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
$02DC, $2122, $FFFD, $203A, $FFFD, $FFFD, $FFFD, $FFFD,
$00A0, $00A1, $00A2, $00A3, $20AA, $00A5, $00A6, $00A7,
$00A8, $00A9, $00D7, $00AB, $00AC, $00AD, $00AE, $00AF,
$00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
$00B8, $00B9, $00F7, $00BB, $00BC, $00BD, $00BE, $00BF,
$05B0, $05B1, $05B2, $05B3, $05B4, $05B5, $05B6, $05B7,
$05B8, $05B9, $FFFD, $05BB, $05BC, $05BD, $05BE, $05BF,
$05C0, $05C1, $05C2, $05C3, $05F0, $05F1, $05F2, $05F3,
$05F4, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD,
$05D0, $05D1, $05D2, $05D3, $05D4, $05D5, $05D6, $05D7,
$05D8, $05D9, $05DA, $05DB, $05DC, $05DD, $05DE, $05DF,
$05E0, $05E1, $05E2, $05E3, $05E4, $05E5, $05E6, $05E7,
$05E8, $05E9, $05EA, $FFFD, $FFFD, $200E, $200F, $FFFD
);
{Arabic
}
CharCP_1256: array[128..255] of Word =
(
$20AC, $067E, $201A, $0192, $201E, $2026, $2020, $2021,
$02C6, $2030, $0679, $2039, $0152, $0686, $0698, $0688,
$06AF, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
$06A9, $2122, $0691, $203A, $0153, $200C, $200D, $06BA,
$00A0, $060C, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
$00A8, $00A9, $06BE, $00AB, $00AC, $00AD, $00AE, $00AF,
$00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
$00B8, $00B9, $061B, $00BB, $00BC, $00BD, $00BE, $061F,
$06C1, $0621, $0622, $0623, $0624, $0625, $0626, $0627,
$0628, $0629, $062A, $062B, $062C, $062D, $062E, $062F,
$0630, $0631, $0632, $0633, $0634, $0635, $0636, $00D7,
$0637, $0638, $0639, $063A, $0640, $0641, $0642, $0643,
$00E0, $0644, $00E2, $0645, $0646, $0647, $0648, $00E7,
$00E8, $00E9, $00EA, $00EB, $0649, $064A, $00EE, $00EF,
$064B, $064C, $064D, $064E, $00F4, $064F, $0650, $00F7,
$0651, $00F9, $0652, $00FB, $00FC, $200E, $200F, $06D2
);
{Baltic
}
CharCP_1257: array[128..255] of Word =
(
$20AC, $FFFD, $201A, $FFFD, $201E, $2026, $2020, $2021,
$FFFD, $2030, $FFFD, $2039, $FFFD, $00A8, $02C7, $00B8,
$FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
$FFFD, $2122, $FFFD, $203A, $FFFD, $00AF, $02DB, $FFFD,
$00A0, $FFFD, $00A2, $00A3, $00A4, $FFFD, $00A6, $00A7,
$00D8, $00A9, $0156, $00AB, $00AC, $00AD, $00AE, $00C6,
$00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
$00F8, $00B9, $0157, $00BB, $00BC, $00BD, $00BE, $00E6,
$0104, $012E, $0100, $0106, $00C4, $00C5, $0118, $0112,
$010C, $00C9, $0179, $0116, $0122, $0136, $012A, $013B,
$0160, $0143, $0145, $00D3, $014C, $00D5, $00D6, $00D7,
$0172, $0141, $015A, $016A, $00DC, $017B, $017D, $00DF,
$0105, $012F, $0101, $0107, $00E4, $00E5, $0119, $0113,
$010D, $00E9, $017A, $0117, $0123, $0137, $012B, $013C,
$0161, $0144, $0146, $00F3, $014D, $00F5, $00F6, $00F7,
$0173, $0142, $015B, $016B, $00FC, $017C, $017E, $02D9
);
{Vietnamese
}
CharCP_1258: array[128..255] of Word =
(
$20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021,
$02C6, $2030, $FFFD, $2039, $0152, $FFFD, $FFFD, $FFFD,
$FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
$02DC, $2122, $FFFD, $203A, $0153, $FFFD, $FFFD, $0178,
$00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
$00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF,
$00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
$00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF,
$00C0, $00C1, $00C2, $0102, $00C4, $00C5, $00C6, $00C7,
$00C8, $00C9, $00CA, $00CB, $0300, $00CD, $00CE, $00CF,
$0110, $00D1, $0309, $00D3, $00D4, $01A0, $00D6, $00D7,
$00D8, $00D9, $00DA, $00DB, $00DC, $01AF, $0303, $00DF,
$00E0, $00E1, $00E2, $0103, $00E4, $00E5, $00E6, $00E7,
$00E8, $00E9, $00EA, $00EB, $0301, $00ED, $00EE, $00EF,
$0111, $00F1, $0323, $00F3, $00F4, $01A1, $00F6, $00F7,
$00F8, $00F9, $00FA, $00FB, $00FC, $01B0, $20AB, $00FF
);
{Cyrillic
}
CharKOI8_R: array[128..255] of Word =
(
$2500, $2502, $250C, $2510, $2514, $2518, $251C, $2524,
$252C, $2534, $253C, $2580, $2584, $2588, $258C, $2590,
$2591, $2592, $2593, $2320, $25A0, $2219, $221A, $2248,
$2264, $2265, $00A0, $2321, $00B0, $00B2, $00B7, $00F7,
$2550, $2551, $2552, $0451, $2553, $2554, $2555, $2556,
$2557, $2558, $2559, $255A, $255B, $255C, $255D, $255E,
$255F, $2560, $2561, $0401, $2562, $2563, $2564, $2565,
$2566, $2567, $2568, $2569, $256A, $256B, $256C, $00A9,
$044E, $0430, $0431, $0446, $0434, $0435, $0444, $0433,
$0445, $0438, $0439, $043A, $043B, $043C, $043D, $043E,
$043F, $044F, $0440, $0441, $0442, $0443, $0436, $0432,
$044C, $044B, $0437, $0448, $044D, $0449, $0447, $044A,
$042E, $0410, $0411, $0426, $0414, $0415, $0424, $0413,
$0425, $0418, $0419, $041A, $041B, $041C, $041D, $041E,
$041F, $042F, $0420, $0421, $0422, $0423, $0416, $0412,
$042C, $042B, $0417, $0428, $042D, $0429, $0427, $042A
);
{Czech (Kamenicky)
}
CharCP_895: array[128..255] of Word =
(
$010C, $00FC, $00E9, $010F, $00E4, $010E, $0164, $010D,
$011B, $011A, $0139, $00CD, $013E, $013A, $00C4, $00C1,
$00C9, $017E, $017D, $00F4, $00F6, $00D3, $016F, $00DA,
$00FD, $00D6, $00DC, $0160, $013D, $00DD, $0158, $0165,
$00E1, $00ED, $00F3, $00FA, $0148, $0147, $016E, $00D4,
$0161, $0159, $0155, $0154, $00BC, $00A7, $00AB, $00BB,
$2591, $2592, $2593, $2502, $2524, $2561, $2562, $2556,
$2555, $2563, $2551, $2557, $255D, $255C, $255B, $2510,
$2514, $2534, $252C, $251C, $2500, $253C, $255E, $255F,
$255A, $2554, $2569, $2566, $2560, $2550, $256C, $2567,
$2568, $2564, $2565, $2559, $2558, $2552, $2553, $256B,
$256A, $2518, $250C, $2588, $2584, $258C, $2590, $2580,
$03B1, $03B2, $0393, $03C0, $03A3, $03C3, $03BC, $03C4,
$03A6, $0398, $03A9, $03B4, $221E, $2205, $03B5, $2229,
$2261, $00B1, $2265, $2264, $2320, $2321, $00F7, $2248,
$2218, $00B7, $2219, $221A, $207F, $00B2, $25A0, $00A0
);
{Eastern European
}
CharCP_852: array[128..255] of Word =
(
$00C7, $00FC, $00E9, $00E2, $00E4, $016F, $0107, $00E7,
$0142, $00EB, $0150, $0151, $00EE, $0179, $00C4, $0106,
$00C9, $0139, $013A, $00F4, $00F6, $013D, $013E, $015A,
$015B, $00D6, $00DC, $0164, $0165, $0141, $00D7, $010D,
$00E1, $00ED, $00F3, $00FA, $0104, $0105, $017D, $017E,
$0118, $0119, $00AC, $017A, $010C, $015F, $00AB, $00BB,
$2591, $2592, $2593, $2502, $2524, $00C1, $00C2, $011A,
$015E, $2563, $2551, $2557, $255D, $017B, $017C, $2510,
$2514, $2534, $252C, $251C, $2500, $253C, $0102, $0103,
$255A, $2554, $2569, $2566, $2560, $2550, $256C, $00A4,
$0111, $0110, $010E, $00CB, $010F, $0147, $00CD, $00CE,
$011B, $2518, $250C, $2588, $2584, $0162, $016E, $2580,
$00D3, $00DF, $00D4, $0143, $0144, $0148, $0160, $0161,
$0154, $00DA, $0155, $0170, $00FD, $00DD, $0163, $00B4,
$00AD, $02DD, $02DB, $02C7, $02D8, $00A7, $00F7, $00B8,
$00B0, $00A8, $02D9, $0171, $0158, $0159, $25A0, $00A0
);
{==============================================================================}
type
TIconvChar = record
Charset: TMimeChar;
CharName: string;
end;
TIconvArr = array [0..112] of TIconvChar;
const
NotFoundChar = '_';
var
SetTwo: set of TMimeChar = [UCS_2, UCS_2LE, UTF_7, UTF_7mod];
SetFour: set of TMimeChar = [UCS_4, UCS_4LE, UTF_8];
SetLE: set of TMimeChar = [UCS_2LE, UCS_4LE];
IconvArr: TIconvArr;
{==============================================================================}
function FindIconvID(const Value, Charname: string): Boolean;
var
s: string;
begin
Result := True;
//exact match
if Value = Charname then
Exit;
//Value is on begin of charname
s := Value + ' ';
if s = Copy(Charname, 1, Length(s)) then
Exit;
//Value is on end of charname
s := ' ' + Value;
if s = Copy(Charname, Length(Charname) - Length(s) + 1, Length(s)) then
Exit;
//value is somewhere inside charname
if Pos( s + ' ', Charname) > 0 then
Exit;
Result := False;
end;
function GetCPFromIconvID(Value: AnsiString): TMimeChar;
var
n: integer;
begin
Result := ISO_8859_1;
Value := UpperCase(Value);
for n := 0 to High(IconvArr) do
if FindIconvID(Value, IconvArr[n].Charname) then
begin
Result := IconvArr[n].Charset;
Break;
end;
end;
{==============================================================================}
function GetIconvIDFromCP(Value: TMimeChar): AnsiString;
var
n: integer;
begin
Result := 'ISO-8859-1';
for n := 0 to High(IconvArr) do
if IconvArr[n].Charset = Value then
begin
Result := Separateleft(IconvArr[n].Charname, ' ');
Break;
end;
end;
{==============================================================================}
function ReplaceUnicode(Value: Word; const TransformTable: array of Word): Word;
var
n: integer;
begin
if High(TransformTable) <> 0 then
for n := 0 to High(TransformTable) do
if not odd(n) then
if TransformTable[n] = Value then
begin
Value := TransformTable[n+1];
break;
end;
Result := Value;
end;
{==============================================================================}
procedure CopyArray(const SourceTable: array of Word;
var TargetTable: array of Word);
var
n: Integer;
begin
for n := 0 to 127 do
TargetTable[n] := SourceTable[n];
end;
{==============================================================================}
procedure GetArray(CharSet: TMimeChar; var Result: array of Word);
begin
case CharSet of
ISO_8859_2:
CopyArray(CharISO_8859_2, Result);
ISO_8859_3:
CopyArray(CharISO_8859_3, Result);
ISO_8859_4:
CopyArray(CharISO_8859_4, Result);
ISO_8859_5:
CopyArray(CharISO_8859_5, Result);
ISO_8859_6:
CopyArray(CharISO_8859_6, Result);
ISO_8859_7:
CopyArray(CharISO_8859_7, Result);
ISO_8859_8:
CopyArray(CharISO_8859_8, Result);
ISO_8859_9:
CopyArray(CharISO_8859_9, Result);
ISO_8859_10:
CopyArray(CharISO_8859_10, Result);
ISO_8859_13:
CopyArray(CharISO_8859_13, Result);
ISO_8859_14:
CopyArray(CharISO_8859_14, Result);
ISO_8859_15:
CopyArray(CharISO_8859_15, Result);
CP1250:
CopyArray(CharCP_1250, Result);
CP1251:
CopyArray(CharCP_1251, Result);
CP1252:
CopyArray(CharCP_1252, Result);
CP1253:
CopyArray(CharCP_1253, Result);
CP1254:
CopyArray(CharCP_1254, Result);
CP1255:
CopyArray(CharCP_1255, Result);
CP1256:
CopyArray(CharCP_1256, Result);
CP1257:
CopyArray(CharCP_1257, Result);
CP1258:
CopyArray(CharCP_1258, Result);
KOI8_R:
CopyArray(CharKOI8_R, Result);
CP895:
CopyArray(CharCP_895, Result);
CP852:
CopyArray(CharCP_852, Result);
else
CopyArray(CharISO_8859_1, Result);
end;
end;
{==============================================================================}
procedure ReadMulti(const Value: AnsiString; var Index: Integer; mb: Byte;
var b1, b2, b3, b4: Byte; le: boolean);
Begin
b1 := 0;
b2 := 0;
b3 := 0;
b4 := 0;
if Index < 0 then
Index := 1;
if mb > 4 then
mb := 1;
if (Index + mb - 1) <= Length(Value) then
begin
if le then
Case mb Of
1:
b1 := Ord(Value[Index]);
2:
Begin
b1 := Ord(Value[Index]);
b2 := Ord(Value[Index + 1]);
End;
3:
Begin
b1 := Ord(Value[Index]);
b2 := Ord(Value[Index + 1]);
b3 := Ord(Value[Index + 2]);
End;
4:
Begin
b1 := Ord(Value[Index]);
b2 := Ord(Value[Index + 1]);
b3 := Ord(Value[Index + 2]);
b4 := Ord(Value[Index + 3]);
End;
end
else
Case mb Of
1:
b1 := Ord(Value[Index]);
2:
Begin
b2 := Ord(Value[Index]);
b1 := Ord(Value[Index + 1]);
End;
3:
Begin
b3 := Ord(Value[Index]);
b2 := Ord(Value[Index + 1]);
b1 := Ord(Value[Index + 2]);
End;
4:
Begin
b4 := Ord(Value[Index]);
b3 := Ord(Value[Index + 1]);
b2 := Ord(Value[Index + 2]);
b1 := Ord(Value[Index + 3]);
End;
end;
end;
Inc(Index, mb);
end;
{==============================================================================}
function WriteMulti(b1, b2, b3, b4: Byte; mb: Byte; le: boolean): AnsiString;
begin
if mb > 4 then
mb := 1;
SetLength(Result, mb);
if le then
case mb Of
1:
Result[1] := AnsiChar(b1);
2:
begin
Result[1] := AnsiChar(b1);
Result[2] := AnsiChar(b2);
end;
3:
begin
Result[1] := AnsiChar(b1);
Result[2] := AnsiChar(b2);
Result[3] := AnsiChar(b3);
end;
4:
begin
Result[1] := AnsiChar(b1);
Result[2] := AnsiChar(b2);
Result[3] := AnsiChar(b3);
Result[4] := AnsiChar(b4);
end;
end
else
case mb Of
1:
Result[1] := AnsiChar(b1);
2:
begin
Result[2] := AnsiChar(b1);
Result[1] := AnsiChar(b2);
end;
3:
begin
Result[3] := AnsiChar(b1);
Result[2] := AnsiChar(b2);
Result[1] := AnsiChar(b3);
end;
4:
begin
Result[4] := AnsiChar(b1);
Result[3] := AnsiChar(b2);
Result[2] := AnsiChar(b3);
Result[1] := AnsiChar(b4);
end;
end;
end;
{==============================================================================}
function UTF8toUCS4(const Value: AnsiString): AnsiString;
var
n, x, ul, m: Integer;
s: AnsiString;
w1, w2: Word;
begin
Result := '';
n := 1;
while Length(Value) >= n do
begin
x := Ord(Value[n]);
Inc(n);
if x < 128 then
Result := Result + WriteMulti(x, 0, 0, 0, 4, false)
else
begin
m := 0;
if (x and $E0) = $C0 then
m := $1F;
if (x and $F0) = $E0 then
m := $0F;
if (x and $F8) = $F0 then
m := $07;
if (x and $FC) = $F8 then
m := $03;
if (x and $FE) = $FC then
m := $01;
ul := x and m;
s := IntToBin(ul, 0);
while Length(Value) >= n do
begin
x := Ord(Value[n]);
Inc(n);
if (x and $C0) = $80 then
s := s + IntToBin(x and $3F, 6)
else
begin
Dec(n);
Break;
end;
end;
ul := BinToInt(s);
w1 := ul div 65536;
w2 := ul mod 65536;
Result := Result + WriteMulti(Lo(w2), Hi(w2), Lo(w1), Hi(w1), 4, false);
end;
end;
end;
{==============================================================================}
function UCS4toUTF8(const Value: AnsiString): AnsiString;
var
s, l, k: AnsiString;
b1, b2, b3, b4: Byte;
n, m, x, y: Integer;
b: Byte;
begin
Result := '';
n := 1;
while Length(Value) >= n do
begin
ReadMulti(Value, n, 4, b1, b2, b3, b4, false);
if (b2 = 0) and (b3 = 0) and (b4 = 0) and (b1 < 128) then
Result := Result + AnsiChar(b1)
else
begin
x := (b1 + 256 * b2) + (b3 + 256 * b4) * 65536;
l := IntToBin(x, 0);
y := Length(l) div 6;
s := '';
for m := 1 to y do
begin
k := Copy(l, Length(l) - 5, 6);
l := Copy(l, 1, Length(l) - 6);
b := BinToInt(k) or $80;
s := AnsiChar(b) + s;
end;
b := BinToInt(l);
case y of
5:
b := b or $FC;
4:
b := b or $F8;
3:
b := b or $F0;
2:
b := b or $E0;
1:
b := b or $C0;
end;
s := AnsiChar(b) + s;
Result := Result + s;
end;
end;
end;
{==============================================================================}
function UTF7toUCS2(const Value: AnsiString; Modified: Boolean): AnsiString;
var
n, i: Integer;
c: AnsiChar;
s, t: AnsiString;
shift: AnsiChar;
table: String;
begin
Result := '';
n := 1;
if modified then
begin
shift := '&';
table := TableBase64mod;
end
else
begin
shift := '+';
table := TableBase64;
end;
while Length(Value) >= n do
begin
c := Value[n];
Inc(n);
if c <> shift then
Result := Result + WriteMulti(Ord(c), 0, 0, 0, 2, false)
else
begin
s := '';
while Length(Value) >= n do
begin
c := Value[n];
Inc(n);
if c = '-' then
Break;
if (c = '=') or (Pos(c, table) < 1) then
begin
Dec(n);
Break;
end;
s := s + c;
end;
if s = '' then
s := WriteMulti(Ord(shift), 0, 0, 0, 2, false)
else
begin
if modified then
t := DecodeBase64mod(s)
else
t := DecodeBase64(s);
if not odd(length(t)) then
s := t
else
begin //ill-formed sequence
t := s;
s := WriteMulti(Ord(shift), 0, 0, 0, 2, false);
for i := 1 to length(t) do
s := s + WriteMulti(Ord(t[i]), 0, 0, 0, 2, false);
end;
end;
Result := Result + s;
end;
end;
end;
{==============================================================================}
function UCS2toUTF7(const Value: AnsiString; Modified: Boolean): AnsiString;
var
s: AnsiString;
b1, b2, b3, b4: Byte;
n, m: Integer;
shift: AnsiChar;
begin
Result := '';
n := 1;
if modified then
shift := '&'
else
shift := '+';
while Length(Value) >= n do
begin
ReadMulti(Value, n, 2, b1, b2, b3, b4, false);
if (b2 = 0) and (b1 < 128) then
if AnsiChar(b1) = shift then
Result := Result + shift + '-'
else
Result := Result + AnsiChar(b1)
else
begin
s := AnsiChar(b2) + AnsiChar(b1);
while Length(Value) >= n do
begin
ReadMulti(Value, n, 2, b1, b2, b3, b4, false);
if (b2 = 0) and (b1 < 128) then
begin
Dec(n, 2);
Break;
end;
s := s + AnsiChar(b2) + AnsiChar(b1);
end;
if modified then
s := EncodeBase64mod(s)
else
s := EncodeBase64(s);
m := Pos('=', s);
if m > 0 then
s := Copy(s, 1, m - 1);
Result := Result + shift + s + '-';
end;
end;
end;
{==============================================================================}
function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar;
CharTo: TMimeChar): AnsiString;
begin
Result := CharsetConversionEx(Value, CharFrom, CharTo, Replace_None);
end;
{==============================================================================}
function CharsetConversionEx(const Value: AnsiString; CharFrom: TMimeChar;
CharTo: TMimeChar; const TransformTable: array of Word): AnsiString;
begin
Result := CharsetConversionTrans(Value, CharFrom, CharTo, TransformTable, True);
end;
{==============================================================================}
function InternalToUcs(const Value: AnsiString; Charfrom: TMimeChar): AnsiString;
var
uni: Word;
n: Integer;
b1, b2, b3, b4: Byte;
SourceTable: array[128..255] of Word;
mbf: Byte;
lef: Boolean;
s: AnsiString;
begin
if CharFrom = UTF_8 then
s := UTF8toUCS4(Value)
else
if CharFrom = UTF_7 then
s := UTF7toUCS2(Value, False)
else
if CharFrom = UTF_7mod then
s := UTF7toUCS2(Value, True)
else
s := Value;
GetArray(CharFrom, SourceTable);
mbf := 1;
if CharFrom in SetTwo then
mbf := 2;
if CharFrom in SetFour then
mbf := 4;
lef := CharFrom in SetLe;
Result := '';
n := 1;
while Length(s) >= n do
begin
ReadMulti(s, n, mbf, b1, b2, b3, b4, lef);
//handle BOM
if (b3 = 0) and (b4 = 0) then
begin
if (b1 = $FE) and (b2 = $FF) then
begin
lef := not lef;
continue;
end;
if (b1 = $FF) and (b2 = $FE) then
continue;
end;
if mbf = 1 then
if b1 > 127 then
begin
uni := SourceTable[b1];
b1 := Lo(uni);
b2 := Hi(uni);
end;
Result := Result + WriteMulti(b1, b2, b3, b4, 2, False);
end;
end;
function CharsetConversionTrans(Value: AnsiString; CharFrom: TMimeChar;
CharTo: TMimeChar; const TransformTable: array of Word; Translit: Boolean): AnsiString;
var
uni: Word;
n, m: Integer;
b: Byte;
b1, b2, b3, b4: Byte;
TargetTable: array[128..255] of Word;
mbt: Byte;
let: Boolean;
ucsstring, s, t: AnsiString;
cd: iconv_t;
f: Boolean;
NotNeedTransform: Boolean;
FromID, ToID: string;
begin
NotNeedTransform := (High(TransformTable) = 0);
if (CharFrom = CharTo) and NotNeedTransform then
begin
Result := Value;
Exit;
end;
FromID := GetIDFromCP(CharFrom);
ToID := GetIDFromCP(CharTo);
cd := Iconv_t(-1);
//do two-pass conversion. Transform to UCS-2 first.
if not DisableIconv then
cd := SynaIconvOpenIgnore('UCS-2BE', FromID);
try
if cd <> iconv_t(-1) then
SynaIconv(cd, Value, ucsstring)
else
ucsstring := InternalToUcs(Value, CharFrom);
finally
SynaIconvClose(cd);
end;
//here we allways have ucstring with UCS-2 encoding
//second pass... from UCS-2 to target encoding.
if not DisableIconv then
if translit then
cd := SynaIconvOpenTranslit(ToID, 'UCS-2BE')
else
cd := SynaIconvOpenIgnore(ToID, 'UCS-2BE');
try
if (cd <> iconv_t(-1)) and NotNeedTransform then
begin
if CharTo = UTF_7 then
ucsstring := ucsstring + #0 + '-';
//when transformtable is not needed and Iconv know target charset,
//do it fast by one call.
SynaIconv(cd, ucsstring, Result);
if CharTo = UTF_7 then
Delete(Result, Length(Result), 1);
end
else
begin
GetArray(CharTo, TargetTable);
mbt := 1;
if CharTo in SetTwo then
mbt := 2;
if CharTo in SetFour then
mbt := 4;
let := CharTo in SetLe;
b3 := 0;
b4 := 0;
Result := '';
for n:= 0 to (Length(ucsstring) div 2) - 1 do
begin
s := Copy(ucsstring, n * 2 + 1, 2);
b2 := Ord(s[1]);
b1 := Ord(s[2]);
uni := b2 * 256 + b1;
if not NotNeedTransform then
begin
uni := ReplaceUnicode(uni, TransformTable);
b1 := Lo(uni);
b2 := Hi(uni);
s[1] := AnsiChar(b2);
s[2] := AnsiChar(b1);
end;
if cd <> iconv_t(-1) then
begin
if CharTo = UTF_7 then
s := s + #0 + '-';
SynaIconv(cd, s, t);
if CharTo = UTF_7 then
Delete(t, Length(t), 1);
Result := Result + t;
end
else
begin
f := True;
if mbt = 1 then
if uni > 127 then
begin
f := False;
b := 0;
for m := 128 to 255 do
if TargetTable[m] = uni then
begin
b := m;
f := True;
Break;
end;
b1 := b;
b2 := 0;
end
else
b1 := Lo(uni);
if not f then
if translit then
begin
b1 := Ord(NotFoundChar);
b2 := 0;
f := True;
end;
if f then
Result := Result + WriteMulti(b1, b2, b3, b4, mbt, let)
end;
end;
if cd = iconv_t(-1) then
begin
if CharTo = UTF_7 then
Result := UCS2toUTF7(Result, false);
if CharTo = UTF_7mod then
Result := UCS2toUTF7(Result, true);
if CharTo = UTF_8 then
Result := UCS4toUTF8(Result);
end;
end;
finally
SynaIconvClose(cd);
end;
end;
{==============================================================================}
{$IFNDEF WIN32}
function GetCurCP: TMimeChar;
begin
{$IFNDEF FPC}
Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME));
{$ELSE}
{$IFDEF FPC_USE_LIBC}
Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME));
{$ELSE}
//How to get system codepage without LIBC?
Result := UTF_8;
{$ENDIF}
{$ENDIF}
end;
function GetCurOEMCP: TMimeChar;
begin
Result := GetCurCP;
end;
{$ELSE}
function CPToMimeChar(Value: Integer): TMimeChar;
begin
case Value of
437, 850, 20127:
Result := ISO_8859_1; //I know, it is not ideal!
737:
Result := CP737;
775:
Result := CP775;
852:
Result := CP852;
855:
Result := CP855;
857:
Result := CP857;
858:
Result := CP858;
860:
Result := CP860;
861:
Result := CP861;
862:
Result := CP862;
863:
Result := CP863;
864:
Result := CP864;
865:
Result := CP865;
866:
Result := CP866;
869:
Result := CP869;
874:
Result := ISO_8859_15;
895:
Result := CP895;
932:
Result := CP932;
936:
Result := CP936;
949:
Result := CP949;
950:
Result := CP950;
1200:
Result := UCS_2LE;
1201:
Result := UCS_2;
1250:
Result := CP1250;
1251:
Result := CP1251;
1253:
Result := CP1253;
1254:
Result := CP1254;
1255:
Result := CP1255;
1256:
Result := CP1256;
1257:
Result := CP1257;
1258:
Result := CP1258;
1361:
Result := CP1361;
10000:
Result := MAC;
10004:
Result := MACAR;
10005:
Result := MACHEB;
10006:
Result := MACGR;
10007:
Result := MACCYR;
10010:
Result := MACRO;
10017:
Result := MACUK;
10021:
Result := MACTH;
10029:
Result := MACCE;
10079:
Result := MACICE;
10081:
Result := MACTU;
10082:
Result := MACCRO;
12000:
Result := UCS_4LE;
12001:
Result := UCS_4;
20866:
Result := KOI8_R;
20932:
Result := JIS_X0208;
20936:
Result := GB2312;
21866:
Result := KOI8_U;
28591:
Result := ISO_8859_1;
28592:
Result := ISO_8859_2;
28593:
Result := ISO_8859_3;
28594:
Result := ISO_8859_4;
28595:
Result := ISO_8859_5;
28596, 708:
Result := ISO_8859_6;
28597:
Result := ISO_8859_7;
28598, 38598:
Result := ISO_8859_8;
28599:
Result := ISO_8859_9;
28605:
Result := ISO_8859_15;
50220:
Result := ISO_2022_JP; //? ISO 2022 Japanese with no halfwidth Katakana
50221:
Result := ISO_2022_JP1;//? Japanese with halfwidth Katakana
50222:
Result := ISO_2022_JP2;//? Japanese JIS X 0201-1989
50225:
Result := ISO_2022_KR;
50227:
Result := ISO_2022_CN;//? ISO 2022 Simplified Chinese
50229:
Result := ISO_2022_CNE;//? ISO 2022 Traditional Chinese
51932:
Result := EUC_JP;
51936:
Result := GB2312;
51949:
Result := EUC_KR;
52936:
Result := HZ;
54936:
Result := GB18030;
65000:
Result := UTF_7;
65001:
Result := UTF_8;
0:
Result := UCS_2LE;
else
Result := CP1252;
end;
end;
function GetCurCP: TMimeChar;
begin
Result := CPToMimeChar(GetACP);
end;
function GetCurOEMCP: TMimeChar;
begin
Result := CPToMimeChar(GetOEMCP);
end;
{$ENDIF}
{==============================================================================}
function NeedCharsetConversion(const Value: AnsiString): Boolean;
var
n: Integer;
begin
Result := False;
for n := 1 to Length(Value) do
if (Ord(Value[n]) > 127) or (Ord(Value[n]) = 0) then
begin
Result := True;
Break;
end;
end;
{==============================================================================}
function IdealCharsetCoding(const Value: AnsiString; CharFrom: TMimeChar;
CharTo: TMimeSetChar): TMimeChar;
var
n: Integer;
max: Integer;
s, t, u: AnsiString;
CharSet: TMimeChar;
begin
Result := ISO_8859_1;
s := Copy(Value, 1, 1024); //max first 1KB for next procedure
max := 0;
for n := Ord(Low(TMimeChar)) to Ord(High(TMimeChar)) do
begin
CharSet := TMimeChar(n);
if CharSet in CharTo then
begin
t := CharsetConversionTrans(s, CharFrom, CharSet, Replace_None, False);
u := CharsetConversionTrans(t, CharSet, CharFrom, Replace_None, False);
if s = u then
begin
Result := CharSet;
Exit;
end;
if Length(u) > max then
begin
Result := CharSet;
max := Length(u);
end;
end;
end;
end;
{==============================================================================}
function GetBOM(Value: TMimeChar): AnsiString;
begin
Result := '';
case Value of
UCS_2:
Result := #$fe + #$ff;
UCS_4:
Result := #$00 + #$00 + #$fe + #$ff;
UCS_2LE:
Result := #$ff + #$fe;
UCS_4LE:
Result := #$ff + #$fe + #$00 + #$00;
UTF_8:
Result := #$ef + #$bb + #$bf;
end;
end;
{==============================================================================}
function GetCPFromID(Value: AnsiString): TMimeChar;
begin
Value := UpperCase(Value);
if (Pos('KAMENICKY', Value) > 0) or (Pos('895', Value) > 0) then
Result := CP895
else
if Pos('MUTF-7', Value) > 0 then
Result := UTF_7mod
else
Result := GetCPFromIconvID(Value);
end;
{==============================================================================}
function GetIDFromCP(Value: TMimeChar): AnsiString;
begin
case Value of
CP895:
Result := 'CP-895';
UTF_7mod:
Result := 'mUTF-7';
else
Result := GetIconvIDFromCP(Value);
end;
end;
{==============================================================================}
function StringToWide(const Value: AnsiString): WideString;
var
n: integer;
x, y: integer;
begin
SetLength(Result, Length(Value) div 2);
for n := 1 to Length(Value) div 2 do
begin
x := Ord(Value[((n-1) * 2) + 1]);
y := Ord(Value[((n-1) * 2) + 2]);
Result[n] := WideChar(x * 256 + y);
end;
end;
{==============================================================================}
function WideToString(const Value: WideString): AnsiString;
var
n: integer;
x: integer;
begin
SetLength(Result, Length(Value) * 2);
for n := 1 to Length(Value) do
begin
x := Ord(Value[n]);
Result[((n-1) * 2) + 1] := AnsiChar(x div 256);
Result[((n-1) * 2) + 2] := AnsiChar(x mod 256);
end;
end;
{==============================================================================}
initialization
begin
IconvArr[0].Charset := ISO_8859_1;
IconvArr[0].Charname := 'ISO-8859-1 CP819 IBM819 ISO-IR-100 ISO8859-1 ISO_8859-1 ISO_8859-1:1987 L1 LATIN1 CSISOLATIN1';
IconvArr[1].Charset := UTF_8;
IconvArr[1].Charname := 'UTF-8';
IconvArr[2].Charset := UCS_2;
IconvArr[2].Charname := 'ISO-10646-UCS-2 UCS-2 CSUNICODE';
IconvArr[3].Charset := UCS_2;
IconvArr[3].Charname := 'UCS-2BE UNICODE-1-1 UNICODEBIG CSUNICODE11';
IconvArr[4].Charset := UCS_2LE;
IconvArr[4].Charname := 'UCS-2LE UNICODELITTLE';
IconvArr[5].Charset := UCS_4;
IconvArr[5].Charname := 'ISO-10646-UCS-4 UCS-4 CSUCS4';
IconvArr[6].Charset := UCS_4;
IconvArr[6].Charname := 'UCS-4BE';
IconvArr[7].Charset := UCS_2LE;
IconvArr[7].Charname := 'UCS-4LE';
IconvArr[8].Charset := UTF_16;
IconvArr[8].Charname := 'UTF-16';
IconvArr[9].Charset := UTF_16;
IconvArr[9].Charname := 'UTF-16BE';
IconvArr[10].Charset := UTF_16LE;
IconvArr[10].Charname := 'UTF-16LE';
IconvArr[11].Charset := UTF_32;
IconvArr[11].Charname := 'UTF-32';
IconvArr[12].Charset := UTF_32;
IconvArr[12].Charname := 'UTF-32BE';
IconvArr[13].Charset := UTF_32;
IconvArr[13].Charname := 'UTF-32LE';
IconvArr[14].Charset := UTF_7;
IconvArr[14].Charname := 'UNICODE-1-1-UTF-7 UTF-7 CSUNICODE11UTF7';
IconvArr[15].Charset := C99;
IconvArr[15].Charname := 'C99';
IconvArr[16].Charset := JAVA;
IconvArr[16].Charname := 'JAVA';
IconvArr[17].Charset := ISO_8859_1;
IconvArr[17].Charname := 'US-ASCII ANSI_X3.4-1968 ANSI_X3.4-1986 ASCII CP367 IBM367 ISO-IR-6 ISO646-US ISO_646.IRV:1991 US CSASCII';
IconvArr[18].Charset := ISO_8859_2;
IconvArr[18].Charname := 'ISO-8859-2 ISO-IR-101 ISO8859-2 ISO_8859-2 ISO_8859-2:1987 L2 LATIN2 CSISOLATIN2';
IconvArr[19].Charset := ISO_8859_3;
IconvArr[19].Charname := 'ISO-8859-3 ISO-IR-109 ISO8859-3 ISO_8859-3 ISO_8859-3:1988 L3 LATIN3 CSISOLATIN3';
IconvArr[20].Charset := ISO_8859_4;
IconvArr[20].Charname := 'ISO-8859-4 ISO-IR-110 ISO8859-4 ISO_8859-4 ISO_8859-4:1988 L4 LATIN4 CSISOLATIN4';
IconvArr[21].Charset := ISO_8859_5;
IconvArr[21].Charname := 'ISO-8859-5 CYRILLIC ISO-IR-144 ISO8859-5 ISO_8859-5 ISO_8859-5:1988 CSISOLATINCYRILLIC';
IconvArr[22].Charset := ISO_8859_6;
IconvArr[22].Charname := 'ISO-8859-6 ARABIC ASMO-708 ECMA-114 ISO-IR-127 ISO8859-6 ISO_8859-6 ISO_8859-6:1987 CSISOLATINARABIC';
IconvArr[23].Charset := ISO_8859_7;
IconvArr[23].Charname := 'ISO-8859-7 ECMA-118 ELOT_928 GREEK GREEK8 ISO-IR-126 ISO8859-7 ISO_8859-7 ISO_8859-7:1987 CSISOLATINGREEK';
IconvArr[24].Charset := ISO_8859_8;
IconvArr[24].Charname := 'ISO-8859-8 HEBREW ISO_8859-8 ISO-IR-138 ISO8859-8 ISO_8859-8:1988 CSISOLATINHEBREW ISO-8859-8-I';
IconvArr[25].Charset := ISO_8859_9;
IconvArr[25].Charname := 'ISO-8859-9 ISO-IR-148 ISO8859-9 ISO_8859-9 ISO_8859-9:1989 L5 LATIN5 CSISOLATIN5';
IconvArr[26].Charset := ISO_8859_10;
IconvArr[26].Charname := 'ISO-8859-10 ISO-IR-157 ISO8859-10 ISO_8859-10 ISO_8859-10:1992 L6 LATIN6 CSISOLATIN6';
IconvArr[27].Charset := ISO_8859_13;
IconvArr[27].Charname := 'ISO-8859-13 ISO-IR-179 ISO8859-13 ISO_8859-13 L7 LATIN7';
IconvArr[28].Charset := ISO_8859_14;
IconvArr[28].Charname := 'ISO-8859-14 ISO-CELTIC ISO-IR-199 ISO8859-14 ISO_8859-14 ISO_8859-14:1998 L8 LATIN8';
IconvArr[29].Charset := ISO_8859_15;
IconvArr[29].Charname := 'ISO-8859-15 ISO-IR-203 ISO8859-15 ISO_8859-15 ISO_8859-15:1998';
IconvArr[30].Charset := ISO_8859_16;
IconvArr[30].Charname := 'ISO-8859-16 ISO-IR-226 ISO8859-16 ISO_8859-16 ISO_8859-16:2000';
IconvArr[31].Charset := KOI8_R;
IconvArr[31].Charname := 'KOI8-R CSKOI8R';
IconvArr[32].Charset := KOI8_U;
IconvArr[32].Charname := 'KOI8-U';
IconvArr[33].Charset := KOI8_RU;
IconvArr[33].Charname := 'KOI8-RU';
IconvArr[34].Charset := CP1250;
IconvArr[34].Charname := 'WINDOWS-1250 CP1250 MS-EE';
IconvArr[35].Charset := CP1251;
IconvArr[35].Charname := 'WINDOWS-1251 CP1251 MS-CYRL';
IconvArr[36].Charset := CP1252;
IconvArr[36].Charname := 'WINDOWS-1252 CP1252 MS-ANSI';
IconvArr[37].Charset := CP1253;
IconvArr[37].Charname := 'WINDOWS-1253 CP1253 MS-GREEK';
IconvArr[38].Charset := CP1254;
IconvArr[38].Charname := 'WINDOWS-1254 CP1254 MS-TURK';
IconvArr[39].Charset := CP1255;
IconvArr[39].Charname := 'WINDOWS-1255 CP1255 MS-HEBR';
IconvArr[40].Charset := CP1256;
IconvArr[40].Charname := 'WINDOWS-1256 CP1256 MS-ARAB';
IconvArr[41].Charset := CP1257;
IconvArr[41].Charname := 'WINDOWS-1257 CP1257 WINBALTRIM';
IconvArr[42].Charset := CP1258;
IconvArr[42].Charname := 'WINDOWS-1258 CP1258';
IconvArr[43].Charset := ISO_8859_1;
IconvArr[43].Charname := '850 CP850 IBM850 CSPC850MULTILINGUAL';
IconvArr[44].Charset := CP862;
IconvArr[44].Charname := '862 CP862 IBM862 CSPC862LATINHEBREW';
IconvArr[45].Charset := CP866;
IconvArr[45].Charname := '866 CP866 IBM866 CSIBM866';
IconvArr[46].Charset := MAC;
IconvArr[46].Charname := 'MAC MACINTOSH MACROMAN CSMACINTOSH';
IconvArr[47].Charset := MACCE;
IconvArr[47].Charname := 'MACCENTRALEUROPE';
IconvArr[48].Charset := MACICE;
IconvArr[48].Charname := 'MACICELAND';
IconvArr[49].Charset := MACCRO;
IconvArr[49].Charname := 'MACCROATIAN';
IconvArr[50].Charset := MACRO;
IconvArr[50].Charname := 'MACROMANIA';
IconvArr[51].Charset := MACCYR;
IconvArr[51].Charname := 'MACCYRILLIC';
IconvArr[52].Charset := MACUK;
IconvArr[52].Charname := 'MACUKRAINE';
IconvArr[53].Charset := MACGR;
IconvArr[53].Charname := 'MACGREEK';
IconvArr[54].Charset := MACTU;
IconvArr[54].Charname := 'MACTURKISH';
IconvArr[55].Charset := MACHEB;
IconvArr[55].Charname := 'MACHEBREW';
IconvArr[56].Charset := MACAR;
IconvArr[56].Charname := 'MACARABIC';
IconvArr[57].Charset := MACTH;
IconvArr[57].Charname := 'MACTHAI';
IconvArr[58].Charset := ROMAN8;
IconvArr[58].Charname := 'HP-ROMAN8 R8 ROMAN8 CSHPROMAN8';
IconvArr[59].Charset := NEXTSTEP;
IconvArr[59].Charname := 'NEXTSTEP';
IconvArr[60].Charset := ARMASCII;
IconvArr[60].Charname := 'ARMSCII-8';
IconvArr[61].Charset := GEORGIAN_AC;
IconvArr[61].Charname := 'GEORGIAN-ACADEMY';
IconvArr[62].Charset := GEORGIAN_PS;
IconvArr[62].Charname := 'GEORGIAN-PS';
IconvArr[63].Charset := KOI8_T;
IconvArr[63].Charname := 'KOI8-T';
IconvArr[64].Charset := MULELAO;
IconvArr[64].Charname := 'MULELAO-1';
IconvArr[65].Charset := CP1133;
IconvArr[65].Charname := 'CP1133 IBM-CP1133';
IconvArr[66].Charset := TIS620;
IconvArr[66].Charname := 'TIS-620 ISO-IR-166 TIS620 TIS620-0 TIS620.2529-1 TIS620.2533-0 TIS620.2533-1';
IconvArr[67].Charset := CP874;
IconvArr[67].Charname := 'CP874 WINDOWS-874';
IconvArr[68].Charset := VISCII;
IconvArr[68].Charname := 'VISCII VISCII1.1-1 CSVISCII';
IconvArr[69].Charset := TCVN;
IconvArr[69].Charname := 'TCVN TCVN-5712 TCVN5712-1 TCVN5712-1:1993';
IconvArr[70].Charset := ISO_IR_14;
IconvArr[70].Charname := 'ISO-IR-14 ISO646-JP JIS_C6220-1969-RO JP CSISO14JISC6220RO';
IconvArr[71].Charset := JIS_X0201;
IconvArr[71].Charname := 'JISX0201-1976 JIS_X0201 X0201 CSHALFWIDTHKATAKANA';
IconvArr[72].Charset := JIS_X0208;
IconvArr[72].Charname := 'ISO-IR-87 JIS0208 JIS_C6226-1983 JIS_X0208 JIS_X0208-1983 JIS_X0208-1990 X0208 CSISO87JISX0208';
IconvArr[73].Charset := JIS_X0212;
IconvArr[73].Charname := 'ISO-IR-159 JIS_X0212 JIS_X0212-1990 JIS_X0212.1990-0 X0212 CSISO159JISX02121990';
IconvArr[74].Charset := GB1988_80;
IconvArr[74].Charname := 'CN GB_1988-80 ISO-IR-57 ISO646-CN CSISO57GB1988';
IconvArr[75].Charset := GB2312_80;
IconvArr[75].Charname := 'CHINESE GB_2312-80 ISO-IR-58 CSISO58GB231280';
IconvArr[76].Charset := ISO_IR_165;
IconvArr[76].Charname := 'CN-GB-ISOIR165 ISO-IR-165';
IconvArr[77].Charset := ISO_IR_149;
IconvArr[77].Charname := 'ISO-IR-149 KOREAN KSC_5601 KS_C_5601-1987 KS_C_5601-1989 CSKSC56011987';
IconvArr[78].Charset := EUC_JP;
IconvArr[78].Charname := 'EUC-JP EUCJP EXTENDED_UNIX_CODE_PACKED_FORMAT_FOR_JAPANESE CSEUCPKDFMTJAPANESE';
IconvArr[79].Charset := SHIFT_JIS;
IconvArr[79].Charname := 'SHIFT-JIS MS_KANJI SHIFT_JIS SJIS CSSHIFTJIS';
IconvArr[80].Charset := CP932;
IconvArr[80].Charname := 'CP932';
IconvArr[81].Charset := ISO_2022_JP;
IconvArr[81].Charname := 'ISO-2022-JP CSISO2022JP';
IconvArr[82].Charset := ISO_2022_JP1;
IconvArr[82].Charname := 'ISO-2022-JP-1';
IconvArr[83].Charset := ISO_2022_JP2;
IconvArr[83].Charname := 'ISO-2022-JP-2 CSISO2022JP2';
IconvArr[84].Charset := GB2312;
IconvArr[84].Charname := 'CN-GB EUC-CN EUCCN GB2312 CSGB2312';
IconvArr[85].Charset := CP936;
IconvArr[85].Charname := 'CP936 GBK';
IconvArr[86].Charset := GB18030;
IconvArr[86].Charname := 'GB18030';
IconvArr[87].Charset := ISO_2022_CN;
IconvArr[87].Charname := 'ISO-2022-CN CSISO2022CN';
IconvArr[88].Charset := ISO_2022_CNE;
IconvArr[88].Charname := 'ISO-2022-CN-EXT';
IconvArr[89].Charset := HZ;
IconvArr[89].Charname := 'HZ HZ-GB-2312';
IconvArr[90].Charset := EUC_TW;
IconvArr[90].Charname := 'EUC-TW EUCTW CSEUCTW';
IconvArr[91].Charset := BIG5;
IconvArr[91].Charname := 'BIG5 BIG-5 BIG-FIVE BIGFIVE CN-BIG5 CSBIG5';
IconvArr[92].Charset := CP950;
IconvArr[92].Charname := 'CP950';
IconvArr[93].Charset := BIG5_HKSCS;
IconvArr[93].Charname := 'BIG5-HKSCS BIG5HKSCS';
IconvArr[94].Charset := EUC_KR;
IconvArr[94].Charname := 'EUC-KR EUCKR CSEUCKR';
IconvArr[95].Charset := CP949;
IconvArr[95].Charname := 'CP949 UHC';
IconvArr[96].Charset := CP1361;
IconvArr[96].Charname := 'CP1361 JOHAB';
IconvArr[97].Charset := ISO_2022_KR;
IconvArr[97].Charname := 'ISO-2022-KR CSISO2022KR';
IconvArr[98].Charset := ISO_8859_1;
IconvArr[98].Charname := '437 CP437 IBM437 CSPC8CODEPAGE437';
IconvArr[99].Charset := CP737;
IconvArr[99].Charname := 'CP737';
IconvArr[100].Charset := CP775;
IconvArr[100].Charname := 'CP775 IBM775 CSPC775BALTIC';
IconvArr[101].Charset := CP852;
IconvArr[101].Charname := '852 CP852 IBM852 CSPCP852';
IconvArr[102].Charset := CP853;
IconvArr[102].Charname := 'CP853';
IconvArr[103].Charset := CP855;
IconvArr[103].Charname := '855 CP855 IBM855 CSIBM855';
IconvArr[104].Charset := CP857;
IconvArr[104].Charname := '857 CP857 IBM857 CSIBM857';
IconvArr[105].Charset := CP858;
IconvArr[105].Charname := 'CP858';
IconvArr[106].Charset := CP860;
IconvArr[106].Charname := '860 CP860 IBM860 CSIBM860';
IconvArr[107].Charset := CP861;
IconvArr[107].Charname := '861 CP-IS CP861 IBM861 CSIBM861';
IconvArr[108].Charset := CP863;
IconvArr[108].Charname := '863 CP863 IBM863 CSIBM863';
IconvArr[109].Charset := CP864;
IconvArr[109].Charname := 'CP864 IBM864 CSIBM864';
IconvArr[110].Charset := CP865;
IconvArr[110].Charname := '865 CP865 IBM865 CSIBM865';
IconvArr[111].Charset := CP869;
IconvArr[111].Charname := '869 CP-GR CP869 IBM869 CSIBM869';
IconvArr[112].Charset := CP1125;
IconvArr[112].Charname := 'CP1125';
end;
end.
TransGUI/synapse/source/lib/mimeinln.pas 0000644 0000000 0000000 00000021674 11366572451 017301 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.001.011 |
|==============================================================================|
| Content: Inline MIME support procedures and functions |
|==============================================================================|
| Copyright (c)1999-2006, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2006. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(Utilities for inline MIME)
Support for Inline MIME encoding and decoding.
Used RFC: RFC-2047, RFC-2231
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit mimeinln;
interface
uses
SysUtils, Classes,
synachar, synacode, synautil;
{:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".}
function InlineDecode(const Value: string; CP: TMimeChar): string;
{:Encodes string to MIME inline encoding. The source characterset is "CP", and
the target charset is "MimeP".}
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
{:Returns @true, if "Value" contains characters needed for inline coding.}
function NeedInline(const Value: AnsiString): boolean;
{:Inline mime encoding similar to @link(InlineEncode), but you can specify
source charset, and the target characterset is automatically assigned.}
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
{:Inline MIME encoding similar to @link(InlineEncode), but the source charset
is automatically set to the system default charset, and the target charset is
automatically assigned from set of allowed encoding for MIME.}
function InlineCode(const Value: string): string;
{:Converts e-mail address to canonical mime form. You can specify source charset.}
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
{:Converts e-mail address to canonical mime form. Source charser it system
default charset.}
function InlineEmail(const Value: string): string;
implementation
{==============================================================================}
function InlineDecode(const Value: string; CP: TMimeChar): string;
var
s, su, v: string;
x, y, z, n: Integer;
ichar: TMimeChar;
c: Char;
function SearchEndInline(const Value: string; be: Integer): Integer;
var
n, q: Integer;
begin
q := 0;
Result := 0;
for n := be + 2 to Length(Value) - 1 do
if Value[n] = '?' then
begin
Inc(q);
if (q > 2) and (Value[n + 1] = '=') then
begin
Result := n;
Break;
end;
end;
end;
begin
Result := '';
v := Value;
x := Pos('=?', v);
y := SearchEndInline(v, x);
//fix for broken coding with begin, but not with end.
if (x > 0) and (y <= 0) then
y := Length(Result);
while (y > x) and (x > 0) do
begin
s := Copy(v, 1, x - 1);
if Trim(s) <> '' then
Result := Result + s;
s := Copy(v, x, y - x + 2);
Delete(v, 1, y + 1);
su := Copy(s, 3, Length(s) - 4);
z := Pos('?', su);
if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then
begin
ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*'));
c := UpperCase(su)[z + 1];
su := Copy(su, z + 3, Length(su) - z - 2);
if c = 'B' then
begin
s := DecodeBase64(su);
s := CharsetConversion(s, ichar, CP);
end;
if c = 'Q' then
begin
s := '';
for n := 1 to Length(su) do
if su[n] = '_' then
s := s + ' '
else
s := s + su[n];
s := DecodeQuotedPrintable(s);
s := CharsetConversion(s, ichar, CP);
end;
end;
Result := Result + s;
x := Pos('=?', v);
y := SearchEndInline(v, x);
end;
Result := Result + v;
end;
{==============================================================================}
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
var
s, s1, e: string;
n: Integer;
begin
s := CharsetConversion(Value, CP, MimeP);
s := EncodeSafeQuotedPrintable(s);
e := GetIdFromCP(MimeP);
s1 := '';
Result := '';
for n := 1 to Length(s) do
if s[n] = ' ' then
begin
// s1 := s1 + '=20';
s1 := s1 + '_';
if Length(s1) > 32 then
begin
if Result <> '' then
Result := Result + ' ';
Result := Result + '=?' + e + '?Q?' + s1 + '?=';
s1 := '';
end;
end
else
s1 := s1 + s[n];
if s1 <> '' then
begin
if Result <> '' then
Result := Result + ' ';
Result := Result + '=?' + e + '?Q?' + s1 + '?=';
end;
end;
{==============================================================================}
function NeedInline(const Value: AnsiString): boolean;
var
n: Integer;
begin
Result := False;
for n := 1 to Length(Value) do
if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then
begin
Result := True;
Break;
end;
end;
{==============================================================================}
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
var
c: TMimeChar;
begin
if NeedInline(Value) then
begin
c := IdealCharsetCoding(Value, FromCP, IdealCharsets);
Result := InlineEncode(Value, FromCP, c);
end
else
Result := Value;
end;
{==============================================================================}
function InlineCode(const Value: string): string;
begin
Result := InlineCodeEx(Value, GetCurCP);
end;
{==============================================================================}
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
var
sd, se: string;
begin
sd := GetEmailDesc(Value);
se := GetEmailAddr(Value);
if sd = '' then
Result := se
else
Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>';
end;
{==============================================================================}
function InlineEmail(const Value: string): string;
begin
Result := InlineEmailEx(Value, GetCurCP);
end;
end.
TransGUI/synapse/source/lib/synacode.pas 0000644 0000000 0000000 00000142632 11366572451 017274 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 002.002.001 |
|==============================================================================|
| Content: Coding and decoding support |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(Various encoding and decoding support)}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$R-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$WARN SUSPICIOUS_TYPECAST OFF}
{$ENDIF}
unit synacode;
interface
uses
SysUtils;
type
TSpecials = set of AnsiChar;
const
SpecialChar: TSpecials =
['=', '(', ')', '[', ']', '<', '>', ':', ';', ',', '@', '/', '?', '\',
'"', '_'];
NonAsciiChar: TSpecials =
[#0..#31, #127..#255];
URLFullSpecialChar: TSpecials =
[';', '/', '?', ':', '@', '=', '&', '#', '+'];
URLSpecialChar: TSpecials =
[#$00..#$20, '_', '<', '>', '"', '%', '{', '}', '|', '\', '^', '~', '[', ']',
'`', #$7F..#$FF];
TableBase64 =
'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=';
TableBase64mod =
'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+,=';
TableUU =
'`!"#$%&''()*+,-./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;
{:Decodes triplet encoding with a given character delimiter. It is used for
decoding quoted-printable or URL encoding.}
function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString;
{:Decodes a string from quoted printable form. (also decodes triplet sequences
like '=7F')}
function DecodeQuotedPrintable(const Value: AnsiString): AnsiString;
{:Decodes a string of URL encoding. (also decodes triplet sequences like '%7F')}
function DecodeURL(const Value: AnsiString): AnsiString;
{:Performs triplet encoding with a given character delimiter. Used for encoding
quoted-printable or URL encoding.}
function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar;
Specials: TSpecials): AnsiString;
{:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar)
are encoded.}
function EncodeQuotedPrintable(const Value: AnsiString): AnsiString;
{:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar) and
@link(SpecialChar) are encoded.}
function EncodeSafeQuotedPrintable(const Value: AnsiString): AnsiString;
{:Encodes a string to URL format. Used for encoding data from a form field in
HTTP, etc. (Encodes all critical characters including characters used as URL
delimiters ('/',':', etc.)}
function EncodeURLElement(const Value: AnsiString): AnsiString;
{:Encodes a string to URL format. Used to encode critical characters in all
URLs.}
function EncodeURL(const Value: AnsiString): AnsiString;
{:Decode 4to3 encoding with given table. If some element is not found in table,
first item from table is used. This is good for buggy coded items by Microsoft
Outlook. This software sometimes using wrong table for UUcode, where is used
' ' instead '`'.}
function Decode4to3(const Value, Table: AnsiString): AnsiString;
{:Decode 4to3 encoding with given REVERSE table. Using this function with
reverse table is much faster then @link(Decode4to3). This function is used
internally for Base64, UU or XX decoding.}
function Decode4to3Ex(const Value, Table: AnsiString): AnsiString;
{:Encode by system 3to4 (used by Base64, UU coding, etc) by given table.}
function Encode3to4(const Value, Table: AnsiString): AnsiString;
{:Decode string from base64 format.}
function DecodeBase64(const Value: AnsiString): AnsiString;
{:Encodes a string to base64 format.}
function EncodeBase64(const Value: AnsiString): AnsiString;
{:Decode string from modified base64 format. (used in IMAP, for example.)}
function DecodeBase64mod(const Value: AnsiString): AnsiString;
{:Encodes a string to modified base64 format. (used in IMAP, for example.)}
function EncodeBase64mod(const Value: AnsiString): AnsiString;
{:Decodes a string from UUcode format.}
function DecodeUU(const Value: AnsiString): AnsiString;
{:encode UUcode. it encode only datas, you must also add header and footer for
proper encode.}
function EncodeUU(const Value: AnsiString): AnsiString;
{:Decodes a string from XXcode format.}
function DecodeXX(const Value: AnsiString): AnsiString;
{:decode line with Yenc code. This code is sometimes used in newsgroups.}
function DecodeYEnc(const Value: AnsiString): AnsiString;
{:Returns a new CRC32 value after adding a new byte of data.}
function UpdateCrc32(Value: Byte; Crc32: Integer): Integer;
{:return CRC32 from a value string.}
function Crc32(const Value: AnsiString): Integer;
{:Returns a new CRC16 value after adding a new byte of data.}
function UpdateCrc16(Value: Byte; Crc16: Word): Word;
{:return CRC16 from a value string.}
function Crc16(const Value: AnsiString): Word;
{:Returns a binary string with a RSA-MD5 hashing of "Value" string.}
function MD5(const Value: AnsiString): AnsiString;
{:Returns a binary string with HMAC-MD5 hash.}
function HMAC_MD5(Text, Key: AnsiString): AnsiString;
{:Returns a binary string with a RSA-MD5 hashing of string what is constructed
by repeating "value" until length is "Len".}
function MD5LongHash(const Value: AnsiString; Len: integer): AnsiString;
{:Returns a binary string with a SHA-1 hashing of "Value" string.}
function SHA1(const Value: AnsiString): AnsiString;
{:Returns a binary string with HMAC-SHA1 hash.}
function HMAC_SHA1(Text, Key: AnsiString): AnsiString;
{:Returns a binary string with a SHA-1 hashing of string what is constructed
by repeating "value" until length is "Len".}
function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString;
{:Returns a binary string with a RSA-MD4 hashing of "Value" string.}
function MD4(const Value: AnsiString): AnsiString;
implementation
const
Crc32Tab: array[0..255] of Integer = (
Integer($00000000), Integer($77073096), Integer($EE0E612C), Integer($990951BA),
Integer($076DC419), Integer($706AF48F), Integer($E963A535), Integer($9E6495A3),
Integer($0EDB8832), Integer($79DCB8A4), Integer($E0D5E91E), Integer($97D2D988),
Integer($09B64C2B), Integer($7EB17CBD), Integer($E7B82D07), Integer($90BF1D91),
Integer($1DB71064), Integer($6AB020F2), Integer($F3B97148), Integer($84BE41DE),
Integer($1ADAD47D), Integer($6DDDE4EB), Integer($F4D4B551), Integer($83D385C7),
Integer($136C9856), Integer($646BA8C0), Integer($FD62F97A), Integer($8A65C9EC),
Integer($14015C4F), Integer($63066CD9), Integer($FA0F3D63), Integer($8D080DF5),
Integer($3B6E20C8), Integer($4C69105E), Integer($D56041E4), Integer($A2677172),
Integer($3C03E4D1), Integer($4B04D447), Integer($D20D85FD), Integer($A50AB56B),
Integer($35B5A8FA), Integer($42B2986C), Integer($DBBBC9D6), Integer($ACBCF940),
Integer($32D86CE3), Integer($45DF5C75), Integer($DCD60DCF), Integer($ABD13D59),
Integer($26D930AC), Integer($51DE003A), Integer($C8D75180), Integer($BFD06116),
Integer($21B4F4B5), Integer($56B3C423), Integer($CFBA9599), Integer($B8BDA50F),
Integer($2802B89E), Integer($5F058808), Integer($C60CD9B2), Integer($B10BE924),
Integer($2F6F7C87), Integer($58684C11), Integer($C1611DAB), Integer($B6662D3D),
Integer($76DC4190), Integer($01DB7106), Integer($98D220BC), Integer($EFD5102A),
Integer($71B18589), Integer($06B6B51F), Integer($9FBFE4A5), Integer($E8B8D433),
Integer($7807C9A2), Integer($0F00F934), Integer($9609A88E), Integer($E10E9818),
Integer($7F6A0DBB), Integer($086D3D2D), Integer($91646C97), Integer($E6635C01),
Integer($6B6B51F4), Integer($1C6C6162), Integer($856530D8), Integer($F262004E),
Integer($6C0695ED), Integer($1B01A57B), Integer($8208F4C1), Integer($F50FC457),
Integer($65B0D9C6), Integer($12B7E950), Integer($8BBEB8EA), Integer($FCB9887C),
Integer($62DD1DDF), Integer($15DA2D49), Integer($8CD37CF3), Integer($FBD44C65),
Integer($4DB26158), Integer($3AB551CE), Integer($A3BC0074), Integer($D4BB30E2),
Integer($4ADFA541), Integer($3DD895D7), Integer($A4D1C46D), Integer($D3D6F4FB),
Integer($4369E96A), Integer($346ED9FC), Integer($AD678846), Integer($DA60B8D0),
Integer($44042D73), Integer($33031DE5), Integer($AA0A4C5F), Integer($DD0D7CC9),
Integer($5005713C), Integer($270241AA), Integer($BE0B1010), Integer($C90C2086),
Integer($5768B525), Integer($206F85B3), Integer($B966D409), Integer($CE61E49F),
Integer($5EDEF90E), Integer($29D9C998), Integer($B0D09822), Integer($C7D7A8B4),
Integer($59B33D17), Integer($2EB40D81), Integer($B7BD5C3B), Integer($C0BA6CAD),
Integer($EDB88320), Integer($9ABFB3B6), Integer($03B6E20C), Integer($74B1D29A),
Integer($EAD54739), Integer($9DD277AF), Integer($04DB2615), Integer($73DC1683),
Integer($E3630B12), Integer($94643B84), Integer($0D6D6A3E), Integer($7A6A5AA8),
Integer($E40ECF0B), Integer($9309FF9D), Integer($0A00AE27), Integer($7D079EB1),
Integer($F00F9344), Integer($8708A3D2), Integer($1E01F268), Integer($6906C2FE),
Integer($F762575D), Integer($806567CB), Integer($196C3671), Integer($6E6B06E7),
Integer($FED41B76), Integer($89D32BE0), Integer($10DA7A5A), Integer($67DD4ACC),
Integer($F9B9DF6F), Integer($8EBEEFF9), Integer($17B7BE43), Integer($60B08ED5),
Integer($D6D6A3E8), Integer($A1D1937E), Integer($38D8C2C4), Integer($4FDFF252),
Integer($D1BB67F1), Integer($A6BC5767), Integer($3FB506DD), Integer($48B2364B),
Integer($D80D2BDA), Integer($AF0A1B4C), Integer($36034AF6), Integer($41047A60),
Integer($DF60EFC3), Integer($A867DF55), Integer($316E8EEF), Integer($4669BE79),
Integer($CB61B38C), Integer($BC66831A), Integer($256FD2A0), Integer($5268E236),
Integer($CC0C7795), Integer($BB0B4703), Integer($220216B9), Integer($5505262F),
Integer($C5BA3BBE), Integer($B2BD0B28), Integer($2BB45A92), Integer($5CB36A04),
Integer($C2D7FFA7), Integer($B5D0CF31), Integer($2CD99E8B), Integer($5BDEAE1D),
Integer($9B64C2B0), Integer($EC63F226), Integer($756AA39C), Integer($026D930A),
Integer($9C0906A9), Integer($EB0E363F), Integer($72076785), Integer($05005713),
Integer($95BF4A82), Integer($E2B87A14), Integer($7BB12BAE), Integer($0CB61B38),
Integer($92D28E9B), Integer($E5D5BE0D), Integer($7CDCEFB7), Integer($0BDBDF21),
Integer($86D3D2D4), Integer($F1D4E242), Integer($68DDB3F8), Integer($1FDA836E),
Integer($81BE16CD), Integer($F6B9265B), Integer($6FB077E1), Integer($18B74777),
Integer($88085AE6), Integer($FF0F6A70), Integer($66063BCA), Integer($11010B5C),
Integer($8F659EFF), Integer($F862AE69), Integer($616BFFD3), Integer($166CCF45),
Integer($A00AE278), Integer($D70DD2EE), Integer($4E048354), Integer($3903B3C2),
Integer($A7672661), Integer($D06016F7), Integer($4969474D), Integer($3E6E77DB),
Integer($AED16A4A), Integer($D9D65ADC), Integer($40DF0B66), Integer($37D83BF0),
Integer($A9BCAE53), Integer($DEBB9EC5), Integer($47B2CF7F), Integer($30B5FFE9),
Integer($BDBDF21C), Integer($CABAC28A), Integer($53B39330), Integer($24B4A3A6),
Integer($BAD03605), Integer($CDD70693), Integer($54DE5729), Integer($23D967BF),
Integer($B3667A2E), Integer($C4614AB8), Integer($5D681B02), Integer($2A6F2B94),
Integer($B40BBE37), Integer($C30C8EA1), Integer($5A05DF1B), Integer($2D02EF8D)
);
Crc16Tab: array[0..255] of Word = (
$0000, $1189, $2312, $329B, $4624, $57AD, $6536, $74BF,
$8C48, $9DC1, $AF5A, $BED3, $CA6C, $DBE5, $E97E, $F8F7,
$1081, $0108, $3393, $221A, $56A5, $472C, $75B7, $643E,
$9CC9, $8D40, $BFDB, $AE52, $DAED, $CB64, $F9FF, $E876,
$2102, $308B, $0210, $1399, $6726, $76AF, $4434, $55BD,
$AD4A, $BCC3, $8E58, $9FD1, $EB6E, $FAE7, $C87C, $D9F5,
$3183, $200A, $1291, $0318, $77A7, $662E, $54B5, $453C,
$BDCB, $AC42, $9ED9, $8F50, $FBEF, $EA66, $D8FD, $C974,
$4204, $538D, $6116, $709F, $0420, $15A9, $2732, $36BB,
$CE4C, $DFC5, $ED5E, $FCD7, $8868, $99E1, $AB7A, $BAF3,
$5285, $430C, $7197, $601E, $14A1, $0528, $37B3, $263A,
$DECD, $CF44, $FDDF, $EC56, $98E9, $8960, $BBFB, $AA72,
$6306, $728F, $4014, $519D, $2522, $34AB, $0630, $17B9,
$EF4E, $FEC7, $CC5C, $DDD5, $A96A, $B8E3, $8A78, $9BF1,
$7387, $620E, $5095, $411C, $35A3, $242A, $16B1, $0738,
$FFCF, $EE46, $DCDD, $CD54, $B9EB, $A862, $9AF9, $8B70,
$8408, $9581, $A71A, $B693, $C22C, $D3A5, $E13E, $F0B7,
$0840, $19C9, $2B52, $3ADB, $4E64, $5FED, $6D76, $7CFF,
$9489, $8500, $B79B, $A612, $D2AD, $C324, $F1BF, $E036,
$18C1, $0948, $3BD3, $2A5A, $5EE5, $4F6C, $7DF7, $6C7E,
$A50A, $B483, $8618, $9791, $E32E, $F2A7, $C03C, $D1B5,
$2942, $38CB, $0A50, $1BD9, $6F66, $7EEF, $4C74, $5DFD,
$B58B, $A402, $9699, $8710, $F3AF, $E226, $D0BD, $C134,
$39C3, $284A, $1AD1, $0B58, $7FE7, $6E6E, $5CF5, $4D7C,
$C60C, $D785, $E51E, $F497, $8028, $91A1, $A33A, $B2B3,
$4A44, $5BCD, $6956, $78DF, $0C60, $1DE9, $2F72, $3EFB,
$D68D, $C704, $F59F, $E416, $90A9, $8120, $B3BB, $A232,
$5AC5, $4B4C, $79D7, $685E, $1CE1, $0D68, $3FF3, $2E7A,
$E70E, $F687, $C41C, $D595, $A12A, $B0A3, $8238, $93B1,
$6B46, $7ACF, $4854, $59DD, $2D62, $3CEB, $0E70, $1FF9,
$F78F, $E606, $D49D, $C514, $B1AB, $A022, $92B9, $8330,
$7BC7, $6A4E, $58D5, $495C, $3DE3, $2C6A, $1EF1, $0F78
);
procedure ArrByteToLong(var ArByte: Array of byte; var ArLong: Array of Integer);
{$IFDEF CIL}
var
n: integer;
{$ENDIF}
begin
if (High(ArByte) + 1) > ((High(ArLong) + 1) * 4) then
Exit;
{$IFDEF CIL}
for n := 0 to ((high(ArByte) + 1) div 4) - 1 do
ArLong[n] := ArByte[n * 4 + 0]
+ (ArByte[n * 4 + 1] shl 8)
+ (ArByte[n * 4 + 2] shl 16)
+ (ArByte[n * 4 + 3] shl 24);
{$ELSE}
Move(ArByte[0], ArLong[0], High(ArByte) + 1);
{$ENDIF}
end;
procedure ArrLongToByte(var ArLong: Array of Integer; var ArByte: Array of byte);
{$IFDEF CIL}
var
n: integer;
{$ENDIF}
begin
if (High(ArByte) + 1) < ((High(ArLong) + 1) * 4) then
Exit;
{$IFDEF CIL}
for n := 0 to high(ArLong) do
begin
ArByte[n * 4 + 0] := ArLong[n] and $000000FF;
ArByte[n * 4 + 1] := (ArLong[n] shr 8) and $000000FF;
ArByte[n * 4 + 2] := (ArLong[n] shr 16) and $000000FF;
ArByte[n * 4 + 3] := (ArLong[n] shr 24) and $000000FF;
end;
{$ELSE}
Move(ArLong[0], ArByte[0], High(ArByte) + 1);
{$ENDIF}
end;
type
TMDCtx = record
State: array[0..3] of Integer;
Count: array[0..1] of Integer;
BufAnsiChar: array[0..63] of Byte;
BufLong: array[0..15] of Integer;
end;
TSHA1Ctx= record
Hi, Lo: integer;
Buffer: array[0..63] of byte;
Index: integer;
Hash: array[0..4] of Integer;
HashByte: array[0..19] of byte;
end;
TMDTransform = procedure(var Buf: array of LongInt; const Data: array of LongInt);
{==============================================================================}
function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString;
var
x, l, lv: Integer;
c: AnsiChar;
b: Byte;
bad: Boolean;
begin
lv := Length(Value);
SetLength(Result, lv);
x := 1;
l := 1;
while x <= lv do
begin
c := Value[x];
Inc(x);
if c <> Delimiter then
begin
Result[l] := c;
Inc(l);
end
else
if x < lv then
begin
Case Value[x] Of
#13:
if (Value[x + 1] = #10) then
Inc(x, 2)
else
Inc(x);
#10:
if (Value[x + 1] = #13) then
Inc(x, 2)
else
Inc(x);
else
begin
bad := False;
Case Value[x] Of
'0'..'9': b := (Byte(Value[x]) - 48) Shl 4;
'a'..'f', 'A'..'F': b := ((Byte(Value[x]) And 7) + 9) shl 4;
else
begin
b := 0;
bad := True;
end;
end;
Case Value[x + 1] Of
'0'..'9': b := b Or (Byte(Value[x + 1]) - 48);
'a'..'f', 'A'..'F': b := b Or ((Byte(Value[x + 1]) And 7) + 9);
else
bad := True;
end;
if bad then
begin
Result[l] := c;
Inc(l);
end
else
begin
Inc(x, 2);
Result[l] := AnsiChar(b);
Inc(l);
end;
end;
end;
end
else
break;
end;
Dec(l);
SetLength(Result, l);
end;
{==============================================================================}
function DecodeQuotedPrintable(const Value: AnsiString): AnsiString;
begin
Result := DecodeTriplet(Value, '=');
end;
{==============================================================================}
function DecodeURL(const Value: AnsiString): AnsiString;
begin
Result := DecodeTriplet(Value, '%');
end;
{==============================================================================}
function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar;
Specials: TSpecials): AnsiString;
var
n, l: Integer;
s: AnsiString;
c: AnsiChar;
begin
SetLength(Result, Length(Value) * 3);
l := 1;
for n := 1 to Length(Value) do
begin
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;
{==============================================================================}
function EncodeQuotedPrintable(const Value: AnsiString): AnsiString;
begin
Result := EncodeTriplet(Value, '=', ['='] + NonAsciiChar);
end;
{==============================================================================}
function EncodeSafeQuotedPrintable(const Value: AnsiString): AnsiString;
begin
Result := EncodeTriplet(Value, '=', SpecialChar + NonAsciiChar);
end;
{==============================================================================}
function EncodeURLElement(const Value: AnsiString): AnsiString;
begin
Result := EncodeTriplet(Value, '%', URLSpecialChar + URLFullSpecialChar);
end;
{==============================================================================}
function EncodeURL(const Value: AnsiString): AnsiString;
begin
Result := EncodeTriplet(Value, '%', URLSpecialChar);
end;
{==============================================================================}
function Decode4to3(const Value, Table: AnsiString): AnsiString;
var
x, y, n, l: Integer;
d: array[0..3] of Byte;
begin
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 := Pos(Value[x], Table);
if y < 1 then
y := 1;
d[n] := y - 1;
end;
Inc(x);
end;
Result[l] := AnsiChar((D[0] and $3F) shl 2 + (D[1] and $30) shr 4);
Inc(l);
if d[2] <> 64 then
begin
Result[l] := AnsiChar((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2);
Inc(l);
if d[3] <> 64 then
begin
Result[l] := AnsiChar((D[2] and $03) shl 6 + (D[3] and $3F));
Inc(l);
end;
end;
end;
Dec(l);
SetLength(Result, l);
end;
{==============================================================================}
function Decode4to3Ex(const Value, Table: AnsiString): AnsiString;
var
x, y, lv: Integer;
d: integer;
dl: integer;
c: byte;
p: integer;
begin
lv := Length(Value);
SetLength(Result, lv);
x := 1;
dl := 4;
d := 0;
p := 1;
while x <= lv do
begin
y := Ord(Value[x]);
if y in [33..127] then
c := Ord(Table[y - 32])
else
c := 64;
Inc(x);
if c > 63 then
continue;
d := (d shl 6) or c;
dec(dl);
if dl <> 0 then
continue;
Result[p] := AnsiChar((d shr 16) and $ff);
inc(p);
Result[p] := AnsiChar((d shr 8) and $ff);
inc(p);
Result[p] := AnsiChar(d and $ff);
inc(p);
d := 0;
dl := 4;
end;
case dl of
1:
begin
d := d shr 2;
Result[p] := AnsiChar((d shr 8) and $ff);
inc(p);
Result[p] := AnsiChar(d and $ff);
inc(p);
end;
2:
begin
d := d shr 4;
Result[p] := AnsiChar(d and $ff);
inc(p);
end;
end;
SetLength(Result, p - 1);
end;
{==============================================================================}
function Encode3to4(const Value, Table: AnsiString): AnsiString;
var
c: Byte;
n, l: Integer;
Count: Integer;
DOut: array[0..3] of Byte;
begin
setlength(Result, ((Length(Value) + 2) div 3) * 4);
l := 1;
Count := 1;
while Count <= Length(Value) do
begin
c := Ord(Value[Count]);
Inc(Count);
DOut[0] := (c and $FC) shr 2;
DOut[1] := (c and $03) shl 4;
if Count <= Length(Value) then
begin
c := Ord(Value[Count]);
Inc(Count);
DOut[1] := DOut[1] + (c and $F0) shr 4;
DOut[2] := (c and $0F) shl 2;
if Count <= Length(Value) then
begin
c := Ord(Value[Count]);
Inc(Count);
DOut[2] := DOut[2] + (c and $C0) shr 6;
DOut[3] := (c and $3F);
end
else
begin
DOut[3] := $40;
end;
end
else
begin
DOut[2] := $40;
DOut[3] := $40;
end;
for n := 0 to 3 do
begin
if (DOut[n] + 1) <= Length(Table) then
begin
Result[l] := Table[DOut[n] + 1];
Inc(l);
end;
end;
end;
SetLength(Result, l - 1);
end;
{==============================================================================}
function DecodeBase64(const Value: AnsiString): AnsiString;
begin
Result := Decode4to3Ex(Value, ReTableBase64);
end;
{==============================================================================}
function EncodeBase64(const Value: AnsiString): AnsiString;
begin
Result := Encode3to4(Value, TableBase64);
end;
{==============================================================================}
function DecodeBase64mod(const Value: AnsiString): AnsiString;
begin
Result := Decode4to3(Value, TableBase64mod);
end;
{==============================================================================}
function EncodeBase64mod(const Value: AnsiString): AnsiString;
begin
Result := Encode3to4(Value, TableBase64mod);
end;
{==============================================================================}
function DecodeUU(const Value: AnsiString): AnsiString;
var
s: AnsiString;
uut: AnsiString;
x: Integer;
begin
Result := '';
uut := TableUU;
s := trim(UpperCase(Value));
if s = '' then Exit;
if Pos('BEGIN', s) = 1 then
Exit;
if Pos('END', s) = 1 then
Exit;
if Pos('TABLE', s) = 1 then
Exit; //ignore Table yet (set custom UUT)
//begin decoding
x := Pos(Value[1], uut) - 1;
case (x mod 3) of
0: x :=(x div 3)* 4;
1: x :=((x div 3) * 4) + 2;
2: x :=((x div 3) * 4) + 3;
end;
//x - lenght UU line
s := Copy(Value, 2, x);
if s = '' then
Exit;
s := s + StringOfChar(' ', x - length(s));
Result := Decode4to3(s, uut);
end;
{==============================================================================}
function EncodeUU(const Value: AnsiString): AnsiString;
begin
Result := '';
if Length(Value) < Length(TableUU) then
Result := TableUU[Length(Value) + 1] + Encode3to4(Value, TableUU);
end;
{==============================================================================}
function DecodeXX(const Value: AnsiString): AnsiString;
var
s: AnsiString;
x: Integer;
begin
Result := '';
s := trim(UpperCase(Value));
if s = '' then
Exit;
if Pos('BEGIN', s) = 1 then
Exit;
if Pos('END', s) = 1 then
Exit;
//begin decoding
x := Pos(Value[1], TableXX) - 1;
case (x mod 3) of
0: x :=(x div 3)* 4;
1: x :=((x div 3) * 4) + 2;
2: x :=((x div 3) * 4) + 3;
end;
//x - lenght XX line
s := Copy(Value, 2, x);
if s = '' then
Exit;
s := s + StringOfChar(' ', x - length(s));
Result := Decode4to3(s, TableXX);
end;
{==============================================================================}
function DecodeYEnc(const Value: AnsiString): AnsiString;
var
C : Byte;
i: integer;
begin
Result := '';
i := 1;
while i <= Length(Value) do
begin
c := Ord(Value[i]);
Inc(i);
if c = Ord('=') then
begin
c := Ord(Value[i]);
Inc(i);
Dec(c, 64);
end;
Dec(C, 42);
Result := Result + AnsiChar(C);
end;
end;
{==============================================================================}
function UpdateCrc32(Value: Byte; Crc32: Integer): Integer;
begin
Result := (Crc32 shr 8)
xor crc32tab[Byte(Value xor (Crc32 and Integer($000000FF)))];
end;
{==============================================================================}
function Crc32(const Value: AnsiString): Integer;
var
n: Integer;
begin
Result := Integer($FFFFFFFF);
for n := 1 to Length(Value) do
Result := UpdateCrc32(Ord(Value[n]), Result);
Result := not Result;
end;
{==============================================================================}
function UpdateCrc16(Value: Byte; Crc16: Word): Word;
begin
Result := ((Crc16 shr 8) and $00FF) xor
crc16tab[Byte(Crc16 xor (Word(Value)) and $00FF)];
end;
{==============================================================================}
function Crc16(const Value: AnsiString): Word;
var
n: Integer;
begin
Result := $FFFF;
for n := 1 to Length(Value) do
Result := UpdateCrc16(Ord(Value[n]), Result);
end;
{==============================================================================}
procedure MDInit(var MDContext: TMDCtx);
var
n: integer;
begin
MDContext.Count[0] := 0;
MDContext.Count[1] := 0;
for n := 0 to high(MDContext.BufAnsiChar) do
MDContext.BufAnsiChar[n] := 0;
for n := 0 to high(MDContext.BufLong) do
MDContext.BufLong[n] := 0;
MDContext.State[0] := Integer($67452301);
MDContext.State[1] := Integer($EFCDAB89);
MDContext.State[2] := Integer($98BADCFE);
MDContext.State[3] := Integer($10325476);
end;
procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt);
var
A, B, C, D: LongInt;
procedure Round1(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte);
begin
Inc(W, (Z xor (X and (Y xor Z))) + Data);
W := (W shl S) or (W shr (32 - S));
Inc(W, X);
end;
procedure Round2(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte);
begin
Inc(W, (Y xor (Z and (X xor Y))) + Data);
W := (W shl S) or (W shr (32 - S));
Inc(W, X);
end;
procedure Round3(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte);
begin
Inc(W, (X xor Y xor Z) + Data);
W := (W shl S) or (W shr (32 - S));
Inc(W, X);
end;
procedure Round4(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte);
begin
Inc(W, (Y xor (X or not Z)) + Data);
W := (W shl S) or (W shr (32 - S));
Inc(W, X);
end;
begin
A := Buf[0];
B := Buf[1];
C := Buf[2];
D := Buf[3];
Round1(A, B, C, D, Data[0] + Longint($D76AA478), 7);
Round1(D, A, B, C, Data[1] + Longint($E8C7B756), 12);
Round1(C, D, A, B, Data[2] + Longint($242070DB), 17);
Round1(B, C, D, A, Data[3] + Longint($C1BDCEEE), 22);
Round1(A, B, C, D, Data[4] + Longint($F57C0FAF), 7);
Round1(D, A, B, C, Data[5] + Longint($4787C62A), 12);
Round1(C, D, A, B, Data[6] + Longint($A8304613), 17);
Round1(B, C, D, A, Data[7] + Longint($FD469501), 22);
Round1(A, B, C, D, Data[8] + Longint($698098D8), 7);
Round1(D, A, B, C, Data[9] + Longint($8B44F7AF), 12);
Round1(C, D, A, B, Data[10] + Longint($FFFF5BB1), 17);
Round1(B, C, D, A, Data[11] + Longint($895CD7BE), 22);
Round1(A, B, C, D, Data[12] + Longint($6B901122), 7);
Round1(D, A, B, C, Data[13] + Longint($FD987193), 12);
Round1(C, D, A, B, Data[14] + Longint($A679438E), 17);
Round1(B, C, D, A, Data[15] + Longint($49B40821), 22);
Round2(A, B, C, D, Data[1] + Longint($F61E2562), 5);
Round2(D, A, B, C, Data[6] + Longint($C040B340), 9);
Round2(C, D, A, B, Data[11] + Longint($265E5A51), 14);
Round2(B, C, D, A, Data[0] + Longint($E9B6C7AA), 20);
Round2(A, B, C, D, Data[5] + Longint($D62F105D), 5);
Round2(D, A, B, C, Data[10] + Longint($02441453), 9);
Round2(C, D, A, B, Data[15] + Longint($D8A1E681), 14);
Round2(B, C, D, A, Data[4] + Longint($E7D3FBC8), 20);
Round2(A, B, C, D, Data[9] + Longint($21E1CDE6), 5);
Round2(D, A, B, C, Data[14] + Longint($C33707D6), 9);
Round2(C, D, A, B, Data[3] + Longint($F4D50D87), 14);
Round2(B, C, D, A, Data[8] + Longint($455A14ED), 20);
Round2(A, B, C, D, Data[13] + Longint($A9E3E905), 5);
Round2(D, A, B, C, Data[2] + Longint($FCEFA3F8), 9);
Round2(C, D, A, B, Data[7] + Longint($676F02D9), 14);
Round2(B, C, D, A, Data[12] + Longint($8D2A4C8A), 20);
Round3(A, B, C, D, Data[5] + Longint($FFFA3942), 4);
Round3(D, A, B, C, Data[8] + Longint($8771F681), 11);
Round3(C, D, A, B, Data[11] + Longint($6D9D6122), 16);
Round3(B, C, D, A, Data[14] + Longint($FDE5380C), 23);
Round3(A, B, C, D, Data[1] + Longint($A4BEEA44), 4);
Round3(D, A, B, C, Data[4] + Longint($4BDECFA9), 11);
Round3(C, D, A, B, Data[7] + Longint($F6BB4B60), 16);
Round3(B, C, D, A, Data[10] + Longint($BEBFBC70), 23);
Round3(A, B, C, D, Data[13] + Longint($289B7EC6), 4);
Round3(D, A, B, C, Data[0] + Longint($EAA127FA), 11);
Round3(C, D, A, B, Data[3] + Longint($D4EF3085), 16);
Round3(B, C, D, A, Data[6] + Longint($04881D05), 23);
Round3(A, B, C, D, Data[9] + Longint($D9D4D039), 4);
Round3(D, A, B, C, Data[12] + Longint($E6DB99E5), 11);
Round3(C, D, A, B, Data[15] + Longint($1FA27CF8), 16);
Round3(B, C, D, A, Data[2] + Longint($C4AC5665), 23);
Round4(A, B, C, D, Data[0] + Longint($F4292244), 6);
Round4(D, A, B, C, Data[7] + Longint($432AFF97), 10);
Round4(C, D, A, B, Data[14] + Longint($AB9423A7), 15);
Round4(B, C, D, A, Data[5] + Longint($FC93A039), 21);
Round4(A, B, C, D, Data[12] + Longint($655B59C3), 6);
Round4(D, A, B, C, Data[3] + Longint($8F0CCC92), 10);
Round4(C, D, A, B, Data[10] + Longint($FFEFF47D), 15);
Round4(B, C, D, A, Data[1] + Longint($85845DD1), 21);
Round4(A, B, C, D, Data[8] + Longint($6FA87E4F), 6);
Round4(D, A, B, C, Data[15] + Longint($FE2CE6E0), 10);
Round4(C, D, A, B, Data[6] + Longint($A3014314), 15);
Round4(B, C, D, A, Data[13] + Longint($4E0811A1), 21);
Round4(A, B, C, D, Data[4] + Longint($F7537E82), 6);
Round4(D, A, B, C, Data[11] + Longint($BD3AF235), 10);
Round4(C, D, A, B, Data[2] + Longint($2AD7D2BB), 15);
Round4(B, C, D, A, Data[9] + Longint($EB86D391), 21);
Inc(Buf[0], A);
Inc(Buf[1], B);
Inc(Buf[2], C);
Inc(Buf[3], D);
end;
//fixed by James McAdams
procedure MDUpdate(var MDContext: TMDCtx; const Data: AnsiString; transform: TMDTransform);
var
Index, partLen, InputLen, I: integer;
{$IFDEF CIL}
n: integer;
{$ENDIF}
begin
InputLen := Length(Data);
with MDContext do
begin
Index := (Count[0] shr 3) and $3F;
Inc(Count[0], InputLen shl 3);
if Count[0] < (InputLen shl 3) then
Inc(Count[1]);
Inc(Count[1], InputLen shr 29);
partLen := 64 - Index;
if InputLen >= partLen then
begin
ArrLongToByte(BufLong, BufAnsiChar);
{$IFDEF CIL}
for n := 1 to partLen do
BufAnsiChar[index - 1 + n] := Ord(Data[n]);
{$ELSE}
Move(Data[1], BufAnsiChar[Index], partLen);
{$ENDIF}
ArrByteToLong(BufAnsiChar, BufLong);
Transform(State, Buflong);
I := partLen;
while I + 63 < InputLen do
begin
ArrLongToByte(BufLong, BufAnsiChar);
{$IFDEF CIL}
for n := 1 to 64 do
BufAnsiChar[n - 1] := Ord(Data[i + n]);
{$ELSE}
Move(Data[I+1], BufAnsiChar, 64);
{$ENDIF}
ArrByteToLong(BufAnsiChar, BufLong);
Transform(State, Buflong);
inc(I, 64);
end;
Index := 0;
end
else
I := 0;
ArrLongToByte(BufLong, BufAnsiChar);
{$IFDEF CIL}
for n := 1 to InputLen-I do
BufAnsiChar[Index + n - 1] := Ord(Data[i + n]);
{$ELSE}
Move(Data[I+1], BufAnsiChar[Index], InputLen-I);
{$ENDIF}
ArrByteToLong(BufAnsiChar, BufLong);
end
end;
function MDFinal(var MDContext: TMDCtx; transform: TMDTransform): AnsiString;
var
Cnt: Word;
P: Byte;
digest: array[0..15] of Byte;
i: Integer;
n: integer;
begin
for I := 0 to 15 do
Digest[I] := I + 1;
with MDContext do
begin
Cnt := (Count[0] shr 3) and $3F;
P := Cnt;
BufAnsiChar[P] := $80;
Inc(P);
Cnt := 64 - 1 - Cnt;
if Cnt < 8 then
begin
for n := 0 to cnt - 1 do
BufAnsiChar[P + n] := 0;
ArrByteToLong(BufAnsiChar, BufLong);
// FillChar(BufAnsiChar[P], Cnt, #0);
Transform(State, BufLong);
ArrLongToByte(BufLong, BufAnsiChar);
for n := 0 to 55 do
BufAnsiChar[n] := 0;
ArrByteToLong(BufAnsiChar, BufLong);
// FillChar(BufAnsiChar, 56, #0);
end
else
begin
for n := 0 to Cnt - 8 - 1 do
BufAnsiChar[p + n] := 0;
ArrByteToLong(BufAnsiChar, BufLong);
// FillChar(BufAnsiChar[P], Cnt - 8, #0);
end;
BufLong[14] := Count[0];
BufLong[15] := Count[1];
Transform(State, BufLong);
ArrLongToByte(State, Digest);
// Move(State, Digest, 16);
Result := '';
for i := 0 to 15 do
Result := Result + AnsiChar(digest[i]);
end;
// FillChar(MD5Context, SizeOf(TMD5Ctx), #0)
end;
{==============================================================================}
function MD5(const Value: AnsiString): AnsiString;
var
MDContext: TMDCtx;
begin
MDInit(MDContext);
MDUpdate(MDContext, Value, @MD5Transform);
Result := MDFinal(MDContext, @MD5Transform);
end;
{==============================================================================}
function HMAC_MD5(Text, Key: AnsiString): AnsiString;
var
ipad, opad, s: AnsiString;
n: Integer;
MDContext: TMDCtx;
begin
if Length(Key) > 64 then
Key := md5(Key);
ipad := StringOfChar(#$36, 64);
opad := StringOfChar(#$5C, 64);
for n := 1 to Length(Key) do
begin
ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n]));
opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n]));
end;
MDInit(MDContext);
MDUpdate(MDContext, ipad, @MD5Transform);
MDUpdate(MDContext, Text, @MD5Transform);
s := MDFinal(MDContext, @MD5Transform);
MDInit(MDContext);
MDUpdate(MDContext, opad, @MD5Transform);
MDUpdate(MDContext, s, @MD5Transform);
Result := MDFinal(MDContext, @MD5Transform);
end;
{==============================================================================}
function MD5LongHash(const Value: AnsiString; Len: integer): AnsiString;
var
cnt, rest: integer;
l: integer;
n: integer;
MDContext: TMDCtx;
begin
l := length(Value);
cnt := Len div l;
rest := Len mod l;
MDInit(MDContext);
for n := 1 to cnt do
MDUpdate(MDContext, Value, @MD5Transform);
if rest > 0 then
MDUpdate(MDContext, Copy(Value, 1, rest), @MD5Transform);
Result := MDFinal(MDContext, @MD5Transform);
end;
{==============================================================================}
// SHA1 is based on sources by Dave Barton (davebarton@bigfoot.com)
procedure SHA1init( var SHA1Context: TSHA1Ctx );
var
n: integer;
begin
SHA1Context.Hi := 0;
SHA1Context.Lo := 0;
SHA1Context.Index := 0;
for n := 0 to High(SHA1Context.Buffer) do
SHA1Context.Buffer[n] := 0;
for n := 0 to High(SHA1Context.HashByte) do
SHA1Context.HashByte[n] := 0;
// FillChar(SHA1Context, SizeOf(TSHA1Ctx), #0);
SHA1Context.Hash[0] := integer($67452301);
SHA1Context.Hash[1] := integer($EFCDAB89);
SHA1Context.Hash[2] := integer($98BADCFE);
SHA1Context.Hash[3] := integer($10325476);
SHA1Context.Hash[4] := integer($C3D2E1F0);
end;
//******************************************************************************
function RB(A: integer): integer;
begin
Result := (A shr 24) or ((A shr 8) and $FF00) or ((A shl 8) and $FF0000) or (A shl 24);
end;
procedure SHA1Compress(var Data: TSHA1Ctx);
var
A, B, C, D, E, T: integer;
W: array[0..79] of integer;
i: integer;
n: integer;
function F1(x, y, z: integer): integer;
begin
Result := z xor (x and (y xor z));
end;
function F2(x, y, z: integer): integer;
begin
Result := x xor y xor z;
end;
function F3(x, y, z: integer): integer;
begin
Result := (x and y) or (z and (x or y));
end;
function LRot32(X: integer; c: integer): integer;
begin
result := (x shl c) or (x shr (32 - c));
end;
begin
ArrByteToLong(Data.Buffer, W);
// Move(Data.Buffer, W, Sizeof(Data.Buffer));
for i := 0 to 15 do
W[i] := RB(W[i]);
for i := 16 to 79 do
W[i] := LRot32(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16], 1);
A := Data.Hash[0];
B := Data.Hash[1];
C := Data.Hash[2];
D := Data.Hash[3];
E := Data.Hash[4];
for i := 0 to 19 do
begin
T := LRot32(A, 5) + F1(B, C, D) + E + W[i] + integer($5A827999);
E := D;
D := C;
C := LRot32(B, 30);
B := A;
A := T;
end;
for i := 20 to 39 do
begin
T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($6ED9EBA1);
E := D;
D := C;
C := LRot32(B, 30);
B := A;
A := T;
end;
for i := 40 to 59 do
begin
T := LRot32(A, 5) + F3(B, C, D) + E + W[i] + integer($8F1BBCDC);
E := D;
D := C;
C := LRot32(B, 30);
B := A;
A := T;
end;
for i := 60 to 79 do
begin
T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($CA62C1D6);
E := D;
D := C;
C := LRot32(B, 30);
B := A;
A := T;
end;
Data.Hash[0] := Data.Hash[0] + A;
Data.Hash[1] := Data.Hash[1] + B;
Data.Hash[2] := Data.Hash[2] + C;
Data.Hash[3] := Data.Hash[3] + D;
Data.Hash[4] := Data.Hash[4] + E;
for n := 0 to high(w) do
w[n] := 0;
// FillChar(W, Sizeof(W), 0);
for n := 0 to high(Data.Buffer) do
Data.Buffer[n] := 0;
// FillChar(Data.Buffer, Sizeof(Data.Buffer), 0);
end;
//******************************************************************************
procedure SHA1Update(var Context: TSHA1Ctx; const Data: AnsiString);
var
Len: integer;
n: integer;
i, k: integer;
begin
Len := Length(data);
for k := 0 to 7 do
begin
i := Context.Lo;
Inc(Context.Lo, Len);
if Context.Lo < i then
Inc(Context.Hi);
end;
for n := 1 to len do
begin
Context.Buffer[Context.Index] := byte(Data[n]);
Inc(Context.Index);
if Context.Index = 64 then
begin
Context.Index := 0;
SHA1Compress(Context);
end;
end;
end;
//******************************************************************************
function SHA1Final(var Context: TSHA1Ctx): AnsiString;
type
Pinteger = ^integer;
var
i: integer;
procedure ItoArr(var Ar: Array of byte; I, value: Integer);
begin
Ar[i + 0] := Value and $000000FF;
Ar[i + 1] := (Value shr 8) and $000000FF;
Ar[i + 2] := (Value shr 16) and $000000FF;
Ar[i + 3] := (Value shr 24) and $000000FF;
end;
begin
Context.Buffer[Context.Index] := $80;
if Context.Index >= 56 then
SHA1Compress(Context);
ItoArr(Context.Buffer, 56, RB(Context.Hi));
ItoArr(Context.Buffer, 60, RB(Context.Lo));
// Pinteger(@Context.Buffer[56])^ := RB(Context.Hi);
// Pinteger(@Context.Buffer[60])^ := RB(Context.Lo);
SHA1Compress(Context);
Context.Hash[0] := RB(Context.Hash[0]);
Context.Hash[1] := RB(Context.Hash[1]);
Context.Hash[2] := RB(Context.Hash[2]);
Context.Hash[3] := RB(Context.Hash[3]);
Context.Hash[4] := RB(Context.Hash[4]);
ArrLongToByte(Context.Hash, Context.HashByte);
Result := '';
for i := 0 to 19 do
Result := Result + AnsiChar(Context.HashByte[i]);
end;
function SHA1(const Value: AnsiString): AnsiString;
var
SHA1Context: TSHA1Ctx;
begin
SHA1Init(SHA1Context);
SHA1Update(SHA1Context, Value);
Result := SHA1Final(SHA1Context);
end;
{==============================================================================}
function HMAC_SHA1(Text, Key: AnsiString): AnsiString;
var
ipad, opad, s: AnsiString;
n: Integer;
SHA1Context: TSHA1Ctx;
begin
if Length(Key) > 64 then
Key := SHA1(Key);
ipad := StringOfChar(#$36, 64);
opad := StringOfChar(#$5C, 64);
for n := 1 to Length(Key) do
begin
ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n]));
opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n]));
end;
SHA1Init(SHA1Context);
SHA1Update(SHA1Context, ipad);
SHA1Update(SHA1Context, Text);
s := SHA1Final(SHA1Context);
SHA1Init(SHA1Context);
SHA1Update(SHA1Context, opad);
SHA1Update(SHA1Context, s);
Result := SHA1Final(SHA1Context);
end;
{==============================================================================}
function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString;
var
cnt, rest: integer;
l: integer;
n: integer;
SHA1Context: TSHA1Ctx;
begin
l := length(Value);
cnt := Len div l;
rest := Len mod l;
SHA1Init(SHA1Context);
for n := 1 to cnt do
SHA1Update(SHA1Context, Value);
if rest > 0 then
SHA1Update(SHA1Context, Copy(Value, 1, rest));
Result := SHA1Final(SHA1Context);
end;
{==============================================================================}
procedure MD4Transform(var Buf: array of LongInt; const Data: array of LongInt);
var
A, B, C, D: LongInt;
function LRot32(a, b: longint): longint;
begin
Result:= (a shl b) or (a shr (32 - b));
end;
begin
A := Buf[0];
B := Buf[1];
C := Buf[2];
D := Buf[3];
A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 0], 3);
D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 1], 7);
C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 2], 11);
B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 3], 19);
A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 4], 3);
D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 5], 7);
C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 6], 11);
B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 7], 19);
A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 8], 3);
D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 9], 7);
C:= LRot32(C + (B xor (D and (A xor B))) + Data[10], 11);
B:= LRot32(B + (A xor (C and (D xor A))) + Data[11], 19);
A:= LRot32(A + (D xor (B and (C xor D))) + Data[12], 3);
D:= LRot32(D + (C xor (A and (B xor C))) + Data[13], 7);
C:= LRot32(C + (B xor (D and (A xor B))) + Data[14], 11);
B:= LRot32(B + (A xor (C and (D xor A))) + Data[15], 19);
A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 0] + longint($5a827999), 3);
D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 4] + longint($5a827999), 5);
C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 8] + longint($5a827999), 9);
B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[12] + longint($5a827999), 13);
A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 1] + longint($5a827999), 3);
D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 5] + longint($5a827999), 5);
C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 9] + longint($5a827999), 9);
B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[13] + longint($5a827999), 13);
A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 2] + longint($5a827999), 3);
D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 6] + longint($5a827999), 5);
C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[10] + longint($5a827999), 9);
B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[14] + longint($5a827999), 13);
A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 3] + longint($5a827999), 3);
D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 7] + longint($5a827999), 5);
C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[11] + longint($5a827999), 9);
B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[15] + longint($5a827999), 13);
A:= LRot32(A + (B xor C xor D) + Data[ 0] + longint($6ed9eba1), 3);
D:= LRot32(D + (A xor B xor C) + Data[ 8] + longint($6ed9eba1), 9);
C:= LRot32(C + (D xor A xor B) + Data[ 4] + longint($6ed9eba1), 11);
B:= LRot32(B + (C xor D xor A) + Data[12] + longint($6ed9eba1), 15);
A:= LRot32(A + (B xor C xor D) + Data[ 2] + longint($6ed9eba1), 3);
D:= LRot32(D + (A xor B xor C) + Data[10] + longint($6ed9eba1), 9);
C:= LRot32(C + (D xor A xor B) + Data[ 6] + longint($6ed9eba1), 11);
B:= LRot32(B + (C xor D xor A) + Data[14] + longint($6ed9eba1), 15);
A:= LRot32(A + (B xor C xor D) + Data[ 1] + longint($6ed9eba1), 3);
D:= LRot32(D + (A xor B xor C) + Data[ 9] + longint($6ed9eba1), 9);
C:= LRot32(C + (D xor A xor B) + Data[ 5] + longint($6ed9eba1), 11);
B:= LRot32(B + (C xor D xor A) + Data[13] + longint($6ed9eba1), 15);
A:= LRot32(A + (B xor C xor D) + Data[ 3] + longint($6ed9eba1), 3);
D:= LRot32(D + (A xor B xor C) + Data[11] + longint($6ed9eba1), 9);
C:= LRot32(C + (D xor A xor B) + Data[ 7] + longint($6ed9eba1), 11);
B:= LRot32(B + (C xor D xor A) + Data[15] + longint($6ed9eba1), 15);
Inc(Buf[0], A);
Inc(Buf[1], B);
Inc(Buf[2], C);
Inc(Buf[3], D);
end;
{==============================================================================}
function MD4(const Value: AnsiString): AnsiString;
var
MDContext: TMDCtx;
begin
MDInit(MDContext);
MDUpdate(MDContext, Value, @MD4Transform);
Result := MDFinal(MDContext, @MD4Transform);
end;
{==============================================================================}
end.
TransGUI/synapse/source/lib/synautil.pas 0000644 0000000 0000000 00000136433 11366572451 017341 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 004.014.000 |
|==============================================================================|
| Content: support procedures and functions |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
| Portions created by Hernan Sanchez are Copyright (c) 2000. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Hernan Sanchez (hernan.sanchez@iname.com) |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(Support procedures and functions)}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$R-}
{$H+}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$WARN SUSPICIOUS_TYPECAST OFF}
{$ENDIF}
unit synautil;
interface
uses
{$IFDEF MSWINDOWS}
Windows,
{$ELSE}
{$IFDEF FPC}
UnixUtil, Unix, BaseUnix,
{$ELSE}
Libc,
{$ENDIF}
{$ENDIF}
{$IFDEF CIL}
System.IO,
{$ENDIF}
SysUtils, Classes, SynaFpc;
{$IFDEF VER100}
type
int64 = integer;
{$ENDIF}
{:Return your timezone bias from UTC time in minutes.}
function TimeZoneBias: integer;
{:Return your timezone bias from UTC time in string representation like "+0200".}
function TimeZone: string;
{:Returns current time in format defined in RFC-822. Useful for SMTP messages,
but other protocols use this time format as well. Results contains the timezone
specification. Four digit year is used to break any Y2K concerns. (Example
'Fri, 15 Oct 1999 21:14:56 +0200')}
function Rfc822DateTime(t: TDateTime): string;
{:Returns date and time in format defined in C compilers in format "mmm dd hh:nn:ss"}
function CDateTime(t: TDateTime): string;
{:Returns date and time in format defined in format 'yymmdd hhnnss'}
function SimpleDateTime(t: TDateTime): string;
{:Returns date and time in format defined in ANSI C compilers in format
"ddd mmm d hh:nn:ss yyyy" }
function AnsiCDateTime(t: TDateTime): string;
{:Decode three-letter string with name of month to their month number. If string
not match any month name, then is returned 0. For parsing are used predefined
names for English, French and German and names from system locale too.}
function GetMonthNumber(Value: String): integer;
{:Return decoded time from given string. Time must be witch separator ':'. You
can use "hh:mm" or "hh:mm:ss".}
function GetTimeFromStr(Value: string): TDateTime;
{:Decode string in format "m-d-y" to TDateTime type.}
function GetDateMDYFromStr(Value: string): TDateTime;
{:Decode various string representations of date and time to Tdatetime type.
This function do all timezone corrections too! This function can decode lot of
formats like:
@longcode(#
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 #)
and more with lot of modifications, include:
@longcode(#
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
#)
Timezone corrections known lot of symbolic timezone names (like CEST, EDT, etc.)
or numeric representation (like +0200). By convention defined in RFC timezone
+0000 is GMT and -0000 is current your system timezone.}
function DecodeRfcDateTime(Value: string): TDateTime;
{:Return current system date and time in UTC timezone.}
function GetUTTime: TDateTime;
{:Set Newdt as current system date and time in UTC timezone. This function work
only if you have administrator rights!}
function SetUTTime(Newdt: TDateTime): Boolean;
{:Return current value of system timer with precizion 1 millisecond. Good for
measure time difference.}
function GetTick: LongWord;
{:Return difference between two timestamps. It working fine only for differences
smaller then maxint. (difference must be smaller then 24 days.)}
function TickDelta(TickOld, TickNew: LongWord): LongWord;
{:Return two characters, which ordinal values represents the value in byte
format. (High-endian)}
function CodeInt(Value: Word): Ansistring;
{:Decodes two characters located at "Index" offset position of the "Value"
string to Word values.}
function DecodeInt(const Value: Ansistring; Index: Integer): Word;
{:Return four characters, which ordinal values represents the value in byte
format. (High-endian)}
function CodeLongInt(Value: LongInt): Ansistring;
{:Decodes four characters located at "Index" offset position of the "Value"
string to LongInt values.}
function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt;
{:Dump binary buffer stored in a string to a result string.}
function DumpStr(const Buffer: Ansistring): string;
{:Dump binary buffer stored in a string to a result string. All bytes with code
of character is written as character, not as hexadecimal value.}
function DumpExStr(const Buffer: Ansistring): string;
{:Dump binary buffer stored in a string to a file with DumpFile filename.}
procedure Dump(const Buffer: AnsiString; DumpFile: string);
{:Dump binary buffer stored in a string to a file with DumpFile filename. All
bytes with code of character is written as character, not as hexadecimal value.}
procedure DumpEx(const Buffer: AnsiString; DumpFile: string);
{:Like TrimLeft, but remove only spaces, not control characters!}
function TrimSPLeft(const S: string): string;
{:Like TrimRight, but remove only spaces, not control characters!}
function TrimSPRight(const S: string): string;
{:Like Trim, but remove only spaces, not control characters!}
function TrimSP(const S: string): string;
{:Returns a portion of the "Value" string located to the left of the "Delimiter"
string. If a delimiter is not found, results is original string.}
function SeparateLeft(const Value, Delimiter: string): string;
{:Returns the portion of the "Value" string located to the right of the
"Delimiter" string. If a delimiter is not found, results is original string.}
function SeparateRight(const Value, Delimiter: string): string;
{:Returns parameter value from string in format:
parameter1="value1"; parameter2=value2}
function GetParameter(const Value, Parameter: string): string;
{:parse value string with elements differed by Delimiter into stringlist.}
procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings);
{:parse value string with elements differed by ';' into stringlist.}
procedure ParseParameters(Value: string; const Parameters: TStrings);
{:Index of string in stringlist with same beginning as Value is returned.}
function IndexByBegin(Value: string; const List: TStrings): integer;
{:Returns only the e-mail portion of an address from the full address format.
i.e. returns 'nobody@@somewhere.com' from '"someone" '}
function GetEmailAddr(const Value: string): string;
{:Returns only the description part from a full address format. i.e. returns
'someone' from '"someone" '}
function GetEmailDesc(Value: string): string;
{:Returns a string with hexadecimal digits representing the corresponding values
of the bytes found in "Value" string.}
function StrToHex(const Value: Ansistring): string;
{:Returns a string of binary "Digits" representing "Value".}
function IntToBin(Value: Integer; Digits: Byte): string;
{:Returns an integer equivalent of the binary string in "Value".
(i.e. ('10001010') returns 138)}
function BinToInt(const Value: string): Integer;
{:Parses a URL to its various components.}
function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
Para: string): string;
{:Replaces all "Search" string values found within "Value" string, with the
"Replace" string value.}
function ReplaceString(Value, Search, Replace: AnsiString): AnsiString;
{:It is like RPos, but search is from specified possition.}
function RPosEx(const Sub, Value: string; From: integer): Integer;
{:It is like POS function, but from right side of Value string.}
function RPos(const Sub, Value: String): Integer;
{:Like @link(fetch), but working with binary strings, not with text.}
function FetchBin(var Value: string; const Delimiter: string): string;
{:Fetch string from left of Value string.}
function Fetch(var Value: string; const Delimiter: string): string;
{:Fetch string from left of Value string. This function ignore delimitesr inside
quotations.}
function FetchEx(var Value: string; const Delimiter, Quotation: string): string;
{:If string is binary string (contains non-printable characters), then is
returned true.}
function IsBinaryString(const Value: AnsiString): Boolean;
{:return position of string terminator in string. If terminator found, then is
returned in terminator parameter.
Possible line terminators are: CRLF, LFCR, CR, LF}
function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer;
{:Delete empty strings from end of stringlist.}
Procedure StringsTrim(const value: TStrings);
{:Like Pos function, buf from given string possition.}
function PosFrom(const SubStr, Value: String; From: integer): integer;
{$IFNDEF CIL}
{:Increase pointer by value.}
function IncPoint(const p: pointer; Value: integer): pointer;
{$ENDIF}
{:Get string between PairBegin and PairEnd. This function respect nesting.
For example:
@longcode(#
Value is: 'Hi! (hello(yes!))'
pairbegin is: '('
pairend is: ')'
In this case result is: 'hello(yes!)'#)}
function GetBetween(const PairBegin, PairEnd, Value: string): string;
{:Return count of Chr in Value string.}
function CountOfChar(const Value: string; Chr: char): integer;
{:Remove quotation from Value string. If Value is not quoted, then return same
string without any modification. }
function UnquoteStr(const Value: string; Quote: Char): string;
{:Quote Value string. If Value contains some Quote chars, then it is doubled.}
function QuoteStr(const Value: string; Quote: Char): string;
{:Convert lines in stringlist from 'name: value' form to 'name=value' form.}
procedure HeadersToList(const Value: TStrings);
{:Convert lines in stringlist from 'name=value' form to 'name: value' form.}
procedure ListToHeaders(const Value: TStrings);
{:swap bytes in integer.}
function SwapBytes(Value: integer): integer;
{:read string with requested length form stream.}
function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString;
{:write string to stream.}
procedure WriteStrToStream(const Stream: TStream; Value: AnsiString);
{:Return filename of new temporary file in Dir (if empty, then default temporary
directory is used) and with optional filename prefix.}
function GetTempFile(const Dir, prefix: AnsiString): AnsiString;
{:Return padded string. If length is greater, string is truncated. If length is
smaller, string is padded by Pad character.}
function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString;
{:Read header from "Value" stringlist beginning at "Index" position. If header
is Splitted into multiple lines, then this procedure de-split it into one line.}
function NormalizeHeader(Value: TStrings; var Index: Integer): string;
var
{:can be used for your own months strings for @link(getmonthnumber)}
CustomMonthNames: array[1..12] of string;
implementation
{==============================================================================}
const
MyDayNames: array[1..7] of AnsiString =
('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
var
MyMonthNames: array[0..6, 1..12] of String =
(
('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //rewrited by system locales
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'),
('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //English
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'),
('jan', 'fév', 'mar', 'avr', 'mai', 'jun', //French
'jul', 'aoû', 'sep', 'oct', 'nov', 'déc'),
('jan', 'fev', 'mar', 'avr', 'mai', 'jun', //French#2
'jul', 'aou', 'sep', 'oct', 'nov', 'dec'),
('Jan', 'Feb', 'Mar', 'Apr', 'Mai', 'Jun', //German
'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'),
('Jan', 'Feb', 'Mär', 'Apr', 'Mai', 'Jun', //German#2
'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'),
('Led', 'Úno', 'Bøe', 'Dub', 'Kvì', 'Èen', //Czech
'Èec', 'Srp', 'Záø', 'Øíj', 'Lis', 'Pro')
);
{==============================================================================}
function TimeZoneBias: integer;
{$IFNDEF MSWINDOWS}
{$IFNDEF FPC}
var
t: TTime_T;
UT: TUnixTime;
begin
__time(@T);
localtime_r(@T, UT);
Result := ut.__tm_gmtoff div 60;
{$ELSE}
begin
Result := TZSeconds div 60;
{$ENDIF}
{$ELSE}
var
zoneinfo: TTimeZoneInformation;
bias: Integer;
begin
case GetTimeZoneInformation(Zoneinfo) of
2:
bias := zoneinfo.Bias + zoneinfo.DaylightBias;
1:
bias := zoneinfo.Bias + zoneinfo.StandardBias;
else
bias := zoneinfo.Bias;
end;
Result := bias * (-1);
{$ENDIF}
end;
{==============================================================================}
function TimeZone: string;
var
bias: Integer;
h, m: Integer;
begin
bias := TimeZoneBias;
if bias >= 0 then
Result := '+'
else
Result := '-';
bias := Abs(bias);
h := bias div 60;
m := bias mod 60;
Result := Result + Format('%.2d%.2d', [h, m]);
end;
{==============================================================================}
function Rfc822DateTime(t: TDateTime): string;
var
wYear, wMonth, wDay: word;
begin
DecodeDate(t, wYear, wMonth, wDay);
Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay,
MyMonthNames[1, wMonth], FormatDateTime('yyyy hh":"nn":"ss', t), TimeZone]);
end;
{==============================================================================}
function CDateTime(t: TDateTime): string;
var
wYear, wMonth, wDay: word;
begin
DecodeDate(t, wYear, wMonth, wDay);
Result:= Format('%s %2d %s', [MyMonthNames[1, wMonth], wDay,
FormatDateTime('hh":"nn":"ss', t)]);
end;
{==============================================================================}
function SimpleDateTime(t: TDateTime): string;
begin
Result := FormatDateTime('yymmdd hhnnss', t);
end;
{==============================================================================}
function AnsiCDateTime(t: TDateTime): string;
var
wYear, wMonth, wDay: word;
begin
DecodeDate(t, wYear, wMonth, wDay);
Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[1, wMonth],
wDay, FormatDateTime('hh":"nn":"ss yyyy ', t)]);
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 GetMonthNumber(Value: String): integer;
var
n: integer;
function TestMonth(Value: String; Index: Integer): Boolean;
var
n: integer;
begin
Result := False;
for n := 0 to 6 do
if Value = AnsiUppercase(MyMonthNames[n, Index]) then
begin
Result := True;
Break;
end;
end;
begin
Result := 0;
Value := AnsiUppercase(Value);
for n := 1 to 12 do
if TestMonth(Value, n) or (Value = AnsiUppercase(CustomMonthNames[n])) then
begin
Result := n;
Break;
end;
end;
{==============================================================================}
function GetTimeFromStr(Value: string): TDateTime;
var
x: integer;
begin
x := rpos(':', Value);
if (x > 0) and ((Length(Value) - x) > 2) then
Value := Copy(Value, 1, x + 2);
Value := ReplaceString(Value, ':', TimeSeparator);
Result := -1;
try
Result := StrToTime(Value);
except
on Exception do ;
end;
end;
{==============================================================================}
function GetDateMDYFromStr(Value: string): TDateTime;
var
wYear, wMonth, wDay: word;
s: string;
begin
Result := 0;
s := Fetch(Value, '-');
wMonth := StrToIntDef(s, 12);
s := Fetch(Value, '-');
wDay := StrToIntDef(s, 30);
wYear := StrToIntDef(Value, 1899);
if wYear < 1000 then
if (wYear > 99) then
wYear := wYear + 1900
else
if wYear > 50 then
wYear := wYear + 1900
else
wYear := wYear + 2000;
try
Result := EncodeDate(wYear, wMonth, wDay);
except
on Exception do ;
end;
end;
{==============================================================================}
function DecodeRfcDateTime(Value: string): TDateTime;
var
day, month, year: Word;
zone: integer;
x, y: integer;
s: string;
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;
if Value = '' then
Exit;
day := 0;
month := 0;
year := 0;
zone := 0;
Value := ReplaceString(Value, ' -', ' #');
Value := ReplaceString(Value, '-', ' ');
Value := ReplaceString(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
if (year = 0) and ((month > 0) or (x > 12)) then
begin
year := x;
if year < 32 then
year := year + 2000;
if year < 1000 then
year := year + 1900;
continue;
end;
end;
// time
if rpos(':', s) > Pos(':', s) then
begin
t := GetTimeFromStr(s);
if t <> -1 then
Result := t;
continue;
end;
//timezone daylight saving time
if s = 'DST' then
begin
zone := zone + 60;
continue;
end;
// month
y := GetMonthNumber(s);
if (y > 0) and (month = 0) then
month := y;
end;
if year = 0 then
year := 1980;
if month < 1 then
month := 1;
if month > 12 then
month := 12;
if day < 1 then
day := 1;
x := MonthDays[IsLeapYear(year), month];
if day > x then
day := x;
Result := Result + Encodedate(year, month, day);
zone := zone - TimeZoneBias;
x := zone div 1440;
Result := Result - x;
zone := zone mod 1440;
t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0);
if zone < 0 then
t := 0 - t;
Result := Result - t;
end;
{==============================================================================}
function GetUTTime: TDateTime;
{$IFDEF MSWINDOWS}
{$IFNDEF FPC}
var
st: TSystemTime;
begin
GetSystemTime(st);
result := SystemTimeToDateTime(st);
{$ELSE}
var
st: SysUtils.TSystemTime;
stw: Windows.TSystemTime;
begin
GetSystemTime(stw);
st.Year := stw.wYear;
st.Month := stw.wMonth;
st.Day := stw.wDay;
st.Hour := stw.wHour;
st.Minute := stw.wMinute;
st.Second := stw.wSecond;
st.Millisecond := stw.wMilliseconds;
result := SystemTimeToDateTime(st);
{$ENDIF}
{$ELSE}
{$IFNDEF FPC}
var
TV: TTimeVal;
begin
gettimeofday(TV, nil);
Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400;
{$ELSE}
var
TV: TimeVal;
begin
fpgettimeofday(@TV, nil);
Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400;
{$ENDIF}
{$ENDIF}
end;
{==============================================================================}
function SetUTTime(Newdt: TDateTime): Boolean;
{$IFDEF MSWINDOWS}
{$IFNDEF FPC}
var
st: TSystemTime;
begin
DateTimeToSystemTime(newdt,st);
Result := SetSystemTime(st);
{$ELSE}
var
st: SysUtils.TSystemTime;
stw: Windows.TSystemTime;
begin
DateTimeToSystemTime(newdt,st);
stw.wYear := st.Year;
stw.wMonth := st.Month;
stw.wDay := st.Day;
stw.wHour := st.Hour;
stw.wMinute := st.Minute;
stw.wSecond := st.Second;
stw.wMilliseconds := st.Millisecond;
Result := SetSystemTime(stw);
{$ENDIF}
{$ELSE}
{$IFNDEF FPC}
var
TV: TTimeVal;
d: double;
TZ: Ttimezone;
PZ: PTimeZone;
begin
TZ.tz_minuteswest := 0;
TZ.tz_dsttime := 0;
PZ := @TZ;
gettimeofday(TV, PZ);
d := (newdt - UnixDateDelta) * 86400;
TV.tv_sec := trunc(d);
TV.tv_usec := trunc(frac(d) * 1000000);
Result := settimeofday(TV, TZ) <> -1;
{$ELSE}
var
TV: TimeVal;
d: double;
begin
d := (newdt - UnixDateDelta) * 86400;
TV.tv_sec := trunc(d);
TV.tv_usec := trunc(frac(d) * 1000000);
Result := fpsettimeofday(@TV, nil) <> -1;
{$ENDIF}
{$ENDIF}
end;
{==============================================================================}
{$IFNDEF MSWINDOWS}
function GetTick: LongWord;
var
Stamp: TTimeStamp;
begin
Stamp := DateTimeToTimeStamp(Now);
Result := Stamp.Time;
end;
{$ELSE}
function GetTick: LongWord;
var
tick, freq: TLargeInteger;
{$IFDEF VER100}
x: TLargeInteger;
{$ENDIF}
begin
if Windows.QueryPerformanceFrequency(freq) then
begin
Windows.QueryPerformanceCounter(tick);
{$IFDEF VER100}
x.QuadPart := (tick.QuadPart / freq.QuadPart) * 1000;
Result := x.LowPart;
{$ELSE}
Result := Trunc((tick / freq) * 1000) and High(LongWord)
{$ENDIF}
end
else
Result := Windows.GetTickCount;
end;
{$ENDIF}
{==============================================================================}
function TickDelta(TickOld, TickNew: LongWord): LongWord;
begin
//if DWord is signed type (older Deplhi),
// then it not work properly on differencies larger then maxint!
Result := 0;
if TickOld <> TickNew then
begin
if TickNew < TickOld then
begin
TickNew := TickNew + LongWord(MaxInt) + 1;
TickOld := TickOld + LongWord(MaxInt) + 1;
end;
Result := TickNew - TickOld;
if TickNew < TickOld then
if Result > 0 then
Result := 0 - Result;
end;
end;
{==============================================================================}
function CodeInt(Value: Word): Ansistring;
begin
setlength(result, 2);
result[1] := AnsiChar(Value div 256);
result[2] := AnsiChar(Value mod 256);
// Result := AnsiChar(Value div 256) + AnsiChar(Value mod 256)
end;
{==============================================================================}
function DecodeInt(const Value: Ansistring; Index: Integer): Word;
var
x, y: Byte;
begin
if Length(Value) > Index then
x := Ord(Value[Index])
else
x := 0;
if Length(Value) >= (Index + 1) then
y := Ord(Value[Index + 1])
else
y := 0;
Result := x * 256 + y;
end;
{==============================================================================}
function CodeLongInt(Value: Longint): Ansistring;
var
x, y: word;
begin
// this is fix for negative numbers on systems where longint = integer
x := (Value shr 16) and integer($ffff);
y := Value and integer($ffff);
setlength(result, 4);
result[1] := AnsiChar(x div 256);
result[2] := AnsiChar(x mod 256);
result[3] := AnsiChar(y div 256);
result[4] := AnsiChar(y mod 256);
end;
{==============================================================================}
function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt;
var
x, y: Byte;
xl, yl: Byte;
begin
if Length(Value) > Index then
x := Ord(Value[Index])
else
x := 0;
if Length(Value) >= (Index + 1) then
y := Ord(Value[Index + 1])
else
y := 0;
if Length(Value) >= (Index + 2) then
xl := Ord(Value[Index + 2])
else
xl := 0;
if Length(Value) >= (Index + 3) then
yl := Ord(Value[Index + 3])
else
yl := 0;
Result := ((x * 256 + y) * 65536) + (xl * 256 + yl);
end;
{==============================================================================}
function DumpStr(const Buffer: Ansistring): string;
var
n: Integer;
begin
Result := '';
for n := 1 to Length(Buffer) do
Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
end;
{==============================================================================}
function DumpExStr(const Buffer: Ansistring): string;
var
n: Integer;
x: Byte;
begin
Result := '';
for n := 1 to Length(Buffer) do
begin
x := Ord(Buffer[n]);
if x in [65..90, 97..122] then
Result := Result + ' +''' + char(x) + ''''
else
Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
end;
end;
{==============================================================================}
procedure Dump(const Buffer: AnsiString; DumpFile: string);
var
f: Text;
begin
AssignFile(f, DumpFile);
if FileExists(DumpFile) then
DeleteFile(DumpFile);
Rewrite(f);
try
Writeln(f, DumpStr(Buffer));
finally
CloseFile(f);
end;
end;
{==============================================================================}
procedure DumpEx(const Buffer: AnsiString; DumpFile: string);
var
f: Text;
begin
AssignFile(f, DumpFile);
if FileExists(DumpFile) then
DeleteFile(DumpFile);
Rewrite(f);
try
Writeln(f, DumpExStr(Buffer));
finally
CloseFile(f);
end;
end;
{==============================================================================}
function TrimSPLeft(const S: string): string;
var
I, L: Integer;
begin
Result := '';
if S = '' then
Exit;
L := Length(S);
I := 1;
while (I <= L) and (S[I] = ' ') do
Inc(I);
Result := Copy(S, I, Maxint);
end;
{==============================================================================}
function TrimSPRight(const S: string): string;
var
I: Integer;
begin
Result := '';
if S = '' then
Exit;
I := Length(S);
while (I > 0) and (S[I] = ' ') do
Dec(I);
Result := Copy(S, 1, I);
end;
{==============================================================================}
function TrimSP(const S: string): string;
begin
Result := TrimSPLeft(s);
Result := TrimSPRight(Result);
end;
{==============================================================================}
function SeparateLeft(const Value, Delimiter: string): string;
var
x: Integer;
begin
x := Pos(Delimiter, Value);
if x < 1 then
Result := Value
else
Result := Copy(Value, 1, x - 1);
end;
{==============================================================================}
function SeparateRight(const Value, Delimiter: string): string;
var
x: Integer;
begin
x := Pos(Delimiter, Value);
if x > 0 then
x := x + Length(Delimiter) - 1;
Result := Copy(Value, x + 1, Length(Value) - x);
end;
{==============================================================================}
function GetParameter(const Value, Parameter: string): string;
var
s: string;
v: string;
begin
Result := '';
v := Value;
while v <> '' do
begin
s := Trim(FetchEx(v, ';', '"'));
if Pos(Uppercase(parameter), Uppercase(s)) = 1 then
begin
Delete(s, 1, Length(Parameter));
s := Trim(s);
if s = '' then
Break;
if s[1] = '=' then
begin
Result := Trim(SeparateRight(s, '='));
Result := UnquoteStr(Result, '"');
break;
end;
end;
end;
end;
{==============================================================================}
procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings);
var
s: string;
begin
Parameters.Clear;
while Value <> '' do
begin
s := Trim(FetchEx(Value, Delimiter, '"'));
Parameters.Add(s);
end;
end;
{==============================================================================}
procedure ParseParameters(Value: string; const Parameters: TStrings);
begin
ParseParametersEx(Value, ';', Parameters);
end;
{==============================================================================}
function IndexByBegin(Value: string; const List: TStrings): integer;
var
n: integer;
s: string;
begin
Result := -1;
Value := uppercase(Value);
for n := 0 to List.Count -1 do
begin
s := UpperCase(List[n]);
if Pos(Value, s) = 1 then
begin
Result := n;
Break;
end;
end;
end;
{==============================================================================}
function GetEmailAddr(const Value: string): string;
var
s: string;
begin
s := SeparateRight(Value, '<');
s := SeparateLeft(s, '>');
Result := Trim(s);
end;
{==============================================================================}
function GetEmailDesc(Value: string): string;
var
s: string;
begin
Value := Trim(Value);
s := SeparateRight(Value, '"');
if s <> Value then
s := SeparateLeft(s, '"')
else
begin
s := SeparateLeft(Value, '<');
if s = Value then
begin
s := SeparateRight(Value, '(');
if s <> Value then
s := SeparateLeft(s, ')')
else
s := '';
end;
end;
Result := Trim(s);
end;
{==============================================================================}
function StrToHex(const Value: Ansistring): string;
var
n: Integer;
begin
Result := '';
for n := 1 to Length(Value) do
Result := Result + IntToHex(Byte(Value[n]), 2);
Result := LowerCase(Result);
end;
{==============================================================================}
function IntToBin(Value: Integer; Digits: Byte): string;
var
x, y, n: Integer;
begin
Result := '';
x := Value;
repeat
y := x mod 2;
x := x div 2;
if y > 0 then
Result := '1' + Result
else
Result := '0' + Result;
until x = 0;
x := Length(Result);
for n := x to Digits - 1 do
Result := '0' + Result;
end;
{==============================================================================}
function BinToInt(const Value: string): Integer;
var
n: Integer;
begin
Result := 0;
for n := 1 to Length(Value) do
begin
if Value[n] = '0' then
Result := Result * 2
else
if Value[n] = '1' then
Result := Result * 2 + 1
else
Break;
end;
end;
{==============================================================================}
function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
Para: string): string;
var
x, y: Integer;
sURL: string;
s: string;
s1, s2: string;
begin
Prot := 'http';
User := '';
Pass := '';
Port := '80';
Para := '';
x := Pos('://', URL);
if x > 0 then
begin
Prot := SeparateLeft(URL, '://');
sURL := SeparateRight(URL, '://');
end
else
sURL := URL;
if UpperCase(Prot) = 'HTTPS' then
Port := '443';
if UpperCase(Prot) = 'FTP' then
Port := '21';
x := Pos('@', sURL);
y := Pos('/', sURL);
if (x > 0) and ((x < y) or (y < 1))then
begin
s := SeparateLeft(sURL, '@');
sURL := SeparateRight(sURL, '@');
x := Pos(':', s);
if x > 0 then
begin
User := SeparateLeft(s, ':');
Pass := SeparateRight(s, ':');
end
else
User := s;
end;
x := Pos('/', sURL);
if x > 0 then
begin
s1 := SeparateLeft(sURL, '/');
s2 := SeparateRight(sURL, '/');
end
else
begin
s1 := sURL;
s2 := '';
end;
if Pos('[', s1) = 1 then
begin
Host := Separateleft(s1, ']');
Delete(Host, 1, 1);
s1 := SeparateRight(s1, ']');
if Pos(':', s1) = 1 then
Port := SeparateRight(s1, ':');
end
else
begin
x := Pos(':', s1);
if x > 0 then
begin
Host := SeparateLeft(s1, ':');
Port := SeparateRight(s1, ':');
end
else
Host := s1;
end;
Result := '/' + s2;
x := Pos('?', s2);
if x > 0 then
begin
Path := '/' + SeparateLeft(s2, '?');
Para := SeparateRight(s2, '?');
end
else
Path := '/' + s2;
if Host = '' then
Host := 'localhost';
end;
{==============================================================================}
function ReplaceString(Value, Search, Replace: AnsiString): AnsiString;
var
x, l, ls, lr: Integer;
begin
if (Value = '') or (Search = '') then
begin
Result := Value;
Exit;
end;
ls := Length(Search);
lr := Length(Replace);
Result := '';
x := Pos(Search, Value);
while x > 0 do
begin
{$IFNDEF CIL}
l := Length(Result);
SetLength(Result, l + x - 1);
Move(Pointer(Value)^, Pointer(@Result[l + 1])^, x - 1);
{$ELSE}
Result:=Result+Copy(Value,1,x-1);
{$ENDIF}
{$IFNDEF CIL}
l := Length(Result);
SetLength(Result, l + lr);
Move(Pointer(Replace)^, Pointer(@Result[l + 1])^, lr);
{$ELSE}
Result:=Result+Replace;
{$ENDIF}
Delete(Value, 1, x - 1 + ls);
x := Pos(Search, Value);
end;
Result := Result + Value;
end;
{==============================================================================}
function RPosEx(const Sub, Value: string; From: integer): Integer;
var
n: Integer;
l: Integer;
begin
result := 0;
l := Length(Sub);
for n := From - l + 1 downto 1 do
begin
if Copy(Value, n, l) = Sub then
begin
result := n;
break;
end;
end;
end;
{==============================================================================}
function RPos(const Sub, Value: String): Integer;
begin
Result := RPosEx(Sub, Value, Length(Value));
end;
{==============================================================================}
function FetchBin(var Value: string; const Delimiter: string): string;
var
s: string;
begin
Result := SeparateLeft(Value, Delimiter);
s := SeparateRight(Value, Delimiter);
if s = Value then
Value := ''
else
Value := s;
end;
{==============================================================================}
function Fetch(var Value: string; const Delimiter: string): string;
begin
Result := FetchBin(Value, Delimiter);
Result := TrimSP(Result);
Value := TrimSP(Value);
end;
{==============================================================================}
function FetchEx(var Value: string; const Delimiter, Quotation: string): string;
var
b: Boolean;
begin
Result := '';
b := False;
while Length(Value) > 0 do
begin
if b then
begin
if Pos(Quotation, Value) = 1 then
b := False;
Result := Result + Value[1];
Delete(Value, 1, 1);
end
else
begin
if Pos(Delimiter, Value) = 1 then
begin
Delete(Value, 1, Length(delimiter));
break;
end;
b := Pos(Quotation, Value) = 1;
Result := Result + Value[1];
Delete(Value, 1, 1);
end;
end;
end;
{==============================================================================}
function IsBinaryString(const Value: AnsiString): Boolean;
var
n: integer;
begin
Result := False;
for n := 1 to Length(Value) do
if Value[n] in [#0..#8, #10..#31] then
//ignore null-terminated strings
if not ((n = Length(value)) and (Value[n] = AnsiChar(#0))) then
begin
Result := True;
Break;
end;
end;
{==============================================================================}
function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer;
var
n, l: integer;
begin
Result := -1;
Terminator := '';
l := length(value);
for n := 1 to l do
if value[n] in [#$0d, #$0a] then
begin
Result := n;
Terminator := Value[n];
if n <> l then
case value[n] of
#$0d:
if value[n + 1] = #$0a then
Terminator := #$0d + #$0a;
#$0a:
if value[n + 1] = #$0d then
Terminator := #$0a + #$0d;
end;
Break;
end;
end;
{==============================================================================}
Procedure StringsTrim(const Value: TStrings);
var
n: integer;
begin
for n := Value.Count - 1 downto 0 do
if Value[n] = '' then
Value.Delete(n)
else
Break;
end;
{==============================================================================}
function PosFrom(const SubStr, Value: String; From: integer): integer;
var
ls,lv: integer;
begin
Result := 0;
ls := Length(SubStr);
lv := Length(Value);
if (ls = 0) or (lv = 0) then
Exit;
if From < 1 then
From := 1;
while (ls + from - 1) <= (lv) do
begin
{$IFNDEF CIL}
if CompareMem(@SubStr[1],@Value[from],ls) then
{$ELSE}
if SubStr = copy(Value, from, ls) then
{$ENDIF}
begin
result := from;
break;
end
else
inc(from);
end;
end;
{==============================================================================}
{$IFNDEF CIL}
function IncPoint(const p: pointer; Value: integer): pointer;
begin
Result := PAnsiChar(p) + Value;
end;
{$ENDIF}
{==============================================================================}
//improved by 'DoggyDawg'
function GetBetween(const PairBegin, PairEnd, Value: string): string;
var
n: integer;
x: integer;
s: string;
lenBegin: integer;
lenEnd: integer;
str: string;
max: integer;
begin
lenBegin := Length(PairBegin);
lenEnd := Length(PairEnd);
n := Length(Value);
if (Value = PairBegin + PairEnd) then
begin
Result := '';//nothing between
exit;
end;
if (n < lenBegin + lenEnd) then
begin
Result := Value;
exit;
end;
s := SeparateRight(Value, PairBegin);
if (s = Value) then
begin
Result := Value;
exit;
end;
n := Pos(PairEnd, s);
if (n = 0) then
begin
Result := Value;
exit;
end;
Result := '';
x := 1;
max := Length(s) - lenEnd + 1;
for n := 1 to max do
begin
str := copy(s, n, lenEnd);
if (str = PairEnd) then
begin
Dec(x);
if (x <= 0) then
Break;
end;
str := copy(s, n, lenBegin);
if (str = PairBegin) then
Inc(x);
Result := Result + s[n];
end;
end;
{==============================================================================}
function CountOfChar(const Value: string; Chr: char): integer;
var
n: integer;
begin
Result := 0;
for n := 1 to Length(Value) do
if Value[n] = chr then
Inc(Result);
end;
{==============================================================================}
// ! do not use AnsiExtractQuotedStr, it's very buggy and can crash application!
function UnquoteStr(const Value: string; Quote: Char): string;
var
n: integer;
inq, dq: Boolean;
c, cn: char;
begin
Result := '';
if Value = '' then
Exit;
if Value = Quote + Quote then
Exit;
inq := False;
dq := False;
for n := 1 to Length(Value) do
begin
c := Value[n];
if n <> Length(Value) then
cn := Value[n + 1]
else
cn := #0;
if c = quote then
if dq then
dq := False
else
if not inq then
inq := True
else
if cn = quote then
begin
Result := Result + Quote;
dq := True;
end
else
inq := False
else
Result := Result + c;
end;
end;
{==============================================================================}
function QuoteStr(const Value: string; Quote: Char): string;
var
n: integer;
begin
Result := '';
for n := 1 to length(value) do
begin
Result := result + Value[n];
if value[n] = Quote then
Result := Result + Quote;
end;
Result := Quote + Result + Quote;
end;
{==============================================================================}
procedure HeadersToList(const Value: TStrings);
var
n, x, y: integer;
s: string;
begin
for n := 0 to Value.Count -1 do
begin
s := Value[n];
x := Pos(':', s);
if x > 0 then
begin
y:= Pos('=',s);
if not ((y > 0) and (y < x)) then
begin
s[x] := '=';
Value[n] := s;
end;
end;
end;
end;
{==============================================================================}
procedure ListToHeaders(const Value: TStrings);
var
n, x: integer;
s: string;
begin
for n := 0 to Value.Count -1 do
begin
s := Value[n];
x := Pos('=', s);
if x > 0 then
begin
s[x] := ':';
Value[n] := s;
end;
end;
end;
{==============================================================================}
function SwapBytes(Value: integer): integer;
var
s: AnsiString;
x, y, xl, yl: Byte;
begin
s := CodeLongInt(Value);
x := Ord(s[4]);
y := Ord(s[3]);
xl := Ord(s[2]);
yl := Ord(s[1]);
Result := ((x * 256 + y) * 65536) + (xl * 256 + yl);
end;
{==============================================================================}
function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString;
var
x: integer;
{$IFDEF CIL}
buf: Array of Byte;
{$ENDIF}
begin
{$IFDEF CIL}
Setlength(buf, Len);
x := Stream.read(buf, Len);
SetLength(buf, x);
Result := StringOf(Buf);
{$ELSE}
Setlength(Result, Len);
x := Stream.read(PAnsiChar(Result)^, Len);
SetLength(Result, x);
{$ENDIF}
end;
{==============================================================================}
procedure WriteStrToStream(const Stream: TStream; Value: AnsiString);
{$IFDEF CIL}
var
buf: Array of Byte;
{$ENDIF}
begin
{$IFDEF CIL}
buf := BytesOf(Value);
Stream.Write(buf,length(Value));
{$ELSE}
Stream.Write(PAnsiChar(Value)^, Length(Value));
{$ENDIF}
end;
{==============================================================================}
function GetTempFile(const Dir, prefix: AnsiString): AnsiString;
{$IFNDEF FPC}
{$IFDEF MSWINDOWS}
var
Path: AnsiString;
x: integer;
{$ENDIF}
{$ENDIF}
begin
{$IFDEF FPC}
Result := GetTempFileName(Dir, Prefix);
{$ELSE}
{$IFNDEF MSWINDOWS}
Result := tempnam(Pointer(Dir), Pointer(prefix));
{$ELSE}
{$IFDEF CIL}
Result := System.IO.Path.GetTempFileName;
{$ELSE}
if Dir = '' then
begin
SetLength(Path, MAX_PATH);
x := GetTempPath(Length(Path), PChar(Path));
SetLength(Path, x);
end
else
Path := Dir;
x := Length(Path);
if Path[x] <> '\' then
Path := Path + '\';
SetLength(Result, MAX_PATH + 1);
GetTempFileName(PChar(Path), PChar(Prefix), 0, PChar(Result));
Result := PChar(Result);
SetFileattributes(PChar(Result), GetFileAttributes(PChar(Result)) or FILE_ATTRIBUTE_TEMPORARY);
{$ENDIF}
{$ENDIF}
{$ENDIF}
end;
{==============================================================================}
function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString;
begin
if length(value) >= len then
Result := Copy(value, 1, len)
else
Result := Value + StringOfChar(Pad, len - length(value));
end;
{==============================================================================}
function NormalizeHeader(Value: TStrings; var Index: Integer): string;
var
s, t: string;
n: Integer;
begin
s := Value[Index];
Inc(Index);
if s <> '' then
while (Value.Count - 1) > Index do
begin
t := Value[Index];
if t = '' then
Break;
for n := 1 to Length(t) do
if t[n] = #9 then
t[n] := ' ';
if not(AnsiChar(t[1]) in [' ', '"', ':', '=']) then
Break
else
begin
s := s + ' ' + Trim(t);
Inc(Index);
end;
end;
Result := TrimRight(s);
end;
{==============================================================================}
var
n: integer;
begin
for n := 1 to 12 do
begin
CustomMonthNames[n] := ShortMonthNames[n];
MyMonthNames[0, n] := ShortMonthNames[n];
end;
end.
TransGUI/synapse/source/lib/ftpsend.pas 0000644 0000000 0000000 00000153052 11366572451 017130 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 003.005.003 |
|==============================================================================|
| Content: FTP client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Petr Esner |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{: @abstract(FTP client protocol)
Used RFC: RFC-959, RFC-2228, RFC-2428
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit ftpsend;
interface
uses
SysUtils, Classes,
blcksock, synautil, synaip, synsock;
const
cFtpProtocol = '21';
cFtpDataProtocol = '20';
{:Terminating value for TLogonActions}
FTP_OK = 255;
{:Terminating value for TLogonActions}
FTP_ERR = 254;
type
{:Array for holding definition of logon sequence.}
TLogonActions = array [0..17] of byte;
{:Procedural type for OnStatus event. Sender is calling @link(TFTPSend) object.
Value is FTP command or reply to this comand. (if it is reply, Response
is @True).}
TFTPStatus = procedure(Sender: TObject; Response: Boolean;
const Value: string) of object;
{: @abstract(Object for holding file information) parsed from directory
listing of FTP server.}
TFTPListRec = class(TObject)
private
FFileName: String;
FDirectory: Boolean;
FReadable: Boolean;
FFileSize: Longint;
FFileTime: TDateTime;
FOriginalLine: string;
FMask: string;
FPermission: String;
public
{: You can assign another TFTPListRec to this object.}
procedure Assign(Value: TFTPListRec); virtual;
{:name of file}
property FileName: string read FFileName write FFileName;
{:if name is subdirectory not file.}
property Directory: Boolean read FDirectory write FDirectory;
{:if you have rights to read}
property Readable: Boolean read FReadable write FReadable;
{:size of file in bytes}
property FileSize: Longint read FFileSize write FFileSize;
{:date and time of file. Local server timezone is used. Any timezone
conversions was not done!}
property FileTime: TDateTime read FFileTime write FFileTime;
{:original unparsed line}
property OriginalLine: string read FOriginalLine write FOriginalLine;
{:mask what was used for parsing}
property Mask: string read FMask write FMask;
{:permission string (depending on used mask!)}
property Permission: string read FPermission write FPermission;
end;
{:@abstract(This is TList of TFTPListRec objects.)
This object is used for holding lististing of all files information in listed
directory on FTP server.}
TFTPList = class(TObject)
protected
FList: TList;
FLines: TStringList;
FMasks: TStringList;
FUnparsedLines: TStringList;
Monthnames: string;
BlockSize: string;
DirFlagValue: string;
FileName: string;
VMSFileName: string;
Day: string;
Month: string;
ThreeMonth: string;
YearTime: string;
Year: string;
Hours: string;
HoursModif: Ansistring;
Minutes: string;
Seconds: string;
Size: Ansistring;
Permissions: Ansistring;
DirFlag: string;
function GetListItem(Index: integer): TFTPListRec; virtual;
function ParseEPLF(Value: string): Boolean; virtual;
procedure ClearStore; virtual;
function ParseByMask(Value, NextValue, Mask: ansistring): Integer; virtual;
function CheckValues: Boolean; virtual;
procedure FillRecord(const Value: TFTPListRec); virtual;
public
{:Constructor. You not need create this object, it is created by TFTPSend
class as their property.}
constructor Create;
destructor Destroy; override;
{:Clear list.}
procedure Clear; virtual;
{:count of holded @link(TFTPListRec) objects}
function Count: integer; virtual;
{:Assigns one list to another}
procedure Assign(Value: TFTPList); virtual;
{:try to parse raw directory listing in @link(lines) to list of
@link(TFTPListRec).}
procedure ParseLines; virtual;
{:By this property you have access to list of @link(TFTPListRec).
This is for compatibility only. Please, use @link(Items) instead.}
property List: TList read FList;
{:By this property you have access to list of @link(TFTPListRec).}
property Items[Index: Integer]: TFTPListRec read GetListItem; default;
{:Set of lines with RAW directory listing for @link(parseLines)}
property Lines: TStringList read FLines;
{:Set of masks for directory listing parser. It is predefined by default,
however you can modify it as you need. (for example, you can add your own
definition mask.) Mask is same as mask used in TotalCommander.}
property Masks: TStringList read FMasks;
{:After @link(ParseLines) it holding lines what was not sucessfully parsed.}
property UnparsedLines: TStringList read FUnparsedLines;
end;
{:@abstract(Implementation of FTP protocol.)
Note: Are you missing properties for setting Username and Password? Look to
parent @link(TSynaClient) object! (Username and Password have default values
for "anonymous" FTP login)
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TFTPSend = class(TSynaClient)
protected
FOnStatus: TFTPStatus;
FSock: TTCPBlockSocket;
FDSock: TTCPBlockSocket;
FResultCode: Integer;
FResultString: string;
FFullResult: TStringList;
FAccount: string;
FFWHost: string;
FFWPort: string;
FFWUsername: string;
FFWPassword: string;
FFWMode: integer;
FDataStream: TMemoryStream;
FDataIP: string;
FDataPort: string;
FDirectFile: Boolean;
FDirectFileName: string;
FCanResume: Boolean;
FPassiveMode: Boolean;
FForceDefaultPort: Boolean;
FForceOldPort: Boolean;
FFtpList: TFTPList;
FBinaryMode: Boolean;
FAutoTLS: Boolean;
FIsTLS: Boolean;
FIsDataTLS: Boolean;
FTLSonData: Boolean;
FFullSSL: Boolean;
function Auth(Mode: integer): Boolean; virtual;
function Connect: Boolean; virtual;
function InternalStor(const Command: string; RestoreAt: integer): Boolean; virtual;
function DataSocket: Boolean; virtual;
function AcceptDataSocket: Boolean; virtual;
procedure DoStatus(Response: Boolean; const Value: string); virtual;
public
{:Custom definition of login sequence. You can use this when you set
@link(FWMode) to value -1.}
CustomLogon: TLogonActions;
constructor Create;
destructor Destroy; override;
{:Waits and read FTP server response. You need this only in special cases!}
function ReadResult: Integer; virtual;
{:Parse remote side information of data channel from value string (returned
by PASV command). This function you need only in special cases!}
procedure ParseRemote(Value: string); virtual;
{:Parse remote side information of data channel from value string (returned
by EPSV command). This function you need only in special cases!}
procedure ParseRemoteEPSV(Value: string); virtual;
{:Send Value as FTP command to FTP server. Returned result code is result of
this function.
This command is good for sending site specific command, or non-standard
commands.}
function FTPCommand(const Value: string): integer; virtual;
{:Connect and logon to FTP server. If you specify any FireWall, connect to
firewall and throw them connect to FTP server. Login sequence depending on
@link(FWMode).}
function Login: Boolean; virtual;
{:Logoff and disconnect from FTP server.}
function Logout: Boolean; virtual;
{:Break current transmission of data. (You can call this method from
Sock.OnStatus event, or from another thread.)}
procedure Abort; virtual;
{:Break current transmission of data. It is same as Abort, but it send abort
telnet commands prior ABOR FTP command. Some servers need it. (You can call
this method from Sock.OnStatus event, or from another thread.)}
procedure TelnetAbort; virtual;
{:Download directory listing of Directory on FTP server. If Directory is
empty string, download listing of current working directory.
If NameList is @true, download only names of files in directory.
(internally use NLST command instead LIST command)
If NameList is @false, returned list is also parsed to @link(FTPList)
property.}
function List(Directory: string; NameList: Boolean): Boolean; virtual;
{:Read data from FileName on FTP server. If Restore is @true and server
supports resume dowloads, download is resumed. (received is only rest
of file)}
function RetrieveFile(const FileName: string; Restore: Boolean): Boolean; virtual;
{:Send data to FileName on FTP server. If Restore is @true and server
supports resume upload, upload is resumed. (send only rest of file)
In this case if remote file is same length as local file, nothing will be
done. If remote file is larger then local, resume is disabled and file is
transfered from begin!}
function StoreFile(const FileName: string; Restore: Boolean): Boolean; virtual;
{:Send data to FTP server and assing unique name for this file.}
function StoreUniqueFile: Boolean; virtual;
{:Append data to FileName on FTP server.}
function AppendFile(const FileName: string): Boolean; virtual;
{:Rename on FTP server file with OldName to NewName.}
function RenameFile(const OldName, NewName: string): Boolean; virtual;
{:Delete file FileName on FTP server.}
function DeleteFile(const FileName: string): Boolean; virtual;
{:Return size of Filename file on FTP server. If command failed (i.e. not
implemented), return -1.}
function FileSize(const FileName: string): integer; virtual;
{:Send NOOP command to FTP server for preserve of disconnect by inactivity
timeout.}
function NoOp: Boolean; virtual;
{:Change currect working directory to Directory on FTP server.}
function ChangeWorkingDir(const Directory: string): Boolean; virtual;
{:walk to upper directory on FTP server.}
function ChangeToParentDir: Boolean; virtual;
{:walk to root directory on FTP server. (May not work with all servers properly!)}
function ChangeToRootDir: Boolean; virtual;
{:Delete Directory on FTP server.}
function DeleteDir(const Directory: string): Boolean; virtual;
{:Create Directory on FTP server.}
function CreateDir(const Directory: string): Boolean; virtual;
{:Return current working directory on FTP server.}
function GetCurrentDir: String; virtual;
{:Establish data channel to FTP server and retrieve data.
This function you need only in special cases, i.e. when you need to implement
some special unsupported FTP command!}
function DataRead(const DestStream: TStream): Boolean; virtual;
{:Establish data channel to FTP server and send data.
This function you need only in special cases, i.e. when you need to implement
some special unsupported FTP command.}
function DataWrite(const SourceStream: TStream): Boolean; virtual;
published
{:After FTP command contains result number of this operation.}
property ResultCode: Integer read FResultCode;
{:After FTP command contains main line of result.}
property ResultString: string read FResultString;
{:After any FTP command it contains all lines of FTP server reply.}
property FullResult: TStringList read FFullResult;
{:Account information used in some cases inside login sequence.}
property Account: string read FAccount Write FAccount;
{:Address of firewall. If empty string (default), firewall not used.}
property FWHost: string read FFWHost Write FFWHost;
{:port of firewall. standard value is same port as ftp server used. (21)}
property FWPort: string read FFWPort Write FFWPort;
{:Username for login to firewall. (if needed)}
property FWUsername: string read FFWUsername Write FFWUsername;
{:password for login to firewall. (if needed)}
property FWPassword: string read FFWPassword Write FFWPassword;
{:Type of Firewall. Used only if you set some firewall address. Supported
predefined firewall login sequences are described by comments in source
file where you can see pseudocode decribing each sequence.}
property FWMode: integer read FFWMode Write FFWMode;
{:Socket object used for TCP/IP operation on control channel. Good for
seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
{:Socket object used for TCP/IP operation on data channel. Good for seting
OnStatus hook, etc.}
property DSock: TTCPBlockSocket read FDSock;
{:If you not use @link(DirectFile) mode, all data transfers is made to or
from this stream.}
property DataStream: TMemoryStream read FDataStream;
{:After data connection is established, contains remote side IP of this
connection.}
property DataIP: string read FDataIP;
{:After data connection is established, contains remote side port of this
connection.}
property DataPort: string read FDataPort;
{:Mode of data handling by data connection. If @False, all data operations
are made to or from @link(DataStream) TMemoryStream.
If @true, data operations is made directly to file in your disk. (filename
is specified by @link(DirectFileName) property.) Dafault is @False!}
property DirectFile: Boolean read FDirectFile Write FDirectFile;
{:Filename for direct disk data operations.}
property DirectFileName: string read FDirectFileName Write FDirectFileName;
{:Indicate after @link(Login) if remote server support resume downloads and
uploads.}
property CanResume: Boolean read FCanResume;
{:If true (default value), all transfers is made by passive method.
It is safer method for various firewalls.}
property PassiveMode: Boolean read FPassiveMode Write FPassiveMode;
{:Force to listen for dataconnection on standard port (20). Default is @false,
dataconnections will be made to any non-standard port reported by PORT FTP
command. This setting is not used, if you use passive mode.}
property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort;
{:When is @true, then is disabled EPSV and EPRT support. However without this
commands you cannot use IPv6! (Disabling of this commands is needed only
when you are behind some crap firewall/NAT.}
property ForceOldPort: Boolean read FForceOldPort Write FForceOldPort;
{:You may set this hook for monitoring FTP commands and replies.}
property OnStatus: TFTPStatus read FOnStatus write FOnStatus;
{:After LIST command is here parsed list of files in given directory.}
property FtpList: TFTPList read FFtpList;
{:if @true (default), then data transfers is in binary mode. If this is set
to @false, then ASCII mode is used.}
property BinaryMode: Boolean read FBinaryMode Write FBinaryMode;
{:if is true, then if server support upgrade to SSL/TLS mode, then use them.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:if server listen on SSL/TLS port, then you set this to true.}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{:Signalise, if control channel is in SSL/TLS mode.}
property IsTLS: Boolean read FIsTLS;
{:Signalise, if data transfers is in SSL/TLS mode.}
property IsDataTLS: Boolean read FIsDataTLS;
{:If @true (default), then try to use SSL/TLS on data transfers too.
If @false, then SSL/TLS is used only for control connection.}
property TLSonData: Boolean read FTLSonData write FTLSonData;
end;
{:A very useful function, and example of use can be found in the TFtpSend object.
Dowload specified file from FTP server to LocalFile.}
function FtpGetFile(const IP, Port, FileName, LocalFile,
User, Pass: string): Boolean;
{:A very useful function, and example of use can be found in the TFtpSend object.
Upload specified LocalFile to FTP server.}
function FtpPutFile(const IP, Port, FileName, LocalFile,
User, Pass: string): Boolean;
{:A very useful function, and example of use can be found in the TFtpSend object.
Initiate transfer of file between two FTP servers.}
function FtpInterServerTransfer(
const FromIP, FromPort, FromFile, FromUser, FromPass: string;
const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean;
implementation
constructor TFTPSend.Create;
begin
inherited Create;
FFullResult := TStringList.Create;
FDataStream := TMemoryStream.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := True;
FDSock := TTCPBlockSocket.Create;
FDSock.Owner := self;
FFtpList := TFTPList.Create;
FTimeout := 300000;
FTargetPort := cFtpProtocol;
FUsername := 'anonymous';
FPassword := 'anonymous@' + FSock.LocalName;
FDirectFile := False;
FPassiveMode := True;
FForceDefaultPort := False;
FForceOldPort := false;
FAccount := '';
FFWHost := '';
FFWPort := cFtpProtocol;
FFWUsername := '';
FFWPassword := '';
FFWMode := 0;
FBinaryMode := True;
FAutoTLS := False;
FFullSSL := False;
FIsTLS := False;
FIsDataTLS := False;
FTLSonData := True;
end;
destructor TFTPSend.Destroy;
begin
FDSock.Free;
FSock.Free;
FFTPList.Free;
FDataStream.Free;
FFullResult.Free;
inherited Destroy;
end;
procedure TFTPSend.DoStatus(Response: Boolean; const Value: string);
begin
if assigned(OnStatus) then
OnStatus(Self, Response, Value);
end;
function TFTPSend.ReadResult: Integer;
var
s, c: AnsiString;
begin
FFullResult.Clear;
c := '';
repeat
s := FSock.RecvString(FTimeout);
if c = '' then
if length(s) > 3 then
if s[4] in [' ', '-'] then
c :=Copy(s, 1, 3);
FResultString := s;
FFullResult.Add(s);
DoStatus(True, s);
if FSock.LastError <> 0 then
Break;
until (c <> '') and (Pos(c + ' ', s) = 1);
Result := StrToIntDef(c, 0);
FResultCode := Result;
end;
function TFTPSend.FTPCommand(const Value: string): integer;
begin
FSock.Purge;
FSock.SendString(Value + CRLF);
DoStatus(False, Value);
Result := ReadResult;
end;
// based on idea by Petr Esner
function TFTPSend.Auth(Mode: integer): Boolean;
const
//if not USER then
// if not PASS then
// if not ACCT then ERROR!
//OK!
Action0: TLogonActions =
(0, FTP_OK, 3,
1, FTP_OK, 6,
2, FTP_OK, FTP_ERR,
0, 0, 0, 0, 0, 0, 0, 0, 0);
//if not USER then
// if not PASS then ERROR!
//if SITE then ERROR!
//if not USER then
// if not PASS then
// if not ACCT then ERROR!
//OK!
Action1: TLogonActions =
(3, 6, 3,
4, 6, FTP_ERR,
5, FTP_ERR, 9,
0, FTP_OK, 12,
1, FTP_OK, 15,
2, FTP_OK, FTP_ERR);
//if not USER then
// if not PASS then ERROR!
//if USER '@' then OK!
//if not PASS then
// if not ACCT then ERROR!
//OK!
Action2: TLogonActions =
(3, 6, 3,
4, 6, FTP_ERR,
6, FTP_OK, 9,
1, FTP_OK, 12,
2, FTP_OK, FTP_ERR,
0, 0, 0);
//if not USER then
// if not PASS then ERROR!
//if not USER then
// if not PASS then
// if not ACCT then ERROR!
//OK!
Action3: TLogonActions =
(3, 6, 3,
4, 6, FTP_ERR,
0, FTP_OK, 9,
1, FTP_OK, 12,
2, FTP_OK, FTP_ERR,
0, 0, 0);
//OPEN
//if not USER then
// if not PASS then
// if not ACCT then ERROR!
//OK!
Action4: TLogonActions =
(7, 3, 3,
0, FTP_OK, 6,
1, FTP_OK, 9,
2, FTP_OK, FTP_ERR,
0, 0, 0, 0, 0, 0);
//if USER '@' then OK!
//if not PASS then
// if not ACCT then ERROR!
//OK!
Action5: TLogonActions =
(6, FTP_OK, 3,
1, FTP_OK, 6,
2, FTP_OK, FTP_ERR,
0, 0, 0, 0, 0, 0, 0, 0, 0);
//if not USER @ then
// if not PASS then ERROR!
//if not USER then
// if not PASS then
// if not ACCT then ERROR!
//OK!
Action6: TLogonActions =
(8, 6, 3,
4, 6, FTP_ERR,
0, FTP_OK, 9,
1, FTP_OK, 12,
2, FTP_OK, FTP_ERR,
0, 0, 0);
//if USER @ then ERROR!
//if not PASS then
// if not ACCT then ERROR!
//OK!
Action7: TLogonActions =
(9, FTP_ERR, 3,
1, FTP_OK, 6,
2, FTP_OK, FTP_ERR,
0, 0, 0, 0, 0, 0, 0, 0, 0);
//if not USER @@ then
// if not PASS @ then
// if not ACCT then ERROR!
//OK!
Action8: TLogonActions =
(10, FTP_OK, 3,
11, FTP_OK, 6,
2, FTP_OK, FTP_ERR,
0, 0, 0, 0, 0, 0, 0, 0, 0);
var
FTPServer: string;
LogonActions: TLogonActions;
i: integer;
s: string;
x: integer;
begin
Result := False;
if FFWHost = '' then
Mode := 0;
if (FTargetPort = cFtpProtocol) or (FTargetPort = '21') then
FTPServer := FTargetHost
else
FTPServer := FTargetHost + ':' + FTargetPort;
case Mode of
-1:
LogonActions := CustomLogon;
1:
LogonActions := Action1;
2:
LogonActions := Action2;
3:
LogonActions := Action3;
4:
LogonActions := Action4;
5:
LogonActions := Action5;
6:
LogonActions := Action6;
7:
LogonActions := Action7;
8:
LogonActions := Action8;
else
LogonActions := Action0;
end;
i := 0;
repeat
case LogonActions[i] of
0: s := 'USER ' + FUserName;
1: s := 'PASS ' + FPassword;
2: s := 'ACCT ' + FAccount;
3: s := 'USER ' + FFWUserName;
4: s := 'PASS ' + FFWPassword;
5: s := 'SITE ' + FTPServer;
6: s := 'USER ' + FUserName + '@' + FTPServer;
7: s := 'OPEN ' + FTPServer;
8: s := 'USER ' + FFWUserName + '@' + FTPServer;
9: s := 'USER ' + FUserName + '@' + FTPServer + ' ' + FFWUserName;
10: s := 'USER ' + FUserName + '@' + FFWUserName + '@' + FTPServer;
11: s := 'PASS ' + FPassword + '@' + FFWPassword;
end;
x := FTPCommand(s);
x := x div 100;
if (x <> 2) and (x <> 3) then
Exit;
i := LogonActions[i + x - 1];
case i of
FTP_ERR:
Exit;
FTP_OK:
begin
Result := True;
Exit;
end;
end;
until False;
end;
function TFTPSend.Connect: Boolean;
begin
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError = 0 then
if FFWHost = '' then
FSock.Connect(FTargetHost, FTargetPort)
else
FSock.Connect(FFWHost, FFWPort);
if FSock.LastError = 0 then
if FFullSSL then
FSock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
function TFTPSend.Login: Boolean;
var
x: integer;
begin
Result := False;
FCanResume := False;
if not Connect then
Exit;
FIsTLS := FFullSSL;
FIsDataTLS := False;
repeat
x := ReadResult div 100;
until x <> 1;
if x <> 2 then
Exit;
if FAutoTLS and not(FIsTLS) then
if (FTPCommand('AUTH TLS') div 100) = 2 then
begin
FSock.SSLDoConnect;
FIsTLS := FSock.LastError = 0;
if not FIsTLS then
begin
Result := False;
Exit;
end;
end;
if not Auth(FFWMode) then
Exit;
if FIsTLS then
begin
FTPCommand('PBSZ 0');
if FTLSonData then
FIsDataTLS := (FTPCommand('PROT P') div 100) = 2;
if not FIsDataTLS then
FTPCommand('PROT C');
end;
FTPCommand('TYPE I');
FTPCommand('STRU F');
FTPCommand('MODE S');
if FTPCommand('REST 0') = 350 then
if FTPCommand('REST 1') = 350 then
begin
FTPCommand('REST 0');
FCanResume := True;
end;
Result := True;
end;
function TFTPSend.Logout: Boolean;
begin
Result := (FTPCommand('QUIT') div 100) = 2;
FSock.CloseSocket;
end;
procedure TFTPSend.ParseRemote(Value: string);
var
n: integer;
nb, ne: integer;
s: string;
x: integer;
begin
Value := trim(Value);
nb := Pos('(',Value);
ne := Pos(')',Value);
if (nb = 0) or (ne = 0) then
begin
nb:=RPos(' ',Value);
s:=Copy(Value, nb + 1, Length(Value) - nb);
end
else
begin
s:=Copy(Value,nb+1,ne-nb-1);
end;
for n := 1 to 4 do
if n = 1 then
FDataIP := Fetch(s, ',')
else
FDataIP := FDataIP + '.' + Fetch(s, ',');
x := StrToIntDef(Fetch(s, ','), 0) * 256;
x := x + StrToIntDef(Fetch(s, ','), 0);
FDataPort := IntToStr(x);
end;
procedure TFTPSend.ParseRemoteEPSV(Value: string);
var
n: integer;
s, v: AnsiString;
begin
s := SeparateRight(Value, '(');
s := Trim(SeparateLeft(s, ')'));
Delete(s, Length(s), 1);
v := '';
for n := Length(s) downto 1 do
if s[n] in ['0'..'9'] then
v := s[n] + v
else
Break;
FDataPort := v;
FDataIP := FTargetHost;
end;
function TFTPSend.DataSocket: boolean;
var
s: string;
begin
Result := False;
if FIsDataTLS then
FPassiveMode := True;
if FPassiveMode then
begin
if FSock.IP6used then
s := '2'
else
s := '1';
if not(FForceOldPort) and ((FTPCommand('EPSV ' + s) div 100) = 2) then
begin
ParseRemoteEPSV(FResultString);
end
else
if FSock.IP6used then
Exit
else
begin
if (FTPCommand('PASV') div 100) <> 2 then
Exit;
ParseRemote(FResultString);
end;
FDSock.CloseSocket;
FDSock.Bind(FIPInterface, cAnyPort);
FDSock.Connect(FDataIP, FDataPort);
Result := FDSock.LastError = 0;
end
else
begin
FDSock.CloseSocket;
if FForceDefaultPort then
s := cFtpDataProtocol
else
s := '0';
//data conection from same interface as command connection
FDSock.Bind(FSock.GetLocalSinIP, s);
if FDSock.LastError <> 0 then
Exit;
FDSock.SetLinger(True, 10000);
FDSock.Listen;
FDSock.GetSins;
FDataIP := FDSock.GetLocalSinIP;
FDataIP := FDSock.ResolveName(FDataIP);
FDataPort := IntToStr(FDSock.GetLocalSinPort);
if not FForceOldPort then
begin
if IsIp6(FDataIP) then
s := '2'
else
s := '1';
s := 'EPRT |' + s +'|' + FDataIP + '|' + FDataPort + '|';
Result := (FTPCommand(s) div 100) = 2;
end;
if not Result and IsIP(FDataIP) then
begin
s := ReplaceString(FDataIP, '.', ',');
s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256)
+ ',' + IntToStr(FDSock.GetLocalSinPort mod 256);
Result := (FTPCommand(s) div 100) = 2;
end;
end;
end;
function TFTPSend.AcceptDataSocket: Boolean;
var
x: TSocket;
begin
if FPassiveMode then
Result := True
else
begin
Result := False;
if FDSock.CanRead(FTimeout) then
begin
x := FDSock.Accept;
if not FDSock.UsingSocks then
FDSock.CloseSocket;
FDSock.Socket := x;
Result := True;
end;
end;
if Result and FIsDataTLS then
begin
FDSock.SSL.Assign(FSock.SSL);
FDSock.SSLDoConnect;
Result := FDSock.LastError = 0;
end;
end;
function TFTPSend.DataRead(const DestStream: TStream): Boolean;
var
x: integer;
begin
Result := False;
try
if not AcceptDataSocket then
Exit;
FDSock.RecvStreamRaw(DestStream, FTimeout);
FDSock.CloseSocket;
x := ReadResult;
Result := (x div 100) = 2;
finally
FDSock.CloseSocket;
end;
end;
function TFTPSend.DataWrite(const SourceStream: TStream): Boolean;
var
x: integer;
b: Boolean;
begin
Result := False;
try
if not AcceptDataSocket then
Exit;
FDSock.SendStreamRaw(SourceStream);
b := FDSock.LastError = 0;
FDSock.CloseSocket;
x := ReadResult;
Result := b and ((x div 100) = 2);
finally
FDSock.CloseSocket;
end;
end;
function TFTPSend.List(Directory: string; NameList: Boolean): Boolean;
var
x: integer;
begin
Result := False;
FDataStream.Clear;
FFTPList.Clear;
if Directory <> '' then
Directory := ' ' + Directory;
FTPCommand('TYPE A');
if not DataSocket then
Exit;
if NameList then
x := FTPCommand('NLST' + Directory)
else
x := FTPCommand('LIST' + Directory);
if (x div 100) <> 1 then
Exit;
Result := DataRead(FDataStream);
if (not NameList) and Result then
begin
FDataStream.Position := 0;
FFTPList.Lines.LoadFromStream(FDataStream);
FFTPList.ParseLines;
end;
FDataStream.Position := 0;
end;
function TFTPSend.RetrieveFile(const FileName: string; Restore: Boolean): Boolean;
var
RetrStream: TStream;
begin
Result := False;
if FileName = '' then
Exit;
if not DataSocket then
Exit;
Restore := Restore and FCanResume;
if FDirectFile then
if Restore and FileExists(FDirectFileName) then
RetrStream := TFileStream.Create(FDirectFileName,
fmOpenReadWrite or fmShareExclusive)
else
RetrStream := TFileStream.Create(FDirectFileName,
fmCreate or fmShareDenyWrite)
else
RetrStream := FDataStream;
try
if FBinaryMode then
FTPCommand('TYPE I')
else
FTPCommand('TYPE A');
if Restore then
begin
RetrStream.Position := RetrStream.Size;
if (FTPCommand('REST ' + IntToStr(RetrStream.Size)) div 100) <> 3 then
Exit;
end
else
if RetrStream is TMemoryStream then
TMemoryStream(RetrStream).Clear;
if (FTPCommand('RETR ' + FileName) div 100) <> 1 then
Exit;
Result := DataRead(RetrStream);
if not FDirectFile then
RetrStream.Position := 0;
finally
if FDirectFile then
RetrStream.Free;
end;
end;
function TFTPSend.InternalStor(const Command: string; RestoreAt: integer): Boolean;
var
SendStream: TStream;
StorSize: integer;
begin
Result := False;
if FDirectFile then
if not FileExists(FDirectFileName) then
Exit
else
SendStream := TFileStream.Create(FDirectFileName,
fmOpenRead or fmShareDenyWrite)
else
SendStream := FDataStream;
try
if not DataSocket then
Exit;
if FBinaryMode then
FTPCommand('TYPE I')
else
FTPCommand('TYPE A');
StorSize := SendStream.Size;
if not FCanResume then
RestoreAt := 0;
if (StorSize > 0) and (RestoreAt = StorSize) then
begin
Result := True;
Exit;
end;
if RestoreAt > StorSize then
RestoreAt := 0;
FTPCommand('ALLO ' + IntToStr(StorSize - RestoreAt));
if FCanResume then
if (FTPCommand('REST ' + IntToStr(RestoreAt)) div 100) <> 3 then
Exit;
SendStream.Position := RestoreAt;
if (FTPCommand(Command) div 100) <> 1 then
Exit;
Result := DataWrite(SendStream);
finally
if FDirectFile then
SendStream.Free;
end;
end;
function TFTPSend.StoreFile(const FileName: string; Restore: Boolean): Boolean;
var
RestoreAt: integer;
begin
Result := False;
if FileName = '' then
Exit;
RestoreAt := 0;
Restore := Restore and FCanResume;
if Restore then
begin
RestoreAt := Self.FileSize(FileName);
if RestoreAt < 0 then
RestoreAt := 0;
end;
Result := InternalStor('STOR ' + FileName, RestoreAt);
end;
function TFTPSend.StoreUniqueFile: Boolean;
begin
Result := InternalStor('STOU', 0);
end;
function TFTPSend.AppendFile(const FileName: string): Boolean;
begin
Result := False;
if FileName = '' then
Exit;
Result := InternalStor('APPE '+FileName, 0);
end;
function TFTPSend.NoOp: Boolean;
begin
Result := (FTPCommand('NOOP') div 100) = 2;
end;
function TFTPSend.RenameFile(const OldName, NewName: string): Boolean;
begin
Result := False;
if (FTPCommand('RNFR ' + OldName) div 100) <> 3 then
Exit;
Result := (FTPCommand('RNTO ' + NewName) div 100) = 2;
end;
function TFTPSend.DeleteFile(const FileName: string): Boolean;
begin
Result := (FTPCommand('DELE ' + FileName) div 100) = 2;
end;
function TFTPSend.FileSize(const FileName: string): integer;
var
s: string;
begin
Result := -1;
if (FTPCommand('SIZE ' + FileName) div 100) = 2 then
begin
s := Trim(SeparateRight(ResultString, ' '));
s := Trim(SeparateLeft(s, ' '));
Result := StrToIntDef(s, -1);
end;
end;
function TFTPSend.ChangeWorkingDir(const Directory: string): Boolean;
begin
Result := (FTPCommand('CWD ' + Directory) div 100) = 2;
end;
function TFTPSend.ChangeToParentDir: Boolean;
begin
Result := (FTPCommand('CDUP') div 100) = 2;
end;
function TFTPSend.ChangeToRootDir: Boolean;
begin
Result := ChangeWorkingDir('/');
end;
function TFTPSend.DeleteDir(const Directory: string): Boolean;
begin
Result := (FTPCommand('RMD ' + Directory) div 100) = 2;
end;
function TFTPSend.CreateDir(const Directory: string): Boolean;
begin
Result := (FTPCommand('MKD ' + Directory) div 100) = 2;
end;
function TFTPSend.GetCurrentDir: String;
begin
Result := '';
if (FTPCommand('PWD') div 100) = 2 then
begin
Result := SeparateRight(FResultString, '"');
Result := Trim(Separateleft(Result, '"'));
end;
end;
procedure TFTPSend.Abort;
begin
FSock.SendString('ABOR' + CRLF);
FDSock.StopFlag := True;
end;
procedure TFTPSend.TelnetAbort;
begin
FSock.SendString(#$FF + #$F4 + #$FF + #$F2);
Abort;
end;
{==============================================================================}
procedure TFTPListRec.Assign(Value: TFTPListRec);
begin
FFileName := Value.FileName;
FDirectory := Value.Directory;
FReadable := Value.Readable;
FFileSize := Value.FileSize;
FFileTime := Value.FileTime;
FOriginalLine := Value.OriginalLine;
FMask := Value.Mask;
end;
constructor TFTPList.Create;
begin
inherited Create;
FList := TList.Create;
FLines := TStringList.Create;
FMasks := TStringList.Create;
FUnparsedLines := TStringList.Create;
//various UNIX
FMasks.add('pppppppppp $!!!S*$TTT$DD$hh mm ss$YYYY$n*');
FMasks.add('pppppppppp $!!!S*$DD$TTT$hh mm ss$YYYY$n*');
FMasks.add('pppppppppp $!!!S*$TTT$DD$UUUUU$n*'); //mostly used UNIX format
FMasks.add('pppppppppp $!!!S*$DD$TTT$UUUUU$n*');
//MacOS
FMasks.add('pppppppppp $!!S*$TTT$DD$UUUUU$n*');
FMasks.add('pppppppppp $!S*$TTT$DD$UUUUU$n*');
//Novell
FMasks.add('d $!S*$TTT$DD$UUUUU$n*');
//Windows
FMasks.add('MM DD YY hh mmH !S* n*');
FMasks.add('MM DD YY hh mmH $ d!n*');
FMasks.add('MM DD YYYY hh mmH !S* n*');
FMasks.add('MM DD YYYY hh mmH $ d!n*');
FMasks.add('DD MM YYYY hh mmH !S* n*');
FMasks.add('DD MM YYYY hh mmH $ d!n*');
//VMS
FMasks.add('v*$ DD TTT YYYY hh mm');
FMasks.add('v*$!DD TTT YYYY hh mm');
FMasks.add('n*$ YYYY MM DD hh mm$S*');
//AS400
FMasks.add('!S*$MM DD YY hh mm ss !n*');
FMasks.add('!S*$DD MM YY hh mm ss !n*');
FMasks.add('n*!S*$MM DD YY hh mm ss d');
FMasks.add('n*!S*$DD MM YY hh mm ss d');
//VxWorks
FMasks.add('$S* TTT DD YYYY hh mm ss $n* $ d');
FMasks.add('$S* TTT DD YYYY hh mm ss $n*');
//Distinct
FMasks.add('d $S*$TTT DD YYYY hh mm$n*');
FMasks.add('d $S*$TTT DD$hh mm$n*');
//PC-NFSD
FMasks.add('nnnnnnnn.nnn dSSSSSSSSSSS MM DD YY hh mmH');
//VOS
FMasks.add('- SSSSS YY MM DD hh mm ss n*');
FMasks.add('- d= SSSSS YY MM DD hh mm ss n*');
//Unissys ClearPath
FMasks.add('nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn SSSSSSSSS MM DD YYYY hh mm');
FMasks.add('n*\x SSSSSSSSS MM DD YYYY hh mm');
//IBM
FMasks.add('- SSSSSSSSSSSS d MM DD YYYY hh mm n*');
//OS9
FMasks.add('- YY MM DD hhmm d SSSSSSSSS n*');
//tandem
FMasks.add('nnnnnnnn SSSSSSS DD TTT YY hh mm ss');
//MVS
FMasks.add('- YYYY MM DD SSSSS d=O n*');
//BullGCOS8
FMasks.add(' $S* MM DD YY hh mm ss !n*');
FMasks.add('d $S* MM DD YY !n*');
//BullGCOS7
FMasks.add(' TTT DD YYYY n*');
FMasks.add(' d n*');
end;
destructor TFTPList.Destroy;
begin
Clear;
FList.Free;
FLines.Free;
FMasks.Free;
FUnparsedLines.Free;
inherited Destroy;
end;
procedure TFTPList.Clear;
var
n:integer;
begin
for n := 0 to FList.Count - 1 do
if Assigned(FList[n]) then
TFTPListRec(FList[n]).Free;
FList.Clear;
FLines.Clear;
FUnparsedLines.Clear;
end;
function TFTPList.Count: integer;
begin
Result := FList.Count;
end;
function TFTPList.GetListItem(Index: integer): TFTPListRec;
begin
Result := nil;
if Index < Count then
Result := TFTPListRec(FList[Index]);
end;
procedure TFTPList.Assign(Value: TFTPList);
var
flr: TFTPListRec;
n: integer;
begin
Clear;
for n := 0 to Value.Count - 1 do
begin
flr := TFTPListRec.Create;
flr.Assign(Value[n]);
Flist.Add(flr);
end;
Lines.Assign(Value.Lines);
Masks.Assign(Value.Masks);
UnparsedLines.Assign(Value.UnparsedLines);
end;
procedure TFTPList.ClearStore;
begin
Monthnames := '';
BlockSize := '';
DirFlagValue := '';
FileName := '';
VMSFileName := '';
Day := '';
Month := '';
ThreeMonth := '';
YearTime := '';
Year := '';
Hours := '';
HoursModif := '';
Minutes := '';
Seconds := '';
Size := '';
Permissions := '';
DirFlag := '';
end;
function TFTPList.ParseByMask(Value, NextValue, Mask: AnsiString): Integer;
var
Ivalue, IMask: integer;
MaskC, LastMaskC: AnsiChar;
c: AnsiChar;
s: string;
begin
ClearStore;
Result := 0;
if Value = '' then
Exit;
if Mask = '' then
Exit;
Ivalue := 1;
IMask := 1;
Result := 1;
LastMaskC := ' ';
while Imask <= Length(mask) do
begin
if (Mask[Imask] <> '*') and (Ivalue > Length(Value)) then
begin
Result := 0;
Exit;
end;
MaskC := Mask[Imask];
if Ivalue > Length(Value) then
Exit;
c := Value[Ivalue];
case MaskC of
'n':
FileName := FileName + c;
'v':
VMSFileName := VMSFileName + c;
'.':
begin
if c in ['.', ' '] then
FileName := TrimSP(FileName) + '.'
else
begin
Result := 0;
Exit;
end;
end;
'D':
Day := Day + c;
'M':
Month := Month + c;
'T':
ThreeMonth := ThreeMonth + c;
'U':
YearTime := YearTime + c;
'Y':
Year := Year + c;
'h':
Hours := Hours + c;
'H':
HoursModif := HoursModif + c;
'm':
Minutes := Minutes + c;
's':
Seconds := Seconds + c;
'S':
Size := Size + c;
'p':
Permissions := Permissions + c;
'd':
DirFlag := DirFlag + c;
'x':
if c <> ' ' then
begin
Result := 0;
Exit;
end;
'*':
begin
s := '';
if LastMaskC in ['n', 'v'] then
begin
if Imask = Length(Mask) then
s := Copy(Value, IValue, Maxint)
else
while IValue <= Length(Value) do
begin
if Value[Ivalue] = ' ' then
break;
s := s + Value[Ivalue];
Inc(Ivalue);
end;
if LastMaskC = 'n' then
FileName := FileName + s
else
VMSFileName := VMSFileName + s;
end
else
begin
while IValue <= Length(Value) do
begin
if not(Value[Ivalue] in ['0'..'9']) then
break;
s := s + Value[Ivalue];
Inc(Ivalue);
end;
case LastMaskC of
'S':
Size := Size + s;
end;
end;
Dec(IValue);
end;
'!':
begin
while IValue <= Length(Value) do
begin
if Value[Ivalue] = ' ' then
break;
Inc(Ivalue);
end;
while IValue <= Length(Value) do
begin
if Value[Ivalue] <> ' ' then
break;
Inc(Ivalue);
end;
Dec(IValue);
end;
'$':
begin
while IValue <= Length(Value) do
begin
if not(Value[Ivalue] in [' ', #9]) then
break;
Inc(Ivalue);
end;
Dec(IValue);
end;
'=':
begin
s := '';
case LastmaskC of
'S':
begin
while Imask <= Length(Mask) do
begin
if not(Mask[Imask] in ['0'..'9']) then
break;
s := s + Mask[Imask];
Inc(Imask);
end;
Dec(Imask);
BlockSize := s;
end;
'T':
begin
Monthnames := Copy(Mask, IMask, 12 * 3);
Inc(IMask, 12 * 3);
end;
'd':
begin
Inc(Imask);
DirFlagValue := Mask[Imask];
end;
end;
end;
'\':
begin
Value := NextValue;
IValue := 0;
Result := 2;
end;
end;
Inc(Ivalue);
Inc(Imask);
LastMaskC := MaskC;
end;
end;
function TFTPList.CheckValues: Boolean;
var
x, n: integer;
begin
Result := false;
if FileName <> '' then
begin
if pos('?', VMSFilename) > 0 then
Exit;
if pos('*', VMSFilename) > 0 then
Exit;
end;
if VMSFileName <> '' then
if pos(';', VMSFilename) <= 0 then
Exit;
if (FileName = '') and (VMSFileName = '') then
Exit;
if Permissions <> '' then
begin
if length(Permissions) <> 10 then
Exit;
for n := 1 to 10 do
if not(Permissions[n] in
['a', 'b', 'c', 'd', 'h', 'l', 'p', 'r', 's', 't', 'w', 'x', 'y', '-']) then
Exit;
end;
if Day <> '' then
begin
Day := TrimSP(Day);
x := StrToIntDef(day, -1);
if (x < 1) or (x > 31) then
Exit;
end;
if Month <> '' then
begin
Month := TrimSP(Month);
x := StrToIntDef(Month, -1);
if (x < 1) or (x > 12) then
Exit;
end;
if Hours <> '' then
begin
Hours := TrimSP(Hours);
x := StrToIntDef(Hours, -1);
if (x < 0) or (x > 24) then
Exit;
end;
if HoursModif <> '' then
begin
if not (HoursModif[1] in ['a', 'A', 'p', 'P']) then
Exit;
end;
if Minutes <> '' then
begin
Minutes := TrimSP(Minutes);
x := StrToIntDef(Minutes, -1);
if (x < 0) or (x > 59) then
Exit;
end;
if Seconds <> '' then
begin
Seconds := TrimSP(Seconds);
x := StrToIntDef(Seconds, -1);
if (x < 0) or (x > 59) then
Exit;
end;
if Size <> '' then
begin
Size := TrimSP(Size);
for n := 1 to Length(Size) do
if not (Size[n] in ['0'..'9']) then
Exit;
end;
if length(Monthnames) = (12 * 3) then
for n := 1 to 12 do
CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3);
if ThreeMonth <> '' then
begin
x := GetMonthNumber(ThreeMonth);
if (x = 0) then
Exit;
end;
if YearTime <> '' then
begin
YearTime := ReplaceString(YearTime, '-', ':');
if pos(':', YearTime) > 0 then
begin
if (GetTimeFromstr(YearTime) = -1) then
Exit;
end
else
begin
YearTime := TrimSP(YearTime);
x := StrToIntDef(YearTime, -1);
if (x = -1) then
Exit;
if (x < 1900) or (x > 2100) then
Exit;
end;
end;
if Year <> '' then
begin
Year := TrimSP(Year);
x := StrToIntDef(Year, -1);
if (x = -1) then
Exit;
if Length(Year) = 4 then
begin
if not((x > 1900) and (x < 2100)) then
Exit;
end
else
if Length(Year) = 2 then
begin
if not((x >= 0) and (x <= 99)) then
Exit;
end
else
if Length(Year) = 3 then
begin
if not((x >= 100) and (x <= 110)) then
Exit;
end
else
Exit;
end;
Result := True;
end;
procedure TFTPList.FillRecord(const Value: TFTPListRec);
var
s: string;
x: integer;
myear: Word;
mmonth: Word;
mday: Word;
mhours, mminutes, mseconds: word;
n: integer;
begin
s := DirFlagValue;
if s = '' then
s := 'D';
s := Uppercase(s);
Value.Directory := s = Uppercase(DirFlag);
if FileName <> '' then
Value.FileName := SeparateLeft(Filename, ' -> ');
if VMSFileName <> '' then
begin
Value.FileName := VMSFilename;
Value.Directory := Pos('.DIR;',VMSFilename) > 0;
end;
Value.FileName := TrimSPRight(Value.FileName);
Value.Readable := not Value.Directory;
if BlockSize <> '' then
x := StrToIntDef(BlockSize, 1)
else
x := 1;
Value.FileSize := x * StrToIntDef(Size, 0);
DecodeDate(Date,myear,mmonth,mday);
mhours := 0;
mminutes := 0;
mseconds := 0;
if Day <> '' then
mday := StrToIntDef(day, 1);
if Month <> '' then
mmonth := StrToIntDef(Month, 1);
if length(Monthnames) = (12 * 3) then
for n := 1 to 12 do
CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3);
if ThreeMonth <> '' then
mmonth := GetMonthNumber(ThreeMonth);
if Year <> '' then
begin
myear := StrToIntDef(Year, 0);
if (myear <= 99) and (myear > 50) then
myear := myear + 1900;
if myear <= 50 then
myear := myear + 2000;
end;
if YearTime <> '' then
begin
if pos(':', YearTime) > 0 then
begin
YearTime := TrimSP(YearTime);
mhours := StrToIntDef(Separateleft(YearTime, ':'), 0);
mminutes := StrToIntDef(SeparateRight(YearTime, ':'), 0);
if (Encodedate(myear, mmonth, mday)
+ EncodeTime(mHours, mminutes, 0, 0)) > now then
Dec(mYear);
end
else
myear := StrToIntDef(YearTime, 0);
end;
if Minutes <> '' then
mminutes := StrToIntDef(Minutes, 0);
if Seconds <> '' then
mseconds := StrToIntDef(Seconds, 0);
if Hours <> '' then
begin
mHours := StrToIntDef(Hours, 0);
if HoursModif <> '' then
if Uppercase(HoursModif[1]) = 'P' then
if mHours <> 12 then
mHours := MHours + 12;
end;
Value.FileTime := Encodedate(myear, mmonth, mday)
+ EncodeTime(mHours, mminutes, mseconds, 0);
if Permissions <> '' then
begin
Value.Permission := Permissions;
Value.Readable := Uppercase(permissions)[2] = 'R';
if Uppercase(permissions)[1] = 'D' then
begin
Value.Directory := True;
Value.Readable := false;
end
else
if Uppercase(permissions)[1] = 'L' then
Value.Directory := True;
end;
end;
function TFTPList.ParseEPLF(Value: string): Boolean;
var
s, os: string;
flr: TFTPListRec;
begin
Result := False;
if Value <> '' then
if Value[1] = '+' then
begin
os := Value;
Delete(Value, 1, 1);
flr := TFTPListRec.create;
flr.FileName := SeparateRight(Value, #9);
s := Fetch(Value, ',');
while s <> '' do
begin
if s[1] = #9 then
Break;
case s[1] of
'/':
flr.Directory := true;
'r':
flr.Readable := true;
's':
flr.FileSize := StrToIntDef(Copy(s, 2, Length(s) - 1), 0);
'm':
flr.FileTime := (StrToIntDef(Copy(s, 2, Length(s) - 1), 0) / 86400)
+ 25569;
end;
s := Fetch(Value, ',');
end;
if flr.FileName <> '' then
if (flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')))
or (flr.FileName = '') then
flr.free
else
begin
flr.OriginalLine := os;
flr.Mask := 'EPLF';
Flist.Add(flr);
Result := True;
end;
end;
end;
procedure TFTPList.ParseLines;
var
flr: TFTPListRec;
n, m: Integer;
S: string;
x: integer;
b: Boolean;
begin
n := 0;
while n < Lines.Count do
begin
if n = Lines.Count - 1 then
s := ''
else
s := Lines[n + 1];
b := False;
x := 0;
if ParseEPLF(Lines[n]) then
begin
b := True;
x := 1;
end
else
for m := 0 to Masks.Count - 1 do
begin
x := ParseByMask(Lines[n], s, Masks[m]);
if x > 0 then
if CheckValues then
begin
flr := TFTPListRec.create;
FillRecord(flr);
flr.OriginalLine := Lines[n];
flr.Mask := Masks[m];
if flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')) then
flr.free
else
Flist.Add(flr);
b := True;
Break;
end;
end;
if not b then
FUnparsedLines.Add(Lines[n]);
Inc(n);
if x > 1 then
Inc(n, x - 1);
end;
end;
{==============================================================================}
function FtpGetFile(const IP, Port, FileName, LocalFile,
User, Pass: string): Boolean;
begin
Result := False;
with TFTPSend.Create do
try
if User <> '' then
begin
Username := User;
Password := Pass;
end;
TargetHost := IP;
TargetPort := Port;
if not Login then
Exit;
DirectFileName := LocalFile;
DirectFile:=True;
Result := RetrieveFile(FileName, False);
Logout;
finally
Free;
end;
end;
function FtpPutFile(const IP, Port, FileName, LocalFile,
User, Pass: string): Boolean;
begin
Result := False;
with TFTPSend.Create do
try
if User <> '' then
begin
Username := User;
Password := Pass;
end;
TargetHost := IP;
TargetPort := Port;
if not Login then
Exit;
DirectFileName := LocalFile;
DirectFile:=True;
Result := StoreFile(FileName, False);
Logout;
finally
Free;
end;
end;
function FtpInterServerTransfer(
const FromIP, FromPort, FromFile, FromUser, FromPass: string;
const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean;
var
FromFTP, ToFTP: TFTPSend;
s: string;
x: integer;
begin
Result := False;
FromFTP := TFTPSend.Create;
toFTP := TFTPSend.Create;
try
if FromUser <> '' then
begin
FromFTP.Username := FromUser;
FromFTP.Password := FromPass;
end;
if ToUser <> '' then
begin
ToFTP.Username := ToUser;
ToFTP.Password := ToPass;
end;
FromFTP.TargetHost := FromIP;
FromFTP.TargetPort := FromPort;
ToFTP.TargetHost := ToIP;
ToFTP.TargetPort := ToPort;
if not FromFTP.Login then
Exit;
if not ToFTP.Login then
Exit;
if (FromFTP.FTPCommand('PASV') div 100) <> 2 then
Exit;
FromFTP.ParseRemote(FromFTP.ResultString);
s := ReplaceString(FromFTP.DataIP, '.', ',');
s := 'PORT ' + s + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) div 256)
+ ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) mod 256);
if (ToFTP.FTPCommand(s) div 100) <> 2 then
Exit;
x := ToFTP.FTPCommand('RETR ' + FromFile);
if (x div 100) <> 1 then
Exit;
x := FromFTP.FTPCommand('STOR ' + ToFile);
if (x div 100) <> 1 then
Exit;
FromFTP.Timeout := 21600000;
x := FromFTP.ReadResult;
if (x div 100) <> 2 then
Exit;
ToFTP.Timeout := 21600000;
x := ToFTP.ReadResult;
if (x div 100) <> 2 then
Exit;
Result := True;
finally
ToFTP.Free;
FromFTP.Free;
end;
end;
end.
TransGUI/synapse/source/lib/synaser.pas 0000644 0000000 0000000 00000201175 11466757142 017154 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 007.005.000 |
|==============================================================================|
| Content: Serial port support |
|==============================================================================|
| Copyright (c)2001-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| (c)2002, Hans-Georg Joepgen (cpom Comport Ownership Manager and bugfixes) |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{: @abstract(Serial port communication library)
This unit contains a class that implements serial port communication
for Windows, Linux, Unix or MacOSx. This class provides numerous methods with
same name and functionality as methods of the Ararat Synapse TCP/IP library.
The following is a small example how establish a connection by modem (in this
case with my USB modem):
@longcode(#
ser:=TBlockSerial.Create;
try
ser.Connect('COM3');
ser.config(460800,8,'N',0,false,true);
ser.ATCommand('AT');
if (ser.LastError <> 0) or (not ser.ATResult) then
Exit;
ser.ATConnect('ATDT+420971200111');
if (ser.LastError <> 0) or (not ser.ATResult) then
Exit;
// you are now connected to a modem at +420971200111
// you can transmit or receive data now
finally
ser.free;
end;
#)
}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
//Kylix does not known UNIX define
{$IFDEF LINUX}
{$IFNDEF UNIX}
{$DEFINE UNIX}
{$ENDIF}
{$ENDIF}
{$IFDEF FPC}
{$MODE DELPHI}
{$IFDEF MSWINDOWS}
{$ASMMODE intel}
{$ENDIF}
{define working mode w/o LIBC for fpc}
{$DEFINE NO_LIBC}
{$ENDIF}
{$Q-}
{$H+}
{$M+}
unit synaser;
interface
uses
{$IFNDEF MSWINDOWS}
{$IFNDEF NO_LIBC}
Libc,
KernelIoctl,
{$ELSE}
termio, baseunix, unix,
{$ENDIF}
{$IFNDEF FPC}
Types,
{$ENDIF}
{$ELSE}
Windows, registry,
{$IFDEF FPC}
winver,
{$ENDIF}
{$ENDIF}
synafpc,
Classes, SysUtils, synautil;
const
CR = #$0d;
LF = #$0a;
CRLF = CR + LF;
cSerialChunk = 8192;
LockfileDirectory = '/var/lock'; {HGJ}
PortIsClosed = -1; {HGJ}
ErrAlreadyOwned = 9991; {HGJ}
ErrAlreadyInUse = 9992; {HGJ}
ErrWrongParameter = 9993; {HGJ}
ErrPortNotOpen = 9994; {HGJ}
ErrNoDeviceAnswer = 9995; {HGJ}
ErrMaxBuffer = 9996;
ErrTimeout = 9997;
ErrNotRead = 9998;
ErrFrame = 9999;
ErrOverrun = 10000;
ErrRxOver = 10001;
ErrRxParity = 10002;
ErrTxFull = 10003;
dcb_Binary = $00000001;
dcb_ParityCheck = $00000002;
dcb_OutxCtsFlow = $00000004;
dcb_OutxDsrFlow = $00000008;
dcb_DtrControlMask = $00000030;
dcb_DtrControlDisable = $00000000;
dcb_DtrControlEnable = $00000010;
dcb_DtrControlHandshake = $00000020;
dcb_DsrSensivity = $00000040;
dcb_TXContinueOnXoff = $00000080;
dcb_OutX = $00000100;
dcb_InX = $00000200;
dcb_ErrorChar = $00000400;
dcb_NullStrip = $00000800;
dcb_RtsControlMask = $00003000;
dcb_RtsControlDisable = $00000000;
dcb_RtsControlEnable = $00001000;
dcb_RtsControlHandshake = $00002000;
dcb_RtsControlToggle = $00003000;
dcb_AbortOnError = $00004000;
dcb_Reserveds = $FFFF8000;
{:stopbit value for 1 stopbit}
SB1 = 0;
{:stopbit value for 1.5 stopbit}
SB1andHalf = 1;
{:stopbit value for 2 stopbits}
SB2 = 2;
{$IFNDEF MSWINDOWS}
const
INVALID_HANDLE_VALUE = THandle(-1);
CS7fix = $0000020;
type
TDCB = record
DCBlength: DWORD;
BaudRate: DWORD;
Flags: Longint;
wReserved: Word;
XonLim: Word;
XoffLim: Word;
ByteSize: Byte;
Parity: Byte;
StopBits: Byte;
XonChar: CHAR;
XoffChar: CHAR;
ErrorChar: CHAR;
EofChar: CHAR;
EvtChar: CHAR;
wReserved1: Word;
end;
PDCB = ^TDCB;
const
{$IFDEF UNIX}
{$IFDEF DARWIN}
MaxRates = 18; //MAC
{$ELSE}
MaxRates = 30; //UNIX
{$ENDIF}
{$ELSE}
MaxRates = 19; //WIN
{$ENDIF}
Rates: array[0..MaxRates, 0..1] of cardinal =
(
(0, B0),
(50, B50),
(75, B75),
(110, B110),
(134, B134),
(150, B150),
(200, B200),
(300, B300),
(600, B600),
(1200, B1200),
(1800, B1800),
(2400, B2400),
(4800, B4800),
(9600, B9600),
(19200, B19200),
(38400, B38400),
(57600, B57600),
(115200, B115200),
(230400, B230400)
{$IFNDEF DARWIN}
,(460800, B460800)
{$IFDEF UNIX}
,(500000, B500000),
(576000, B576000),
(921600, B921600),
(1000000, B1000000),
(1152000, B1152000),
(1500000, B1500000),
(2000000, B2000000),
(2500000, B2500000),
(3000000, B3000000),
(3500000, B3500000),
(4000000, B4000000)
{$ENDIF}
{$ENDIF}
);
{$ENDIF}
{$IFDEF DARWIN}
const // From fcntl.h
O_SYNC = $0080; { synchronous writes }
{$ENDIF}
const
sOK = 0;
sErr = integer(-1);
type
{:Possible status event types for @link(THookSerialStatus)}
THookSerialReason = (
HR_SerialClose,
HR_Connect,
HR_CanRead,
HR_CanWrite,
HR_ReadCount,
HR_WriteCount,
HR_Wait
);
{:procedural prototype for status event hooking}
THookSerialStatus = procedure(Sender: TObject; Reason: THookSerialReason;
const Value: string) of object;
{:@abstract(Exception type for SynaSer errors)}
ESynaSerError = class(Exception)
public
ErrorCode: integer;
ErrorMessage: string;
end;
{:@abstract(Main class implementing all communication routines)}
TBlockSerial = class(TObject)
protected
FOnStatus: THookSerialStatus;
Fhandle: THandle;
FTag: integer;
FDevice: string;
FLastError: integer;
FLastErrorDesc: string;
FBuffer: AnsiString;
FRaiseExcept: boolean;
FRecvBuffer: integer;
FSendBuffer: integer;
FModemWord: integer;
FRTSToggle: Boolean;
FDeadlockTimeout: integer;
FInstanceActive: boolean; {HGJ}
FTestDSR: Boolean;
FTestCTS: Boolean;
FLastCR: Boolean;
FLastLF: Boolean;
FMaxLineLength: Integer;
FLinuxLock: Boolean;
FMaxSendBandwidth: Integer;
FNextSend: LongWord;
FMaxRecvBandwidth: Integer;
FNextRecv: LongWord;
FConvertLineEnd: Boolean;
FATResult: Boolean;
FAtTimeout: integer;
FInterPacketTimeout: Boolean;
FComNr: integer;
{$IFDEF MSWINDOWS}
FPortAddr: Word;
function CanEvent(Event: dword; Timeout: integer): boolean;
procedure DecodeCommError(Error: DWord); virtual;
function GetPortAddr: Word; virtual;
function ReadTxEmpty(PortAddr: Word): Boolean; virtual;
{$ENDIF}
procedure SetSizeRecvBuffer(size: integer); virtual;
function GetDSR: Boolean; virtual;
procedure SetDTRF(Value: Boolean); virtual;
function GetCTS: Boolean; virtual;
procedure SetRTSF(Value: Boolean); virtual;
function GetCarrier: Boolean; virtual;
function GetRing: Boolean; virtual;
procedure DoStatus(Reason: THookSerialReason; const Value: string); virtual;
procedure GetComNr(Value: string); virtual;
function PreTestFailing: boolean; virtual;{HGJ}
function TestCtrlLine: Boolean; virtual;
{$IFDEF UNIX}
procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual;
procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual;
function ReadLockfile: integer; virtual;
function LockfileName: String; virtual;
procedure CreateLockfile(PidNr: integer); virtual;
{$ENDIF}
procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); virtual;
procedure SetBandwidth(Value: Integer); virtual;
public
{: data Control Block with communication parameters. Usable only when you
need to call API directly.}
DCB: Tdcb;
{$IFDEF UNIX}
TermiosStruc: termios;
{$ENDIF}
{:Object constructor.}
constructor Create;
{:Object destructor.}
destructor Destroy; override;
{:Returns a string containing the version number of the library.}
class function GetVersion: string; virtual;
{:Destroy handle in use. It close connection to serial port.}
procedure CloseSocket; virtual;
{:Reconfigure communication parameters on the fly. You must be connected to
port before!
@param(baud Define connection speed. Baud rate can be from 50 to 4000000
bits per second. (it depends on your hardware!))
@param(bits Number of bits in communication.)
@param(parity Define communication parity (N - None, O - Odd, E - Even, M - Mark or S - Space).)
@param(stop Define number of stopbits. Use constants @link(SB1),
@link(SB1andHalf) and @link(SB2).)
@param(softflow Enable XON/XOFF handshake.)
@param(hardflow Enable CTS/RTS handshake.)}
procedure Config(baud, bits: integer; parity: char; stop: integer;
softflow, hardflow: boolean); virtual;
{:Connects to the port indicated by comport. Comport can be used in Windows
style (COM2), or in Linux style (/dev/ttyS1). When you use windows style
in Linux, then it will be converted to Linux name. And vice versa! However
you can specify any device name! (other device names then standart is not
converted!)
After successfull connection the DTR signal is set (if you not set hardware
handshake, then the RTS signal is set, too!)
Connection parameters is predefined by your system configuration. If you
need use another parameters, then you can use Config method after.
Notes:
- Remember, the commonly used serial Laplink cable does not support
hardware handshake.
- Before setting any handshake you must be sure that it is supported by
your hardware.
- Some serial devices are slow. In some cases you must wait up to a few
seconds after connection for the device to respond.
- when you connect to a modem device, then is best to test it by an empty
AT command. (call ATCommand('AT'))}
procedure Connect(comport: string); virtual;
{:Set communication parameters from the DCB structure (the DCB structure is
simulated under Linux).}
procedure SetCommState; virtual;
{:Read communication parameters into the DCB structure (DCB structure is
simulated under Linux).}
procedure GetCommState; virtual;
{:Sends Length bytes of data from Buffer through the connected port.}
function SendBuffer(buffer: pointer; length: integer): integer; virtual;
{:One data BYTE is sent.}
procedure SendByte(data: byte); virtual;
{:Send the string in the data parameter. No terminator is appended by this
method. If you need to send a string with CR/LF terminator, you must append
the CR/LF characters to the data string!
Since no terminator is appended, you can use this function for sending
binary data too.}
procedure SendString(data: AnsiString); virtual;
{:send four bytes as integer.}
procedure SendInteger(Data: integer); virtual;
{:send data as one block. Each block begins with integer value with Length
of block.}
procedure SendBlock(const Data: AnsiString); virtual;
{:send content of stream from current position}
procedure SendStreamRaw(const Stream: TStream); virtual;
{:send content of stream as block. see @link(SendBlock)}
procedure SendStream(const Stream: TStream); virtual;
{:send content of stream as block, but this is compatioble with Indy library.
(it have swapped lenght of block). See @link(SendStream)}
procedure SendStreamIndy(const Stream: TStream); virtual;
{:Waits until the allocated buffer is filled by received data. Returns number
of data bytes received, which equals to the Length value under normal
operation. If it is not equal, the communication channel is possibly broken.
This method not using any internal buffering, like all others receiving
methods. You cannot freely combine this method with all others receiving
methods!}
function RecvBuffer(buffer: pointer; length: integer): integer; virtual;
{:Method waits until data is received. If no data is received within
the Timeout (in milliseconds) period, @link(LastError) is set to
@link(ErrTimeout). This method is used to read any amount of data
(e. g. 1MB), and may be freely combined with all receviving methods what
have Timeout parameter, like the @link(RecvString), @link(RecvByte) or
@link(RecvTerminated) methods.}
function RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer; virtual;
{:It is like recvBufferEx, but data is readed to dynamicly allocated binary
string.}
function RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; virtual;
{:Read all available data and return it in the function result string. This
function may be combined with @link(RecvString), @link(RecvByte) or related
methods.}
function RecvPacket(Timeout: Integer): AnsiString; virtual;
{:Waits until one data byte is received which is returned as the function
result. If no data is received within the Timeout (in milliseconds) period,
@link(LastError) is set to @link(ErrTimeout).}
function RecvByte(timeout: integer): byte; virtual;
{:This method waits until a terminated data string is received. This string
is terminated by the Terminator string. The resulting string is returned
without this termination string! If no data is received within the Timeout
(in milliseconds) period, @link(LastError) is set to @link(ErrTimeout).}
function RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; virtual;
{:This method waits until a terminated data string is received. The string
is terminated by a CR/LF sequence. The resulting string is returned without
the terminator (CR/LF)! If no data is received within the Timeout (in
milliseconds) period, @link(LastError) is set to @link(ErrTimeout).
If @link(ConvertLineEnd) is used, then the CR/LF sequence may not be exactly
CR/LF. See the description of @link(ConvertLineEnd).
This method serves for line protocol implementation and uses its own
buffers to maximize performance. Therefore do NOT use this method with the
@link(RecvBuffer) method to receive data as it may cause data loss.}
function Recvstring(timeout: integer): AnsiString; virtual;
{:Waits until four data bytes are received which is returned as the function
integer result. If no data is received within the Timeout (in milliseconds) period,
@link(LastError) is set to @link(ErrTimeout).}
function RecvInteger(Timeout: Integer): Integer; virtual;
{:Waits until one data block is received. See @link(sendblock). If no data
is received within the Timeout (in milliseconds) period, @link(LastError)
is set to @link(ErrTimeout).}
function RecvBlock(Timeout: Integer): AnsiString; virtual;
{:Receive all data to stream, until some error occured. (for example timeout)}
procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual;
{:receive requested count of bytes to stream}
procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); virtual;
{:receive block of data to stream. (Data can be sended by @link(sendstream)}
procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual;
{:receive block of data to stream. (Data can be sended by @link(sendstreamIndy)}
procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual;
{:Returns the number of received bytes waiting for reading. 0 is returned
when there is no data waiting.}
function WaitingData: integer; virtual;
{:Same as @link(WaitingData), but in respect to data in the internal
@link(LineBuffer).}
function WaitingDataEx: integer; virtual;
{:Returns the number of bytes waiting to be sent in the output buffer.
0 is returned when the output buffer is empty.}
function SendingData: integer; virtual;
{:Enable or disable RTS driven communication (half-duplex). It can be used
to communicate with RS485 converters, or other special equipment. If you
enable this feature, the system automatically controls the RTS signal.
Notes:
- On Windows NT (or higher) ir RTS signal driven by system driver.
- On Win9x family is used special code for waiting until last byte is
sended from your UART.
- On Linux you must have kernel 2.1 or higher!}
procedure EnableRTSToggle(value: boolean); virtual;
{:Waits until all data to is sent and buffers are emptied.
Warning: On Windows systems is this method returns when all buffers are
flushed to the serial port controller, before the last byte is sent!}
procedure Flush; virtual;
{:Unconditionally empty all buffers. It is good when you need to interrupt
communication and for cleanups.}
procedure Purge; virtual;
{:Returns @True, if you can from read any data from the port. Status is
tested for a period of time given by the Timeout parameter (in milliseconds).
If the value of the Timeout parameter is 0, the status is tested only once
and the function returns immediately. If the value of the Timeout parameter
is set to -1, the function returns only after it detects data on the port
(this may cause the process to hang).}
function CanRead(Timeout: integer): boolean; virtual;
{:Returns @True, if you can write any data to the port (this function is not
sending the contents of the buffer). Status is tested for a period of time
given by the Timeout parameter (in milliseconds). If the value of
the Timeout parameter is 0, the status is tested only once and the function
returns immediately. If the value of the Timeout parameter is set to -1,
the function returns only after it detects that it can write data to
the port (this may cause the process to hang).}
function CanWrite(Timeout: integer): boolean; virtual;
{:Same as @link(CanRead), but the test is against data in the internal
@link(LineBuffer) too.}
function CanReadEx(Timeout: integer): boolean; virtual;
{:Returns the status word of the modem. Decoding the status word could yield
the status of carrier detect signaland other signals. This method is used
internally by the modem status reading properties. You usually do not need
to call this method directly.}
function ModemStatus: integer; virtual;
{:Send a break signal to the communication device for Duration milliseconds.}
procedure SetBreak(Duration: integer); virtual;
{:This function is designed to send AT commands to the modem. The AT command
is sent in the Value parameter and the response is returned in the function
return value (may contain multiple lines!).
If the AT command is processed successfully (modem returns OK), then the
@link(ATResult) property is set to True.
This function is designed only for AT commands that return OK or ERROR
response! To call connection commands the @link(ATConnect) method.
Remember, when you connect to a modem device, it is in AT command mode.
Now you can send AT commands to the modem. If you need to transfer data to
the modem on the other side of the line, you must first switch to data mode
using the @link(ATConnect) method.}
function ATCommand(value: AnsiString): AnsiString; virtual;
{:This function is used to send connect type AT commands to the modem. It is
for commands to switch to connected state. (ATD, ATA, ATO,...)
It sends the AT command in the Value parameter and returns the modem's
response (may be multiple lines - usually with connection parameters info).
If the AT command is processed successfully (the modem returns CONNECT),
then the ATResult property is set to @True.
This function is designed only for AT commands which respond by CONNECT,
BUSY, NO DIALTONE NO CARRIER or ERROR. For other AT commands use the
@link(ATCommand) method.
The connect timeout is 90*@link(ATTimeout). If this command is successful
(@link(ATresult) is @true), then the modem is in data state. When you now
send or receive some data, it is not to or from your modem, but from the
modem on other side of the line. Now you can transfer your data.
If the connection attempt failed (@link(ATResult) is @False), then the
modem is still in AT command mode.}
function ATConnect(value: AnsiString): AnsiString; virtual;
{:If you "manually" call API functions, forward their return code in
the SerialResult parameter to this function, which evaluates it and sets
@link(LastError) and @link(LastErrorDesc).}
function SerialCheck(SerialResult: integer): integer; virtual;
{:If @link(Lasterror) is not 0 and exceptions are enabled, then this procedure
raises an exception. This method is used internally. You may need it only
in special cases.}
procedure ExceptCheck; virtual;
{:Set Synaser to error state with ErrNumber code. Usually used by internal
routines.}
procedure SetSynaError(ErrNumber: integer); virtual;
{:Raise Synaser error with ErrNumber code. Usually used by internal routines.}
procedure RaiseSynaError(ErrNumber: integer); virtual;
{$IFDEF UNIX}
function cpomComportAccessible: boolean; virtual;{HGJ}
procedure cpomReleaseComport; virtual; {HGJ}
{$ENDIF}
{:True device name of currently used port}
property Device: string read FDevice;
{:Error code of last operation. Value is defined by the host operating
system, but value 0 is always OK.}
property LastError: integer read FLastError;
{:Human readable description of LastError code.}
property LastErrorDesc: string read FLastErrorDesc;
{:Indicates if the last @link(ATCommand) or @link(ATConnect) method was successful}
property ATResult: Boolean read FATResult;
{:Read the value of the RTS signal.}
property RTS: Boolean write SetRTSF;
{:Indicates the presence of the CTS signal}
property CTS: boolean read GetCTS;
{:Use this property to set the value of the DTR signal.}
property DTR: Boolean write SetDTRF;
{:Exposes the status of the DSR signal.}
property DSR: boolean read GetDSR;
{:Indicates the presence of the Carrier signal}
property Carrier: boolean read GetCarrier;
{:Reflects the status of the Ring signal.}
property Ring: boolean read GetRing;
{:indicates if this instance of SynaSer is active. (Connected to some port)}
property InstanceActive: boolean read FInstanceActive; {HGJ}
{:Defines maximum bandwidth for all sending operations in bytes per second.
If this value is set to 0 (default), bandwidth limitation is not used.}
property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth;
{:Defines maximum bandwidth for all receiving operations in bytes per second.
If this value is set to 0 (default), bandwidth limitation is not used.}
property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth;
{:Defines maximum bandwidth for all sending and receiving operations
in bytes per second. If this value is set to 0 (default), bandwidth
limitation is not used.}
property MaxBandwidth: Integer Write SetBandwidth;
{:Size of the Windows internal receive buffer. Default value is usually
4096 bytes. Note: Valid only in Windows versions!}
property SizeRecvBuffer: integer read FRecvBuffer write SetSizeRecvBuffer;
published
{:Returns the descriptive text associated with ErrorCode. You need this
method only in special cases. Description of LastError is now accessible
through the LastErrorDesc property.}
class function GetErrorDesc(ErrorCode: integer): string;
{:Freely usable property}
property Tag: integer read FTag write FTag;
{:Contains the handle of the open communication port.
You may need this value to directly call communication functions outside
SynaSer.}
property Handle: THandle read Fhandle write FHandle;
{:Internally used read buffer.}
property LineBuffer: AnsiString read FBuffer write FBuffer;
{:If @true, communication errors raise exceptions. If @false (default), only
the @link(LastError) value is set.}
property RaiseExcept: boolean read FRaiseExcept write FRaiseExcept;
{:This event is triggered when the communication status changes. It can be
used to monitor communication status.}
property OnStatus: THookSerialStatus read FOnStatus write FOnStatus;
{:If you set this property to @true, then the value of the DSR signal
is tested before every data transfer. It can be used to detect the presence
of a communications device.}
property TestDSR: boolean read FTestDSR write FTestDSR;
{:If you set this property to @true, then the value of the CTS signal
is tested before every data transfer. It can be used to detect the presence
of a communications device. Warning: This property cannot be used if you
need hardware handshake!}
property TestCTS: boolean read FTestCTS write FTestCTS;
{:Use this property you to limit the maximum size of LineBuffer
(as a protection against unlimited memory allocation for LineBuffer).
Default value is 0 - no limit.}
property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength;
{:This timeout value is used as deadlock protection when trying to send data
to (or receive data from) a device that stopped communicating during data
transmission (e.g. by physically disconnecting the device).
The timeout value is in milliseconds. The default value is 30,000 (30 seconds).}
property DeadlockTimeout: Integer read FDeadlockTimeout Write FDeadlockTimeout;
{:If set to @true (default value), port locking is enabled (under Linux only).
WARNING: To use this feature, the application must run by a user with full
permission to the /var/lock directory!}
property LinuxLock: Boolean read FLinuxLock write FLinuxLock;
{:Indicates if non-standard line terminators should be converted to a CR/LF pair
(standard DOS line terminator). If @TRUE, line terminators CR, single LF
or LF/CR are converted to CR/LF. Defaults to @FALSE.
This property has effect only on the behavior of the RecvString method.}
property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd;
{:Timeout for AT modem based operations}
property AtTimeout: integer read FAtTimeout Write FAtTimeout;
{:If @true (default), then all timeouts is timeout between two characters.
If @False, then timeout is overall for whoole reading operation.}
property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout;
end;
{:Returns list of existing computer serial ports. Working properly only in Windows!}
function GetSerialPortNames: string;
implementation
constructor TBlockSerial.Create;
begin
inherited create;
FRaiseExcept := false;
FHandle := INVALID_HANDLE_VALUE;
FDevice := '';
FComNr:= PortIsClosed; {HGJ}
FInstanceActive:= false; {HGJ}
Fbuffer := '';
FRTSToggle := False;
FMaxLineLength := 0;
FTestDSR := False;
FTestCTS := False;
FDeadlockTimeout := 30000;
FLinuxLock := True;
FMaxSendBandwidth := 0;
FNextSend := 0;
FMaxRecvBandwidth := 0;
FNextRecv := 0;
FConvertLineEnd := False;
SetSynaError(sOK);
FRecvBuffer := 4096;
FLastCR := False;
FLastLF := False;
FAtTimeout := 1000;
FInterPacketTimeout := True;
end;
destructor TBlockSerial.Destroy;
begin
CloseSocket;
inherited destroy;
end;
class function TBlockSerial.GetVersion: string;
begin
Result := 'SynaSer 7.5.0';
end;
procedure TBlockSerial.CloseSocket;
begin
if Fhandle <> INVALID_HANDLE_VALUE then
begin
Purge;
RTS := False;
DTR := False;
FileClose(FHandle);
end;
if InstanceActive then
begin
{$IFDEF UNIX}
if FLinuxLock then
cpomReleaseComport;
{$ENDIF}
FInstanceActive:= false
end;
Fhandle := INVALID_HANDLE_VALUE;
FComNr:= PortIsClosed;
SetSynaError(sOK);
DoStatus(HR_SerialClose, FDevice);
end;
{$IFDEF MSWINDOWS}
function TBlockSerial.GetPortAddr: Word;
begin
Result := 0;
if Win32Platform <> VER_PLATFORM_WIN32_NT then
begin
EscapeCommFunction(FHandle, 10);
asm
MOV @Result, DX;
end;
end;
end;
function TBlockSerial.ReadTxEmpty(PortAddr: Word): Boolean;
begin
Result := True;
if Win32Platform <> VER_PLATFORM_WIN32_NT then
begin
asm
MOV DX, PortAddr;
ADD DX, 5;
IN AL, DX;
AND AL, $40;
JZ @K;
MOV AL,1;
@K: MOV @Result, AL;
end;
end;
end;
{$ENDIF}
procedure TBlockSerial.GetComNr(Value: string);
begin
FComNr := PortIsClosed;
if pos('COM', uppercase(Value)) = 1 then
FComNr := StrToIntdef(copy(Value, 4, Length(Value) - 3), PortIsClosed + 1) - 1;
if pos('/DEV/TTYS', uppercase(Value)) = 1 then
FComNr := StrToIntdef(copy(Value, 10, Length(Value) - 9), PortIsClosed - 1);
end;
procedure TBlockSerial.SetBandwidth(Value: Integer);
begin
MaxSendBandwidth := Value;
MaxRecvBandwidth := Value;
end;
procedure TBlockSerial.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord);
var
x: LongWord;
y: LongWord;
begin
if MaxB > 0 then
begin
y := GetTick;
if Next > y then
begin
x := Next - y;
if x > 0 then
begin
DoStatus(HR_Wait, IntToStr(x));
sleep(x);
end;
end;
Next := GetTick + Trunc((Length / MaxB) * 1000);
end;
end;
procedure TBlockSerial.Config(baud, bits: integer; parity: char; stop: integer;
softflow, hardflow: boolean);
begin
FillChar(dcb, SizeOf(dcb), 0);
GetCommState;
dcb.DCBlength := SizeOf(dcb);
dcb.BaudRate := baud;
dcb.ByteSize := bits;
case parity of
'N', 'n': dcb.parity := 0;
'O', 'o': dcb.parity := 1;
'E', 'e': dcb.parity := 2;
'M', 'm': dcb.parity := 3;
'S', 's': dcb.parity := 4;
end;
dcb.StopBits := stop;
dcb.XonChar := #17;
dcb.XoffChar := #19;
dcb.XonLim := FRecvBuffer div 4;
dcb.XoffLim := FRecvBuffer div 4;
dcb.Flags := dcb_Binary;
if softflow then
dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX;
if hardflow then
dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake
else
dcb.Flags := dcb.Flags or dcb_RtsControlEnable;
dcb.Flags := dcb.Flags or dcb_DtrControlEnable;
if dcb.Parity > 0 then
dcb.Flags := dcb.Flags or dcb_ParityCheck;
SetCommState;
end;
procedure TBlockSerial.Connect(comport: string);
{$IFDEF MSWINDOWS}
var
CommTimeouts: TCommTimeouts;
{$ENDIF}
begin
// Is this TBlockSerial Instance already busy?
if InstanceActive then {HGJ}
begin {HGJ}
RaiseSynaError(ErrAlreadyInUse);
Exit; {HGJ}
end; {HGJ}
FBuffer := '';
FDevice := comport;
GetComNr(comport);
{$IFDEF MSWINDOWS}
SetLastError (sOK);
{$ELSE}
{$IFNDEF FPC}
SetLastError (sOK);
{$ELSE}
fpSetErrno(sOK);
{$ENDIF}
{$ENDIF}
{$IFNDEF MSWINDOWS}
if FComNr <> PortIsClosed then
FDevice := '/dev/ttyS' + IntToStr(FComNr);
// Comport already owned by another process? {HGJ}
if FLinuxLock then
if not cpomComportAccessible then
begin
RaiseSynaError(ErrAlreadyOwned);
Exit;
end;
{$IFNDEF FPC}
FHandle := THandle(Libc.open(pchar(FDevice), O_RDWR or O_SYNC));
{$ELSE}
FHandle := THandle(fpOpen(FDevice, O_RDWR or O_SYNC));
{$ENDIF}
if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms!
SerialCheck(-1)
else
SerialCheck(0);
{$IFDEF UNIX}
if FLastError <> sOK then
if FLinuxLock then
cpomReleaseComport;
{$ENDIF}
ExceptCheck;
if FLastError <> sOK then
Exit;
{$ELSE}
if FComNr <> PortIsClosed then
FDevice := '\\.\COM' + IntToStr(FComNr + 1);
FHandle := THandle(CreateFile(PChar(FDevice), GENERIC_READ or GENERIC_WRITE,
0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0));
if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms!
SerialCheck(-1)
else
SerialCheck(0);
ExceptCheck;
if FLastError <> sOK then
Exit;
SetCommMask(FHandle, 0);
SetupComm(Fhandle, FRecvBuffer, 0);
CommTimeOuts.ReadIntervalTimeout := MAXWORD;
CommTimeOuts.ReadTotalTimeoutMultiplier := 0;
CommTimeOuts.ReadTotalTimeoutConstant := 0;
CommTimeOuts.WriteTotalTimeoutMultiplier := 0;
CommTimeOuts.WriteTotalTimeoutConstant := 0;
SetCommTimeOuts(FHandle, CommTimeOuts);
FPortAddr := GetPortAddr;
{$ENDIF}
SetSynaError(sOK);
if not TestCtrlLine then {HGJ}
begin
SetSynaError(ErrNoDeviceAnswer);
FileClose(FHandle); {HGJ}
{$IFDEF UNIX}
if FLinuxLock then
cpomReleaseComport; {HGJ}
{$ENDIF} {HGJ}
Fhandle := INVALID_HANDLE_VALUE; {HGJ}
FComNr:= PortIsClosed; {HGJ}
end
else
begin
FInstanceActive:= True;
RTS := True;
DTR := True;
Purge;
end;
ExceptCheck;
DoStatus(HR_Connect, FDevice);
end;
function TBlockSerial.SendBuffer(buffer: pointer; length: integer): integer;
{$IFDEF MSWINDOWS}
var
Overlapped: TOverlapped;
x, y, Err: DWord;
{$ENDIF}
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
if FRTSToggle then
begin
Flush;
RTS := True;
end;
{$IFNDEF MSWINDOWS}
result := FileWrite(Fhandle, Buffer^, Length);
serialcheck(result);
{$ELSE}
FillChar(Overlapped, Sizeof(Overlapped), 0);
SetSynaError(sOK);
y := 0;
if not WriteFile(FHandle, Buffer^, Length, DWord(Result), @Overlapped) then
y := GetLastError;
if y = ERROR_IO_PENDING then
begin
x := WaitForSingleObject(FHandle, FDeadlockTimeout);
if x = WAIT_TIMEOUT then
begin
PurgeComm(FHandle, PURGE_TXABORT);
SetSynaError(ErrTimeout);
end;
GetOverlappedResult(FHandle, Overlapped, Dword(Result), False);
end
else
SetSynaError(y);
ClearCommError(FHandle, err, nil);
if err <> 0 then
DecodeCommError(err);
{$ENDIF}
if FRTSToggle then
begin
Flush;
CanWrite(255);
RTS := False;
end;
ExceptCheck;
DoStatus(HR_WriteCount, IntToStr(Result));
end;
procedure TBlockSerial.SendByte(data: byte);
begin
SendBuffer(@Data, 1);
end;
procedure TBlockSerial.SendString(data: AnsiString);
begin
SendBuffer(Pointer(Data), Length(Data));
end;
procedure TBlockSerial.SendInteger(Data: integer);
begin
SendBuffer(@data, SizeOf(Data));
end;
procedure TBlockSerial.SendBlock(const Data: AnsiString);
begin
SendInteger(Length(data));
SendString(Data);
end;
procedure TBlockSerial.SendStreamRaw(const Stream: TStream);
var
si: integer;
x, y, yr: integer;
s: AnsiString;
begin
si := Stream.Size - Stream.Position;
x := 0;
while x < si do
begin
y := si - x;
if y > cSerialChunk then
y := cSerialChunk;
Setlength(s, y);
yr := Stream.read(PAnsiChar(s)^, y);
if yr > 0 then
begin
SetLength(s, yr);
SendString(s);
Inc(x, yr);
end
else
break;
end;
end;
procedure TBlockSerial.SendStreamIndy(const Stream: TStream);
var
si: integer;
begin
si := Stream.Size - Stream.Position;
si := Swapbytes(si);
SendInteger(si);
SendStreamRaw(Stream);
end;
procedure TBlockSerial.SendStream(const Stream: TStream);
var
si: integer;
begin
si := Stream.Size - Stream.Position;
SendInteger(si);
SendStreamRaw(Stream);
end;
function TBlockSerial.RecvBuffer(buffer: pointer; length: integer): integer;
{$IFNDEF MSWINDOWS}
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
result := FileRead(FHandle, Buffer^, length);
serialcheck(result);
{$ELSE}
var
Overlapped: TOverlapped;
x, y, Err: DWord;
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
FillChar(Overlapped, Sizeof(Overlapped), 0);
SetSynaError(sOK);
y := 0;
if not ReadFile(FHandle, Buffer^, length, Dword(Result), @Overlapped) then
y := GetLastError;
if y = ERROR_IO_PENDING then
begin
x := WaitForSingleObject(FHandle, FDeadlockTimeout);
if x = WAIT_TIMEOUT then
begin
PurgeComm(FHandle, PURGE_RXABORT);
SetSynaError(ErrTimeout);
end;
GetOverlappedResult(FHandle, Overlapped, Dword(Result), False);
end
else
SetSynaError(y);
ClearCommError(FHandle, err, nil);
if err <> 0 then
DecodeCommError(err);
{$ENDIF}
ExceptCheck;
DoStatus(HR_ReadCount, IntToStr(Result));
end;
function TBlockSerial.RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer;
var
s: AnsiString;
rl, l: integer;
ti: LongWord;
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
SetSynaError(sOK);
rl := 0;
repeat
ti := GetTick;
s := RecvPacket(Timeout);
l := System.Length(s);
if (rl + l) > Length then
l := Length - rl;
Move(Pointer(s)^, IncPoint(Buffer, rl)^, l);
rl := rl + l;
if FLastError <> sOK then
Break;
if rl >= Length then
Break;
if not FInterPacketTimeout then
begin
Timeout := Timeout - integer(TickDelta(ti, GetTick));
if Timeout <= 0 then
begin
SetSynaError(ErrTimeout);
Break;
end;
end;
until False;
delete(s, 1, l);
FBuffer := s;
Result := rl;
end;
function TBlockSerial.RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString;
var
x: integer;
begin
Result := '';
if PreTestFailing then {HGJ}
Exit; {HGJ}
SetSynaError(sOK);
if Length > 0 then
begin
Setlength(Result, Length);
x := RecvBufferEx(PAnsiChar(Result), Length , Timeout);
if FLastError = sOK then
SetLength(Result, x)
else
Result := '';
end;
end;
function TBlockSerial.RecvPacket(Timeout: Integer): AnsiString;
var
x: integer;
begin
Result := '';
if PreTestFailing then {HGJ}
Exit; {HGJ}
SetSynaError(sOK);
if FBuffer <> '' then
begin
Result := FBuffer;
FBuffer := '';
end
else
begin
//not drain CPU on large downloads...
Sleep(0);
x := WaitingData;
if x > 0 then
begin
SetLength(Result, x);
x := RecvBuffer(Pointer(Result), x);
if x >= 0 then
SetLength(Result, x);
end
else
begin
if CanRead(Timeout) then
begin
x := WaitingData;
if x = 0 then
SetSynaError(ErrTimeout);
if x > 0 then
begin
SetLength(Result, x);
x := RecvBuffer(Pointer(Result), x);
if x >= 0 then
SetLength(Result, x);
end;
end
else
SetSynaError(ErrTimeout);
end;
end;
ExceptCheck;
end;
function TBlockSerial.RecvByte(timeout: integer): byte;
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
SetSynaError(sOK);
if FBuffer = '' then
FBuffer := RecvPacket(Timeout);
if (FLastError = sOK) and (FBuffer <> '') then
begin
Result := Ord(FBuffer[1]);
System.Delete(FBuffer, 1, 1);
end;
ExceptCheck;
end;
function TBlockSerial.RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString;
var
x: Integer;
s: AnsiString;
l: Integer;
CorCRLF: Boolean;
t: ansistring;
tl: integer;
ti: LongWord;
begin
Result := '';
if PreTestFailing then {HGJ}
Exit; {HGJ}
SetSynaError(sOK);
l := system.Length(Terminator);
if l = 0 then
Exit;
tl := l;
CorCRLF := FConvertLineEnd and (Terminator = CRLF);
s := '';
x := 0;
repeat
ti := GetTick;
//get rest of FBuffer or incomming new data...
s := s + RecvPacket(Timeout);
if FLastError <> sOK then
Break;
x := 0;
if Length(s) > 0 then
if CorCRLF then
begin
if FLastCR and (s[1] = LF) then
Delete(s, 1, 1);
if FLastLF and (s[1] = CR) then
Delete(s, 1, 1);
FLastCR := False;
FLastLF := False;
t := '';
x := PosCRLF(s, t);
tl := system.Length(t);
if t = CR then
FLastCR := True;
if t = LF then
FLastLF := True;
end
else
begin
x := pos(Terminator, s);
tl := l;
end;
if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then
begin
SetSynaError(ErrMaxBuffer);
Break;
end;
if x > 0 then
Break;
if not FInterPacketTimeout then
begin
Timeout := Timeout - integer(TickDelta(ti, GetTick));
if Timeout <= 0 then
begin
SetSynaError(ErrTimeout);
Break;
end;
end;
until False;
if x > 0 then
begin
Result := Copy(s, 1, x - 1);
System.Delete(s, 1, x + tl - 1);
end;
FBuffer := s;
ExceptCheck;
end;
function TBlockSerial.RecvString(Timeout: Integer): AnsiString;
var
s: AnsiString;
begin
Result := '';
s := RecvTerminated(Timeout, #13 + #10);
if FLastError = sOK then
Result := s;
end;
function TBlockSerial.RecvInteger(Timeout: Integer): Integer;
var
s: AnsiString;
begin
Result := 0;
s := RecvBufferStr(4, Timeout);
if FLastError = 0 then
Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536;
end;
function TBlockSerial.RecvBlock(Timeout: Integer): AnsiString;
var
x: integer;
begin
Result := '';
x := RecvInteger(Timeout);
if FLastError = 0 then
Result := RecvBufferStr(x, Timeout);
end;
procedure TBlockSerial.RecvStreamRaw(const Stream: TStream; Timeout: Integer);
var
s: AnsiString;
begin
repeat
s := RecvPacket(Timeout);
if FLastError = 0 then
WriteStrToStream(Stream, s);
until FLastError <> 0;
end;
procedure TBlockSerial.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer);
var
s: AnsiString;
n: integer;
begin
for n := 1 to (Size div cSerialChunk) do
begin
s := RecvBufferStr(cSerialChunk, Timeout);
if FLastError <> 0 then
Exit;
Stream.Write(PAnsichar(s)^, cSerialChunk);
end;
n := Size mod cSerialChunk;
if n > 0 then
begin
s := RecvBufferStr(n, Timeout);
if FLastError <> 0 then
Exit;
Stream.Write(PAnsichar(s)^, n);
end;
end;
procedure TBlockSerial.RecvStreamIndy(const Stream: TStream; Timeout: Integer);
var
x: integer;
begin
x := RecvInteger(Timeout);
x := SwapBytes(x);
if FLastError = 0 then
RecvStreamSize(Stream, Timeout, x);
end;
procedure TBlockSerial.RecvStream(const Stream: TStream; Timeout: Integer);
var
x: integer;
begin
x := RecvInteger(Timeout);
if FLastError = 0 then
RecvStreamSize(Stream, Timeout, x);
end;
{$IFNDEF MSWINDOWS}
function TBlockSerial.WaitingData: integer;
begin
{$IFNDEF FPC}
serialcheck(ioctl(FHandle, FIONREAD, @result));
{$ELSE}
serialcheck(fpIoctl(FHandle, FIONREAD, @result));
{$ENDIF}
if FLastError <> 0 then
Result := 0;
ExceptCheck;
end;
{$ELSE}
function TBlockSerial.WaitingData: integer;
var
stat: TComStat;
err: DWORD;
begin
if ClearCommError(FHandle, err, @stat) then
begin
SetSynaError(sOK);
Result := stat.cbInQue;
end
else
begin
SerialCheck(sErr);
Result := 0;
end;
ExceptCheck;
end;
{$ENDIF}
function TBlockSerial.WaitingDataEx: integer;
begin
if FBuffer <> '' then
Result := Length(FBuffer)
else
Result := Waitingdata;
end;
{$IFNDEF MSWINDOWS}
function TBlockSerial.SendingData: integer;
begin
SetSynaError(sOK);
Result := 0;
end;
{$ELSE}
function TBlockSerial.SendingData: integer;
var
stat: TComStat;
err: DWORD;
begin
SetSynaError(sOK);
if not ClearCommError(FHandle, err, @stat) then
serialcheck(sErr);
ExceptCheck;
result := stat.cbOutQue;
end;
{$ENDIF}
{$IFNDEF MSWINDOWS}
procedure TBlockSerial.DcbToTermios(const dcb: TDCB; var term: termios);
var
n: integer;
x: cardinal;
begin
//others
cfmakeraw(term);
term.c_cflag := term.c_cflag or CREAD;
term.c_cflag := term.c_cflag or CLOCAL;
term.c_cflag := term.c_cflag or HUPCL;
//hardware handshake
if (dcb.flags and dcb_RtsControlHandshake) > 0 then
term.c_cflag := term.c_cflag or CRTSCTS
else
term.c_cflag := term.c_cflag and (not CRTSCTS);
//software handshake
if (dcb.flags and dcb_OutX) > 0 then
term.c_iflag := term.c_iflag or IXON or IXOFF or IXANY
else
term.c_iflag := term.c_iflag and (not (IXON or IXOFF or IXANY));
//size of byte
term.c_cflag := term.c_cflag and (not CSIZE);
case dcb.bytesize of
5:
term.c_cflag := term.c_cflag or CS5;
6:
term.c_cflag := term.c_cflag or CS6;
7:
{$IFDEF FPC}
term.c_cflag := term.c_cflag or CS7;
{$ELSE}
term.c_cflag := term.c_cflag or CS7fix;
{$ENDIF}
8:
term.c_cflag := term.c_cflag or CS8;
end;
//parity
if (dcb.flags and dcb_ParityCheck) > 0 then
term.c_cflag := term.c_cflag or PARENB
else
term.c_cflag := term.c_cflag and (not PARENB);
case dcb.parity of
1: //'O'
term.c_cflag := term.c_cflag or PARODD;
2: //'E'
term.c_cflag := term.c_cflag and (not PARODD);
end;
//stop bits
if dcb.stopbits > 0 then
term.c_cflag := term.c_cflag or CSTOPB
else
term.c_cflag := term.c_cflag and (not CSTOPB);
//set baudrate;
x := 0;
for n := 0 to Maxrates do
if rates[n, 0] = dcb.BaudRate then
begin
x := rates[n, 1];
break;
end;
cfsetospeed(term, x);
cfsetispeed(term, x);
end;
procedure TBlockSerial.TermiosToDcb(const term: termios; var dcb: TDCB);
var
n: integer;
x: cardinal;
begin
//set baudrate;
dcb.baudrate := 0;
{$IFDEF FPC}
//why FPC not have cfgetospeed???
x := term.c_oflag and $0F;
{$ELSE}
x := cfgetospeed(term);
{$ENDIF}
for n := 0 to Maxrates do
if rates[n, 1] = x then
begin
dcb.baudrate := rates[n, 0];
break;
end;
//hardware handshake
if (term.c_cflag and CRTSCTS) > 0 then
dcb.flags := dcb.flags or dcb_RtsControlHandshake or dcb_OutxCtsFlow
else
dcb.flags := dcb.flags and (not (dcb_RtsControlHandshake or dcb_OutxCtsFlow));
//software handshake
if (term.c_cflag and IXOFF) > 0 then
dcb.flags := dcb.flags or dcb_OutX or dcb_InX
else
dcb.flags := dcb.flags and (not (dcb_OutX or dcb_InX));
//size of byte
case term.c_cflag and CSIZE of
CS5:
dcb.bytesize := 5;
CS6:
dcb.bytesize := 6;
CS7fix:
dcb.bytesize := 7;
CS8:
dcb.bytesize := 8;
end;
//parity
if (term.c_cflag and PARENB) > 0 then
dcb.flags := dcb.flags or dcb_ParityCheck
else
dcb.flags := dcb.flags and (not dcb_ParityCheck);
dcb.parity := 0;
if (term.c_cflag and PARODD) > 0 then
dcb.parity := 1
else
dcb.parity := 2;
//stop bits
if (term.c_cflag and CSTOPB) > 0 then
dcb.stopbits := 2
else
dcb.stopbits := 0;
end;
{$ENDIF}
{$IFNDEF MSWINDOWS}
procedure TBlockSerial.SetCommState;
begin
DcbToTermios(dcb, termiosstruc);
SerialCheck(tcsetattr(FHandle, TCSANOW, termiosstruc));
ExceptCheck;
end;
{$ELSE}
procedure TBlockSerial.SetCommState;
begin
SetSynaError(sOK);
if not windows.SetCommState(Fhandle, dcb) then
SerialCheck(sErr);
ExceptCheck;
end;
{$ENDIF}
{$IFNDEF MSWINDOWS}
procedure TBlockSerial.GetCommState;
begin
SerialCheck(tcgetattr(FHandle, termiosstruc));
ExceptCheck;
TermiostoDCB(termiosstruc, dcb);
end;
{$ELSE}
procedure TBlockSerial.GetCommState;
begin
SetSynaError(sOK);
if not windows.GetCommState(Fhandle, dcb) then
SerialCheck(sErr);
ExceptCheck;
end;
{$ENDIF}
procedure TBlockSerial.SetSizeRecvBuffer(size: integer);
begin
{$IFDEF MSWINDOWS}
SetupComm(Fhandle, size, 0);
GetCommState;
dcb.XonLim := size div 4;
dcb.XoffLim := size div 4;
SetCommState;
{$ENDIF}
FRecvBuffer := size;
end;
function TBlockSerial.GetDSR: Boolean;
begin
ModemStatus;
{$IFNDEF MSWINDOWS}
Result := (FModemWord and TIOCM_DSR) > 0;
{$ELSE}
Result := (FModemWord and MS_DSR_ON) > 0;
{$ENDIF}
end;
procedure TBlockSerial.SetDTRF(Value: Boolean);
begin
{$IFNDEF MSWINDOWS}
ModemStatus;
if Value then
FModemWord := FModemWord or TIOCM_DTR
else
FModemWord := FModemWord and not TIOCM_DTR;
{$IFNDEF FPC}
ioctl(FHandle, TIOCMSET, @FModemWord);
{$ELSE}
fpioctl(FHandle, TIOCMSET, @FModemWord);
{$ENDIF}
{$ELSE}
if Value then
EscapeCommFunction(FHandle, SETDTR)
else
EscapeCommFunction(FHandle, CLRDTR);
{$ENDIF}
end;
function TBlockSerial.GetCTS: Boolean;
begin
ModemStatus;
{$IFNDEF MSWINDOWS}
Result := (FModemWord and TIOCM_CTS) > 0;
{$ELSE}
Result := (FModemWord and MS_CTS_ON) > 0;
{$ENDIF}
end;
procedure TBlockSerial.SetRTSF(Value: Boolean);
begin
{$IFNDEF MSWINDOWS}
ModemStatus;
if Value then
FModemWord := FModemWord or TIOCM_RTS
else
FModemWord := FModemWord and not TIOCM_RTS;
{$IFNDEF FPC}
ioctl(FHandle, TIOCMSET, @FModemWord);
{$ELSE}
fpioctl(FHandle, TIOCMSET, @FModemWord);
{$ENDIF}
{$ELSE}
if Value then
EscapeCommFunction(FHandle, SETRTS)
else
EscapeCommFunction(FHandle, CLRRTS);
{$ENDIF}
end;
function TBlockSerial.GetCarrier: Boolean;
begin
ModemStatus;
{$IFNDEF MSWINDOWS}
Result := (FModemWord and TIOCM_CAR) > 0;
{$ELSE}
Result := (FModemWord and MS_RLSD_ON) > 0;
{$ENDIF}
end;
function TBlockSerial.GetRing: Boolean;
begin
ModemStatus;
{$IFNDEF MSWINDOWS}
Result := (FModemWord and TIOCM_RNG) > 0;
{$ELSE}
Result := (FModemWord and MS_RING_ON) > 0;
{$ENDIF}
end;
{$IFDEF MSWINDOWS}
function TBlockSerial.CanEvent(Event: dword; Timeout: integer): boolean;
var
ex: DWord;
y: Integer;
Overlapped: TOverlapped;
begin
FillChar(Overlapped, Sizeof(Overlapped), 0);
Overlapped.hEvent := CreateEvent(nil, True, False, nil);
try
SetCommMask(FHandle, Event);
SetSynaError(sOK);
if (Event = EV_RXCHAR) and (Waitingdata > 0) then
Result := True
else
begin
y := 0;
if not WaitCommEvent(FHandle, ex, @Overlapped) then
y := GetLastError;
if y = ERROR_IO_PENDING then
begin
//timedout
WaitForSingleObject(Overlapped.hEvent, Timeout);
SetCommMask(FHandle, 0);
GetOverlappedResult(FHandle, Overlapped, DWord(y), True);
end;
Result := (ex and Event) = Event;
end;
finally
SetCommMask(FHandle, 0);
CloseHandle(Overlapped.hEvent);
end;
end;
{$ENDIF}
{$IFNDEF MSWINDOWS}
function TBlockSerial.CanRead(Timeout: integer): boolean;
var
FDSet: TFDSet;
TimeVal: PTimeVal;
TimeV: TTimeVal;
x: Integer;
begin
TimeV.tv_usec := (Timeout mod 1000) * 1000;
TimeV.tv_sec := Timeout div 1000;
TimeVal := @TimeV;
if Timeout = -1 then
TimeVal := nil;
{$IFNDEF FPC}
FD_ZERO(FDSet);
FD_SET(FHandle, FDSet);
x := Select(FHandle + 1, @FDSet, nil, nil, TimeVal);
{$ELSE}
fpFD_ZERO(FDSet);
fpFD_SET(FHandle, FDSet);
x := fpSelect(FHandle + 1, @FDSet, nil, nil, TimeVal);
{$ENDIF}
SerialCheck(x);
if FLastError <> sOK then
x := 0;
Result := x > 0;
ExceptCheck;
if Result then
DoStatus(HR_CanRead, '');
end;
{$ELSE}
function TBlockSerial.CanRead(Timeout: integer): boolean;
begin
Result := WaitingData > 0;
if not Result then
Result := CanEvent(EV_RXCHAR, Timeout) or (WaitingData > 0);
//check WaitingData again due some broken virtual ports
if Result then
DoStatus(HR_CanRead, '');
end;
{$ENDIF}
{$IFNDEF MSWINDOWS}
function TBlockSerial.CanWrite(Timeout: integer): boolean;
var
FDSet: TFDSet;
TimeVal: PTimeVal;
TimeV: TTimeVal;
x: Integer;
begin
TimeV.tv_usec := (Timeout mod 1000) * 1000;
TimeV.tv_sec := Timeout div 1000;
TimeVal := @TimeV;
if Timeout = -1 then
TimeVal := nil;
{$IFNDEF FPC}
FD_ZERO(FDSet);
FD_SET(FHandle, FDSet);
x := Select(FHandle + 1, nil, @FDSet, nil, TimeVal);
{$ELSE}
fpFD_ZERO(FDSet);
fpFD_SET(FHandle, FDSet);
x := fpSelect(FHandle + 1, nil, @FDSet, nil, TimeVal);
{$ENDIF}
SerialCheck(x);
if FLastError <> sOK then
x := 0;
Result := x > 0;
ExceptCheck;
if Result then
DoStatus(HR_CanWrite, '');
end;
{$ELSE}
function TBlockSerial.CanWrite(Timeout: integer): boolean;
var
t: LongWord;
begin
Result := SendingData = 0;
if not Result then
Result := CanEvent(EV_TXEMPTY, Timeout);
if Result and (Win32Platform <> VER_PLATFORM_WIN32_NT) then
begin
t := GetTick;
while not ReadTxEmpty(FPortAddr) do
begin
if TickDelta(t, GetTick) > 255 then
Break;
Sleep(0);
end;
end;
if Result then
DoStatus(HR_CanWrite, '');
end;
{$ENDIF}
function TBlockSerial.CanReadEx(Timeout: integer): boolean;
begin
if Fbuffer <> '' then
Result := True
else
Result := CanRead(Timeout);
end;
procedure TBlockSerial.EnableRTSToggle(Value: boolean);
begin
SetSynaError(sOK);
{$IFNDEF MSWINDOWS}
FRTSToggle := Value;
if Value then
RTS:=False;
{$ELSE}
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
GetCommState;
if value then
dcb.Flags := dcb.Flags or dcb_RtsControlToggle
else
dcb.flags := dcb.flags and (not dcb_RtsControlToggle);
SetCommState;
end
else
begin
FRTSToggle := Value;
if Value then
RTS:=False;
end;
{$ENDIF}
end;
procedure TBlockSerial.Flush;
begin
{$IFNDEF MSWINDOWS}
SerialCheck(tcdrain(FHandle));
{$ELSE}
SetSynaError(sOK);
if not Flushfilebuffers(FHandle) then
SerialCheck(sErr);
{$ENDIF}
ExceptCheck;
end;
{$IFNDEF MSWINDOWS}
procedure TBlockSerial.Purge;
begin
{$IFNDEF FPC}
SerialCheck(ioctl(FHandle, TCFLSH, TCIOFLUSH));
{$ELSE}
{$IFDEF DARWIN}
SerialCheck(fpioctl(FHandle, TCIOflush, TCIOFLUSH));
{$ELSE}
SerialCheck(fpioctl(FHandle, TCFLSH, TCIOFLUSH));
{$ENDIF}
{$ENDIF}
FBuffer := '';
ExceptCheck;
end;
{$ELSE}
procedure TBlockSerial.Purge;
var
x: integer;
begin
SetSynaError(sOK);
x := PURGE_TXABORT or PURGE_TXCLEAR or PURGE_RXABORT or PURGE_RXCLEAR;
if not PurgeComm(FHandle, x) then
SerialCheck(sErr);
FBuffer := '';
ExceptCheck;
end;
{$ENDIF}
function TBlockSerial.ModemStatus: integer;
begin
Result := 0;
{$IFNDEF MSWINDOWS}
{$IFNDEF FPC}
SerialCheck(ioctl(FHandle, TIOCMGET, @Result));
{$ELSE}
SerialCheck(fpioctl(FHandle, TIOCMGET, @Result));
{$ENDIF}
{$ELSE}
SetSynaError(sOK);
if not GetCommModemStatus(FHandle, dword(Result)) then
SerialCheck(sErr);
{$ENDIF}
ExceptCheck;
FModemWord := Result;
end;
procedure TBlockSerial.SetBreak(Duration: integer);
begin
{$IFNDEF MSWINDOWS}
SerialCheck(tcsendbreak(FHandle, Duration));
{$ELSE}
SetCommBreak(FHandle);
Sleep(Duration);
SetSynaError(sOK);
if not ClearCommBreak(FHandle) then
SerialCheck(sErr);
{$ENDIF}
end;
{$IFDEF MSWINDOWS}
procedure TBlockSerial.DecodeCommError(Error: DWord);
begin
if (Error and DWord(CE_FRAME)) > 1 then
FLastError := ErrFrame;
if (Error and DWord(CE_OVERRUN)) > 1 then
FLastError := ErrOverrun;
if (Error and DWord(CE_RXOVER)) > 1 then
FLastError := ErrRxOver;
if (Error and DWord(CE_RXPARITY)) > 1 then
FLastError := ErrRxParity;
if (Error and DWord(CE_TXFULL)) > 1 then
FLastError := ErrTxFull;
end;
{$ENDIF}
//HGJ
function TBlockSerial.PreTestFailing: Boolean;
begin
if not FInstanceActive then
begin
RaiseSynaError(ErrPortNotOpen);
result:= true;
Exit;
end;
Result := not TestCtrlLine;
if result then
RaiseSynaError(ErrNoDeviceAnswer)
end;
function TBlockSerial.TestCtrlLine: Boolean;
begin
result := ((not FTestDSR) or DSR) and ((not FTestCTS) or CTS);
end;
function TBlockSerial.ATCommand(value: AnsiString): AnsiString;
var
s: AnsiString;
ConvSave: Boolean;
begin
result := '';
FAtResult := False;
ConvSave := FConvertLineEnd;
try
FConvertLineEnd := True;
SendString(value + #$0D);
repeat
s := RecvString(FAtTimeout);
if s <> Value then
result := result + s + CRLF;
if s = 'OK' then
begin
FAtResult := True;
break;
end;
if s = 'ERROR' then
break;
until FLastError <> sOK;
finally
FConvertLineEnd := Convsave;
end;
end;
function TBlockSerial.ATConnect(value: AnsiString): AnsiString;
var
s: AnsiString;
ConvSave: Boolean;
begin
result := '';
FAtResult := False;
ConvSave := FConvertLineEnd;
try
FConvertLineEnd := True;
SendString(value + #$0D);
repeat
s := RecvString(90 * FAtTimeout);
if s <> Value then
result := result + s + CRLF;
if s = 'NO CARRIER' then
break;
if s = 'ERROR' then
break;
if s = 'BUSY' then
break;
if s = 'NO DIALTONE' then
break;
if Pos('CONNECT', s) = 1 then
begin
FAtResult := True;
break;
end;
until FLastError <> sOK;
finally
FConvertLineEnd := Convsave;
end;
end;
function TBlockSerial.SerialCheck(SerialResult: integer): integer;
begin
if SerialResult = integer(INVALID_HANDLE_VALUE) then
{$IFDEF MSWINDOWS}
result := GetLastError
{$ELSE}
{$IFNDEF FPC}
result := GetLastError
{$ELSE}
result := fpGetErrno
{$ENDIF}
{$ENDIF}
else
result := sOK;
FLastError := result;
FLastErrorDesc := GetErrorDesc(FLastError);
end;
procedure TBlockSerial.ExceptCheck;
var
e: ESynaSerError;
s: string;
begin
if FRaiseExcept and (FLastError <> sOK) then
begin
s := GetErrorDesc(FLastError);
e := ESynaSerError.CreateFmt('Communication error %d: %s', [FLastError, s]);
e.ErrorCode := FLastError;
e.ErrorMessage := s;
raise e;
end;
end;
procedure TBlockSerial.SetSynaError(ErrNumber: integer);
begin
FLastError := ErrNumber;
FLastErrorDesc := GetErrorDesc(FLastError);
end;
procedure TBlockSerial.RaiseSynaError(ErrNumber: integer);
begin
SetSynaError(ErrNumber);
ExceptCheck;
end;
procedure TBlockSerial.DoStatus(Reason: THookSerialReason; const Value: string);
begin
if assigned(OnStatus) then
OnStatus(Self, Reason, Value);
end;
{======================================================================}
class function TBlockSerial.GetErrorDesc(ErrorCode: integer): string;
begin
Result:= '';
case ErrorCode of
sOK: Result := 'OK';
ErrAlreadyOwned: Result := 'Port owned by other process';{HGJ}
ErrAlreadyInUse: Result := 'Instance already in use'; {HGJ}
ErrWrongParameter: Result := 'Wrong paramter at call'; {HGJ}
ErrPortNotOpen: Result := 'Instance not yet connected'; {HGJ}
ErrNoDeviceAnswer: Result := 'No device answer detected'; {HGJ}
ErrMaxBuffer: Result := 'Maximal buffer length exceeded';
ErrTimeout: Result := 'Timeout during operation';
ErrNotRead: Result := 'Reading of data failed';
ErrFrame: Result := 'Receive framing error';
ErrOverrun: Result := 'Receive Overrun Error';
ErrRxOver: Result := 'Receive Queue overflow';
ErrRxParity: Result := 'Receive Parity Error';
ErrTxFull: Result := 'Tranceive Queue is full';
end;
if Result = '' then
begin
Result := SysErrorMessage(ErrorCode);
end;
end;
{---------- cpom Comport Ownership Manager Routines -------------
by Hans-Georg Joepgen of Stuttgart, Germany.
Copyright (c) 2002, by Hans-Georg Joepgen
Stefan Krauss of Stuttgart, Germany, contributed literature and Internet
research results, invaluable advice and excellent answers to the Comport
Ownership Manager.
}
{$IFDEF UNIX}
function TBlockSerial.LockfileName: String;
var
s: string;
begin
s := SeparateRight(FDevice, '/dev/');
result := LockfileDirectory + '/LCK..' + s;
end;
procedure TBlockSerial.CreateLockfile(PidNr: integer);
var
f: TextFile;
s: string;
begin
// Create content for file
s := IntToStr(PidNr);
while length(s) < 10 do
s := ' ' + s;
// Create file
try
AssignFile(f, LockfileName);
try
Rewrite(f);
writeln(f, s);
finally
CloseFile(f);
end;
// Allow all users to enjoy the benefits of cpom
s := 'chmod a+rw ' + LockfileName;
{$IFNDEF FPC}
FileSetReadOnly( LockfileName, False ) ;
// Libc.system(pchar(s));
{$ELSE}
fpSystem(s);
{$ENDIF}
except
// not raise exception, if you not have write permission for lock.
on Exception do
;
end;
end;
function TBlockSerial.ReadLockfile: integer;
{Returns PID from Lockfile. Lockfile must exist.}
var
f: TextFile;
s: string;
begin
AssignFile(f, LockfileName);
Reset(f);
try
readln(f, s);
finally
CloseFile(f);
end;
Result := StrToIntDef(s, -1)
end;
function TBlockSerial.cpomComportAccessible: boolean;
var
MyPid: integer;
Filename: string;
begin
Filename := LockfileName;
{$IFNDEF FPC}
MyPid := Libc.getpid;
{$ELSE}
MyPid := fpGetPid;
{$ENDIF}
// Make sure, the Lock Files Directory exists. We need it.
if not DirectoryExists(LockfileDirectory) then
CreateDir(LockfileDirectory);
// Check the Lockfile
if not FileExists (Filename) then
begin // comport is not locked. Lock it for us.
CreateLockfile(MyPid);
result := true;
exit; // done.
end;
// Is port owned by orphan? Then it's time for error recovery.
//FPC forgot to add getsid.. :-(
{$IFNDEF FPC}
if Libc.getsid(ReadLockfile) = -1 then
begin // Lockfile was left from former desaster
DeleteFile(Filename); // error recovery
CreateLockfile(MyPid);
result := true;
exit;
end;
{$ENDIF}
result := false // Sorry, port is owned by living PID and locked
end;
procedure TBlockSerial.cpomReleaseComport;
begin
DeleteFile(LockfileName);
end;
{$ENDIF}
{----------------------------------------------------------------}
{$IFDEF MSWINDOWS}
function GetSerialPortNames: string;
var
reg: TRegistry;
l, v: TStringList;
n: integer;
begin
l := TStringList.Create;
v := TStringList.Create;
reg := TRegistry.Create;
try
{$IFNDEF VER100}
{$IFNDEF VER120}
reg.Access := KEY_READ;
{$ENDIF}
{$ENDIF}
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('\HARDWARE\DEVICEMAP\SERIALCOMM', false);
reg.GetValueNames(l);
for n := 0 to l.Count - 1 do
v.Add(reg.ReadString(l[n]));
Result := v.CommaText;
finally
reg.Free;
l.Free;
v.Free;
end;
end;
{$ENDIF}
{$IFNDEF MSWINDOWS}
function GetSerialPortNames: string;
var
Index: Integer;
Data: string;
TmpPorts: String;
sr : TSearchRec;
begin
try
TmpPorts := '';
if FindFirst('/dev/ttyS*', $FFFFFFFF, sr) = 0 then
begin
repeat
if (sr.Attr and $FFFFFFFF) = Sr.Attr then
begin
data := sr.Name;
index := length(data);
while (index > 1) and (data[index] <> '/') do
index := index - 1;
TmpPorts := TmpPorts + ' ' + copy(data, 1, index + 1);
end;
until FindNext(sr) <> 0;
end;
FindClose(sr);
finally
Result:=TmpPorts;
end;
end;
{$ENDIF}
end.
TransGUI/synapse/source/lib/mimepart.pas 0000644 0000000 0000000 00000101274 11366572451 017302 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 002.008.000 |
|==============================================================================|
| Content: MIME support procedures and functions |
|==============================================================================|
| Copyright (c)1999-2008, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2008. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(MIME part handling)
Handling with MIME parts.
Used RFC: RFC-2045
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$Q-}
{$R-}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit mimepart;
interface
uses
SysUtils, Classes,
synafpc,
synachar, synacode, synautil, mimeinln;
type
TMimePart = class;
{:@abstract(Procedural type for @link(TMimepart.Walkpart) hook). This hook is used for
easy walking through MIME subparts.}
THookWalkPart = procedure(const Sender: TMimePart) of object;
{:The four types of MIME parts. (textual, multipart, message or any other
binary data.)}
TMimePrimary = (MP_TEXT, MP_MULTIPART, MP_MESSAGE, MP_BINARY);
{:The various types of possible part encodings.}
TMimeEncoding = (ME_7BIT, ME_8BIT, ME_QUOTED_PRINTABLE,
ME_BASE64, ME_UU, ME_XX);
{:@abstract(Object for working with parts of MIME e-mail.)
Each TMimePart object can handle any number of nested subparts as new
TMimepart objects. It can handle any tree hierarchy structure of nested MIME
subparts itself.
Basic tasks are:
Decoding of MIME message:
- store message into Lines property
- call DecomposeParts. Now you have decomposed MIME parts in all nested levels!
- now you can explore all properties and subparts. (You can use WalkPart method)
- if you need decode part, call DecodePart.
Encoding of MIME message:
- if you need multipart message, you must create subpart by AddSubPart.
- set all properties of all parts.
- set content of part into DecodedLines stream
- encode this stream by EncodePart.
- compose full message by ComposeParts. (it build full MIME message from all subparts. Do not call this method for each subpart! It is needed on root part!)
- encoded MIME message is stored in Lines property.
}
TMimePart = class(TObject)
private
FPrimary: string;
FPrimaryCode: TMimePrimary;
FSecondary: string;
FEncoding: string;
FEncodingCode: TMimeEncoding;
FDefaultCharset: string;
FCharset: string;
FCharsetCode: TMimeChar;
FTargetCharset: TMimeChar;
FDescription: string;
FDisposition: string;
FContentID: string;
FBoundary: string;
FFileName: string;
FLines: TStringList;
FPartBody: TStringList;
FHeaders: TStringList;
FPrePart: TStringList;
FPostPart: TStringList;
FDecodedLines: TMemoryStream;
FSubParts: TList;
FOnWalkPart: THookWalkPart;
FMaxLineLength: integer;
FSubLevel: integer;
FMaxSubLevel: integer;
FAttachInside: boolean;
FConvertCharset: Boolean;
FForcedHTMLConvert: Boolean;
procedure SetPrimary(Value: string);
procedure SetEncoding(Value: string);
procedure SetCharset(Value: string);
function IsUUcode(Value: string): boolean;
public
constructor Create;
destructor Destroy; override;
{:Assign content of another object to this object. (Only this part,
not subparts!)}
procedure Assign(Value: TMimePart);
{:Assign content of another object to this object. (With all subparts!)}
procedure AssignSubParts(Value: TMimePart);
{:Clear all data values to default values. It also call @link(ClearSubparts).}
procedure Clear;
{:Decode Mime part from @link(Lines) to @link(DecodedLines).}
procedure DecodePart;
{:Parse header lines from Headers property into another properties.}
procedure DecodePartHeader;
{:Encode mime part from @link(DecodedLines) to @link(Lines) and build mime
headers.}
procedure EncodePart;
{:Build header lines in Headers property from another properties.}
procedure EncodePartHeader;
{:generate primary and secondary mime type from filename extension in value.
If type not recognised, it return 'Application/octet-string' type.}
procedure MimeTypeFromExt(Value: string);
{:Return number of decomposed subparts. (On this level! Each of this
subparts can hold any number of their own nested subparts!)}
function GetSubPartCount: integer;
{:Get nested subpart object as new TMimePart. For getting maximum possible
index you can use @link(GetSubPartCount) method.}
function GetSubPart(index: integer): TMimePart;
{:delete subpart on given index.}
procedure DeleteSubPart(index: integer);
{:Clear and destroy all subpart TMimePart objects.}
procedure ClearSubParts;
{:Add and create new subpart.}
function AddSubPart: TMimePart;
{:E-mail message in @link(Lines) property is parsed into this object.
E-mail headers are stored in @link(Headers) property and is parsed into
another properties automaticly. Not need call @link(DecodePartHeader)!
Content of message (part) is stored into @link(PartBody) property. This
part is in undecoded form! If you need decode it, then you must call
@link(DecodePart) method by your hands. Lot of another properties is filled
also.
Decoding of parts you must call separately due performance reasons. (Not
needed to decode all parts in all reasons.)
For each MIME subpart is created new TMimepart object (accessible via
method @link(GetSubPart)).}
procedure DecomposeParts;
{:This part and all subparts is composed into one MIME message stored in
@link(Lines) property.}
procedure ComposeParts;
{:By calling this method is called @link(OnWalkPart) event for each part
and their subparts. It is very good for calling some code for each part in
MIME message}
procedure WalkPart;
{:Return @true when is possible create next subpart. (@link(maxSublevel)
is still not reached)}
function CanSubPart: boolean;
published
{:Primary Mime type of part. (i.e. 'application') Writing to this property
automaticly generate value of @link(PrimaryCode).}
property Primary: string read FPrimary write SetPrimary;
{:String representation of used Mime encoding in part. (i.e. 'base64')
Writing to this property automaticly generate value of @link(EncodingCode).}
property Encoding: string read FEncoding write SetEncoding;
{:String representation of used Mime charset in part. (i.e. 'iso-8859-1')
Writing to this property automaticly generate value of @link(CharsetCode).
Charset is used only for text parts.}
property Charset: string read FCharset write SetCharset;
{:Define default charset for decoding text MIME parts without charset
specification. Default value is 'ISO-8859-1' by RCF documents.
But Microsoft Outlook use windows codings as default. This property allows
properly decode textual parts from some broken versions of Microsoft
Outlook. (this is bad software!)}
property DefaultCharset: string read FDefaultCharset write FDefaultCharset;
{:Decoded primary type. Possible values are: MP_TEXT, MP_MULTIPART,
MP_MESSAGE and MP_BINARY. If type not recognised, result is MP_BINARY.}
property PrimaryCode: TMimePrimary read FPrimaryCode Write FPrimaryCode;
{:Decoded encoding type. Possible values are: ME_7BIT, ME_8BIT,
ME_QUOTED_PRINTABLE and ME_BASE64. If type not recognised, result is
ME_7BIT.}
property EncodingCode: TMimeEncoding read FEncodingCode Write FEncodingCode;
{:Decoded charset type. Possible values are defined in @link(SynaChar) unit.}
property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
{:System charset type. Default value is charset used by default in your
operating system.}
property TargetCharset: TMimeChar read FTargetCharset Write FTargetCharset;
{:If @true, then do internal charset translation of part content between @link(CharsetCode)
and @link(TargetCharset)}
property ConvertCharset: Boolean read FConvertCharset Write FConvertCharset;
{:If @true, then allways do internal charset translation of HTML parts
by MIME even it have their own charset in META tag. Default is @false.}
property ForcedHTMLConvert: Boolean read FForcedHTMLConvert Write FForcedHTMLConvert;
{:Secondary Mime type of part. (i.e. 'mixed')}
property Secondary: string read FSecondary Write FSecondary;
{:Description of Mime part.}
property Description: string read FDescription Write FDescription;
{:Value of content disposition field. (i.e. 'inline' or 'attachment')}
property Disposition: string read FDisposition Write FDisposition;
{:Content ID.}
property ContentID: string read FContentID Write FContentID;
{:Boundary delimiter of multipart Mime part. Used only in multipart part.}
property Boundary: string read FBoundary Write FBoundary;
{:Filename of file in binary part.}
property FileName: string read FFileName Write FFileName;
{:String list with lines contains mime part (It can be a full message).}
property Lines: TStringList read FLines;
{:Encoded form of MIME part data.}
property PartBody: TStringList read FPartBody;
{:All header lines of MIME part.}
property Headers: TStringList read FHeaders;
{:On multipart this contains part of message between first line of message
and first boundary.}
property PrePart: TStringList read FPrePart;
{:On multipart this contains part of message between last boundary and end
of message.}
property PostPart: TStringList read FPostPart;
{:Stream with decoded form of budy part.}
property DecodedLines: TMemoryStream read FDecodedLines;
{:Show nested level in subpart tree. Value 0 means root part. 1 means
subpart from this root. etc.}
property SubLevel: integer read FSubLevel write FSubLevel;
{:Specify maximum sublevel value for decomposing.}
property MaxSubLevel: integer read FMaxSubLevel write FMaxSubLevel;
{:When is @true, then this part maybe(!) have included some uuencoded binary
data.}
property AttachInside: boolean read FAttachInside;
{:Here you can assign hook procedure for walking through all part and their
subparts.}
property OnWalkPart: THookWalkPart read FOnWalkPart write FOnWalkPart;
{:Here you can specify maximum line length for encoding of MIME part.
If line is longer, then is splitted by standard of MIME. Correct MIME
mailers can de-split this line into original length.}
property MaxLineLength: integer read FMaxLineLength Write FMaxLineLength;
end;
const
MaxMimeType = 25;
MimeType: array[0..MaxMimeType, 0..2] of string =
(
('AU', 'audio', 'basic'),
('AVI', 'video', 'x-msvideo'),
('BMP', 'image', 'BMP'),
('DOC', 'application', 'MSWord'),
('EPS', 'application', 'Postscript'),
('GIF', 'image', 'GIF'),
('JPEG', 'image', 'JPEG'),
('JPG', 'image', 'JPEG'),
('MID', 'audio', 'midi'),
('MOV', 'video', 'quicktime'),
('MPEG', 'video', 'MPEG'),
('MPG', 'video', 'MPEG'),
('MP2', 'audio', 'mpeg'),
('MP3', 'audio', 'mpeg'),
('PDF', 'application', 'PDF'),
('PNG', 'image', 'PNG'),
('PS', 'application', 'Postscript'),
('QT', 'video', 'quicktime'),
('RA', 'audio', 'x-realaudio'),
('RTF', 'application', 'RTF'),
('SND', 'audio', 'basic'),
('TIF', 'image', 'TIFF'),
('TIFF', 'image', 'TIFF'),
('WAV', 'audio', 'x-wav'),
('WPD', 'application', 'Wordperfect5.1'),
('ZIP', 'application', 'ZIP')
);
{:Generates a unique boundary string.}
function GenerateBoundary: string;
implementation
{==============================================================================}
constructor TMIMEPart.Create;
begin
inherited Create;
FOnWalkPart := nil;
FLines := TStringList.Create;
FPartBody := TStringList.Create;
FHeaders := TStringList.Create;
FPrePart := TStringList.Create;
FPostPart := TStringList.Create;
FDecodedLines := TMemoryStream.Create;
FSubParts := TList.Create;
FTargetCharset := GetCurCP;
//was 'US-ASCII' before, but RFC-ignorant Outlook sometimes using default
//system charset instead.
FDefaultCharset := GetIDFromCP(GetCurCP);
FMaxLineLength := 78;
FSubLevel := 0;
FMaxSubLevel := -1;
FAttachInside := false;
FConvertCharset := true;
FForcedHTMLConvert := false;
end;
destructor TMIMEPart.Destroy;
begin
ClearSubParts;
FSubParts.Free;
FDecodedLines.Free;
FPartBody.Free;
FLines.Free;
FHeaders.Free;
FPrePart.Free;
FPostPart.Free;
inherited Destroy;
end;
{==============================================================================}
procedure TMIMEPart.Clear;
begin
FPrimary := '';
FEncoding := '';
FCharset := '';
FPrimaryCode := MP_TEXT;
FEncodingCode := ME_7BIT;
FCharsetCode := ISO_8859_1;
FTargetCharset := GetCurCP;
FSecondary := '';
FDisposition := '';
FContentID := '';
FDescription := '';
FBoundary := '';
FFileName := '';
FAttachInside := False;
FPartBody.Clear;
FHeaders.Clear;
FPrePart.Clear;
FPostPart.Clear;
FDecodedLines.Clear;
FConvertCharset := true;
FForcedHTMLConvert := false;
ClearSubParts;
end;
{==============================================================================}
procedure TMIMEPart.Assign(Value: TMimePart);
begin
Primary := Value.Primary;
Encoding := Value.Encoding;
Charset := Value.Charset;
DefaultCharset := Value.DefaultCharset;
PrimaryCode := Value.PrimaryCode;
EncodingCode := Value.EncodingCode;
CharsetCode := Value.CharsetCode;
TargetCharset := Value.TargetCharset;
Secondary := Value.Secondary;
Description := Value.Description;
Disposition := Value.Disposition;
ContentID := Value.ContentID;
Boundary := Value.Boundary;
FileName := Value.FileName;
Lines.Assign(Value.Lines);
PartBody.Assign(Value.PartBody);
Headers.Assign(Value.Headers);
PrePart.Assign(Value.PrePart);
PostPart.Assign(Value.PostPart);
MaxLineLength := Value.MaxLineLength;
FAttachInside := Value.AttachInside;
FConvertCharset := Value.ConvertCharset;
end;
{==============================================================================}
procedure TMIMEPart.AssignSubParts(Value: TMimePart);
var
n: integer;
p: TMimePart;
begin
Assign(Value);
for n := 0 to Value.GetSubPartCount - 1 do
begin
p := AddSubPart;
p.AssignSubParts(Value.GetSubPart(n));
end;
end;
{==============================================================================}
function TMIMEPart.GetSubPartCount: integer;
begin
Result := FSubParts.Count;
end;
{==============================================================================}
function TMIMEPart.GetSubPart(index: integer): TMimePart;
begin
Result := nil;
if Index < GetSubPartCount then
Result := TMimePart(FSubParts[Index]);
end;
{==============================================================================}
procedure TMIMEPart.DeleteSubPart(index: integer);
begin
if Index < GetSubPartCount then
begin
GetSubPart(Index).Free;
FSubParts.Delete(Index);
end;
end;
{==============================================================================}
procedure TMIMEPart.ClearSubParts;
var
n: integer;
begin
for n := 0 to GetSubPartCount - 1 do
TMimePart(FSubParts[n]).Free;
FSubParts.Clear;
end;
{==============================================================================}
function TMIMEPart.AddSubPart: TMimePart;
begin
Result := TMimePart.Create;
Result.DefaultCharset := FDefaultCharset;
FSubParts.Add(Result);
Result.SubLevel := FSubLevel + 1;
Result.MaxSubLevel := FMaxSubLevel;
end;
{==============================================================================}
procedure TMIMEPart.DecomposeParts;
var
x: integer;
s: string;
Mime: TMimePart;
procedure SkipEmpty;
begin
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
if s <> '' then
Break;
Inc(x);
end;
end;
begin
x := 0;
Clear;
//extract headers
while FLines.Count > x do
begin
s := NormalizeHeader(FLines, x);
if s = '' then
Break;
FHeaders.Add(s);
end;
DecodePartHeader;
//extract prepart
if FPrimaryCode = MP_MULTIPART then
begin
while FLines.Count > x do
begin
s := FLines[x];
Inc(x);
if TrimRight(s) = '--' + FBoundary then
Break;
FPrePart.Add(s);
if not FAttachInside then
FAttachInside := IsUUcode(s);
end;
end;
//extract body part
if FPrimaryCode = MP_MULTIPART then
begin
repeat
if CanSubPart then
begin
Mime := AddSubPart;
while FLines.Count > x do
begin
s := FLines[x];
Inc(x);
if Pos('--' + FBoundary, s) = 1 then
Break;
Mime.Lines.Add(s);
end;
Mime.DecomposeParts;
end
else
begin
s := FLines[x];
Inc(x);
FPartBody.Add(s);
end;
if x >= FLines.Count then
break;
until s = '--' + FBoundary + '--';
end;
if (FPrimaryCode = MP_MESSAGE) and CanSubPart then
begin
Mime := AddSubPart;
SkipEmpty;
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
Inc(x);
Mime.Lines.Add(s);
end;
Mime.DecomposeParts;
end
else
begin
while FLines.Count > x do
begin
s := FLines[x];
Inc(x);
FPartBody.Add(s);
if not FAttachInside then
FAttachInside := IsUUcode(s);
end;
end;
//extract postpart
if FPrimaryCode = MP_MULTIPART then
begin
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
Inc(x);
FPostPart.Add(s);
if not FAttachInside then
FAttachInside := IsUUcode(s);
end;
end;
end;
{==============================================================================}
procedure TMIMEPart.ComposeParts;
var
n: integer;
mime: TMimePart;
s, t: string;
d1, d2, d3: integer;
x: integer;
begin
FLines.Clear;
//add headers
for n := 0 to FHeaders.Count -1 do
begin
s := FHeaders[n];
repeat
if Length(s) < FMaxLineLength then
begin
t := s;
s := '';
end
else
begin
d1 := RPosEx('; ', s, FMaxLineLength);
d2 := RPosEx(' ', s, FMaxLineLength);
d3 := RPosEx(', ', s, FMaxLineLength);
if (d1 <= 1) and (d2 <= 1) and (d3 <= 1) then
begin
x := Pos(' ', Copy(s, 2, Length(s) - 1));
if x < 1 then
x := Length(s);
end
else
if d1 > 0 then
x := d1
else
if d3 > 0 then
x := d3
else
x := d2 - 1;
t := Copy(s, 1, x);
Delete(s, 1, x);
end;
Flines.Add(t);
until s = '';
end;
Flines.Add('');
//add body
//if multipart
if FPrimaryCode = MP_MULTIPART then
begin
Flines.AddStrings(FPrePart);
for n := 0 to GetSubPartCount - 1 do
begin
Flines.Add('--' + FBoundary);
mime := GetSubPart(n);
mime.ComposeParts;
FLines.AddStrings(mime.Lines);
end;
Flines.Add('--' + FBoundary + '--');
Flines.AddStrings(FPostPart);
end;
//if message
if FPrimaryCode = MP_MESSAGE then
begin
if GetSubPartCount > 0 then
begin
mime := GetSubPart(0);
mime.ComposeParts;
FLines.AddStrings(mime.Lines);
end;
end
else
//if normal part
begin
FLines.AddStrings(FPartBody);
end;
end;
{==============================================================================}
procedure TMIMEPart.DecodePart;
var
n: Integer;
s, t, t2: string;
b: Boolean;
begin
FDecodedLines.Clear;
case FEncodingCode of
ME_QUOTED_PRINTABLE:
s := DecodeQuotedPrintable(FPartBody.Text);
ME_BASE64:
s := DecodeBase64(FPartBody.Text);
ME_UU, ME_XX:
begin
s := '';
for n := 0 to FPartBody.Count - 1 do
if FEncodingCode = ME_UU then
s := s + DecodeUU(FPartBody[n])
else
s := s + DecodeXX(FPartBody[n]);
end;
else
s := FPartBody.Text;
end;
if FConvertCharset and (FPrimaryCode = MP_TEXT) then
if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then
begin
b := false;
t2 := uppercase(s);
t := SeparateLeft(t2, '');
if length(t) <> length(s) then
begin
t := SeparateRight(t, '');
t := ReplaceString(t, '"', '');
t := ReplaceString(t, ' ', '');
b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0;
end;
//workaround for shitty M$ Outlook 11 which is placing this information
//outside section
if not b then
begin
t := Copy(t2, 1, 2048);
t := ReplaceString(t, '"', '');
t := ReplaceString(t, ' ', '');
b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0;
end;
if not b then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end
else
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
WriteStrToStream(FDecodedLines, s);
FDecodedLines.Seek(0, soFromBeginning);
end;
{==============================================================================}
procedure TMIMEPart.DecodePartHeader;
var
n: integer;
s, su, fn: string;
st, st2: string;
begin
Primary := 'text';
FSecondary := 'plain';
FDescription := '';
Charset := FDefaultCharset;
FFileName := '';
//was 7bit before, but this is more compatible with RFC-ignorant outlook
Encoding := '8BIT';
FDisposition := '';
FContentID := '';
fn := '';
for n := 0 to FHeaders.Count - 1 do
if FHeaders[n] <> '' then
begin
s := FHeaders[n];
su := UpperCase(s);
if Pos('CONTENT-TYPE:', su) = 1 then
begin
st := Trim(SeparateRight(su, ':'));
st2 := Trim(SeparateLeft(st, ';'));
Primary := Trim(SeparateLeft(st2, '/'));
FSecondary := Trim(SeparateRight(st2, '/'));
if (FSecondary = Primary) and (Pos('/', st2) < 1) then
FSecondary := '';
case FPrimaryCode of
MP_TEXT:
begin
Charset := UpperCase(GetParameter(s, 'charset'));
FFileName := GetParameter(s, 'name');
end;
MP_MULTIPART:
FBoundary := GetParameter(s, 'Boundary');
MP_MESSAGE:
begin
end;
MP_BINARY:
FFileName := GetParameter(s, 'name');
end;
end;
if Pos('CONTENT-TRANSFER-ENCODING:', su) = 1 then
Encoding := Trim(SeparateRight(su, ':'));
if Pos('CONTENT-DESCRIPTION:', su) = 1 then
FDescription := Trim(SeparateRight(s, ':'));
if Pos('CONTENT-DISPOSITION:', su) = 1 then
begin
FDisposition := SeparateRight(su, ':');
FDisposition := Trim(SeparateLeft(FDisposition, ';'));
fn := GetParameter(s, 'FileName');
end;
if Pos('CONTENT-ID:', su) = 1 then
FContentID := Trim(SeparateRight(s, ':'));
end;
if fn <> '' then
FFileName := fn;
FFileName := InlineDecode(FFileName, FTargetCharset);
FFileName := ExtractFileName(FFileName);
end;
{==============================================================================}
procedure TMIMEPart.EncodePart;
var
l: TStringList;
s, t: string;
n, x: Integer;
d1, d2: integer;
begin
if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then
Encoding := 'base64';
l := TStringList.Create;
FPartBody.Clear;
FDecodedLines.Seek(0, soFromBeginning);
try
case FPrimaryCode of
MP_MULTIPART, MP_MESSAGE:
FPartBody.LoadFromStream(FDecodedLines);
MP_TEXT, MP_BINARY:
begin
s := ReadStrFromStream(FDecodedLines, FDecodedLines.Size);
if FConvertCharset and (FPrimaryCode = MP_TEXT) and (FEncodingCode <> ME_7BIT) then
s := GetBOM(FCharSetCode) + CharsetConversion(s, FTargetCharset, FCharsetCode);
if FEncodingCode = ME_BASE64 then
begin
x := 1;
while x <= length(s) do
begin
t := copy(s, x, 54);
x := x + length(t);
t := EncodeBase64(t);
FPartBody.Add(t);
end;
end
else
begin
if FPrimaryCode = MP_BINARY then
l.Add(s)
else
l.Text := s;
for n := 0 to l.Count - 1 do
begin
s := l[n];
if FEncodingCode = ME_QUOTED_PRINTABLE then
begin
s := EncodeQuotedPrintable(s);
repeat
if Length(s) < FMaxLineLength then
begin
t := s;
s := '';
end
else
begin
d1 := RPosEx('=', s, FMaxLineLength);
d2 := RPosEx(' ', s, FMaxLineLength);
if (d1 = 0) and (d2 = 0) then
x := FMaxLineLength
else
if d1 > d2 then
x := d1 - 1
else
x := d2 - 1;
if x = 0 then
x := FMaxLineLength;
t := Copy(s, 1, x);
Delete(s, 1, x);
if s <> '' then
t := t + '=';
end;
FPartBody.Add(t);
until s = '';
end
else
FPartBody.Add(s);
end;
if (FPrimaryCode = MP_BINARY)
and (FEncodingCode = ME_QUOTED_PRINTABLE) then
FPartBody[FPartBody.Count - 1] := FPartBody[FPartBody.Count - 1] + '=';
end;
end;
end;
finally
l.Free;
end;
end;
{==============================================================================}
procedure TMIMEPart.EncodePartHeader;
var
s: string;
begin
FHeaders.Clear;
if FSecondary = '' then
case FPrimaryCode of
MP_TEXT:
FSecondary := 'plain';
MP_MULTIPART:
FSecondary := 'mixed';
MP_MESSAGE:
FSecondary := 'rfc822';
MP_BINARY:
FSecondary := 'octet-stream';
end;
if FDescription <> '' then
FHeaders.Insert(0, 'Content-Description: ' + FDescription);
if FDisposition <> '' then
begin
s := '';
if FFileName <> '' then
s := '; FileName=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"');
FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
end;
if FContentID <> '' then
FHeaders.Insert(0, 'Content-ID: ' + FContentID);
case FEncodingCode of
ME_7BIT:
s := '7bit';
ME_8BIT:
s := '8bit';
ME_QUOTED_PRINTABLE:
s := 'Quoted-printable';
ME_BASE64:
s := 'Base64';
end;
case FPrimaryCode of
MP_TEXT,
MP_BINARY: FHeaders.Insert(0, 'Content-Transfer-Encoding: ' + s);
end;
case FPrimaryCode of
MP_TEXT:
s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode);
MP_MULTIPART:
s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"';
MP_MESSAGE, MP_BINARY:
s := FPrimary + '/' + FSecondary;
end;
if FFileName <> '' then
s := s + '; name=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"');
FHeaders.Insert(0, 'Content-type: ' + s);
end;
{==============================================================================}
procedure TMIMEPart.MimeTypeFromExt(Value: string);
var
s: string;
n: Integer;
begin
Primary := '';
FSecondary := '';
s := UpperCase(ExtractFileExt(Value));
if s = '' then
s := UpperCase(Value);
s := SeparateRight(s, '.');
for n := 0 to MaxMimeType do
if MimeType[n, 0] = s then
begin
Primary := MimeType[n, 1];
FSecondary := MimeType[n, 2];
Break;
end;
if Primary = '' then
Primary := 'application';
if FSecondary = '' then
FSecondary := 'octet-stream';
end;
{==============================================================================}
procedure TMIMEPart.WalkPart;
var
n: integer;
m: TMimepart;
begin
if assigned(OnWalkPart) then
begin
OnWalkPart(self);
for n := 0 to GetSubPartCount - 1 do
begin
m := GetSubPart(n);
m.OnWalkPart := OnWalkPart;
m.WalkPart;
end;
end;
end;
{==============================================================================}
procedure TMIMEPart.SetPrimary(Value: string);
var
s: string;
begin
FPrimary := Value;
s := UpperCase(Value);
FPrimaryCode := MP_BINARY;
if Pos('TEXT', s) = 1 then
FPrimaryCode := MP_TEXT;
if Pos('MULTIPART', s) = 1 then
FPrimaryCode := MP_MULTIPART;
if Pos('MESSAGE', s) = 1 then
FPrimaryCode := MP_MESSAGE;
end;
procedure TMIMEPart.SetEncoding(Value: string);
var
s: string;
begin
FEncoding := Value;
s := UpperCase(Value);
FEncodingCode := ME_7BIT;
if Pos('8BIT', s) = 1 then
FEncodingCode := ME_8BIT;
if Pos('QUOTED-PRINTABLE', s) = 1 then
FEncodingCode := ME_QUOTED_PRINTABLE;
if Pos('BASE64', s) = 1 then
FEncodingCode := ME_BASE64;
if Pos('X-UU', s) = 1 then
FEncodingCode := ME_UU;
if Pos('X-XX', s) = 1 then
FEncodingCode := ME_XX;
end;
procedure TMIMEPart.SetCharset(Value: string);
begin
if value <> '' then
begin
FCharset := Value;
FCharsetCode := GetCPFromID(Value);
end;
end;
function TMIMEPart.CanSubPart: boolean;
begin
Result := True;
if FMaxSubLevel <> -1 then
Result := FMaxSubLevel > FSubLevel;
end;
function TMIMEPart.IsUUcode(Value: string): boolean;
begin
Value := UpperCase(Value);
Result := (pos('BEGIN ', Value) = 1) and (Trim(SeparateRight(Value, ' ')) <> '');
end;
{==============================================================================}
function GenerateBoundary: string;
var
x, y: Integer;
begin
y := GetTick;
x := y;
while TickDelta(y, x) = 0 do
begin
Sleep(1);
x := GetTick;
end;
Randomize;
y := Random(MaxInt);
Result := IntToHex(x, 8) + '_' + IntToHex(y, 8) + '_Synapse_boundary';
end;
end.
TransGUI/synapse/source/lib/asn1util.pas 0000644 0000000 0000000 00000035054 11366572451 017226 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.004.004 |
|==============================================================================|
| Content: support for ASN.1 BER coding and decoding |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2003 |
| Portions created by Hernan Sanchez are Copyright (c) 2000. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Hernan Sanchez (hernan.sanchez@iname.com) |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{: @abstract(Utilities for handling ASN.1 BER encoding)
By this unit you can parse ASN.1 BER encoded data to elements or build back any
elements to ASN.1 BER encoded buffer. You can dump ASN.1 BER encoded data to
human readable form for easy debugging, too.
Supported element types are: ASN1_BOOL, ASN1_INT, ASN1_OCTSTR, ASN1_NULL,
ASN1_OBJID, ASN1_ENUM, ASN1_SEQ, ASN1_SETOF, ASN1_IPADDR, ASN1_COUNTER,
ASN1_GAUGE, ASN1_TIMETICKS, ASN1_OPAQUE
For sample of using, look to @link(TSnmpSend) or @link(TLdapSend)class.
}
{$Q-}
{$H+}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit asn1util;
interface
uses
SysUtils, Classes, synautil;
const
ASN1_BOOL = $01;
ASN1_INT = $02;
ASN1_OCTSTR = $04;
ASN1_NULL = $05;
ASN1_OBJID = $06;
ASN1_ENUM = $0a;
ASN1_SEQ = $30;
ASN1_SETOF = $31;
ASN1_IPADDR = $40;
ASN1_COUNTER = $41;
ASN1_GAUGE = $42;
ASN1_TIMETICKS = $43;
ASN1_OPAQUE = $44;
{:Encodes OID item to binary form.}
function ASNEncOIDItem(Value: Integer): AnsiString;
{:Decodes an OID item of the next element in the "Buffer" from the "Start"
position.}
function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer;
{:Encodes the length of ASN.1 element to binary.}
function ASNEncLen(Len: Integer): AnsiString;
{:Decodes length of next element in "Buffer" from the "Start" position.}
function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer;
{:Encodes a signed integer to ASN.1 binary}
function ASNEncInt(Value: Integer): AnsiString;
{:Encodes unsigned integer into ASN.1 binary}
function ASNEncUInt(Value: Integer): AnsiString;
{:Encodes ASN.1 object to binary form.}
function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString;
{:Beginning with the "Start" position, decode the ASN.1 item of the next element
in "Buffer". Type of item is stored in "ValueType."}
function ASNItem(var Start: Integer; const Buffer: AnsiString;
var ValueType: Integer): AnsiString;
{:Encodes an MIB OID string to binary form.}
function MibToId(Mib: String): AnsiString;
{:Decodes MIB OID from binary form to string form.}
function IdToMib(const Id: AnsiString): String;
{:Encodes an one number from MIB OID to binary form. (used internally from
@link(MibToId))}
function IntMibToStr(const Value: AnsiString): AnsiString;
{:Convert ASN.1 BER encoded buffer to human readable form for debugging.}
function ASNdump(const Value: AnsiString): AnsiString;
implementation
{==============================================================================}
function ASNEncOIDItem(Value: Integer): AnsiString;
var
x, xm: Integer;
b: Boolean;
begin
x := Value;
b := False;
Result := '';
repeat
xm := x mod 128;
x := x div 128;
if b then
xm := xm or $80;
if x > 0 then
b := True;
Result := AnsiChar(xm) + Result;
until x = 0;
end;
{==============================================================================}
function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer;
var
x: Integer;
b: Boolean;
begin
Result := 0;
repeat
Result := Result * 128;
x := Ord(Buffer[Start]);
Inc(Start);
b := x > $7F;
x := x and $7F;
Result := Result + x;
until not b;
end;
{==============================================================================}
function ASNEncLen(Len: Integer): AnsiString;
var
x, y: Integer;
begin
if Len < $80 then
Result := AnsiChar(Len)
else
begin
x := Len;
Result := '';
repeat
y := x mod 256;
x := x div 256;
Result := AnsiChar(y) + Result;
until x = 0;
y := Length(Result);
y := y or $80;
Result := AnsiChar(y) + Result;
end;
end;
{==============================================================================}
function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer;
var
x, n: Integer;
begin
x := Ord(Buffer[Start]);
Inc(Start);
if x < $80 then
Result := x
else
begin
Result := 0;
x := x and $7F;
for n := 1 to x do
begin
Result := Result * 256;
x := Ord(Buffer[Start]);
Inc(Start);
Result := Result + x;
end;
end;
end;
{==============================================================================}
function ASNEncInt(Value: Integer): AnsiString;
var
x, y: Cardinal;
neg: Boolean;
begin
neg := Value < 0;
x := Abs(Value);
if neg then
x := not (x - 1);
Result := '';
repeat
y := x mod 256;
x := x div 256;
Result := AnsiChar(y) + Result;
until x = 0;
if (not neg) and (Result[1] > #$7F) then
Result := #0 + Result;
end;
{==============================================================================}
function ASNEncUInt(Value: Integer): AnsiString;
var
x, y: Integer;
neg: Boolean;
begin
neg := Value < 0;
x := Value;
if neg then
x := x and $7FFFFFFF;
Result := '';
repeat
y := x mod 256;
x := x div 256;
Result := AnsiChar(y) + Result;
until x = 0;
if neg then
Result[1] := AnsiChar(Ord(Result[1]) or $80);
end;
{==============================================================================}
function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString;
begin
Result := AnsiChar(ASNType) + ASNEncLen(Length(Data)) + Data;
end;
{==============================================================================}
function ASNItem(var Start: Integer; const Buffer: AnsiString;
var ValueType: Integer): AnsiString;
var
ASNType: Integer;
ASNSize: Integer;
y, n: Integer;
x: byte;
s: AnsiString;
c: AnsiChar;
neg: Boolean;
l: Integer;
begin
Result := '';
ValueType := ASN1_NULL;
l := Length(Buffer);
if l < (Start + 1) then
Exit;
ASNType := Ord(Buffer[Start]);
ValueType := ASNType;
Inc(Start);
ASNSize := ASNDecLen(Start, Buffer);
if (Start + ASNSize - 1) > l then
Exit;
if (ASNType and $20) > 0 then
// Result := '$' + IntToHex(ASNType, 2)
Result := Copy(Buffer, Start, ASNSize)
else
case ASNType of
ASN1_INT, ASN1_ENUM, ASN1_BOOL:
begin
y := 0;
neg := False;
for n := 1 to ASNSize do
begin
x := Ord(Buffer[Start]);
if (n = 1) and (x > $7F) then
neg := True;
if neg then
x := not x;
y := y * 256 + x;
Inc(Start);
end;
if neg then
y := -(y + 1);
Result := IntToStr(y);
end;
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
begin
y := 0;
for n := 1 to ASNSize do
begin
y := y * 256 + Ord(Buffer[Start]);
Inc(Start);
end;
Result := IntToStr(y);
end;
ASN1_OCTSTR, ASN1_OPAQUE:
begin
for n := 1 to ASNSize do
begin
c := AnsiChar(Buffer[Start]);
Inc(Start);
s := s + c;
end;
Result := s;
end;
ASN1_OBJID:
begin
for n := 1 to ASNSize do
begin
c := AnsiChar(Buffer[Start]);
Inc(Start);
s := s + c;
end;
Result := IdToMib(s);
end;
ASN1_IPADDR:
begin
s := '';
for n := 1 to ASNSize do
begin
if (n <> 1) then
s := s + '.';
y := Ord(Buffer[Start]);
Inc(Start);
s := s + IntToStr(y);
end;
Result := s;
end;
ASN1_NULL:
begin
Result := '';
Start := Start + ASNSize;
end;
else // unknown
begin
for n := 1 to ASNSize do
begin
c := AnsiChar(Buffer[Start]);
Inc(Start);
s := s + c;
end;
Result := s;
end;
end;
end;
{==============================================================================}
function MibToId(Mib: String): AnsiString;
var
x: Integer;
function WalkInt(var s: String): Integer;
var
x: Integer;
t: AnsiString;
begin
x := Pos('.', s);
if x < 1 then
begin
t := s;
s := '';
end
else
begin
t := Copy(s, 1, x - 1);
s := Copy(s, x + 1, Length(s) - x);
end;
Result := StrToIntDef(t, 0);
end;
begin
Result := '';
x := WalkInt(Mib);
x := x * 40 + WalkInt(Mib);
Result := ASNEncOIDItem(x);
while Mib <> '' do
begin
x := WalkInt(Mib);
Result := Result + ASNEncOIDItem(x);
end;
end;
{==============================================================================}
function IdToMib(const Id: AnsiString): String;
var
x, y, n: Integer;
begin
Result := '';
n := 1;
while Length(Id) + 1 > n do
begin
x := ASNDecOIDItem(n, Id);
if (n - 1) = 1 then
begin
y := x div 40;
x := x mod 40;
Result := IntToStr(y);
end;
Result := Result + '.' + IntToStr(x);
end;
end;
{==============================================================================}
function IntMibToStr(const Value: AnsiString): AnsiString;
var
n, y: Integer;
begin
y := 0;
for n := 1 to Length(Value) - 1 do
y := y * 256 + Ord(Value[n]);
Result := IntToStr(y);
end;
{==============================================================================}
function ASNdump(const Value: AnsiString): AnsiString;
var
i, at, x, n: integer;
s, indent: AnsiString;
il: TStringList;
begin
il := TStringList.Create;
try
Result := '';
i := 1;
indent := '';
while i < Length(Value) do
begin
for n := il.Count - 1 downto 0 do
begin
x := StrToIntDef(il[n], 0);
if x <= i then
begin
il.Delete(n);
Delete(indent, 1, 2);
end;
end;
s := ASNItem(i, Value, at);
Result := Result + indent + '$' + IntToHex(at, 2);
if (at and $20) > 0 then
begin
x := Length(s);
Result := Result + ' constructed: length ' + IntToStr(x);
indent := indent + ' ';
il.Add(IntToStr(x + i - 1));
end
else
begin
case at of
ASN1_BOOL:
Result := Result + ' BOOL: ';
ASN1_INT:
Result := Result + ' INT: ';
ASN1_ENUM:
Result := Result + ' ENUM: ';
ASN1_COUNTER:
Result := Result + ' COUNTER: ';
ASN1_GAUGE:
Result := Result + ' GAUGE: ';
ASN1_TIMETICKS:
Result := Result + ' TIMETICKS: ';
ASN1_OCTSTR:
Result := Result + ' OCTSTR: ';
ASN1_OPAQUE:
Result := Result + ' OPAQUE: ';
ASN1_OBJID:
Result := Result + ' OBJID: ';
ASN1_IPADDR:
Result := Result + ' IPADDR: ';
ASN1_NULL:
Result := Result + ' NULL: ';
else // other
Result := Result + ' unknown: ';
end;
if IsBinaryString(s) then
s := DumpExStr(s);
Result := Result + s;
end;
Result := Result + #$0d + #$0a;
end;
finally
il.Free;
end;
end;
{==============================================================================}
end.
TransGUI/synapse/source/lib/blcksock.pas 0000644 0000000 0000000 00000367534 11466757142 017277 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 009.008.003 |
|==============================================================================|
| Content: Library base |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)1999-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{
Special thanks to Gregor Ibic
(Intelicom d.o.o., http://www.intelicom.si)
for good inspiration about SSL programming.
}
{$DEFINE ONCEWINSOCK}
{Note about define ONCEWINSOCK:
If you remove this compiler directive, then socket interface is loaded and
initialized on constructor of TBlockSocket class for each socket separately.
Socket interface is used only if your need it.
If you leave this directive here, then socket interface is loaded and
initialized only once at start of your program! It boost performace on high
count of created and destroyed sockets. It eliminate possible small resource
leak on Windows systems too.
}
//{$DEFINE RAISEEXCEPT}
{When you enable this define, then is Raiseexcept property is on by default
}
{:@abstract(Synapse's library core)
Core with implementation basic socket classes.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$IFDEF VER125}
{$DEFINE BCB}
{$ENDIF}
{$IFDEF BCB}
{$ObjExportAll On}
{$ENDIF}
{$Q-}
{$H+}
{$M+}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit blcksock;
interface
uses
SysUtils, Classes,
synafpc,
synsock, synautil, synacode, synaip
{$IFDEF CIL}
,System.Net
,System.Net.Sockets
,System.Text
{$ENDIF}
;
const
SynapseRelease = '38';
cLocalhost = '127.0.0.1';
cAnyHost = '0.0.0.0';
cBroadcast = '255.255.255.255';
c6Localhost = '::1';
c6AnyHost = '::0';
c6Broadcast = 'ffff::1';
cAnyPort = '0';
CR = #$0d;
LF = #$0a;
CRLF = CR + LF;
c64k = 65536;
type
{:@abstract(Exception clas used by Synapse)
When you enable generating of exceptions, this exception is raised by
Synapse's units.}
ESynapseError = class(Exception)
private
FErrorCode: Integer;
FErrorMessage: string;
published
{:Code of error. Value depending on used operating system}
property ErrorCode: Integer read FErrorCode Write FErrorCode;
{:Human readable description of error.}
property ErrorMessage: string read FErrorMessage Write FErrorMessage;
end;
{:Types of OnStatus events}
THookSocketReason = (
{:Resolving is begin. Resolved IP and port is in parameter in format like:
'localhost.somewhere.com:25'.}
HR_ResolvingBegin,
{:Resolving is done. Resolved IP and port is in parameter in format like:
'localhost.somewhere.com:25'. It is always same as in HR_ResolvingBegin!}
HR_ResolvingEnd,
{:Socket created by CreateSocket method. It reporting Family of created
socket too!}
HR_SocketCreate,
{:Socket closed by CloseSocket method.}
HR_SocketClose,
{:Socket binded to IP and Port. Binded IP and Port is in parameter in format
like: 'localhost.somewhere.com:25'.}
HR_Bind,
{:Socket connected to IP and Port. Connected IP and Port is in parameter in
format like: 'localhost.somewhere.com:25'.}
HR_Connect,
{:Called when CanRead method is used with @True result.}
HR_CanRead,
{:Called when CanWrite method is used with @True result.}
HR_CanWrite,
{:Socket is swithed to Listen mode. (TCP socket only)}
HR_Listen,
{:Socket Accepting client connection. (TCP socket only)}
HR_Accept,
{:report count of bytes readed from socket. Number is in parameter string.
If you need is in integer, you must use StrToInt function!}
HR_ReadCount,
{:report count of bytes writed to socket. Number is in parameter string. If
you need is in integer, you must use StrToInt function!}
HR_WriteCount,
{:If is limiting of bandwidth on, then this reason is called when sending or
receiving is stopped for satisfy bandwidth limit. Parameter is count of
waiting milliseconds.}
HR_Wait,
{:report situation where communication error occured. When raiseexcept is
@true, then exception is called after this Hook reason.}
HR_Error
);
{:Procedural type for OnStatus event. Sender is calling TBlockSocket object,
Reason is one of set Status events and value is optional data.}
THookSocketStatus = procedure(Sender: TObject; Reason: THookSocketReason;
const Value: String) of object;
{:This procedural type is used for DataFilter hooks.}
THookDataFilter = procedure(Sender: TObject; var Value: AnsiString) of object;
{:This procedural type is used for hook OnCreateSocket. By this hook you can
insert your code after initialisation of socket. (you can set special socket
options, etc.)}
THookCreateSocket = procedure(Sender: TObject) of object;
{:This procedural type is used for monitoring of communication.}
THookMonitor = procedure(Sender: TObject; Writing: Boolean;
const Buffer: TMemory; Len: Integer) of object;
{:This procedural type is used for hook OnAfterConnect. By this hook you can
insert your code after TCP socket has been sucessfully connected.}
THookAfterConnect = procedure(Sender: TObject) of object;
{:This procedural type is used for hook OnHeartbeat. By this hook you can
call your code repeately during long socket operations.
You must enable heartbeats by @Link(HeartbeatRate) property!}
THookHeartbeat = procedure(Sender: TObject) of object;
{:Specify family of socket.}
TSocketFamily = (
{:Default mode. Socket family is defined by target address for connection.
It allows instant access to IPv4 and IPv6 nodes. When you need IPv6 address
as destination, then is used IPv6 mode. othervise is used IPv4 mode.
However this mode not working properly with preliminary IPv6 supports!}
SF_Any,
{:Turn this class to pure IPv4 mode. This mode is totally compatible with
previous Synapse releases.}
SF_IP4,
{:Turn to only IPv6 mode.}
SF_IP6
);
{:specify possible values of SOCKS modes.}
TSocksType = (
ST_Socks5,
ST_Socks4
);
{:Specify requested SSL/TLS version for secure connection.}
TSSLType = (
LT_all,
LT_SSLv2,
LT_SSLv3,
LT_TLSv1,
LT_TLSv1_1,
LT_SSHv2
);
{:Specify type of socket delayed option.}
TSynaOptionType = (
SOT_Linger,
SOT_RecvBuff,
SOT_SendBuff,
SOT_NonBlock,
SOT_RecvTimeout,
SOT_SendTimeout,
SOT_Reuse,
SOT_TTL,
SOT_Broadcast,
SOT_MulticastTTL,
SOT_MulticastLoop
);
{:@abstract(this object is used for remember delayed socket option set.)}
TSynaOption = class(TObject)
public
Option: TSynaOptionType;
Enabled: Boolean;
Value: Integer;
end;
TCustomSSL = class;
TSSLClass = class of TCustomSSL;
{:@abstract(Basic IP object.)
This is parent class for other class with protocol implementations. Do not
use this class directly! Use @link(TICMPBlockSocket), @link(TRAWBlockSocket),
@link(TTCPBlockSocket) or @link(TUDPBlockSocket) instead.}
TBlockSocket = class(TObject)
private
FOnStatus: THookSocketStatus;
FOnReadFilter: THookDataFilter;
FOnCreateSocket: THookCreateSocket;
FOnMonitor: THookMonitor;
FOnHeartbeat: THookHeartbeat;
FLocalSin: TVarSin;
FRemoteSin: TVarSin;
FTag: integer;
FBuffer: AnsiString;
FRaiseExcept: Boolean;
FNonBlockMode: Boolean;
FMaxLineLength: Integer;
FMaxSendBandwidth: Integer;
FNextSend: LongWord;
FMaxRecvBandwidth: Integer;
FNextRecv: LongWord;
FConvertLineEnd: Boolean;
FLastCR: Boolean;
FLastLF: Boolean;
FBinded: Boolean;
FFamily: TSocketFamily;
FFamilySave: TSocketFamily;
FIP6used: Boolean;
FPreferIP4: Boolean;
FDelayedOptions: TList;
FInterPacketTimeout: Boolean;
{$IFNDEF CIL}
FFDSet: TFDSet;
{$ENDIF}
FRecvCounter: Integer;
FSendCounter: Integer;
FSendMaxChunk: Integer;
FStopFlag: Boolean;
FNonblockSendTimeout: Integer;
FHeartbeatRate: integer;
function GetSizeRecvBuffer: Integer;
procedure SetSizeRecvBuffer(Size: Integer);
function GetSizeSendBuffer: Integer;
procedure SetSizeSendBuffer(Size: Integer);
procedure SetNonBlockMode(Value: Boolean);
procedure SetTTL(TTL: integer);
function GetTTL:integer;
procedure SetFamily(Value: TSocketFamily); virtual;
procedure SetSocket(Value: TSocket); virtual;
function GetWsaData: TWSAData;
function FamilyToAF(f: TSocketFamily): TAddrFamily;
protected
FSocket: TSocket;
FLastError: Integer;
FLastErrorDesc: string;
FOwner: TObject;
procedure SetDelayedOption(const Value: TSynaOption);
procedure DelayedOption(const Value: TSynaOption);
procedure ProcessDelayedOptions;
procedure InternalCreateSocket(Sin: TVarSin);
procedure SetSin(var Sin: TVarSin; IP, Port: string);
function GetSinIP(Sin: TVarSin): string;
function GetSinPort(Sin: TVarSin): Integer;
procedure DoStatus(Reason: THookSocketReason; const Value: string);
procedure DoReadFilter(Buffer: TMemory; var Len: Integer);
procedure DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer);
procedure DoCreateSocket;
procedure DoHeartbeat;
procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord);
procedure SetBandwidth(Value: Integer);
function TestStopFlag: Boolean;
procedure InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); virtual;
function InternalCanRead(Timeout: Integer): Boolean; virtual;
public
constructor Create;
{:Create object and load all necessary socket library. What library is
loaded is described by STUB parameter. If STUB is empty string, then is
loaded default libraries.}
constructor CreateAlternate(Stub: string);
destructor Destroy; override;
{:If @link(family) is not SF_Any, then create socket with type defined in
@link(Family) property. If family is SF_Any, then do nothing! (socket is
created automaticly when you know what type of socket you need to create.
(i.e. inside @link(Connect) or @link(Bind) call.) When socket is created,
then is aplyed all stored delayed socket options.}
procedure CreateSocket;
{:It create socket. Address resolving of Value tells what type of socket is
created. If Value is resolved as IPv4 IP, then is created IPv4 socket. If
value is resolved as IPv6 address, then is created IPv6 socket.}
procedure CreateSocketByName(const Value: String);
{:Destroy socket in use. This method is also automatically called from
object destructor.}
procedure CloseSocket; virtual;
{:Abort any work on Socket and destroy them.}
procedure AbortSocket; virtual;
{:Connects socket to local IP address and PORT. IP address may be numeric or
symbolic ('192.168.74.50', 'cosi.nekde.cz', 'ff08::1'). The same for PORT
- it may be number or mnemonic port ('23', 'telnet').
If port value is '0', system chooses itself and conects unused port in the
range 1024 to 4096 (this depending by operating system!). Structure
LocalSin is filled after calling this method.
Note: If you call this on non-created socket, then socket is created
automaticly.
Warning: when you call : Bind('0.0.0.0','0'); then is nothing done! In this
case is used implicit system bind instead.}
procedure Bind(IP, Port: string);
{:Connects socket to remote IP address and PORT. The same rules as with
@link(BIND) method are valid. The only exception is that PORT with 0 value
will not be connected!
Structures LocalSin and RemoteSin will be filled with valid values.
When you call this on non-created socket, then socket is created
automaticly. Type of created socket is by @link(Family) property. If is
used SF_IP4, then is created socket for IPv4. If is used SF_IP6, then is
created socket for IPv6. When you have family on SF_Any (default!), then
type of created socket is determined by address resolving of destination
address. (Not work properly on prilimitary winsock IPv6 support!)}
procedure Connect(IP, Port: string); virtual;
{:Sets socket to receive mode for new incoming connections. It is necessary
to use @link(TBlockSocket.BIND) function call before this method to select
receiving port!}
procedure Listen; virtual;
{:Waits until new incoming connection comes. After it comes a new socket is
automatically created (socket handler is returned by this function as
result).}
function Accept: TSocket; virtual;
{:Sends data of LENGTH from BUFFER address via connected socket. System
automatically splits data to packets.}
function SendBuffer(Buffer: Tmemory; Length: Integer): Integer; virtual;
{:One data BYTE is sent via connected socket.}
procedure SendByte(Data: Byte); virtual;
{:Send data string via connected socket. Any terminator is not added! If you
need send true string with CR-LF termination, you must add CR-LF characters
to sended string! Because any termination is not added automaticly, you can
use this function for sending any binary data in binary string.}
procedure SendString(Data: AnsiString); virtual;
{:Send integer as four bytes to socket.}
procedure SendInteger(Data: integer); virtual;
{:Send data as one block to socket. Each block begin with 4 bytes with
length of data in block. This 4 bytes is added automaticly by this
function.}
procedure SendBlock(const Data: AnsiString); virtual;
{:Send data from stream to socket.}
procedure SendStreamRaw(const Stream: TStream); virtual;
{:Send content of stream to socket. It using @link(SendBlock) method}
procedure SendStream(const Stream: TStream); virtual;
{:Send content of stream to socket. It using @link(SendBlock) method and
this is compatible with streams in Indy library.}
procedure SendStreamIndy(const Stream: TStream); virtual;
{:Note: This is low-level receive function. You must be sure if data is
waiting for read before call this function for avoid deadlock!
Waits until allocated buffer is filled by received data. Returns number of
data received, which equals to LENGTH value under normal operation. If it
is not equal the communication channel is possibly broken.
On stream oriented sockets if is received 0 bytes, it mean 'socket is
closed!"
On datagram socket is readed first waiting datagram.}
function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; virtual;
{:Note: This is high-level receive function. It using internal
@link(LineBuffer) and you can combine this function freely with other
high-level functions!
Method waits until data is received. If no data is received within TIMEOUT
(in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT. Methods
serves for reading any size of data (i.e. one megabyte...). This method is
preffered for reading from stream sockets (like TCP).}
function RecvBufferEx(Buffer: Tmemory; Len: Integer;
Timeout: Integer): Integer; virtual;
{:Similar to @link(RecvBufferEx), but readed data is stored in binary
string, not in memory buffer.}
function RecvBufferStr(Len: Integer; Timeout: Integer): AnsiString; virtual;
{:Note: This is high-level receive function. It using internal
@link(LineBuffer) and you can combine this function freely with other
high-level functions.
Waits until one data byte is received which is also returned as function
result. If no data is received within TIMEOUT (in milliseconds)period,
@link(LastError) is set to WSAETIMEDOUT and result have value 0.}
function RecvByte(Timeout: Integer): Byte; virtual;
{:Note: This is high-level receive function. It using internal
@link(LineBuffer) and you can combine this function freely with other
high-level functions.
Waits until one four bytes are received and return it as one Ineger Value.
If no data is received within TIMEOUT (in milliseconds)period,
@link(LastError) is set to WSAETIMEDOUT and result have value 0.}
function RecvInteger(Timeout: Integer): Integer; virtual;
{:Note: This is high-level receive function. It using internal
@link(LineBuffer) and you can combine this function freely with other
high-level functions.
Method waits until data string is received. This string is terminated by
CR-LF characters. The resulting string is returned without this termination
(CR-LF)! If @link(ConvertLineEnd) is used, then CR-LF sequence may not be
exactly CR-LF. See @link(ConvertLineEnd) description. If no data is
received within TIMEOUT (in milliseconds) period, @link(LastError) is set
to WSAETIMEDOUT. You may also specify maximum length of reading data by
@link(MaxLineLength) property.}
function RecvString(Timeout: Integer): AnsiString; virtual;
{:Note: This is high-level receive function. It using internal
@link(LineBuffer) and you can combine this function freely with other
high-level functions.
Method waits until data string is received. This string is terminated by
Terminator string. The resulting string is returned without this
termination. If no data is received within TIMEOUT (in milliseconds)
period, @link(LastError) is set to WSAETIMEDOUT. You may also specify
maximum length of reading data by @link(MaxLineLength) property.}
function RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; virtual;
{:Note: This is high-level receive function. It using internal
@link(LineBuffer) and you can combine this function freely with other
high-level functions.
Method reads all data waiting for read. If no data is received within
TIMEOUT (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT.
Methods serves for reading unknown size of data. Because before call this
function you don't know size of received data, returned data is stored in
dynamic size binary string. This method is preffered for reading from
stream sockets (like TCP). It is very goot for receiving datagrams too!
(UDP protocol)}
function RecvPacket(Timeout: Integer): AnsiString; virtual;
{:Read one block of data from socket. Each block begin with 4 bytes with
length of data in block. This function read first 4 bytes for get lenght,
then it wait for reported count of bytes.}
function RecvBlock(Timeout: Integer): AnsiString; virtual;
{:Read all data from socket to stream until socket is closed (or any error
occured.)}
procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual;
{:Read requested count of bytes from socket to stream.}
procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer);
{:Receive data to stream. It using @link(RecvBlock) method.}
procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual;
{:Receive data to stream. This function is compatible with similar function
in Indy library. It using @link(RecvBlock) method.}
procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual;
{:Same as @link(RecvBuffer), but readed data stays in system input buffer.
Warning: this function not respect data in @link(LineBuffer)! Is not
recommended to use this function!}
function PeekBuffer(Buffer: TMemory; Length: Integer): Integer; virtual;
{:Same as @link(RecvByte), but readed data stays in input system buffer.
Warning: this function not respect data in @link(LineBuffer)! Is not
recommended to use this function!}
function PeekByte(Timeout: Integer): Byte; virtual;
{:On stream sockets it returns number of received bytes waiting for picking.
0 is returned when there is no such data. On datagram socket it returns
length of the first waiting datagram. Returns 0 if no datagram is waiting.}
function WaitingData: Integer; virtual;
{:Same as @link(WaitingData), but if exists some of data in @link(Linebuffer),
return their length instead.}
function WaitingDataEx: Integer;
{:Clear all waiting data for read from buffers.}
procedure Purge;
{:Sets linger. Enabled linger means that the system waits another LINGER
(in milliseconds) time for delivery of sent data. This function is only for
stream type of socket! (TCP)}
procedure SetLinger(Enable: Boolean; Linger: Integer);
{:Actualize values in @link(LocalSin).}
procedure GetSinLocal;
{:Actualize values in @link(RemoteSin).}
procedure GetSinRemote;
{:Actualize values in @link(LocalSin) and @link(RemoteSin).}
procedure GetSins;
{:Reset @link(LastError) and @link(LastErrorDesc) to non-error state.}
procedure ResetLastError;
{:If you "manually" call Socket API functions, forward their return code as
parameter to this function, which evaluates it, eventually calls
GetLastError and found error code returns and stores to @link(LastError).}
function SockCheck(SockResult: Integer): Integer; virtual;
{:If @link(LastError) contains some error code and @link(RaiseExcept)
property is @true, raise adequate exception.}
procedure ExceptCheck;
{:Returns local computer name as numerical or symbolic value. It try get
fully qualified domain name. Name is returned in the format acceptable by
functions demanding IP as input parameter.}
function LocalName: string;
{:Try resolve name to all possible IP address. i.e. If you pass as name
result of @link(LocalName) method, you get all IP addresses used by local
system.}
procedure ResolveNameToIP(Name: string; const IPList: TStrings);
{:Try resolve name to primary IP address. i.e. If you pass as name result of
@link(LocalName) method, you get primary IP addresses used by local system.}
function ResolveName(Name: string): string;
{:Try resolve IP to their primary domain name. If IP not have domain name,
then is returned original IP.}
function ResolveIPToName(IP: string): string;
{:Try resolve symbolic port name to port number. (i.e. 'Echo' to 8)}
function ResolvePort(Port: string): Word;
{:Set information about remote side socket. It is good for seting remote
side for sending UDP packet, etc.}
procedure SetRemoteSin(IP, Port: string);
{:Picks IP socket address from @link(LocalSin).}
function GetLocalSinIP: string; virtual;
{:Picks IP socket address from @link(RemoteSin).}
function GetRemoteSinIP: string; virtual;
{:Picks socket PORT number from @link(LocalSin).}
function GetLocalSinPort: Integer; virtual;
{:Picks socket PORT number from @link(RemoteSin).}
function GetRemoteSinPort: Integer; virtual;
{:Return @TRUE, if you can read any data from socket or is incoming
connection on TCP based socket. Status is tested for time Timeout (in
milliseconds). If value in Timeout is 0, status is only tested and
continue. If value in Timeout is -1, run is breaked and waiting for read
data maybe forever.
This function is need only on special cases, when you need use
@link(RecvBuffer) function directly! read functioms what have timeout as
calling parameter, calling this function internally.}
function CanRead(Timeout: Integer): Boolean; virtual;
{:Same as @link(CanRead), but additionally return @TRUE if is some data in
@link(LineBuffer).}
function CanReadEx(Timeout: Integer): Boolean; virtual;
{:Return @TRUE, if you can to socket write any data (not full sending
buffer). Status is tested for time Timeout (in milliseconds). If value in
Timeout is 0, status is only tested and continue. If value in Timeout is
-1, run is breaked and waiting for write data maybe forever.
This function is need only on special cases!}
function CanWrite(Timeout: Integer): Boolean; virtual;
{:Same as @link(SendBuffer), but send datagram to address from
@link(RemoteSin). Usefull for sending reply to datagram received by
function @link(RecvBufferFrom).}
function SendBufferTo(Buffer: TMemory; Length: Integer): Integer; virtual;
{:Note: This is low-lever receive function. You must be sure if data is
waiting for read before call this function for avoid deadlock!
Receives first waiting datagram to allocated buffer. If there is no waiting
one, then waits until one comes. Returns length of datagram stored in
BUFFER. If length exceeds buffer datagram is truncated. After this
@link(RemoteSin) structure contains information about sender of UDP packet.}
function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; virtual;
{$IFNDEF CIL}
{:This function is for check for incoming data on set of sockets. Whitch
sockets is checked is decribed by SocketList Tlist with TBlockSocket
objects. TList may have maximal number of objects defined by FD_SETSIZE
constant. Return @TRUE, if you can from some socket read any data or is
incoming connection on TCP based socket. Status is tested for time Timeout
(in milliseconds). If value in Timeout is 0, status is only tested and
continue. If value in Timeout is -1, run is breaked and waiting for read
data maybe forever. If is returned @TRUE, CanReadList TList is filled by all
TBlockSocket objects what waiting for read.}
function GroupCanRead(const SocketList: TList; Timeout: Integer;
const CanReadList: TList): Boolean;
{$ENDIF}
{:By this method you may turn address reuse mode for local @link(bind). It
is good specially for UDP protocol. Using this with TCP protocol is
hazardous!}
procedure EnableReuse(Value: Boolean);
{:Try set timeout for all sending and receiving operations, if socket
provider can do it. (It not supported by all socket providers!)}
procedure SetTimeout(Timeout: Integer);
{:Try set timeout for all sending operations, if socket provider can do it.
(It not supported by all socket providers!)}
procedure SetSendTimeout(Timeout: Integer);
{:Try set timeout for all receiving operations, if socket provider can do
it. (It not supported by all socket providers!)}
procedure SetRecvTimeout(Timeout: Integer);
{:Return value of socket type.}
function GetSocketType: integer; Virtual;
{:Return value of protocol type for socket creation.}
function GetSocketProtocol: integer; Virtual;
{:WSA structure with information about socket provider. On non-windows
platforms this structure is simulated!}
property WSAData: TWSADATA read GetWsaData;
{:FDset structure prepared for usage with this socket.}
property FDset: TFDSet read FFDset;
{:Structure describing local socket side.}
property LocalSin: TVarSin read FLocalSin write FLocalSin;
{:Structure describing remote socket side.}
property RemoteSin: TVarSin read FRemoteSin write FRemoteSin;
{:Socket handler. Suitable for "manual" calls to socket API or manual
connection of socket to a previously created socket (i.e by Accept method
on TCP socket)}
property Socket: TSocket read FSocket write SetSocket;
{:Last socket operation error code. Error codes are described in socket
documentation. Human readable error description is stored in
@link(LastErrorDesc) property.}
property LastError: Integer read FLastError;
{:Human readable error description of @link(LastError) code.}
property LastErrorDesc: string read FLastErrorDesc;
{:Buffer used by all high-level receiving functions. This buffer is used for
optimized reading of data from socket. In normal cases you not need access
to this buffer directly!}
property LineBuffer: AnsiString read FBuffer write FBuffer;
{:Size of Winsock receive buffer. If it is not supported by socket provider,
it return as size one kilobyte.}
property SizeRecvBuffer: Integer read GetSizeRecvBuffer write SetSizeRecvBuffer;
{:Size of Winsock send buffer. If it is not supported by socket provider, it
return as size one kilobyte.}
property SizeSendBuffer: Integer read GetSizeSendBuffer write SetSizeSendBuffer;
{:If @True, turn class to non-blocking mode. Not all functions are working
properly in this mode, you must know exactly what you are doing! However
when you have big experience with non-blocking programming, then you can
optimise your program by non-block mode!}
property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode;
{:Set Time-to-live value. (if system supporting it!)}
property TTL: Integer read GetTTL Write SetTTL;
{:If is @true, then class in in IPv6 mode.}
property IP6used: Boolean read FIP6used;
{:Return count of received bytes on this socket from begin of current
connection.}
property RecvCounter: Integer read FRecvCounter;
{:Return count of sended bytes on this socket from begin of current
connection.}
property SendCounter: Integer read FSendCounter;
published
{:Return descriptive string for given error code. This is class function.
You may call it without created object!}
class function GetErrorDesc(ErrorCode: Integer): string;
{:Return descriptive string for @link(LastError).}
function GetErrorDescEx: string; virtual;
{:this value is for free use.}
property Tag: Integer read FTag write FTag;
{:If @true, winsock errors raises exception. Otherwise is setted
@link(LastError) value only and you must check it from your program! Default
value is @false.}
property RaiseExcept: Boolean read FRaiseExcept write FRaiseExcept;
{:Define maximum length in bytes of @link(LineBuffer) for high-level
receiving functions. If this functions try to read more data then this
limit, error is returned! If value is 0 (default), no limitation is used.
This is very good protection for stupid attacks to your server by sending
lot of data without proper terminator... until all your memory is allocated
by LineBuffer!
Note: This maximum length is checked only in functions, what read unknown
number of bytes! (like @link(RecvString) or @link(RecvTerminated))}
property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength;
{:Define maximal bandwidth for all sending operations in bytes per second.
If value is 0 (default), bandwidth limitation is not used.}
property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth;
{:Define maximal bandwidth for all receiving operations in bytes per second.
If value is 0 (default), bandwidth limitation is not used.}
property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth;
{:Define maximal bandwidth for all sending and receiving operations in bytes
per second. If value is 0 (default), bandwidth limitation is not used.}
property MaxBandwidth: Integer Write SetBandwidth;
{:Do a conversion of non-standard line terminators to CRLF. (Off by default)
If @True, then terminators like sigle CR, single LF or LFCR are converted
to CRLF internally. This have effect only in @link(RecvString) method!}
property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd;
{:Specified Family of this socket. When you are using Windows preliminary
support for IPv6, then I recommend to set this property!}
property Family: TSocketFamily read FFamily Write SetFamily;
{:When resolving of domain name return both IPv4 and IPv6 addresses, then
specify if is used IPv4 (dafault - @true) or IPv6.}
property PreferIP4: Boolean read FPreferIP4 Write FPreferIP4;
{:By default (@true) is all timeouts used as timeout between two packets in
reading operations. If you set this to @false, then Timeouts is for overall
reading operation!}
property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout;
{:All sended datas was splitted by this value.}
property SendMaxChunk: Integer read FSendMaxChunk Write FSendMaxChunk;
{:By setting this property to @true you can stop any communication. You can
use this property for soft abort of communication.}
property StopFlag: Boolean read FStopFlag Write FStopFlag;
{:Timeout for data sending by non-blocking socket mode.}
property NonblockSendTimeout: Integer read FNonblockSendTimeout Write FNonblockSendTimeout;
{:This event is called by various reasons. It is good for monitoring socket,
create gauges for data transfers, etc.}
property OnStatus: THookSocketStatus read FOnStatus write FOnStatus;
{:this event is good for some internal thinks about filtering readed datas.
It is used by telnet client by example.}
property OnReadFilter: THookDataFilter read FOnReadFilter write FOnReadFilter;
{:This event is called after real socket creation for setting special socket
options, because you not know when socket is created. (it is depended on
Ipv4, IPv6 or automatic mode)}
property OnCreateSocket: THookCreateSocket read FOnCreateSocket write FOnCreateSocket;
{:This event is good for monitoring content of readed or writed datas.}
property OnMonitor: THookMonitor read FOnMonitor write FOnMonitor;
{:This event is good for calling your code during long socket operations.
(Example, for refresing UI if class in not called within the thread.)
Rate of heartbeats can be modified by @link(HeartbeatRate) property.}
property OnHeartbeat: THookHeartbeat read FOnHeartbeat write FOnHeartbeat;
{:Specify typical rate of @link(OnHeartbeat) event and @link(StopFlag) testing.
Default value 0 disabling heartbeats! Value is in milliseconds.
Real rate can be higher or smaller then this value, because it depending
on real socket operations too!
Note: Each heartbeat slowing socket processing.}
property HeartbeatRate: integer read FHeartbeatRate Write FHeartbeatRate;
{:What class own this socket? Used by protocol implementation classes.}
property Owner: TObject read FOwner Write FOwner;
end;
{:@abstract(Support for SOCKS4 and SOCKS5 proxy)
Layer with definition all necessary properties and functions for
implementation SOCKS proxy client. Do not use this class directly.}
TSocksBlockSocket = class(TBlockSocket)
protected
FSocksIP: string;
FSocksPort: string;
FSocksTimeout: integer;
FSocksUsername: string;
FSocksPassword: string;
FUsingSocks: Boolean;
FSocksResolver: Boolean;
FSocksLastError: integer;
FSocksResponseIP: string;
FSocksResponsePort: string;
FSocksLocalIP: string;
FSocksLocalPort: string;
FSocksRemoteIP: string;
FSocksRemotePort: string;
FBypassFlag: Boolean;
FSocksType: TSocksType;
function SocksCode(IP, Port: string): Ansistring;
function SocksDecode(Value: Ansistring): integer;
public
constructor Create;
{:Open connection to SOCKS proxy and if @link(SocksUsername) is set, do
authorisation to proxy. This is needed only in special cases! (it is called
internally!)}
function SocksOpen: Boolean;
{:Send specified request to SOCKS proxy. This is needed only in special
cases! (it is called internally!)}
function SocksRequest(Cmd: Byte; const IP, Port: string): Boolean;
{:Receive response to previosly sended request. This is needed only in
special cases! (it is called internally!)}
function SocksResponse: Boolean;
{:Is @True when class is using SOCKS proxy.}
property UsingSocks: Boolean read FUsingSocks;
{:If SOCKS proxy failed, here is error code returned from SOCKS proxy.}
property SocksLastError: integer read FSocksLastError;
published
{:Address of SOCKS server. If value is empty string, SOCKS support is
disabled. Assingning any value to this property enable SOCKS mode.
Warning: You cannot combine this mode with HTTP-tunneling mode!}
property SocksIP: string read FSocksIP write FSocksIP;
{:Port of SOCKS server. Default value is '1080'.}
property SocksPort: string read FSocksPort write FSocksPort;
{:If you need authorisation on SOCKS server, set username here.}
property SocksUsername: string read FSocksUsername write FSocksUsername;
{:If you need authorisation on SOCKS server, set password here.}
property SocksPassword: string read FSocksPassword write FSocksPassword;
{:Specify timeout for communicatin with SOCKS server. Default is one minute.}
property SocksTimeout: integer read FSocksTimeout write FSocksTimeout;
{:If @True, all symbolic names of target hosts is not translated to IP's
locally, but resolving is by SOCKS proxy. Default is @True.}
property SocksResolver: Boolean read FSocksResolver write FSocksResolver;
{:Specify SOCKS type. By default is used SOCKS5, but you can use SOCKS4 too.
When you select SOCKS4, then if @link(SOCKSResolver) is enabled, then is
used SOCKS4a. Othervise is used pure SOCKS4.}
property SocksType: TSocksType read FSocksType write FSocksType;
end;
{:@abstract(Implementation of TCP socket.)
Supported features: IPv4, IPv6, SSL/TLS or SSH (depending on used plugin),
SOCKS5 proxy (outgoing connections and limited incomming), SOCKS4/4a proxy
(outgoing connections and limited incomming), TCP through HTTP proxy tunnel.}
TTCPBlockSocket = class(TSocksBlockSocket)
protected
FOnAfterConnect: THookAfterConnect;
FSSL: TCustomSSL;
FHTTPTunnelIP: string;
FHTTPTunnelPort: string;
FHTTPTunnel: Boolean;
FHTTPTunnelRemoteIP: string;
FHTTPTunnelRemotePort: string;
FHTTPTunnelUser: string;
FHTTPTunnelPass: string;
FHTTPTunnelTimeout: integer;
procedure SocksDoConnect(IP, Port: string);
procedure HTTPTunnelDoConnect(IP, Port: string);
procedure DoAfterConnect;
public
{:Create TCP socket class with default plugin for SSL/TSL/SSH implementation
(see @link(SSLImplementation))}
constructor Create;
{:Create TCP socket class with desired plugin for SSL/TSL/SSH implementation}
constructor CreateWithSSL(SSLPlugin: TSSLClass);
destructor Destroy; override;
{:See @link(TBlockSocket.CloseSocket)}
procedure CloseSocket; override;
{:See @link(TBlockSocket.WaitingData)}
function WaitingData: Integer; override;
{:Sets socket to receive mode for new incoming connections. It is necessary
to use @link(TBlockSocket.BIND) function call before this method to select
receiving port!
If you use SOCKS, activate incoming TCP connection by this proxy. (By BIND
method of SOCKS.)}
procedure Listen; override;
{:Waits until new incoming connection comes. After it comes a new socket is
automatically created (socket handler is returned by this function as
result).
If you use SOCKS, new socket is not created! In this case is used same
socket as socket for listening! So, you can accept only one connection in
SOCKS mode.}
function Accept: TSocket; override;
{:Connects socket to remote IP address and PORT. The same rules as with
@link(TBlockSocket.BIND) method are valid. The only exception is that PORT
with 0 value will not be connected. After call to this method
a communication channel between local and remote socket is created. Local
socket is assigned automatically if not controlled by previous call to
@link(TBlockSocket.BIND) method. Structures @link(TBlockSocket.LocalSin)
and @link(TBlockSocket.RemoteSin) will be filled with valid values.
If you use SOCKS, activate outgoing TCP connection by SOCKS proxy specified
in @link(TSocksBlockSocket.SocksIP). (By CONNECT method of SOCKS.)
If you use HTTP-tunnel mode, activate outgoing TCP connection by HTTP
tunnel specified in @link(HTTPTunnelIP). (By CONNECT method of HTTP
protocol.)
Note: If you call this on non-created socket, then socket is created
automaticly.}
procedure Connect(IP, Port: string); override;
{:If you need upgrade existing TCP connection to SSL/TLS (or SSH2, if plugin
allows it) mode, then call this method. This method switch this class to
SSL mode and do SSL/TSL handshake.}
procedure SSLDoConnect;
{:By this method you can downgrade existing SSL/TLS connection to normal TCP
connection.}
procedure SSLDoShutdown;
{:If you need use this component as SSL/TLS TCP server, then after accepting
of inbound connection you need start SSL/TLS session by this method. Before
call this function, you must have assigned all neeeded certificates and
keys!}
function SSLAcceptConnection: Boolean;
{:See @link(TBlockSocket.GetLocalSinIP)}
function GetLocalSinIP: string; override;
{:See @link(TBlockSocket.GetRemoteSinIP)}
function GetRemoteSinIP: string; override;
{:See @link(TBlockSocket.GetLocalSinPort)}
function GetLocalSinPort: Integer; override;
{:See @link(TBlockSocket.GetRemoteSinPort)}
function GetRemoteSinPort: Integer; override;
{:See @link(TBlockSocket.SendBuffer)}
function SendBuffer(Buffer: TMemory; Length: Integer): Integer; override;
{:See @link(TBlockSocket.RecvBuffer)}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:Return value of socket type. For TCP return SOCK_STREAM.}
function GetSocketType: integer; override;
{:Return value of protocol type for socket creation. For TCP return
IPPROTO_TCP.}
function GetSocketProtocol: integer; override;
{:Class implementing SSL/TLS support. It is allways some descendant
of @link(TCustomSSL) class. When programmer not select some SSL plugin
class, then is used @link(TSSLNone)}
property SSL: TCustomSSL read FSSL;
{:@True if is used HTTP tunnel mode.}
property HTTPTunnel: Boolean read FHTTPTunnel;
published
{:Return descriptive string for @link(LastError). On case of error
in SSL/TLS subsystem, it returns right error description.}
function GetErrorDescEx: string; override;
{:Specify IP address of HTTP proxy. Assingning non-empty value to this
property enable HTTP-tunnel mode. This mode is for tunnelling any outgoing
TCP connection through HTTP proxy server. (If policy on HTTP proxy server
allow this!) Warning: You cannot combine this mode with SOCK5 mode!}
property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP;
{:Specify port of HTTP proxy for HTTP-tunneling.}
property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort;
{:Specify authorisation username for access to HTTP proxy in HTTP-tunnel
mode. If you not need authorisation, then let this property empty.}
property HTTPTunnelUser: string read FHTTPTunnelUser Write FHTTPTunnelUser;
{:Specify authorisation password for access to HTTP proxy in HTTP-tunnel
mode.}
property HTTPTunnelPass: string read FHTTPTunnelPass Write FHTTPTunnelPass;
{:Specify timeout for communication with HTTP proxy in HTTPtunnel mode.}
property HTTPTunnelTimeout: integer read FHTTPTunnelTimeout Write FHTTPTunnelTimeout;
{:This event is called after sucessful TCP socket connection.}
property OnAfterConnect: THookAfterConnect read FOnAfterConnect write FOnAfterConnect;
end;
{:@abstract(Datagram based communication)
This class implementing datagram based communication instead default stream
based communication style.}
TDgramBlockSocket = class(TSocksBlockSocket)
public
{:Fill @link(TBlockSocket.RemoteSin) structure. This address is used for
sending data.}
procedure Connect(IP, Port: string); override;
{:Silently redirected to @link(TBlockSocket.SendBufferTo).}
function SendBuffer(Buffer: TMemory; Length: Integer): Integer; override;
{:Silently redirected to @link(TBlockSocket.RecvBufferFrom).}
function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; override;
end;
{:@abstract(Implementation of UDP socket.)
NOTE: in this class is all receiving redirected to RecvBufferFrom. You can
use for reading any receive function. Preffered is RecvPacket! Similary all
sending is redirected to SendbufferTo. You can use for sending UDP packet any
sending function, like SendString.
Supported features: IPv4, IPv6, unicasts, broadcasts, multicasts, SOCKS5
proxy (only unicasts! Outgoing and incomming.)}
TUDPBlockSocket = class(TDgramBlockSocket)
protected
FSocksControlSock: TTCPBlockSocket;
function UdpAssociation: Boolean;
procedure SetMulticastTTL(TTL: integer);
function GetMulticastTTL:integer;
public
destructor Destroy; override;
{:Enable or disable sending of broadcasts. If seting OK, result is @true.
This method is not supported in SOCKS5 mode! IPv6 does not support
broadcasts! In this case you must use Multicasts instead.}
procedure EnableBroadcast(Value: Boolean);
{:See @link(TBlockSocket.SendBufferTo)}
function SendBufferTo(Buffer: TMemory; Length: Integer): Integer; override;
{:See @link(TBlockSocket.RecvBufferFrom)}
function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; override;
{$IFNDEF CIL}
{:Add this socket to given multicast group. You cannot use Multicasts in
SOCKS mode!}
procedure AddMulticast(MCastIP:string);
{:Remove this socket from given multicast group.}
procedure DropMulticast(MCastIP:string);
{$ENDIF}
{:All sended multicast datagrams is loopbacked to your interface too. (you
can read your sended datas.) You can disable this feature by this function.
This function not working on some Windows systems!}
procedure EnableMulticastLoop(Value: Boolean);
{:Return value of socket type. For UDP return SOCK_DGRAM.}
function GetSocketType: integer; override;
{:Return value of protocol type for socket creation. For UDP return
IPPROTO_UDP.}
function GetSocketProtocol: integer; override;
{:Set Time-to-live value for multicasts packets. It define number of routers
for transfer of datas. If you set this to 1 (dafault system value), then
multicasts packet goes only to you local network. If you need transport
multicast packet to worldwide, then increase this value, but be carefull,
lot of routers on internet does not transport multicasts packets!}
property MulticastTTL: Integer read GetMulticastTTL Write SetMulticastTTL;
end;
{:@abstract(Implementation of RAW ICMP socket.)
For this object you must have rights for creating RAW sockets!}
TICMPBlockSocket = class(TDgramBlockSocket)
public
{:Return value of socket type. For RAW and ICMP return SOCK_RAW.}
function GetSocketType: integer; override;
{:Return value of protocol type for socket creation. For ICMP returns
IPPROTO_ICMP or IPPROTO_ICMPV6}
function GetSocketProtocol: integer; override;
end;
{:@abstract(Implementation of RAW socket.)
For this object you must have rights for creating RAW sockets!}
TRAWBlockSocket = class(TBlockSocket)
public
{:Return value of socket type. For RAW and ICMP return SOCK_RAW.}
function GetSocketType: integer; override;
{:Return value of protocol type for socket creation. For RAW returns
IPPROTO_RAW.}
function GetSocketProtocol: integer; override;
end;
{:@abstract(Implementation of PGM-message socket.)
Not all systems supports this protocol!}
TPGMMessageBlockSocket = class(TBlockSocket)
public
{:Return value of socket type. For PGM-message return SOCK_RDM.}
function GetSocketType: integer; override;
{:Return value of protocol type for socket creation. For PGM-message returns
IPPROTO_RM.}
function GetSocketProtocol: integer; override;
end;
{:@abstract(Implementation of PGM-stream socket.)
Not all systems supports this protocol!}
TPGMStreamBlockSocket = class(TBlockSocket)
public
{:Return value of socket type. For PGM-stream return SOCK_STREAM.}
function GetSocketType: integer; override;
{:Return value of protocol type for socket creation. For PGM-stream returns
IPPROTO_RM.}
function GetSocketProtocol: integer; override;
end;
{:@abstract(Parent class for all SSL plugins.)
This is abstract class defining interface for other SSL plugins.
Instance of this class will be created for each @link(TTCPBlockSocket).
Warning: not all methods and propertis can work in all existing SSL plugins!
Please, read documentation of used SSL plugin.}
TCustomSSL = class(TObject)
protected
FSocket: TTCPBlockSocket;
FSSLEnabled: Boolean;
FLastError: integer;
FLastErrorDesc: string;
FSSLType: TSSLType;
FKeyPassword: string;
FCiphers: string;
FCertificateFile: string;
FPrivateKeyFile: string;
FCertificate: Ansistring;
FPrivateKey: Ansistring;
FPFX: Ansistring;
FPFXfile: string;
FCertCA: Ansistring;
FCertCAFile: string;
FTrustCertificate: Ansistring;
FTrustCertificateFile: string;
FVerifyCert: Boolean;
FUsername: string;
FPassword: string;
FSSHChannelType: string;
FSSHChannelArg1: string;
FSSHChannelArg2: string;
procedure ReturnError;
function CreateSelfSignedCert(Host: string): Boolean; virtual;
public
{: Create plugin class. it is called internally from @link(TTCPBlockSocket)}
constructor Create(const Value: TTCPBlockSocket); virtual;
{: Assign settings (certificates and configuration) from another SSL plugin
class.}
procedure Assign(const Value: TCustomSSL); virtual;
{: return description of used plugin. It usually return name and version
of used SSL library.}
function LibVersion: String; virtual;
{: return name of used plugin.}
function LibName: String; virtual;
{: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
Here is needed code for start SSL connection.}
function Connect: boolean; virtual;
{: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
Here is needed code for acept new SSL connection.}
function Accept: boolean; virtual;
{: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
Here is needed code for hard shutdown of SSL connection. (for example,
before socket is closed)}
function Shutdown: boolean; virtual;
{: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
Here is needed code for soft shutdown of SSL connection. (for example,
when you need to continue with unprotected connection.)}
function BiShutdown: boolean; virtual;
{: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
Here is needed code for sending some datas by SSL connection.}
function SendBuffer(Buffer: TMemory; Len: Integer): Integer; virtual;
{: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
Here is needed code for receiving some datas by SSL connection.}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; virtual;
{: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
Here is needed code for getting count of datas what waiting for read.
If SSL plugin not allows this, then it should return 0.}
function WaitingData: Integer; virtual;
{:Return string with identificator of SSL/TLS version of existing
connection.}
function GetSSLVersion: string; virtual;
{:Return subject of remote SSL peer.}
function GetPeerSubject: string; virtual;
{:Return issuer certificate of remote SSL peer.}
function GetPeerIssuer: string; virtual;
{:Return peer name from remote side certificate. This is good for verify,
if certificate is generated for remote side IP name.}
function GetPeerName: string; virtual;
{:Return fingerprint of remote SSL peer.}
function GetPeerFingerprint: string; virtual;
{:Return all detailed information about certificate from remote side of
SSL/TLS connection. Result string can be multilined! Each plugin can return
this informations in different format!}
function GetCertInfo: string; virtual;
{:Return currently used Cipher.}
function GetCipherName: string; virtual;
{:Return currently used number of bits in current Cipher algorythm.}
function GetCipherBits: integer; virtual;
{:Return number of bits in current Cipher algorythm.}
function GetCipherAlgBits: integer; virtual;
{:Return result value of verify remote side certificate. Look to OpenSSL
documentation for possible values. For example 0 is successfuly verified
certificate, or 18 is self-signed certificate.}
function GetVerifyCert: integer; virtual;
{: Resurn @true if SSL mode is enabled on existing cvonnection.}
property SSLEnabled: Boolean read FSSLEnabled;
{:Return error code of last SSL operation. 0 is OK.}
property LastError: integer read FLastError;
{:Return error description of last SSL operation.}
property LastErrorDesc: string read FLastErrorDesc;
published
{:Here you can specify requested SSL/TLS mode. Default is autodetection, but
on some servers autodetection not working properly. In this case you must
specify requested SSL/TLS mode by your hand!}
property SSLType: TSSLType read FSSLType write FSSLType;
{:Password for decrypting of encoded certificate or key.}
property KeyPassword: string read FKeyPassword write FKeyPassword;
{:Username for possible credentials.}
property Username: string read FUsername write FUsername;
{:password for possible credentials.}
property Password: string read FPassword write FPassword;
{:By this property you can modify default set of SSL/TLS ciphers.}
property Ciphers: string read FCiphers write FCiphers;
{:Used for loading certificate from disk file. See to plugin documentation
if this method is supported and how!}
property CertificateFile: string read FCertificateFile write FCertificateFile;
{:Used for loading private key from disk file. See to plugin documentation
if this method is supported and how!}
property PrivateKeyFile: string read FPrivateKeyFile write FPrivateKeyFile;
{:Used for loading certificate from binary string. See to plugin documentation
if this method is supported and how!}
property Certificate: Ansistring read FCertificate write FCertificate;
{:Used for loading private key from binary string. See to plugin documentation
if this method is supported and how!}
property PrivateKey: Ansistring read FPrivateKey write FPrivateKey;
{:Used for loading PFX from binary string. See to plugin documentation
if this method is supported and how!}
property PFX: Ansistring read FPFX write FPFX;
{:Used for loading PFX from disk file. See to plugin documentation
if this method is supported and how!}
property PFXfile: string read FPFXfile write FPFXfile;
{:Used for loading trusted certificates from disk file. See to plugin documentation
if this method is supported and how!}
property TrustCertificateFile: string read FTrustCertificateFile write FTrustCertificateFile;
{:Used for loading trusted certificates from binary string. See to plugin documentation
if this method is supported and how!}
property TrustCertificate: Ansistring read FTrustCertificate write FTrustCertificate;
{:Used for loading CA certificates from binary string. See to plugin documentation
if this method is supported and how!}
property CertCA: Ansistring read FCertCA write FCertCA;
{:Used for loading CA certificates from disk file. See to plugin documentation
if this method is supported and how!}
property CertCAFile: string read FCertCAFile write FCertCAFile;
{:If @true, then is verified client certificate. (it is good for writing
SSL/TLS servers.) When you are not server, but you are client, then if this
property is @true, verify servers certificate.}
property VerifyCert: Boolean read FVerifyCert write FVerifyCert;
{:channel type for possible SSH connections}
property SSHChannelType: string read FSSHChannelType write FSSHChannelType;
{:First argument of channel type for possible SSH connections}
property SSHChannelArg1: string read FSSHChannelArg1 write FSSHChannelArg1;
{:Second argument of channel type for possible SSH connections}
property SSHChannelArg2: string read FSSHChannelArg2 write FSSHChannelArg2;
end;
{:@abstract(Default SSL plugin with no SSL support.)
Dummy SSL plugin implementation for applications without SSL/TLS support.}
TSSLNone = class (TCustomSSL)
public
{:See @inherited}
function LibVersion: String; override;
{:See @inherited}
function LibName: String; override;
end;
{:@abstract(Record with definition of IP packet header.)
For reading data from ICMP or RAW sockets.}
TIPHeader = record
VerLen: Byte;
TOS: Byte;
TotalLen: Word;
Identifer: Word;
FragOffsets: Word;
TTL: Byte;
Protocol: Byte;
CheckSum: Word;
SourceIp: LongWord;
DestIp: LongWord;
Options: LongWord;
end;
{:@abstract(Parent class of application protocol implementations.)
By this class is defined common properties.}
TSynaClient = Class(TObject)
protected
FTargetHost: string;
FTargetPort: string;
FIPInterface: string;
FTimeout: integer;
FUserName: string;
FPassword: string;
public
constructor Create;
published
{:Specify terget server IP (or symbolic name). Default is 'localhost'.}
property TargetHost: string read FTargetHost Write FTargetHost;
{:Specify terget server port (or symbolic name).}
property TargetPort: string read FTargetPort Write FTargetPort;
{:Defined local socket address. (outgoing IP address). By default is used
'0.0.0.0' as wildcard for default IP.}
property IPInterface: string read FIPInterface Write FIPInterface;
{:Specify default timeout for socket operations.}
property Timeout: integer read FTimeout Write FTimeout;
{:If protocol need user authorization, then fill here username.}
property UserName: string read FUserName Write FUserName;
{:If protocol need user authorization, then fill here password.}
property Password: string read FPassword Write FPassword;
end;
var
{:Selected SSL plugin. Default is @link(TSSLNone).
Do not change this value directly!!!
Just add your plugin unit to your project uses instead. Each plugin unit have
initialization code what modify this variable.}
SSLImplementation: TSSLClass = TSSLNone;
implementation
{$IFDEF ONCEWINSOCK}
var
WsaDataOnce: TWSADATA;
e: ESynapseError;
{$ENDIF}
constructor TBlockSocket.Create;
begin
CreateAlternate('');
end;
constructor TBlockSocket.CreateAlternate(Stub: string);
{$IFNDEF ONCEWINSOCK}
var
e: ESynapseError;
{$ENDIF}
begin
inherited Create;
FDelayedOptions := TList.Create;
FRaiseExcept := False;
{$IFDEF RAISEEXCEPT}
FRaiseExcept := True;
{$ENDIF}
FSocket := INVALID_SOCKET;
FBuffer := '';
FLastCR := False;
FLastLF := False;
FBinded := False;
FNonBlockMode := False;
FMaxLineLength := 0;
FMaxSendBandwidth := 0;
FNextSend := 0;
FMaxRecvBandwidth := 0;
FNextRecv := 0;
FConvertLineEnd := False;
FFamily := SF_Any;
FFamilySave := SF_Any;
FIP6used := False;
FPreferIP4 := True;
FInterPacketTimeout := True;
FRecvCounter := 0;
FSendCounter := 0;
FSendMaxChunk := c64k;
FStopFlag := False;
FNonblockSendTimeout := 15000;
FHeartbeatRate := 0;
FOwner := nil;
{$IFNDEF ONCEWINSOCK}
if Stub = '' then
Stub := DLLStackName;
if not InitSocketInterface(Stub) then
begin
e := ESynapseError.Create('Error loading Socket interface (' + Stub + ')!');
e.ErrorCode := 0;
e.ErrorMessage := 'Error loading Socket interface (' + Stub + ')!';
raise e;
end;
SockCheck(synsock.WSAStartup(WinsockLevel, FWsaDataOnce));
ExceptCheck;
{$ENDIF}
end;
destructor TBlockSocket.Destroy;
var
n: integer;
p: TSynaOption;
begin
CloseSocket;
{$IFNDEF ONCEWINSOCK}
synsock.WSACleanup;
DestroySocketInterface;
{$ENDIF}
for n := FDelayedOptions.Count - 1 downto 0 do
begin
p := TSynaOption(FDelayedOptions[n]);
p.Free;
end;
FDelayedOptions.Free;
inherited Destroy;
end;
function TBlockSocket.FamilyToAF(f: TSocketFamily): TAddrFamily;
begin
case f of
SF_ip4:
Result := AF_INET;
SF_ip6:
Result := AF_INET6;
else
Result := AF_UNSPEC;
end;
end;
procedure TBlockSocket.SetDelayedOption(const Value: TSynaOption);
var
li: TLinger;
x: integer;
buf: TMemory;
{$IFNDEF MSWINDOWS}
timeval: TTimeval;
{$ENDIF}
begin
case value.Option of
SOT_Linger:
begin
{$IFDEF CIL}
li := TLinger.Create(Value.Enabled, Value.Value div 1000);
synsock.SetSockOptObj(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), li);
{$ELSE}
li.l_onoff := Ord(Value.Enabled);
li.l_linger := Value.Value div 1000;
buf := @li;
synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), buf, SizeOf(li));
{$ENDIF}
end;
SOT_RecvBuff:
begin
{$IFDEF CIL}
buf := System.BitConverter.GetBytes(value.Value);
{$ELSE}
buf := @Value.Value;
{$ENDIF}
synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF),
buf, SizeOf(Value.Value));
end;
SOT_SendBuff:
begin
{$IFDEF CIL}
buf := System.BitConverter.GetBytes(value.Value);
{$ELSE}
buf := @Value.Value;
{$ENDIF}
synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF),
buf, SizeOf(Value.Value));
end;
SOT_NonBlock:
begin
FNonBlockMode := Value.Enabled;
x := Ord(FNonBlockMode);
synsock.IoctlSocket(FSocket, FIONBIO, x);
end;
SOT_RecvTimeout:
begin
{$IFDEF CIL}
buf := System.BitConverter.GetBytes(value.Value);
synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
buf, SizeOf(Value.Value));
{$ELSE}
{$IFDEF MSWINDOWS}
buf := @Value.Value;
synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
buf, SizeOf(Value.Value));
{$ELSE}
timeval.tv_sec:=Value.Value div 1000;
timeval.tv_usec:=(Value.Value mod 1000) * 1000;
synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
@timeval, SizeOf(timeval));
{$ENDIF}
{$ENDIF}
end;
SOT_SendTimeout:
begin
{$IFDEF CIL}
buf := System.BitConverter.GetBytes(value.Value);
{$ELSE}
{$IFDEF MSWINDOWS}
buf := @Value.Value;
synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO),
buf, SizeOf(Value.Value));
{$ELSE}
timeval.tv_sec:=Value.Value div 1000;
timeval.tv_usec:=(Value.Value mod 1000) * 1000;
synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO),
@timeval, SizeOf(timeval));
{$ENDIF}
{$ENDIF}
end;
SOT_Reuse:
begin
x := Ord(Value.Enabled);
{$IFDEF CIL}
buf := System.BitConverter.GetBytes(x);
{$ELSE}
buf := @x;
{$ENDIF}
synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_REUSEADDR), buf, SizeOf(x));
end;
SOT_TTL:
begin
{$IFDEF CIL}
buf := System.BitConverter.GetBytes(value.Value);
{$ELSE}
buf := @Value.Value;
{$ENDIF}
if FIP6Used then
synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_UNICAST_HOPS),
buf, SizeOf(Value.Value))
else
synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_TTL),
buf, SizeOf(Value.Value));
end;
SOT_Broadcast:
begin
//#todo1 broadcasty na IP6
x := Ord(Value.Enabled);
{$IFDEF CIL}
buf := System.BitConverter.GetBytes(x);
{$ELSE}
buf := @x;
{$ENDIF}
synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_BROADCAST), buf, SizeOf(x));
end;
SOT_MulticastTTL:
begin
{$IFDEF CIL}
buf := System.BitConverter.GetBytes(value.Value);
{$ELSE}
buf := @Value.Value;
{$ENDIF}
if FIP6Used then
synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_HOPS),
buf, SizeOf(Value.Value))
else
synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_TTL),
buf, SizeOf(Value.Value));
end;
SOT_MulticastLoop:
begin
x := Ord(Value.Enabled);
{$IFDEF CIL}
buf := System.BitConverter.GetBytes(x);
{$ELSE}
buf := @x;
{$ENDIF}
if FIP6Used then
synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_LOOP), buf, SizeOf(x))
else
synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_LOOP), buf, SizeOf(x));
end;
end;
Value.free;
end;
procedure TBlockSocket.DelayedOption(const Value: TSynaOption);
begin
if FSocket = INVALID_SOCKET then
begin
FDelayedOptions.Insert(0, Value);
end
else
SetDelayedOption(Value);
end;
procedure TBlockSocket.ProcessDelayedOptions;
var
n: integer;
d: TSynaOption;
begin
for n := FDelayedOptions.Count - 1 downto 0 do
begin
d := TSynaOption(FDelayedOptions[n]);
SetDelayedOption(d);
end;
FDelayedOptions.Clear;
end;
procedure TBlockSocket.SetSin(var Sin: TVarSin; IP, Port: string);
var
f: TSocketFamily;
begin
DoStatus(HR_ResolvingBegin, IP + ':' + Port);
ResetLastError;
//if socket exists, then use their type, else use users selection
f := SF_Any;
if (FSocket = INVALID_SOCKET) and (FFamily = SF_any) then
begin
if IsIP(IP) then
f := SF_IP4
else
if IsIP6(IP) then
f := SF_IP6;
end
else
f := FFamily;
FLastError := synsock.SetVarSin(sin, ip, port, FamilyToAF(f),
GetSocketprotocol, GetSocketType, FPreferIP4);
DoStatus(HR_ResolvingEnd, GetSinIP(sin) + ':' + IntTostr(GetSinPort(sin)));
end;
function TBlockSocket.GetSinIP(Sin: TVarSin): string;
begin
Result := synsock.GetSinIP(sin);
end;
function TBlockSocket.GetSinPort(Sin: TVarSin): Integer;
begin
Result := synsock.GetSinPort(sin);
end;
procedure TBlockSocket.CreateSocket;
var
sin: TVarSin;
begin
//dummy for SF_Any Family mode
ResetLastError;
if (FFamily <> SF_Any) and (FSocket = INVALID_SOCKET) then
begin
{$IFDEF CIL}
if FFamily = SF_IP6 then
sin := TVarSin.Create(IPAddress.Parse('::0'), 0)
else
sin := TVarSin.Create(IPAddress.Parse('0.0.0.0'), 0);
{$ELSE}
FillChar(Sin, Sizeof(Sin), 0);
if FFamily = SF_IP6 then
sin.sin_family := AF_INET6
else
sin.sin_family := AF_INET;
{$ENDIF}
InternalCreateSocket(Sin);
end;
end;
procedure TBlockSocket.CreateSocketByName(const Value: String);
var
sin: TVarSin;
begin
ResetLastError;
if FSocket = INVALID_SOCKET then
begin
SetSin(sin, value, '0');
if FLastError = 0 then
InternalCreateSocket(Sin);
end;
end;
procedure TBlockSocket.InternalCreateSocket(Sin: TVarSin);
begin
FStopFlag := False;
FRecvCounter := 0;
FSendCounter := 0;
ResetLastError;
if FSocket = INVALID_SOCKET then
begin
FBuffer := '';
FBinded := False;
FIP6Used := Sin.AddressFamily = AF_INET6;
FSocket := synsock.Socket(integer(Sin.AddressFamily), GetSocketType, GetSocketProtocol);
if FSocket = INVALID_SOCKET then
FLastError := synsock.WSAGetLastError;
{$IFNDEF CIL}
FD_ZERO(FFDSet);
FD_SET(FSocket, FFDSet);
{$ENDIF}
ExceptCheck;
if FIP6used then
DoStatus(HR_SocketCreate, 'IPv6')
else
DoStatus(HR_SocketCreate, 'IPv4');
ProcessDelayedOptions;
DoCreateSocket;
end;
end;
procedure TBlockSocket.CloseSocket;
begin
AbortSocket;
end;
procedure TBlockSocket.AbortSocket;
var
n: integer;
p: TSynaOption;
begin
if FSocket <> INVALID_SOCKET then
synsock.CloseSocket(FSocket);
FSocket := INVALID_SOCKET;
for n := FDelayedOptions.Count - 1 downto 0 do
begin
p := TSynaOption(FDelayedOptions[n]);
p.Free;
end;
FDelayedOptions.Clear;
FFamily := FFamilySave;
DoStatus(HR_SocketClose, '');
end;
procedure TBlockSocket.Bind(IP, Port: string);
var
Sin: TVarSin;
begin
ResetLastError;
if (FSocket <> INVALID_SOCKET)
or not((FFamily = SF_ANY) and (IP = cAnyHost) and (Port = cAnyPort)) then
begin
SetSin(Sin, IP, Port);
if FLastError = 0 then
begin
if FSocket = INVALID_SOCKET then
InternalCreateSocket(Sin);
SockCheck(synsock.Bind(FSocket, Sin));
GetSinLocal;
FBuffer := '';
FBinded := True;
end;
ExceptCheck;
DoStatus(HR_Bind, IP + ':' + Port);
end;
end;
procedure TBlockSocket.Connect(IP, Port: string);
var
Sin: TVarSin;
begin
SetSin(Sin, IP, Port);
if FLastError = 0 then
begin
if FSocket = INVALID_SOCKET then
InternalCreateSocket(Sin);
SockCheck(synsock.Connect(FSocket, Sin));
if FLastError = 0 then
GetSins;
FBuffer := '';
FLastCR := False;
FLastLF := False;
end;
ExceptCheck;
DoStatus(HR_Connect, IP + ':' + Port);
end;
procedure TBlockSocket.Listen;
begin
SockCheck(synsock.Listen(FSocket, SOMAXCONN));
GetSins;
ExceptCheck;
DoStatus(HR_Listen, '');
end;
function TBlockSocket.Accept: TSocket;
begin
Result := synsock.Accept(FSocket, FRemoteSin);
/// SockCheck(Result);
ExceptCheck;
DoStatus(HR_Accept, '');
end;
procedure TBlockSocket.GetSinLocal;
begin
synsock.GetSockName(FSocket, FLocalSin);
end;
procedure TBlockSocket.GetSinRemote;
begin
synsock.GetPeerName(FSocket, FRemoteSin);
end;
procedure TBlockSocket.GetSins;
begin
GetSinLocal;
GetSinRemote;
end;
procedure TBlockSocket.SetBandwidth(Value: Integer);
begin
MaxSendBandwidth := Value;
MaxRecvBandwidth := Value;
end;
procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord);
var
x: LongWord;
y: LongWord;
n: integer;
begin
if FStopFlag then
exit;
if MaxB > 0 then
begin
y := GetTick;
if Next > y then
begin
x := Next - y;
if x > 0 then
begin
DoStatus(HR_Wait, IntToStr(x));
sleep(x mod 250);
for n := 1 to x div 250 do
if FStopFlag then
Break
else
sleep(250);
end;
end;
Next := GetTick + Trunc((Length / MaxB) * 1000);
end;
end;
function TBlockSocket.TestStopFlag: Boolean;
begin
DoHeartbeat;
Result := FStopFlag;
if Result then
begin
FStopFlag := False;
FLastError := WSAECONNABORTED;
ExceptCheck;
end;
end;
function TBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer;
{$IFNDEF CIL}
var
x, y: integer;
l, r: integer;
p: Pointer;
{$ENDIF}
begin
Result := 0;
if TestStopFlag then
Exit;
DoMonitor(True, Buffer, Length);
{$IFDEF CIL}
Result := synsock.Send(FSocket, Buffer, Length, 0);
{$ELSE}
l := Length;
x := 0;
while x < l do
begin
y := l - x;
if y > FSendMaxChunk then
y := FSendMaxChunk;
if y > 0 then
begin
LimitBandwidth(y, FMaxSendBandwidth, FNextsend);
p := IncPoint(Buffer, x);
r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL);
SockCheck(r);
if FLastError = WSAEWOULDBLOCK then
begin
if CanWrite(FNonblockSendTimeout) then
begin
r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL);
SockCheck(r);
end
else
FLastError := WSAETIMEDOUT;
end;
if FLastError <> 0 then
Break;
Inc(x, r);
Inc(Result, r);
Inc(FSendCounter, r);
DoStatus(HR_WriteCount, IntToStr(r));
end
else
break;
end;
{$ENDIF}
ExceptCheck;
end;
procedure TBlockSocket.SendByte(Data: Byte);
{$IFDEF CIL}
var
buf: TMemory;
{$ENDIF}
begin
{$IFDEF CIL}
setlength(buf, 1);
buf[0] := Data;
SendBuffer(buf, 1);
{$ELSE}
SendBuffer(@Data, 1);
{$ENDIF}
end;
procedure TBlockSocket.SendString(Data: AnsiString);
var
buf: TMemory;
begin
{$IFDEF CIL}
buf := BytesOf(Data);
{$ELSE}
buf := Pointer(data);
{$ENDIF}
SendBuffer(buf, Length(Data));
end;
procedure TBlockSocket.SendInteger(Data: integer);
var
buf: TMemory;
begin
{$IFDEF CIL}
buf := System.BitConverter.GetBytes(Data);
{$ELSE}
buf := @Data;
{$ENDIF}
SendBuffer(buf, SizeOf(Data));
end;
procedure TBlockSocket.SendBlock(const Data: AnsiString);
var
i: integer;
begin
i := SwapBytes(Length(data));
SendString(Codelongint(i) + Data);
end;
procedure TBlockSocket.InternalSendStream(const Stream: TStream; WithSize, Indy: boolean);
var
l: integer;
yr: integer;
s: AnsiString;
b: boolean;
{$IFDEF CIL}
buf: TMemory;
{$ENDIF}
begin
b := true;
l := 0;
if WithSize then
begin
l := Stream.Size - Stream.Position;;
if not Indy then
l := synsock.HToNL(l);
end;
repeat
{$IFDEF CIL}
Setlength(buf, FSendMaxChunk);
yr := Stream.read(buf, FSendMaxChunk);
if yr > 0 then
begin
if WithSize and b then
begin
b := false;
SendString(CodeLongInt(l));
end;
SendBuffer(buf, yr);
if FLastError <> 0 then
break;
end
{$ELSE}
Setlength(s, FSendMaxChunk);
yr := Stream.read(Pointer(s)^, FSendMaxChunk);
if yr > 0 then
begin
SetLength(s, yr);
if WithSize and b then
begin
b := false;
SendString(CodeLongInt(l) + s);
end
else
SendString(s);
if FLastError <> 0 then
break;
end
{$ENDIF}
until yr <= 0;
end;
procedure TBlockSocket.SendStreamRaw(const Stream: TStream);
begin
InternalSendStream(Stream, false, false);
end;
procedure TBlockSocket.SendStreamIndy(const Stream: TStream);
begin
InternalSendStream(Stream, true, true);
end;
procedure TBlockSocket.SendStream(const Stream: TStream);
begin
InternalSendStream(Stream, true, false);
end;
function TBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer;
begin
Result := 0;
if TestStopFlag then
Exit;
LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
// Result := synsock.Recv(FSocket, Buffer^, Length, MSG_NOSIGNAL);
Result := synsock.Recv(FSocket, Buffer, Length, MSG_NOSIGNAL);
if Result = 0 then
FLastError := WSAECONNRESET
else
SockCheck(Result);
ExceptCheck;
if Result > 0 then
begin
Inc(FRecvCounter, Result);
DoStatus(HR_ReadCount, IntToStr(Result));
DoMonitor(False, Buffer, Result);
DoReadFilter(Buffer, Result);
end;
end;
function TBlockSocket.RecvBufferEx(Buffer: TMemory; Len: Integer;
Timeout: Integer): Integer;
var
s: AnsiString;
rl, l: integer;
ti: LongWord;
{$IFDEF CIL}
n: integer;
b: TMemory;
{$ENDIF}
begin
ResetLastError;
Result := 0;
if Len > 0 then
begin
rl := 0;
repeat
ti := GetTick;
s := RecvPacket(Timeout);
l := Length(s);
if (rl + l) > Len then
l := Len - rl;
{$IFDEF CIL}
b := BytesOf(s);
for n := 0 to l do
Buffer[rl + n] := b[n];
{$ELSE}
Move(Pointer(s)^, IncPoint(Buffer, rl)^, l);
{$ENDIF}
rl := rl + l;
if FLastError <> 0 then
Break;
if rl >= Len then
Break;
if not FInterPacketTimeout then
begin
Timeout := Timeout - integer(TickDelta(ti, GetTick));
if Timeout <= 0 then
begin
FLastError := WSAETIMEDOUT;
Break;
end;
end;
until False;
delete(s, 1, l);
FBuffer := s;
Result := rl;
end;
end;
function TBlockSocket.RecvBufferStr(Len: Integer; Timeout: Integer): AnsiString;
var
x: integer;
{$IFDEF CIL}
buf: Tmemory;
{$ENDIF}
begin
Result := '';
if Len > 0 then
begin
{$IFDEF CIL}
Setlength(Buf, Len);
x := RecvBufferEx(buf, Len , Timeout);
if FLastError = 0 then
begin
SetLength(Buf, x);
Result := StringOf(buf);
end
else
Result := '';
{$ELSE}
Setlength(Result, Len);
x := RecvBufferEx(Pointer(Result), Len , Timeout);
if FLastError = 0 then
SetLength(Result, x)
else
Result := '';
{$ENDIF}
end;
end;
function TBlockSocket.RecvPacket(Timeout: Integer): AnsiString;
var
x: integer;
{$IFDEF CIL}
buf: TMemory;
{$ENDIF}
begin
Result := '';
ResetLastError;
if FBuffer <> '' then
begin
Result := FBuffer;
FBuffer := '';
end
else
begin
{$IFDEF MSWINDOWS}
//not drain CPU on large downloads...
Sleep(0);
{$ENDIF}
x := WaitingData;
if x > 0 then
begin
{$IFDEF CIL}
SetLength(Buf, x);
x := RecvBuffer(Buf, x);
if x >= 0 then
begin
SetLength(Buf, x);
Result := StringOf(Buf);
end;
{$ELSE}
SetLength(Result, x);
x := RecvBuffer(Pointer(Result), x);
if x >= 0 then
SetLength(Result, x);
{$ENDIF}
end
else
begin
if CanRead(Timeout) then
begin
x := WaitingData;
if x = 0 then
FLastError := WSAECONNRESET;
if x > 0 then
begin
{$IFDEF CIL}
SetLength(Buf, x);
x := RecvBuffer(Buf, x);
if x >= 0 then
begin
SetLength(Buf, x);
result := StringOf(Buf);
end;
{$ELSE}
SetLength(Result, x);
x := RecvBuffer(Pointer(Result), x);
if x >= 0 then
SetLength(Result, x);
{$ENDIF}
end;
end
else
FLastError := WSAETIMEDOUT;
end;
end;
if FConvertLineEnd and (Result <> '') then
begin
if FLastCR and (Result[1] = LF) then
Delete(Result, 1, 1);
if FLastLF and (Result[1] = CR) then
Delete(Result, 1, 1);
FLastCR := False;
FLastLF := False;
end;
ExceptCheck;
end;
function TBlockSocket.RecvByte(Timeout: Integer): Byte;
begin
Result := 0;
ResetLastError;
if FBuffer = '' then
FBuffer := RecvPacket(Timeout);
if (FLastError = 0) and (FBuffer <> '') then
begin
Result := Ord(FBuffer[1]);
Delete(FBuffer, 1, 1);
end;
ExceptCheck;
end;
function TBlockSocket.RecvInteger(Timeout: Integer): Integer;
var
s: AnsiString;
begin
Result := 0;
s := RecvBufferStr(4, Timeout);
if FLastError = 0 then
Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536;
end;
function TBlockSocket.RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString;
var
x: Integer;
s: AnsiString;
l: Integer;
CorCRLF: Boolean;
t: AnsiString;
tl: integer;
ti: LongWord;
begin
ResetLastError;
Result := '';
l := Length(Terminator);
if l = 0 then
Exit;
tl := l;
CorCRLF := FConvertLineEnd and (Terminator = CRLF);
s := '';
x := 0;
repeat
//get rest of FBuffer or incomming new data...
ti := GetTick;
s := s + RecvPacket(Timeout);
if FLastError <> 0 then
Break;
x := 0;
if Length(s) > 0 then
if CorCRLF then
begin
t := '';
x := PosCRLF(s, t);
tl := Length(t);
if t = CR then
FLastCR := True;
if t = LF then
FLastLF := True;
end
else
begin
x := pos(Terminator, s);
tl := l;
end;
if (FMaxLineLength <> 0) and (Length(s) > FMaxLineLength) then
begin
FLastError := WSAENOBUFS;
Break;
end;
if x > 0 then
Break;
if not FInterPacketTimeout then
begin
Timeout := Timeout - integer(TickDelta(ti, GetTick));
if Timeout <= 0 then
begin
FLastError := WSAETIMEDOUT;
Break;
end;
end;
until False;
if x > 0 then
begin
Result := Copy(s, 1, x - 1);
Delete(s, 1, x + tl - 1);
end;
FBuffer := s;
ExceptCheck;
end;
function TBlockSocket.RecvString(Timeout: Integer): AnsiString;
var
s: AnsiString;
begin
Result := '';
s := RecvTerminated(Timeout, CRLF);
if FLastError = 0 then
Result := s;
end;
function TBlockSocket.RecvBlock(Timeout: Integer): AnsiString;
var
x: integer;
begin
Result := '';
x := RecvInteger(Timeout);
if FLastError = 0 then
Result := RecvBufferStr(x, Timeout);
end;
procedure TBlockSocket.RecvStreamRaw(const Stream: TStream; Timeout: Integer);
var
s: AnsiString;
begin
repeat
s := RecvPacket(Timeout);
if FLastError = 0 then
WriteStrToStream(Stream, s);
until FLastError <> 0;
end;
procedure TBlockSocket.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer);
var
s: AnsiString;
n: integer;
{$IFDEF CIL}
buf: TMemory;
{$ENDIF}
begin
for n := 1 to (Size div FSendMaxChunk) do
begin
{$IFDEF CIL}
SetLength(buf, FSendMaxChunk);
RecvBufferEx(buf, FSendMaxChunk, Timeout);
if FLastError <> 0 then
Exit;
Stream.Write(buf, FSendMaxChunk);
{$ELSE}
s := RecvBufferStr(FSendMaxChunk, Timeout);
if FLastError <> 0 then
Exit;
WriteStrToStream(Stream, s);
{$ENDIF}
end;
n := Size mod FSendMaxChunk;
if n > 0 then
begin
{$IFDEF CIL}
SetLength(buf, n);
RecvBufferEx(buf, n, Timeout);
if FLastError <> 0 then
Exit;
Stream.Write(buf, n);
{$ELSE}
s := RecvBufferStr(n, Timeout);
if FLastError <> 0 then
Exit;
WriteStrToStream(Stream, s);
{$ENDIF}
end;
end;
procedure TBlockSocket.RecvStreamIndy(const Stream: TStream; Timeout: Integer);
var
x: integer;
begin
x := RecvInteger(Timeout);
x := synsock.NToHL(x);
if FLastError = 0 then
RecvStreamSize(Stream, Timeout, x);
end;
procedure TBlockSocket.RecvStream(const Stream: TStream; Timeout: Integer);
var
x: integer;
begin
x := RecvInteger(Timeout);
if FLastError = 0 then
RecvStreamSize(Stream, Timeout, x);
end;
function TBlockSocket.PeekBuffer(Buffer: TMemory; Length: Integer): Integer;
begin
{$IFNDEF CIL}
// Result := synsock.Recv(FSocket, Buffer^, Length, MSG_PEEK + MSG_NOSIGNAL);
Result := synsock.Recv(FSocket, Buffer, Length, MSG_PEEK + MSG_NOSIGNAL);
SockCheck(Result);
ExceptCheck;
{$ENDIF}
end;
function TBlockSocket.PeekByte(Timeout: Integer): Byte;
var
s: string;
begin
{$IFNDEF CIL}
Result := 0;
if CanRead(Timeout) then
begin
SetLength(s, 1);
PeekBuffer(Pointer(s), 1);
if s <> '' then
Result := Ord(s[1]);
end
else
FLastError := WSAETIMEDOUT;
ExceptCheck;
{$ENDIF}
end;
procedure TBlockSocket.ResetLastError;
begin
FLastError := 0;
FLastErrorDesc := '';
end;
function TBlockSocket.SockCheck(SockResult: Integer): Integer;
begin
ResetLastError;
if SockResult = integer(SOCKET_ERROR) then
begin
FLastError := synsock.WSAGetLastError;
FLastErrorDesc := GetErrorDescEx;
end;
Result := FLastError;
end;
procedure TBlockSocket.ExceptCheck;
var
e: ESynapseError;
begin
FLastErrorDesc := GetErrorDescEx;
if (LastError <> 0) and (LastError <> WSAEINPROGRESS)
and (LastError <> WSAEWOULDBLOCK) then
begin
DoStatus(HR_Error, IntToStr(FLastError) + ',' + FLastErrorDesc);
if FRaiseExcept then
begin
e := ESynapseError.Create(Format('Synapse TCP/IP Socket error %d: %s',
[FLastError, FLastErrorDesc]));
e.ErrorCode := FLastError;
e.ErrorMessage := FLastErrorDesc;
raise e;
end;
end;
end;
function TBlockSocket.WaitingData: Integer;
var
x: Integer;
begin
Result := 0;
if synsock.IoctlSocket(FSocket, FIONREAD, x) = 0 then
Result := x;
if Result > c64k then
Result := c64k;
end;
function TBlockSocket.WaitingDataEx: Integer;
begin
if FBuffer <> '' then
Result := Length(FBuffer)
else
Result := WaitingData;
end;
procedure TBlockSocket.Purge;
begin
Sleep(1);
try
while (Length(FBuffer) > 0) or (WaitingData > 0) do
begin
RecvPacket(0);
if FLastError <> 0 then
break;
end;
except
on exception do;
end;
ResetLastError;
end;
procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer);
var
d: TSynaOption;
begin
d := TSynaOption.Create;
d.Option := SOT_Linger;
d.Enabled := Enable;
d.Value := Linger;
DelayedOption(d);
end;
function TBlockSocket.LocalName: string;
begin
Result := synsock.GetHostName;
if Result = '' then
Result := '127.0.0.1';
end;
procedure TBlockSocket.ResolveNameToIP(Name: string; const IPList: TStrings);
begin
IPList.Clear;
synsock.ResolveNameToIP(Name, FamilyToAF(FFamily), GetSocketprotocol, GetSocketType, IPList);
if IPList.Count = 0 then
IPList.Add(cAnyHost);
end;
function TBlockSocket.ResolveName(Name: string): string;
var
l: TStringList;
begin
l := TStringList.Create;
try
ResolveNameToIP(Name, l);
Result := l[0];
finally
l.Free;
end;
end;
function TBlockSocket.ResolvePort(Port: string): Word;
begin
Result := synsock.ResolvePort(Port, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType);
end;
function TBlockSocket.ResolveIPToName(IP: string): string;
begin
if not IsIP(IP) or not IsIp6(IP) then
IP := ResolveName(IP);
Result := synsock.ResolveIPToName(IP, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType);
end;
procedure TBlockSocket.SetRemoteSin(IP, Port: string);
begin
SetSin(FRemoteSin, IP, Port);
end;
function TBlockSocket.GetLocalSinIP: string;
begin
Result := GetSinIP(FLocalSin);
end;
function TBlockSocket.GetRemoteSinIP: string;
begin
Result := GetSinIP(FRemoteSin);
end;
function TBlockSocket.GetLocalSinPort: Integer;
begin
Result := GetSinPort(FLocalSin);
end;
function TBlockSocket.GetRemoteSinPort: Integer;
begin
Result := GetSinPort(FRemoteSin);
end;
function TBlockSocket.InternalCanRead(Timeout: Integer): Boolean;
{$IFDEF CIL}
begin
Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectRead);
{$ELSE}
var
TimeVal: PTimeVal;
TimeV: TTimeVal;
x: Integer;
FDSet: TFDSet;
begin
TimeV.tv_usec := (Timeout mod 1000) * 1000;
TimeV.tv_sec := Timeout div 1000;
TimeVal := @TimeV;
if Timeout = -1 then
TimeVal := nil;
FDSet := FFdSet;
x := synsock.Select(FSocket + 1, @FDSet, nil, nil, TimeVal);
SockCheck(x);
if FLastError <> 0 then
x := 0;
Result := x > 0;
{$ENDIF}
end;
function TBlockSocket.CanRead(Timeout: Integer): Boolean;
var
ti, tr: Integer;
n: integer;
begin
if (FHeartbeatRate <> 0) and (Timeout <> -1) then
begin
ti := Timeout div FHeartbeatRate;
tr := Timeout mod FHeartbeatRate;
end
else
begin
ti := 0;
tr := Timeout;
end;
Result := InternalCanRead(tr);
if not Result then
for n := 0 to ti do
begin
DoHeartbeat;
if FStopFlag then
begin
Result := False;
FStopFlag := False;
Break;
end;
Result := InternalCanRead(FHeartbeatRate);
if Result then
break;
end;
ExceptCheck;
if Result then
DoStatus(HR_CanRead, '');
end;
function TBlockSocket.CanWrite(Timeout: Integer): Boolean;
{$IFDEF CIL}
begin
Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectWrite);
{$ELSE}
var
TimeVal: PTimeVal;
TimeV: TTimeVal;
x: Integer;
FDSet: TFDSet;
begin
TimeV.tv_usec := (Timeout mod 1000) * 1000;
TimeV.tv_sec := Timeout div 1000;
TimeVal := @TimeV;
if Timeout = -1 then
TimeVal := nil;
FDSet := FFdSet;
x := synsock.Select(FSocket + 1, nil, @FDSet, nil, TimeVal);
SockCheck(x);
if FLastError <> 0 then
x := 0;
Result := x > 0;
{$ENDIF}
ExceptCheck;
if Result then
DoStatus(HR_CanWrite, '');
end;
function TBlockSocket.CanReadEx(Timeout: Integer): Boolean;
begin
if FBuffer <> '' then
Result := True
else
Result := CanRead(Timeout);
end;
function TBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer;
begin
Result := 0;
if TestStopFlag then
Exit;
DoMonitor(True, Buffer, Length);
LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
Result := synsock.SendTo(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin);
SockCheck(Result);
ExceptCheck;
Inc(FSendCounter, Result);
DoStatus(HR_WriteCount, IntToStr(Result));
end;
function TBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer;
begin
Result := 0;
if TestStopFlag then
Exit;
LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
Result := synsock.RecvFrom(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin);
SockCheck(Result);
ExceptCheck;
Inc(FRecvCounter, Result);
DoStatus(HR_ReadCount, IntToStr(Result));
DoMonitor(False, Buffer, Result);
end;
function TBlockSocket.GetSizeRecvBuffer: Integer;
var
l: Integer;
{$IFDEF CIL}
buf: TMemory;
{$ENDIF}
begin
{$IFDEF CIL}
setlength(buf, 4);
SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF), buf, l));
Result := System.BitConverter.ToInt32(buf,0);
{$ELSE}
l := SizeOf(Result);
SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_RCVBUF, @Result, l));
if FLastError <> 0 then
Result := 1024;
ExceptCheck;
{$ENDIF}
end;
procedure TBlockSocket.SetSizeRecvBuffer(Size: Integer);
var
d: TSynaOption;
begin
d := TSynaOption.Create;
d.Option := SOT_RecvBuff;
d.Value := Size;
DelayedOption(d);
end;
function TBlockSocket.GetSizeSendBuffer: Integer;
var
l: Integer;
{$IFDEF CIL}
buf: TMemory;
{$ENDIF}
begin
{$IFDEF CIL}
setlength(buf, 4);
SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF), buf, l));
Result := System.BitConverter.ToInt32(buf,0);
{$ELSE}
l := SizeOf(Result);
SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_SNDBUF, @Result, l));
if FLastError <> 0 then
Result := 1024;
ExceptCheck;
{$ENDIF}
end;
procedure TBlockSocket.SetSizeSendBuffer(Size: Integer);
var
d: TSynaOption;
begin
d := TSynaOption.Create;
d.Option := SOT_SendBuff;
d.Value := Size;
DelayedOption(d);
end;
procedure TBlockSocket.SetNonBlockMode(Value: Boolean);
var
d: TSynaOption;
begin
d := TSynaOption.Create;
d.Option := SOT_nonblock;
d.Enabled := Value;
DelayedOption(d);
end;
procedure TBlockSocket.SetTimeout(Timeout: Integer);
begin
SetSendTimeout(Timeout);
SetRecvTimeout(Timeout);
end;
procedure TBlockSocket.SetSendTimeout(Timeout: Integer);
var
d: TSynaOption;
begin
d := TSynaOption.Create;
d.Option := SOT_sendtimeout;
d.Value := Timeout;
DelayedOption(d);
end;
procedure TBlockSocket.SetRecvTimeout(Timeout: Integer);
var
d: TSynaOption;
begin
d := TSynaOption.Create;
d.Option := SOT_recvtimeout;
d.Value := Timeout;
DelayedOption(d);
end;
{$IFNDEF CIL}
function TBlockSocket.GroupCanRead(const SocketList: TList; Timeout: Integer;
const CanReadList: TList): boolean;
var
FDSet: TFDSet;
TimeVal: PTimeVal;
TimeV: TTimeVal;
x, n: Integer;
Max: Integer;
begin
TimeV.tv_usec := (Timeout mod 1000) * 1000;
TimeV.tv_sec := Timeout div 1000;
TimeVal := @TimeV;
if Timeout = -1 then
TimeVal := nil;
FD_ZERO(FDSet);
Max := 0;
for n := 0 to SocketList.Count - 1 do
if TObject(SocketList.Items[n]) is TBlockSocket then
begin
if TBlockSocket(SocketList.Items[n]).Socket > Max then
Max := TBlockSocket(SocketList.Items[n]).Socket;
FD_SET(TBlockSocket(SocketList.Items[n]).Socket, FDSet);
end;
x := synsock.Select(Max + 1, @FDSet, nil, nil, TimeVal);
SockCheck(x);
ExceptCheck;
if FLastError <> 0 then
x := 0;
Result := x > 0;
CanReadList.Clear;
if Result then
for n := 0 to SocketList.Count - 1 do
if TObject(SocketList.Items[n]) is TBlockSocket then
if FD_ISSET(TBlockSocket(SocketList.Items[n]).Socket, FDSet) then
CanReadList.Add(TBlockSocket(SocketList.Items[n]));
end;
{$ENDIF}
procedure TBlockSocket.EnableReuse(Value: Boolean);
var
d: TSynaOption;
begin
d := TSynaOption.Create;
d.Option := SOT_reuse;
d.Enabled := Value;
DelayedOption(d);
end;
procedure TBlockSocket.SetTTL(TTL: integer);
var
d: TSynaOption;
begin
d := TSynaOption.Create;
d.Option := SOT_TTL;
d.Value := TTL;
DelayedOption(d);
end;
function TBlockSocket.GetTTL:integer;
var
l: Integer;
begin
{$IFNDEF CIL}
l := SizeOf(Result);
if FIP6Used then
synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_UNICAST_HOPS, @Result, l)
else
synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_TTL, @Result, l);
{$ENDIF}
end;
procedure TBlockSocket.SetFamily(Value: TSocketFamily);
begin
FFamily := Value;
FFamilySave := Value;
end;
procedure TBlockSocket.SetSocket(Value: TSocket);
begin
FRecvCounter := 0;
FSendCounter := 0;
FSocket := Value;
{$IFNDEF CIL}
FD_ZERO(FFDSet);
FD_SET(FSocket, FFDSet);
{$ENDIF}
GetSins;
FIP6Used := FRemoteSin.AddressFamily = AF_INET6;
end;
function TBlockSocket.GetWsaData: TWSAData;
begin
Result := WsaDataOnce;
end;
function TBlockSocket.GetSocketType: integer;
begin
Result := 0;
end;
function TBlockSocket.GetSocketProtocol: integer;
begin
Result := integer(IPPROTO_IP);
end;
procedure TBlockSocket.DoStatus(Reason: THookSocketReason; const Value: string);
begin
if assigned(OnStatus) then
OnStatus(Self, Reason, Value);
end;
procedure TBlockSocket.DoReadFilter(Buffer: TMemory; var Len: Integer);
var
s: AnsiString;
begin
if assigned(OnReadFilter) then
if Len > 0 then
begin
{$IFDEF CIL}
s := StringOf(Buffer);
{$ELSE}
SetLength(s, Len);
Move(Buffer^, Pointer(s)^, Len);
{$ENDIF}
OnReadFilter(Self, s);
if Length(s) > Len then
SetLength(s, Len);
Len := Length(s);
{$IFDEF CIL}
Buffer := BytesOf(s);
{$ELSE}
Move(Pointer(s)^, Buffer^, Len);
{$ENDIF}
end;
end;
procedure TBlockSocket.DoCreateSocket;
begin
if assigned(OnCreateSocket) then
OnCreateSocket(Self);
end;
procedure TBlockSocket.DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer);
begin
if assigned(OnMonitor) then
begin
OnMonitor(Self, Writing, Buffer, Len);
end;
end;
procedure TBlockSocket.DoHeartbeat;
begin
if assigned(OnHeartbeat) and (FHeartbeatRate <> 0) then
begin
OnHeartbeat(Self);
end;
end;
function TBlockSocket.GetErrorDescEx: string;
begin
Result := GetErrorDesc(FLastError);
end;
class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string;
begin
{$IFDEF CIL}
if ErrorCode = 0 then
Result := ''
else
begin
Result := WSAGetLastErrorDesc;
if Result = '' then
Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')';
end;
{$ELSE}
case ErrorCode of
0:
Result := '';
WSAEINTR: {10004}
Result := 'Interrupted system call';
WSAEBADF: {10009}
Result := 'Bad file number';
WSAEACCES: {10013}
Result := 'Permission denied';
WSAEFAULT: {10014}
Result := 'Bad address';
WSAEINVAL: {10022}
Result := 'Invalid argument';
WSAEMFILE: {10024}
Result := 'Too many open files';
WSAEWOULDBLOCK: {10035}
Result := 'Operation would block';
WSAEINPROGRESS: {10036}
Result := 'Operation now in progress';
WSAEALREADY: {10037}
Result := 'Operation already in progress';
WSAENOTSOCK: {10038}
Result := 'Socket operation on nonsocket';
WSAEDESTADDRREQ: {10039}
Result := 'Destination address required';
WSAEMSGSIZE: {10040}
Result := 'Message too long';
WSAEPROTOTYPE: {10041}
Result := 'Protocol wrong type for Socket';
WSAENOPROTOOPT: {10042}
Result := 'Protocol not available';
WSAEPROTONOSUPPORT: {10043}
Result := 'Protocol not supported';
WSAESOCKTNOSUPPORT: {10044}
Result := 'Socket not supported';
WSAEOPNOTSUPP: {10045}
Result := 'Operation not supported on Socket';
WSAEPFNOSUPPORT: {10046}
Result := 'Protocol family not supported';
WSAEAFNOSUPPORT: {10047}
Result := 'Address family not supported';
WSAEADDRINUSE: {10048}
Result := 'Address already in use';
WSAEADDRNOTAVAIL: {10049}
Result := 'Can''t assign requested address';
WSAENETDOWN: {10050}
Result := 'Network is down';
WSAENETUNREACH: {10051}
Result := 'Network is unreachable';
WSAENETRESET: {10052}
Result := 'Network dropped connection on reset';
WSAECONNABORTED: {10053}
Result := 'Software caused connection abort';
WSAECONNRESET: {10054}
Result := 'Connection reset by peer';
WSAENOBUFS: {10055}
Result := 'No Buffer space available';
WSAEISCONN: {10056}
Result := 'Socket is already connected';
WSAENOTCONN: {10057}
Result := 'Socket is not connected';
WSAESHUTDOWN: {10058}
Result := 'Can''t send after Socket shutdown';
WSAETOOMANYREFS: {10059}
Result := 'Too many references:can''t splice';
WSAETIMEDOUT: {10060}
Result := 'Connection timed out';
WSAECONNREFUSED: {10061}
Result := 'Connection refused';
WSAELOOP: {10062}
Result := 'Too many levels of symbolic links';
WSAENAMETOOLONG: {10063}
Result := 'File name is too long';
WSAEHOSTDOWN: {10064}
Result := 'Host is down';
WSAEHOSTUNREACH: {10065}
Result := 'No route to host';
WSAENOTEMPTY: {10066}
Result := 'Directory is not empty';
WSAEPROCLIM: {10067}
Result := 'Too many processes';
WSAEUSERS: {10068}
Result := 'Too many users';
WSAEDQUOT: {10069}
Result := 'Disk quota exceeded';
WSAESTALE: {10070}
Result := 'Stale NFS file handle';
WSAEREMOTE: {10071}
Result := 'Too many levels of remote in path';
WSASYSNOTREADY: {10091}
Result := 'Network subsystem is unusable';
WSAVERNOTSUPPORTED: {10092}
Result := 'Winsock DLL cannot support this application';
WSANOTINITIALISED: {10093}
Result := 'Winsock not initialized';
WSAEDISCON: {10101}
Result := 'Disconnect';
WSAHOST_NOT_FOUND: {11001}
Result := 'Host not found';
WSATRY_AGAIN: {11002}
Result := 'Non authoritative - host not found';
WSANO_RECOVERY: {11003}
Result := 'Non recoverable error';
WSANO_DATA: {11004}
Result := 'Valid name, no data record of requested type'
else
Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')';
end;
{$ENDIF}
end;
{======================================================================}
constructor TSocksBlockSocket.Create;
begin
inherited Create;
FSocksIP:= '';
FSocksPort:= '1080';
FSocksTimeout:= 60000;
FSocksUsername:= '';
FSocksPassword:= '';
FUsingSocks := False;
FSocksResolver := True;
FSocksLastError := 0;
FSocksResponseIP := '';
FSocksResponsePort := '';
FSocksLocalIP := '';
FSocksLocalPort := '';
FSocksRemoteIP := '';
FSocksRemotePort := '';
FBypassFlag := False;
FSocksType := ST_Socks5;
end;
function TSocksBlockSocket.SocksOpen: boolean;
var
Buf: AnsiString;
n: integer;
begin
Result := False;
FUsingSocks := False;
if FSocksType <> ST_Socks5 then
begin
FUsingSocks := True;
Result := True;
end
else
begin
FBypassFlag := True;
try
if FSocksUsername = '' then
Buf := #5 + #1 + #0
else
Buf := #5 + #2 + #2 +#0;
SendString(Buf);
Buf := RecvBufferStr(2, FSocksTimeout);
if Length(Buf) < 2 then
Exit;
if Buf[1] <> #5 then
Exit;
n := Ord(Buf[2]);
case n of
0: //not need authorisation
;
2:
begin
Buf := #1 + AnsiChar(Length(FSocksUsername)) + FSocksUsername
+ AnsiChar(Length(FSocksPassword)) + FSocksPassword;
SendString(Buf);
Buf := RecvBufferStr(2, FSocksTimeout);
if Length(Buf) < 2 then
Exit;
if Buf[2] <> #0 then
Exit;
end;
else
//other authorisation is not supported!
Exit;
end;
FUsingSocks := True;
Result := True;
finally
FBypassFlag := False;
end;
end;
end;
function TSocksBlockSocket.SocksRequest(Cmd: Byte;
const IP, Port: string): Boolean;
var
Buf: AnsiString;
begin
FBypassFlag := True;
try
if FSocksType <> ST_Socks5 then
Buf := #4 + AnsiChar(Cmd) + SocksCode(IP, Port)
else
Buf := #5 + AnsiChar(Cmd) + #0 + SocksCode(IP, Port);
SendString(Buf);
Result := FLastError = 0;
finally
FBypassFlag := False;
end;
end;
function TSocksBlockSocket.SocksResponse: Boolean;
var
Buf, s: AnsiString;
x: integer;
begin
Result := False;
FBypassFlag := True;
try
FSocksResponseIP := '';
FSocksResponsePort := '';
FSocksLastError := -1;
if FSocksType <> ST_Socks5 then
begin
Buf := RecvBufferStr(8, FSocksTimeout);
if FLastError <> 0 then
Exit;
if Buf[1] <> #0 then
Exit;
FSocksLastError := Ord(Buf[2]);
end
else
begin
Buf := RecvBufferStr(4, FSocksTimeout);
if FLastError <> 0 then
Exit;
if Buf[1] <> #5 then
Exit;
case Ord(Buf[4]) of
1:
s := RecvBufferStr(4, FSocksTimeout);
3:
begin
x := RecvByte(FSocksTimeout);
if FLastError <> 0 then
Exit;
s := AnsiChar(x) + RecvBufferStr(x, FSocksTimeout);
end;
4:
s := RecvBufferStr(16, FSocksTimeout);
else
Exit;
end;
Buf := Buf + s + RecvBufferStr(2, FSocksTimeout);
if FLastError <> 0 then
Exit;
FSocksLastError := Ord(Buf[2]);
end;
if ((FSocksLastError <> 0) and (FSocksLastError <> 90)) then
Exit;
SocksDecode(Buf);
Result := True;
finally
FBypassFlag := False;
end;
end;
function TSocksBlockSocket.SocksCode(IP, Port: string): Ansistring;
var
ip6: TIp6Bytes;
n: integer;
begin
if FSocksType <> ST_Socks5 then
begin
Result := CodeInt(ResolvePort(Port));
if not FSocksResolver then
IP := ResolveName(IP);
if IsIP(IP) then
begin
Result := Result + IPToID(IP);
Result := Result + FSocksUsername + #0;
end
else
begin
Result := Result + IPToID('0.0.0.1');
Result := Result + FSocksUsername + #0;
Result := Result + IP + #0;
end;
end
else
begin
if not FSocksResolver then
IP := ResolveName(IP);
if IsIP(IP) then
Result := #1 + IPToID(IP)
else
if IsIP6(IP) then
begin
ip6 := StrToIP6(IP);
Result := #4;
for n := 0 to 15 do
Result := Result + AnsiChar(ip6[n]);
end
else
Result := #3 + AnsiChar(Length(IP)) + IP;
Result := Result + CodeInt(ResolvePort(Port));
end;
end;
function TSocksBlockSocket.SocksDecode(Value: Ansistring): integer;
var
Atyp: Byte;
y, n: integer;
w: Word;
ip6: TIp6Bytes;
begin
FSocksResponsePort := '0';
Result := 0;
if FSocksType <> ST_Socks5 then
begin
if Length(Value) < 8 then
Exit;
Result := 3;
w := DecodeInt(Value, Result);
FSocksResponsePort := IntToStr(w);
FSocksResponseIP := Format('%d.%d.%d.%d',
[Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]);
Result := 9;
end
else
begin
if Length(Value) < 4 then
Exit;
Atyp := Ord(Value[4]);
Result := 5;
case Atyp of
1:
begin
if Length(Value) < 10 then
Exit;
FSocksResponseIP := Format('%d.%d.%d.%d',
[Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]);
Result := 9;
end;
3:
begin
y := Ord(Value[5]);
if Length(Value) < (5 + y + 2) then
Exit;
for n := 6 to 6 + y - 1 do
FSocksResponseIP := FSocksResponseIP + Value[n];
Result := 5 + y + 1;
end;
4:
begin
if Length(Value) < 22 then
Exit;
for n := 0 to 15 do
ip6[n] := ord(Value[n + 5]);
FSocksResponseIP := IP6ToStr(ip6);
Result := 21;
end;
else
Exit;
end;
w := DecodeInt(Value, Result);
FSocksResponsePort := IntToStr(w);
Result := Result + 2;
end;
end;
{======================================================================}
procedure TDgramBlockSocket.Connect(IP, Port: string);
begin
SetRemoteSin(IP, Port);
InternalCreateSocket(FRemoteSin);
FBuffer := '';
DoStatus(HR_Connect, IP + ':' + Port);
end;
function TDgramBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer;
begin
Result := RecvBufferFrom(Buffer, Length);
end;
function TDgramBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer;
begin
Result := SendBufferTo(Buffer, Length);
end;
{======================================================================}
destructor TUDPBlockSocket.Destroy;
begin
if Assigned(FSocksControlSock) then
FSocksControlSock.Free;
inherited;
end;
procedure TUDPBlockSocket.EnableBroadcast(Value: Boolean);
var
d: TSynaOption;
begin
d := TSynaOption.Create;
d.Option := SOT_Broadcast;
d.Enabled := Value;
DelayedOption(d);
end;
function TUDPBlockSocket.UdpAssociation: Boolean;
var
b: Boolean;
begin
Result := True;
FUsingSocks := False;
if FSocksIP <> '' then
begin
Result := False;
if not Assigned(FSocksControlSock) then
FSocksControlSock := TTCPBlockSocket.Create;
FSocksControlSock.CloseSocket;
FSocksControlSock.CreateSocketByName(FSocksIP);
FSocksControlSock.Connect(FSocksIP, FSocksPort);
if FSocksControlSock.LastError <> 0 then
Exit;
// if not assigned local port, assign it!
if not FBinded then
Bind(cAnyHost, cAnyPort);
//open control TCP connection to SOCKS
FSocksControlSock.FSocksUsername := FSocksUsername;
FSocksControlSock.FSocksPassword := FSocksPassword;
b := FSocksControlSock.SocksOpen;
if b then
b := FSocksControlSock.SocksRequest(3, GetLocalSinIP, IntToStr(GetLocalSinPort));
if b then
b := FSocksControlSock.SocksResponse;
if not b and (FLastError = 0) then
FLastError := WSANO_RECOVERY;
FUsingSocks :=FSocksControlSock.UsingSocks;
FSocksRemoteIP := FSocksControlSock.FSocksResponseIP;
FSocksRemotePort := FSocksControlSock.FSocksResponsePort;
Result := b and (FLastError = 0);
end;
end;
function TUDPBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer;
var
SIp: string;
SPort: integer;
Buf: Ansistring;
begin
Result := 0;
FUsingSocks := False;
if (FSocksIP <> '') and (not UdpAssociation) then
FLastError := WSANO_RECOVERY
else
begin
if FUsingSocks then
begin
{$IFNDEF CIL}
Sip := GetRemoteSinIp;
SPort := GetRemoteSinPort;
SetRemoteSin(FSocksRemoteIP, FSocksRemotePort);
SetLength(Buf,Length);
Move(Buffer^, Pointer(Buf)^, Length);
Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf;
Result := inherited SendBufferTo(Pointer(Buf), System.Length(buf));
SetRemoteSin(Sip, IntToStr(SPort));
{$ENDIF}
end
else
Result := inherited SendBufferTo(Buffer, Length);
end;
end;
function TUDPBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer;
var
Buf: Ansistring;
x: integer;
begin
Result := inherited RecvBufferFrom(Buffer, Length);
if FUsingSocks then
begin
{$IFNDEF CIL}
SetLength(Buf, Result);
Move(Buffer^, Pointer(Buf)^, Result);
x := SocksDecode(Buf);
Result := Result - x + 1;
Buf := Copy(Buf, x, Result);
Move(Pointer(Buf)^, Buffer^, Result);
SetRemoteSin(FSocksResponseIP, FSocksResponsePort);
{$ENDIF}
end;
end;
{$IFNDEF CIL}
procedure TUDPBlockSocket.AddMulticast(MCastIP: string);
var
Multicast: TIP_mreq;
Multicast6: TIPv6_mreq;
n: integer;
ip6: Tip6bytes;
begin
if FIP6Used then
begin
ip6 := StrToIp6(MCastIP);
for n := 0 to 15 do
Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n];
Multicast6.ipv6mr_interface := 0;
SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_JOIN_GROUP,
PAnsiChar(@Multicast6), SizeOf(Multicast6)));
end
else
begin
Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP));
Multicast.imr_interface.S_addr := INADDR_ANY;
SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_ADD_MEMBERSHIP,
PAnsiChar(@Multicast), SizeOf(Multicast)));
end;
ExceptCheck;
end;
procedure TUDPBlockSocket.DropMulticast(MCastIP: string);
var
Multicast: TIP_mreq;
Multicast6: TIPv6_mreq;
n: integer;
ip6: Tip6bytes;
begin
if FIP6Used then
begin
ip6 := StrToIp6(MCastIP);
for n := 0 to 15 do
Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n];
Multicast6.ipv6mr_interface := 0;
SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_LEAVE_GROUP,
PAnsiChar(@Multicast6), SizeOf(Multicast6)));
end
else
begin
Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP));
Multicast.imr_interface.S_addr := INADDR_ANY;
SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_DROP_MEMBERSHIP,
PAnsiChar(@Multicast), SizeOf(Multicast)));
end;
ExceptCheck;
end;
{$ENDIF}
procedure TUDPBlockSocket.SetMulticastTTL(TTL: integer);
var
d: TSynaOption;
begin
d := TSynaOption.Create;
d.Option := SOT_MulticastTTL;
d.Value := TTL;
DelayedOption(d);
end;
function TUDPBlockSocket.GetMulticastTTL:integer;
var
l: Integer;
begin
{$IFNDEF CIL}
l := SizeOf(Result);
if FIP6Used then
synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_MULTICAST_HOPS, @Result, l)
else
synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, @Result, l);
{$ENDIF}
end;
procedure TUDPBlockSocket.EnableMulticastLoop(Value: Boolean);
var
d: TSynaOption;
begin
d := TSynaOption.Create;
d.Option := SOT_MulticastLoop;
d.Enabled := Value;
DelayedOption(d);
end;
function TUDPBlockSocket.GetSocketType: integer;
begin
Result := integer(SOCK_DGRAM);
end;
function TUDPBlockSocket.GetSocketProtocol: integer;
begin
Result := integer(IPPROTO_UDP);
end;
{======================================================================}
constructor TTCPBlockSocket.CreateWithSSL(SSLPlugin: TSSLClass);
begin
inherited Create;
FSSL := SSLPlugin.Create(self);
FHTTPTunnelIP := '';
FHTTPTunnelPort := '';
FHTTPTunnel := False;
FHTTPTunnelRemoteIP := '';
FHTTPTunnelRemotePort := '';
FHTTPTunnelUser := '';
FHTTPTunnelPass := '';
FHTTPTunnelTimeout := 30000;
end;
constructor TTCPBlockSocket.Create;
begin
CreateWithSSL(SSLImplementation);
end;
destructor TTCPBlockSocket.Destroy;
begin
inherited Destroy;
FSSL.Free;
end;
function TTCPBlockSocket.GetErrorDescEx: string;
begin
Result := inherited GetErrorDescEx;
if (FLastError = WSASYSNOTREADY) and (self.SSL.LastError <> 0) then
begin
Result := self.SSL.LastErrorDesc;
end;
end;
procedure TTCPBlockSocket.CloseSocket;
begin
if FSSL.SSLEnabled then
FSSL.Shutdown;
if (FSocket <> INVALID_SOCKET) and (FLastError = 0) then
begin
Synsock.Shutdown(FSocket, 1);
Purge;
end;
inherited CloseSocket;
end;
procedure TTCPBlockSocket.DoAfterConnect;
begin
if assigned(OnAfterConnect) then
begin
OnAfterConnect(Self);
end;
end;
function TTCPBlockSocket.WaitingData: Integer;
begin
Result := 0;
if FSSL.SSLEnabled and (FSocket <> INVALID_SOCKET) then
Result := FSSL.WaitingData;
if Result = 0 then
Result := inherited WaitingData;
end;
procedure TTCPBlockSocket.Listen;
var
b: Boolean;
Sip,SPort: string;
begin
if FSocksIP = '' then
begin
inherited Listen;
end
else
begin
Sip := GetLocalSinIP;
if Sip = cAnyHost then
Sip := LocalName;
SPort := IntToStr(GetLocalSinPort);
inherited Connect(FSocksIP, FSocksPort);
b := SocksOpen;
if b then
b := SocksRequest(2, Sip, SPort);
if b then
b := SocksResponse;
if not b and (FLastError = 0) then
FLastError := WSANO_RECOVERY;
FSocksLocalIP := FSocksResponseIP;
if FSocksLocalIP = cAnyHost then
FSocksLocalIP := FSocksIP;
FSocksLocalPort := FSocksResponsePort;
FSocksRemoteIP := '';
FSocksRemotePort := '';
ExceptCheck;
DoStatus(HR_Listen, '');
end;
end;
function TTCPBlockSocket.Accept: TSocket;
begin
if FUsingSocks then
begin
if not SocksResponse and (FLastError = 0) then
FLastError := WSANO_RECOVERY;
FSocksRemoteIP := FSocksResponseIP;
FSocksRemotePort := FSocksResponsePort;
Result := FSocket;
ExceptCheck;
DoStatus(HR_Accept, '');
end
else
begin
result := inherited Accept;
end;
end;
procedure TTCPBlockSocket.Connect(IP, Port: string);
begin
if FSocksIP <> '' then
SocksDoConnect(IP, Port)
else
if FHTTPTunnelIP <> '' then
HTTPTunnelDoConnect(IP, Port)
else
inherited Connect(IP, Port);
if FLasterror = 0 then
DoAfterConnect;
end;
procedure TTCPBlockSocket.SocksDoConnect(IP, Port: string);
var
b: Boolean;
begin
inherited Connect(FSocksIP, FSocksPort);
if FLastError = 0 then
begin
b := SocksOpen;
if b then
b := SocksRequest(1, IP, Port);
if b then
b := SocksResponse;
if not b and (FLastError = 0) then
FLastError := WSASYSNOTREADY;
FSocksLocalIP := FSocksResponseIP;
FSocksLocalPort := FSocksResponsePort;
FSocksRemoteIP := IP;
FSocksRemotePort := Port;
end;
ExceptCheck;
DoStatus(HR_Connect, IP + ':' + Port);
end;
procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string);
//bugfixed by Mike Green (mgreen@emixode.com)
var
s: string;
begin
Port := IntToStr(ResolvePort(Port));
inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort);
if FLastError <> 0 then
Exit;
FHTTPTunnel := False;
if IsIP6(IP) then
IP := '[' + IP + ']';
SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + CRLF);
if FHTTPTunnelUser <> '' then
Sendstring('Proxy-Authorization: Basic ' +
EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + CRLF);
SendString(CRLF);
repeat
s := RecvTerminated(FHTTPTunnelTimeout, #$0a);
if FLastError <> 0 then
Break;
if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then
FHTTPTunnel := s[10] = '2';
until (s = '') or (s = #$0d);
if (FLasterror = 0) and not FHTTPTunnel then
FLastError := WSASYSNOTREADY;
FHTTPTunnelRemoteIP := IP;
FHTTPTunnelRemotePort := Port;
ExceptCheck;
end;
procedure TTCPBlockSocket.SSLDoConnect;
begin
ResetLastError;
if not FSSL.Connect then
FLastError := WSASYSNOTREADY;
ExceptCheck;
end;
procedure TTCPBlockSocket.SSLDoShutdown;
begin
ResetLastError;
FSSL.BiShutdown;
end;
function TTCPBlockSocket.GetLocalSinIP: string;
begin
if FUsingSocks then
Result := FSocksLocalIP
else
Result := inherited GetLocalSinIP;
end;
function TTCPBlockSocket.GetRemoteSinIP: string;
begin
if FUsingSocks then
Result := FSocksRemoteIP
else
if FHTTPTunnel then
Result := FHTTPTunnelRemoteIP
else
Result := inherited GetRemoteSinIP;
end;
function TTCPBlockSocket.GetLocalSinPort: Integer;
begin
if FUsingSocks then
Result := StrToIntDef(FSocksLocalPort, 0)
else
Result := inherited GetLocalSinPort;
end;
function TTCPBlockSocket.GetRemoteSinPort: Integer;
begin
if FUsingSocks then
Result := ResolvePort(FSocksRemotePort)
else
if FHTTPTunnel then
Result := StrToIntDef(FHTTPTunnelRemotePort, 0)
else
Result := inherited GetRemoteSinPort;
end;
function TTCPBlockSocket.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
begin
if FSSL.SSLEnabled then
begin
Result := 0;
if TestStopFlag then
Exit;
ResetLastError;
LimitBandwidth(Len, FMaxRecvBandwidth, FNextRecv);
Result := FSSL.RecvBuffer(Buffer, Len);
if FSSL.LastError <> 0 then
FLastError := WSASYSNOTREADY;
ExceptCheck;
Inc(FRecvCounter, Result);
DoStatus(HR_ReadCount, IntToStr(Result));
DoMonitor(False, Buffer, Result);
DoReadFilter(Buffer, Result);
end
else
Result := inherited RecvBuffer(Buffer, Len);
end;
function TTCPBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer;
var
x, y: integer;
l, r: integer;
{$IFNDEF CIL}
p: Pointer;
{$ENDIF}
begin
if FSSL.SSLEnabled then
begin
Result := 0;
if TestStopFlag then
Exit;
ResetLastError;
DoMonitor(True, Buffer, Length);
{$IFDEF CIL}
Result := FSSL.SendBuffer(Buffer, Length);
if FSSL.LastError <> 0 then
FLastError := WSASYSNOTREADY;
Inc(FSendCounter, Result);
DoStatus(HR_WriteCount, IntToStr(Result));
{$ELSE}
l := Length;
x := 0;
while x < l do
begin
y := l - x;
if y > FSendMaxChunk then
y := FSendMaxChunk;
if y > 0 then
begin
LimitBandwidth(y, FMaxSendBandwidth, FNextsend);
p := IncPoint(Buffer, x);
r := FSSL.SendBuffer(p, y);
if FSSL.LastError <> 0 then
FLastError := WSASYSNOTREADY;
if Flasterror <> 0 then
Break;
Inc(x, r);
Inc(Result, r);
Inc(FSendCounter, r);
DoStatus(HR_WriteCount, IntToStr(r));
end
else
break;
end;
{$ENDIF}
ExceptCheck;
end
else
Result := inherited SendBuffer(Buffer, Length);
end;
function TTCPBlockSocket.SSLAcceptConnection: Boolean;
begin
ResetLastError;
if not FSSL.Accept then
FLastError := WSASYSNOTREADY;
ExceptCheck;
Result := FLastError = 0;
end;
function TTCPBlockSocket.GetSocketType: integer;
begin
Result := integer(SOCK_STREAM);
end;
function TTCPBlockSocket.GetSocketProtocol: integer;
begin
Result := integer(IPPROTO_TCP);
end;
{======================================================================}
function TICMPBlockSocket.GetSocketType: integer;
begin
Result := integer(SOCK_RAW);
end;
function TICMPBlockSocket.GetSocketProtocol: integer;
begin
if FIP6Used then
Result := integer(IPPROTO_ICMPV6)
else
Result := integer(IPPROTO_ICMP);
end;
{======================================================================}
function TRAWBlockSocket.GetSocketType: integer;
begin
Result := integer(SOCK_RAW);
end;
function TRAWBlockSocket.GetSocketProtocol: integer;
begin
Result := integer(IPPROTO_RAW);
end;
{======================================================================}
function TPGMmessageBlockSocket.GetSocketType: integer;
begin
Result := integer(SOCK_RDM);
end;
function TPGMmessageBlockSocket.GetSocketProtocol: integer;
begin
Result := integer(IPPROTO_RM);
end;
{======================================================================}
function TPGMstreamBlockSocket.GetSocketType: integer;
begin
Result := integer(SOCK_STREAM);
end;
function TPGMstreamBlockSocket.GetSocketProtocol: integer;
begin
Result := integer(IPPROTO_RM);
end;
{======================================================================}
constructor TSynaClient.Create;
begin
inherited Create;
FIPInterface := cAnyHost;
FTargetHost := cLocalhost;
FTargetPort := cAnyPort;
FTimeout := 5000;
FUsername := '';
FPassword := '';
end;
{======================================================================}
constructor TCustomSSL.Create(const Value: TTCPBlockSocket);
begin
inherited Create;
FSocket := Value;
FSSLEnabled := False;
FUsername := '';
FPassword := '';
FLastError := 0;
FLastErrorDesc := '';
FVerifyCert := False;
FSSLType := LT_all;
FKeyPassword := '';
FCiphers := '';
FCertificateFile := '';
FPrivateKeyFile := '';
FCertCAFile := '';
FCertCA := '';
FTrustCertificate := '';
FTrustCertificateFile := '';
FCertificate := '';
FPrivateKey := '';
FPFX := '';
FPFXfile := '';
FSSHChannelType := '';
FSSHChannelArg1 := '';
FSSHChannelArg2 := '';
end;
procedure TCustomSSL.Assign(const Value: TCustomSSL);
begin
FUsername := Value.Username;
FPassword := Value.Password;
FVerifyCert := Value.VerifyCert;
FSSLType := Value.SSLType;
FKeyPassword := Value.KeyPassword;
FCiphers := Value.Ciphers;
FCertificateFile := Value.CertificateFile;
FPrivateKeyFile := Value.PrivateKeyFile;
FCertCAFile := Value.CertCAFile;
FCertCA := Value.CertCA;
FTrustCertificate := Value.TrustCertificate;
FTrustCertificateFile := Value.TrustCertificateFile;
FCertificate := Value.Certificate;
FPrivateKey := Value.PrivateKey;
FPFX := Value.PFX;
FPFXfile := Value.PFXfile;
end;
procedure TCustomSSL.ReturnError;
begin
FLastError := -1;
FLastErrorDesc := 'SSL/TLS support is not compiled!';
end;
function TCustomSSL.LibVersion: String;
begin
Result := '';
end;
function TCustomSSL.LibName: String;
begin
Result := '';
end;
function TCustomSSL.CreateSelfSignedCert(Host: string): Boolean;
begin
Result := False;
end;
function TCustomSSL.Connect: boolean;
begin
ReturnError;
Result := False;
end;
function TCustomSSL.Accept: boolean;
begin
ReturnError;
Result := False;
end;
function TCustomSSL.Shutdown: boolean;
begin
ReturnError;
Result := False;
end;
function TCustomSSL.BiShutdown: boolean;
begin
ReturnError;
Result := False;
end;
function TCustomSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
begin
ReturnError;
Result := integer(SOCKET_ERROR);
end;
function TCustomSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
begin
ReturnError;
Result := integer(SOCKET_ERROR);
end;
function TCustomSSL.WaitingData: Integer;
begin
ReturnError;
Result := 0;
end;
function TCustomSSL.GetSSLVersion: string;
begin
Result := '';
end;
function TCustomSSL.GetPeerSubject: string;
begin
Result := '';
end;
function TCustomSSL.GetPeerName: string;
begin
Result := '';
end;
function TCustomSSL.GetPeerIssuer: string;
begin
Result := '';
end;
function TCustomSSL.GetPeerFingerprint: string;
begin
Result := '';
end;
function TCustomSSL.GetCertInfo: string;
begin
Result := '';
end;
function TCustomSSL.GetCipherName: string;
begin
Result := '';
end;
function TCustomSSL.GetCipherBits: integer;
begin
Result := 0;
end;
function TCustomSSL.GetCipherAlgBits: integer;
begin
Result := 0;
end;
function TCustomSSL.GetVerifyCert: integer;
begin
Result := 1;
end;
{======================================================================}
function TSSLNone.LibVersion: String;
begin
Result := 'Without SSL support';
end;
function TSSLNone.LibName: String;
begin
Result := 'ssl_none';
end;
{======================================================================}
{$IFDEF ONCEWINSOCK}
initialization
begin
if not InitSocketInterface(DLLStackName) then
begin
e := ESynapseError.Create('Error loading Socket interface (' + DLLStackName + ')!');
e.ErrorCode := 0;
e.ErrorMessage := 'Error loading Socket interface (' + DLLStackName + ')!';
raise e;
end;
synsock.WSAStartup(WinsockLevel, WsaDataOnce);
end;
{$ENDIF}
finalization
begin
{$IFDEF ONCEWINSOCK}
synsock.WSACleanup;
DestroySocketInterface;
{$ENDIF}
end;
end.
TransGUI/synapse/source/lib/pop3send.pas 0000644 0000000 0000000 00000035423 11366572451 017221 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 002.006.002 |
|==============================================================================|
| Content: POP3 client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(POP3 protocol client)
Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$M+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit pop3send;
interface
uses
SysUtils, Classes,
blcksock, synautil, synacode;
const
cPop3Protocol = '110';
type
{:The three types of possible authorization methods for "logging in" to a POP3
server.}
TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP);
{:@abstract(Implementation of POP3 client protocol.)
Note: Are you missing properties for setting Username and Password? Look to
parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TPOP3Send = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FResultCode: Integer;
FResultString: string;
FFullResult: TStringList;
FStatCount: Integer;
FStatSize: Integer;
FListSize: Integer;
FTimeStamp: string;
FAuthType: TPOP3AuthType;
FPOP3cap: TStringList;
FAutoTLS: Boolean;
FFullSSL: Boolean;
function ReadResult(Full: Boolean): Integer;
function Connect: Boolean;
function AuthLogin: Boolean;
function AuthApop: Boolean;
public
constructor Create;
destructor Destroy; override;
{:You can call any custom by this method. Call Command without trailing CRLF.
If MultiLine parameter is @true, multilined response are expected.
Result is @true on sucess.}
function CustomCommand(const Command: string; MultiLine: Boolean): boolean;
{:Call CAPA command for get POP3 server capabilites.
note: not all servers support this command!}
function Capability: Boolean;
{:Connect to remote POP3 host. If all OK, result is @true.}
function Login: Boolean;
{:Disconnects from POP3 server.}
function Logout: Boolean;
{:Send RSET command. If all OK, result is @true.}
function Reset: Boolean;
{:Send NOOP command. If all OK, result is @true.}
function NoOp: Boolean;
{:Send STAT command and fill @link(StatCount) and @link(StatSize) property.
If all OK, result is @true.}
function Stat: Boolean;
{:Send LIST command. If Value is 0, LIST is for all messages. After
successful operation is listing in FullResult. If all OK, result is @True.}
function List(Value: Integer): Boolean;
{:Send RETR command. After successful operation dowloaded message in
@link(FullResult). If all OK, result is @true.}
function Retr(Value: Integer): Boolean;
{:Send RETR command. After successful operation dowloaded message in
@link(Stream). If all OK, result is @true.}
function RetrStream(Value: Integer; Stream: TStream): Boolean;
{:Send DELE command for delete specified message. If all OK, result is @true.}
function Dele(Value: Integer): Boolean;
{:Send TOP command. After successful operation dowloaded headers of message
and maxlines count of message in @link(FullResult). If all OK, result is
@true.}
function Top(Value, Maxlines: Integer): Boolean;
{:Send UIDL command. If Value is 0, UIDL is for all messages. After
successful operation is listing in FullResult. If all OK, result is @True.}
function Uidl(Value: Integer): Boolean;
{:Call STLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean;
{:Try to find given capabily in capabilty string returned from POP3 server
by CAPA command.}
function FindCap(const Value: string): string;
published
{:Result code of last POP3 operation. 0 - error, 1 - OK.}
property ResultCode: Integer read FResultCode;
{:Result string of last POP3 operation.}
property ResultString: string read FResultString;
{:Stringlist with full lines returned as result of POP3 operation. I.e. if
operation is LIST, this property is filled by list of messages. If
operation is RETR, this property have downloaded message.}
property FullResult: TStringList read FFullResult;
{:After STAT command is there count of messages in inbox.}
property StatCount: Integer read FStatCount;
{:After STAT command is there size of all messages in inbox.}
property StatSize: Integer read FStatSize;
{:After LIST 0 command size of all messages on server, After LIST x size of message x on server}
property ListSize: Integer read FListSize;
{:If server support this, after comnnect is in this property timestamp of
remote server.}
property TimeStamp: string read FTimeStamp;
{:Type of authorisation for login to POP3 server. Dafault is autodetect one
of possible authorisation. Autodetect do this:
If remote POP3 server support APOP, try login by APOP method. If APOP is
not supported, or if APOP login failed, try classic USER+PASS login method.}
property AuthType: TPOP3AuthType read FAuthType Write FAuthType;
{:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
end;
implementation
constructor TPOP3Send.Create;
begin
inherited Create;
FFullResult := TStringList.Create;
FPOP3cap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := true;
FTimeout := 60000;
FTargetPort := cPop3Protocol;
FStatCount := 0;
FStatSize := 0;
FListSize := 0;
FAuthType := POP3AuthAll;
FAutoTLS := False;
FFullSSL := False;
end;
destructor TPOP3Send.Destroy;
begin
FSock.Free;
FPOP3cap.Free;
FullResult.Free;
inherited Destroy;
end;
function TPOP3Send.ReadResult(Full: Boolean): Integer;
var
s: AnsiString;
begin
Result := 0;
FFullResult.Clear;
s := FSock.RecvString(FTimeout);
if Pos('+OK', s) = 1 then
Result := 1;
FResultString := s;
if Full and (Result = 1) then
repeat
s := FSock.RecvString(FTimeout);
if s = '.' then
Break;
if s <> '' then
if s[1] = '.' then
Delete(s, 1, 1);
FFullResult.Add(s);
until FSock.LastError <> 0;
if not Full and (Result = 1) then
FFullResult.Add(SeparateRight(FResultString, ' '));
if FSock.LastError <> 0 then
Result := 0;
FResultCode := Result;
end;
function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean;
begin
FSock.SendString(Command + CRLF);
Result := ReadResult(MultiLine) <> 0;
end;
function TPOP3Send.AuthLogin: Boolean;
begin
Result := False;
if not CustomCommand('USER ' + FUserName, False) then
exit;
Result := CustomCommand('PASS ' + FPassword, False)
end;
function TPOP3Send.AuthAPOP: Boolean;
var
s: string;
begin
s := StrToHex(MD5(FTimeStamp + FPassWord));
Result := CustomCommand('APOP ' + FUserName + ' ' + s, False);
end;
function TPOP3Send.Connect: Boolean;
begin
// Do not call this function! It is calling by LOGIN method!
FStatCount := 0;
FStatSize := 0;
FSock.CloseSocket;
FSock.LineBuffer := '';
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError = 0 then
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError = 0 then
if FFullSSL then
FSock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
function TPOP3Send.Capability: Boolean;
begin
FPOP3cap.Clear;
Result := CustomCommand('CAPA', True);
if Result then
FPOP3cap.AddStrings(FFullResult);
end;
function TPOP3Send.Login: Boolean;
var
s, s1: string;
begin
Result := False;
FTimeStamp := '';
if not Connect then
Exit;
if ReadResult(False) <> 1 then
Exit;
s := SeparateRight(FResultString, '<');
if s <> FResultString then
begin
s1 := Trim(SeparateLeft(s, '>'));
if s1 <> s then
FTimeStamp := '<' + s1 + '>';
end;
Result := False;
if Capability then
if FAutoTLS and (Findcap('STLS') <> '') then
if StartTLS then
Capability
else
begin
Result := False;
Exit;
end;
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;
function TPOP3Send.Logout: Boolean;
begin
Result := CustomCommand('QUIT', False);
FSock.CloseSocket;
end;
function TPOP3Send.Reset: Boolean;
begin
Result := CustomCommand('RSET', False);
end;
function TPOP3Send.NoOp: Boolean;
begin
Result := CustomCommand('NOOP', False);
end;
function TPOP3Send.Stat: Boolean;
var
s: string;
begin
Result := CustomCommand('STAT', False);
if Result then
begin
s := SeparateRight(ResultString, '+OK ');
FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0);
FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0);
end;
end;
function TPOP3Send.List(Value: Integer): Boolean;
var
s: string;
n: integer;
begin
if Value = 0 then
s := 'LIST'
else
s := 'LIST ' + IntToStr(Value);
Result := CustomCommand(s, Value = 0);
FListSize := 0;
if Result then
if Value <> 0 then
begin
s := SeparateRight(ResultString, '+OK ');
FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
end
else
for n := 0 to FFullResult.Count - 1 do
FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
end;
function TPOP3Send.Retr(Value: Integer): Boolean;
begin
Result := CustomCommand('RETR ' + IntToStr(Value), True);
end;
//based on code by Miha Vrhovnik
function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean;
var
s: string;
begin
Result := False;
FFullResult.Clear;
Stream.Size := 0;
FSock.SendString('RETR ' + IntToStr(Value) + CRLF);
s := FSock.RecvString(FTimeout);
if Pos('+OK', s) = 1 then
Result := True;
FResultString := s;
if Result then begin
repeat
s := FSock.RecvString(FTimeout);
if s = '.' then
Break;
if s <> '' then begin
if s[1] = '.' then
Delete(s, 1, 1);
end;
WriteStrToStream(Stream, s);
WriteStrToStream(Stream, CRLF);
until FSock.LastError <> 0;
end;
if Result then
FResultCode := 1
else
FResultCode := 0;
end;
function TPOP3Send.Dele(Value: Integer): Boolean;
begin
Result := CustomCommand('DELE ' + IntToStr(Value), False);
end;
function TPOP3Send.Top(Value, Maxlines: Integer): Boolean;
begin
Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True);
end;
function TPOP3Send.Uidl(Value: Integer): Boolean;
var
s: string;
begin
if Value = 0 then
s := 'UIDL'
else
s := 'UIDL ' + IntToStr(Value);
Result := CustomCommand(s, Value = 0);
end;
function TPOP3Send.StartTLS: Boolean;
begin
Result := False;
if CustomCommand('STLS', False) then
begin
Fsock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
function TPOP3Send.FindCap(const Value: string): string;
var
n: Integer;
s: string;
begin
s := UpperCase(Value);
Result := '';
for n := 0 to FPOP3cap.Count - 1 do
if Pos(s, UpperCase(FPOP3cap[n])) = 1 then
begin
Result := FPOP3cap[n];
Break;
end;
end;
end.
TransGUI/synapse/source/lib/sntpsend.pas 0000644 0000000 0000000 00000030503 11366572451 017316 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 003.000.003 |
|==============================================================================|
| Content: SNTP client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Patrick Chevalley |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract( NTP and SNTP client)
Used RFC: RFC-1305, RFC-2030
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
unit sntpsend;
interface
uses
SysUtils,
synsock, blcksock, synautil;
const
cNtpProtocol = '123';
type
{:@abstract(Record containing the NTP packet.)}
TNtp = packed record
mode: Byte;
stratum: Byte;
poll: Byte;
Precision: Byte;
RootDelay: Longint;
RootDisperson: Longint;
RefID: Longint;
Ref1: Longint;
Ref2: Longint;
Org1: Longint;
Org2: Longint;
Rcv1: Longint;
Rcv2: Longint;
Xmit1: Longint;
Xmit2: Longint;
end;
{:@abstract(Implementation of NTP and SNTP client protocol),
include time synchronisation. It can send NTP or SNTP time queries, or it
can receive NTP broadcasts too.
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TSNTPSend = class(TSynaClient)
private
FNTPReply: TNtp;
FNTPTime: TDateTime;
FNTPOffset: double;
FNTPDelay: double;
FMaxSyncDiff: double;
FSyncTime: Boolean;
FSock: TUDPBlockSocket;
FBuffer: AnsiString;
FLi, FVn, Fmode : byte;
function StrToNTP(const Value: AnsiString): TNtp;
function NTPtoStr(const Value: Tntp): AnsiString;
procedure ClearNTP(var Value: Tntp);
public
constructor Create;
destructor Destroy; override;
{:Decode 128 bit timestamp used in NTP packet to TDateTime type.}
function DecodeTs(Nsec, Nfrac: Longint): TDateTime;
{:Decode TDateTime type to 128 bit timestamp used in NTP packet.}
procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
{:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
valid.}
function GetSNTP: Boolean;
{:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
valid. Result time is after all needed corrections.}
function GetNTP: Boolean;
{:Wait for broadcast NTP packet. If all OK, result is @true and
@link(NTPReply) and @link(NTPTime) are valid.}
function GetBroadcastNTP: Boolean;
{:Holds last received NTP packet.}
property NTPReply: TNtp read FNTPReply;
published
{:Date and time of remote NTP or SNTP server. (UTC time!!!)}
property NTPTime: TDateTime read FNTPTime;
{:Offset between your computer and remote NTP or SNTP server.}
property NTPOffset: Double read FNTPOffset;
{:Delay between your computer and remote NTP or SNTP server.}
property NTPDelay: Double read FNTPDelay;
{:Define allowed maximum difference between your time and remote time for
synchronising time. If difference is bigger, your system time is not
changed!}
property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff;
{:If @true, after successfull getting time is local computer clock
synchronised to given time.
For synchronising time you must have proper rights! (Usually Administrator)}
property SyncTime: Boolean read FSyncTime write FSyncTime;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TUDPBlockSocket read FSock;
end;
implementation
constructor TSNTPSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FTimeout := 5000;
FTargetPort := cNtpProtocol;
FMaxSyncDiff := 3600;
FSyncTime := False;
end;
destructor TSNTPSend.Destroy;
begin
FSock.Free;
inherited Destroy;
end;
function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp;
begin
if length(FBuffer) >= SizeOf(Result) then
begin
Result.mode := ord(Value[1]);
Result.stratum := ord(Value[2]);
Result.poll := ord(Value[3]);
Result.Precision := ord(Value[4]);
Result.RootDelay := DecodeLongInt(value, 5);
Result.RootDisperson := DecodeLongInt(value, 9);
Result.RefID := DecodeLongInt(value, 13);
Result.Ref1 := DecodeLongInt(value, 17);
Result.Ref2 := DecodeLongInt(value, 21);
Result.Org1 := DecodeLongInt(value, 25);
Result.Org2 := DecodeLongInt(value, 29);
Result.Rcv1 := DecodeLongInt(value, 33);
Result.Rcv2 := DecodeLongInt(value, 37);
Result.Xmit1 := DecodeLongInt(value, 41);
Result.Xmit2 := DecodeLongInt(value, 45);
end;
end;
function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString;
begin
SetLength(Result, 4);
Result[1] := AnsiChar(Value.mode);
Result[2] := AnsiChar(Value.stratum);
Result[3] := AnsiChar(Value.poll);
Result[4] := AnsiChar(Value.precision);
Result := Result + CodeLongInt(Value.RootDelay);
Result := Result + CodeLongInt(Value.RootDisperson);
Result := Result + CodeLongInt(Value.RefID);
Result := Result + CodeLongInt(Value.Ref1);
Result := Result + CodeLongInt(Value.Ref2);
Result := Result + CodeLongInt(Value.Org1);
Result := Result + CodeLongInt(Value.Org2);
Result := Result + CodeLongInt(Value.Rcv1);
Result := Result + CodeLongInt(Value.Rcv2);
Result := Result + CodeLongInt(Value.Xmit1);
Result := Result + CodeLongInt(Value.Xmit2);
end;
procedure TSNTPSend.ClearNTP(var Value: Tntp);
begin
Value.mode := 0;
Value.stratum := 0;
Value.poll := 0;
Value.Precision := 0;
Value.RootDelay := 0;
Value.RootDisperson := 0;
Value.RefID := 0;
Value.Ref1 := 0;
Value.Ref2 := 0;
Value.Org1 := 0;
Value.Org2 := 0;
Value.Rcv1 := 0;
Value.Rcv2 := 0;
Value.Xmit1 := 0;
Value.Xmit2 := 0;
end;
function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
const
maxi = 4294967295.0;
var
d, d1: Double;
begin
d := Nsec;
if d < 0 then
d := maxi + d + 1;
d1 := Nfrac;
if d1 < 0 then
d1 := maxi + d1 + 1;
d1 := d1 / maxi;
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);
if d > maxilongint then
d := d - maxi - 1;
d := trunc(d);
d1 := Trunc(d1 * 10000) / 10000;
d1 := d1 * maxi;
if d1 > maxilongint then
d1 := d1 - maxi - 1;
Nsec:=trunc(d);
Nfrac:=trunc(d1);
end;
function TSNTPSend.GetBroadcastNTP: Boolean;
var
x: Integer;
begin
Result := False;
FSock.Bind(FIPInterface, FTargetPort);
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
x := Length(FBuffer);
if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then
if x >= SizeOf(NTPReply) then
begin
FNTPReply := StrToNTP(FBuffer);
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
SetUTTime(FNTPTime);
Result := True;
end;
end;
end;
function TSNTPSend.GetSNTP: Boolean;
var
q: TNtp;
x: Integer;
begin
Result := False;
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
ClearNtp(q);
q.mode := $1B;
FBuffer := NTPtoStr(q);
FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
x := Length(FBuffer);
if x >= SizeOf(NTPReply) then
begin
FNTPReply := StrToNTP(FBuffer);
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;
x: Integer;
t1, t2, t3, t4 : TDateTime;
begin
Result := False;
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
ClearNtp(q);
q.mode := $1B;
t1 := GetUTTime;
EncodeTs(t1, q.org1, q.org2);
FBuffer := NTPtoStr(q);
FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
x := Length(FBuffer);
t4 := GetUTTime;
if x >= SizeOf(NTPReply) then
begin
FNTPReply := StrToNTP(FBuffer);
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.
TransGUI/synapse/source/lib/synamisc.pas 0000644 0000000 0000000 00000030622 11466757142 017313 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.003.001 |
|==============================================================================|
| Content: misc. procedures and functions |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 2002-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(Misc. network based utilities)}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
//Kylix does not known UNIX define
{$IFDEF LINUX}
{$IFNDEF UNIX}
{$DEFINE UNIX}
{$ENDIF}
{$ENDIF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit synamisc;
interface
{$IFDEF VER125}
{$DEFINE BCB}
{$ENDIF}
{$IFDEF BCB}
{$ObjExportAll On}
{$HPPEMIT '#pragma comment( lib , "wininet.lib" )'}
{$ENDIF}
uses
synautil, blcksock, SysUtils, Classes
{$IFDEF UNIX}
{$IFNDEF FPC}
, Libc
{$ENDIF}
{$ELSE}
, Windows
{$ENDIF}
;
Type
{:@abstract(This record contains information about proxy setting.)}
TProxySetting = record
Host: string;
Port: string;
Bypass: string;
end;
{:By this function you can turn-on computer on network, if this computer
supporting Wake-on-lan feature. You need MAC number (network card indentifier)
of computer for turn-on. You can also assign target IP addres. If you not
specify it, then is used broadcast for delivery magic wake-on packet. However
broadcasts workinh only on your local network. When you need to wake-up
computer on another network, you must specify any existing IP addres on same
network segment as targeting computer.}
procedure WakeOnLan(MAC, IP: string);
{:Autodetect current DNS servers used by system. If is defined more then one DNS
server, then result is comma-delimited.}
function GetDNS: string;
{:Autodetect InternetExplorer proxy setting for given protocol. This function
working only on windows!}
function GetIEProxy(protocol: string): TProxySetting;
{:Return all known IP addresses on local system. Addresses are divided by comma.}
function GetLocalIPs: string;
implementation
{==============================================================================}
procedure WakeOnLan(MAC, IP: string);
var
sock: TUDPBlockSocket;
HexMac: Ansistring;
data: Ansistring;
n: integer;
b: Byte;
begin
if MAC <> '' then
begin
MAC := ReplaceString(MAC, '-', '');
MAC := ReplaceString(MAC, ':', '');
if Length(MAC) < 12 then
Exit;
HexMac := '';
for n := 0 to 5 do
begin
b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0);
HexMac := HexMac + char(b);
end;
if IP = '' then
IP := cBroadcast;
sock := TUDPBlockSocket.Create;
try
sock.CreateSocket;
sock.EnableBroadcast(true);
sock.Connect(IP, '9');
data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF;
for n := 1 to 16 do
data := data + HexMac;
sock.SendString(data);
finally
sock.Free;
end;
end;
end;
{==============================================================================}
{$IFNDEF UNIX}
function GetDNSbyIpHlp: string;
type
PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING;
TIP_ADDRESS_STRING = array[0..15] of Ansichar;
PTIP_ADDR_STRING = ^TIP_ADDR_STRING;
TIP_ADDR_STRING = packed record
Next: PTIP_ADDR_STRING;
IpAddress: TIP_ADDRESS_STRING;
IpMask: TIP_ADDRESS_STRING;
Context: DWORD;
end;
PTFixedInfo = ^TFixedInfo;
TFixedInfo = packed record
HostName: array[1..128 + 4] of Ansichar;
DomainName: array[1..128 + 4] of Ansichar;
CurrentDNSServer: PTIP_ADDR_STRING;
DNSServerList: TIP_ADDR_STRING;
NodeType: UINT;
ScopeID: array[1..256 + 4] of Ansichar;
EnableRouting: UINT;
EnableProxy: UINT;
EnableDNS: UINT;
end;
const
IpHlpDLL = 'IPHLPAPI.DLL';
var
IpHlpModule: THandle;
FixedInfo: PTFixedInfo;
InfoSize: Longint;
PDnsServer: PTIP_ADDR_STRING;
err: integer;
GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall;
begin
InfoSize := 0;
Result := '...';
IpHlpModule := LoadLibrary(IpHlpDLL);
if IpHlpModule = 0 then
exit;
try
GetNetworkParams := GetProcAddress(IpHlpModule,PAnsiChar(AnsiString('GetNetworkParams')));
if @GetNetworkParams = nil then
Exit;
err := GetNetworkParams(Nil, @InfoSize);
if err <> ERROR_BUFFER_OVERFLOW then
Exit;
Result := '';
GetMem (FixedInfo, InfoSize);
try
err := GetNetworkParams(FixedInfo, @InfoSize);
if err <> ERROR_SUCCESS then
exit;
with FixedInfo^ do
begin
Result := DnsServerList.IpAddress;
PDnsServer := DnsServerList.Next;
while PDnsServer <> Nil do
begin
if Result <> '' then
Result := Result + ',';
Result := Result + PDnsServer^.IPAddress;
PDnsServer := PDnsServer.Next;
end;
end;
finally
FreeMem(FixedInfo);
end;
finally
FreeLibrary(IpHlpModule);
end;
end;
function ReadReg(SubKey, Vn: PChar): string;
var
OpenKey: HKEY;
DataType, DataSize: integer;
Temp: array [0..2048] of char;
begin
Result := '';
if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE,
KEY_READ, OpenKey) = ERROR_SUCCESS then
begin
DataType := REG_SZ;
DataSize := SizeOf(Temp);
if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then
SetString(Result, Temp, DataSize div SizeOf(Char) - 1);
RegCloseKey(OpenKey);
end;
end ;
{$ENDIF}
function GetDNS: string;
{$IFDEF UNIX}
var
l: TStringList;
n: integer;
begin
Result := '';
l := TStringList.Create;
try
l.LoadFromFile('/etc/resolv.conf');
for n := 0 to l.Count - 1 do
if Pos('NAMESERVER', uppercase(l[n])) = 1 then
begin
if Result <> '' then
Result := Result + ',';
Result := Result + SeparateRight(l[n], ' ');
end;
finally
l.Free;
end;
end;
{$ELSE}
const
NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary';
NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters';
W9xfix = 'System\CurrentControlSet\Services\MSTCP';
begin
Result := GetDNSbyIpHlp;
if Result = '...' then
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
Result := ReadReg(NTdyn, 'NameServer');
if result = '' then
Result := ReadReg(NTfix, 'NameServer');
if result = '' then
Result := ReadReg(NTfix, 'DhcpNameServer');
end
else
Result := ReadReg(W9xfix, 'NameServer');
Result := ReplaceString(trim(Result), ' ', ',');
end;
end;
{$ENDIF}
{==============================================================================}
function GetIEProxy(protocol: string): TProxySetting;
{$IFDEF UNIX}
begin
Result.Host := '';
Result.Port := '';
Result.Bypass := '';
end;
{$ELSE}
type
PInternetProxyInfo = ^TInternetProxyInfo;
TInternetProxyInfo = packed record
dwAccessType: DWORD;
lpszProxy: LPCSTR;
lpszProxyBypass: LPCSTR;
end;
const
INTERNET_OPTION_PROXY = 38;
INTERNET_OPEN_TYPE_PROXY = 3;
WininetDLL = 'WININET.DLL';
var
WininetModule: THandle;
ProxyInfo: PInternetProxyInfo;
Err: Boolean;
Len: DWORD;
Proxy: string;
DefProxy: string;
ProxyList: TStringList;
n: integer;
InternetQueryOption: function (hInet: Pointer; dwOption: DWORD;
lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall;
begin
Result.Host := '';
Result.Port := '';
Result.Bypass := '';
WininetModule := LoadLibrary(WininetDLL);
if WininetModule = 0 then
exit;
try
InternetQueryOption := GetProcAddress(WininetModule,PAnsiChar(AnsiString('InternetQueryOptionA')));
if @InternetQueryOption = nil then
Exit;
if protocol = '' then
protocol := 'http';
Len := 4096;
GetMem(ProxyInfo, Len);
ProxyList := TStringList.Create;
try
Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len);
if Err then
if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
begin
ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ',');
Proxy := '';
DefProxy := '';
for n := 0 to ProxyList.Count -1 do
begin
if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then
begin
Proxy := SeparateRight(ProxyList[n], '=');
break;
end;
if Pos('=', ProxyList[n]) < 1 then
DefProxy := ProxyList[n];
end;
if Proxy = '' then
Proxy := DefProxy;
if Proxy <> '' then
begin
Result.Host := Trim(SeparateLeft(Proxy, ':'));
Result.Port := Trim(SeparateRight(Proxy, ':'));
end;
Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ',');
end;
finally
ProxyList.Free;
FreeMem(ProxyInfo);
end;
finally
FreeLibrary(WininetModule);
end;
end;
{$ENDIF}
{==============================================================================}
function GetLocalIPs: string;
var
TcpSock: TTCPBlockSocket;
ipList: TStringList;
begin
Result := '';
ipList := TStringList.Create;
try
TcpSock := TTCPBlockSocket.create;
try
TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList);
Result := ipList.CommaText;
finally
TcpSock.Free;
end;
finally
ipList.Free;
end;
end;
{==============================================================================}
end.
TransGUI/synapse/source/lib/nntpsend.pas 0000644 0000000 0000000 00000033773 11366572451 017325 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.005.002 |
|==============================================================================|
| Content: NNTP client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(NNTP client)
NNTP (network news transfer protocol)
Used RFC: RFC-977, RFC-2980
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$WARN SUSPICIOUS_TYPECAST OFF}
{$ENDIF}
unit nntpsend;
interface
uses
SysUtils, Classes,
blcksock, synautil;
const
cNNTPProtocol = '119';
type
{:abstract(Implementation of Network News Transfer Protocol.
Note: Are you missing properties for setting Username and Password? Look to
parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TNNTPSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FResultCode: Integer;
FResultString: string;
FData: TStringList;
FDataToSend: TStringList;
FAutoTLS: Boolean;
FFullSSL: Boolean;
FNNTPcap: TStringList;
function ReadResult: Integer;
function ReadData: boolean;
function SendData: boolean;
function Connect: Boolean;
public
constructor Create;
destructor Destroy; override;
{:Connects to NNTP server and begin session.}
function Login: Boolean;
{:Logout from NNTP server and terminate session.}
function Logout: Boolean;
{:By this you can call any NNTP command.}
function DoCommand(const Command: string): boolean;
{:by this you can call any NNTP command. This variant is used for commands
for download information from server.}
function DoCommandRead(const Command: string): boolean;
{:by this you can call any NNTP command. This variant is used for commands
for upload information to server.}
function DoCommandWrite(const Command: string): boolean;
{:Download full message to @link(data) property. Value can be number of
message or message-id (in brackets).}
function GetArticle(const Value: string): Boolean;
{:Download only body of message to @link(data) property. Value can be number
of message or message-id (in brackets).}
function GetBody(const Value: string): Boolean;
{:Download only headers of message to @link(data) property. Value can be
number of message or message-id (in brackets).}
function GetHead(const Value: string): Boolean;
{:Get message status. Value can be number of message or message-id
(in brackets).}
function GetStat(const Value: string): Boolean;
{:Select given group.}
function SelectGroup(const Value: string): Boolean;
{:Tell to server 'I have mesage with given message-ID.' If server need this
message, message is uploaded to server.}
function IHave(const MessID: string): Boolean;
{:Move message pointer to last item in group.}
function GotoLast: Boolean;
{:Move message pointer to next item in group.}
function GotoNext: Boolean;
{:Download to @link(data) property list of all groups on NNTP server.}
function ListGroups: Boolean;
{:Download to @link(data) property list of all groups created after given time.}
function ListNewGroups(Since: TDateTime): Boolean;
{:Download to @link(data) property list of message-ids in given group since
given time.}
function NewArticles(const Group: string; Since: TDateTime): Boolean;
{:Upload new article to server. (for new messages by you)}
function PostArticle: Boolean;
{:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP
server'.}
function SwitchToSlave: Boolean;
{:Call NNTP XOVER command.}
function Xover(xoStart, xoEnd: string): boolean;
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean;
{:Try to find given capability in extension list. This list is getted after
successful login to NNTP server. If extension capability is not found,
then return is empty string.}
function FindCap(const Value: string): string;
{:Try get list of server extensions. List is returned in @link(data) property.}
function ListExtensions: Boolean;
published
{:Result code number of last operation.}
property ResultCode: Integer read FResultCode;
{:String description of last result code from NNTP server.}
property ResultString: string read FResultString;
{:Readed data. (message, etc.)}
property Data: TStringList read FData;
{:If is set to @true, then upgrade to SSL/TLS mode after login if remote
server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
end;
implementation
constructor TNNTPSend.Create;
begin
inherited Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FData := TStringList.Create;
FDataToSend := TStringList.Create;
FNNTPcap := TStringList.Create;
FSock.ConvertLineEnd := True;
FTimeout := 60000;
FTargetPort := cNNTPProtocol;
FAutoTLS := False;
FFullSSL := False;
end;
destructor TNNTPSend.Destroy;
begin
FSock.Free;
FDataToSend.Free;
FData.Free;
FNNTPcap.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
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
for n := 0 to FDataToSend.Count - 1 do
begin
s := FDataToSend[n];
if (s <> '') and (s[1] = '.') then
s := s + '.';
FSock.SendString(s + CRLF);
if FSock.LastError <> 0 then
break;
end;
if FDataToSend.Count = 0 then
FSock.SendString(CRLF);
if FSock.LastError = 0 then
FSock.SendString('.' + CRLF);
FDataToSend.Clear;
Result := FSock.LastError = 0;
end;
function TNNTPSend.Connect: Boolean;
begin
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError = 0 then
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError = 0 then
if FFullSSL then
FSock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
function TNNTPSend.Login: Boolean;
begin
Result := False;
FNNTPcap.Clear;
if not Connect then
Exit;
Result := (ReadResult div 100) = 2;
ListExtensions;
FNNTPcap.Assign(Fdata);
if Result then
if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
Result := StartTLS;
if (FUsername <> '') and Result then
begin
FSock.SendString('AUTHINFO USER ' + FUsername + CRLF);
if (ReadResult div 100) = 3 then
begin
FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF);
Result := (ReadResult div 100) = 2;
end;
end;
end;
function TNNTPSend.Logout: Boolean;
begin
FSock.SendString('QUIT' + CRLF);
Result := (ReadResult div 100) = 2;
FSock.CloseSocket;
end;
function TNNTPSend.DoCommand(const Command: string): Boolean;
begin
FSock.SendString(Command + CRLF);
Result := (ReadResult div 100) = 2;
Result := Result and (FSock.LastError = 0);
end;
function TNNTPSend.DoCommandRead(const Command: string): Boolean;
begin
Result := DoCommand(Command);
if Result then
begin
Result := ReadData;
Result := Result and (FSock.LastError = 0);
end;
end;
function TNNTPSend.DoCommandWrite(const Command: string): Boolean;
var
x: integer;
begin
FDataToSend.Assign(FData);
FSock.SendString(Command + CRLF);
x := (ReadResult div 100);
if x = 3 then
begin
SendData;
x := (ReadResult div 100);
end;
Result := x = 2;
Result := Result and (FSock.LastError = 0);
end;
function TNNTPSend.GetArticle(const Value: string): Boolean;
var
s: string;
begin
s := 'ARTICLE';
if Value <> '' then
s := s + ' ' + Value;
Result := DoCommandRead(s);
end;
function TNNTPSend.GetBody(const Value: string): Boolean;
var
s: string;
begin
s := 'BODY';
if Value <> '' then
s := s + ' ' + Value;
Result := DoCommandRead(s);
end;
function TNNTPSend.GetHead(const Value: string): Boolean;
var
s: string;
begin
s := 'HEAD';
if Value <> '' then
s := s + ' ' + Value;
Result := DoCommandRead(s);
end;
function TNNTPSend.GetStat(const Value: string): Boolean;
var
s: string;
begin
s := 'STAT';
if Value <> '' then
s := s + ' ' + Value;
Result := DoCommand(s);
end;
function TNNTPSend.SelectGroup(const Value: string): Boolean;
begin
Result := DoCommand('GROUP ' + Value);
end;
function TNNTPSend.IHave(const MessID: string): Boolean;
begin
Result := DoCommandWrite('IHAVE ' + MessID);
end;
function TNNTPSend.GotoLast: Boolean;
begin
Result := DoCommand('LAST');
end;
function TNNTPSend.GotoNext: Boolean;
begin
Result := DoCommand('NEXT');
end;
function TNNTPSend.ListGroups: Boolean;
begin
Result := DoCommandRead('LIST');
end;
function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean;
begin
Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT');
end;
function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean;
begin
Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT');
end;
function TNNTPSend.PostArticle: Boolean;
begin
Result := DoCommandWrite('POST');
end;
function TNNTPSend.SwitchToSlave: Boolean;
begin
Result := DoCommand('SLAVE');
end;
function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean;
var
s: string;
begin
s := 'XOVER ' + xoStart;
if xoEnd <> xoStart then
s := s + '-' + xoEnd;
Result := DoCommandRead(s);
end;
function TNNTPSend.StartTLS: Boolean;
begin
Result := False;
if FindCap('STARTTLS') <> '' then
begin
if DoCommand('STARTTLS') then
begin
Fsock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
end;
function TNNTPSend.ListExtensions: Boolean;
begin
Result := DoCommandRead('LIST EXTENSIONS');
end;
function TNNTPSend.FindCap(const Value: string): string;
var
n: Integer;
s: string;
begin
s := UpperCase(Value);
Result := '';
for n := 0 to FNNTPcap.Count - 1 do
if Pos(s, UpperCase(FNNTPcap[n])) = 1 then
begin
Result := FNNTPcap[n];
Break;
end;
end;
{==============================================================================}
end.
TransGUI/synapse/source/lib/ssl_cryptlib.pas 0000644 0000000 0000000 00000045062 11366572451 020177 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.001.000 |
|==============================================================================|
| Content: SSL/SSH support by Peter Gutmann's CryptLib |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(SSL/SSH plugin for CryptLib)
This plugin requires cl32.dll at least version 3.2.0! It can be used on Win32
and Linux. This library is staticly linked - when you compile your application
with this plugin, you MUST distribute it with Cryptib library, otherwise you
cannot run your application!
It can work with keys and certificates stored as PKCS#15 only! It must be stored
as disk file only, you cannot load them from memory! Each file can hold multiple
keys and certificates. You must identify it by 'label' stored in
@link(TSSLCryptLib.PrivateKeyLabel).
If you need to use secure connection and authorize self by certificate
(each SSL/TLS server or client with client authorization), then use
@link(TCustomSSL.PrivateKeyFile), @link(TSSLCryptLib.PrivateKeyLabel) and
@link(TCustomSSL.KeyPassword) properties.
If you need to use server what verifying client certificates, then use
@link(TCustomSSL.CertCAFile) as PKCS#15 file with public keyas of allowed clients. Clients
with non-matching certificates will be rejected by cryptLib.
This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS
server without explicitly assigned key and certificate, then this plugin create
Ad-Hoc key and certificate for each incomming connection by self. It slowdown
accepting of new connections!
You can use this plugin for SSHv2 connections too! You must explicitly set
@link(TCustomSSL.SSLType) to value LT_SSHv2 and set @link(TCustomSSL.username)
and @link(TCustomSSL.password). You can use special SSH channels too, see
@link(TCustomSSL).
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit ssl_cryptlib;
interface
uses
SysUtils,
blcksock, synsock, synautil, synacode,
cryptlib;
type
{:@abstract(class implementing CryptLib SSL/SSH plugin.)
Instance of this class will be created for each @link(TTCPBlockSocket).
You not need to create instance of this class, all is done by Synapse itself!}
TSSLCryptLib = class(TCustomSSL)
protected
FCryptSession: CRYPT_SESSION;
FPrivateKeyLabel: string;
FDelCert: Boolean;
FReadBuffer: string;
function SSLCheck(Value: integer): Boolean;
function Init(server:Boolean): Boolean;
function DeInit: Boolean;
function Prepare(server:Boolean): Boolean;
function GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
function CreateSelfSignedCert(Host: string): Boolean; override;
function PopAll: string;
public
{:See @inherited}
constructor Create(const Value: TTCPBlockSocket); override;
destructor Destroy; override;
{:See @inherited}
function LibVersion: String; override;
{:See @inherited}
function LibName: String; override;
{:See @inherited}
procedure Assign(const Value: TCustomSSL); override;
{:See @inherited and @link(ssl_cryptlib) for more details.}
function Connect: boolean; override;
{:See @inherited and @link(ssl_cryptlib) for more details.}
function Accept: boolean; override;
{:See @inherited}
function Shutdown: boolean; override;
{:See @inherited}
function BiShutdown: boolean; override;
{:See @inherited}
function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function WaitingData: Integer; override;
{:See @inherited}
function GetSSLVersion: string; override;
{:See @inherited}
function GetPeerSubject: string; override;
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerFingerprint: string; override;
published
{:name of certificate/key within PKCS#15 file. It can hold more then one
certificate/key and each certificate/key must have unique label within one file.}
property PrivateKeyLabel: string read FPrivateKeyLabel Write FPrivateKeyLabel;
end;
implementation
{==============================================================================}
constructor TSSLCryptLib.Create(const Value: TTCPBlockSocket);
begin
inherited Create(Value);
FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
FPrivateKeyLabel := 'synapse';
FDelCert := false;
end;
destructor TSSLCryptLib.Destroy;
begin
DeInit;
inherited Destroy;
end;
procedure TSSLCryptLib.Assign(const Value: TCustomSSL);
begin
inherited Assign(Value);
if Value is TSSLCryptLib then
begin
FPrivateKeyLabel := TSSLCryptLib(Value).privatekeyLabel;
end;
end;
function TSSLCryptLib.GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
var
l: integer;
begin
l := 0;
cryptGetAttributeString(cryptHandle, attributeType, nil, l);
setlength(Result, l);
cryptGetAttributeString(cryptHandle, attributeType, pointer(Result), l);
setlength(Result, l);
end;
function TSSLCryptLib.LibVersion: String;
var
x: integer;
begin
Result := GetString(CRYPT_UNUSED, CRYPT_OPTION_INFO_DESCRIPTION);
cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION, x);
Result := Result + ' v' + IntToStr(x);
cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION, x);
Result := Result + '.' + IntToStr(x);
cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_STEPPING, x);
Result := Result + '.' + IntToStr(x);
end;
function TSSLCryptLib.LibName: String;
begin
Result := 'ssl_cryptlib';
end;
function TSSLCryptLib.SSLCheck(Value: integer): Boolean;
begin
Result := true;
FLastErrorDesc := '';
if Value = CRYPT_ERROR_COMPLETE then
Value := 0;
FLastError := Value;
if FLastError <> 0 then
begin
Result := False;
FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE);
end;
end;
function TSSLCryptLib.CreateSelfSignedCert(Host: string): Boolean;
var
privateKey: CRYPT_CONTEXT;
keyset: CRYPT_KEYSET;
cert: CRYPT_CERTIFICATE;
publicKey: CRYPT_CONTEXT;
begin
Result := False;
if FPrivatekeyFile = '' then
FPrivatekeyFile := GetTempFile('', 'key');
cryptCreateContext(privateKey, CRYPT_UNUSED, CRYPT_ALGO_RSA);
cryptSetAttributeString(privateKey, CRYPT_CTXINFO_LABEL, Pointer(FPrivatekeyLabel),
Length(FPrivatekeyLabel));
cryptSetAttribute(privateKey, CRYPT_CTXINFO_KEYSIZE, 1024);
cryptGenerateKey(privateKey);
cryptKeysetOpen(keyset, CRYPT_UNUSED, CRYPT_KEYSET_FILE, PChar(FPrivatekeyFile), CRYPT_KEYOPT_CREATE);
FDelCert := True;
cryptAddPrivateKey(keyset, privateKey, PChar(FKeyPassword));
cryptCreateCert(cert, CRYPT_UNUSED, CRYPT_CERTTYPE_CERTIFICATE);
cryptSetAttribute(cert, CRYPT_CERTINFO_XYZZY, 1);
cryptGetPublicKey(keyset, publicKey, CRYPT_KEYID_NAME, PChar(FPrivatekeyLabel));
cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTPUBLICKEYINFO, publicKey);
cryptSetAttributeString(cert, CRYPT_CERTINFO_COMMONNAME, Pointer(host), Length(host));
cryptSignCert(cert, privateKey);
cryptAddPublicKey(keyset, cert);
cryptKeysetClose(keyset);
cryptDestroyCert(cert);
cryptDestroyContext(privateKey);
cryptDestroyContext(publicKey);
Result := True;
end;
function TSSLCryptLib.PopAll: string;
const
BufferMaxSize = 32768;
var
Outbuffer: string;
WriteLen: integer;
begin
Result := '';
repeat
setlength(outbuffer, BufferMaxSize);
Writelen := 0;
SSLCheck(CryptPopData(FCryptSession, @OutBuffer[1], BufferMaxSize, Writelen));
if FLastError <> 0 then
Break;
if WriteLen > 0 then
begin
setlength(outbuffer, WriteLen);
Result := Result + outbuffer;
end;
until WriteLen = 0;
end;
function TSSLCryptLib.Init(server:Boolean): Boolean;
var
st: CRYPT_SESSION_TYPE;
keysetobj: CRYPT_KEYSET;
cryptContext: CRYPT_CONTEXT;
x: integer;
begin
Result := False;
FLastErrorDesc := '';
FLastError := 0;
FDelCert := false;
FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
if server then
case FSSLType of
LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
st := CRYPT_SESSION_SSL_SERVER;
LT_SSHv2:
st := CRYPT_SESSION_SSH_SERVER;
else
Exit;
end
else
case FSSLType of
LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
st := CRYPT_SESSION_SSL;
LT_SSHv2:
st := CRYPT_SESSION_SSH;
else
Exit;
end;
if not SSLCheck(cryptCreateSession(FcryptSession, CRYPT_UNUSED, st)) then
Exit;
x := -1;
case FSSLType of
LT_SSLv3:
x := 0;
LT_TLSv1:
x := 1;
LT_TLSv1_1:
x := 2;
end;
if x >= 0 then
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then
Exit;
if FUsername <> '' then
begin
cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME,
Pointer(FUsername), Length(FUsername));
cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD,
Pointer(FPassword), Length(FPassword));
end;
if FSSLType = LT_SSHv2 then
if FSSHChannelType <> '' then
begin
cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL, CRYPT_UNUSED);
cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_TYPE,
Pointer(FSSHChannelType), Length(FSSHChannelType));
if FSSHChannelArg1 <> '' then
cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG1,
Pointer(FSSHChannelArg1), Length(FSSHChannelArg1));
if FSSHChannelArg2 <> '' then
cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG2,
Pointer(FSSHChannelArg2), Length(FSSHChannelArg2));
end;
if server and (FPrivatekeyFile = '') then
begin
if FPrivatekeyLabel = '' then
FPrivatekeyLabel := 'synapse';
if FkeyPassword = '' then
FkeyPassword := 'synapse';
CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
end;
if (FPrivatekeyLabel <> '') and (FPrivatekeyFile <> '') then
begin
if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
PChar(FPrivatekeyFile), CRYPT_KEYOPT_READONLY)) then
Exit;
try
if not SSLCheck(cryptGetPrivateKey(KeySetObj, cryptcontext, CRYPT_KEYID_NAME,
PChar(FPrivatekeyLabel), PChar(FKeyPassword))) then
Exit;
if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_PRIVATEKEY,
cryptcontext)) then
Exit;
finally
cryptKeysetClose(keySetObj);
cryptDestroyContext(cryptcontext);
end;
end;
if server and FVerifyCert then
begin
if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
PChar(FCertCAFile), CRYPT_KEYOPT_READONLY)) then
Exit;
try
if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_KEYSET,
keySetObj)) then
Exit;
finally
cryptKeysetClose(keySetObj);
end;
end;
Result := true;
end;
function TSSLCryptLib.DeInit: Boolean;
begin
Result := True;
if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
CryptDestroySession(FcryptSession);
FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
FSSLEnabled := False;
if FDelCert then
Deletefile(FPrivatekeyFile);
end;
function TSSLCryptLib.Prepare(server:Boolean): Boolean;
begin
Result := false;
DeInit;
if Init(server) then
Result := true
else
DeInit;
end;
function TSSLCryptLib.Connect: boolean;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(false) then
begin
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
Exit;
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
Exit;
FSSLEnabled := True;
Result := True;
FReadBuffer := '';
end;
end;
function TSSLCryptLib.Accept: boolean;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(true) then
begin
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
Exit;
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
Exit;
FSSLEnabled := True;
Result := True;
FReadBuffer := '';
end;
end;
function TSSLCryptLib.Shutdown: boolean;
begin
Result := BiShutdown;
end;
function TSSLCryptLib.BiShutdown: boolean;
begin
if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0);
DeInit;
FReadBuffer := '';
Result := True;
end;
function TSSLCryptLib.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
var
l: integer;
begin
FLastError := 0;
FLastErrorDesc := '';
SSLCheck(cryptPushData(FCryptSession, Buffer, Len, L));
cryptFlushData(FcryptSession);
Result := l;
end;
function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
var
l: integer;
begin
FLastError := 0;
FLastErrorDesc := '';
if Length(FReadBuffer) = 0 then
FReadBuffer := PopAll;
if Len > Length(FReadBuffer) then
Len := Length(FReadBuffer);
Move(Pointer(FReadBuffer)^, buffer^, Len);
Delete(FReadBuffer, 1, Len);
Result := Len;
end;
function TSSLCryptLib.WaitingData: Integer;
begin
Result := Length(FReadBuffer);
end;
function TSSLCryptLib.GetSSLVersion: string;
var
x: integer;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x);
if FSSLType in [LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_all] then
case x of
0:
Result := 'SSLv3';
1:
Result := 'TLSv1';
2:
Result := 'TLSv1.1';
end;
if FSSLType in [LT_SSHv2] then
case x of
0:
Result := 'SSHv1';
1:
Result := 'SSHv2';
end;
end;
function TSSLCryptLib.GetPeerSubject: string;
var
cert: CRYPT_CERTIFICATE;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTNAME, CRYPT_UNUSED);
Result := GetString(cert, CRYPT_CERTINFO_DN);
cryptDestroyCert(cert);
end;
function TSSLCryptLib.GetPeerName: string;
var
cert: CRYPT_CERTIFICATE;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED);
Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME);
cryptDestroyCert(cert);
end;
function TSSLCryptLib.GetPeerIssuer: string;
var
cert: CRYPT_CERTIFICATE;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED);
Result := GetString(cert, CRYPT_CERTINFO_DN);
cryptDestroyCert(cert);
end;
function TSSLCryptLib.GetPeerFingerprint: string;
var
cert: CRYPT_CERTIFICATE;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
Result := GetString(cert, CRYPT_CERTINFO_FINGERPRINT);
Result := MD5(Result);
cryptDestroyCert(cert);
end;
{==============================================================================}
initialization
if cryptInit = CRYPT_OK then
SSLImplementation := TSSLCryptLib;
cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL);
finalization
cryptEnd;
end.
TransGUI/synapse/source/lib/snmpsend.pas 0000644 0000000 0000000 00000103776 11366572451 017324 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 003.000.010 |
|==============================================================================|
| Content: SNMP client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Jean-Fabien Connault (cycocrew@worldnet.fr) |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(SNMP client)
Supports SNMPv1 include traps, SNMPv2c and SNMPv3 include authorization
(encryption not yet supported!)
Used RFC: RFC-1157, RFC-1901, RFC-3412, RFC-3414, RFC-3416
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit snmpsend;
interface
uses
Classes, SysUtils,
blcksock, synautil, asn1util, synaip, synacode;
const
cSnmpProtocol = '161';
cSnmpTrapProtocol = '162';
SNMP_V1 = 0;
SNMP_V2C = 1;
SNMP_V3 = 3;
//PDU type
PDUGetRequest = $A0;
PDUGetNextRequest = $A1;
PDUGetResponse = $A2;
PDUSetRequest = $A3;
PDUTrap = $A4; //Obsolete
//for SNMPv2
PDUGetBulkRequest = $A5;
PDUInformRequest = $A6;
PDUTrapV2 = $A7;
PDUReport = $A8;
//errors
ENoError = 0;
ETooBig = 1;
ENoSuchName = 2;
EBadValue = 3;
EReadOnly = 4;
EGenErr = 5;
//errors SNMPv2
ENoAccess = 6;
EWrongType = 7;
EWrongLength = 8;
EWrongEncoding = 9;
EWrongValue = 10;
ENoCreation = 11;
EInconsistentValue = 12;
EResourceUnavailable = 13;
ECommitFailed = 14;
EUndoFailed = 15;
EAuthorizationError = 16;
ENotWritable = 17;
EInconsistentName = 18;
type
{:@abstract(Possible values for SNMPv3 flags.)
This flags specify level of authorization and encryption.}
TV3Flags = (
NoAuthNoPriv,
AuthNoPriv,
AuthPriv);
{:@abstract(Type of SNMPv3 authorization)}
TV3Auth = (
AuthMD5,
AuthSHA1);
{:@abstract(Data object with one record of MIB OID and corresponding values.)}
TSNMPMib = class(TObject)
protected
FOID: AnsiString;
FValue: AnsiString;
FValueType: Integer;
published
{:OID number in string format.}
property OID: AnsiString read FOID write FOID;
{:Value of OID object in string format.}
property Value: AnsiString read FValue write FValue;
{:Define type of Value. Supported values are defined in @link(asn1util).
For queries use ASN1_NULL, becouse you don't know type in response!}
property ValueType: Integer read FValueType write FValueType;
end;
{:@abstract(It holding all information for SNMPv3 agent synchronization)
Used internally.}
TV3Sync = record
EngineID: AnsiString;
EngineBoots: integer;
EngineTime: integer;
EngineStamp: Cardinal;
end;
{:@abstract(Data object abstracts SNMP data packet)}
TSNMPRec = class(TObject)
protected
FVersion: Integer;
FPDUType: Integer;
FID: Integer;
FErrorStatus: Integer;
FErrorIndex: Integer;
FCommunity: AnsiString;
FSNMPMibList: TList;
FMaxSize: Integer;
FFlags: TV3Flags;
FFlagReportable: Boolean;
FContextEngineID: AnsiString;
FContextName: AnsiString;
FAuthMode: TV3Auth;
FAuthEngineID: AnsiString;
FAuthEngineBoots: integer;
FAuthEngineTime: integer;
FAuthEngineTimeStamp: cardinal;
FUserName: AnsiString;
FPassword: AnsiString;
FAuthKey: AnsiString;
FPrivKey: AnsiString;
FOldTrapEnterprise: AnsiString;
FOldTrapHost: AnsiString;
FOldTrapGen: Integer;
FOldTrapSpec: Integer;
FOldTrapTimeTicks: Integer;
function Pass2Key(const Value: AnsiString): AnsiString;
public
constructor Create;
destructor Destroy; override;
{:Decode SNMP packet in buffer to object properties.}
function DecodeBuf(const Buffer: AnsiString): Boolean;
{:Encode obeject properties to SNMP packet.}
function EncodeBuf: AnsiString;
{:Clears all object properties to default values.}
procedure Clear;
{:Add entry to @link(SNMPMibList). For queries use value as empty string,
and ValueType as ASN1_NULL.}
procedure MIBAdd(const MIB, Value: AnsiString; ValueType: Integer);
{:Delete entry from @link(SNMPMibList).}
procedure MIBDelete(Index: Integer);
{:Search @link(SNMPMibList) list for MIB and return correspond value.}
function MIBGet(const MIB: AnsiString): AnsiString;
{:return number of entries in MIB array.}
function MIBCount: integer;
{:Return MIB information from given row of MIB array.}
function MIBByIndex(Index: Integer): TSNMPMib;
{:List of @link(TSNMPMib) objects.}
property SNMPMibList: TList read FSNMPMibList;
published
{:Version of SNMP packet. Default value is 0 (SNMP ver. 1). You can use
value 1 for SNMPv2c or value 3 for SNMPv3.}
property Version: Integer read FVersion write FVersion;
{:Community string for autorize access to SNMP server. (Case sensitive!)
Community string is not used in SNMPv3! Use @link(Username) and
@link(password) instead!}
property Community: AnsiString read FCommunity write FCommunity;
{:Define type of SNMP operation.}
property PDUType: Integer read FPDUType write FPDUType;
{:Contains ID number. Not need to use.}
property ID: Integer read FID write FID;
{:When packet is reply, contains error code. Supported values are defined by
E* constants.}
property ErrorStatus: Integer read FErrorStatus write FErrorStatus;
{:Point to error position in reply packet. Not usefull for users. It only
good for debugging!}
property ErrorIndex: Integer read FErrorIndex write FErrorIndex;
{:special value for GetBulkRequest of SNMPv2 and v3.}
property NonRepeaters: Integer read FErrorStatus write FErrorStatus;
{:special value for GetBulkRequest of SNMPv2 and v3.}
property MaxRepetitions: Integer read FErrorIndex write FErrorIndex;
{:Maximum message size in bytes for SNMPv3. For sending is default 1472 bytes.}
property MaxSize: Integer read FMaxSize write FMaxSize;
{:Specify if message is authorised or encrypted. Used only in SNMPv3, and
encryption is not yet supported!}
property Flags: TV3Flags read FFlags write FFlags;
{:For SNMPv3.... If is @true, SNMP agent must send reply (at least with some
error).}
property FlagReportable: Boolean read FFlagReportable write FFlagReportable;
{:For SNMPv3. If not specified, is used value from @link(AuthEngineID)}
property ContextEngineID: AnsiString read FContextEngineID write FContextEngineID;
{:For SNMPv3.}
property ContextName: AnsiString read FContextName write FContextName;
{:For SNMPv3. Specify Authorization mode. (specify used hash for
authorization)}
property AuthMode: TV3Auth read FAuthMode write FAuthMode;
{:value used by SNMPv3 authorisation for synchronization with SNMP agent.}
property AuthEngineID: AnsiString read FAuthEngineID write FAuthEngineID;
{:value used by SNMPv3 authorisation for synchronization with SNMP agent.}
property AuthEngineBoots: Integer read FAuthEngineBoots write FAuthEngineBoots;
{:value used by SNMPv3 authorisation for synchronization with SNMP agent.}
property AuthEngineTime: Integer read FAuthEngineTime write FAuthEngineTime;
{:value used by SNMPv3 authorisation for synchronization with SNMP agent.}
property AuthEngineTimeStamp: Cardinal read FAuthEngineTimeStamp Write FAuthEngineTimeStamp;
{:SNMPv3 authorization username}
property UserName: AnsiString read FUserName write FUserName;
{:SNMPv3 authorization password}
property Password: AnsiString read FPassword write FPassword;
{:For SNMPv3. Computed Athorization key from @link(password).}
property AuthKey: AnsiString read FAuthKey write FAuthKey;
{:For SNMPv3. Encryption key for message encryption. Not yet used!}
property PrivKey: AnsiString read FPrivKey write FPrivKey;
{:MIB value to identify the object that sent the TRAPv1.}
property OldTrapEnterprise: AnsiString read FOldTrapEnterprise write FOldTrapEnterprise;
{:Address of TRAPv1 sender (IP address).}
property OldTrapHost: AnsiString read FOldTrapHost write FOldTrapHost;
{:Generic TRAPv1 identification.}
property OldTrapGen: Integer read FOldTrapGen write FOldTrapGen;
{:Specific TRAPv1 identification.}
property OldTrapSpec: Integer read FOldTrapSpec write FOldTrapSpec;
{:Number of 1/100th of seconds since last reboot or power up. (for TRAPv1)}
property OldTrapTimeTicks: Integer read FOldTrapTimeTicks write FOldTrapTimeTicks;
end;
{:@abstract(Implementation of SNMP protocol.)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TSNMPSend = class(TSynaClient)
protected
FSock: TUDPBlockSocket;
FBuffer: AnsiString;
FHostIP: AnsiString;
FQuery: TSNMPRec;
FReply: TSNMPRec;
function InternalSendSnmp(const Value: TSNMPRec): Boolean;
function InternalRecvSnmp(const Value: TSNMPRec): Boolean;
function InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean;
function GetV3EngineID: AnsiString;
function GetV3Sync: TV3Sync;
public
constructor Create;
destructor Destroy; override;
{:Connects to a Host and send there query. If in timeout SNMP server send
back query, result is @true. If is used SNMPv3, then it synchronize self
with SNMPv3 agent first. (It is needed for SNMPv3 auhorization!)}
function SendRequest: Boolean;
{:Send SNMP packet only, but not waits for reply. Good for sending traps.}
function SendTrap: Boolean;
{:Receive SNMP packet only. Good for receiving traps.}
function RecvTrap: Boolean;
{:Mapped to @link(SendRequest) internally. This function is only for
backward compatibility.}
function DoIt: Boolean;
published
{:contains raw binary form of SNMP packet. Good for debugging.}
property Buffer: AnsiString read FBuffer write FBuffer;
{:After SNMP operation hold IP address of remote side.}
property HostIP: AnsiString read FHostIP;
{:Data object contains SNMP query.}
property Query: TSNMPRec read FQuery;
{:Data object contains SNMP reply.}
property Reply: TSNMPRec read FReply;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TUDPBlockSocket read FSock;
end;
{:A very useful function and example of its use would be found in the TSNMPSend
object. It implements basic GET method of the SNMP protocol. The MIB value is
located in the "OID" variable, and is sent to the requested "SNMPHost" with
the proper "Community" access identifier. Upon a successful retrieval, "Value"
will contain the information requested. If the SNMP operation is successful,
the result returns @true.}
function SNMPGet(const OID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
{:This is useful function and example of use TSNMPSend object. It implements
the basic SET method of the SNMP protocol. If the SNMP operation is successful,
the result is @true. "Value" is value of MIB Oid for "SNMPHost" with "Community"
access identifier. You must specify "ValueType" too.}
function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; ValueType: Integer): Boolean;
{:A very useful function and example of its use would be found in the TSNMPSend
object. It implements basic GETNEXT method of the SNMP protocol. The MIB value
is located in the "OID" variable, and is sent to the requested "SNMPHost" with
the proper "Community" access identifier. Upon a successful retrieval, "Value"
will contain the information requested. If the SNMP operation is successful,
the result returns @true.}
function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
{:A very useful function and example of its use would be found in the TSNMPSend
object. It implements basic read of SNMP MIB tables. As BaseOID you must
specify basic MIB OID of requested table (base IOD is OID without row and
column specificator!)
Table is readed into stringlist, where each string is comma delimited string.
Warning: this function is not have best performance. For better performance
you must write your own function. best performace you can get by knowledge
of structuture of table and by more then one MIB on one query. }
function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean;
{:A very useful function and example of its use would be found in the TSNMPSend
object. It implements basic read of SNMP MIB table element. As BaseOID you must
specify basic MIB OID of requested table (base IOD is OID without row and
column specificator!)
As next you must specify identificator of row and column for specify of needed
field of table.}
function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
{:A very useful function and example of its use would be found in the TSNMPSend
object. It implements a TRAPv1 to send with all data in the parameters.}
function SendTrap(const Dest, Source, Enterprise, Community: AnsiString;
Generic, Specific, Seconds: Integer; const MIBName, MIBValue: AnsiString;
MIBtype: Integer): Integer;
{:A very useful function and example of its use would be found in the TSNMPSend
object. It receives a TRAPv1 and returns all the data that comes with it.}
function RecvTrap(var Dest, Source, Enterprise, Community: AnsiString;
var Generic, Specific, Seconds: Integer; const MIBName,
MIBValue: TStringList): Integer;
implementation
{==============================================================================}
constructor TSNMPRec.Create;
begin
inherited Create;
FSNMPMibList := TList.Create;
Clear;
FID := 1;
FMaxSize := 1472;
end;
destructor TSNMPRec.Destroy;
var
i: Integer;
begin
for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(FSNMPMibList[i]).Free;
FSNMPMibList.Clear;
FSNMPMibList.Free;
inherited Destroy;
end;
function TSNMPRec.Pass2Key(const Value: AnsiString): AnsiString;
var
key: AnsiString;
begin
case FAuthMode of
AuthMD5:
begin
key := MD5LongHash(Value, 1048576);
Result := MD5(key + FAuthEngineID + key);
end;
AuthSHA1:
begin
key := SHA1LongHash(Value, 1048576);
Result := SHA1(key + FAuthEngineID + key);
end;
else
Result := '';
end;
end;
function TSNMPRec.DecodeBuf(const Buffer: AnsiString): Boolean;
var
Pos: Integer;
EndPos: Integer;
sm, sv: AnsiString;
Svt: Integer;
s: AnsiString;
Spos: integer;
x: Byte;
begin
Clear;
Result := False;
if Length(Buffer) < 2 then
Exit;
if (Ord(Buffer[1]) and $20) = 0 then
Exit;
Pos := 2;
EndPos := ASNDecLen(Pos, Buffer);
if Length(Buffer) < (EndPos + 2) then
Exit;
Self.FVersion := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
if FVersion = 3 then
begin
ASNItem(Pos, Buffer, Svt); //header data seq
ASNItem(Pos, Buffer, Svt); //ID
FMaxSize := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
s := ASNItem(Pos, Buffer, Svt);
x := 0;
if s <> '' then
x := Ord(s[1]);
FFlagReportable := (x and 4) > 0;
x := x and 3;
case x of
1:
FFlags := AuthNoPriv;
3:
FFlags := AuthPriv;
else
FFlags := NoAuthNoPriv;
end;
x := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
s := ASNItem(Pos, Buffer, Svt); //SecurityParameters
//if SecurityModel is USM, then try to decode SecurityParameters
if (x = 3) and (s <> '') then
begin
spos := 1;
ASNItem(SPos, s, Svt);
FAuthEngineID := ASNItem(SPos, s, Svt);
FAuthEngineBoots := StrToIntDef(ASNItem(SPos, s, Svt), 0);
FAuthEngineTime := StrToIntDef(ASNItem(SPos, s, Svt), 0);
FAuthEngineTimeStamp := GetTick;
FUserName := ASNItem(SPos, s, Svt);
FAuthKey := ASNItem(SPos, s, Svt);
FPrivKey := ASNItem(SPos, s, Svt);
end;
//scopedPDU
s := ASNItem(Pos, Buffer, Svt);
if Svt = ASN1_OCTSTR then
begin
//decrypt!
end;
FContextEngineID := ASNItem(Pos, Buffer, Svt);
FContextName := ASNItem(Pos, Buffer, Svt);
end
else
begin
//old packet
Self.FCommunity := ASNItem(Pos, Buffer, Svt);
end;
ASNItem(Pos, Buffer, Svt);
Self.FPDUType := Svt;
if Self.FPDUType = PDUTrap then
begin
FOldTrapEnterprise := ASNItem(Pos, Buffer, Svt);
FOldTrapHost := ASNItem(Pos, Buffer, Svt);
FOldTrapGen := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
FOldTrapSpec := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
FOldTrapTimeTicks := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
end
else
begin
Self.FID := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.FErrorStatus := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.FErrorIndex := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
end;
ASNItem(Pos, Buffer, Svt);
while Pos < EndPos do
begin
ASNItem(Pos, Buffer, Svt);
Sm := ASNItem(Pos, Buffer, Svt);
Sv := ASNItem(Pos, Buffer, Svt);
Self.MIBAdd(sm, sv, Svt);
end;
Result := True;
end;
function TSNMPRec.EncodeBuf: AnsiString;
var
s: AnsiString;
SNMPMib: TSNMPMib;
n: Integer;
pdu, head, auth, authbeg: AnsiString;
x: Byte;
begin
pdu := '';
for n := 0 to FSNMPMibList.Count - 1 do
begin
SNMPMib := TSNMPMib(FSNMPMibList[n]);
case SNMPMib.ValueType of
ASN1_INT:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(ASNEncInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(ASNEncUInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
ASN1_OBJID:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(MibToID(SNMPMib.Value), SNMPMib.ValueType);
ASN1_IPADDR:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(IPToID(SNMPMib.Value), SNMPMib.ValueType);
ASN1_NULL:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject('', ASN1_NULL);
else
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(SNMPMib.Value, SNMPMib.ValueType);
end;
pdu := pdu + ASNObject(s, ASN1_SEQ);
end;
pdu := ASNObject(pdu, ASN1_SEQ);
if Self.FPDUType = PDUTrap then
pdu := ASNObject(MibToID(FOldTrapEnterprise), ASN1_OBJID) +
ASNObject(IPToID(FOldTrapHost), ASN1_IPADDR) +
ASNObject(ASNEncInt(FOldTrapGen), ASN1_INT) +
ASNObject(ASNEncInt(FOldTrapSpec), ASN1_INT) +
ASNObject(ASNEncUInt(FOldTrapTimeTicks), ASN1_TIMETICKS) +
pdu
else
pdu := ASNObject(ASNEncInt(Self.FID), ASN1_INT) +
ASNObject(ASNEncInt(Self.FErrorStatus), ASN1_INT) +
ASNObject(ASNEncInt(Self.FErrorIndex), ASN1_INT) +
pdu;
pdu := ASNObject(pdu, Self.FPDUType);
if FVersion = 3 then
begin
if FContextEngineID = '' then
FContextEngineID := FAuthEngineID;
//complete PDUv3...
pdu := ASNObject(FContextEngineID, ASN1_OCTSTR)
+ ASNObject(FContextName, ASN1_OCTSTR)
+ pdu;
//maybe encrypt pdu... in future
pdu := ASNObject(pdu, ASN1_SEQ);
//prepare flags
case FFlags of
AuthNoPriv:
x := 1;
AuthPriv:
x := 3;
else
x := 0;
end;
if FFlagReportable then
x := x or 4;
head := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT);
s := ASNObject(ASNEncInt(FID), ASN1_INT)
+ ASNObject(ASNEncInt(FMaxSize), ASN1_INT)
+ ASNObject(AnsiChar(x), ASN1_OCTSTR)
//encode security model USM
+ ASNObject(ASNEncInt(3), ASN1_INT);
head := head + ASNObject(s, ASN1_SEQ);
//compute engine time difference
x := TickDelta(FAuthEngineTimeStamp, GetTick) div 1000;
authbeg := ASNObject(FAuthEngineID, ASN1_OCTSTR)
+ ASNObject(ASNEncInt(FAuthEngineBoots), ASN1_INT)
+ ASNObject(ASNEncInt(FAuthEngineTime + x), ASN1_INT)
+ ASNObject(FUserName, ASN1_OCTSTR);
case FFlags of
AuthNoPriv,
AuthPriv:
begin
s := authbeg + ASNObject(StringOfChar(#0, 12), ASN1_OCTSTR)
+ ASNObject(FPrivKey, ASN1_OCTSTR);
s := ASNObject(s, ASN1_SEQ);
s := head + ASNObject(s, ASN1_OCTSTR);
s := ASNObject(s + pdu, ASN1_SEQ);
//in s is entire packet without auth info...
case FAuthMode of
AuthMD5:
begin
s := HMAC_MD5(s, Pass2Key(FPassword) + StringOfChar(#0, 48));
//strip to HMAC-MD5-96
delete(s, 13, 4);
end;
AuthSHA1:
begin
s := HMAC_SHA1(s, Pass2Key(FPassword) + StringOfChar(#0, 44));
//strip to HMAC-SHA-96
delete(s, 13, 8);
end;
else
s := '';
end;
FAuthKey := s;
end;
end;
auth := authbeg + ASNObject(FAuthKey, ASN1_OCTSTR)
+ ASNObject(FPrivKey, ASN1_OCTSTR);
auth := ASNObject(auth, ASN1_SEQ);
head := head + ASNObject(auth, ASN1_OCTSTR);
Result := ASNObject(head + pdu, ASN1_SEQ);
end
else
begin
head := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT) +
ASNObject(Self.FCommunity, ASN1_OCTSTR);
Result := ASNObject(head + pdu, ASN1_SEQ);
end;
inc(self.FID);
end;
procedure TSNMPRec.Clear;
var
i: Integer;
begin
FVersion := SNMP_V1;
FCommunity := 'public';
FUserName := '';
FPassword := '';
FPDUType := 0;
FErrorStatus := 0;
FErrorIndex := 0;
for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(FSNMPMibList[i]).Free;
FSNMPMibList.Clear;
FOldTrapEnterprise := '';
FOldTrapHost := '';
FOldTrapGen := 0;
FOldTrapSpec := 0;
FOldTrapTimeTicks := 0;
FFlags := NoAuthNoPriv;
FFlagReportable := false;
FContextEngineID := '';
FContextName := '';
FAuthMode := AuthMD5;
FAuthEngineID := '';
FAuthEngineBoots := 0;
FAuthEngineTime := 0;
FAuthEngineTimeStamp := 0;
FAuthKey := '';
FPrivKey := '';
end;
procedure TSNMPRec.MIBAdd(const MIB, Value: AnsiString; ValueType: Integer);
var
SNMPMib: TSNMPMib;
begin
SNMPMib := TSNMPMib.Create;
SNMPMib.OID := MIB;
SNMPMib.Value := Value;
SNMPMib.ValueType := ValueType;
FSNMPMibList.Add(SNMPMib);
end;
procedure TSNMPRec.MIBDelete(Index: Integer);
begin
if (Index >= 0) and (Index < MIBCount) then
begin
TSNMPMib(FSNMPMibList[Index]).Free;
FSNMPMibList.Delete(Index);
end;
end;
function TSNMPRec.MIBCount: integer;
begin
Result := FSNMPMibList.Count;
end;
function TSNMPRec.MIBByIndex(Index: Integer): TSNMPMib;
begin
Result := nil;
if (Index >= 0) and (Index < MIBCount) then
Result := TSNMPMib(FSNMPMibList[Index]);
end;
function TSNMPRec.MIBGet(const MIB: AnsiString): AnsiString;
var
i: Integer;
begin
Result := '';
for i := 0 to MIBCount - 1 do
begin
if ((TSNMPMib(FSNMPMibList[i])).OID = MIB) then
begin
Result := (TSNMPMib(FSNMPMibList[i])).Value;
Break;
end;
end;
end;
{==============================================================================}
constructor TSNMPSend.Create;
begin
inherited Create;
FQuery := TSNMPRec.Create;
FReply := TSNMPRec.Create;
FQuery.Clear;
FReply.Clear;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FTimeout := 5000;
FTargetPort := cSnmpProtocol;
FHostIP := '';
end;
destructor TSNMPSend.Destroy;
begin
FSock.Free;
FReply.Free;
FQuery.Free;
inherited Destroy;
end;
function TSNMPSend.InternalSendSnmp(const Value: TSNMPRec): Boolean;
begin
FBuffer := Value.EncodeBuf;
FSock.SendString(FBuffer);
Result := FSock.LastError = 0;
end;
function TSNMPSend.InternalRecvSnmp(const Value: TSNMPRec): Boolean;
begin
Result := False;
FReply.Clear;
FHostIP := cAnyHost;
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
FHostIP := FSock.GetRemoteSinIP;
Result := Value.DecodeBuf(FBuffer);
end;
end;
function TSNMPSend.InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean;
begin
Result := False;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
if InternalSendSnmp(QValue) then
Result := InternalRecvSnmp(RValue);
end;
function TSNMPSend.SendRequest: Boolean;
var
sync: TV3Sync;
begin
Result := False;
if FQuery.FVersion = 3 then
begin
sync := GetV3Sync;
FQuery.AuthEngineBoots := Sync.EngineBoots;
FQuery.AuthEngineTime := Sync.EngineTime;
FQuery.AuthEngineTimeStamp := Sync.EngineStamp;
FQuery.AuthEngineID := Sync.EngineID;
end;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
if InternalSendSnmp(FQuery) then
Result := InternalRecvSnmp(FReply);
end;
function TSNMPSend.SendTrap: Boolean;
begin
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
Result := InternalSendSnmp(FQuery);
end;
function TSNMPSend.RecvTrap: Boolean;
begin
FSock.Bind(FIPInterface, FTargetPort);
Result := InternalRecvSnmp(FReply);
end;
function TSNMPSend.DoIt: Boolean;
begin
Result := SendRequest;
end;
function TSNMPSend.GetV3EngineID: AnsiString;
var
DisQuery: TSNMPRec;
begin
Result := '';
DisQuery := TSNMPRec.Create;
try
DisQuery.Version := 3;
DisQuery.UserName := '';
DisQuery.FlagReportable := True;
DisQuery.PDUType := PDUGetRequest;
if InternalSendRequest(DisQuery, FReply) then
Result := FReply.FAuthEngineID;
finally
DisQuery.Free;
end;
end;
function TSNMPSend.GetV3Sync: TV3Sync;
var
SyncQuery: TSNMPRec;
begin
Result.EngineID := GetV3EngineID;
Result.EngineBoots := FReply.AuthEngineBoots;
Result.EngineTime := FReply.AuthEngineTime;
Result.EngineStamp := FReply.AuthEngineTimeStamp;
if Result.EngineTime = 0 then
begin
//still not have sync...
SyncQuery := TSNMPRec.Create;
try
SyncQuery.Version := 3;
SyncQuery.UserName := FQuery.UserName;
SyncQuery.Password := FQuery.Password;
SyncQuery.FlagReportable := True;
SyncQuery.Flags := FQuery.Flags;
SyncQuery.PDUType := PDUGetRequest;
SyncQuery.AuthEngineID := FReply.FAuthEngineID;
if InternalSendRequest(SyncQuery, FReply) then
begin
Result.EngineBoots := FReply.AuthEngineBoots;
Result.EngineTime := FReply.AuthEngineTime;
Result.EngineStamp := FReply.AuthEngineTimeStamp;
end;
finally
SyncQuery.Free;
end;
end;
end;
{==============================================================================}
function SNMPGet(const OID, Community, SNMPHost: AnsiString; var Value: AnsiString): 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.TargetHost := SNMPHost;
Result := SNMPSend.SendRequest;
Value := '';
if Result then
Value := SNMPSend.Reply.MIBGet(OID);
finally
SNMPSend.Free;
end;
end;
function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; 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.TargetHost := SNMPHost;
Result := SNMPSend.Sendrequest = True;
finally
SNMPSend.Free;
end;
end;
function InternalGetNext(const SNMPSend: TSNMPSend; var OID: AnsiString;
const Community: AnsiString; var Value: AnsiString): Boolean;
begin
SNMPSend.Query.Clear;
SNMPSend.Query.ID := SNMPSend.Query.ID + 1;
SNMPSend.Query.Community := Community;
SNMPSend.Query.PDUType := PDUGetNextRequest;
SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL);
Result := SNMPSend.Sendrequest;
Value := '';
if Result then
if SNMPSend.Reply.SNMPMibList.Count > 0 then
begin
OID := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).OID;
Value := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).Value;
end;
end;
function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
var
SNMPSend: TSNMPSend;
begin
SNMPSend := TSNMPSend.Create;
try
SNMPSend.TargetHost := SNMPHost;
Result := InternalGetNext(SNMPSend, OID, Community, Value);
finally
SNMPSend.Free;
end;
end;
function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean;
var
OID: AnsiString;
s: AnsiString;
col,row: String;
x: integer;
SNMPSend: TSNMPSend;
RowList: TStringList;
begin
Value.Clear;
SNMPSend := TSNMPSend.Create;
RowList := TStringList.Create;
try
SNMPSend.TargetHost := SNMPHost;
OID := BaseOID;
repeat
Result := InternalGetNext(SNMPSend, OID, Community, s);
if Pos(BaseOID, OID) <> 1 then
break;
row := separateright(oid, baseoid + '.');
col := fetch(row, '.');
if IsBinaryString(s) then
s := StrToHex(s);
x := RowList.indexOf(Row);
if x < 0 then
begin
x := RowList.add(Row);
Value.Add('');
end;
if (Value[x] <> '') then
Value[x] := Value[x] + ',';
Value[x] := Value[x] + AnsiQuotedStr(s, '"');
until not result;
finally
SNMPSend.Free;
RowList.Free;
end;
end;
function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
var
s: AnsiString;
begin
s := BaseOID + '.' + ColID + '.' + RowID;
Result := SnmpGet(s, Community, SNMPHost, Value);
end;
function SendTrap(const Dest, Source, Enterprise, Community: AnsiString;
Generic, Specific, Seconds: Integer; const MIBName, MIBValue: AnsiString;
MIBtype: Integer): Integer;
var
SNMPSend: TSNMPSend;
begin
SNMPSend := TSNMPSend.Create;
try
SNMPSend.TargetHost := Dest;
SNMPSend.TargetPort := cSnmpTrapProtocol;
SNMPSend.Query.Community := Community;
SNMPSend.Query.Version := SNMP_V1;
SNMPSend.Query.PDUType := PDUTrap;
SNMPSend.Query.OldTrapHost := Source;
SNMPSend.Query.OldTrapEnterprise := Enterprise;
SNMPSend.Query.OldTrapGen := Generic;
SNMPSend.Query.OldTrapSpec := Specific;
SNMPSend.Query.OldTrapTimeTicks := Seconds;
SNMPSend.Query.MIBAdd(MIBName, MIBValue, MIBType);
Result := Ord(SNMPSend.SendTrap);
finally
SNMPSend.Free;
end;
end;
function RecvTrap(var Dest, Source, Enterprise, Community: AnsiString;
var Generic, Specific, Seconds: Integer;
const MIBName, MIBValue: TStringList): Integer;
var
SNMPSend: TSNMPSend;
i: Integer;
begin
SNMPSend := TSNMPSend.Create;
try
Result := 0;
SNMPSend.TargetPort := cSnmpTrapProtocol;
if SNMPSend.RecvTrap then
begin
Result := 1;
Dest := SNMPSend.HostIP;
Community := SNMPSend.Reply.Community;
Source := SNMPSend.Reply.OldTrapHost;
Enterprise := SNMPSend.Reply.OldTrapEnterprise;
Generic := SNMPSend.Reply.OldTrapGen;
Specific := SNMPSend.Reply.OldTrapSpec;
Seconds := SNMPSend.Reply.OldTrapTimeTicks;
MIBName.Clear;
MIBValue.Clear;
for i := 0 to SNMPSend.Reply.SNMPMibList.Count - 1 do
begin
MIBName.Add(TSNMPMib(SNMPSend.Reply.SNMPMibList[i]).OID);
MIBValue.Add(TSNMPMib(SNMPSend.Reply.SNMPMibList[i]).Value);
end;
end;
finally
SNMPSend.Free;
end;
end;
end.
TransGUI/synapse/source/lib/clamsend.pas 0000644 0000000 0000000 00000021536 11366572451 017254 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.001.001 |
|==============================================================================|
| Content: ClamAV-daemon client |
|==============================================================================|
| Copyright (c)2005-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract( ClamAV-daemon client)
This unit is capable to do antivirus scan of your data by TCP channel to ClamD
daemon from ClamAV. See more about ClamAV on @LINK(http://www.clamav.net)
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit clamsend;
interface
uses
SysUtils, Classes,
synsock, blcksock, synautil;
const
cClamProtocol = '3310';
type
{:@abstract(Implementation of ClamAV-daemon client protocol)
By this class you can scan any your data by ClamAV opensource antivirus.
This class can connect to ClamD by TCP channel, send your data to ClamD
and read result.}
TClamSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FDSock: TTCPBlockSocket;
FSession: boolean;
function Login: boolean; virtual;
function Logout: Boolean; virtual;
function OpenStream: Boolean; virtual;
public
constructor Create;
destructor Destroy; override;
{:Call any command to ClamD. Used internally by other methods.}
function DoCommand(const Value: AnsiString): AnsiString; virtual;
{:Return ClamAV version and version of loaded databases.}
function GetVersion: AnsiString; virtual;
{:Scan content of TStrings.}
function ScanStrings(const Value: TStrings): AnsiString; virtual;
{:Scan content of TStream.}
function ScanStream(const Value: TStream): AnsiString; virtual;
{:Scan content of TStrings by new 0.95 API.}
function ScanStrings2(const Value: TStrings): AnsiString; virtual;
{:Scan content of TStream by new 0.95 API.}
function ScanStream2(const Value: TStream): AnsiString; virtual;
published
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
{:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.}
property DSock: TTCPBlockSocket read FDSock;
{:Can turn-on session mode of communication with ClamD. Default is @false,
because ClamAV developers design their TCP code very badly and session mode
is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs
and this mode will be possible in future.}
property Session: boolean read FSession write FSession;
end;
implementation
constructor TClamSend.Create;
begin
inherited Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FDSock := TTCPBlockSocket.Create;
FDSock.Owner := self;
FTimeout := 60000;
FTargetPort := cClamProtocol;
FSession := false;
end;
destructor TClamSend.Destroy;
begin
Logout;
FDSock.Free;
FSock.Free;
inherited Destroy;
end;
function TClamSend.DoCommand(const Value: AnsiString): AnsiString;
begin
Result := '';
if not FSession then
FSock.CloseSocket
else
FSock.SendString(Value + LF);
if not FSession or (FSock.LastError <> 0) then
begin
if Login then
FSock.SendString(Value + LF)
else
Exit;
end;
Result := FSock.RecvTerminated(FTimeout, LF);
end;
function TClamSend.Login: boolean;
begin
Result := False;
Sock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError <> 0 then
Exit;
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError <> 0 then
Exit;
if FSession then
FSock.SendString('SESSION' + LF);
Result := FSock.LastError = 0;
end;
function TClamSend.Logout: Boolean;
begin
FSock.SendString('END' + LF);
Result := FSock.LastError = 0;
FSock.CloseSocket;
end;
function TClamSend.GetVersion: AnsiString;
begin
Result := DoCommand('nVERSION');
end;
function TClamSend.OpenStream: Boolean;
var
S: AnsiString;
begin
Result := False;
s := DoCommand('nSTREAM');
if (s <> '') and (Copy(s, 1, 4) = 'PORT') then
begin
s := SeparateRight(s, ' ');
FDSock.CloseSocket;
FDSock.Bind(FIPInterface, cAnyPort);
if FDSock.LastError <> 0 then
Exit;
FDSock.Connect(FTargetHost, s);
if FDSock.LastError <> 0 then
Exit;
Result := True;
end;
end;
function TClamSend.ScanStrings(const Value: TStrings): AnsiString;
begin
Result := '';
if OpenStream then
begin
DSock.SendString(Value.Text);
DSock.CloseSocket;
Result := FSock.RecvTerminated(FTimeout, LF);
end;
end;
function TClamSend.ScanStream(const Value: TStream): AnsiString;
begin
Result := '';
if OpenStream then
begin
DSock.SendStreamRaw(Value);
DSock.CloseSocket;
Result := FSock.RecvTerminated(FTimeout, LF);
end;
end;
function TClamSend.ScanStrings2(const Value: TStrings): AnsiString;
var
i: integer;
s: AnsiString;
begin
Result := '';
if not FSession then
FSock.CloseSocket
else
FSock.sendstring('nINSTREAM' + LF);
if not FSession or (FSock.LastError <> 0) then
begin
if Login then
FSock.sendstring('nINSTREAM' + LF)
else
Exit;
end;
s := Value.text;
i := length(s);
FSock.SendString(CodeLongint(i) + s + #0#0#0#0);
Result := FSock.RecvTerminated(FTimeout, LF);
end;
function TClamSend.ScanStream2(const Value: TStream): AnsiString;
var
i: integer;
begin
Result := '';
if not FSession then
FSock.CloseSocket
else
FSock.sendstring('nINSTREAM' + LF);
if not FSession or (FSock.LastError <> 0) then
begin
if Login then
FSock.sendstring('nINSTREAM' + LF)
else
Exit;
end;
i := value.Size;
FSock.SendString(CodeLongint(i));
FSock.SendStreamRaw(Value);
FSock.SendString(#0#0#0#0);
Result := FSock.RecvTerminated(FTimeout, LF);
end;
end.
TransGUI/synapse/source/lib/sslinux.pas 0000644 0000000 0000000 00000116017 11366572451 017172 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 002.000.009 |
|==============================================================================|
| Content: Socket Independent Platform Layer - Linux definition include |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@exclude}
{$IFDEF LINUX}
//{$DEFINE FORCEOLDAPI}
{Note about define FORCEOLDAPI:
If you activate this compiler directive, then is allways used old socket API
for name resolution. If you leave this directive inactive, then the new API
is used, when running system allows it.
For IPv6 support you must have new API!
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
interface
uses
SyncObjs, SysUtils, Classes,
synafpc,
Libc;
function InitSocketInterface(stack: string): Boolean;
function DestroySocketInterface: Boolean;
const
WinsockLevel = $0202;
type
u_char = Char;
u_short = Word;
u_int = Integer;
u_long = Longint;
pu_long = ^u_long;
pu_short = ^u_short;
TSocket = u_int;
TAddrFamily = integer;
TMemory = pointer;
const
DLLStackName = 'libc.so.6';
cLocalhost = '127.0.0.1';
cAnyHost = '0.0.0.0';
cBroadcast = '255.255.255.255';
c6Localhost = '::1';
c6AnyHost = '::0';
c6Broadcast = 'ffff::1';
cAnyPort = '0';
type
DWORD = Integer;
__fd_mask = LongWord;
const
__FD_SETSIZE = 1024;
__NFDBITS = 8 * sizeof(__fd_mask);
type
__fd_set = {packed} record
fds_bits: packed array[0..(__FD_SETSIZE div __NFDBITS)-1] of __fd_mask;
end;
TFDSet = __fd_set;
PFDSet = ^TFDSet;
const
FIONREAD = $541B;
FIONBIO = $5421;
FIOASYNC = $5452;
type
PTimeVal = ^TTimeVal;
TTimeVal = packed record
tv_sec: Longint;
tv_usec: Longint;
end;
const
IPPROTO_IP = 0; { Dummy }
IPPROTO_ICMP = 1; { Internet Control Message Protocol }
IPPROTO_IGMP = 2; { Internet Group Management Protocol}
IPPROTO_TCP = 6; { TCP }
IPPROTO_UDP = 17; { User Datagram Protocol }
IPPROTO_IPV6 = 41;
IPPROTO_ICMPV6 = 58;
IPPROTO_RM = 113;
IPPROTO_RAW = 255;
IPPROTO_MAX = 256;
type
PInAddr = ^TInAddr;
TInAddr = packed record
case integer of
0: (S_bytes: packed array [0..3] of byte);
1: (S_addr: u_long);
end;
PSockAddrIn = ^TSockAddrIn;
TSockAddrIn = packed record
case Integer of
0: (sin_family: u_short;
sin_port: u_short;
sin_addr: TInAddr;
sin_zero: array[0..7] of Char);
1: (sa_family: u_short;
sa_data: array[0..13] of Char)
end;
TIP_mreq = record
imr_multiaddr: TInAddr; { IP multicast address of group }
imr_interface: TInAddr; { local IP address of interface }
end;
PInAddr6 = ^TInAddr6;
TInAddr6 = packed record
case integer of
0: (S6_addr: packed array [0..15] of byte);
1: (u6_addr8: packed array [0..15] of byte);
2: (u6_addr16: packed array [0..7] of word);
3: (u6_addr32: packed array [0..3] of integer);
end;
PSockAddrIn6 = ^TSockAddrIn6;
TSockAddrIn6 = packed record
sin6_family: u_short; // AF_INET6
sin6_port: u_short; // Transport level port number
sin6_flowinfo: u_long; // IPv6 flow information
sin6_addr: TInAddr6; // IPv6 address
sin6_scope_id: u_long; // Scope Id: IF number for link-local
// SITE id for site-local
end;
TIPv6_mreq = record
ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address.
ipv6mr_interface: integer; // Interface index.
padding: u_long;
end;
PHostEnt = ^THostEnt;
THostent = record
h_name: PChar;
h_aliases: PPChar;
h_addrtype: Integer;
h_length: Cardinal;
case Byte of
0: (h_addr_list: PPChar);
1: (h_addr: PPChar);
end;
PNetEnt = ^TNetEnt;
TNetEnt = record
n_name: PChar;
n_aliases: PPChar;
n_addrtype: Integer;
n_net: uint32_t;
end;
PServEnt = ^TServEnt;
TServEnt = record
s_name: PChar;
s_aliases: PPChar;
s_port: Integer;
s_proto: PChar;
end;
PProtoEnt = ^TProtoEnt;
TProtoEnt = record
p_name: PChar;
p_aliases: ^PChar;
p_proto: u_short;
end;
const
INADDR_ANY = $00000000;
INADDR_LOOPBACK = $7F000001;
INADDR_BROADCAST = $FFFFFFFF;
INADDR_NONE = $FFFFFFFF;
ADDR_ANY = INADDR_ANY;
INVALID_SOCKET = TSocket(NOT(0));
SOCKET_ERROR = -1;
Const
IP_TOS = 1; { int; IP type of service and precedence. }
IP_TTL = 2; { int; IP time to live. }
IP_HDRINCL = 3; { int; Header is included with data. }
IP_OPTIONS = 4; { ip_opts; IP per-packet options. }
IP_ROUTER_ALERT = 5; { bool }
IP_RECVOPTS = 6; { bool }
IP_RETOPTS = 7; { bool }
IP_PKTINFO = 8; { bool }
IP_PKTOPTIONS = 9;
IP_PMTUDISC = 10; { obsolete name? }
IP_MTU_DISCOVER = 10; { int; see below }
IP_RECVERR = 11; { bool }
IP_RECVTTL = 12; { bool }
IP_RECVTOS = 13; { bool }
IP_MULTICAST_IF = 32; { in_addr; set/get IP multicast i/f }
IP_MULTICAST_TTL = 33; { u_char; set/get IP multicast ttl }
IP_MULTICAST_LOOP = 34; { i_char; set/get IP multicast loopback }
IP_ADD_MEMBERSHIP = 35; { ip_mreq; add an IP group membership }
IP_DROP_MEMBERSHIP = 36; { ip_mreq; drop an IP group membership }
SOL_SOCKET = 1;
SO_DEBUG = 1;
SO_REUSEADDR = 2;
SO_TYPE = 3;
SO_ERROR = 4;
SO_DONTROUTE = 5;
SO_BROADCAST = 6;
SO_SNDBUF = 7;
SO_RCVBUF = 8;
SO_KEEPALIVE = 9;
SO_OOBINLINE = 10;
SO_NO_CHECK = 11;
SO_PRIORITY = 12;
SO_LINGER = 13;
SO_BSDCOMPAT = 14;
SO_REUSEPORT = 15;
SO_PASSCRED = 16;
SO_PEERCRED = 17;
SO_RCVLOWAT = 18;
SO_SNDLOWAT = 19;
SO_RCVTIMEO = 20;
SO_SNDTIMEO = 21;
{ Security levels - as per NRL IPv6 - don't actually do anything }
SO_SECURITY_AUTHENTICATION = 22;
SO_SECURITY_ENCRYPTION_TRANSPORT = 23;
SO_SECURITY_ENCRYPTION_NETWORK = 24;
SO_BINDTODEVICE = 25;
{ Socket filtering }
SO_ATTACH_FILTER = 26;
SO_DETACH_FILTER = 27;
SOMAXCONN = 128;
IPV6_UNICAST_HOPS = 16;
IPV6_MULTICAST_IF = 17;
IPV6_MULTICAST_HOPS = 18;
IPV6_MULTICAST_LOOP = 19;
IPV6_JOIN_GROUP = 20;
IPV6_LEAVE_GROUP = 21;
MSG_NOSIGNAL = $4000; // Do not generate SIGPIPE.
// getnameinfo constants
NI_MAXHOST = 1025;
NI_MAXSERV = 32;
NI_NOFQDN = $4;
NI_NUMERICHOST = $1;
NI_NAMEREQD = $8;
NI_NUMERICSERV = $2;
NI_DGRAM = $10;
const
SOCK_STREAM = 1; { stream socket }
SOCK_DGRAM = 2; { datagram socket }
SOCK_RAW = 3; { raw-protocol interface }
SOCK_RDM = 4; { reliably-delivered message }
SOCK_SEQPACKET = 5; { sequenced packet stream }
{ TCP options. }
TCP_NODELAY = $0001;
{ Address families. }
AF_UNSPEC = 0; { unspecified }
AF_INET = 2; { internetwork: UDP, TCP, etc. }
AF_INET6 = 10; { Internetwork Version 6 }
AF_MAX = 24;
{ Protocol families, same as address families for now. }
PF_UNSPEC = AF_UNSPEC;
PF_INET = AF_INET;
PF_INET6 = AF_INET6;
PF_MAX = AF_MAX;
type
{ Structure used by kernel to store most addresses. }
PSockAddr = ^TSockAddr;
TSockAddr = TSockAddrIn;
{ Structure used by kernel to pass protocol information in raw sockets. }
PSockProto = ^TSockProto;
TSockProto = packed record
sp_family: u_short;
sp_protocol: u_short;
end;
type
PAddrInfo = ^TAddrInfo;
TAddrInfo = record
ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST.
ai_family: integer; // PF_xxx.
ai_socktype: integer; // SOCK_xxx.
ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6.
ai_addrlen: u_int; // Length of ai_addr.
ai_addr: PSockAddr; // Binary address.
ai_canonname: PChar; // Canonical name for nodename.
ai_next: PAddrInfo; // Next structure in linked list.
end;
const
// Flags used in "hints" argument to getaddrinfo().
AI_PASSIVE = $1; // Socket address will be used in bind() call.
AI_CANONNAME = $2; // Return canonical name in first ai_canonname.
AI_NUMERICHOST = $4; // Nodename must be a numeric address string.
type
{ Structure used for manipulating linger option. }
PLinger = ^TLinger;
TLinger = packed record
l_onoff: integer;
l_linger: integer;
end;
const
MSG_OOB = $01; // Process out-of-band data.
MSG_PEEK = $02; // Peek at incoming messages.
const
WSAEINTR = EINTR;
WSAEBADF = EBADF;
WSAEACCES = EACCES;
WSAEFAULT = EFAULT;
WSAEINVAL = EINVAL;
WSAEMFILE = EMFILE;
WSAEWOULDBLOCK = EWOULDBLOCK;
WSAEINPROGRESS = EINPROGRESS;
WSAEALREADY = EALREADY;
WSAENOTSOCK = ENOTSOCK;
WSAEDESTADDRREQ = EDESTADDRREQ;
WSAEMSGSIZE = EMSGSIZE;
WSAEPROTOTYPE = EPROTOTYPE;
WSAENOPROTOOPT = ENOPROTOOPT;
WSAEPROTONOSUPPORT = EPROTONOSUPPORT;
WSAESOCKTNOSUPPORT = ESOCKTNOSUPPORT;
WSAEOPNOTSUPP = EOPNOTSUPP;
WSAEPFNOSUPPORT = EPFNOSUPPORT;
WSAEAFNOSUPPORT = EAFNOSUPPORT;
WSAEADDRINUSE = EADDRINUSE;
WSAEADDRNOTAVAIL = EADDRNOTAVAIL;
WSAENETDOWN = ENETDOWN;
WSAENETUNREACH = ENETUNREACH;
WSAENETRESET = ENETRESET;
WSAECONNABORTED = ECONNABORTED;
WSAECONNRESET = ECONNRESET;
WSAENOBUFS = ENOBUFS;
WSAEISCONN = EISCONN;
WSAENOTCONN = ENOTCONN;
WSAESHUTDOWN = ESHUTDOWN;
WSAETOOMANYREFS = ETOOMANYREFS;
WSAETIMEDOUT = ETIMEDOUT;
WSAECONNREFUSED = ECONNREFUSED;
WSAELOOP = ELOOP;
WSAENAMETOOLONG = ENAMETOOLONG;
WSAEHOSTDOWN = EHOSTDOWN;
WSAEHOSTUNREACH = EHOSTUNREACH;
WSAENOTEMPTY = ENOTEMPTY;
WSAEPROCLIM = -1;
WSAEUSERS = EUSERS;
WSAEDQUOT = EDQUOT;
WSAESTALE = ESTALE;
WSAEREMOTE = EREMOTE;
WSASYSNOTREADY = -2;
WSAVERNOTSUPPORTED = -3;
WSANOTINITIALISED = -4;
WSAEDISCON = -5;
WSAHOST_NOT_FOUND = HOST_NOT_FOUND;
WSATRY_AGAIN = TRY_AGAIN;
WSANO_RECOVERY = NO_RECOVERY;
WSANO_DATA = -6;
EAI_BADFLAGS = -1; { Invalid value for `ai_flags' field. }
EAI_NONAME = -2; { NAME or SERVICE is unknown. }
EAI_AGAIN = -3; { Temporary failure in name resolution. }
EAI_FAIL = -4; { Non-recoverable failure in name res. }
EAI_NODATA = -5; { No address associated with NAME. }
EAI_FAMILY = -6; { `ai_family' not supported. }
EAI_SOCKTYPE = -7; { `ai_socktype' not supported. }
EAI_SERVICE = -8; { SERVICE not supported for `ai_socktype'. }
EAI_ADDRFAMILY = -9; { Address family for NAME not supported. }
EAI_MEMORY = -10; { Memory allocation failure. }
EAI_SYSTEM = -11; { System error returned in `errno'. }
const
WSADESCRIPTION_LEN = 256;
WSASYS_STATUS_LEN = 128;
type
PWSAData = ^TWSAData;
TWSAData = packed record
wVersion: Word;
wHighVersion: Word;
szDescription: array[0..WSADESCRIPTION_LEN] of Char;
szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
iMaxSockets: Word;
iMaxUdpDg: Word;
lpVendorInfo: PChar;
end;
function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean;
procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
var
in6addr_any, in6addr_loopback : TInAddr6;
procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
procedure FD_ZERO(var FDSet: TFDSet);
{=============================================================================}
type
TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer;
cdecl;
TWSACleanup = function: Integer;
cdecl;
TWSAGetLastError = function: Integer;
cdecl;
TGetServByName = function(name, proto: PChar): PServEnt;
cdecl;
TGetServByPort = function(port: Integer; proto: PChar): PServEnt;
cdecl;
TGetProtoByName = function(name: PChar): PProtoEnt;
cdecl;
TGetProtoByNumber = function(proto: Integer): PProtoEnt;
cdecl;
TGetHostByName = function(name: PChar): PHostEnt;
cdecl;
TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt;
cdecl;
TGetHostName = function(name: PChar; len: Integer): Integer;
cdecl;
TShutdown = function(s: TSocket; how: Integer): Integer;
cdecl;
TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar;
optlen: Integer): Integer;
cdecl;
TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar;
var optlen: Integer): Integer;
cdecl;
TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr;
tolen: Integer): Integer;
cdecl;
TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer;
cdecl;
TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer;
cdecl;
TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr;
var fromlen: Integer): Integer;
cdecl;
Tntohs = function(netshort: u_short): u_short;
cdecl;
Tntohl = function(netlong: u_long): u_long;
cdecl;
TListen = function(s: TSocket; backlog: Integer): Integer;
cdecl;
TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: integer): Integer;
cdecl;
TInet_ntoa = function(inaddr: TInAddr): PChar;
cdecl;
TInet_addr = function(cp: PChar): u_long;
cdecl;
Thtons = function(hostshort: u_short): u_short;
cdecl;
Thtonl = function(hostlong: u_long): u_long;
cdecl;
TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
cdecl;
TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
cdecl;
TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer;
cdecl;
TCloseSocket = function(s: TSocket): Integer;
cdecl;
TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer;
cdecl;
TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket;
cdecl;
TTSocket = function(af, Struc, Protocol: Integer): TSocket;
cdecl;
TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint;
cdecl;
TGetAddrInfo = function(NodeName: PChar; ServName: PChar; Hints: PAddrInfo;
var Addrinfo: PAddrInfo): integer;
cdecl;
TFreeAddrInfo = procedure(ai: PAddrInfo);
cdecl;
TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PChar;
hostlen: DWORD; serv: PChar; servlen: DWORD; flags: integer): integer;
cdecl;
var
WSAStartup: TWSAStartup = nil;
WSACleanup: TWSACleanup = nil;
WSAGetLastError: TWSAGetLastError = nil;
GetServByName: TGetServByName = nil;
GetServByPort: TGetServByPort = nil;
GetProtoByName: TGetProtoByName = nil;
GetProtoByNumber: TGetProtoByNumber = nil;
GetHostByName: TGetHostByName = nil;
GetHostByAddr: TGetHostByAddr = nil;
ssGetHostName: TGetHostName = nil;
Shutdown: TShutdown = nil;
SetSockOpt: TSetSockOpt = nil;
GetSockOpt: TGetSockOpt = nil;
ssSendTo: TSendTo = nil;
ssSend: TSend = nil;
ssRecv: TRecv = nil;
ssRecvFrom: TRecvFrom = nil;
ntohs: Tntohs = nil;
ntohl: Tntohl = nil;
Listen: TListen = nil;
IoctlSocket: TIoctlSocket = nil;
Inet_ntoa: TInet_ntoa = nil;
Inet_addr: TInet_addr = nil;
htons: Thtons = nil;
htonl: Thtonl = nil;
ssGetSockName: TGetSockName = nil;
ssGetPeerName: TGetPeerName = nil;
ssConnect: TConnect = nil;
CloseSocket: TCloseSocket = nil;
ssBind: TBind = nil;
ssAccept: TAccept = nil;
Socket: TTSocket = nil;
Select: TSelect = nil;
GetAddrInfo: TGetAddrInfo = nil;
FreeAddrInfo: TFreeAddrInfo = nil;
GetNameInfo: TGetNameInfo = nil;
function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; cdecl;
function LSWSACleanup: Integer; cdecl;
function LSWSAGetLastError: Integer; cdecl;
var
SynSockCS: SyncObjs.TCriticalSection;
SockEnhancedApi: Boolean;
SockWship6Api: Boolean;
type
TVarSin = packed record
case integer of
0: (AddressFamily: u_short);
1: (
case sin_family: u_short of
AF_INET: (sin_port: u_short;
sin_addr: TInAddr;
sin_zero: array[0..7] of Char);
AF_INET6: (sin6_port: u_short;
sin6_flowinfo: u_long;
sin6_addr: TInAddr6;
sin6_scope_id: u_long);
);
end;
function SizeOfVarSin(sin: TVarSin): integer;
function Bind(s: TSocket; const addr: TVarSin): Integer;
function Connect(s: TSocket; const name: TVarSin): Integer;
function GetSockName(s: TSocket; var name: TVarSin): Integer;
function GetPeerName(s: TSocket; var name: TVarSin): Integer;
function GetHostName: string;
function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
function Accept(s: TSocket; var addr: TVarSin): TSocket;
function IsNewApi(Family: integer): Boolean;
function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
function GetSinIP(Sin: TVarSin): string;
function GetSinPort(Sin: TVarSin): Integer;
procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings);
function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string;
function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
{==============================================================================}
implementation
var
SynSockCount: Integer = 0;
LibHandle: TLibHandle = 0;
Libwship6Handle: TLibHandle = 0;
function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
(a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0));
end;
function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
(a^.u6_addr32[2] = 0) and
(a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and
(a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1));
end;
function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80));
end;
function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0));
end;
function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
begin
Result := (a^.u6_addr8[0] = $FF);
end;
function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean;
begin
Result := (CompareMem( a, b, sizeof(TInAddr6)));
end;
procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
begin
FillChar(a^, sizeof(TInAddr6), 0);
end;
procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
begin
FillChar(a^, sizeof(TInAddr6), 0);
a^.u6_addr8[15] := 1;
end;
{=============================================================================}
var
{$IFNDEF VER1_0} //FTP version 1.0.x
errno_loc: function: PInteger cdecl = nil;
{$ELSE}
errno_loc: function: PInteger = nil; cdecl;
{$ENDIF}
function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
begin
with WSData do
begin
wVersion := wVersionRequired;
wHighVersion := $202;
szDescription := 'Synsock - Synapse Platform Independent Socket Layer';
szSystemStatus := 'Running on Linux';
iMaxSockets := 32768;
iMaxUdpDg := 8192;
end;
Result := 0;
end;
function LSWSACleanup: Integer;
begin
Result := 0;
end;
function LSWSAGetLastError: Integer;
var
p: PInteger;
begin
p := errno_loc;
Result := p^;
end;
function __FDELT(Socket: TSocket): Integer;
begin
Result := Socket div __NFDBITS;
end;
function __FDMASK(Socket: TSocket): __fd_mask;
begin
Result := LongWord(1) shl (Socket mod __NFDBITS);
end;
function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean;
begin
Result := (fdset.fds_bits[__FDELT(Socket)] and __FDMASK(Socket)) <> 0;
end;
procedure FD_SET(Socket: TSocket; var fdset: TFDSet);
begin
fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] or __FDMASK(Socket);
end;
procedure FD_CLR(Socket: TSocket; var fdset: TFDSet);
begin
fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] and (not __FDMASK(Socket));
end;
procedure FD_ZERO(var fdset: TFDSet);
var
I: Integer;
begin
with fdset do
for I := Low(fds_bits) to High(fds_bits) do
fds_bits[I] := 0;
end;
{=============================================================================}
function SizeOfVarSin(sin: TVarSin): integer;
begin
case sin.sin_family of
AF_INET:
Result := SizeOf(TSockAddrIn);
AF_INET6:
Result := SizeOf(TSockAddrIn6);
else
Result := 0;
end;
end;
{=============================================================================}
function Bind(s: TSocket; const addr: TVarSin): Integer;
begin
Result := ssBind(s, @addr, SizeOfVarSin(addr));
end;
function Connect(s: TSocket; const name: TVarSin): Integer;
begin
Result := ssConnect(s, @name, SizeOfVarSin(name));
end;
function GetSockName(s: TSocket; var name: TVarSin): Integer;
var
len: integer;
begin
len := SizeOf(name);
FillChar(name, len, 0);
Result := ssGetSockName(s, @name, Len);
end;
function GetPeerName(s: TSocket; var name: TVarSin): Integer;
var
len: integer;
begin
len := SizeOf(name);
FillChar(name, len, 0);
Result := ssGetPeerName(s, @name, Len);
end;
function GetHostName: string;
var
s: string;
begin
Result := '';
setlength(s, 255);
ssGetHostName(pchar(s), Length(s) - 1);
Result := Pchar(s);
end;
function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
begin
Result := ssSend(s, Buf^, len, flags);
end;
function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
begin
Result := ssRecv(s, Buf^, len, flags);
end;
function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
begin
Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto));
end;
function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
var
x: integer;
begin
x := SizeOf(from);
Result := ssRecvFrom(s, Buf^, len, flags, @from, x);
end;
function Accept(s: TSocket; var addr: TVarSin): TSocket;
var
x: integer;
begin
x := SizeOf(addr);
Result := ssAccept(s, @addr, x);
end;
{=============================================================================}
function IsNewApi(Family: integer): Boolean;
begin
Result := SockEnhancedApi;
if not Result then
Result := (Family = AF_INET6) and SockWship6Api;
end;
function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
type
pu_long = ^u_long;
var
ProtoEnt: PProtoEnt;
ServEnt: PServEnt;
HostEnt: PHostEnt;
r: integer;
Hints1, Hints2: TAddrInfo;
Sin1, Sin2: TVarSin;
TwoPass: boolean;
function GetAddr(const IP, port: string; Hints: TAddrInfo; var Sin: TVarSin): integer;
var
Addr: PAddrInfo;
begin
Addr := nil;
try
FillChar(Sin, Sizeof(Sin), 0);
if Hints.ai_socktype = SOCK_RAW then
begin
Hints.ai_socktype := 0;
Hints.ai_protocol := 0;
Result := synsock.GetAddrInfo(PChar(IP), nil, @Hints, Addr);
end
else
begin
if (IP = cAnyHost) or (IP = c6AnyHost) then
begin
Hints.ai_flags := AI_PASSIVE;
Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr);
end
else
if (IP = cLocalhost) or (IP = c6Localhost) then
begin
Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr);
end
else
begin
Result := synsock.GetAddrInfo(PChar(IP), PChar(Port), @Hints, Addr);
end;
end;
if Result = 0 then
if (Addr <> nil) then
Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen);
finally
if Assigned(Addr) then
synsock.FreeAddrInfo(Addr);
end;
end;
begin
Result := 0;
FillChar(Sin, Sizeof(Sin), 0);
if not IsNewApi(family) then
begin
SynSockCS.Enter;
try
Sin.sin_family := AF_INET;
ProtoEnt := synsock.GetProtoByNumber(SockProtocol);
ServEnt := nil;
if ProtoEnt <> nil then
ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name);
if ServEnt = nil then
Sin.sin_port := synsock.htons(StrToIntDef(Port, 0))
else
Sin.sin_port := ServEnt^.s_port;
if IP = cBroadcast then
Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST)
else
begin
Sin.sin_addr.s_addr := synsock.inet_addr(PChar(IP));
if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then
begin
HostEnt := synsock.GetHostByName(PChar(IP));
Result := synsock.WSAGetLastError;
if HostEnt <> nil then
Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^);
end;
end;
finally
SynSockCS.Leave;
end;
end
else
begin
FillChar(Hints1, Sizeof(Hints1), 0);
FillChar(Hints2, Sizeof(Hints2), 0);
TwoPass := False;
if Family = AF_UNSPEC then
begin
if PreferIP4 then
begin
Hints1.ai_family := AF_INET;
Hints2.ai_family := AF_INET6;
TwoPass := True;
end
else
begin
Hints2.ai_family := AF_INET;
Hints1.ai_family := AF_INET6;
TwoPass := True;
end;
end
else
Hints1.ai_family := Family;
Hints1.ai_socktype := SockType;
Hints1.ai_protocol := SockProtocol;
Hints2.ai_socktype := Hints1.ai_socktype;
Hints2.ai_protocol := Hints1.ai_protocol;
r := GetAddr(IP, Port, Hints1, Sin1);
Result := r;
sin := sin1;
if r <> 0 then
if TwoPass then
begin
r := GetAddr(IP, Port, Hints2, Sin2);
Result := r;
if r = 0 then
sin := sin2;
end;
end;
end;
function GetSinIP(Sin: TVarSin): string;
var
p: PChar;
host, serv: string;
hostlen, servlen: integer;
r: integer;
begin
Result := '';
if not IsNewApi(Sin.AddressFamily) then
begin
p := synsock.inet_ntoa(Sin.sin_addr);
if p <> nil then
Result := p;
end
else
begin
hostlen := NI_MAXHOST;
servlen := NI_MAXSERV;
setlength(host, hostlen);
setlength(serv, servlen);
r := getnameinfo(@sin, SizeOfVarSin(sin), PChar(host), hostlen,
PChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV);
if r = 0 then
Result := PChar(host);
end;
end;
function GetSinPort(Sin: TVarSin): Integer;
begin
if (Sin.sin_family = AF_INET6) then
Result := synsock.ntohs(Sin.sin6_port)
else
Result := synsock.ntohs(Sin.sin_port);
end;
procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings);
type
TaPInAddr = array[0..250] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
Hints: TAddrInfo;
Addr: PAddrInfo;
AddrNext: PAddrInfo;
r: integer;
host, serv: string;
hostlen, servlen: integer;
RemoteHost: PHostEnt;
IP: u_long;
PAdrPtr: PaPInAddr;
i: Integer;
s: string;
InAddr: TInAddr;
begin
IPList.Clear;
if not IsNewApi(Family) then
begin
IP := synsock.inet_addr(PChar(Name));
if IP = u_long(INADDR_NONE) then
begin
SynSockCS.Enter;
try
RemoteHost := synsock.GetHostByName(PChar(Name));
if RemoteHost <> nil then
begin
PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list);
i := 0;
while PAdrPtr^[i] <> nil do
begin
InAddr := PAdrPtr^[i]^;
s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1],
InAddr.S_bytes[2], InAddr.S_bytes[3]]);
IPList.Add(s);
Inc(i);
end;
end;
finally
SynSockCS.Leave;
end;
end
else
IPList.Add(Name);
end
else
begin
Addr := nil;
try
FillChar(Hints, Sizeof(Hints), 0);
Hints.ai_family := AF_UNSPEC;
Hints.ai_socktype := SockType;
Hints.ai_protocol := SockProtocol;
Hints.ai_flags := 0;
r := synsock.GetAddrInfo(PChar(Name), nil, @Hints, Addr);
if r = 0 then
begin
AddrNext := Addr;
while not(AddrNext = nil) do
begin
if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET))
or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then
begin
hostlen := NI_MAXHOST;
servlen := NI_MAXSERV;
setlength(host, hostlen);
setlength(serv, servlen);
r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen,
PChar(host), hostlen, PChar(serv), servlen,
NI_NUMERICHOST + NI_NUMERICSERV);
if r = 0 then
begin
host := PChar(host);
IPList.Add(host);
end;
end;
AddrNext := AddrNext^.ai_next;
end;
end;
finally
if Assigned(Addr) then
synsock.FreeAddrInfo(Addr);
end;
end;
if IPList.Count = 0 then
IPList.Add(cAnyHost);
end;
function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
var
ProtoEnt: PProtoEnt;
ServEnt: PServEnt;
Hints: TAddrInfo;
Addr: PAddrInfo;
r: integer;
begin
Result := 0;
if not IsNewApi(Family) then
begin
SynSockCS.Enter;
try
ProtoEnt := synsock.GetProtoByNumber(SockProtocol);
ServEnt := nil;
if ProtoEnt <> nil then
ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name);
if ServEnt = nil then
Result := StrToIntDef(Port, 0)
else
Result := synsock.htons(ServEnt^.s_port);
finally
SynSockCS.Leave;
end;
end
else
begin
Addr := nil;
try
FillChar(Hints, Sizeof(Hints), 0);
Hints.ai_family := AF_UNSPEC;
Hints.ai_socktype := SockType;
Hints.ai_protocol := Sockprotocol;
Hints.ai_flags := AI_PASSIVE;
r := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr);
if (r = 0) and Assigned(Addr) then
begin
if Addr^.ai_family = AF_INET then
Result := synsock.htons(Addr^.ai_addr^.sin_port);
if Addr^.ai_family = AF_INET6 then
Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port);
end;
finally
if Assigned(Addr) then
synsock.FreeAddrInfo(Addr);
end;
end;
end;
function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string;
var
Hints: TAddrInfo;
Addr: PAddrInfo;
r: integer;
host, serv: string;
hostlen, servlen: integer;
RemoteHost: PHostEnt;
IPn: u_long;
begin
Result := IP;
if not IsNewApi(Family) then
begin
IPn := synsock.inet_addr(PChar(IP));
if IPn <> u_long(INADDR_NONE) then
begin
SynSockCS.Enter;
try
RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET);
if RemoteHost <> nil then
Result := RemoteHost^.h_name;
finally
SynSockCS.Leave;
end;
end;
end
else
begin
Addr := nil;
try
FillChar(Hints, Sizeof(Hints), 0);
Hints.ai_family := AF_UNSPEC;
Hints.ai_socktype := SockType;
Hints.ai_protocol := SockProtocol;
Hints.ai_flags := 0;
r := synsock.GetAddrInfo(PChar(IP), nil, @Hints, Addr);
if (r = 0) and Assigned(Addr)then
begin
hostlen := NI_MAXHOST;
servlen := NI_MAXSERV;
setlength(host, hostlen);
setlength(serv, servlen);
r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen,
PChar(host), hostlen, PChar(serv), servlen,
NI_NUMERICSERV);
if r = 0 then
Result := PChar(host);
end;
finally
if Assigned(Addr) then
synsock.FreeAddrInfo(Addr);
end;
end;
end;
{=============================================================================}
function InitSocketInterface(stack: string): Boolean;
begin
Result := False;
SockEnhancedApi := False;
if stack = '' then
stack := DLLStackName;
SynSockCS.Enter;
try
if SynSockCount = 0 then
begin
SockEnhancedApi := False;
SockWship6Api := False;
Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN));
LibHandle := LoadLibrary(PChar(Stack));
if LibHandle <> 0 then
begin
errno_loc := GetProcAddress(LibHandle, PChar('__errno_location'));
CloseSocket := GetProcAddress(LibHandle, PChar('close'));
IoctlSocket := GetProcAddress(LibHandle, PChar('ioctl'));
WSAGetLastError := LSWSAGetLastError;
WSAStartup := LSWSAStartup;
WSACleanup := LSWSACleanup;
ssAccept := GetProcAddress(LibHandle, PChar('accept'));
ssBind := GetProcAddress(LibHandle, PChar('bind'));
ssConnect := GetProcAddress(LibHandle, PChar('connect'));
ssGetPeerName := GetProcAddress(LibHandle, PChar('getpeername'));
ssGetSockName := GetProcAddress(LibHandle, PChar('getsockname'));
GetSockOpt := GetProcAddress(LibHandle, PChar('getsockopt'));
Htonl := GetProcAddress(LibHandle, PChar('htonl'));
Htons := GetProcAddress(LibHandle, PChar('htons'));
Inet_Addr := GetProcAddress(LibHandle, PChar('inet_addr'));
Inet_Ntoa := GetProcAddress(LibHandle, PChar('inet_ntoa'));
Listen := GetProcAddress(LibHandle, PChar('listen'));
Ntohl := GetProcAddress(LibHandle, PChar('ntohl'));
Ntohs := GetProcAddress(LibHandle, PChar('ntohs'));
ssRecv := GetProcAddress(LibHandle, PChar('recv'));
ssRecvFrom := GetProcAddress(LibHandle, PChar('recvfrom'));
Select := GetProcAddress(LibHandle, PChar('select'));
ssSend := GetProcAddress(LibHandle, PChar('send'));
ssSendTo := GetProcAddress(LibHandle, PChar('sendto'));
SetSockOpt := GetProcAddress(LibHandle, PChar('setsockopt'));
ShutDown := GetProcAddress(LibHandle, PChar('shutdown'));
Socket := GetProcAddress(LibHandle, PChar('socket'));
GetHostByAddr := GetProcAddress(LibHandle, PChar('gethostbyaddr'));
GetHostByName := GetProcAddress(LibHandle, PChar('gethostbyname'));
GetProtoByName := GetProcAddress(LibHandle, PChar('getprotobyname'));
GetProtoByNumber := GetProcAddress(LibHandle, PChar('getprotobynumber'));
GetServByName := GetProcAddress(LibHandle, PChar('getservbyname'));
GetServByPort := GetProcAddress(LibHandle, PChar('getservbyport'));
ssGetHostName := GetProcAddress(LibHandle, PChar('gethostname'));
{$IFNDEF FORCEOLDAPI}
GetAddrInfo := GetProcAddress(LibHandle, PChar('getaddrinfo'));
FreeAddrInfo := GetProcAddress(LibHandle, PChar('freeaddrinfo'));
GetNameInfo := GetProcAddress(LibHandle, PChar('getnameinfo'));
SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo)
and Assigned(GetNameInfo);
{$ENDIF}
Result := True;
end;
end
else Result := True;
if Result then
Inc(SynSockCount);
finally
SynSockCS.Leave;
end;
end;
function DestroySocketInterface: Boolean;
begin
SynSockCS.Enter;
try
Dec(SynSockCount);
if SynSockCount < 0 then
SynSockCount := 0;
if SynSockCount = 0 then
begin
if LibHandle <> 0 then
begin
FreeLibrary(libHandle);
LibHandle := 0;
end;
if LibWship6Handle <> 0 then
begin
FreeLibrary(LibWship6Handle);
LibWship6Handle := 0;
end;
end;
finally
SynSockCS.Leave;
end;
Result := True;
end;
initialization
begin
SynSockCS := SyncObjs.TCriticalSection.Create;
SET_IN6_IF_ADDR_ANY (@in6addr_any);
SET_LOOPBACK_ADDR6 (@in6addr_loopback);
end;
finalization
begin
SynSockCS.Free;
end;
{$ENDIF}
TransGUI/synapse/source/lib/mimemess.pas 0000644 0000000 0000000 00000064463 11366572451 017313 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 002.005.002 |
|==============================================================================|
| Content: MIME message object |
|==============================================================================|
| Copyright (c)1999-2006, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2006. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM From distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(MIME message handling)
Classes for easy handling with e-mail message.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit mimemess;
interface
uses
Classes, SysUtils,
mimepart, synachar, synautil, mimeinln;
type
{:Possible values for message priority}
TMessPriority = (MP_unknown, MP_low, MP_normal, MP_high);
{:@abstract(Object for basic e-mail header fields.)}
TMessHeader = class(TObject)
private
FFrom: string;
FToList: TStringList;
FCCList: TStringList;
FSubject: string;
FOrganization: string;
FCustomHeaders: TStringList;
FDate: TDateTime;
FXMailer: string;
FCharsetCode: TMimeChar;
FReplyTo: string;
FMessageID: string;
FPriority: TMessPriority;
Fpri: TMessPriority;
Fxpri: TMessPriority;
Fxmspri: TMessPriority;
protected
function ParsePriority(value: string): TMessPriority;
function DecodeHeader(value: string): boolean; virtual;
public
constructor Create; virtual;
destructor Destroy; override;
{:Clears all data fields.}
procedure Clear; virtual;
{Add headers from from this object to Value.}
procedure EncodeHeaders(const Value: TStrings); virtual;
{:Parse header from Value to this object.}
procedure DecodeHeaders(const Value: TStrings);
{:Try find specific header in CustomHeader. Search is case insensitive.
This is good for reading any non-parsed header.}
function FindHeader(Value: string): string;
{:Try find specific headers in CustomHeader. This metod is for repeatly used
headers like 'received' header, etc. Search is case insensitive.
This is good for reading ano non-parsed header.}
procedure FindHeaderList(Value: string; const HeaderList: TStrings);
published
{:Sender of message.}
property From: string read FFrom Write FFrom;
{:Stringlist with receivers of message. (one per line)}
property ToList: TStringList read FToList;
{:Stringlist with Carbon Copy receivers of message. (one per line)}
property CCList: TStringList read FCCList;
{:Subject of message.}
property Subject: string read FSubject Write FSubject;
{:Organization string.}
property Organization: string read FOrganization Write FOrganization;
{:After decoding contains all headers lines witch not have parsed to any
other structures in this object. It mean: this conatins all other headers
except:
X-MAILER, FROM, SUBJECT, ORGANIZATION, TO, CC, DATE, MIME-VERSION,
CONTENT-TYPE, CONTENT-DESCRIPTION, CONTENT-DISPOSITION, CONTENT-ID,
CONTENT-TRANSFER-ENCODING, REPLY-TO, MESSAGE-ID, X-MSMAIL-PRIORITY,
X-PRIORITY, PRIORITY
When you encode headers, all this lines is added as headers. Be carefull
for duplicites!}
property CustomHeaders: TStringList read FCustomHeaders;
{:Date and time of message.}
property Date: TDateTime read FDate Write FDate;
{:Mailer identification.}
property XMailer: string read FXMailer Write FXMailer;
{:Address for replies}
property ReplyTo: string read FReplyTo Write FReplyTo;
{:message indetifier}
property MessageID: string read FMessageID Write FMessageID;
{:message priority}
property Priority: TMessPriority read FPriority Write FPriority;
{:Specify base charset. By default is used system charset.}
property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
end;
TMessHeaderClass = class of TMessHeader;
{:@abstract(Object for handling of e-mail message.)}
TMimeMess = class(TObject)
private
FMessagePart: TMimePart;
FLines: TStringList;
FHeader: TMessHeader;
public
constructor Create;
{:create this object and assign your own descendant of @link(TMessHeader)
object to @link(header) property. So, you can create your own message
headers parser and use it by this object.}
constructor CreateAltHeaders(HeadClass: TMessHeaderClass);
destructor Destroy; override;
{:Reset component to default state.}
procedure Clear; virtual;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then one subpart,
you must have PartParent of multipart type!}
function AddPart(const PartParent: TMimePart): TMimePart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
This part is marked as multipart with secondary MIME type specified by
MultipartType parameter. (typical value is 'mixed')
This part can be used as PartParent for another parts (include next
multipart). If you need only one part, then you not need Multipart part.}
function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
After creation of part set type to text part and set all necessary
properties. Content of part is readed from value stringlist.}
function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
After creation of part set type to text part and set all necessary
properties. Content of part is readed from value stringlist. You can select
your charset and your encoding type. If Raw is @true, then it not doing
charset conversion!}
function AddPartTextEx(const Value: TStrings; const PartParent: TMimePart;
PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
After creation of part set type to text part to HTML type and set all
necessary properties. Content of HTML part is readed from Value stringlist.}
function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartText), but content is readed from file}
function AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartHTML), but content is readed from file}
function AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart,
you must have PartParent of multipart type!
After creation of part set type to binary and set all necessary properties.
MIME primary and secondary types defined automaticly by filename extension.
Content of binary part is readed from Stream. This binary part is encoded
as file attachment.}
function AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartBinary), but content is readed from file}
function AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
After creation of part set type to binary and set all necessary properties.
MIME primary and secondary types defined automaticly by filename extension.
Content of binary part is readed from Stream.
This binary part is encoded as inline data with given Conten ID (cid).
Content ID can be used as reference ID in HTML source in HTML part.}
function AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartHTMLBinary), but content is readed from file}
function AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
After creation of part set type to message and set all necessary properties.
MIME primary and secondary types are setted to 'message/rfc822'.
Content of raw RFC-822 message is readed from Stream.}
function AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartMess), but content is readed from file}
function AddPartMessFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
{:Compose message from @link(MessagePart) to @link(Lines). Headers from
@link(Header) object is added also.}
procedure EncodeMessage;
{:Decode message from @link(Lines) to @link(MessagePart). Massage headers
are parsed into @link(Header) object.}
procedure DecodeMessage;
published
{:@link(TMimePart) object with decoded MIME message. This object can handle
any number of nested @link(TMimePart) objects itself. It is used for handle
any tree of MIME subparts.}
property MessagePart: TMimePart read FMessagePart;
{:Raw MIME encoded message.}
property Lines: TStringList read FLines;
{:Object for e-mail header fields. This object is created automaticly.
Do not free this object!}
property Header: TMessHeader read FHeader;
end;
implementation
{==============================================================================}
constructor TMessHeader.Create;
begin
inherited Create;
FToList := TStringList.Create;
FCCList := TStringList.Create;
FCustomHeaders := TStringList.Create;
FCharsetCode := GetCurCP;
end;
destructor TMessHeader.Destroy;
begin
FCustomHeaders.Free;
FCCList.Free;
FToList.Free;
inherited Destroy;
end;
{==============================================================================}
procedure TMessHeader.Clear;
begin
FFrom := '';
FToList.Clear;
FCCList.Clear;
FSubject := '';
FOrganization := '';
FCustomHeaders.Clear;
FDate := 0;
FXMailer := '';
FReplyTo := '';
FMessageID := '';
FPriority := MP_unknown;
end;
procedure TMessHeader.EncodeHeaders(const Value: TStrings);
var
n: Integer;
s: string;
begin
if FDate = 0 then
FDate := Now;
for n := FCustomHeaders.Count - 1 downto 0 do
if FCustomHeaders[n] <> '' then
Value.Insert(0, FCustomHeaders[n]);
if FPriority <> MP_unknown then
case FPriority of
MP_high:
begin
Value.Insert(0, 'X-MSMAIL-Priority: High');
Value.Insert(0, 'X-Priority: 1');
Value.Insert(0, 'Priority: urgent');
end;
MP_low:
begin
Value.Insert(0, 'X-MSMAIL-Priority: low');
Value.Insert(0, 'X-Priority: 5');
Value.Insert(0, 'Priority: non-urgent');
end;
end;
if FReplyTo <> '' then
Value.Insert(0, 'Reply-To: ' + GetEmailAddr(FReplyTo));
if FMessageID <> '' then
Value.Insert(0, 'Message-ID: <' + trim(FMessageID) + '>');
if FXMailer = '' then
Value.Insert(0, 'X-mailer: Synapse - Pascal TCP/IP library by Lukas Gebauer')
else
Value.Insert(0, 'X-mailer: ' + FXMailer);
Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)');
if FOrganization <> '' then
Value.Insert(0, 'Organization: ' + InlineCodeEx(FOrganization, FCharsetCode));
s := '';
for n := 0 to FCCList.Count - 1 do
if s = '' then
s := InlineEmailEx(FCCList[n], FCharsetCode)
else
s := s + ', ' + InlineEmailEx(FCCList[n], FCharsetCode);
if s <> '' then
Value.Insert(0, 'CC: ' + s);
Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate));
if FSubject <> '' then
Value.Insert(0, 'Subject: ' + InlineCodeEx(FSubject, FCharsetCode));
s := '';
for n := 0 to FToList.Count - 1 do
if s = '' then
s := InlineEmailEx(FToList[n], FCharsetCode)
else
s := s + ', ' + InlineEmailEx(FToList[n], FCharsetCode);
if s <> '' then
Value.Insert(0, 'To: ' + s);
Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode));
end;
function TMessHeader.ParsePriority(value: string): TMessPriority;
var
s: string;
x: integer;
begin
Result := MP_unknown;
s := Trim(separateright(value, ':'));
s := Separateleft(s, ' ');
x := StrToIntDef(s, -1);
if x >= 0 then
case x of
1, 2:
Result := MP_High;
3:
Result := MP_Normal;
4, 5:
Result := MP_Low;
end
else
begin
s := lowercase(s);
if (s = 'urgent') or (s = 'high') or (s = 'highest') then
Result := MP_High;
if (s = 'normal') or (s = 'medium') then
Result := MP_Normal;
if (s = 'low') or (s = 'lowest')
or (s = 'no-priority') or (s = 'non-urgent') then
Result := MP_Low;
end;
end;
function TMessHeader.DecodeHeader(value: string): boolean;
var
s, t: string;
cp: TMimeChar;
begin
Result := True;
cp := FCharsetCode;
s := uppercase(value);
if Pos('X-MAILER:', s) = 1 then
begin
FXMailer := Trim(SeparateRight(Value, ':'));
Exit;
end;
if Pos('FROM:', s) = 1 then
begin
FFrom := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
Exit;
end;
if Pos('SUBJECT:', s) = 1 then
begin
FSubject := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
Exit;
end;
if Pos('ORGANIZATION:', s) = 1 then
begin
FOrganization := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
Exit;
end;
if Pos('TO:', s) = 1 then
begin
s := Trim(SeparateRight(Value, ':'));
repeat
t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
if t <> '' then
FToList.Add(t);
until s = '';
Exit;
end;
if Pos('CC:', s) = 1 then
begin
s := Trim(SeparateRight(Value, ':'));
repeat
t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
if t <> '' then
FCCList.Add(t);
until s = '';
Exit;
end;
if Pos('DATE:', s) = 1 then
begin
FDate := DecodeRfcDateTime(Trim(SeparateRight(Value, ':')));
Exit;
end;
if Pos('REPLY-TO:', s) = 1 then
begin
FReplyTo := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
Exit;
end;
if Pos('MESSAGE-ID:', s) = 1 then
begin
FMessageID := GetEmailAddr(Trim(SeparateRight(Value, ':')));
Exit;
end;
if Pos('PRIORITY:', s) = 1 then
begin
FPri := ParsePriority(value);
Exit;
end;
if Pos('X-PRIORITY:', s) = 1 then
begin
FXPri := ParsePriority(value);
Exit;
end;
if Pos('X-MSMAIL-PRIORITY:', s) = 1 then
begin
FXmsPri := ParsePriority(value);
Exit;
end;
if Pos('MIME-VERSION:', s) = 1 then
Exit;
if Pos('CONTENT-TYPE:', s) = 1 then
Exit;
if Pos('CONTENT-DESCRIPTION:', s) = 1 then
Exit;
if Pos('CONTENT-DISPOSITION:', s) = 1 then
Exit;
if Pos('CONTENT-ID:', s) = 1 then
Exit;
if Pos('CONTENT-TRANSFER-ENCODING:', s) = 1 then
Exit;
Result := False;
end;
procedure TMessHeader.DecodeHeaders(const Value: TStrings);
var
s: string;
x: Integer;
begin
Clear;
Fpri := MP_unknown;
Fxpri := MP_unknown;
Fxmspri := MP_unknown;
x := 0;
while Value.Count > x do
begin
s := NormalizeHeader(Value, x);
if s = '' then
Break;
if not DecodeHeader(s) then
FCustomHeaders.Add(s);
end;
if Fpri <> MP_unknown then
FPriority := Fpri
else
if Fxpri <> MP_unknown then
FPriority := Fxpri
else
if Fxmspri <> MP_unknown then
FPriority := Fxmspri
end;
function TMessHeader.FindHeader(Value: string): string;
var
n: integer;
begin
Result := '';
for n := 0 to FCustomHeaders.Count - 1 do
if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
begin
Result := Trim(SeparateRight(FCustomHeaders[n], ':'));
break;
end;
end;
procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStrings);
var
n: integer;
begin
HeaderList.Clear;
for n := 0 to FCustomHeaders.Count - 1 do
if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
begin
HeaderList.Add(Trim(SeparateRight(FCustomHeaders[n], ':')));
end;
end;
{==============================================================================}
constructor TMimeMess.Create;
begin
CreateAltHeaders(TMessHeader);
end;
constructor TMimeMess.CreateAltHeaders(HeadClass: TMessHeaderClass);
begin
inherited Create;
FMessagePart := TMimePart.Create;
FLines := TStringList.Create;
FHeader := HeadClass.Create;
end;
destructor TMimeMess.Destroy;
begin
FMessagePart.Free;
FHeader.Free;
FLines.Free;
inherited Destroy;
end;
{==============================================================================}
procedure TMimeMess.Clear;
begin
FMessagePart.Clear;
FLines.Clear;
FHeader.Clear;
end;
{==============================================================================}
function TMimeMess.AddPart(const PartParent: TMimePart): TMimePart;
begin
if PartParent = nil then
Result := FMessagePart
else
Result := PartParent.AddSubPart;
Result.Clear;
end;
{==============================================================================}
function TMimeMess.AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
begin
Result := AddPart(PartParent);
with Result do
begin
Primary := 'Multipart';
Secondary := MultipartType;
Description := 'Multipart message';
Boundary := GenerateBoundary;
EncodePartHeader;
end;
end;
function TMimeMess.AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
begin
Result := AddPart(PartParent);
with Result do
begin
Value.SaveToStream(DecodedLines);
Primary := 'text';
Secondary := 'plain';
Description := 'Message text';
Disposition := 'inline';
CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, IdealCharsets);
EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart;
EncodePartHeader;
end;
end;
function TMimeMess.AddPartTextEx(const Value: TStrings; const PartParent: TMimePart;
PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart;
begin
Result := AddPart(PartParent);
with Result do
begin
Value.SaveToStream(DecodedLines);
Primary := 'text';
Secondary := 'plain';
Description := 'Message text';
Disposition := 'inline';
CharsetCode := PartCharset;
EncodingCode := PartEncoding;
ConvertCharset := not Raw;
EncodePart;
EncodePartHeader;
end;
end;
function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
begin
Result := AddPart(PartParent);
with Result do
begin
Value.SaveToStream(DecodedLines);
Primary := 'text';
Secondary := 'html';
Description := 'HTML text';
Disposition := 'inline';
CharsetCode := UTF_8;
EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart;
EncodePartHeader;
end;
end;
function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
var
tmp: TStrings;
begin
tmp := TStringList.Create;
try
tmp.LoadFromFile(FileName);
Result := AddPartText(tmp, PartParent);
Finally
tmp.Free;
end;
end;
function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
var
tmp: TStrings;
begin
tmp := TStringList.Create;
try
tmp.LoadFromFile(FileName);
Result := AddPartHTML(tmp, PartParent);
Finally
tmp.Free;
end;
end;
function TMimeMess.AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
begin
Result := AddPart(PartParent);
Result.DecodedLines.LoadFromStream(Stream);
Result.MimeTypeFromExt(FileName);
Result.Description := 'Attached file: ' + FileName;
Result.Disposition := 'attachment';
Result.FileName := FileName;
Result.EncodingCode := ME_BASE64;
Result.EncodePart;
Result.EncodePartHeader;
end;
function TMimeMess.AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
var
tmp: TMemoryStream;
begin
tmp := TMemoryStream.Create;
try
tmp.LoadFromFile(FileName);
Result := AddPartBinary(tmp, ExtractFileName(FileName), PartParent);
finally
tmp.Free;
end;
end;
function TMimeMess.AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
begin
Result := AddPart(PartParent);
Result.DecodedLines.LoadFromStream(Stream);
Result.MimeTypeFromExt(FileName);
Result.Description := 'Included file: ' + FileName;
Result.Disposition := 'inline';
Result.ContentID := Cid;
Result.FileName := FileName;
Result.EncodingCode := ME_BASE64;
Result.EncodePart;
Result.EncodePartHeader;
end;
function TMimeMess.AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
var
tmp: TMemoryStream;
begin
tmp := TMemoryStream.Create;
try
tmp.LoadFromFile(FileName);
Result :=AddPartHTMLBinary(tmp, ExtractFileName(FileName), Cid, PartParent);
finally
tmp.Free;
end;
end;
function TMimeMess.AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
var
part: Tmimepart;
begin
Result := AddPart(PartParent);
part := AddPart(result);
part.lines.addstrings(Value);
part.DecomposeParts;
with Result do
begin
Primary := 'message';
Secondary := 'rfc822';
Description := 'E-mail Message';
EncodePart;
EncodePartHeader;
end;
end;
function TMimeMess.AddPartMessFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
var
tmp: TStrings;
begin
tmp := TStringList.Create;
try
tmp.LoadFromFile(FileName);
Result := AddPartMess(tmp, PartParent);
Finally
tmp.Free;
end;
end;
{==============================================================================}
procedure TMimeMess.EncodeMessage;
var
l: TStringList;
x: integer;
begin
//merge headers from THeaders and header field from MessagePart
l := TStringList.Create;
try
FHeader.EncodeHeaders(l);
x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
x := IndexByBegin('CONTENT-DESCRIPTION', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
x := IndexByBegin('CONTENT-DISPOSITION', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
x := IndexByBegin('CONTENT-ID', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
x := IndexByBegin('CONTENT-TRANSFER-ENCODING', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
FMessagePart.Headers.Assign(l);
finally
l.Free;
end;
FMessagePart.ComposeParts;
FLines.Assign(FMessagePart.Lines);
end;
{==============================================================================}
procedure TMimeMess.DecodeMessage;
begin
FHeader.Clear;
FHeader.DecodeHeaders(FLines);
FMessagePart.Lines.Assign(FLines);
FMessagePart.DecomposeParts;
end;
end.
TransGUI/synapse/source/lib/synacrypt.pas 0000644 0000000 0000000 00000142244 11366572451 017522 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.000.001 |
|==============================================================================|
| Content: Encryption support |
|==============================================================================|
| Copyright (c)2007-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2007-2010. |
| All Rights Reserved. |
| Based on work of David Barton and Eric Young |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(Encryption support)
Implemented are DES and 3DES encryption/decryption by ECB, CBC, CFB-8bit,
CFB-block, OFB and CTR methods.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$R-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit synacrypt;
interface
uses
SysUtils, Classes, synautil;
type
{:@abstract(Implementation of common routines for 64-bit block ciphers)
Do not use this class directly, use descendants only!}
TSynaBlockCipher= class(TObject)
protected
procedure InitKey(Key: AnsiString); virtual;
private
IV, CV: AnsiString;
procedure IncCounter;
public
{:Sets the IV to Value and performs a reset}
procedure SetIV(const Value: AnsiString); virtual;
{:Returns the current chaining information, not the actual IV}
function GetIV: AnsiString; virtual;
{:Reset any stored chaining information}
procedure Reset; virtual;
{:Encrypt a 64-bit block of data using the ECB method of encryption}
function EncryptECB(const InData: AnsiString): AnsiString; virtual;
{:Decrypt a 64-bit block of data using the ECB method of decryption}
function DecryptECB(const InData: AnsiString): AnsiString; virtual;
{:Encrypt data using the CBC method of encryption}
function EncryptCBC(const Indata: AnsiString): AnsiString; virtual;
{:Decrypt data using the CBC method of decryption}
function DecryptCBC(const Indata: AnsiString): AnsiString; virtual;
{:Encrypt data using the CFB (8 bit) method of encryption}
function EncryptCFB8bit(const Indata: AnsiString): AnsiString; virtual;
{:Decrypt data using the CFB (8 bit) method of decryption}
function DecryptCFB8bit(const Indata: AnsiString): AnsiString; virtual;
{:Encrypt data using the CFB (block) method of encryption}
function EncryptCFBblock(const Indata: AnsiString): AnsiString; virtual;
{:Decrypt data using the CFB (block) method of decryption}
function DecryptCFBblock(const Indata: AnsiString): AnsiString; virtual;
{:Encrypt data using the OFB method of encryption}
function EncryptOFB(const Indata: AnsiString): AnsiString; virtual;
{:Decrypt data using the OFB method of decryption}
function DecryptOFB(const Indata: AnsiString): AnsiString; virtual;
{:Encrypt data using the CTR method of encryption}
function EncryptCTR(const Indata: AnsiString): AnsiString; virtual;
{:Decrypt data using the CTR method of decryption}
function DecryptCTR(const Indata: AnsiString): AnsiString; virtual;
{:Create a encryptor/decryptor instance and initialize it by the Key.}
constructor Create(Key: AnsiString);
end;
{:@abstract(Datatype for holding one DES key data)
This data type is used internally.}
TDesKeyData = array[0..31] of integer;
{:@abstract(Implementation of common routines for DES encryption)
Do not use this class directly, use descendants only!}
TSynaCustomDes = class(TSynaBlockcipher)
protected
procedure DoInit(KeyB: AnsiString; var KeyData: TDesKeyData);
function EncryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString;
function DecryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString;
end;
{:@abstract(Implementation of DES encryption)}
TSynaDes= class(TSynaCustomDes)
protected
KeyData: TDesKeyData;
procedure InitKey(Key: AnsiString); override;
public
{:Encrypt a 64-bit block of data using the ECB method of encryption}
function EncryptECB(const InData: AnsiString): AnsiString; override;
{:Decrypt a 64-bit block of data using the ECB method of decryption}
function DecryptECB(const InData: AnsiString): AnsiString; override;
end;
{:@abstract(Implementation of 3DES encryption)}
TSyna3Des= class(TSynaCustomDes)
protected
KeyData: array[0..2] of TDesKeyData;
procedure InitKey(Key: AnsiString); override;
public
{:Encrypt a 64-bit block of data using the ECB method of encryption}
function EncryptECB(const InData: AnsiString): AnsiString; override;
{:Decrypt a 64-bit block of data using the ECB method of decryption}
function DecryptECB(const InData: AnsiString): AnsiString; override;
end;
{:Call internal test of all DES encryptions. Returns @true if all is OK.}
function TestDes: boolean;
{:Call internal test of all 3DES encryptions. Returns @true if all is OK.}
function Test3Des: boolean;
{==============================================================================}
implementation
const
shifts2: array[0..15]of byte=
(0,0,1,1,1,1,1,1,0,1,1,1,1,1,1,0);
des_skb: array[0..7,0..63]of integer=(
(
(* for C bits (numbered as per FIPS 46) 1 2 3 4 5 6 *)
integer($00000000),integer($00000010),integer($20000000),integer($20000010),
integer($00010000),integer($00010010),integer($20010000),integer($20010010),
integer($00000800),integer($00000810),integer($20000800),integer($20000810),
integer($00010800),integer($00010810),integer($20010800),integer($20010810),
integer($00000020),integer($00000030),integer($20000020),integer($20000030),
integer($00010020),integer($00010030),integer($20010020),integer($20010030),
integer($00000820),integer($00000830),integer($20000820),integer($20000830),
integer($00010820),integer($00010830),integer($20010820),integer($20010830),
integer($00080000),integer($00080010),integer($20080000),integer($20080010),
integer($00090000),integer($00090010),integer($20090000),integer($20090010),
integer($00080800),integer($00080810),integer($20080800),integer($20080810),
integer($00090800),integer($00090810),integer($20090800),integer($20090810),
integer($00080020),integer($00080030),integer($20080020),integer($20080030),
integer($00090020),integer($00090030),integer($20090020),integer($20090030),
integer($00080820),integer($00080830),integer($20080820),integer($20080830),
integer($00090820),integer($00090830),integer($20090820),integer($20090830)
),(
(* for C bits (numbered as per FIPS 46) 7 8 10 11 12 13 *)
integer($00000000),integer($02000000),integer($00002000),integer($02002000),
integer($00200000),integer($02200000),integer($00202000),integer($02202000),
integer($00000004),integer($02000004),integer($00002004),integer($02002004),
integer($00200004),integer($02200004),integer($00202004),integer($02202004),
integer($00000400),integer($02000400),integer($00002400),integer($02002400),
integer($00200400),integer($02200400),integer($00202400),integer($02202400),
integer($00000404),integer($02000404),integer($00002404),integer($02002404),
integer($00200404),integer($02200404),integer($00202404),integer($02202404),
integer($10000000),integer($12000000),integer($10002000),integer($12002000),
integer($10200000),integer($12200000),integer($10202000),integer($12202000),
integer($10000004),integer($12000004),integer($10002004),integer($12002004),
integer($10200004),integer($12200004),integer($10202004),integer($12202004),
integer($10000400),integer($12000400),integer($10002400),integer($12002400),
integer($10200400),integer($12200400),integer($10202400),integer($12202400),
integer($10000404),integer($12000404),integer($10002404),integer($12002404),
integer($10200404),integer($12200404),integer($10202404),integer($12202404)
),(
(* for C bits (numbered as per FIPS 46) 14 15 16 17 19 20 *)
integer($00000000),integer($00000001),integer($00040000),integer($00040001),
integer($01000000),integer($01000001),integer($01040000),integer($01040001),
integer($00000002),integer($00000003),integer($00040002),integer($00040003),
integer($01000002),integer($01000003),integer($01040002),integer($01040003),
integer($00000200),integer($00000201),integer($00040200),integer($00040201),
integer($01000200),integer($01000201),integer($01040200),integer($01040201),
integer($00000202),integer($00000203),integer($00040202),integer($00040203),
integer($01000202),integer($01000203),integer($01040202),integer($01040203),
integer($08000000),integer($08000001),integer($08040000),integer($08040001),
integer($09000000),integer($09000001),integer($09040000),integer($09040001),
integer($08000002),integer($08000003),integer($08040002),integer($08040003),
integer($09000002),integer($09000003),integer($09040002),integer($09040003),
integer($08000200),integer($08000201),integer($08040200),integer($08040201),
integer($09000200),integer($09000201),integer($09040200),integer($09040201),
integer($08000202),integer($08000203),integer($08040202),integer($08040203),
integer($09000202),integer($09000203),integer($09040202),integer($09040203)
),(
(* for C bits (numbered as per FIPS 46) 21 23 24 26 27 28 *)
integer($00000000),integer($00100000),integer($00000100),integer($00100100),
integer($00000008),integer($00100008),integer($00000108),integer($00100108),
integer($00001000),integer($00101000),integer($00001100),integer($00101100),
integer($00001008),integer($00101008),integer($00001108),integer($00101108),
integer($04000000),integer($04100000),integer($04000100),integer($04100100),
integer($04000008),integer($04100008),integer($04000108),integer($04100108),
integer($04001000),integer($04101000),integer($04001100),integer($04101100),
integer($04001008),integer($04101008),integer($04001108),integer($04101108),
integer($00020000),integer($00120000),integer($00020100),integer($00120100),
integer($00020008),integer($00120008),integer($00020108),integer($00120108),
integer($00021000),integer($00121000),integer($00021100),integer($00121100),
integer($00021008),integer($00121008),integer($00021108),integer($00121108),
integer($04020000),integer($04120000),integer($04020100),integer($04120100),
integer($04020008),integer($04120008),integer($04020108),integer($04120108),
integer($04021000),integer($04121000),integer($04021100),integer($04121100),
integer($04021008),integer($04121008),integer($04021108),integer($04121108)
),(
(* for D bits (numbered as per FIPS 46) 1 2 3 4 5 6 *)
integer($00000000),integer($10000000),integer($00010000),integer($10010000),
integer($00000004),integer($10000004),integer($00010004),integer($10010004),
integer($20000000),integer($30000000),integer($20010000),integer($30010000),
integer($20000004),integer($30000004),integer($20010004),integer($30010004),
integer($00100000),integer($10100000),integer($00110000),integer($10110000),
integer($00100004),integer($10100004),integer($00110004),integer($10110004),
integer($20100000),integer($30100000),integer($20110000),integer($30110000),
integer($20100004),integer($30100004),integer($20110004),integer($30110004),
integer($00001000),integer($10001000),integer($00011000),integer($10011000),
integer($00001004),integer($10001004),integer($00011004),integer($10011004),
integer($20001000),integer($30001000),integer($20011000),integer($30011000),
integer($20001004),integer($30001004),integer($20011004),integer($30011004),
integer($00101000),integer($10101000),integer($00111000),integer($10111000),
integer($00101004),integer($10101004),integer($00111004),integer($10111004),
integer($20101000),integer($30101000),integer($20111000),integer($30111000),
integer($20101004),integer($30101004),integer($20111004),integer($30111004)
),(
(* for D bits (numbered as per FIPS 46) 8 9 11 12 13 14 *)
integer($00000000),integer($08000000),integer($00000008),integer($08000008),
integer($00000400),integer($08000400),integer($00000408),integer($08000408),
integer($00020000),integer($08020000),integer($00020008),integer($08020008),
integer($00020400),integer($08020400),integer($00020408),integer($08020408),
integer($00000001),integer($08000001),integer($00000009),integer($08000009),
integer($00000401),integer($08000401),integer($00000409),integer($08000409),
integer($00020001),integer($08020001),integer($00020009),integer($08020009),
integer($00020401),integer($08020401),integer($00020409),integer($08020409),
integer($02000000),integer($0A000000),integer($02000008),integer($0A000008),
integer($02000400),integer($0A000400),integer($02000408),integer($0A000408),
integer($02020000),integer($0A020000),integer($02020008),integer($0A020008),
integer($02020400),integer($0A020400),integer($02020408),integer($0A020408),
integer($02000001),integer($0A000001),integer($02000009),integer($0A000009),
integer($02000401),integer($0A000401),integer($02000409),integer($0A000409),
integer($02020001),integer($0A020001),integer($02020009),integer($0A020009),
integer($02020401),integer($0A020401),integer($02020409),integer($0A020409)
),(
(* for D bits (numbered as per FIPS 46) 16 17 18 19 20 21 *)
integer($00000000),integer($00000100),integer($00080000),integer($00080100),
integer($01000000),integer($01000100),integer($01080000),integer($01080100),
integer($00000010),integer($00000110),integer($00080010),integer($00080110),
integer($01000010),integer($01000110),integer($01080010),integer($01080110),
integer($00200000),integer($00200100),integer($00280000),integer($00280100),
integer($01200000),integer($01200100),integer($01280000),integer($01280100),
integer($00200010),integer($00200110),integer($00280010),integer($00280110),
integer($01200010),integer($01200110),integer($01280010),integer($01280110),
integer($00000200),integer($00000300),integer($00080200),integer($00080300),
integer($01000200),integer($01000300),integer($01080200),integer($01080300),
integer($00000210),integer($00000310),integer($00080210),integer($00080310),
integer($01000210),integer($01000310),integer($01080210),integer($01080310),
integer($00200200),integer($00200300),integer($00280200),integer($00280300),
integer($01200200),integer($01200300),integer($01280200),integer($01280300),
integer($00200210),integer($00200310),integer($00280210),integer($00280310),
integer($01200210),integer($01200310),integer($01280210),integer($01280310)
),(
(* for D bits (numbered as per FIPS 46) 22 23 24 25 27 28 *)
integer($00000000),integer($04000000),integer($00040000),integer($04040000),
integer($00000002),integer($04000002),integer($00040002),integer($04040002),
integer($00002000),integer($04002000),integer($00042000),integer($04042000),
integer($00002002),integer($04002002),integer($00042002),integer($04042002),
integer($00000020),integer($04000020),integer($00040020),integer($04040020),
integer($00000022),integer($04000022),integer($00040022),integer($04040022),
integer($00002020),integer($04002020),integer($00042020),integer($04042020),
integer($00002022),integer($04002022),integer($00042022),integer($04042022),
integer($00000800),integer($04000800),integer($00040800),integer($04040800),
integer($00000802),integer($04000802),integer($00040802),integer($04040802),
integer($00002800),integer($04002800),integer($00042800),integer($04042800),
integer($00002802),integer($04002802),integer($00042802),integer($04042802),
integer($00000820),integer($04000820),integer($00040820),integer($04040820),
integer($00000822),integer($04000822),integer($00040822),integer($04040822),
integer($00002820),integer($04002820),integer($00042820),integer($04042820),
integer($00002822),integer($04002822),integer($00042822),integer($04042822)
));
des_sptrans: array[0..7,0..63] of integer=(
(
(* nibble 0 *)
integer($02080800), integer($00080000), integer($02000002), integer($02080802),
integer($02000000), integer($00080802), integer($00080002), integer($02000002),
integer($00080802), integer($02080800), integer($02080000), integer($00000802),
integer($02000802), integer($02000000), integer($00000000), integer($00080002),
integer($00080000), integer($00000002), integer($02000800), integer($00080800),
integer($02080802), integer($02080000), integer($00000802), integer($02000800),
integer($00000002), integer($00000800), integer($00080800), integer($02080002),
integer($00000800), integer($02000802), integer($02080002), integer($00000000),
integer($00000000), integer($02080802), integer($02000800), integer($00080002),
integer($02080800), integer($00080000), integer($00000802), integer($02000800),
integer($02080002), integer($00000800), integer($00080800), integer($02000002),
integer($00080802), integer($00000002), integer($02000002), integer($02080000),
integer($02080802), integer($00080800), integer($02080000), integer($02000802),
integer($02000000), integer($00000802), integer($00080002), integer($00000000),
integer($00080000), integer($02000000), integer($02000802), integer($02080800),
integer($00000002), integer($02080002), integer($00000800), integer($00080802)
),(
(* nibble 1 *)
integer($40108010), integer($00000000), integer($00108000), integer($40100000),
integer($40000010), integer($00008010), integer($40008000), integer($00108000),
integer($00008000), integer($40100010), integer($00000010), integer($40008000),
integer($00100010), integer($40108000), integer($40100000), integer($00000010),
integer($00100000), integer($40008010), integer($40100010), integer($00008000),
integer($00108010), integer($40000000), integer($00000000), integer($00100010),
integer($40008010), integer($00108010), integer($40108000), integer($40000010),
integer($40000000), integer($00100000), integer($00008010), integer($40108010),
integer($00100010), integer($40108000), integer($40008000), integer($00108010),
integer($40108010), integer($00100010), integer($40000010), integer($00000000),
integer($40000000), integer($00008010), integer($00100000), integer($40100010),
integer($00008000), integer($40000000), integer($00108010), integer($40008010),
integer($40108000), integer($00008000), integer($00000000), integer($40000010),
integer($00000010), integer($40108010), integer($00108000), integer($40100000),
integer($40100010), integer($00100000), integer($00008010), integer($40008000),
integer($40008010), integer($00000010), integer($40100000), integer($00108000)
),(
(* nibble 2 *)
integer($04000001), integer($04040100), integer($00000100), integer($04000101),
integer($00040001), integer($04000000), integer($04000101), integer($00040100),
integer($04000100), integer($00040000), integer($04040000), integer($00000001),
integer($04040101), integer($00000101), integer($00000001), integer($04040001),
integer($00000000), integer($00040001), integer($04040100), integer($00000100),
integer($00000101), integer($04040101), integer($00040000), integer($04000001),
integer($04040001), integer($04000100), integer($00040101), integer($04040000),
integer($00040100), integer($00000000), integer($04000000), integer($00040101),
integer($04040100), integer($00000100), integer($00000001), integer($00040000),
integer($00000101), integer($00040001), integer($04040000), integer($04000101),
integer($00000000), integer($04040100), integer($00040100), integer($04040001),
integer($00040001), integer($04000000), integer($04040101), integer($00000001),
integer($00040101), integer($04000001), integer($04000000), integer($04040101),
integer($00040000), integer($04000100), integer($04000101), integer($00040100),
integer($04000100), integer($00000000), integer($04040001), integer($00000101),
integer($04000001), integer($00040101), integer($00000100), integer($04040000)
),(
(* nibble 3 *)
integer($00401008), integer($10001000), integer($00000008), integer($10401008),
integer($00000000), integer($10400000), integer($10001008), integer($00400008),
integer($10401000), integer($10000008), integer($10000000), integer($00001008),
integer($10000008), integer($00401008), integer($00400000), integer($10000000),
integer($10400008), integer($00401000), integer($00001000), integer($00000008),
integer($00401000), integer($10001008), integer($10400000), integer($00001000),
integer($00001008), integer($00000000), integer($00400008), integer($10401000),
integer($10001000), integer($10400008), integer($10401008), integer($00400000),
integer($10400008), integer($00001008), integer($00400000), integer($10000008),
integer($00401000), integer($10001000), integer($00000008), integer($10400000),
integer($10001008), integer($00000000), integer($00001000), integer($00400008),
integer($00000000), integer($10400008), integer($10401000), integer($00001000),
integer($10000000), integer($10401008), integer($00401008), integer($00400000),
integer($10401008), integer($00000008), integer($10001000), integer($00401008),
integer($00400008), integer($00401000), integer($10400000), integer($10001008),
integer($00001008), integer($10000000), integer($10000008), integer($10401000)
),(
(* nibble 4 *)
integer($08000000), integer($00010000), integer($00000400), integer($08010420),
integer($08010020), integer($08000400), integer($00010420), integer($08010000),
integer($00010000), integer($00000020), integer($08000020), integer($00010400),
integer($08000420), integer($08010020), integer($08010400), integer($00000000),
integer($00010400), integer($08000000), integer($00010020), integer($00000420),
integer($08000400), integer($00010420), integer($00000000), integer($08000020),
integer($00000020), integer($08000420), integer($08010420), integer($00010020),
integer($08010000), integer($00000400), integer($00000420), integer($08010400),
integer($08010400), integer($08000420), integer($00010020), integer($08010000),
integer($00010000), integer($00000020), integer($08000020), integer($08000400),
integer($08000000), integer($00010400), integer($08010420), integer($00000000),
integer($00010420), integer($08000000), integer($00000400), integer($00010020),
integer($08000420), integer($00000400), integer($00000000), integer($08010420),
integer($08010020), integer($08010400), integer($00000420), integer($00010000),
integer($00010400), integer($08010020), integer($08000400), integer($00000420),
integer($00000020), integer($00010420), integer($08010000), integer($08000020)
),(
(* nibble 5 *)
integer($80000040), integer($00200040), integer($00000000), integer($80202000),
integer($00200040), integer($00002000), integer($80002040), integer($00200000),
integer($00002040), integer($80202040), integer($00202000), integer($80000000),
integer($80002000), integer($80000040), integer($80200000), integer($00202040),
integer($00200000), integer($80002040), integer($80200040), integer($00000000),
integer($00002000), integer($00000040), integer($80202000), integer($80200040),
integer($80202040), integer($80200000), integer($80000000), integer($00002040),
integer($00000040), integer($00202000), integer($00202040), integer($80002000),
integer($00002040), integer($80000000), integer($80002000), integer($00202040),
integer($80202000), integer($00200040), integer($00000000), integer($80002000),
integer($80000000), integer($00002000), integer($80200040), integer($00200000),
integer($00200040), integer($80202040), integer($00202000), integer($00000040),
integer($80202040), integer($00202000), integer($00200000), integer($80002040),
integer($80000040), integer($80200000), integer($00202040), integer($00000000),
integer($00002000), integer($80000040), integer($80002040), integer($80202000),
integer($80200000), integer($00002040), integer($00000040), integer($80200040)
),(
(* nibble 6 *)
integer($00004000), integer($00000200), integer($01000200), integer($01000004),
integer($01004204), integer($00004004), integer($00004200), integer($00000000),
integer($01000000), integer($01000204), integer($00000204), integer($01004000),
integer($00000004), integer($01004200), integer($01004000), integer($00000204),
integer($01000204), integer($00004000), integer($00004004), integer($01004204),
integer($00000000), integer($01000200), integer($01000004), integer($00004200),
integer($01004004), integer($00004204), integer($01004200), integer($00000004),
integer($00004204), integer($01004004), integer($00000200), integer($01000000),
integer($00004204), integer($01004000), integer($01004004), integer($00000204),
integer($00004000), integer($00000200), integer($01000000), integer($01004004),
integer($01000204), integer($00004204), integer($00004200), integer($00000000),
integer($00000200), integer($01000004), integer($00000004), integer($01000200),
integer($00000000), integer($01000204), integer($01000200), integer($00004200),
integer($00000204), integer($00004000), integer($01004204), integer($01000000),
integer($01004200), integer($00000004), integer($00004004), integer($01004204),
integer($01000004), integer($01004200), integer($01004000), integer($00004004)
),(
(* nibble 7 *)
integer($20800080), integer($20820000), integer($00020080), integer($00000000),
integer($20020000), integer($00800080), integer($20800000), integer($20820080),
integer($00000080), integer($20000000), integer($00820000), integer($00020080),
integer($00820080), integer($20020080), integer($20000080), integer($20800000),
integer($00020000), integer($00820080), integer($00800080), integer($20020000),
integer($20820080), integer($20000080), integer($00000000), integer($00820000),
integer($20000000), integer($00800000), integer($20020080), integer($20800080),
integer($00800000), integer($00020000), integer($20820000), integer($00000080),
integer($00800000), integer($00020000), integer($20000080), integer($20820080),
integer($00020080), integer($20000000), integer($00000000), integer($00820000),
integer($20800080), integer($20020080), integer($20020000), integer($00800080),
integer($20820000), integer($00000080), integer($00800080), integer($20020000),
integer($20820080), integer($00800000), integer($20800000), integer($20000080),
integer($00820000), integer($00020080), integer($20020080), integer($20800000),
integer($00000080), integer($20820000), integer($00820080), integer($00000000),
integer($20000000), integer($20800080), integer($00020000), integer($00820080)
));
{==============================================================================}
function XorString(Indata1, Indata2: AnsiString): AnsiString;
var
i: integer;
begin
Indata2 := PadString(Indata2, length(Indata1), #0);
Result := '';
for i := 1 to length(Indata1) do
Result := Result + AnsiChar(ord(Indata1[i]) xor ord(Indata2[i]));
end;
procedure hperm_op(var a, t: integer; n, m: integer);
begin
t:= ((a shl (16 - n)) xor a) and m;
a:= a xor t xor (t shr (16 - n));
end;
procedure perm_op(var a, b, t: integer; n, m: integer);
begin
t:= ((a shr n) xor b) and m;
b:= b xor t;
a:= a xor (t shl n);
end;
{==============================================================================}
procedure TSynaBlockCipher.IncCounter;
var
i: integer;
begin
Inc(CV[8]);
i:= 7;
while (i> 0) and (CV[i + 1] = #0) do
begin
Inc(CV[i]);
Dec(i);
end;
end;
procedure TSynaBlockCipher.Reset;
begin
CV := IV;
end;
procedure TSynaBlockCipher.InitKey(Key: AnsiString);
begin
end;
procedure TSynaBlockCipher.SetIV(const Value: AnsiString);
begin
IV := PadString(Value, 8, #0);
Reset;
end;
function TSynaBlockCipher.GetIV: AnsiString;
begin
Result := CV;
end;
function TSynaBlockCipher.EncryptECB(const InData: AnsiString): AnsiString;
begin
Result := InData;
end;
function TSynaBlockCipher.DecryptECB(const InData: AnsiString): AnsiString;
begin
Result := InData;
end;
function TSynaBlockCipher.EncryptCBC(const Indata: AnsiString): AnsiString;
var
i: integer;
s: ansistring;
l: integer;
begin
Result := '';
l := Length(InData);
for i:= 1 to (l div 8) do
begin
s := copy(Indata, (i - 1) * 8 + 1, 8);
s := XorString(s, CV);
s := EncryptECB(s);
CV := s;
Result := Result + s;
end;
if (l mod 8)<> 0 then
begin
CV := EncryptECB(CV);
s := copy(Indata, (l div 8) * 8 + 1, l mod 8);
s := XorString(s, CV);
Result := Result + s;
end;
end;
function TSynaBlockCipher.DecryptCBC(const Indata: AnsiString): AnsiString;
var
i: integer;
s, temp: ansistring;
l: integer;
begin
Result := '';
l := Length(InData);
for i:= 1 to (l div 8) do
begin
s := copy(Indata, (i - 1) * 8 + 1, 8);
temp := s;
s := DecryptECB(s);
s := XorString(s, CV);
Result := Result + s;
CV := Temp;
end;
if (l mod 8)<> 0 then
begin
CV := EncryptECB(CV);
s := copy(Indata, (l div 8) * 8 + 1, l mod 8);
s := XorString(s, CV);
Result := Result + s;
end;
end;
function TSynaBlockCipher.EncryptCFB8bit(const Indata: AnsiString): AnsiString;
var
i: integer;
Temp: AnsiString;
c: AnsiChar;
begin
Result := '';
for i:= 1 to Length(Indata) do
begin
Temp := EncryptECB(CV);
c := AnsiChar(ord(InData[i]) xor ord(temp[1]));
Result := Result + c;
Delete(CV, 1, 1);
CV := CV + c;
end;
end;
function TSynaBlockCipher.DecryptCFB8bit(const Indata: AnsiString): AnsiString;
var
i: integer;
Temp: AnsiString;
c: AnsiChar;
begin
Result := '';
for i:= 1 to length(Indata) do
begin
c:= Indata[i];
Temp := EncryptECB(CV);
Result := Result + AnsiChar(ord(InData[i]) xor ord(temp[1]));
Delete(CV, 1, 1);
CV := CV + c;
end;
end;
function TSynaBlockCipher.EncryptCFBblock(const Indata: AnsiString): AnsiString;
var
i: integer;
s: AnsiString;
l: integer;
begin
Result := '';
l := Length(InData);
for i:= 1 to (l div 8) do
begin
CV := EncryptECB(CV);
s := copy(Indata, (i - 1) * 8 + 1, 8);
s := XorString(s, CV);
Result := Result + s;
CV := s;
end;
if (l mod 8)<> 0 then
begin
CV := EncryptECB(CV);
s := copy(Indata, (l div 8) * 8 + 1, l mod 8);
s := XorString(s, CV);
Result := Result + s;
end;
end;
function TSynaBlockCipher.DecryptCFBblock(const Indata: AnsiString): AnsiString;
var
i: integer;
S, Temp: AnsiString;
l: integer;
begin
Result := '';
l := Length(InData);
for i:= 1 to (l div 8) do
begin
s := copy(Indata, (i - 1) * 8 + 1, 8);
Temp := s;
CV := EncryptECB(CV);
s := XorString(s, CV);
Result := result + s;
CV := temp;
end;
if (l mod 8)<> 0 then
begin
CV := EncryptECB(CV);
s := copy(Indata, (l div 8) * 8 + 1, l mod 8);
s := XorString(s, CV);
Result := Result + s;
end;
end;
function TSynaBlockCipher.EncryptOFB(const Indata: AnsiString): AnsiString;
var
i: integer;
s: AnsiString;
l: integer;
begin
Result := '';
l := Length(InData);
for i:= 1 to (l div 8) do
begin
CV := EncryptECB(CV);
s := copy(Indata, (i - 1) * 8 + 1, 8);
s := XorString(s, CV);
Result := Result + s;
end;
if (l mod 8)<> 0 then
begin
CV := EncryptECB(CV);
s := copy(Indata, (l div 8) * 8 + 1, l mod 8);
s := XorString(s, CV);
Result := Result + s;
end;
end;
function TSynaBlockCipher.DecryptOFB(const Indata: AnsiString): AnsiString;
var
i: integer;
s: AnsiString;
l: integer;
begin
Result := '';
l := Length(InData);
for i:= 1 to (l div 8) do
begin
Cv := EncryptECB(CV);
s := copy(Indata, (i - 1) * 8 + 1, 8);
s := XorString(s, CV);
Result := Result + s;
end;
if (l mod 8)<> 0 then
begin
CV := EncryptECB(CV);
s := copy(Indata, (l div 8) * 8 + 1, l mod 8);
s := XorString(s, CV);
Result := Result + s;
end;
end;
function TSynaBlockCipher.EncryptCTR(const Indata: AnsiString): AnsiString;
var
temp: AnsiString;
i: integer;
s: AnsiString;
l: integer;
begin
Result := '';
l := Length(InData);
for i:= 1 to (l div 8) do
begin
temp := EncryptECB(CV);
IncCounter;
s := copy(Indata, (i - 1) * 8 + 1, 8);
s := XorString(s, temp);
Result := Result + s;
end;
if (l mod 8)<> 0 then
begin
temp := EncryptECB(CV);
IncCounter;
s := copy(Indata, (l div 8) * 8 + 1, l mod 8);
s := XorString(s, temp);
Result := Result + s;
end;
end;
function TSynaBlockCipher.DecryptCTR(const Indata: AnsiString): AnsiString;
var
temp: AnsiString;
s: AnsiString;
i: integer;
l: integer;
begin
Result := '';
l := Length(InData);
for i:= 1 to (l div 8) do
begin
temp := EncryptECB(CV);
IncCounter;
s := copy(Indata, (i - 1) * 8 + 1, 8);
s := XorString(s, temp);
Result := Result + s;
end;
if (l mod 8)<> 0 then
begin
temp := EncryptECB(CV);
IncCounter;
s := copy(Indata, (l div 8) * 8 + 1, l mod 8);
s := XorString(s, temp);
Result := Result + s;
end;
end;
constructor TSynaBlockCipher.Create(Key: AnsiString);
begin
inherited Create;
InitKey(Key);
IV := StringOfChar(#0, 8);
IV := EncryptECB(IV);
Reset;
end;
{==============================================================================}
procedure TSynaCustomDes.DoInit(KeyB: AnsiString; var KeyData: TDesKeyData);
var
c, d, t, s, t2, i: integer;
begin
KeyB := PadString(KeyB, 8, #0);
c:= ord(KeyB[1]) or (ord(KeyB[2]) shl 8) or (ord(KeyB[3]) shl 16) or (ord(KeyB[4]) shl 24);
d:= ord(KeyB[5]) or (ord(KeyB[6]) shl 8) or (ord(KeyB[7]) shl 16) or (ord(KeyB[8]) shl 24);
perm_op(d,c,t,4,integer($0f0f0f0f));
hperm_op(c,t,integer(-2),integer($cccc0000));
hperm_op(d,t,integer(-2),integer($cccc0000));
perm_op(d,c,t,1,integer($55555555));
perm_op(c,d,t,8,integer($00ff00ff));
perm_op(d,c,t,1,integer($55555555));
d:= ((d and $ff) shl 16) or (d and $ff00) or ((d and $ff0000) shr 16) or
((c and integer($f0000000)) shr 4);
c:= c and $fffffff;
for i:= 0 to 15 do
begin
if shifts2[i]<> 0 then
begin
c:= ((c shr 2) or (c shl 26));
d:= ((d shr 2) or (d shl 26));
end
else
begin
c:= ((c shr 1) or (c shl 27));
d:= ((d shr 1) or (d shl 27));
end;
c:= c and $fffffff;
d:= d and $fffffff;
s:= des_skb[0,c and $3f] or
des_skb[1,((c shr 6) and $03) or ((c shr 7) and $3c)] or
des_skb[2,((c shr 13) and $0f) or ((c shr 14) and $30)] or
des_skb[3,((c shr 20) and $01) or ((c shr 21) and $06) or ((c shr 22) and $38)];
t:= des_skb[4,d and $3f] or
des_skb[5,((d shr 7) and $03) or ((d shr 8) and $3c)] or
des_skb[6, (d shr 15) and $3f ] or
des_skb[7,((d shr 21) and $0f) or ((d shr 22) and $30)];
t2:= ((t shl 16) or (s and $ffff));
KeyData[(i shl 1)]:= ((t2 shl 2) or (t2 shr 30));
t2:= ((s shr 16) or (t and integer($ffff0000)));
KeyData[(i shl 1)+1]:= ((t2 shl 6) or (t2 shr 26));
end;
end;
function TSynaCustomDes.EncryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString;
var
l, r, t, u: integer;
i: longint;
begin
r := Swapbytes(DecodeLongint(Indata, 1));
l := swapbytes(DecodeLongint(Indata, 5));
t:= ((l shr 4) xor r) and $0f0f0f0f;
r:= r xor t;
l:= l xor (t shl 4);
t:= ((r shr 16) xor l) and $0000ffff;
l:= l xor t;
r:= r xor (t shl 16);
t:= ((l shr 2) xor r) and $33333333;
r:= r xor t;
l:= l xor (t shl 2);
t:= ((r shr 8) xor l) and $00ff00ff;
l:= l xor t;
r:= r xor (t shl 8);
t:= ((l shr 1) xor r) and $55555555;
r:= r xor t;
l:= l xor (t shl 1);
r:= (r shr 29) or (r shl 3);
l:= (l shr 29) or (l shl 3);
i:= 0;
while i< 32 do
begin
u:= r xor KeyData[i ];
t:= r xor KeyData[i+1];
t:= (t shr 4) or (t shl 28);
l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor
des_SPtrans[2,(u shr 10) and $3f] xor
des_SPtrans[4,(u shr 18) and $3f] xor
des_SPtrans[6,(u shr 26) and $3f] xor
des_SPtrans[1,(t shr 2) and $3f] xor
des_SPtrans[3,(t shr 10) and $3f] xor
des_SPtrans[5,(t shr 18) and $3f] xor
des_SPtrans[7,(t shr 26) and $3f];
u:= l xor KeyData[i+2];
t:= l xor KeyData[i+3];
t:= (t shr 4) or (t shl 28);
r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor
des_SPtrans[2,(u shr 10) and $3f] xor
des_SPtrans[4,(u shr 18) and $3f] xor
des_SPtrans[6,(u shr 26) and $3f] xor
des_SPtrans[1,(t shr 2) and $3f] xor
des_SPtrans[3,(t shr 10) and $3f] xor
des_SPtrans[5,(t shr 18) and $3f] xor
des_SPtrans[7,(t shr 26) and $3f];
u:= r xor KeyData[i+4];
t:= r xor KeyData[i+5];
t:= (t shr 4) or (t shl 28);
l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor
des_SPtrans[2,(u shr 10) and $3f] xor
des_SPtrans[4,(u shr 18) and $3f] xor
des_SPtrans[6,(u shr 26) and $3f] xor
des_SPtrans[1,(t shr 2) and $3f] xor
des_SPtrans[3,(t shr 10) and $3f] xor
des_SPtrans[5,(t shr 18) and $3f] xor
des_SPtrans[7,(t shr 26) and $3f];
u:= l xor KeyData[i+6];
t:= l xor KeyData[i+7];
t:= (t shr 4) or (t shl 28);
r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor
des_SPtrans[2,(u shr 10) and $3f] xor
des_SPtrans[4,(u shr 18) and $3f] xor
des_SPtrans[6,(u shr 26) and $3f] xor
des_SPtrans[1,(t shr 2) and $3f] xor
des_SPtrans[3,(t shr 10) and $3f] xor
des_SPtrans[5,(t shr 18) and $3f] xor
des_SPtrans[7,(t shr 26) and $3f];
Inc(i,8);
end;
r:= (r shr 3) or (r shl 29);
l:= (l shr 3) or (l shl 29);
t:= ((r shr 1) xor l) and $55555555;
l:= l xor t;
r:= r xor (t shl 1);
t:= ((l shr 8) xor r) and $00ff00ff;
r:= r xor t;
l:= l xor (t shl 8);
t:= ((r shr 2) xor l) and $33333333;
l:= l xor t;
r:= r xor (t shl 2);
t:= ((l shr 16) xor r) and $0000ffff;
r:= r xor t;
l:= l xor (t shl 16);
t:= ((r shr 4) xor l) and $0f0f0f0f;
l:= l xor t;
r:= r xor (t shl 4);
Result := CodeLongInt(Swapbytes(l)) + CodeLongInt(Swapbytes(r));
end;
function TSynaCustomDes.DecryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString;
var
l, r, t, u: integer;
i: longint;
begin
r := Swapbytes(DecodeLongint(Indata, 1));
l := Swapbytes(DecodeLongint(Indata, 5));
t:= ((l shr 4) xor r) and $0f0f0f0f;
r:= r xor t;
l:= l xor (t shl 4);
t:= ((r shr 16) xor l) and $0000ffff;
l:= l xor t;
r:= r xor (t shl 16);
t:= ((l shr 2) xor r) and $33333333;
r:= r xor t;
l:= l xor (t shl 2);
t:= ((r shr 8) xor l) and $00ff00ff;
l:= l xor t;
r:= r xor (t shl 8);
t:= ((l shr 1) xor r) and $55555555;
r:= r xor t;
l:= l xor (t shl 1);
r:= (r shr 29) or (r shl 3);
l:= (l shr 29) or (l shl 3);
i:= 30;
while i> 0 do
begin
u:= r xor KeyData[i ];
t:= r xor KeyData[i+1];
t:= (t shr 4) or (t shl 28);
l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor
des_SPtrans[2,(u shr 10) and $3f] xor
des_SPtrans[4,(u shr 18) and $3f] xor
des_SPtrans[6,(u shr 26) and $3f] xor
des_SPtrans[1,(t shr 2) and $3f] xor
des_SPtrans[3,(t shr 10) and $3f] xor
des_SPtrans[5,(t shr 18) and $3f] xor
des_SPtrans[7,(t shr 26) and $3f];
u:= l xor KeyData[i-2];
t:= l xor KeyData[i-1];
t:= (t shr 4) or (t shl 28);
r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor
des_SPtrans[2,(u shr 10) and $3f] xor
des_SPtrans[4,(u shr 18) and $3f] xor
des_SPtrans[6,(u shr 26) and $3f] xor
des_SPtrans[1,(t shr 2) and $3f] xor
des_SPtrans[3,(t shr 10) and $3f] xor
des_SPtrans[5,(t shr 18) and $3f] xor
des_SPtrans[7,(t shr 26) and $3f];
u:= r xor KeyData[i-4];
t:= r xor KeyData[i-3];
t:= (t shr 4) or (t shl 28);
l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor
des_SPtrans[2,(u shr 10) and $3f] xor
des_SPtrans[4,(u shr 18) and $3f] xor
des_SPtrans[6,(u shr 26) and $3f] xor
des_SPtrans[1,(t shr 2) and $3f] xor
des_SPtrans[3,(t shr 10) and $3f] xor
des_SPtrans[5,(t shr 18) and $3f] xor
des_SPtrans[7,(t shr 26) and $3f];
u:= l xor KeyData[i-6];
t:= l xor KeyData[i-5];
t:= (t shr 4) or (t shl 28);
r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor
des_SPtrans[2,(u shr 10) and $3f] xor
des_SPtrans[4,(u shr 18) and $3f] xor
des_SPtrans[6,(u shr 26) and $3f] xor
des_SPtrans[1,(t shr 2) and $3f] xor
des_SPtrans[3,(t shr 10) and $3f] xor
des_SPtrans[5,(t shr 18) and $3f] xor
des_SPtrans[7,(t shr 26) and $3f];
Dec(i,8);
end;
r:= (r shr 3) or (r shl 29);
l:= (l shr 3) or (l shl 29);
t:= ((r shr 1) xor l) and $55555555;
l:= l xor t;
r:= r xor (t shl 1);
t:= ((l shr 8) xor r) and $00ff00ff;
r:= r xor t;
l:= l xor (t shl 8);
t:= ((r shr 2) xor l) and $33333333;
l:= l xor t;
r:= r xor (t shl 2);
t:= ((l shr 16) xor r) and $0000ffff;
r:= r xor t;
l:= l xor (t shl 16);
t:= ((r shr 4) xor l) and $0f0f0f0f;
l:= l xor t;
r:= r xor (t shl 4);
Result := CodeLongInt(Swapbytes(l)) + CodeLongInt(Swapbytes(r));
end;
{==============================================================================}
procedure TSynaDes.InitKey(Key: AnsiString);
begin
Key := PadString(Key, 8, #0);
DoInit(Key,KeyData);
end;
function TSynaDes.EncryptECB(const InData: AnsiString): AnsiString;
begin
Result := EncryptBlock(InData,KeyData);
end;
function TSynaDes.DecryptECB(const InData: AnsiString): AnsiString;
begin
Result := DecryptBlock(Indata,KeyData);
end;
{==============================================================================}
procedure TSyna3Des.InitKey(Key: AnsiString);
var
Size: integer;
n: integer;
begin
Size := length(Key);
key := PadString(key, 3 * 8, #0);
DoInit(Copy(key, 1, 8),KeyData[0]);
DoInit(Copy(key, 9, 8),KeyData[1]);
if Size > 16 then
DoInit(Copy(key, 17, 8),KeyData[2])
else
for n := 0 to high(KeyData[0]) do
KeyData[2][n] := Keydata[0][n];
end;
function TSyna3Des.EncryptECB(const InData: AnsiString): AnsiString;
begin
Result := EncryptBlock(Indata,KeyData[0]);
Result := DecryptBlock(Result,KeyData[1]);
Result := EncryptBlock(Result,KeyData[2]);
end;
function TSyna3Des.DecryptECB(const InData: AnsiString): AnsiString;
begin
Result := DecryptBlock(InData,KeyData[2]);
Result := EncryptBlock(Result,KeyData[1]);
Result := DecryptBlock(Result,KeyData[0]);
end;
{==============================================================================}
function TestDes: boolean;
var
des: TSynaDes;
s, t: string;
const
key = '01234567';
data1= '01234567';
data2= '0123456789abcdefghij';
begin
//ECB
des := TSynaDes.Create(key);
try
s := des.EncryptECB(data1);
t := strtohex(s);
result := t = 'c50ad028c6da9800';
s := des.DecryptECB(s);
result := result and (data1 = s);
finally
des.free;
end;
//CBC
des := TSynaDes.Create(key);
try
s := des.EncryptCBC(data2);
t := strtohex(s);
result := result and (t = 'eec50f6353115ad6dee90a22ed1b6a88a0926e35');
des.Reset;
s := des.DecryptCBC(s);
result := result and (data2 = s);
finally
des.free;
end;
//CFB-8bit
des := TSynaDes.Create(key);
try
s := des.EncryptCFB8bit(data2);
t := strtohex(s);
result := result and (t = 'eb6aa12c2f0ff634b4dfb6da6cb2af8f9c5c1452');
des.Reset;
s := des.DecryptCFB8bit(s);
result := result and (data2 = s);
finally
des.free;
end;
//CFB-block
des := TSynaDes.Create(key);
try
s := des.EncryptCFBblock(data2);
t := strtohex(s);
result := result and (t = 'ebdbbaa7f9286cdec28605e07f9b7f3be1053257');
des.Reset;
s := des.DecryptCFBblock(s);
result := result and (data2 = s);
finally
des.free;
end;
//OFB
des := TSynaDes.Create(key);
try
s := des.EncryptOFB(data2);
t := strtohex(s);
result := result and (t = 'ebdbbaa7f9286cdee0b8b3798c4c34baac87dbdc');
des.Reset;
s := des.DecryptOFB(s);
result := result and (data2 = s);
finally
des.free;
end;
//CTR
des := TSynaDes.Create(key);
try
s := des.EncryptCTR(data2);
t := strtohex(s);
result := result and (t = 'ebdbbaa7f9286cde0dd20b45f3afd9aa1b91b87e');
des.Reset;
s := des.DecryptCTR(s);
result := result and (data2 = s);
finally
des.free;
end;
end;
function Test3Des: boolean;
var
des: TSyna3Des;
s, t: string;
const
key = '0123456789abcdefghijklmn';
data1= '01234567';
data2= '0123456789abcdefghij';
begin
//ECB
des := TSyna3Des.Create(key);
try
s := des.EncryptECB(data1);
t := strtohex(s);
result := t = 'e0dee91008dc460c';
s := des.DecryptECB(s);
result := result and (data1 = s);
finally
des.free;
end;
//CBC
des := TSyna3Des.Create(key);
try
s := des.EncryptCBC(data2);
t := strtohex(s);
result := result and (t = 'ee844a2a4f49c01b91a1599b8eba29128c1ad87a');
des.Reset;
s := des.DecryptCBC(s);
result := result and (data2 = s);
finally
des.free;
end;
//CFB-8bit
des := TSyna3Des.Create(key);
try
s := des.EncryptCFB8bit(data2);
t := strtohex(s);
result := result and (t = '935bbf5210c32cfa1faf61f91e8dc02dfa0ff1e8');
des.Reset;
s := des.DecryptCFB8bit(s);
result := result and (data2 = s);
finally
des.free;
end;
//CFB-block
des := TSyna3Des.Create(key);
try
s := des.EncryptCFBblock(data2);
t := strtohex(s);
result := result and (t = '93754e3d54828fbf4bd81f1739419e8d2cfe1671');
des.Reset;
s := des.DecryptCFBblock(s);
result := result and (data2 = s);
finally
des.free;
end;
//OFB
des := TSyna3Des.Create(key);
try
s := des.EncryptOFB(data2);
t := strtohex(s);
result := result and (t = '93754e3d54828fbf04ef0a5efc926ebdf2d95f20');
des.Reset;
s := des.DecryptOFB(s);
result := result and (data2 = s);
finally
des.free;
end;
//CTR
des := TSyna3Des.Create(key);
try
s := des.EncryptCTR(data2);
t := strtohex(s);
result := result and (t = '93754e3d54828fbf1c51a121d2c93f989e70b3ad');
des.Reset;
s := des.DecryptCTR(s);
result := result and (data2 = s);
finally
des.free;
end;
end;
{==============================================================================}
end.
TransGUI/synapse/source/lib/ssl_streamsec.pas 0000644 0000000 0000000 00000040466 11366572451 020340 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.000.006 |
|==============================================================================|
| Content: SSL support by StreamSecII |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Henrick Hellström |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(SSL plugin for StreamSecII or OpenStreamSecII)
StreamSecII is native pascal library, you not need any external libraries!
You can tune lot of StreamSecII properties by using your GlobalServer. If you not
using your GlobalServer, then this plugin create own TSimpleTLSInternalServer
instance for each TCP connection. Formore information about GlobalServer usage
refer StreamSecII documentation.
If you are not using key and certificate by GlobalServer, then you can use
properties of this plugin instead, but this have limited features and
@link(TCustomSSL.KeyPassword) not working properly yet!
For handling keys and certificates you can use this properties:
@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA),
@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate),
@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey),
@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate),
@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats
of keys and certificates refer to StreamSecII documentation.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit ssl_streamsec;
interface
uses
SysUtils, Classes,
blcksock, synsock, synautil, synacode,
TlsInternalServer, TlsSynaSock, TlsConst, StreamSecII, Asn1, X509Base,
SecUtils;
type
{:@exclude}
TMyTLSSynSockSlave = class(TTLSSynSockSlave)
protected
procedure SetMyTLSServer(const Value: TCustomTLSInternalServer);
function GetMyTLSServer: TCustomTLSInternalServer;
published
property MyTLSServer: TCustomTLSInternalServer read GetMyTLSServer write SetMyTLSServer;
end;
{:@abstract(class implementing StreamSecII SSL plugin.)
Instance of this class will be created for each @link(TTCPBlockSocket).
You not need to create instance of this class, all is done by Synapse itself!}
TSSLStreamSec = class(TCustomSSL)
protected
FSlave: TMyTLSSynSockSlave;
FIsServer: Boolean;
FTLSServer: TCustomTLSInternalServer;
FServerCreated: Boolean;
function SSLCheck: Boolean;
function Init(server:Boolean): Boolean;
function DeInit: Boolean;
function Prepare(server:Boolean): Boolean;
procedure NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
function X500StrToStr(const Prefix: string; const Value: TX500String): string;
function X501NameToStr(const Value: TX501Name): string;
function GetCert: PASN1Struct;
public
constructor Create(const Value: TTCPBlockSocket); override;
destructor Destroy; override;
{:See @inherited}
function LibVersion: String; override;
{:See @inherited}
function LibName: String; override;
{:See @inherited and @link(ssl_streamsec) for more details.}
function Connect: boolean; override;
{:See @inherited and @link(ssl_streamsec) for more details.}
function Accept: boolean; override;
{:See @inherited}
function Shutdown: boolean; override;
{:See @inherited}
function BiShutdown: boolean; override;
{:See @inherited}
function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function WaitingData: Integer; override;
{:See @inherited}
function GetSSLVersion: string; override;
{:See @inherited}
function GetPeerSubject: string; override;
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerFingerprint: string; override;
{:See @inherited}
function GetCertInfo: string; override;
published
{:TLS server for tuning of StreamSecII.}
property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
end;
implementation
{==============================================================================}
procedure TMyTLSSynSockSlave.SetMyTLSServer(const Value: TCustomTLSInternalServer);
begin
TLSServer := Value;
end;
function TMyTLSSynSockSlave.GetMyTLSServer: TCustomTLSInternalServer;
begin
Result := TLSServer;
end;
{==============================================================================}
constructor TSSLStreamSec.Create(const Value: TTCPBlockSocket);
begin
inherited Create(Value);
FSlave := nil;
FIsServer := False;
FTLSServer := nil;
end;
destructor TSSLStreamSec.Destroy;
begin
DeInit;
inherited Destroy;
end;
function TSSLStreamSec.LibVersion: String;
begin
Result := 'StreamSecII';
end;
function TSSLStreamSec.LibName: String;
begin
Result := 'ssl_streamsec';
end;
function TSSLStreamSec.SSLCheck: Boolean;
begin
Result := true;
FLastErrorDesc := '';
if not Assigned(FSlave) then
Exit;
FLastError := FSlave.ErrorCode;
if FLastError <> 0 then
begin
FLastErrorDesc := TlsConst.AlertMsg(FLastError);
end;
end;
procedure TSSLStreamSec.NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
begin
ExplicitTrust := true;
end;
function TSSLStreamSec.Init(server:Boolean): Boolean;
var
st: TMemoryStream;
pass: ISecretKey;
ws: WideString;
begin
Result := False;
ws := FKeyPassword;
pass := TSecretKey.CreateBmpStr(PWideChar(ws), length(ws));
try
FIsServer := Server;
FSlave := TMyTLSSynSockSlave.CreateSocket(FSocket.Socket);
if Assigned(FTLSServer) then
FSlave.MyTLSServer := FTLSServer
else
if Assigned(TLSInternalServer.GlobalServer) then
FSlave.MyTLSServer := TLSInternalServer.GlobalServer
else begin
FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil);
FServerCreated := True;
end;
if server then
FSlave.MyTLSServer.ClientOrServer := cosServerSide
else
FSlave.MyTLSServer.ClientOrServer := cosClientSide;
if not FVerifyCert then
begin
FSlave.MyTLSServer.OnCertNotTrusted := NotTrustEvent;
end;
FSlave.MyTLSServer.Options.VerifyServerName := [];
FSlave.MyTLSServer.Options.Export40Bit := prAllowed;
FSlave.MyTLSServer.Options.Export56Bit := prAllowed;
FSlave.MyTLSServer.Options.RequestClientCertificate := False;
FSlave.MyTLSServer.Options.RequireClientCertificate := False;
if server and FVerifyCert then
begin
FSlave.MyTLSServer.Options.RequestClientCertificate := True;
FSlave.MyTLSServer.Options.RequireClientCertificate := True;
end;
if FCertCAFile <> '' then
FSlave.MyTLSServer.LoadRootCertsFromFile(CertCAFile);
if FCertCA <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FCertCA);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadRootCertsFromStream(st);
finally
st.free;
end;
end;
if FTrustCertificateFile <> '' then
FSlave.MyTLSServer.LoadTrustedCertsFromFile(FTrustCertificateFile);
if FTrustCertificate <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FTrustCertificate);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadTrustedCertsFromStream(st);
finally
st.free;
end;
end;
if FPrivateKeyFile <> '' then
FSlave.MyTLSServer.LoadPrivateKeyRingFromFile(FPrivateKeyFile, pass);
// FSlave.MyTLSServer.PrivateKeyRing.LoadPrivateKeyFromFile(FPrivateKeyFile, pass);
if FPrivateKey <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FPrivateKey);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadPrivateKeyRingFromStream(st, pass);
finally
st.free;
end;
end;
if FCertificateFile <> '' then
FSlave.MyTLSServer.LoadMyCertsFromFile(FCertificateFile);
if FCertificate <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FCertificate);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadMyCertsFromStream(st);
finally
st.free;
end;
end;
if FPFXfile <> '' then
FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass);
if server and FServerCreated then
begin
FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer;
FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed;
FSlave.MyTLSServer.Options.EphemeralECDHKeySize := ecs256;
FSlave.MyTLSServer.Options.SignatureRSA := prPrefer;
FSlave.MyTLSServer.Options.KeyAgreementRSA := prAllowed;
FSlave.MyTLSServer.Options.KeyAgreementECDHE := prAllowed;
FSlave.MyTLSServer.Options.KeyAgreementDHE := prPrefer;
FSlave.MyTLSServer.TLSSetupServer;
end;
Result := true;
finally
pass := nil;
end;
end;
function TSSLStreamSec.DeInit: Boolean;
var
obj: TObject;
begin
Result := True;
if assigned(FSlave) then
begin
FSlave.Close;
if FServerCreated then
obj := FSlave.TLSServer
else
obj := nil;
FSlave.Free;
obj.Free;
FSlave := nil;
end;
FSSLEnabled := false;
end;
function TSSLStreamSec.Prepare(server:Boolean): Boolean;
begin
Result := false;
DeInit;
if Init(server) then
Result := true
else
DeInit;
end;
function TSSLStreamSec.Connect: boolean;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(false) then
begin
FSlave.Open;
SSLCheck;
if FLastError <> 0 then
Exit;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLStreamSec.Accept: boolean;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(true) then
begin
FSlave.DoConnect;
SSLCheck;
if FLastError <> 0 then
Exit;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLStreamSec.Shutdown: boolean;
begin
Result := BiShutdown;
end;
function TSSLStreamSec.BiShutdown: boolean;
begin
DeInit;
Result := True;
end;
function TSSLStreamSec.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
var
l: integer;
begin
l := len;
FSlave.SendBuf(Buffer^, l, true);
Result := l;
SSLCheck;
end;
function TSSLStreamSec.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
var
l: integer;
begin
l := Len;
Result := FSlave.ReceiveBuf(Buffer^, l);
SSLCheck;
end;
function TSSLStreamSec.WaitingData: Integer;
begin
Result := 0;
while FSlave.Connected do begin
Result := FSlave.ReceiveLength;
if Result > 0 then
Break;
Sleep(1);
end;
end;
function TSSLStreamSec.GetSSLVersion: string;
begin
Result := 'SSLv3 or TLSv1';
end;
function TSSLStreamSec.GetCert: PASN1Struct;
begin
if FIsServer then
Result := FSlave.GetClientCert
else
Result := FSlave.GetServerCert;
end;
function TSSLStreamSec.GetPeerSubject: string;
var
XName: TX501Name;
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
ExtractSubject(Cert^,XName, false);
Result := X501NameToStr(XName);
end;
end;
function TSSLStreamSec.GetPeerName: string;
var
XName: TX501Name;
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
ExtractSubject(Cert^,XName, false);
Result := XName.commonName.Str;
end;
end;
function TSSLStreamSec.GetPeerIssuer: string;
var
XName: TX501Name;
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
ExtractIssuer(Cert^, XName, false);
Result := X501NameToStr(XName);
end;
end;
function TSSLStreamSec.GetPeerFingerprint: string;
var
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
Result := MD5(Cert.ContentAsOctetString);
end;
function TSSLStreamSec.GetCertInfo: string;
var
Cert: PASN1Struct;
l: Tstringlist;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
l := TStringList.Create;
try
Asn1.RenderAsText(cert^, l, true, true, true, 2);
Result := l.Text;
finally
l.free;
end;
end;
end;
function TSSLStreamSec.X500StrToStr(const Prefix: string;
const Value: TX500String): string;
begin
if Value.Str = '' then
Result := ''
else
Result := '/' + Prefix + '=' + Value.Str;
end;
function TSSLStreamSec.X501NameToStr(const Value: TX501Name): string;
begin
Result := X500StrToStr('CN',Value.commonName) +
X500StrToStr('C',Value.countryName) +
X500StrToStr('L',Value.localityName) +
X500StrToStr('ST',Value.stateOrProvinceName) +
X500StrToStr('O',Value.organizationName) +
X500StrToStr('OU',Value.organizationalUnitName) +
X500StrToStr('T',Value.title) +
X500StrToStr('N',Value.name) +
X500StrToStr('G',Value.givenName) +
X500StrToStr('I',Value.initials) +
X500StrToStr('SN',Value.surname) +
X500StrToStr('GQ',Value.generationQualifier) +
X500StrToStr('DNQ',Value.dnQualifier) +
X500StrToStr('E',Value.emailAddress);
end;
{==============================================================================}
initialization
SSLImplementation := TSSLStreamSec;
finalization
end.
TransGUI/synapse/source/lib/tlntsend.pas 0000644 0000000 0000000 00000025366 11366572451 017326 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.003.001 |
|==============================================================================|
| Content: TELNET and SSH2 client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2002-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(Telnet script client)
Used RFC: RFC-854
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit tlntsend;
interface
uses
SysUtils, Classes,
blcksock, synautil;
const
cTelnetProtocol = '23';
cSSHProtocol = '22';
TLNT_EOR = #239;
TLNT_SE = #240;
TLNT_NOP = #241;
TLNT_DATA_MARK = #242;
TLNT_BREAK = #243;
TLNT_IP = #244;
TLNT_AO = #245;
TLNT_AYT = #246;
TLNT_EC = #247;
TLNT_EL = #248;
TLNT_GA = #249;
TLNT_SB = #250;
TLNT_WILL = #251;
TLNT_WONT = #252;
TLNT_DO = #253;
TLNT_DONT = #254;
TLNT_IAC = #255;
type
{:@abstract(State of telnet protocol). Used internaly by TTelnetSend.}
TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT,
tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC);
{:@abstract(Class with implementation of Telnet/SSH script client.)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TTelnetSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FBuffer: Ansistring;
FState: TTelnetState;
FSessionLog: Ansistring;
FSubNeg: Ansistring;
FSubType: Ansichar;
FTermType: Ansistring;
function Connect: Boolean;
function Negotiate(const Buf: Ansistring): Ansistring;
procedure FilterHook(Sender: TObject; var Value: AnsiString);
public
constructor Create;
destructor Destroy; override;
{:Connects to Telnet server.}
function Login: Boolean;
{:Connects to SSH2 server and login by Username and Password properties.
You must use some of SSL plugins with SSH support. For exammple CryptLib.}
function SSHLogin: Boolean;
{:Logout from telnet server.}
procedure Logout;
{:Send this data to telnet server.}
procedure Send(const Value: string);
{:Reading data from telnet server until Value is readed. If it is not readed
until timeout, result is @false. Otherwise result is @true.}
function WaitFor(const Value: string): Boolean;
{:Read data terminated by terminator from telnet server.}
function RecvTerminated(const Terminator: string): string;
{:Read string from telnet server.}
function RecvString: string;
published
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
{:all readed datas in this session (from connect) is stored in this large
string.}
property SessionLog: Ansistring read FSessionLog write FSessionLog;
{:Terminal type indentification. By default is 'SYNAPSE'.}
property TermType: Ansistring read FTermType write FTermType;
end;
implementation
constructor TTelnetSend.Create;
begin
inherited Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.OnReadFilter := FilterHook;
FTimeout := 60000;
FTargetPort := cTelnetProtocol;
FSubNeg := '';
FSubType := #0;
FTermType := 'SYNAPSE';
end;
destructor TTelnetSend.Destroy;
begin
FSock.Free;
inherited Destroy;
end;
function TTelnetSend.Connect: Boolean;
begin
// Do not call this function! It is calling by LOGIN method!
FBuffer := '';
FSessionLog := '';
FState := tsDATA;
FSock.CloseSocket;
FSock.LineBuffer := '';
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
Result := FSock.LastError = 0;
end;
function TTelnetSend.RecvTerminated(const Terminator: string): string;
begin
Result := FSock.RecvTerminated(FTimeout, Terminator);
end;
function TTelnetSend.RecvString: string;
begin
Result := FSock.RecvTerminated(FTimeout, CRLF);
end;
function TTelnetSend.WaitFor(const Value: string): Boolean;
begin
Result := FSock.RecvTerminated(FTimeout, Value) <> '';
end;
procedure TTelnetSend.FilterHook(Sender: TObject; var Value: AnsiString);
begin
Value := Negotiate(Value);
FSessionLog := FSessionLog + Value;
end;
function TTelnetSend.Negotiate(const Buf: Ansistring): Ansistring;
var
n: integer;
c: Ansichar;
Reply: Ansistring;
SubReply: Ansistring;
begin
Result := '';
for n := 1 to Length(Buf) do
begin
c := Buf[n];
Reply := '';
case FState of
tsData:
if c = TLNT_IAC then
FState := tsIAC
else
Result := Result + c;
tsIAC:
case c of
TLNT_IAC:
begin
FState := tsData;
Result := Result + TLNT_IAC;
end;
TLNT_WILL:
FState := tsIAC_WILL;
TLNT_WONT:
FState := tsIAC_WONT;
TLNT_DONT:
FState := tsIAC_DONT;
TLNT_DO:
FState := tsIAC_DO;
TLNT_EOR:
FState := tsDATA;
TLNT_SB:
begin
FState := tsIAC_SB;
FSubType := #0;
FSubNeg := '';
end;
else
FState := tsData;
end;
tsIAC_WILL:
begin
case c of
#3: //suppress GA
Reply := TLNT_DO;
else
Reply := TLNT_DONT;
end;
FState := tsData;
end;
tsIAC_WONT:
begin
Reply := TLNT_DONT;
FState := tsData;
end;
tsIAC_DO:
begin
case c of
#24: //termtype
Reply := TLNT_WILL;
else
Reply := TLNT_WONT;
end;
FState := tsData;
end;
tsIAC_DONT:
begin
Reply := TLNT_WONT;
FState := tsData;
end;
tsIAC_SB:
begin
FSubType := c;
FState := tsIAC_SBDATA;
end;
tsIAC_SBDATA:
begin
if c = TLNT_IAC then
FState := tsSBDATA_IAC
else
FSubNeg := FSubNeg + c;
end;
tsSBDATA_IAC:
case c of
TLNT_IAC:
begin
FState := tsIAC_SBDATA;
FSubNeg := FSubNeg + c;
end;
TLNT_SE:
begin
SubReply := '';
case FSubType of
#24: //termtype
begin
if (FSubNeg <> '') and (FSubNeg[1] = #1) then
SubReply := #0 + FTermType;
end;
end;
Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE);
FState := tsDATA;
end;
else
FState := tsDATA;
end;
else
FState := tsData;
end;
if Reply <> '' then
Sock.SendString(TLNT_IAC + Reply + c);
end;
end;
procedure TTelnetSend.Send(const Value: string);
begin
Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC));
end;
function TTelnetSend.Login: Boolean;
begin
Result := False;
if not Connect then
Exit;
Result := True;
end;
function TTelnetSend.SSHLogin: Boolean;
begin
Result := False;
if Connect then
begin
FSock.SSL.SSLType := LT_SSHv2;
FSock.SSL.Username := FUsername;
FSock.SSL.Password := FPassword;
FSock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
procedure TTelnetSend.Logout;
begin
FSock.CloseSocket;
end;
end.
TransGUI/synapse/source/lib/ssl_openssl.pas 0000644 0000000 0000000 00000051343 11520020531 020004 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.001.001 |
|==============================================================================|
| Content: SSL support by OpenSSL |
|==============================================================================|
| Copyright (c)1999-2008, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005-2008. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//requires OpenSSL libraries!
{:@abstract(SSL plugin for OpenSSL)
You need OpenSSL libraries version 0.9.7. It can work with 0.9.6 too, but
application mysteriously crashing when you are using freePascal on Linux.
Use Kylix on Linux is OK! If you have version 0.9.7 on Linux, then I not see
any problems with FreePascal.
OpenSSL libraries are loaded dynamicly - you not need OpenSSl librares even you
compile your application with this unit. SSL just not working when you not have
OpenSSL libraries.
This plugin have limited support for .NET too! Because is not possible to use
callbacks with CDECL calling convention under .NET, is not supported
key/certificate passwords and multithread locking. :-(
For handling keys and certificates you can use this properties:
@link(TCustomSSL.CertificateFile) for PEM or ASN1 DER (cer) format. @br
@link(TCustomSSL.Certificate) for ASN1 DER format only. @br
@link(TCustomSSL.PrivateKeyFile) for PEM or ASN1 DER (key) format. @br
@link(TCustomSSL.PrivateKey) for ASN1 DER format only. @br
@link(TCustomSSL.CertCAFile) for PEM CA certificate bundle. @br
@link(TCustomSSL.PFXFile) for PFX format. @br
@link(TCustomSSL.PFX) for PFX format from binary string. @br
This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS
server without explicitly assigned key and certificate, then this plugin create
Ad-Hoc key and certificate for each incomming connection by self. It slowdown
accepting of new connections!
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit ssl_openssl;
interface
uses
SysUtils, Classes,
blcksock, synsock, synautil,
{$IFDEF CIL}
System.Text,
{$ENDIF}
ssl_openssl_lib;
type
{:@abstract(class implementing OpenSSL SSL plugin.)
Instance of this class will be created for each @link(TTCPBlockSocket).
You not need to create instance of this class, all is done by Synapse itself!}
TSSLOpenSSL = class(TCustomSSL)
protected
FSsl: PSSL;
Fctx: PSSL_CTX;
function SSLCheck: Boolean;
function SetSslKeys: boolean;
function Init(server:Boolean): Boolean;
function DeInit: Boolean;
function Prepare(server:Boolean): Boolean;
function LoadPFX(pfxdata: ansistring): Boolean;
function CreateSelfSignedCert(Host: string): Boolean; override;
public
{:See @inherited}
constructor Create(const Value: TTCPBlockSocket); override;
destructor Destroy; override;
{:See @inherited}
function LibVersion: String; override;
{:See @inherited}
function LibName: String; override;
{:See @inherited and @link(ssl_cryptlib) for more details.}
function Connect: boolean; override;
{:See @inherited and @link(ssl_cryptlib) for more details.}
function Accept: boolean; override;
{:See @inherited}
function Shutdown: boolean; override;
{:See @inherited}
function BiShutdown: boolean; override;
{:See @inherited}
function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function WaitingData: Integer; override;
{:See @inherited}
function GetSSLVersion: string; override;
{:See @inherited}
function GetPeerSubject: string; override;
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerFingerprint: string; override;
{:See @inherited}
function GetCertInfo: string; override;
{:See @inherited}
function GetCipherName: string; override;
{:See @inherited}
function GetCipherBits: integer; override;
{:See @inherited}
function GetCipherAlgBits: integer; override;
{:See @inherited}
function GetVerifyCert: integer; override;
end;
implementation
{==============================================================================}
{$IFNDEF CIL}
function PasswordCallback(buf:PAnsiChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl;
var
Password: AnsiString;
begin
Password := '';
if TCustomSSL(userdata) is TCustomSSL then
Password := TCustomSSL(userdata).KeyPassword;
if Length(Password) > (Size - 1) then
SetLength(Password, Size - 1);
Result := Length(Password);
StrLCopy(buf, PAnsiChar(Password + #0), Result + 1);
end;
{$ENDIF}
{==============================================================================}
constructor TSSLOpenSSL.Create(const Value: TTCPBlockSocket);
begin
inherited Create(Value);
FCiphers := 'DEFAULT';
FSsl := nil;
Fctx := nil;
end;
destructor TSSLOpenSSL.Destroy;
begin
DeInit;
inherited Destroy;
end;
function TSSLOpenSSL.LibVersion: String;
begin
Result := SSLeayversion(0);
end;
function TSSLOpenSSL.LibName: String;
begin
Result := 'ssl_openssl';
end;
function TSSLOpenSSL.SSLCheck: Boolean;
var
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
s : AnsiString;
begin
Result := true;
FLastErrorDesc := '';
FLastError := ErrGetError;
ErrClearError;
if FLastError <> 0 then
begin
Result := False;
{$IFDEF CIL}
sb := StringBuilder.Create(256);
ErrErrorString(FLastError, sb, 256);
FLastErrorDesc := Trim(sb.ToString);
{$ELSE}
s := StringOfChar(#0, 256);
ErrErrorString(FLastError, s, Length(s));
FLastErrorDesc := s;
{$ENDIF}
end;
end;
function TSSLOpenSSL.CreateSelfSignedCert(Host: string): Boolean;
var
pk: EVP_PKEY;
x: PX509;
rsa: PRSA;
t: PASN1_UTCTIME;
name: PX509_NAME;
b: PBIO;
xn, y: integer;
s: AnsiString;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
Result := True;
pk := EvpPkeynew;
x := X509New;
try
rsa := RsaGenerateKey(1024, $10001, nil, nil);
EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa);
X509SetVersion(x, 2);
Asn1IntegerSet(X509getSerialNumber(x), 0);
t := Asn1UtctimeNew;
try
X509GmtimeAdj(t, -60 * 60 *24);
X509SetNotBefore(x, t);
X509GmtimeAdj(t, 60 * 60 * 60 *24);
X509SetNotAfter(x, t);
finally
Asn1UtctimeFree(t);
end;
X509SetPubkey(x, pk);
Name := X509GetSubjectName(x);
X509NameAddEntryByTxt(Name, 'C', $1001, 'CZ', -1, -1, 0);
X509NameAddEntryByTxt(Name, 'CN', $1001, host, -1, -1, 0);
x509SetIssuerName(x, Name);
x509Sign(x, pk, EvpGetDigestByName('SHA1'));
b := BioNew(BioSMem);
try
i2dX509Bio(b, x);
xn := bioctrlpending(b);
{$IFDEF CIL}
sb := StringBuilder.Create(xn);
y := bioread(b, sb, xn);
if y > 0 then
begin
sb.Length := y;
s := sb.ToString;
end;
{$ELSE}
setlength(s, xn);
y := bioread(b, s, xn);
if y > 0 then
setlength(s, y);
{$ENDIF}
finally
BioFreeAll(b);
end;
FCertificate := s;
b := BioNew(BioSMem);
try
i2dPrivatekeyBio(b, pk);
xn := bioctrlpending(b);
{$IFDEF CIL}
sb := StringBuilder.Create(xn);
y := bioread(b, sb, xn);
if y > 0 then
begin
sb.Length := y;
s := sb.ToString;
end;
{$ELSE}
setlength(s, xn);
y := bioread(b, s, xn);
if y > 0 then
setlength(s, y);
{$ENDIF}
finally
BioFreeAll(b);
end;
FPrivatekey := s;
finally
X509free(x);
EvpPkeyFree(pk);
end;
end;
function TSSLOpenSSL.LoadPFX(pfxdata: Ansistring): Boolean;
var
cert, pkey, ca: SslPtr;
b: PBIO;
p12: SslPtr;
begin
Result := False;
b := BioNew(BioSMem);
try
BioWrite(b, pfxdata, Length(PfxData));
p12 := d2iPKCS12bio(b, nil);
if not Assigned(p12) then
Exit;
try
cert := nil;
pkey := nil;
ca := nil;
if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then
if SSLCTXusecertificate(Fctx, cert) > 0 then
if SSLCTXusePrivateKey(Fctx, pkey) > 0 then
Result := True;
finally
PKCS12free(p12);
end;
finally
BioFreeAll(b);
end;
end;
function TSSLOpenSSL.SetSslKeys: boolean;
var
st: TFileStream;
s: string;
begin
Result := False;
if not assigned(FCtx) then
Exit;
try
if FCertificateFile <> '' then
if SslCtxUseCertificateChainFile(FCtx, FCertificateFile) <> 1 then
if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_PEM) <> 1 then
if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_ASN1) <> 1 then
Exit;
if FCertificate <> '' then
if SslCtxUseCertificateASN1(FCtx, length(FCertificate), FCertificate) <> 1 then
Exit;
SSLCheck;
if FPrivateKeyFile <> '' then
if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_PEM) <> 1 then
if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_ASN1) <> 1 then
Exit;
if FPrivateKey <> '' then
if SslCtxUsePrivateKeyASN1(EVP_PKEY_RSA, FCtx, FPrivateKey, length(FPrivateKey)) <> 1 then
Exit;
SSLCheck;
if FCertCAFile <> '' then
if SslCtxLoadVerifyLocations(FCtx, FCertCAFile, '') <> 1 then
Exit;
if FPFXfile <> '' then
begin
try
st := TFileStream.Create(FPFXfile, fmOpenRead or fmShareDenyNone);
try
s := ReadStrFromStream(st, st.Size);
finally
st.Free;
end;
if not LoadPFX(s) then
Exit;
except
on Exception do
Exit;
end;
end;
if FPFX <> '' then
if not LoadPFX(FPfx) then
Exit;
SSLCheck;
Result := True;
finally
SSLCheck;
end;
end;
function TSSLOpenSSL.Init(server:Boolean): Boolean;
var
s: AnsiString;
begin
Result := False;
FLastErrorDesc := '';
FLastError := 0;
Fctx := nil;
case FSSLType of
LT_SSLv2:
Fctx := SslCtxNew(SslMethodV2);
LT_SSLv3:
Fctx := SslCtxNew(SslMethodV3);
LT_TLSv1:
Fctx := SslCtxNew(SslMethodTLSV1);
LT_all:
Fctx := SslCtxNew(SslMethodV23);
else
Exit;
end;
if Fctx = nil then
begin
SSLCheck;
Exit;
end
else
begin
s := FCiphers;
SslCtxSetCipherList(Fctx, s);
if FVerifyCert then
SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil)
else
SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil);
{$IFNDEF CIL}
SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback);
SslCtxSetDefaultPasswdCbUserdata(FCtx, self);
{$ENDIF}
if server and (FCertificateFile = '') and (FCertificate = '')
and (FPFXfile = '') and (FPFX = '') then
begin
CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
end;
if not SetSSLKeys then
Exit
else
begin
Fssl := nil;
Fssl := SslNew(Fctx);
if Fssl = nil then
begin
SSLCheck;
exit;
end;
end;
end;
Result := true;
end;
function TSSLOpenSSL.DeInit: Boolean;
begin
Result := True;
if assigned (Fssl) then
sslfree(Fssl);
Fssl := nil;
if assigned (Fctx) then
begin
SslCtxFree(Fctx);
Fctx := nil;
ErrRemoveState(0);
end;
FSSLEnabled := False;
end;
function TSSLOpenSSL.Prepare(server:Boolean): Boolean;
begin
Result := false;
DeInit;
if Init(server) then
Result := true
else
DeInit;
end;
function TSSLOpenSSL.Connect: boolean;
var
x: integer;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(False) then
begin
{$IFDEF CIL}
if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
{$ELSE}
if sslsetfd(FSsl, FSocket.Socket) < 1 then
{$ENDIF}
begin
SSLCheck;
Exit;
end;
x := sslconnect(FSsl);
if x < 1 then
begin
SSLcheck;
Exit;
end;
if FverifyCert then
if GetVerifyCert <> 0 then
Exit;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLOpenSSL.Accept: boolean;
var
x: integer;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(True) then
begin
{$IFDEF CIL}
if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
{$ELSE}
if sslsetfd(FSsl, FSocket.Socket) < 1 then
{$ENDIF}
begin
SSLCheck;
Exit;
end;
x := sslAccept(FSsl);
if x < 1 then
begin
SSLcheck;
Exit;
end;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLOpenSSL.Shutdown: boolean;
begin
if assigned(FSsl) then
sslshutdown(FSsl);
DeInit;
Result := True;
end;
function TSSLOpenSSL.BiShutdown: boolean;
var
x: integer;
begin
if assigned(FSsl) then
begin
x := sslshutdown(FSsl);
if x = 0 then
begin
Synsock.Shutdown(FSocket.Socket, 1);
sslshutdown(FSsl);
end;
end;
DeInit;
Result := True;
end;
function TSSLOpenSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
var
err: integer;
{$IFDEF CIL}
s: ansistring;
{$ENDIF}
begin
FLastError := 0;
FLastErrorDesc := '';
repeat
{$IFDEF CIL}
s := StringOf(Buffer);
Result := SslWrite(FSsl, s, Len);
{$ELSE}
Result := SslWrite(FSsl, Buffer , Len);
{$ENDIF}
err := SslGetError(FSsl, Result);
until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
if err = SSL_ERROR_ZERO_RETURN then
Result := 0
else
if (err <> 0) then
FLastError := err;
end;
function TSSLOpenSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
var
err: integer;
{$IFDEF CIL}
sb: stringbuilder;
s: ansistring;
{$ENDIF}
begin
FLastError := 0;
FLastErrorDesc := '';
repeat
{$IFDEF CIL}
sb := StringBuilder.Create(Len);
Result := SslRead(FSsl, sb, Len);
if Result > 0 then
begin
sb.Length := Result;
s := sb.ToString;
System.Array.Copy(BytesOf(s), Buffer, length(s));
end;
{$ELSE}
Result := SslRead(FSsl, Buffer , Len);
{$ENDIF}
err := SslGetError(FSsl, Result);
until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
if err = SSL_ERROR_ZERO_RETURN then
Result := 0;
if (err <> 0) then
FLastError := err;
end;
function TSSLOpenSSL.WaitingData: Integer;
begin
Result := sslpending(Fssl);
end;
function TSSLOpenSSL.GetSSLVersion: string;
begin
if not assigned(FSsl) then
Result := ''
else
Result := SSlGetVersion(FSsl);
end;
function TSSLOpenSSL.GetPeerSubject: string;
var
cert: PX509;
s: ansistring;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
if not assigned(cert) then
begin
Result := '';
Exit;
end;
{$IFDEF CIL}
sb := StringBuilder.Create(4096);
Result := X509NameOneline(X509GetSubjectName(cert), sb, 4096);
{$ELSE}
setlength(s, 4096);
Result := X509NameOneline(X509GetSubjectName(cert), s, Length(s));
{$ENDIF}
X509Free(cert);
end;
function TSSLOpenSSL.GetPeerName: string;
var
s: ansistring;
begin
s := GetPeerSubject;
s := SeparateRight(s, '/CN=');
Result := Trim(SeparateLeft(s, '/'));
end;
function TSSLOpenSSL.GetPeerIssuer: string;
var
cert: PX509;
s: ansistring;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
if not assigned(cert) then
begin
Result := '';
Exit;
end;
{$IFDEF CIL}
sb := StringBuilder.Create(4096);
Result := X509NameOneline(X509GetIssuerName(cert), sb, 4096);
{$ELSE}
setlength(s, 4096);
Result := X509NameOneline(X509GetIssuerName(cert), s, Length(s));
{$ENDIF}
X509Free(cert);
end;
function TSSLOpenSSL.GetPeerFingerprint: string;
var
cert: PX509;
x: integer;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
if not assigned(cert) then
begin
Result := '';
Exit;
end;
{$IFDEF CIL}
sb := StringBuilder.Create(EVP_MAX_MD_SIZE);
X509Digest(cert, EvpGetDigestByName('MD5'), sb, x);
sb.Length := x;
Result := sb.ToString;
{$ELSE}
setlength(Result, EVP_MAX_MD_SIZE);
X509Digest(cert, EvpGetDigestByName('MD5'), Result, x);
SetLength(Result, x);
{$ENDIF}
X509Free(cert);
end;
function TSSLOpenSSL.GetCertInfo: string;
var
cert: PX509;
x, y: integer;
b: PBIO;
s: AnsiString;
{$IFDEF CIL}
sb: stringbuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
if not assigned(cert) then
begin
Result := '';
Exit;
end;
b := BioNew(BioSMem);
try
X509Print(b, cert);
x := bioctrlpending(b);
{$IFDEF CIL}
sb := StringBuilder.Create(x);
y := bioread(b, sb, x);
if y > 0 then
begin
sb.Length := y;
s := sb.ToString;
end;
{$ELSE}
setlength(s,x);
y := bioread(b,s,x);
if y > 0 then
setlength(s, y);
{$ENDIF}
Result := ReplaceString(s, LF, CRLF);
finally
BioFreeAll(b);
end;
end;
function TSSLOpenSSL.GetCipherName: string;
begin
if not assigned(FSsl) then
Result := ''
else
Result := SslCipherGetName(SslGetCurrentCipher(FSsl));
end;
function TSSLOpenSSL.GetCipherBits: integer;
var
x: integer;
begin
if not assigned(FSsl) then
Result := 0
else
Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), x);
end;
function TSSLOpenSSL.GetCipherAlgBits: integer;
begin
if not assigned(FSsl) then
Result := 0
else
SSLCipherGetBits(SslGetCurrentCipher(FSsl), Result);
end;
function TSSLOpenSSL.GetVerifyCert: integer;
begin
if not assigned(FSsl) then
Result := 1
else
Result := SslGetVerifyResult(FSsl);
end;
{==============================================================================}
initialization
// if InitSSLInterface then
// SSLImplementation := TSSLOpenSSL;
end.
TransGUI/synapse/source/lib/synaip.pas 0000644 0000000 0000000 00000027177 11366572451 017000 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.002.001 |
|==============================================================================|
| Content: IP address support procedures and functions |
|==============================================================================|
| Copyright (c)2006-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 2006-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(IP adress support procedures and functions)}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$R-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$WARN SUSPICIOUS_TYPECAST OFF}
{$ENDIF}
unit synaip;
interface
uses
SysUtils, SynaUtil;
type
{:binary form of IPv6 adress (for string conversion routines)}
TIp6Bytes = array [0..15] of Byte;
{:binary form of IPv6 adress (for string conversion routines)}
TIp6Words = array [0..7] of Word;
{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!}
function IsIP(const Value: string): Boolean;
{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!}
function IsIP6(const Value: string): Boolean;
{:Returns a string with the "Host" ip address converted to binary form.}
function IPToID(Host: string): Ansistring;
{:Convert IPv6 address from their string form to binary byte array.}
function StrToIp6(value: string): TIp6Bytes;
{:Convert IPv6 address from binary byte array to string form.}
function Ip6ToStr(value: TIp6Bytes): string;
{:Convert IPv4 address from their string form to binary.}
function StrToIp(value: string): integer;
{:Convert IPv4 address from binary to string form.}
function IpToStr(value: integer): string;
{:Convert IPv4 address to reverse form.}
function ReverseIP(Value: AnsiString): AnsiString;
{:Convert IPv6 address to reverse form.}
function ReverseIP6(Value: AnsiString): AnsiString;
{:Expand short form of IPv6 address to long form.}
function ExpandIP6(Value: AnsiString): AnsiString;
implementation
{==============================================================================}
function IsIP(const Value: string): Boolean;
var
TempIP: string;
function ByteIsOk(const Value: string): Boolean;
var
x, n: integer;
begin
x := StrToIntDef(Value, -1);
Result := (x >= 0) and (x < 256);
// X may be in correct range, but value still may not be correct value!
// i.e. "$80"
if Result then
for n := 1 to length(Value) do
if not (AnsiChar(Value[n]) in ['0'..'9']) then
begin
Result := False;
Break;
end;
end;
begin
TempIP := Value;
Result := False;
if not ByteIsOk(Fetch(TempIP, '.')) then
Exit;
if not ByteIsOk(Fetch(TempIP, '.')) then
Exit;
if not ByteIsOk(Fetch(TempIP, '.')) then
Exit;
if ByteIsOk(TempIP) then
Result := True;
end;
{==============================================================================}
function IsIP6(const Value: string): Boolean;
var
TempIP: string;
s,t: string;
x: integer;
partcount: integer;
zerocount: integer;
First: Boolean;
begin
TempIP := Value;
Result := False;
if Value = '::' then
begin
Result := True;
Exit;
end;
partcount := 0;
zerocount := 0;
First := True;
while tempIP <> '' do
begin
s := fetch(TempIP, ':');
if not(First) and (s = '') then
Inc(zerocount);
First := False;
if zerocount > 1 then
break;
Inc(partCount);
if s = '' then
Continue;
if partCount > 8 then
break;
if tempIP = '' then
begin
t := SeparateRight(s, '%');
s := SeparateLeft(s, '%');
x := StrToIntDef('$' + t, -1);
if (x < 0) or (x > $ffff) then
break;
end;
x := StrToIntDef('$' + s, -1);
if (x < 0) or (x > $ffff) then
break;
if tempIP = '' then
if not((PartCount = 1) and (ZeroCount = 0)) then
Result := True;
end;
end;
{==============================================================================}
function IPToID(Host: string): Ansistring;
var
s: string;
i, x: Integer;
begin
Result := '';
for x := 0 to 3 do
begin
s := Fetch(Host, '.');
i := StrToIntDef(s, 0);
Result := Result + AnsiChar(i);
end;
end;
{==============================================================================}
function StrToIp(value: string): integer;
var
s: string;
i, x: Integer;
begin
Result := 0;
for x := 0 to 3 do
begin
s := Fetch(value, '.');
i := StrToIntDef(s, 0);
Result := (256 * Result) + i;
end;
end;
{==============================================================================}
function IpToStr(value: integer): string;
var
x1, x2: word;
y1, y2: byte;
begin
Result := '';
x1 := value shr 16;
x2 := value and $FFFF;
y1 := x1 div $100;
y2 := x1 mod $100;
Result := inttostr(y1) + '.' + inttostr(y2) + '.';
y1 := x2 div $100;
y2 := x2 mod $100;
Result := Result + inttostr(y1) + '.' + inttostr(y2);
end;
{==============================================================================}
function ExpandIP6(Value: AnsiString): AnsiString;
var
n: integer;
s: ansistring;
x: integer;
begin
Result := '';
if value = '' then
exit;
x := countofchar(value, ':');
if x > 7 then
exit;
if value[1] = ':' then
value := '0' + value;
if value[length(value)] = ':' then
value := value + '0';
x := 8 - x;
s := '';
for n := 1 to x do
s := s + ':0';
s := s + ':';
Result := replacestring(value, '::', s);
end;
{==============================================================================}
function StrToIp6(Value: string): TIp6Bytes;
var
IPv6: TIp6Words;
Index: Integer;
n: integer;
b1, b2: byte;
s: string;
x: integer;
begin
for n := 0 to 15 do
Result[n] := 0;
for n := 0 to 7 do
Ipv6[n] := 0;
Index := 0;
Value := ExpandIP6(value);
if value = '' then
exit;
while Value <> '' do
begin
if Index > 7 then
Exit;
s := fetch(value, ':');
if s = '@' then
break;
if s = '' then
begin
IPv6[Index] := 0;
end
else
begin
x := StrToIntDef('$' + s, -1);
if (x > 65535) or (x < 0) then
Exit;
IPv6[Index] := x;
end;
Inc(Index);
end;
for n := 0 to 7 do
begin
b1 := ipv6[n] div 256;
b2 := ipv6[n] mod 256;
Result[n * 2] := b1;
Result[(n * 2) + 1] := b2;
end;
end;
{==============================================================================}
//based on routine by the Free Pascal development team
function Ip6ToStr(value: TIp6Bytes): string;
var
i, x: byte;
zr1,zr2: set of byte;
zc1,zc2: byte;
have_skipped: boolean;
ip6w: TIp6words;
begin
zr1 := [];
zr2 := [];
zc1 := 0;
zc2 := 0;
for i := 0 to 7 do
begin
x := i * 2;
ip6w[i] := value[x] * 256 + value[x + 1];
if ip6w[i] = 0 then
begin
include(zr2, i);
inc(zc2);
end
else
begin
if zc1 < zc2 then
begin
zc1 := zc2;
zr1 := zr2;
zc2 := 0;
zr2 := [];
end;
end;
end;
if zc1 < zc2 then
begin
zr1 := zr2;
end;
SetLength(Result, 8*5-1);
SetLength(Result, 0);
have_skipped := false;
for i := 0 to 7 do
begin
if not(i in zr1) then
begin
if have_skipped then
begin
if Result = '' then
Result := '::'
else
Result := Result + ':';
have_skipped := false;
end;
Result := Result + IntToHex(Ip6w[i], 1) + ':';
end
else
begin
have_skipped := true;
end;
end;
if have_skipped then
if Result = '' then
Result := '::0'
else
Result := Result + ':';
if Result = '' then
Result := '::0';
if not (7 in zr1) then
SetLength(Result, Length(Result)-1);
Result := LowerCase(result);
end;
{==============================================================================}
function ReverseIP(Value: AnsiString): AnsiString;
var
x: Integer;
begin
Result := '';
repeat
x := LastDelimiter('.', Value);
Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x);
Delete(Value, x, Length(Value) - x + 1);
until x < 1;
if Length(Result) > 0 then
if Result[1] = '.' then
Delete(Result, 1, 1);
end;
{==============================================================================}
function ReverseIP6(Value: AnsiString): AnsiString;
var
ip6: TIp6bytes;
n: integer;
x, y: integer;
begin
ip6 := StrToIP6(Value);
x := ip6[15] div 16;
y := ip6[15] mod 16;
Result := IntToHex(y, 1) + '.' + IntToHex(x, 1);
for n := 14 downto 0 do
begin
x := ip6[n] div 16;
y := ip6[n] mod 16;
Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1);
end;
end;
{==============================================================================}
end.
TransGUI/synapse/source/lib/ldapsend.pas 0000644 0000000 0000000 00000106344 11366572451 017261 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.007.000 |
|==============================================================================|
| Content: LDAP client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(LDAP client)
Used RFC: RFC-2251, RFC-2254, RFC-2829, RFC-2830
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit ldapsend;
interface
uses
SysUtils, Classes,
blcksock, synautil, asn1util, synacode;
const
cLDAPProtocol = '389';
LDAP_ASN1_BIND_REQUEST = $60;
LDAP_ASN1_BIND_RESPONSE = $61;
LDAP_ASN1_UNBIND_REQUEST = $42;
LDAP_ASN1_SEARCH_REQUEST = $63;
LDAP_ASN1_SEARCH_ENTRY = $64;
LDAP_ASN1_SEARCH_DONE = $65;
LDAP_ASN1_SEARCH_REFERENCE = $73;
LDAP_ASN1_MODIFY_REQUEST = $66;
LDAP_ASN1_MODIFY_RESPONSE = $67;
LDAP_ASN1_ADD_REQUEST = $68;
LDAP_ASN1_ADD_RESPONSE = $69;
LDAP_ASN1_DEL_REQUEST = $4A;
LDAP_ASN1_DEL_RESPONSE = $6B;
LDAP_ASN1_MODIFYDN_REQUEST = $6C;
LDAP_ASN1_MODIFYDN_RESPONSE = $6D;
LDAP_ASN1_COMPARE_REQUEST = $6E;
LDAP_ASN1_COMPARE_RESPONSE = $6F;
LDAP_ASN1_ABANDON_REQUEST = $70;
LDAP_ASN1_EXT_REQUEST = $77;
LDAP_ASN1_EXT_RESPONSE = $78;
type
{:@abstract(LDAP attribute with list of their values)
This class holding name of LDAP attribute and list of their values. This is
descendant of TStringList class enhanced by some new properties.}
TLDAPAttribute = class(TStringList)
private
FAttributeName: AnsiString;
FIsBinary: Boolean;
protected
function Get(Index: integer): string; override;
procedure Put(Index: integer; const Value: string); override;
procedure SetAttributeName(Value: AnsiString);
published
{:Name of LDAP attribute.}
property AttributeName: AnsiString read FAttributeName Write SetAttributeName;
{:Return @true when attribute contains binary data.}
property IsBinary: Boolean read FIsBinary;
end;
{:@abstract(List of @link(TLDAPAttribute))
This object can hold list of TLDAPAttribute objects.}
TLDAPAttributeList = class(TObject)
private
FAttributeList: TList;
function GetAttribute(Index: integer): TLDAPAttribute;
public
constructor Create;
destructor Destroy; override;
{:Clear list.}
procedure Clear;
{:Return count of TLDAPAttribute objects in list.}
function Count: integer;
{:Add new TLDAPAttribute object to list.}
function Add: TLDAPAttribute;
{:Delete one TLDAPAttribute object from list.}
procedure Del(Index: integer);
{:Find and return attribute with requested name. Returns nil if not found.}
function Find(AttributeName: AnsiString): TLDAPAttribute;
{:Find and return attribute value with requested name. Returns empty string if not found.}
function Get(AttributeName: AnsiString): string;
{:List of TLDAPAttribute objects.}
property Items[Index: Integer]: TLDAPAttribute read GetAttribute; default;
end;
{:@abstract(LDAP result object)
This object can hold LDAP object. (their name and all their attributes with
values)}
TLDAPResult = class(TObject)
private
FObjectName: AnsiString;
FAttributes: TLDAPAttributeList;
public
constructor Create;
destructor Destroy; override;
published
{:Name of this LDAP object.}
property ObjectName: AnsiString read FObjectName write FObjectName;
{:Here is list of object attributes.}
property Attributes: TLDAPAttributeList read FAttributes;
end;
{:@abstract(List of LDAP result objects)
This object can hold list of LDAP objects. (for example result of LDAP SEARCH.)}
TLDAPResultList = class(TObject)
private
FResultList: TList;
function GetResult(Index: integer): TLDAPResult;
public
constructor Create;
destructor Destroy; override;
{:Clear all TLDAPResult objects in list.}
procedure Clear;
{:Return count of TLDAPResult objects in list.}
function Count: integer;
{:Create and add new TLDAPResult object to list.}
function Add: TLDAPResult;
{:List of TLDAPResult objects.}
property Items[Index: Integer]: TLDAPResult read GetResult; default;
end;
{:Define possible operations for LDAP MODIFY operations.}
TLDAPModifyOp = (
MO_Add,
MO_Delete,
MO_Replace
);
{:Specify possible values for search scope.}
TLDAPSearchScope = (
SS_BaseObject,
SS_SingleLevel,
SS_WholeSubtree
);
{:Specify possible values about alias dereferencing.}
TLDAPSearchAliases = (
SA_NeverDeref,
SA_InSearching,
SA_FindingBaseObj,
SA_Always
);
{:@abstract(Implementation of LDAP client)
(version 2 and 3)
Note: Are you missing properties for setting Username and Password? Look to
parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TLDAPSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FResultCode: Integer;
FResultString: AnsiString;
FFullResult: AnsiString;
FAutoTLS: Boolean;
FFullSSL: Boolean;
FSeq: integer;
FResponseCode: integer;
FResponseDN: AnsiString;
FReferals: TStringList;
FVersion: integer;
FSearchScope: TLDAPSearchScope;
FSearchAliases: TLDAPSearchAliases;
FSearchSizeLimit: integer;
FSearchTimeLimit: integer;
FSearchResult: TLDAPResultList;
FExtName: AnsiString;
FExtValue: AnsiString;
function Connect: Boolean;
function BuildPacket(const Value: AnsiString): AnsiString;
function ReceiveResponse: AnsiString;
function DecodeResponse(const Value: AnsiString): AnsiString;
function LdapSasl(Value: AnsiString): AnsiString;
function TranslateFilter(Value: AnsiString): AnsiString;
function GetErrorString(Value: integer): AnsiString;
public
constructor Create;
destructor Destroy; override;
{:Try to connect to LDAP server and start secure channel, when it is required.}
function Login: Boolean;
{:Try to bind to LDAP server with @link(TSynaClient.Username) and
@link(TSynaClient.Password). If this is empty strings, then it do annonymous
Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous
mode.
This method using plaintext transport of password! It is not secure!}
function Bind: Boolean;
{:Try to bind to LDAP server with @link(TSynaClient.Username) and
@link(TSynaClient.Password). If this is empty strings, then it do annonymous
Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous
mode.
This method using SASL with DIGEST-MD5 method for secure transfer of your
password.}
function BindSasl: Boolean;
{:Close connection to LDAP server.}
function Logout: Boolean;
{:Modify content of LDAP attribute on this object.}
function Modify(obj: AnsiString; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean;
{:Add list of attributes to specified object.}
function Add(obj: AnsiString; const Value: TLDAPAttributeList): Boolean;
{:Delete this LDAP object from server.}
function Delete(obj: AnsiString): Boolean;
{:Modify object name of this LDAP object.}
function ModifyDN(obj, newRDN, newSuperior: AnsiString; DeleteoldRDN: Boolean): Boolean;
{:Try to compare Attribute value with this LDAP object.}
function Compare(obj, AttributeValue: AnsiString): Boolean;
{:Search LDAP base for LDAP objects by Filter.}
function Search(obj: AnsiString; TypesOnly: Boolean; Filter: AnsiString;
const Attributes: TStrings): Boolean;
{:Call any LDAPv3 extended command.}
function Extended(const Name, Value: AnsiString): Boolean;
{:Try to start SSL/TLS connection to LDAP server.}
function StartTLS: Boolean;
published
{:Specify version of used LDAP protocol. Default value is 3.}
property Version: integer read FVersion Write FVersion;
{:Result code of last LDAP operation.}
property ResultCode: Integer read FResultCode;
{:Human readable description of result code of last LDAP operation.}
property ResultString: AnsiString read FResultString;
{:Binary string with full last response of LDAP server. This string is
encoded by ASN.1 BER encoding! You need this only for debugging.}
property FullResult: AnsiString read FFullResult;
{:If @true, then try to start TSL mode in Login procedure.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:If @true, then use connection to LDAP server through SSL/TLS tunnel.}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{:Sequence number of last LDAp command. It is incremented by any LDAP command.}
property Seq: integer read FSeq;
{:Specify what search scope is used in search command.}
property SearchScope: TLDAPSearchScope read FSearchScope Write FSearchScope;
{:Specify how to handle aliases in search command.}
property SearchAliases: TLDAPSearchAliases read FSearchAliases Write FSearchAliases;
{:Specify result size limit in search command. Value 0 means without limit.}
property SearchSizeLimit: integer read FSearchSizeLimit Write FSearchSizeLimit;
{:Specify search time limit in search command (seconds). Value 0 means
without limit.}
property SearchTimeLimit: integer read FSearchTimeLimit Write FSearchTimeLimit;
{:Here is result of search command.}
property SearchResult: TLDAPResultList read FSearchResult;
{:On each LDAP operation can LDAP server return some referals URLs. Here is
their list.}
property Referals: TStringList read FReferals;
{:When you call @link(Extended) operation, then here is result Name returned
by server.}
property ExtName: AnsiString read FExtName;
{:When you call @link(Extended) operation, then here is result Value returned
by server.}
property ExtValue: AnsiString read FExtValue;
{:TCP socket used by all LDAP operations.}
property Sock: TTCPBlockSocket read FSock;
end;
{:Dump result of LDAP SEARCH into human readable form. Good for debugging.}
function LDAPResultDump(const Value: TLDAPResultList): AnsiString;
implementation
{==============================================================================}
function TLDAPAttribute.Get(Index: integer): string;
begin
Result := inherited Get(Index);
if FIsbinary then
Result := DecodeBase64(Result);
end;
procedure TLDAPAttribute.Put(Index: integer; const Value: string);
var
s: AnsiString;
begin
s := Value;
if FIsbinary then
s := EncodeBase64(Value)
else
s :=UnquoteStr(s, '"');
inherited Put(Index, s);
end;
procedure TLDAPAttribute.SetAttributeName(Value: AnsiString);
begin
FAttributeName := Value;
FIsBinary := Pos(';binary', Lowercase(value)) > 0;
end;
{==============================================================================}
constructor TLDAPAttributeList.Create;
begin
inherited Create;
FAttributeList := TList.Create;
end;
destructor TLDAPAttributeList.Destroy;
begin
Clear;
FAttributeList.Free;
inherited Destroy;
end;
procedure TLDAPAttributeList.Clear;
var
n: integer;
x: TLDAPAttribute;
begin
for n := Count - 1 downto 0 do
begin
x := GetAttribute(n);
if Assigned(x) then
x.Free;
end;
FAttributeList.Clear;
end;
function TLDAPAttributeList.Count: integer;
begin
Result := FAttributeList.Count;
end;
function TLDAPAttributeList.Get(AttributeName: AnsiString): string;
var
x: TLDAPAttribute;
begin
Result := '';
x := self.Find(AttributeName);
if x <> nil then
if x.Count > 0 then
Result := x[0];
end;
function TLDAPAttributeList.GetAttribute(Index: integer): TLDAPAttribute;
begin
Result := nil;
if Index < Count then
Result := TLDAPAttribute(FAttributeList[Index]);
end;
function TLDAPAttributeList.Add: TLDAPAttribute;
begin
Result := TLDAPAttribute.Create;
FAttributeList.Add(Result);
end;
procedure TLDAPAttributeList.Del(Index: integer);
var
x: TLDAPAttribute;
begin
x := GetAttribute(Index);
if Assigned(x) then
x.free;
FAttributeList.Delete(Index);
end;
function TLDAPAttributeList.Find(AttributeName: AnsiString): TLDAPAttribute;
var
n: integer;
x: TLDAPAttribute;
begin
Result := nil;
AttributeName := lowercase(AttributeName);
for n := 0 to Count - 1 do
begin
x := GetAttribute(n);
if Assigned(x) then
if lowercase(x.AttributeName) = Attributename then
begin
result := x;
break;
end;
end;
end;
{==============================================================================}
constructor TLDAPResult.Create;
begin
inherited Create;
FAttributes := TLDAPAttributeList.Create;
end;
destructor TLDAPResult.Destroy;
begin
FAttributes.Free;
inherited Destroy;
end;
{==============================================================================}
constructor TLDAPResultList.Create;
begin
inherited Create;
FResultList := TList.Create;
end;
destructor TLDAPResultList.Destroy;
begin
Clear;
FResultList.Free;
inherited Destroy;
end;
procedure TLDAPResultList.Clear;
var
n: integer;
x: TLDAPResult;
begin
for n := Count - 1 downto 0 do
begin
x := GetResult(n);
if Assigned(x) then
x.Free;
end;
FResultList.Clear;
end;
function TLDAPResultList.Count: integer;
begin
Result := FResultList.Count;
end;
function TLDAPResultList.GetResult(Index: integer): TLDAPResult;
begin
Result := nil;
if Index < Count then
Result := TLDAPResult(FResultList[Index]);
end;
function TLDAPResultList.Add: TLDAPResult;
begin
Result := TLDAPResult.Create;
FResultList.Add(Result);
end;
{==============================================================================}
constructor TLDAPSend.Create;
begin
inherited Create;
FReferals := TStringList.Create;
FFullResult := '';
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FTimeout := 60000;
FTargetPort := cLDAPProtocol;
FAutoTLS := False;
FFullSSL := False;
FSeq := 0;
FVersion := 3;
FSearchScope := SS_WholeSubtree;
FSearchAliases := SA_Always;
FSearchSizeLimit := 0;
FSearchTimeLimit := 0;
FSearchResult := TLDAPResultList.Create;
end;
destructor TLDAPSend.Destroy;
begin
FSock.Free;
FSearchResult.Free;
FReferals.Free;
inherited Destroy;
end;
function TLDAPSend.GetErrorString(Value: integer): AnsiString;
begin
case Value of
0:
Result := 'Success';
1:
Result := 'Operations error';
2:
Result := 'Protocol error';
3:
Result := 'Time limit Exceeded';
4:
Result := 'Size limit Exceeded';
5:
Result := 'Compare FALSE';
6:
Result := 'Compare TRUE';
7:
Result := 'Auth method not supported';
8:
Result := 'Strong auth required';
9:
Result := '-- reserved --';
10:
Result := 'Referal';
11:
Result := 'Admin limit exceeded';
12:
Result := 'Unavailable critical extension';
13:
Result := 'Confidentality required';
14:
Result := 'Sasl bind in progress';
16:
Result := 'No such attribute';
17:
Result := 'Undefined attribute type';
18:
Result := 'Inappropriate matching';
19:
Result := 'Constraint violation';
20:
Result := 'Attribute or value exists';
21:
Result := 'Invalid attribute syntax';
32:
Result := 'No such object';
33:
Result := 'Alias problem';
34:
Result := 'Invalid DN syntax';
36:
Result := 'Alias dereferencing problem';
48:
Result := 'Inappropriate authentication';
49:
Result := 'Invalid credentials';
50:
Result := 'Insufficient access rights';
51:
Result := 'Busy';
52:
Result := 'Unavailable';
53:
Result := 'Unwilling to perform';
54:
Result := 'Loop detect';
64:
Result := 'Naming violation';
65:
Result := 'Object class violation';
66:
Result := 'Not allowed on non leaf';
67:
Result := 'Not allowed on RDN';
68:
Result := 'Entry already exists';
69:
Result := 'Object class mods prohibited';
71:
Result := 'Affects multiple DSAs';
80:
Result := 'Other';
else
Result := '--unknown--';
end;
end;
function TLDAPSend.Connect: Boolean;
begin
// Do not call this function! It is calling by LOGIN method!
FSock.CloseSocket;
FSock.LineBuffer := '';
FSeq := 0;
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError = 0 then
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError = 0 then
if FFullSSL then
FSock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
function TLDAPSend.BuildPacket(const Value: AnsiString): AnsiString;
begin
Inc(FSeq);
Result := ASNObject(ASNObject(ASNEncInt(FSeq), ASN1_INT) + Value, ASN1_SEQ);
end;
function TLDAPSend.ReceiveResponse: AnsiString;
var
x: Byte;
i,j: integer;
begin
Result := '';
FFullResult := '';
x := FSock.RecvByte(FTimeout);
if x <> ASN1_SEQ then
Exit;
Result := AnsiChar(x);
x := FSock.RecvByte(FTimeout);
Result := Result + AnsiChar(x);
if x < $80 then
i := 0
else
i := x and $7F;
if i > 0 then
Result := Result + FSock.RecvBufferStr(i, Ftimeout);
if FSock.LastError <> 0 then
begin
Result := '';
Exit;
end;
//get length of LDAP packet
j := 2;
i := ASNDecLen(j, Result);
//retreive rest of LDAP packet
if i > 0 then
Result := Result + FSock.RecvBufferStr(i, Ftimeout);
if FSock.LastError <> 0 then
begin
Result := '';
Exit;
end;
FFullResult := Result;
end;
function TLDAPSend.DecodeResponse(const Value: AnsiString): AnsiString;
var
i, x: integer;
Svt: Integer;
s, t: AnsiString;
begin
Result := '';
FResultCode := -1;
FResultstring := '';
FResponseCode := -1;
FResponseDN := '';
FReferals.Clear;
i := 1;
ASNItem(i, Value, Svt);
x := StrToIntDef(ASNItem(i, Value, Svt), 0);
if (svt <> ASN1_INT) or (x <> FSeq) then
Exit;
s := ASNItem(i, Value, Svt);
FResponseCode := svt;
if FResponseCode in [LDAP_ASN1_BIND_RESPONSE, LDAP_ASN1_SEARCH_DONE,
LDAP_ASN1_MODIFY_RESPONSE, LDAP_ASN1_ADD_RESPONSE, LDAP_ASN1_DEL_RESPONSE,
LDAP_ASN1_MODIFYDN_RESPONSE, LDAP_ASN1_COMPARE_RESPONSE,
LDAP_ASN1_EXT_RESPONSE] then
begin
FResultCode := StrToIntDef(ASNItem(i, Value, Svt), -1);
FResponseDN := ASNItem(i, Value, Svt);
FResultString := ASNItem(i, Value, Svt);
if FResultString = '' then
FResultString := GetErrorString(FResultCode);
if FResultCode = 10 then
begin
s := ASNItem(i, Value, Svt);
if svt = $A3 then
begin
x := 1;
while x < Length(s) do
begin
t := ASNItem(x, s, Svt);
FReferals.Add(t);
end;
end;
end;
end;
Result := Copy(Value, i, Length(Value) - i + 1);
end;
function TLDAPSend.LdapSasl(Value: AnsiString): AnsiString;
var
nonce, cnonce, nc, realm, qop, uri, response: AnsiString;
s: AnsiString;
a1, a2: AnsiString;
l: TStringList;
n: integer;
begin
l := TStringList.Create;
try
nonce := '';
realm := '';
l.CommaText := Value;
n := IndexByBegin('nonce=', l);
if n >= 0 then
nonce := UnQuoteStr(Trim(SeparateRight(l[n], 'nonce=')), '"');
n := IndexByBegin('realm=', l);
if n >= 0 then
realm := UnQuoteStr(Trim(SeparateRight(l[n], 'realm=')), '"');
cnonce := IntToHex(GetTick, 8);
nc := '00000001';
qop := 'auth';
uri := 'ldap/' + FSock.ResolveIpToName(FSock.GetRemoteSinIP);
a1 := md5(FUsername + ':' + realm + ':' + FPassword)
+ ':' + nonce + ':' + cnonce;
a2 := 'AUTHENTICATE:' + uri;
s := strtohex(md5(a1))+':' + nonce + ':' + nc + ':' + cnonce + ':'
+ qop +':'+strtohex(md5(a2));
response := strtohex(md5(s));
Result := 'username="' + Fusername + '",realm="' + realm + '",nonce="';
Result := Result + nonce + '",cnonce="' + cnonce + '",nc=' + nc + ',qop=';
Result := Result + qop + ',digest-uri="' + uri + '",response=' + response;
finally
l.Free;
end;
end;
function TLDAPSend.TranslateFilter(Value: AnsiString): AnsiString;
var
x: integer;
s, t, l: AnsiString;
r: string;
c: Ansichar;
attr, rule: AnsiString;
dn: Boolean;
begin
Result := '';
if Value = '' then
Exit;
s := Value;
if Value[1] = '(' then
begin
x := RPos(')', Value);
s := Copy(Value, 2, x - 2);
end;
if s = '' then
Exit;
case s[1] of
'!':
// NOT rule (recursive call)
begin
Result := ASNOBject(TranslateFilter(GetBetween('(', ')', s)), $A2);
end;
'&':
// AND rule (recursive call)
begin
repeat
t := GetBetween('(', ')', s);
s := Trim(SeparateRight(s, t));
if s <> '' then
if s[1] = ')' then
{$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1);
Result := Result + TranslateFilter(t);
until s = '';
Result := ASNOBject(Result, $A0);
end;
'|':
// OR rule (recursive call)
begin
repeat
t := GetBetween('(', ')', s);
s := Trim(SeparateRight(s, t));
if s <> '' then
if s[1] = ')' then
{$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1);
Result := Result + TranslateFilter(t);
until s = '';
Result := ASNOBject(Result, $A1);
end;
else
begin
l := Trim(SeparateLeft(s, '='));
r := Trim(SeparateRight(s, '='));
if l <> '' then
begin
c := l[Length(l)];
case c of
':':
// Extensible match
begin
{$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
dn := False;
attr := '';
rule := '';
if Pos(':dn', l) > 0 then
begin
dn := True;
l := ReplaceString(l, ':dn', '');
end;
attr := Trim(SeparateLeft(l, ':'));
rule := Trim(SeparateRight(l, ':'));
if rule = l then
rule := '';
if rule <> '' then
Result := ASNObject(rule, $81);
if attr <> '' then
Result := Result + ASNObject(attr, $82);
Result := Result + ASNObject(DecodeTriplet(r, '\'), $83);
if dn then
Result := Result + ASNObject(AsnEncInt($ff), $84)
else
Result := Result + ASNObject(AsnEncInt(0), $84);
Result := ASNOBject(Result, $a9);
end;
'~':
// Approx match
begin
{$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
Result := ASNOBject(l, ASN1_OCTSTR)
+ ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
Result := ASNOBject(Result, $a8);
end;
'>':
// Greater or equal match
begin
{$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
Result := ASNOBject(l, ASN1_OCTSTR)
+ ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
Result := ASNOBject(Result, $a5);
end;
'<':
// Less or equal match
begin
{$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
Result := ASNOBject(l, ASN1_OCTSTR)
+ ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
Result := ASNOBject(Result, $a6);
end;
else
// present
if r = '*' then
Result := ASNOBject(l, $87)
else
if Pos('*', r) > 0 then
// substrings
begin
s := Fetch(r, '*');
if s <> '' then
Result := ASNOBject(DecodeTriplet(s, '\'), $80);
while r <> '' do
begin
if Pos('*', r) <= 0 then
break;
s := Fetch(r, '*');
Result := Result + ASNOBject(DecodeTriplet(s, '\'), $81);
end;
if r <> '' then
Result := Result + ASNOBject(DecodeTriplet(r, '\'), $82);
Result := ASNOBject(l, ASN1_OCTSTR)
+ ASNOBject(Result, ASN1_SEQ);
Result := ASNOBject(Result, $a4);
end
else
begin
// Equality match
Result := ASNOBject(l, ASN1_OCTSTR)
+ ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
Result := ASNOBject(Result, $a3);
end;
end;
end;
end;
end;
end;
function TLDAPSend.Login: Boolean;
begin
Result := False;
if not Connect then
Exit;
Result := True;
if FAutoTLS then
Result := StartTLS;
end;
function TLDAPSend.Bind: Boolean;
var
s: AnsiString;
begin
s := ASNObject(ASNEncInt(FVersion), ASN1_INT)
+ ASNObject(FUsername, ASN1_OCTSTR)
+ ASNObject(FPassword, $80);
s := ASNObject(s, LDAP_ASN1_BIND_REQUEST);
Fsock.SendString(BuildPacket(s));
s := ReceiveResponse;
DecodeResponse(s);
Result := FResultCode = 0;
end;
function TLDAPSend.BindSasl: Boolean;
var
s, t: AnsiString;
x, xt: integer;
digreq: AnsiString;
begin
Result := False;
if FPassword = '' then
Result := Bind
else
begin
digreq := ASNObject(ASNEncInt(FVersion), ASN1_INT)
+ ASNObject('', ASN1_OCTSTR)
+ ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR), $A3);
digreq := ASNObject(digreq, LDAP_ASN1_BIND_REQUEST);
Fsock.SendString(BuildPacket(digreq));
s := ReceiveResponse;
t := DecodeResponse(s);
if FResultCode = 14 then
begin
s := t;
x := 1;
t := ASNItem(x, s, xt);
s := ASNObject(ASNEncInt(FVersion), ASN1_INT)
+ ASNObject('', ASN1_OCTSTR)
+ ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR)
+ ASNObject(LdapSasl(t), ASN1_OCTSTR), $A3);
s := ASNObject(s, LDAP_ASN1_BIND_REQUEST);
Fsock.SendString(BuildPacket(s));
s := ReceiveResponse;
DecodeResponse(s);
if FResultCode = 14 then
begin
Fsock.SendString(BuildPacket(digreq));
s := ReceiveResponse;
DecodeResponse(s);
end;
Result := FResultCode = 0;
end;
end;
end;
function TLDAPSend.Logout: Boolean;
begin
Fsock.SendString(BuildPacket(ASNObject('', LDAP_ASN1_UNBIND_REQUEST)));
FSock.CloseSocket;
Result := True;
end;
function TLDAPSend.Modify(obj: AnsiString; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean;
var
s: AnsiString;
n: integer;
begin
s := '';
for n := 0 to Value.Count -1 do
s := s + ASNObject(Value[n], ASN1_OCTSTR);
s := ASNObject(Value.AttributeName, ASN1_OCTSTR) + ASNObject(s, ASN1_SETOF);
s := ASNObject(ASNEncInt(Ord(Op)), ASN1_ENUM) + ASNObject(s, ASN1_SEQ);
s := ASNObject(s, ASN1_SEQ);
s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ);
s := ASNObject(s, LDAP_ASN1_MODIFY_REQUEST);
Fsock.SendString(BuildPacket(s));
s := ReceiveResponse;
DecodeResponse(s);
Result := FResultCode = 0;
end;
function TLDAPSend.Add(obj: AnsiString; const Value: TLDAPAttributeList): Boolean;
var
s, t: AnsiString;
n, m: integer;
begin
s := '';
for n := 0 to Value.Count - 1 do
begin
t := '';
for m := 0 to Value[n].Count - 1 do
t := t + ASNObject(Value[n][m], ASN1_OCTSTR);
t := ASNObject(Value[n].AttributeName, ASN1_OCTSTR)
+ ASNObject(t, ASN1_SETOF);
s := s + ASNObject(t, ASN1_SEQ);
end;
s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ);
s := ASNObject(s, LDAP_ASN1_ADD_REQUEST);
Fsock.SendString(BuildPacket(s));
s := ReceiveResponse;
DecodeResponse(s);
Result := FResultCode = 0;
end;
function TLDAPSend.Delete(obj: AnsiString): Boolean;
var
s: AnsiString;
begin
s := ASNObject(obj, LDAP_ASN1_DEL_REQUEST);
Fsock.SendString(BuildPacket(s));
s := ReceiveResponse;
DecodeResponse(s);
Result := FResultCode = 0;
end;
function TLDAPSend.ModifyDN(obj, newRDN, newSuperior: AnsiString; DeleteOldRDN: Boolean): Boolean;
var
s: AnsiString;
begin
s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(newRDN, ASN1_OCTSTR);
if DeleteOldRDN then
s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL)
else
s := s + ASNObject(ASNEncInt(0), ASN1_BOOL);
if newSuperior <> '' then
s := s + ASNObject(newSuperior, $80);
s := ASNObject(s, LDAP_ASN1_MODIFYDN_REQUEST);
Fsock.SendString(BuildPacket(s));
s := ReceiveResponse;
DecodeResponse(s);
Result := FResultCode = 0;
end;
function TLDAPSend.Compare(obj, AttributeValue: AnsiString): Boolean;
var
s: AnsiString;
begin
s := ASNObject(Trim(SeparateLeft(AttributeValue, '=')), ASN1_OCTSTR)
+ ASNObject(Trim(SeparateRight(AttributeValue, '=')), ASN1_OCTSTR);
s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ);
s := ASNObject(s, LDAP_ASN1_COMPARE_REQUEST);
Fsock.SendString(BuildPacket(s));
s := ReceiveResponse;
DecodeResponse(s);
Result := FResultCode = 0;
end;
function TLDAPSend.Search(obj: AnsiString; TypesOnly: Boolean; Filter: AnsiString;
const Attributes: TStrings): Boolean;
var
s, t, u: AnsiString;
n, i, x: integer;
r: TLDAPResult;
a: TLDAPAttribute;
begin
FSearchResult.Clear;
FReferals.Clear;
s := ASNObject(obj, ASN1_OCTSTR);
s := s + ASNObject(ASNEncInt(Ord(FSearchScope)), ASN1_ENUM);
s := s + ASNObject(ASNEncInt(Ord(FSearchAliases)), ASN1_ENUM);
s := s + ASNObject(ASNEncInt(FSearchSizeLimit), ASN1_INT);
s := s + ASNObject(ASNEncInt(FSearchTimeLimit), ASN1_INT);
if TypesOnly then
s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL)
else
s := s + ASNObject(ASNEncInt(0), ASN1_BOOL);
if Filter = '' then
Filter := '(objectclass=*)';
t := TranslateFilter(Filter);
if t = '' then
s := s + ASNObject('', ASN1_NULL)
else
s := s + t;
t := '';
for n := 0 to Attributes.Count - 1 do
t := t + ASNObject(Attributes[n], ASN1_OCTSTR);
s := s + ASNObject(t, ASN1_SEQ);
s := ASNObject(s, LDAP_ASN1_SEARCH_REQUEST);
Fsock.SendString(BuildPacket(s));
repeat
s := ReceiveResponse;
t := DecodeResponse(s);
if FResponseCode = LDAP_ASN1_SEARCH_ENTRY then
begin
//dekoduj zaznam
r := FSearchResult.Add;
n := 1;
r.ObjectName := ASNItem(n, t, x);
ASNItem(n, t, x);
if x = ASN1_SEQ then
begin
while n < Length(t) do
begin
s := ASNItem(n, t, x);
if x = ASN1_SEQ then
begin
i := n + Length(s);
a := r.Attributes.Add;
u := ASNItem(n, t, x);
a.AttributeName := u;
ASNItem(n, t, x);
if x = ASN1_SETOF then
while n < i do
begin
u := ASNItem(n, t, x);
a.Add(u);
end;
end;
end;
end;
end;
if FResponseCode = LDAP_ASN1_SEARCH_REFERENCE then
begin
n := 1;
while n < Length(t) do
FReferals.Add(ASNItem(n, t, x));
end;
until FResponseCode = LDAP_ASN1_SEARCH_DONE;
Result := FResultCode = 0;
end;
function TLDAPSend.Extended(const Name, Value: AnsiString): Boolean;
var
s, t: AnsiString;
x, xt: integer;
begin
s := ASNObject(Name, $80);
if Value <> '' then
s := s + ASNObject(Value, $81);
s := ASNObject(s, LDAP_ASN1_EXT_REQUEST);
Fsock.SendString(BuildPacket(s));
s := ReceiveResponse;
t := DecodeResponse(s);
Result := FResultCode = 0;
if Result then
begin
x := 1;
FExtName := ASNItem(x, t, xt);
FExtValue := ASNItem(x, t, xt);
end;
end;
function TLDAPSend.StartTLS: Boolean;
begin
Result := Extended('1.3.6.1.4.1.1466.20037', '');
if Result then
begin
Fsock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
{==============================================================================}
function LDAPResultDump(const Value: TLDAPResultList): AnsiString;
var
n, m, o: integer;
r: TLDAPResult;
a: TLDAPAttribute;
begin
Result := 'Results: ' + IntToStr(Value.Count) + CRLF +CRLF;
for n := 0 to Value.Count - 1 do
begin
Result := Result + 'Result: ' + IntToStr(n) + CRLF;
r := Value[n];
Result := Result + ' Object: ' + r.ObjectName + CRLF;
for m := 0 to r.Attributes.Count - 1 do
begin
a := r.Attributes[m];
Result := Result + ' Attribute: ' + a.AttributeName + CRLF;
for o := 0 to a.Count - 1 do
Result := Result + ' ' + a[o] + CRLF;
end;
end;
end;
end.
TransGUI/synapse/source/lib/laz_synapse.pas 0000644 0000000 0000000 00000001156 11466757142 020015 0 ustar root root { This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit laz_synapse;
interface
uses
asn1util, blcksock, clamsend, dnssend, ftpsend, ftptsend, httpsend,
imapsend, ldapsend, mimeinln, mimemess, mimepart, nntpsend, pingsend,
pop3send, slogsend, smtpsend, snmpsend, sntpsend, synachar, synacode,
synacrypt, synadbg, synafpc, synaicnv, synaip, synamisc, synaser, synautil,
synsock, tlntsend, LazarusPackageIntf;
implementation
procedure Register;
begin
end;
initialization
RegisterPackage('laz_synapse', @Register);
end.
TransGUI/synapse/source/lib/ssl_sbb.pas 0000644 0000000 0000000 00000047714 11366572451 017123 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.000.003 |
|==============================================================================|
| Content: SSL support for SecureBlackBox |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Allen Drennan (adrennan@wiredred.com) |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(SSL plugin for Eldos SecureBlackBox)
For handling keys and certificates you can use this properties:
@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA),
@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate),
@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey),
@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate),
@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats
of keys and certificates refer to SecureBlackBox documentation.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit ssl_sbb;
interface
uses
SysUtils, Classes, Windows, blcksock, synsock, synautil, synacode,
SBClient, SBServer, SBX509, SBWinCertStorage, SBCustomCertStorage,
SBUtils, SBConstants, SBSessionPool;
const
DEFAULT_RECV_BUFFER=32768;
type
{:@abstract(class implementing SecureBlackbox SSL plugin.)
Instance of this class will be created for each @link(TTCPBlockSocket).
You not need to create instance of this class, all is done by Synapse itself!}
TSSLSBB=class(TCustomSSL)
protected
FServer: Boolean;
FElSecureClient:TElSecureClient;
FElSecureServer:TElSecureServer;
FElCertStorage:TElMemoryCertStorage;
FElX509Certificate:TElX509Certificate;
FElX509CACertificate:TElX509Certificate;
FCipherSuites:TBits;
private
FRecvBuffer:String;
FRecvBuffers:String;
FRecvBuffersLock:TRTLCriticalSection;
FRecvDecodedBuffers:String;
function GetCipherSuite:Integer;
procedure Reset;
function Prepare(Server:Boolean):Boolean;
procedure OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean);
procedure OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt);
procedure OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;var Written:LongInt);
procedure OnData(Sender:TObject;Buffer:Pointer;Size:LongInt);
public
constructor Create(const Value: TTCPBlockSocket); override;
destructor Destroy; override;
{:See @inherited}
function LibVersion: String; override;
{:See @inherited}
function LibName: String; override;
{:See @inherited and @link(ssl_sbb) for more details.}
function Connect: boolean; override;
{:See @inherited and @link(ssl_sbb) for more details.}
function Accept: boolean; override;
{:See @inherited}
function Shutdown: boolean; override;
{:See @inherited}
function BiShutdown: boolean; override;
{:See @inherited}
function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function WaitingData: Integer; override;
{:See @inherited}
function GetSSLVersion: string; override;
{:See @inherited}
function GetPeerSubject: string; override;
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerFingerprint: string; override;
{:See @inherited}
function GetCertInfo: string; override;
published
property ElSecureClient:TElSecureClient read FElSecureClient write FElSecureClient;
property ElSecureServer:TElSecureServer read FElSecureServer write FElSecureServer;
property CipherSuites:TBits read FCipherSuites write FCipherSuites;
property CipherSuite:Integer read GetCipherSuite;
end;
implementation
var
FAcceptThread:THandle=0;
// on error
procedure TSSLSBB.OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean);
begin
FLastErrorDesc:='';
FLastError:=ErrorCode;
end;
// on send
procedure TSSLSBB.OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt);
var
lResult:Integer;
begin
if FSocket.Socket=INVALID_SOCKET then
Exit;
lResult:=Send(FSocket.Socket,Buffer,Size,0);
if lResult=SOCKET_ERROR then
begin
FLastErrorDesc:='';
FLastError:=WSAGetLastError;
end;
end;
// on receive
procedure TSSLSBB.OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;var Written:LongInt);
begin
if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock);
try
if Length(FRecvBuffers)<=MaxSize then
begin
Written:=Length(FRecvBuffers);
Move(FRecvBuffers[1],Buffer^,Written);
FRecvBuffers:='';
end
else
begin
Written:=MaxSize;
Move(FRecvBuffers[1],Buffer^,Written);
Delete(FRecvBuffers,1,Written);
end;
finally
if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock);
end;
end;
// on data
procedure TSSLSBB.OnData(Sender:TObject;Buffer:Pointer;Size:LongInt);
var
lString:String;
begin
SetLength(lString,Size);
Move(Buffer^,lString[1],Size);
FRecvDecodedBuffers:=FRecvDecodedBuffers+lString;
end;
{ inherited }
constructor TSSLSBB.Create(const Value: TTCPBlockSocket);
var
loop1:Integer;
begin
inherited Create(Value);
FServer:=FALSE;
FElSecureClient:=NIL;
FElSecureServer:=NIL;
FElCertStorage:=NIL;
FElX509Certificate:=NIL;
FElX509CACertificate:=NIL;
SetLength(FRecvBuffer,DEFAULT_RECV_BUFFER);
FRecvBuffers:='';
InitializeCriticalSection(FRecvBuffersLock);
FRecvDecodedBuffers:='';
FCipherSuites:=TBits.Create;
if FCipherSuites<>NIL then
begin
FCipherSuites.Size:=SB_SUITE_LAST+1;
for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do
FCipherSuites[loop1]:=TRUE;
end;
end;
destructor TSSLSBB.Destroy;
begin
Reset;
inherited Destroy;
if FCipherSuites<>NIL then
FreeAndNIL(FCipherSuites);
DeleteCriticalSection(FRecvBuffersLock);
end;
function TSSLSBB.LibVersion: String;
begin
Result:='SecureBlackBox';
end;
function TSSLSBB.LibName: String;
begin
Result:='ssl_sbb';
end;
function FileToString(lFile:String):String;
var
lStream:TMemoryStream;
begin
Result:='';
lStream:=TMemoryStream.Create;
if lStream<>NIL then
begin
lStream.LoadFromFile(lFile);
if lStream.Size>0 then
begin
lStream.Position:=0;
SetLength(Result,lStream.Size);
Move(lStream.Memory^,Result[1],lStream.Size);
end;
lStream.Free;
end;
end;
function TSSLSBB.GetCipherSuite:Integer;
begin
if FServer then
Result:=FElSecureServer.CipherSuite
else
Result:=FElSecureClient.CipherSuite;
end;
procedure TSSLSBB.Reset;
begin
if FElSecureServer<>NIL then
FreeAndNIL(FElSecureServer);
if FElSecureClient<>NIL then
FreeAndNIL(FElSecureClient);
if FElX509Certificate<>NIL then
FreeAndNIL(FElX509Certificate);
if FElX509CACertificate<>NIL then
FreeAndNIL(FElX509CACertificate);
if FElCertStorage<>NIL then
FreeAndNIL(FElCertStorage);
FSSLEnabled:=FALSE;
end;
function TSSLSBB.Prepare(Server:Boolean): Boolean;
var
loop1:Integer;
lStream:TMemoryStream;
lCertificate,lPrivateKey,lCertCA:String;
begin
Result:=FALSE;
FServer:=Server;
// reset, if necessary
Reset;
// init, certificate
if FCertificateFile<>'' then
lCertificate:=FileToString(FCertificateFile)
else
lCertificate:=FCertificate;
if FPrivateKeyFile<>'' then
lPrivateKey:=FileToString(FPrivateKeyFile)
else
lPrivateKey:=FPrivateKey;
if FCertCAFile<>'' then
lCertCA:=FileToString(FCertCAFile)
else
lCertCA:=FCertCA;
if (lCertificate<>'') and (lPrivateKey<>'') then
begin
FElCertStorage:=TElMemoryCertStorage.Create(NIL);
if FElCertStorage<>NIL then
FElCertStorage.Clear;
// apply ca certificate
if lCertCA<>'' then
begin
FElX509CACertificate:=TElX509Certificate.Create(NIL);
if FElX509CACertificate<>NIL then
begin
with FElX509CACertificate do
begin
lStream:=TMemoryStream.Create;
try
WriteStrToStream(lStream,lCertCA);
lStream.Seek(0,soFromBeginning);
LoadFromStream(lStream);
finally
lStream.Free;
end;
end;
if FElCertStorage<>NIL then
FElCertStorage.Add(FElX509CACertificate);
end;
end;
// apply certificate
FElX509Certificate:=TElX509Certificate.Create(NIL);
if FElX509Certificate<>NIL then
begin
with FElX509Certificate do
begin
lStream:=TMemoryStream.Create;
try
WriteStrToStream(lStream,lCertificate);
lStream.Seek(0,soFromBeginning);
LoadFromStream(lStream);
finally
lStream.Free;
end;
lStream:=TMemoryStream.Create;
try
WriteStrToStream(lStream,lPrivateKey);
lStream.Seek(0,soFromBeginning);
LoadKeyFromStream(lStream);
finally
lStream.Free;
end;
if FElCertStorage<>NIL then
FElCertStorage.Add(FElX509Certificate);
end;
end;
end;
// init, as server
if FServer then
begin
FElSecureServer:=TElSecureServer.Create(NIL);
if FElSecureServer<>NIL then
begin
// init, ciphers
for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do
FElSecureServer.CipherSuites[loop1]:=FCipherSuites[loop1];
FElSecureServer.Versions:=[sbSSL2,sbSSL3,sbTLS1];
FElSecureServer.ClientAuthentication:=FALSE;
FElSecureServer.OnError:=OnError;
FElSecureServer.OnSend:=OnSend;
FElSecureServer.OnReceive:=OnReceive;
FElSecureServer.OnData:=OnData;
FElSecureServer.CertStorage:=FElCertStorage;
Result:=TRUE;
end;
end
else
// init, as client
begin
FElSecureClient:=TElSecureClient.Create(NIL);
if FElSecureClient<>NIL then
begin
// init, ciphers
for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do
FElSecureClient.CipherSuites[loop1]:=FCipherSuites[loop1];
FElSecureClient.Versions:=[sbSSL3,sbTLS1];
FElSecureClient.OnError:=OnError;
FElSecureClient.OnSend:=OnSend;
FElSecureClient.OnReceive:=OnReceive;
FElSecureClient.OnData:=OnData;
FElSecureClient.CertStorage:=FElCertStorage;
Result:=TRUE;
end;
end;
end;
function TSSLSBB.Connect:Boolean;
var
lResult:Integer;
begin
Result:=FALSE;
if FSocket.Socket=INVALID_SOCKET then
Exit;
if Prepare(FALSE) then
begin
FElSecureClient.Open;
// reset
FRecvBuffers:='';
FRecvDecodedBuffers:='';
// wait for open or error
while (not FElSecureClient.Active) and
(FLastError=0) do
begin
// data available?
if FRecvBuffers<>'' then
FElSecureClient.DataAvailable
else
begin
// socket recv
lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0);
if lResult=SOCKET_ERROR then
begin
FLastErrorDesc:='';
FLastError:=WSAGetLastError;
end
else
begin
if lResult>0 then
FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult)
else
Break;
end;
end;
end;
if FLastError<>0 then
Exit;
FSSLEnabled:=FElSecureClient.Active;
Result:=FSSLEnabled;
end;
end;
function TSSLSBB.Accept:Boolean;
var
lResult:Integer;
begin
Result:=FALSE;
if FSocket.Socket=INVALID_SOCKET then
Exit;
if Prepare(TRUE) then
begin
FAcceptThread:=GetCurrentThreadId;
FElSecureServer.Open;
// reset
FRecvBuffers:='';
FRecvDecodedBuffers:='';
// wait for open or error
while (not FElSecureServer.Active) and
(FLastError=0) do
begin
// data available?
if FRecvBuffers<>'' then
FElSecureServer.DataAvailable
else
begin
// socket recv
lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0);
if lResult=SOCKET_ERROR then
begin
FLastErrorDesc:='';
FLastError:=WSAGetLastError;
end
else
begin
if lResult>0 then
FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult)
else
Break;
end;
end;
end;
if FLastError<>0 then
Exit;
FSSLEnabled:=FElSecureServer.Active;
Result:=FSSLEnabled;
end;
end;
function TSSLSBB.Shutdown:Boolean;
begin
Result:=BiShutdown;
end;
function TSSLSBB.BiShutdown: boolean;
begin
Reset;
Result:=TRUE;
end;
function TSSLSBB.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
begin
if FServer then
FElSecureServer.SendData(Buffer,Len)
else
FElSecureClient.SendData(Buffer,Len);
Result:=Len;
end;
function TSSLSBB.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
begin
Result:=0;
try
// recv waiting, if necessary
if FRecvDecodedBuffers='' then
WaitingData;
// received
if Length(FRecvDecodedBuffers)FAcceptThread then EnterCriticalSection(FRecvBuffersLock);
try
lRecvBuffers:=FRecvBuffers<>'';
finally
if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock);
end;
if lRecvBuffers then
begin
if FServer then
FElSecureServer.DataAvailable
else
FElSecureClient.DataAvailable;
end
else
begin
// socket recv
lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0);
if lResult=SOCKET_ERROR then
begin
FLastErrorDesc:='';
FLastError:=WSAGetLastError;
end
else
begin
if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock);
try
FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult);
finally
if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock);
end;
// data available?
if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock);
try
lRecvBuffers:=FRecvBuffers<>'';
finally
if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock);
end;
if lRecvBuffers then
begin
if FServer then
FElSecureServer.DataAvailable
else
FElSecureClient.DataAvailable;
end;
end;
end;
// decoded buffers result
Result:=Length(FRecvDecodedBuffers);
end;
function TSSLSBB.GetSSLVersion: string;
begin
Result:='SSLv3 or TLSv1';
end;
function TSSLSBB.GetPeerSubject: string;
begin
Result := '';
// if FServer then
// must return subject of the client certificate
// else
// must return subject of the server certificate
end;
function TSSLSBB.GetPeerName: string;
begin
Result := '';
// if FServer then
// must return commonname of the client certificate
// else
// must return commonname of the server certificate
end;
function TSSLSBB.GetPeerIssuer: string;
begin
Result := '';
// if FServer then
// must return issuer of the client certificate
// else
// must return issuer of the server certificate
end;
function TSSLSBB.GetPeerFingerprint: string;
begin
Result := '';
// if FServer then
// must return a unique hash string of the client certificate
// else
// must return a unique hash string of the server certificate
end;
function TSSLSBB.GetCertInfo: string;
begin
Result := '';
// if FServer then
// must return a text representation of the ASN of the client certificate
// else
// must return a text representation of the ASN of the server certificate
end;
{==============================================================================}
initialization
SSLImplementation := TSSLSBB;
finalization
end.
TransGUI/synapse/source/lib/ssl_openssl_lib.pas 0000644 0000000 0000000 00000222267 11466757142 020667 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 003.006.002 |
|==============================================================================|
| Content: SSL support by OpenSSL |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2002-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{
Special thanks to Gregor Ibic
(Intelicom d.o.o., http://www.intelicom.si)
for good inspiration about begin with SSL programming.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF VER125}
{$DEFINE BCB}
{$ENDIF}
{$IFDEF BCB}
{$ObjExportAll On}
(*$HPPEMIT 'namespace ssl_openssl_lib { using System::Shortint; }' *)
{$ENDIF}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{:@abstract(OpenSSL support)
This unit is Pascal interface to OpenSSL library (used by @link(ssl_openssl) unit).
OpenSSL is loaded dynamicly on-demand. If this library is not found in system,
requested OpenSSL function just return errorcode.
}
unit ssl_openssl_lib;
interface
uses
{$IFDEF CIL}
System.Runtime.InteropServices,
System.Text,
{$ENDIF}
Classes,
synafpc,
{$IFNDEF MSWINDOWS}
{$IFDEF FPC}
BaseUnix, SysUtils;
{$ELSE}
Libc, SysUtils;
{$ENDIF}
{$ELSE}
Windows;
{$ENDIF}
{$IFDEF CIL}
const
{$IFDEF LINUX}
DLLSSLName = 'libssl.so';
DLLUtilName = 'libcrypto.so';
{$ELSE}
DLLSSLName = 'ssleay32.dll';
DLLUtilName = 'libeay32.dll';
{$ENDIF}
{$ELSE}
var
{$IFNDEF MSWINDOWS}
{$IFDEF DARWIN}
DLLSSLName: string = 'libssl.dylib';
DLLUtilName: string = 'libcrypto.dylib';
{$ELSE}
DLLSSLName: string = 'libssl.so';
DLLUtilName: string = 'libcrypto.so';
{$ENDIF}
{$ELSE}
DLLSSLName: string = 'ssleay32.dll';
DLLSSLName2: string = 'libssl32.dll';
DLLUtilName: string = 'libeay32.dll';
{$ENDIF}
{$ENDIF}
type
{$IFDEF CIL}
SslPtr = IntPtr;
{$ELSE}
SslPtr = Pointer;
{$ENDIF}
PSslPtr = ^SslPtr;
PSSL_CTX = SslPtr;
PSSL = SslPtr;
PSSL_METHOD = SslPtr;
PX509 = SslPtr;
PX509_NAME = SslPtr;
PEVP_MD = SslPtr;
PInteger = ^Integer;
PBIO_METHOD = SslPtr;
PBIO = SslPtr;
EVP_PKEY = SslPtr;
PRSA = SslPtr;
PASN1_UTCTIME = SslPtr;
PASN1_INTEGER = SslPtr;
PPasswdCb = SslPtr;
PFunction = procedure;
DES_cblock = array[0..7] of Byte;
PDES_cblock = ^DES_cblock;
des_ks_struct = packed record
ks: DES_cblock;
weak_key: Integer;
end;
des_key_schedule = array[1..16] of des_ks_struct;
const
EVP_MAX_MD_SIZE = 16 + 20;
SSL_ERROR_NONE = 0;
SSL_ERROR_SSL = 1;
SSL_ERROR_WANT_READ = 2;
SSL_ERROR_WANT_WRITE = 3;
SSL_ERROR_WANT_X509_LOOKUP = 4;
SSL_ERROR_SYSCALL = 5; //look at error stack/return value/errno
SSL_ERROR_ZERO_RETURN = 6;
SSL_ERROR_WANT_CONNECT = 7;
SSL_ERROR_WANT_ACCEPT = 8;
SSL_OP_NO_SSLv2 = $01000000;
SSL_OP_NO_SSLv3 = $02000000;
SSL_OP_NO_TLSv1 = $04000000;
SSL_OP_ALL = $000FFFFF;
SSL_VERIFY_NONE = $00;
SSL_VERIFY_PEER = $01;
OPENSSL_DES_DECRYPT = 0;
OPENSSL_DES_ENCRYPT = 1;
X509_V_OK = 0;
X509_V_ILLEGAL = 1;
X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT = 2;
X509_V_ERR_UNABLE_TO_GET_CRL = 3;
X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE = 4;
X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE = 5;
X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY = 6;
X509_V_ERR_CERT_SIGNATURE_FAILURE = 7;
X509_V_ERR_CRL_SIGNATURE_FAILURE = 8;
X509_V_ERR_CERT_NOT_YET_VALID = 9;
X509_V_ERR_CERT_HAS_EXPIRED = 10;
X509_V_ERR_CRL_NOT_YET_VALID = 11;
X509_V_ERR_CRL_HAS_EXPIRED = 12;
X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD = 13;
X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD = 14;
X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD = 15;
X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD = 16;
X509_V_ERR_OUT_OF_MEM = 17;
X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT = 18;
X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN = 19;
X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY = 20;
X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE = 21;
X509_V_ERR_CERT_CHAIN_TOO_LONG = 22;
X509_V_ERR_CERT_REVOKED = 23;
X509_V_ERR_INVALID_CA = 24;
X509_V_ERR_PATH_LENGTH_EXCEEDED = 25;
X509_V_ERR_INVALID_PURPOSE = 26;
X509_V_ERR_CERT_UNTRUSTED = 27;
X509_V_ERR_CERT_REJECTED = 28;
//These are 'informational' when looking for issuer cert
X509_V_ERR_SUBJECT_ISSUER_MISMATCH = 29;
X509_V_ERR_AKID_SKID_MISMATCH = 30;
X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH = 31;
X509_V_ERR_KEYUSAGE_NO_CERTSIGN = 32;
X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER = 33;
X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION = 34;
//The application is not happy
X509_V_ERR_APPLICATION_VERIFICATION = 50;
SSL_FILETYPE_ASN1 = 2;
SSL_FILETYPE_PEM = 1;
EVP_PKEY_RSA = 6;
var
SSLLibHandle: TLibHandle = 0;
SSLUtilHandle: TLibHandle = 0;
SSLLibFile: string = '';
SSLUtilFile: string = '';
{$IFDEF CIL}
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_get_error')]
function SslGetError(s: PSSL; ret_code: Integer): Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_library_init')]
function SslLibraryInit: Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_load_error_strings')]
procedure SslLoadErrorStrings; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_set_cipher_list')]
function SslCtxSetCipherList(arg0: PSSL_CTX; var str: String): Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_new')]
function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_free')]
procedure SslCtxFree (arg0: PSSL_CTX); external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_set_fd')]
function SslSetFd(s: PSSL; fd: Integer):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSLv2_method')]
function SslMethodV2 : PSSL_METHOD; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSLv3_method')]
function SslMethodV3 : PSSL_METHOD; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'TLSv1_method')]
function SslMethodTLSV1:PSSL_METHOD; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSLv23_method')]
function SslMethodV23 : PSSL_METHOD; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_use_PrivateKey')]
function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_use_PrivateKey_ASN1')]
function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: String; len: integer):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_use_RSAPrivateKey_file')]
function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_use_certificate')]
function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_use_certificate_ASN1')]
function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: String):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_use_certificate_file')]
function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer;external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_use_certificate_chain_file')]
function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: String):Integer;external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_check_private_key')]
function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_set_default_passwd_cb')]
procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_set_default_passwd_cb_userdata')]
procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: IntPtr); external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_load_verify_locations')]
function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; CAfile: string; CApath: String):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_ctrl')]
function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: IntPtr): integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_new')]
function SslNew(ctx: PSSL_CTX):PSSL; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_free')]
procedure SslFree(ssl: PSSL); external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_accept')]
function SslAccept(ssl: PSSL):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_connect')]
function SslConnect(ssl: PSSL):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_shutdown')]
function SslShutdown(s: PSSL):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_read')]
function SslRead(ssl: PSSL; buf: StringBuilder; num: Integer):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_peek')]
function SslPeek(ssl: PSSL; buf: StringBuilder; num: Integer):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_write')]
function SslWrite(ssl: PSSL; buf: String; num: Integer):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_pending')]
function SslPending(ssl: PSSL):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_get_version')]
function SslGetVersion(ssl: PSSL):String; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_get_peer_certificate')]
function SslGetPeerCertificate(s: PSSL):PX509; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_set_verify')]
procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_get_current_cipher')]
function SSLGetCurrentCipher(s: PSSL): SslPtr; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CIPHER_get_name')]
function SSLCipherGetName(c: SslPtr):String; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CIPHER_get_bits')]
function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_get_verify_result')]
function SSLGetVerifyResult(ssl: PSSL):Integer;external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_new')]
function X509New: PX509; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_free')]
procedure X509Free(x: PX509); external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_NAME_oneline')]
function X509NameOneline(a: PX509_NAME; buf: StringBuilder; size: Integer): String; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_get_subject_name')]
function X509GetSubjectName(a: PX509):PX509_NAME; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_get_issuer_name')]
function X509GetIssuerName(a: PX509):PX509_NAME; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_NAME_hash')]
function X509NameHash(x: PX509_NAME):Cardinal; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_digest')]
function X509Digest (data: PX509; _type: PEVP_MD; md: StringBuilder; var len: Integer):Integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_set_version')]
function X509SetVersion(x: PX509; version: integer): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_set_pubkey')]
function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_set_issuer_name')]
function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_NAME_add_entry_by_txt')]
function X509NameAddEntryByTxt(name: PX509_NAME; field: string; _type: integer;
bytes: string; len, loc, _set: integer): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_sign')]
function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_print')]
function X509print(b: PBIO; a: PX509): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_gmtime_adj')]
function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_set_notBefore')]
function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_set_notAfter')]
function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'X509_get_serialNumber')]
function X509GetSerialNumber(x: PX509): PASN1_INTEGER; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'EVP_PKEY_new')]
function EvpPkeyNew: EVP_PKEY; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'EVP_PKEY_free')]
procedure EvpPkeyFree(pk: EVP_PKEY); external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'EVP_PKEY_assign')]
function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'EVP_get_digestbyname')]
function EvpGetDigestByName(Name: String): PEVP_MD; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'EVP_cleanup')]
procedure EVPcleanup; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSLeay_version')]
function SSLeayversion(t: integer): String; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'ERR_error_string_n')]
procedure ErrErrorString(e: integer; buf: StringBuilder; len: integer); external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'ERR_get_error')]
function ErrGetError: integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'ERR_clear_error')]
procedure ErrClearError; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'ERR_free_strings')]
procedure ErrFreeStrings; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'ERR_remove_state')]
procedure ErrRemoveState(pid: integer); external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'OPENSSL_add_all_algorithms_noconf')]
procedure OPENSSLaddallalgorithms; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'CRYPTO_cleanup_all_ex_data')]
procedure CRYPTOcleanupAllExData; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'RAND_screen')]
procedure RandScreen; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'BIO_new')]
function BioNew(b: PBIO_METHOD): PBIO; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'BIO_free_all')]
procedure BioFreeAll(b: PBIO); external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'BIO_s_mem')]
function BioSMem: PBIO_METHOD; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'BIO_ctrl_pending')]
function BioCtrlPending(b: PBIO): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'BIO_read')]
function BioRead(b: PBIO; Buf: StringBuilder; Len: integer): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'BIO_write')]
function BioWrite(b: PBIO; var Buf: String; Len: integer): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'd2i_PKCS12_bio')]
function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'PKCS12_parse')]
function PKCS12parse(p12: SslPtr; pass: string; var pkey, cert, ca: SslPtr): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'PKCS12_free')]
procedure PKCS12free(p12: SslPtr); external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'RSA_generate_key')]
function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'ASN1_UTCTIME_new')]
function Asn1UtctimeNew: PASN1_UTCTIME; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'ASN1_UTCTIME_free')]
procedure Asn1UtctimeFree(a: PASN1_UTCTIME); external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'ASN1_INTEGER_set')]
function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'i2d_X509_bio')]
function i2dX509bio(b: PBIO; x: PX509): integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'i2d_PrivateKey_bio')]
function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; external;
// 3DES functions
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'DES_set_odd_parity')]
procedure DESsetoddparity(Key: des_cblock); external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'DES_set_key_checked')]
function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; external;
[DllImport(DLLUtilName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'DES_ecb_encrypt')]
procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); external;
{$ELSE}
// libssl.dll
function SslGetError(s: PSSL; ret_code: Integer):Integer;
function SslLibraryInit:Integer;
procedure SslLoadErrorStrings;
// function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer;
function SslCtxSetCipherList(arg0: PSSL_CTX; var str: AnsiString):Integer;
function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX;
procedure SslCtxFree(arg0: PSSL_CTX);
function SslSetFd(s: PSSL; fd: Integer):Integer;
function SslMethodV2:PSSL_METHOD;
function SslMethodV3:PSSL_METHOD;
function SslMethodTLSV1:PSSL_METHOD;
function SslMethodV23:PSSL_METHOD;
function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer;
function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: AnsiString; len: integer):Integer;
// function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer;
function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer;
function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer;
function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: AnsiString):Integer;
function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer;
// function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer;
function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: AnsiString):Integer;
function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer;
procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb);
procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr);
// function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer;
function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: AnsiString; const CApath: AnsiString):Integer;
function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer;
function SslNew(ctx: PSSL_CTX):PSSL;
procedure SslFree(ssl: PSSL);
function SslAccept(ssl: PSSL):Integer;
function SslConnect(ssl: PSSL):Integer;
function SslShutdown(ssl: PSSL):Integer;
function SslRead(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
function SslPeek(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
function SslWrite(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
function SslPending(ssl: PSSL):Integer;
function SslGetVersion(ssl: PSSL):AnsiString;
function SslGetPeerCertificate(ssl: PSSL):PX509;
procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction);
function SSLGetCurrentCipher(s: PSSL):SslPtr;
function SSLCipherGetName(c: SslPtr): AnsiString;
function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer;
function SSLGetVerifyResult(ssl: PSSL):Integer;
// libeay.dll
function X509New: PX509;
procedure X509Free(x: PX509);
function X509NameOneline(a: PX509_NAME; var buf: AnsiString; size: Integer):AnsiString;
function X509GetSubjectName(a: PX509):PX509_NAME;
function X509GetIssuerName(a: PX509):PX509_NAME;
function X509NameHash(x: PX509_NAME):Cardinal;
// function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer;
function X509Digest(data: PX509; _type: PEVP_MD; md: AnsiString; var len: Integer):Integer;
function X509print(b: PBIO; a: PX509): integer;
function X509SetVersion(x: PX509; version: integer): integer;
function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer;
function X509SetIssuerName(x: PX509; name: PX509_NAME): integer;
function X509NameAddEntryByTxt(name: PX509_NAME; field: Ansistring; _type: integer;
bytes: Ansistring; len, loc, _set: integer): integer;
function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer;
function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME;
function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer;
function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer;
function X509GetSerialNumber(x: PX509): PASN1_INTEGER;
function EvpPkeyNew: EVP_PKEY;
procedure EvpPkeyFree(pk: EVP_PKEY);
function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer;
function EvpGetDigestByName(Name: AnsiString): PEVP_MD;
procedure EVPcleanup;
// function ErrErrorString(e: integer; buf: PChar): PChar;
function SSLeayversion(t: integer): Ansistring;
procedure ErrErrorString(e: integer; var buf: Ansistring; len: integer);
function ErrGetError: integer;
procedure ErrClearError;
procedure ErrFreeStrings;
procedure ErrRemoveState(pid: integer);
procedure OPENSSLaddallalgorithms;
procedure CRYPTOcleanupAllExData;
procedure RandScreen;
function BioNew(b: PBIO_METHOD): PBIO;
procedure BioFreeAll(b: PBIO);
function BioSMem: PBIO_METHOD;
function BioCtrlPending(b: PBIO): integer;
function BioRead(b: PBIO; var Buf: AnsiString; Len: integer): integer;
function BioWrite(b: PBIO; Buf: AnsiString; Len: integer): integer;
function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr;
function PKCS12parse(p12: SslPtr; pass: Ansistring; var pkey, cert, ca: SslPtr): integer;
procedure PKCS12free(p12: SslPtr);
function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA;
function Asn1UtctimeNew: PASN1_UTCTIME;
procedure Asn1UtctimeFree(a: PASN1_UTCTIME);
function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer;
function i2dX509bio(b: PBIO; x: PX509): integer;
function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer;
// 3DES functions
procedure DESsetoddparity(Key: des_cblock);
function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer;
procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer);
{$ENDIF}
function IsSSLloaded: Boolean;
function InitSSLInterface: Boolean;
function DestroySSLInterface: Boolean;
implementation
uses SyncObjs;
{$IFNDEF CIL}
type
// libssl.dll
TSslGetError = function(s: PSSL; ret_code: Integer):Integer; cdecl;
TSslLibraryInit = function:Integer; cdecl;
TSslLoadErrorStrings = procedure; cdecl;
TSslCtxSetCipherList = function(arg0: PSSL_CTX; str: PAnsiChar):Integer; cdecl;
TSslCtxNew = function(meth: PSSL_METHOD):PSSL_CTX; cdecl;
TSslCtxFree = procedure(arg0: PSSL_CTX); cdecl;
TSslSetFd = function(s: PSSL; fd: Integer):Integer; cdecl;
TSslMethodV2 = function:PSSL_METHOD; cdecl;
TSslMethodV3 = function:PSSL_METHOD; cdecl;
TSslMethodTLSV1 = function:PSSL_METHOD; cdecl;
TSslMethodV23 = function:PSSL_METHOD; cdecl;
TSslCtxUsePrivateKey = function(ctx: PSSL_CTX; pkey: sslptr):Integer; cdecl;
TSslCtxUsePrivateKeyASN1 = function(pk: integer; ctx: PSSL_CTX; d: sslptr; len: integer):Integer; cdecl;
TSslCtxUsePrivateKeyFile = function(ctx: PSSL_CTX; const _file: PAnsiChar; _type: Integer):Integer; cdecl;
TSslCtxUseCertificate = function(ctx: PSSL_CTX; x: SslPtr):Integer; cdecl;
TSslCtxUseCertificateASN1 = function(ctx: PSSL_CTX; len: Integer; d: SslPtr):Integer; cdecl;
TSslCtxUseCertificateFile = function(ctx: PSSL_CTX; const _file: PAnsiChar; _type: Integer):Integer; cdecl;
TSslCtxUseCertificateChainFile = function(ctx: PSSL_CTX; const _file: PAnsiChar):Integer; cdecl;
TSslCtxCheckPrivateKeyFile = function(ctx: PSSL_CTX):Integer; cdecl;
TSslCtxSetDefaultPasswdCb = procedure(ctx: PSSL_CTX; cb: SslPtr); cdecl;
TSslCtxSetDefaultPasswdCbUserdata = procedure(ctx: PSSL_CTX; u: SslPtr); cdecl;
TSslCtxLoadVerifyLocations = function(ctx: PSSL_CTX; const CAfile: PAnsiChar; const CApath: PAnsiChar):Integer; cdecl;
TSslCtxCtrl = function(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; cdecl;
TSslNew = function(ctx: PSSL_CTX):PSSL; cdecl;
TSslFree = procedure(ssl: PSSL); cdecl;
TSslAccept = function(ssl: PSSL):Integer; cdecl;
TSslConnect = function(ssl: PSSL):Integer; cdecl;
TSslShutdown = function(ssl: PSSL):Integer; cdecl;
TSslRead = function(ssl: PSSL; buf: PAnsiChar; num: Integer):Integer; cdecl;
TSslPeek = function(ssl: PSSL; buf: PAnsiChar; num: Integer):Integer; cdecl;
TSslWrite = function(ssl: PSSL; const buf: PAnsiChar; num: Integer):Integer; cdecl;
TSslPending = function(ssl: PSSL):Integer; cdecl;
TSslGetVersion = function(ssl: PSSL):PAnsiChar; cdecl;
TSslGetPeerCertificate = function(ssl: PSSL):PX509; cdecl;
TSslCtxSetVerify = procedure(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); cdecl;
TSSLGetCurrentCipher = function(s: PSSL):SslPtr; cdecl;
TSSLCipherGetName = function(c: Sslptr):PAnsiChar; cdecl;
TSSLCipherGetBits = function(c: SslPtr; alg_bits: PInteger):Integer; cdecl;
TSSLGetVerifyResult = function(ssl: PSSL):Integer; cdecl;
// libeay.dll
TX509New = function: PX509; cdecl;
TX509Free = procedure(x: PX509); cdecl;
TX509NameOneline = function(a: PX509_NAME; buf: PAnsiChar; size: Integer):PAnsiChar; cdecl;
TX509GetSubjectName = function(a: PX509):PX509_NAME; cdecl;
TX509GetIssuerName = function(a: PX509):PX509_NAME; cdecl;
TX509NameHash = function(x: PX509_NAME):Cardinal; cdecl;
TX509Digest = function(data: PX509; _type: PEVP_MD; md: PAnsiChar; len: PInteger):Integer; cdecl;
TX509print = function(b: PBIO; a: PX509): integer; cdecl;
TX509SetVersion = function(x: PX509; version: integer): integer; cdecl;
TX509SetPubkey = function(x: PX509; pkey: EVP_PKEY): integer; cdecl;
TX509SetIssuerName = function(x: PX509; name: PX509_NAME): integer; cdecl;
TX509NameAddEntryByTxt = function(name: PX509_NAME; field: PAnsiChar; _type: integer;
bytes: PAnsiChar; len, loc, _set: integer): integer; cdecl;
TX509Sign = function(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; cdecl;
TX509GmtimeAdj = function(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; cdecl;
TX509SetNotBefore = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl;
TX509SetNotAfter = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl;
TX509GetSerialNumber = function(x: PX509): PASN1_INTEGER; cdecl;
TEvpPkeyNew = function: EVP_PKEY; cdecl;
TEvpPkeyFree = procedure(pk: EVP_PKEY); cdecl;
TEvpPkeyAssign = function(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; cdecl;
TEvpGetDigestByName = function(Name: PAnsiChar): PEVP_MD; cdecl;
TEVPcleanup = procedure; cdecl;
TSSLeayversion = function(t: integer): PAnsiChar; cdecl;
TErrErrorString = procedure(e: integer; buf: PAnsiChar; len: integer); cdecl;
TErrGetError = function: integer; cdecl;
TErrClearError = procedure; cdecl;
TErrFreeStrings = procedure; cdecl;
TErrRemoveState = procedure(pid: integer); cdecl;
TOPENSSLaddallalgorithms = procedure; cdecl;
TCRYPTOcleanupAllExData = procedure; cdecl;
TRandScreen = procedure; cdecl;
TBioNew = function(b: PBIO_METHOD): PBIO; cdecl;
TBioFreeAll = procedure(b: PBIO); cdecl;
TBioSMem = function: PBIO_METHOD; cdecl;
TBioCtrlPending = function(b: PBIO): integer; cdecl;
TBioRead = function(b: PBIO; Buf: PAnsiChar; Len: integer): integer; cdecl;
TBioWrite = function(b: PBIO; Buf: PAnsiChar; Len: integer): integer; cdecl;
Td2iPKCS12bio = function(b:PBIO; Pkcs12: SslPtr): SslPtr; cdecl;
TPKCS12parse = function(p12: SslPtr; pass: PAnsiChar; var pkey, cert, ca: SslPtr): integer; cdecl;
TPKCS12free = procedure(p12: SslPtr); cdecl;
TRsaGenerateKey = function(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; cdecl;
TAsn1UtctimeNew = function: PASN1_UTCTIME; cdecl;
TAsn1UtctimeFree = procedure(a: PASN1_UTCTIME); cdecl;
TAsn1IntegerSet = function(a: PASN1_INTEGER; v: integer): integer; cdecl;
Ti2dX509bio = function(b: PBIO; x: PX509): integer; cdecl;
Ti2dPrivateKeyBio= function(b: PBIO; pkey: EVP_PKEY): integer; cdecl;
// 3DES functions
TDESsetoddparity = procedure(Key: des_cblock); cdecl;
TDESsetkeychecked = function(key: des_cblock; schedule: des_key_schedule): Integer; cdecl;
TDESecbencrypt = procedure(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); cdecl;
//thread lock functions
TCRYPTOnumlocks = function: integer; cdecl;
TCRYPTOSetLockingCallback = procedure(cb: Sslptr); cdecl;
var
// libssl.dll
_SslGetError: TSslGetError = nil;
_SslLibraryInit: TSslLibraryInit = nil;
_SslLoadErrorStrings: TSslLoadErrorStrings = nil;
_SslCtxSetCipherList: TSslCtxSetCipherList = nil;
_SslCtxNew: TSslCtxNew = nil;
_SslCtxFree: TSslCtxFree = nil;
_SslSetFd: TSslSetFd = nil;
_SslMethodV2: TSslMethodV2 = nil;
_SslMethodV3: TSslMethodV3 = nil;
_SslMethodTLSV1: TSslMethodTLSV1 = nil;
_SslMethodV23: TSslMethodV23 = nil;
_SslCtxUsePrivateKey: TSslCtxUsePrivateKey = nil;
_SslCtxUsePrivateKeyASN1: TSslCtxUsePrivateKeyASN1 = nil;
_SslCtxUsePrivateKeyFile: TSslCtxUsePrivateKeyFile = nil;
_SslCtxUseCertificate: TSslCtxUseCertificate = nil;
_SslCtxUseCertificateASN1: TSslCtxUseCertificateASN1 = nil;
_SslCtxUseCertificateFile: TSslCtxUseCertificateFile = nil;
_SslCtxUseCertificateChainFile: TSslCtxUseCertificateChainFile = nil;
_SslCtxCheckPrivateKeyFile: TSslCtxCheckPrivateKeyFile = nil;
_SslCtxSetDefaultPasswdCb: TSslCtxSetDefaultPasswdCb = nil;
_SslCtxSetDefaultPasswdCbUserdata: TSslCtxSetDefaultPasswdCbUserdata = nil;
_SslCtxLoadVerifyLocations: TSslCtxLoadVerifyLocations = nil;
_SslCtxCtrl: TSslCtxCtrl = nil;
_SslNew: TSslNew = nil;
_SslFree: TSslFree = nil;
_SslAccept: TSslAccept = nil;
_SslConnect: TSslConnect = nil;
_SslShutdown: TSslShutdown = nil;
_SslRead: TSslRead = nil;
_SslPeek: TSslPeek = nil;
_SslWrite: TSslWrite = nil;
_SslPending: TSslPending = nil;
_SslGetVersion: TSslGetVersion = nil;
_SslGetPeerCertificate: TSslGetPeerCertificate = nil;
_SslCtxSetVerify: TSslCtxSetVerify = nil;
_SSLGetCurrentCipher: TSSLGetCurrentCipher = nil;
_SSLCipherGetName: TSSLCipherGetName = nil;
_SSLCipherGetBits: TSSLCipherGetBits = nil;
_SSLGetVerifyResult: TSSLGetVerifyResult = nil;
// libeay.dll
_X509New: TX509New = nil;
_X509Free: TX509Free = nil;
_X509NameOneline: TX509NameOneline = nil;
_X509GetSubjectName: TX509GetSubjectName = nil;
_X509GetIssuerName: TX509GetIssuerName = nil;
_X509NameHash: TX509NameHash = nil;
_X509Digest: TX509Digest = nil;
_X509print: TX509print = nil;
_X509SetVersion: TX509SetVersion = nil;
_X509SetPubkey: TX509SetPubkey = nil;
_X509SetIssuerName: TX509SetIssuerName = nil;
_X509NameAddEntryByTxt: TX509NameAddEntryByTxt = nil;
_X509Sign: TX509Sign = nil;
_X509GmtimeAdj: TX509GmtimeAdj = nil;
_X509SetNotBefore: TX509SetNotBefore = nil;
_X509SetNotAfter: TX509SetNotAfter = nil;
_X509GetSerialNumber: TX509GetSerialNumber = nil;
_EvpPkeyNew: TEvpPkeyNew = nil;
_EvpPkeyFree: TEvpPkeyFree = nil;
_EvpPkeyAssign: TEvpPkeyAssign = nil;
_EvpGetDigestByName: TEvpGetDigestByName = nil;
_EVPcleanup: TEVPcleanup = nil;
_SSLeayversion: TSSLeayversion = nil;
_ErrErrorString: TErrErrorString = nil;
_ErrGetError: TErrGetError = nil;
_ErrClearError: TErrClearError = nil;
_ErrFreeStrings: TErrFreeStrings = nil;
_ErrRemoveState: TErrRemoveState = nil;
_OPENSSLaddallalgorithms: TOPENSSLaddallalgorithms = nil;
_CRYPTOcleanupAllExData: TCRYPTOcleanupAllExData = nil;
_RandScreen: TRandScreen = nil;
_BioNew: TBioNew = nil;
_BioFreeAll: TBioFreeAll = nil;
_BioSMem: TBioSMem = nil;
_BioCtrlPending: TBioCtrlPending = nil;
_BioRead: TBioRead = nil;
_BioWrite: TBioWrite = nil;
_d2iPKCS12bio: Td2iPKCS12bio = nil;
_PKCS12parse: TPKCS12parse = nil;
_PKCS12free: TPKCS12free = nil;
_RsaGenerateKey: TRsaGenerateKey = nil;
_Asn1UtctimeNew: TAsn1UtctimeNew = nil;
_Asn1UtctimeFree: TAsn1UtctimeFree = nil;
_Asn1IntegerSet: TAsn1IntegerSet = nil;
_i2dX509bio: Ti2dX509bio = nil;
_i2dPrivateKeyBio: Ti2dPrivateKeyBio = nil;
// 3DES functions
_DESsetoddparity: TDESsetoddparity = nil;
_DESsetkeychecked: TDESsetkeychecked = nil;
_DESecbencrypt: TDESecbencrypt = nil;
//thread lock functions
_CRYPTOnumlocks: TCRYPTOnumlocks = nil;
_CRYPTOSetLockingCallback: TCRYPTOSetLockingCallback = nil;
{$ENDIF}
var
SSLCS: TCriticalSection;
SSLloaded: boolean = false;
{$IFNDEF CIL}
Locks: TList;
{$ENDIF}
{$IFNDEF CIL}
// libssl.dll
function SslGetError(s: PSSL; ret_code: Integer):Integer;
begin
if InitSSLInterface and Assigned(_SslGetError) then
Result := _SslGetError(s, ret_code)
else
Result := SSL_ERROR_SSL;
end;
function SslLibraryInit:Integer;
begin
if InitSSLInterface and Assigned(_SslLibraryInit) then
Result := _SslLibraryInit
else
Result := 1;
end;
procedure SslLoadErrorStrings;
begin
if InitSSLInterface and Assigned(_SslLoadErrorStrings) then
_SslLoadErrorStrings;
end;
//function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer;
function SslCtxSetCipherList(arg0: PSSL_CTX; var str: AnsiString):Integer;
begin
if InitSSLInterface and Assigned(_SslCtxSetCipherList) then
Result := _SslCtxSetCipherList(arg0, PAnsiChar(str))
else
Result := 0;
end;
function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX;
begin
if InitSSLInterface and Assigned(_SslCtxNew) then
Result := _SslCtxNew(meth)
else
Result := nil;
end;
procedure SslCtxFree(arg0: PSSL_CTX);
begin
if InitSSLInterface and Assigned(_SslCtxFree) then
_SslCtxFree(arg0);
end;
function SslSetFd(s: PSSL; fd: Integer):Integer;
begin
if InitSSLInterface and Assigned(_SslSetFd) then
Result := _SslSetFd(s, fd)
else
Result := 0;
end;
function SslMethodV2:PSSL_METHOD;
begin
if InitSSLInterface and Assigned(_SslMethodV2) then
Result := _SslMethodV2
else
Result := nil;
end;
function SslMethodV3:PSSL_METHOD;
begin
if InitSSLInterface and Assigned(_SslMethodV3) then
Result := _SslMethodV3
else
Result := nil;
end;
function SslMethodTLSV1:PSSL_METHOD;
begin
if InitSSLInterface and Assigned(_SslMethodTLSV1) then
Result := _SslMethodTLSV1
else
Result := nil;
end;
function SslMethodV23:PSSL_METHOD;
begin
if InitSSLInterface and Assigned(_SslMethodV23) then
Result := _SslMethodV23
else
Result := nil;
end;
function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer;
begin
if InitSSLInterface and Assigned(_SslCtxUsePrivateKey) then
Result := _SslCtxUsePrivateKey(ctx, pkey)
else
Result := 0;
end;
function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: AnsiString; len: integer):Integer;
begin
if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyASN1) then
Result := _SslCtxUsePrivateKeyASN1(pk, ctx, Sslptr(d), len)
else
Result := 0;
end;
//function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer;
function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer;
begin
if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyFile) then
Result := _SslCtxUsePrivateKeyFile(ctx, PAnsiChar(_file), _type)
else
Result := 0;
end;
function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer;
begin
if InitSSLInterface and Assigned(_SslCtxUseCertificate) then
Result := _SslCtxUseCertificate(ctx, x)
else
Result := 0;
end;
function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: AnsiString):Integer;
begin
if InitSSLInterface and Assigned(_SslCtxUseCertificateASN1) then
Result := _SslCtxUseCertificateASN1(ctx, len, SslPtr(d))
else
Result := 0;
end;
function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer;
begin
if InitSSLInterface and Assigned(_SslCtxUseCertificateFile) then
Result := _SslCtxUseCertificateFile(ctx, PAnsiChar(_file), _type)
else
Result := 0;
end;
//function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer;
function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: AnsiString):Integer;
begin
if InitSSLInterface and Assigned(_SslCtxUseCertificateChainFile) then
Result := _SslCtxUseCertificateChainFile(ctx, PAnsiChar(_file))
else
Result := 0;
end;
function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer;
begin
if InitSSLInterface and Assigned(_SslCtxCheckPrivateKeyFile) then
Result := _SslCtxCheckPrivateKeyFile(ctx)
else
Result := 0;
end;
procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb);
begin
if InitSSLInterface and Assigned(_SslCtxSetDefaultPasswdCb) then
_SslCtxSetDefaultPasswdCb(ctx, cb);
end;
procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr);
begin
if InitSSLInterface and Assigned(_SslCtxSetDefaultPasswdCbUserdata) then
_SslCtxSetDefaultPasswdCbUserdata(ctx, u);
end;
//function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer;
function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: AnsiString; const CApath: AnsiString):Integer;
begin
if InitSSLInterface and Assigned(_SslCtxLoadVerifyLocations) then
Result := _SslCtxLoadVerifyLocations(ctx, SslPtr(CAfile), SslPtr(CApath))
else
Result := 0;
end;
function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer;
begin
if InitSSLInterface and Assigned(_SslCtxCtrl) then
Result := _SslCtxCtrl(ctx, cmd, larg, parg)
else
Result := 0;
end;
function SslNew(ctx: PSSL_CTX):PSSL;
begin
if InitSSLInterface and Assigned(_SslNew) then
Result := _SslNew(ctx)
else
Result := nil;
end;
procedure SslFree(ssl: PSSL);
begin
if InitSSLInterface and Assigned(_SslFree) then
_SslFree(ssl);
end;
function SslAccept(ssl: PSSL):Integer;
begin
if InitSSLInterface and Assigned(_SslAccept) then
Result := _SslAccept(ssl)
else
Result := -1;
end;
function SslConnect(ssl: PSSL):Integer;
begin
if InitSSLInterface and Assigned(_SslConnect) then
Result := _SslConnect(ssl)
else
Result := -1;
end;
function SslShutdown(ssl: PSSL):Integer;
begin
if InitSSLInterface and Assigned(_SslShutdown) then
Result := _SslShutdown(ssl)
else
Result := -1;
end;
//function SslRead(ssl: PSSL; buf: PChar; num: Integer):Integer;
function SslRead(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
begin
if InitSSLInterface and Assigned(_SslRead) then
Result := _SslRead(ssl, PAnsiChar(buf), num)
else
Result := -1;
end;
//function SslPeek(ssl: PSSL; buf: PChar; num: Integer):Integer;
function SslPeek(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
begin
if InitSSLInterface and Assigned(_SslPeek) then
Result := _SslPeek(ssl, PAnsiChar(buf), num)
else
Result := -1;
end;
//function SslWrite(ssl: PSSL; const buf: PChar; num: Integer):Integer;
function SslWrite(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
begin
if InitSSLInterface and Assigned(_SslWrite) then
Result := _SslWrite(ssl, PAnsiChar(buf), num)
else
Result := -1;
end;
function SslPending(ssl: PSSL):Integer;
begin
if InitSSLInterface and Assigned(_SslPending) then
Result := _SslPending(ssl)
else
Result := 0;
end;
//function SslGetVersion(ssl: PSSL):PChar;
function SslGetVersion(ssl: PSSL):AnsiString;
begin
if InitSSLInterface and Assigned(_SslGetVersion) then
Result := _SslGetVersion(ssl)
else
Result := '';
end;
function SslGetPeerCertificate(ssl: PSSL):PX509;
begin
if InitSSLInterface and Assigned(_SslGetPeerCertificate) then
Result := _SslGetPeerCertificate(ssl)
else
Result := nil;
end;
//procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr);
procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction);
begin
if InitSSLInterface and Assigned(_SslCtxSetVerify) then
_SslCtxSetVerify(ctx, mode, @arg2);
end;
function SSLGetCurrentCipher(s: PSSL):SslPtr;
begin
if InitSSLInterface and Assigned(_SSLGetCurrentCipher) then
{$IFDEF CIL}
{$ELSE}
Result := _SSLGetCurrentCipher(s)
{$ENDIF}
else
Result := nil;
end;
//function SSLCipherGetName(c: SslPtr):PChar;
function SSLCipherGetName(c: SslPtr):AnsiString;
begin
if InitSSLInterface and Assigned(_SSLCipherGetName) then
Result := _SSLCipherGetName(c)
else
Result := '';
end;
//function SSLCipherGetBits(c: SslPtr; alg_bits: PInteger):Integer;
function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer;
begin
if InitSSLInterface and Assigned(_SSLCipherGetBits) then
Result := _SSLCipherGetBits(c, @alg_bits)
else
Result := 0;
end;
function SSLGetVerifyResult(ssl: PSSL):Integer;
begin
if InitSSLInterface and Assigned(_SSLGetVerifyResult) then
Result := _SSLGetVerifyResult(ssl)
else
Result := X509_V_ERR_APPLICATION_VERIFICATION;
end;
// libeay.dll
function X509New: PX509;
begin
if InitSSLInterface and Assigned(_X509New) then
Result := _X509New
else
Result := nil;
end;
procedure X509Free(x: PX509);
begin
if InitSSLInterface and Assigned(_X509Free) then
_X509Free(x);
end;
//function SslX509NameOneline(a: PX509_NAME; buf: PChar; size: Integer):PChar;
function X509NameOneline(a: PX509_NAME; var buf: AnsiString; size: Integer):AnsiString;
begin
if InitSSLInterface and Assigned(_X509NameOneline) then
Result := _X509NameOneline(a, PAnsiChar(buf),size)
else
Result := '';
end;
function X509GetSubjectName(a: PX509):PX509_NAME;
begin
if InitSSLInterface and Assigned(_X509GetSubjectName) then
Result := _X509GetSubjectName(a)
else
Result := nil;
end;
function X509GetIssuerName(a: PX509):PX509_NAME;
begin
if InitSSLInterface and Assigned(_X509GetIssuerName) then
Result := _X509GetIssuerName(a)
else
Result := nil;
end;
function X509NameHash(x: PX509_NAME):Cardinal;
begin
if InitSSLInterface and Assigned(_X509NameHash) then
Result := _X509NameHash(x)
else
Result := 0;
end;
//function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer;
function X509Digest(data: PX509; _type: PEVP_MD; md: AnsiString; var len: Integer):Integer;
begin
if InitSSLInterface and Assigned(_X509Digest) then
Result := _X509Digest(data, _type, PAnsiChar(md), @len)
else
Result := 0;
end;
function EvpPkeyNew: EVP_PKEY;
begin
if InitSSLInterface and Assigned(_EvpPkeyNew) then
Result := _EvpPkeyNew
else
Result := nil;
end;
procedure EvpPkeyFree(pk: EVP_PKEY);
begin
if InitSSLInterface and Assigned(_EvpPkeyFree) then
_EvpPkeyFree(pk);
end;
function SSLeayversion(t: integer): Ansistring;
begin
if InitSSLInterface and Assigned(_SSLeayversion) then
Result := PAnsiChar(_SSLeayversion(t))
else
Result := '';
end;
procedure ErrErrorString(e: integer; var buf: Ansistring; len: integer);
begin
if InitSSLInterface and Assigned(_ErrErrorString) then
_ErrErrorString(e, Pointer(buf), len);
buf := PAnsiChar(Buf);
end;
function ErrGetError: integer;
begin
if InitSSLInterface and Assigned(_ErrGetError) then
Result := _ErrGetError
else
Result := SSL_ERROR_SSL;
end;
procedure ErrClearError;
begin
if InitSSLInterface and Assigned(_ErrClearError) then
_ErrClearError;
end;
procedure ErrFreeStrings;
begin
if InitSSLInterface and Assigned(_ErrFreeStrings) then
_ErrFreeStrings;
end;
procedure ErrRemoveState(pid: integer);
begin
if InitSSLInterface and Assigned(_ErrRemoveState) then
_ErrRemoveState(pid);
end;
procedure OPENSSLaddallalgorithms;
begin
if InitSSLInterface and Assigned(_OPENSSLaddallalgorithms) then
_OPENSSLaddallalgorithms;
end;
procedure EVPcleanup;
begin
if InitSSLInterface and Assigned(_EVPcleanup) then
_EVPcleanup;
end;
procedure CRYPTOcleanupAllExData;
begin
if InitSSLInterface and Assigned(_CRYPTOcleanupAllExData) then
_CRYPTOcleanupAllExData;
end;
procedure RandScreen;
begin
if InitSSLInterface and Assigned(_RandScreen) then
_RandScreen;
end;
function BioNew(b: PBIO_METHOD): PBIO;
begin
if InitSSLInterface and Assigned(_BioNew) then
Result := _BioNew(b)
else
Result := nil;
end;
procedure BioFreeAll(b: PBIO);
begin
if InitSSLInterface and Assigned(_BioFreeAll) then
_BioFreeAll(b);
end;
function BioSMem: PBIO_METHOD;
begin
if InitSSLInterface and Assigned(_BioSMem) then
Result := _BioSMem
else
Result := nil;
end;
function BioCtrlPending(b: PBIO): integer;
begin
if InitSSLInterface and Assigned(_BioCtrlPending) then
Result := _BioCtrlPending(b)
else
Result := 0;
end;
//function BioRead(b: PBIO; Buf: PChar; Len: integer): integer;
function BioRead(b: PBIO; var Buf: AnsiString; Len: integer): integer;
begin
if InitSSLInterface and Assigned(_BioRead) then
Result := _BioRead(b, PAnsiChar(Buf), Len)
else
Result := -2;
end;
//function BioWrite(b: PBIO; Buf: PChar; Len: integer): integer;
function BioWrite(b: PBIO; Buf: AnsiString; Len: integer): integer;
begin
if InitSSLInterface and Assigned(_BioWrite) then
Result := _BioWrite(b, PAnsiChar(Buf), Len)
else
Result := -2;
end;
function X509print(b: PBIO; a: PX509): integer;
begin
if InitSSLInterface and Assigned(_X509print) then
Result := _X509print(b, a)
else
Result := 0;
end;
function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr;
begin
if InitSSLInterface and Assigned(_d2iPKCS12bio) then
Result := _d2iPKCS12bio(b, Pkcs12)
else
Result := nil;
end;
function PKCS12parse(p12: SslPtr; pass: Ansistring; var pkey, cert, ca: SslPtr): integer;
begin
if InitSSLInterface and Assigned(_PKCS12parse) then
Result := _PKCS12parse(p12, SslPtr(pass), pkey, cert, ca)
else
Result := 0;
end;
procedure PKCS12free(p12: SslPtr);
begin
if InitSSLInterface and Assigned(_PKCS12free) then
_PKCS12free(p12);
end;
function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA;
begin
if InitSSLInterface and Assigned(_RsaGenerateKey) then
Result := _RsaGenerateKey(bits, e, callback, cb_arg)
else
Result := nil;
end;
function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer;
begin
if InitSSLInterface and Assigned(_EvpPkeyAssign) then
Result := _EvpPkeyAssign(pkey, _type, key)
else
Result := 0;
end;
function X509SetVersion(x: PX509; version: integer): integer;
begin
if InitSSLInterface and Assigned(_X509SetVersion) then
Result := _X509SetVersion(x, version)
else
Result := 0;
end;
function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer;
begin
if InitSSLInterface and Assigned(_X509SetPubkey) then
Result := _X509SetPubkey(x, pkey)
else
Result := 0;
end;
function X509SetIssuerName(x: PX509; name: PX509_NAME): integer;
begin
if InitSSLInterface and Assigned(_X509SetIssuerName) then
Result := _X509SetIssuerName(x, name)
else
Result := 0;
end;
function X509NameAddEntryByTxt(name: PX509_NAME; field: Ansistring; _type: integer;
bytes: Ansistring; len, loc, _set: integer): integer;
begin
if InitSSLInterface and Assigned(_X509NameAddEntryByTxt) then
Result := _X509NameAddEntryByTxt(name, PAnsiChar(field), _type, PAnsiChar(Bytes), len, loc, _set)
else
Result := 0;
end;
function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer;
begin
if InitSSLInterface and Assigned(_X509Sign) then
Result := _X509Sign(x, pkey, md)
else
Result := 0;
end;
function Asn1UtctimeNew: PASN1_UTCTIME;
begin
if InitSSLInterface and Assigned(_Asn1UtctimeNew) then
Result := _Asn1UtctimeNew
else
Result := nil;
end;
procedure Asn1UtctimeFree(a: PASN1_UTCTIME);
begin
if InitSSLInterface and Assigned(_Asn1UtctimeFree) then
_Asn1UtctimeFree(a);
end;
function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME;
begin
if InitSSLInterface and Assigned(_X509GmtimeAdj) then
Result := _X509GmtimeAdj(s, adj)
else
Result := nil;
end;
function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer;
begin
if InitSSLInterface and Assigned(_X509SetNotBefore) then
Result := _X509SetNotBefore(x, tm)
else
Result := 0;
end;
function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer;
begin
if InitSSLInterface and Assigned(_X509SetNotAfter) then
Result := _X509SetNotAfter(x, tm)
else
Result := 0;
end;
function i2dX509bio(b: PBIO; x: PX509): integer;
begin
if InitSSLInterface and Assigned(_i2dX509bio) then
Result := _i2dX509bio(b, x)
else
Result := 0;
end;
function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer;
begin
if InitSSLInterface and Assigned(_i2dPrivateKeyBio) then
Result := _i2dPrivateKeyBio(b, pkey)
else
Result := 0;
end;
function EvpGetDigestByName(Name: AnsiString): PEVP_MD;
begin
if InitSSLInterface and Assigned(_EvpGetDigestByName) then
Result := _EvpGetDigestByName(PAnsiChar(Name))
else
Result := nil;
end;
function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer;
begin
if InitSSLInterface and Assigned(_Asn1IntegerSet) then
Result := _Asn1IntegerSet(a, v)
else
Result := 0;
end;
function X509GetSerialNumber(x: PX509): PASN1_INTEGER;
begin
if InitSSLInterface and Assigned(_X509GetSerialNumber) then
Result := _X509GetSerialNumber(x)
else
Result := nil;
end;
// 3DES functions
procedure DESsetoddparity(Key: des_cblock);
begin
if InitSSLInterface and Assigned(_DESsetoddparity) then
_DESsetoddparity(Key);
end;
function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer;
begin
if InitSSLInterface and Assigned(_DESsetkeychecked) then
Result := _DESsetkeychecked(key, schedule)
else
Result := -1;
end;
procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer);
begin
if InitSSLInterface and Assigned(_DESecbencrypt) then
_DESecbencrypt(Input, output, ks, enc);
end;
procedure locking_callback(mode, ltype: integer; lfile: PChar; line: integer); cdecl;
begin
if (mode and 1) > 0 then
TCriticalSection(Locks[ltype]).Enter
else
TCriticalSection(Locks[ltype]).Leave;
end;
procedure InitLocks;
var
n: integer;
max: integer;
begin
Locks := TList.Create;
max := _CRYPTOnumlocks;
for n := 1 to max do
Locks.Add(TCriticalSection.Create);
_CRYPTOsetlockingcallback(@locking_callback);
end;
procedure FreeLocks;
var
n: integer;
begin
_CRYPTOsetlockingcallback(nil);
for n := 0 to Locks.Count - 1 do
TCriticalSection(Locks[n]).Free;
Locks.Free;
end;
{$ENDIF}
function LoadLib(const Value: String): HModule;
begin
{$IFDEF CIL}
Result := LoadLibrary(Value);
{$ELSE}
Result := LoadLibrary(PChar(Value));
{$ENDIF}
end;
function GetProcAddr(module: HModule; const ProcName: string): SslPtr;
begin
{$IFDEF CIL}
Result := GetProcAddress(module, ProcName);
{$ELSE}
Result := GetProcAddress(module, PChar(ProcName));
{$ENDIF}
end;
function InitSSLInterface: Boolean;
var
s: string;
x: integer;
begin
SSLCS.Enter;
try
if not IsSSLloaded then
begin
{$IFDEF CIL}
SSLLibHandle := 1;
SSLUtilHandle := 1;
{$ELSE}
SSLLibHandle := LoadLib(DLLSSLName);
SSLUtilHandle := LoadLib(DLLUtilName);
{$IFDEF MSWINDOWS}
if (SSLLibHandle = 0) then
SSLLibHandle := LoadLib(DLLSSLName2);
{$ENDIF}
{$ENDIF}
if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then
begin
{$IFNDEF CIL}
_SslGetError := GetProcAddr(SSLLibHandle, 'SSL_get_error');
_SslLibraryInit := GetProcAddr(SSLLibHandle, 'SSL_library_init');
_SslLoadErrorStrings := GetProcAddr(SSLLibHandle, 'SSL_load_error_strings');
_SslCtxSetCipherList := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_cipher_list');
_SslCtxNew := GetProcAddr(SSLLibHandle, 'SSL_CTX_new');
_SslCtxFree := GetProcAddr(SSLLibHandle, 'SSL_CTX_free');
_SslSetFd := GetProcAddr(SSLLibHandle, 'SSL_set_fd');
_SslMethodV2 := GetProcAddr(SSLLibHandle, 'SSLv2_method');
_SslMethodV3 := GetProcAddr(SSLLibHandle, 'SSLv3_method');
_SslMethodTLSV1 := GetProcAddr(SSLLibHandle, 'TLSv1_method');
_SslMethodV23 := GetProcAddr(SSLLibHandle, 'SSLv23_method');
_SslCtxUsePrivateKey := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey');
_SslCtxUsePrivateKeyASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey_ASN1');
//use SSL_CTX_use_RSAPrivateKey_file instead SSL_CTX_use_PrivateKey_file,
//because SSL_CTX_use_PrivateKey_file not support DER format. :-O
_SslCtxUsePrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_RSAPrivateKey_file');
_SslCtxUseCertificate := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate');
_SslCtxUseCertificateASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_ASN1');
_SslCtxUseCertificateFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_file');
_SslCtxUseCertificateChainFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_chain_file');
_SslCtxCheckPrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_check_private_key');
_SslCtxSetDefaultPasswdCb := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb');
_SslCtxSetDefaultPasswdCbUserdata := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb_userdata');
_SslCtxLoadVerifyLocations := GetProcAddr(SSLLibHandle, 'SSL_CTX_load_verify_locations');
_SslCtxCtrl := GetProcAddr(SSLLibHandle, 'SSL_CTX_ctrl');
_SslNew := GetProcAddr(SSLLibHandle, 'SSL_new');
_SslFree := GetProcAddr(SSLLibHandle, 'SSL_free');
_SslAccept := GetProcAddr(SSLLibHandle, 'SSL_accept');
_SslConnect := GetProcAddr(SSLLibHandle, 'SSL_connect');
_SslShutdown := GetProcAddr(SSLLibHandle, 'SSL_shutdown');
_SslRead := GetProcAddr(SSLLibHandle, 'SSL_read');
_SslPeek := GetProcAddr(SSLLibHandle, 'SSL_peek');
_SslWrite := GetProcAddr(SSLLibHandle, 'SSL_write');
_SslPending := GetProcAddr(SSLLibHandle, 'SSL_pending');
_SslGetPeerCertificate := GetProcAddr(SSLLibHandle, 'SSL_get_peer_certificate');
_SslGetVersion := GetProcAddr(SSLLibHandle, 'SSL_get_version');
_SslCtxSetVerify := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_verify');
_SslGetCurrentCipher := GetProcAddr(SSLLibHandle, 'SSL_get_current_cipher');
_SslCipherGetName := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_name');
_SslCipherGetBits := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_bits');
_SslGetVerifyResult := GetProcAddr(SSLLibHandle, 'SSL_get_verify_result');
_X509New := GetProcAddr(SSLUtilHandle, 'X509_new');
_X509Free := GetProcAddr(SSLUtilHandle, 'X509_free');
_X509NameOneline := GetProcAddr(SSLUtilHandle, 'X509_NAME_oneline');
_X509GetSubjectName := GetProcAddr(SSLUtilHandle, 'X509_get_subject_name');
_X509GetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_get_issuer_name');
_X509NameHash := GetProcAddr(SSLUtilHandle, 'X509_NAME_hash');
_X509Digest := GetProcAddr(SSLUtilHandle, 'X509_digest');
_X509print := GetProcAddr(SSLUtilHandle, 'X509_print');
_X509SetVersion := GetProcAddr(SSLUtilHandle, 'X509_set_version');
_X509SetPubkey := GetProcAddr(SSLUtilHandle, 'X509_set_pubkey');
_X509SetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_set_issuer_name');
_X509NameAddEntryByTxt := GetProcAddr(SSLUtilHandle, 'X509_NAME_add_entry_by_txt');
_X509Sign := GetProcAddr(SSLUtilHandle, 'X509_sign');
_X509GmtimeAdj := GetProcAddr(SSLUtilHandle, 'X509_gmtime_adj');
_X509SetNotBefore := GetProcAddr(SSLUtilHandle, 'X509_set_notBefore');
_X509SetNotAfter := GetProcAddr(SSLUtilHandle, 'X509_set_notAfter');
_X509GetSerialNumber := GetProcAddr(SSLUtilHandle, 'X509_get_serialNumber');
_EvpPkeyNew := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_new');
_EvpPkeyFree := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_free');
_EvpPkeyAssign := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_assign');
_EVPCleanup := GetProcAddr(SSLUtilHandle, 'EVP_cleanup');
_EvpGetDigestByName := GetProcAddr(SSLUtilHandle, 'EVP_get_digestbyname');
_SSLeayversion := GetProcAddr(SSLUtilHandle, 'SSLeay_version');
_ErrErrorString := GetProcAddr(SSLUtilHandle, 'ERR_error_string_n');
_ErrGetError := GetProcAddr(SSLUtilHandle, 'ERR_get_error');
_ErrClearError := GetProcAddr(SSLUtilHandle, 'ERR_clear_error');
_ErrFreeStrings := GetProcAddr(SSLUtilHandle, 'ERR_free_strings');
_ErrRemoveState := GetProcAddr(SSLUtilHandle, 'ERR_remove_state');
_OPENSSLaddallalgorithms := GetProcAddr(SSLUtilHandle, 'OPENSSL_add_all_algorithms_noconf');
_CRYPTOcleanupAllExData := GetProcAddr(SSLUtilHandle, 'CRYPTO_cleanup_all_ex_data');
_RandScreen := GetProcAddr(SSLUtilHandle, 'RAND_screen');
_BioNew := GetProcAddr(SSLUtilHandle, 'BIO_new');
_BioFreeAll := GetProcAddr(SSLUtilHandle, 'BIO_free_all');
_BioSMem := GetProcAddr(SSLUtilHandle, 'BIO_s_mem');
_BioCtrlPending := GetProcAddr(SSLUtilHandle, 'BIO_ctrl_pending');
_BioRead := GetProcAddr(SSLUtilHandle, 'BIO_read');
_BioWrite := GetProcAddr(SSLUtilHandle, 'BIO_write');
_d2iPKCS12bio := GetProcAddr(SSLUtilHandle, 'd2i_PKCS12_bio');
_PKCS12parse := GetProcAddr(SSLUtilHandle, 'PKCS12_parse');
_PKCS12free := GetProcAddr(SSLUtilHandle, 'PKCS12_free');
_RsaGenerateKey := GetProcAddr(SSLUtilHandle, 'RSA_generate_key');
_Asn1UtctimeNew := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_new');
_Asn1UtctimeFree := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_free');
_Asn1IntegerSet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_set');
_i2dX509bio := GetProcAddr(SSLUtilHandle, 'i2d_X509_bio');
_i2dPrivateKeyBio := GetProcAddr(SSLUtilHandle, 'i2d_PrivateKey_bio');
// 3DES functions
_DESsetoddparity := GetProcAddr(SSLUtilHandle, 'DES_set_odd_parity');
_DESsetkeychecked := GetProcAddr(SSLUtilHandle, 'DES_set_key_checked');
_DESecbencrypt := GetProcAddr(SSLUtilHandle, 'DES_ecb_encrypt');
//
_CRYPTOnumlocks := GetProcAddr(SSLUtilHandle, 'CRYPTO_num_locks');
_CRYPTOsetlockingcallback := GetProcAddr(SSLUtilHandle, 'CRYPTO_set_locking_callback');
{$ENDIF}
{$IFDEF CIL}
SslLibraryInit;
SslLoadErrorStrings;
OPENSSLaddallalgorithms;
RandScreen;
{$ELSE}
SetLength(s, 1024);
x := GetModuleFilename(SSLLibHandle,PChar(s),Length(s));
SetLength(s, x);
SSLLibFile := s;
SetLength(s, 1024);
x := GetModuleFilename(SSLUtilHandle,PChar(s),Length(s));
SetLength(s, x);
SSLUtilFile := s;
//init library
if assigned(_SslLibraryInit) then
_SslLibraryInit;
if assigned(_SslLoadErrorStrings) then
_SslLoadErrorStrings;
if assigned(_OPENSSLaddallalgorithms) then
_OPENSSLaddallalgorithms;
if assigned(_RandScreen) then
_RandScreen;
if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then
InitLocks;
{$ENDIF}
Result := True;
SSLloaded := True;
end
else
begin
//load failed!
if SSLLibHandle <> 0 then
begin
{$IFNDEF CIL}
FreeLibrary(SSLLibHandle);
{$ENDIF}
SSLLibHandle := 0;
end;
if SSLUtilHandle <> 0 then
begin
{$IFNDEF CIL}
FreeLibrary(SSLUtilHandle);
{$ENDIF}
SSLLibHandle := 0;
end;
Result := False;
end;
end
else
//loaded before...
Result := true;
finally
SSLCS.Leave;
end;
end;
function DestroySSLInterface: Boolean;
begin
SSLCS.Enter;
try
if IsSSLLoaded then
begin
//deinit library
{$IFNDEF CIL}
if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then
FreeLocks;
{$ENDIF}
EVPCleanup;
CRYPTOcleanupAllExData;
ErrRemoveState(0);
end;
SSLloaded := false;
if SSLLibHandle <> 0 then
begin
{$IFNDEF CIL}
FreeLibrary(SSLLibHandle);
{$ENDIF}
SSLLibHandle := 0;
end;
if SSLUtilHandle <> 0 then
begin
{$IFNDEF CIL}
FreeLibrary(SSLUtilHandle);
{$ENDIF}
SSLLibHandle := 0;
end;
{$IFNDEF CIL}
_SslGetError := nil;
_SslLibraryInit := nil;
_SslLoadErrorStrings := nil;
_SslCtxSetCipherList := nil;
_SslCtxNew := nil;
_SslCtxFree := nil;
_SslSetFd := nil;
_SslMethodV2 := nil;
_SslMethodV3 := nil;
_SslMethodTLSV1 := nil;
_SslMethodV23 := nil;
_SslCtxUsePrivateKey := nil;
_SslCtxUsePrivateKeyASN1 := nil;
_SslCtxUsePrivateKeyFile := nil;
_SslCtxUseCertificate := nil;
_SslCtxUseCertificateASN1 := nil;
_SslCtxUseCertificateFile := nil;
_SslCtxUseCertificateChainFile := nil;
_SslCtxCheckPrivateKeyFile := nil;
_SslCtxSetDefaultPasswdCb := nil;
_SslCtxSetDefaultPasswdCbUserdata := nil;
_SslCtxLoadVerifyLocations := nil;
_SslCtxCtrl := nil;
_SslNew := nil;
_SslFree := nil;
_SslAccept := nil;
_SslConnect := nil;
_SslShutdown := nil;
_SslRead := nil;
_SslPeek := nil;
_SslWrite := nil;
_SslPending := nil;
_SslGetPeerCertificate := nil;
_SslGetVersion := nil;
_SslCtxSetVerify := nil;
_SslGetCurrentCipher := nil;
_SslCipherGetName := nil;
_SslCipherGetBits := nil;
_SslGetVerifyResult := nil;
_X509New := nil;
_X509Free := nil;
_X509NameOneline := nil;
_X509GetSubjectName := nil;
_X509GetIssuerName := nil;
_X509NameHash := nil;
_X509Digest := nil;
_X509print := nil;
_X509SetVersion := nil;
_X509SetPubkey := nil;
_X509SetIssuerName := nil;
_X509NameAddEntryByTxt := nil;
_X509Sign := nil;
_X509GmtimeAdj := nil;
_X509SetNotBefore := nil;
_X509SetNotAfter := nil;
_X509GetSerialNumber := nil;
_EvpPkeyNew := nil;
_EvpPkeyFree := nil;
_EvpPkeyAssign := nil;
_EVPCleanup := nil;
_EvpGetDigestByName := nil;
_SSLeayversion := nil;
_ErrErrorString := nil;
_ErrGetError := nil;
_ErrClearError := nil;
_ErrFreeStrings := nil;
_ErrRemoveState := nil;
_OPENSSLaddallalgorithms := nil;
_CRYPTOcleanupAllExData := nil;
_RandScreen := nil;
_BioNew := nil;
_BioFreeAll := nil;
_BioSMem := nil;
_BioCtrlPending := nil;
_BioRead := nil;
_BioWrite := nil;
_d2iPKCS12bio := nil;
_PKCS12parse := nil;
_PKCS12free := nil;
_RsaGenerateKey := nil;
_Asn1UtctimeNew := nil;
_Asn1UtctimeFree := nil;
_Asn1IntegerSet := nil;
_i2dX509bio := nil;
_i2dPrivateKeyBio := nil;
// 3DES functions
_DESsetoddparity := nil;
_DESsetkeychecked := nil;
_DESecbencrypt := nil;
//
_CRYPTOnumlocks := nil;
_CRYPTOsetlockingcallback := nil;
{$ENDIF}
finally
SSLCS.Leave;
end;
Result := True;
end;
function IsSSLloaded: Boolean;
begin
Result := SSLLoaded;
end;
initialization
begin
SSLCS:= TCriticalSection.Create;
end;
finalization
begin
{$IFNDEF CIL}
DestroySSLInterface;
{$ENDIF}
SSLCS.Free;
end;
end.
TransGUI/synapse/source/lib/slogsend.pas 0000644 0000000 0000000 00000023324 11366572451 017301 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.002.003 |
|==============================================================================|
| Content: SysLog client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Christian Brosius |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(BSD SYSLOG protocol)
Used RFC: RFC-3164
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
unit slogsend;
interface
uses
SysUtils, Classes,
blcksock, synautil;
const
cSysLogProtocol = '514';
FCL_Kernel = 0;
FCL_UserLevel = 1;
FCL_MailSystem = 2;
FCL_System = 3;
FCL_Security = 4;
FCL_Syslogd = 5;
FCL_Printer = 6;
FCL_News = 7;
FCL_UUCP = 8;
FCL_Clock = 9;
FCL_Authorization = 10;
FCL_FTP = 11;
FCL_NTP = 12;
FCL_LogAudit = 13;
FCL_LogAlert = 14;
FCL_Time = 15;
FCL_Local0 = 16;
FCL_Local1 = 17;
FCL_Local2 = 18;
FCL_Local3 = 19;
FCL_Local4 = 20;
FCL_Local5 = 21;
FCL_Local6 = 22;
FCL_Local7 = 23;
type
{:@abstract(Define possible priority of Syslog message)}
TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info,
Debug);
{:@abstract(encoding or decoding of SYSLOG message)}
TSyslogMessage = class(TObject)
private
FFacility:Byte;
FSeverity:TSyslogSeverity;
FDateTime:TDateTime;
FTag:String;
FMessage:String;
FLocalIP:String;
function GetPacketBuf:String;
procedure SetPacketBuf(Value:String);
public
{:Reset values to defaults}
procedure Clear;
published
{:Define facilicity of Syslog message. For specify you may use predefined
FCL_* constants. Default is "FCL_Local0".}
property Facility:Byte read FFacility write FFacility;
{:Define possible priority of Syslog message. Default is "Debug".}
property Severity:TSyslogSeverity read FSeverity write FSeverity;
{:date and time of Syslog message}
property DateTime:TDateTime read FDateTime write FDateTime;
{:This is used for identify process of this message. Default is filename
of your executable file.}
property Tag:String read FTag write FTag;
{:Text of your message for log.}
property LogMessage:String read FMessage write FMessage;
{:IP address of message sender.}
property LocalIP:String read FLocalIP write FLocalIP;
{:This property holds encoded binary SYSLOG packet}
property PacketBuf:String read GetPacketBuf write SetPacketBuf;
end;
{:@abstract(This object implement BSD SysLog client)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TSyslogSend = class(TSynaClient)
private
FSock: TUDPBlockSocket;
FSysLogMessage: TSysLogMessage;
public
constructor Create;
destructor Destroy; override;
{:Send Syslog UDP packet defined by @link(SysLogMessage).}
function DoIt: Boolean;
published
{:Syslog message for send}
property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage;
end;
{:Simply send packet to specified Syslog server.}
function ToSysLog(const SyslogServer: string; Facil: Byte;
Sever: TSyslogSeverity; const Content: string): Boolean;
implementation
function TSyslogMessage.GetPacketBuf:String;
begin
Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>';
Result := Result + CDateTime(FDateTime) + ' ';
Result := Result + FLocalIP + ' ';
Result := Result + FTag + ': ' + FMessage;
end;
procedure TSyslogMessage.SetPacketBuf(Value:String);
var StrBuf:String;
IntBuf,Pos:Integer;
begin
if Length(Value) < 1 then exit;
Pos := 1;
if Value[Pos] <> '<' then exit;
Inc(Pos);
// Facility and Severity
StrBuf := '';
while (Value[Pos] <> '>')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
IntBuf := StrToInt(StrBuf);
FFacility := IntBuf div 8;
case (IntBuf mod 8)of
0:FSeverity := Emergency;
1:FSeverity := Alert;
2:FSeverity := Critical;
3:FSeverity := Error;
4:FSeverity := Warning;
5:FSeverity := Notice;
6:FSeverity := Info;
7:FSeverity := Debug;
end;
// DateTime
Inc(Pos);
StrBuf := '';
// Month
while (Value[Pos] <> ' ')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
// Day
while (Value[Pos] <> ' ')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
// Time
while (Value[Pos] <> ' ')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
FDateTime := DecodeRFCDateTime(StrBuf);
Inc(Pos);
// LocalIP
StrBuf := '';
while (Value[Pos] <> ' ')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
FLocalIP := StrBuf;
Inc(Pos);
// Tag
StrBuf := '';
while (Value[Pos] <> ':')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
FTag := StrBuf;
// LogMessage
Inc(Pos);
StrBuf := '';
while (Pos <= Length(Value))do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
FMessage := TrimSP(StrBuf);
end;
procedure TSysLogMessage.Clear;
begin
FFacility := FCL_Local0;
FSeverity := Debug;
FTag := ExtractFileName(ParamStr(0));
FMessage := '';
FLocalIP := '0.0.0.0';
end;
//------------------------------------------------------------------------------
constructor TSyslogSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FSysLogMessage := TSysLogMessage.Create;
FTargetPort := cSysLogProtocol;
end;
destructor TSyslogSend.Destroy;
begin
FSock.Free;
FSysLogMessage.Free;
inherited Destroy;
end;
function TSyslogSend.DoIt: Boolean;
var
L: TStringList;
begin
Result := False;
L := TStringList.Create;
try
FSock.ResolveNameToIP(FSock.Localname, L);
if L.Count < 1 then
FSysLogMessage.LocalIP := '0.0.0.0'
else
FSysLogMessage.LocalIP := L[0];
finally
L.Free;
end;
FSysLogMessage.DateTime := Now;
if Length(FSysLogMessage.PacketBuf) <= 1024 then
begin
FSock.Connect(FTargetHost, FTargetPort);
FSock.SendString(FSysLogMessage.PacketBuf);
Result := FSock.LastError = 0;
end;
end;
{==============================================================================}
function ToSysLog(const SyslogServer: string; Facil: Byte;
Sever: TSyslogSeverity; const Content: string): Boolean;
begin
with TSyslogSend.Create do
try
TargetHost :=SyslogServer;
SysLogMessage.Facility := Facil;
SysLogMessage.Severity := Sever;
SysLogMessage.LogMessage := Content;
Result := DoIt;
finally
Free;
end;
end;
end.
TransGUI/synapse/source/lib/smtpsend.pas 0000644 0000000 0000000 00000057660 11366572451 017332 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 003.005.001 |
|==============================================================================|
| Content: SMTP client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(SMTP client)
Used RFC: RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487,
RFC-2554, RFC-2821
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit smtpsend;
interface
uses
SysUtils, Classes,
blcksock, synautil, synacode;
const
cSmtpProtocol = '25';
type
{:@abstract(Implementation of SMTP and ESMTP procotol),
include some ESMTP extensions, include SSL/TLS too.
Note: Are you missing properties for setting Username and Password for ESMTP?
Look to parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TSMTPSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FResultCode: Integer;
FResultString: string;
FFullResult: TStringList;
FESMTPcap: TStringList;
FESMTP: Boolean;
FAuthDone: Boolean;
FESMTPSize: Boolean;
FMaxSize: Integer;
FEnhCode1: Integer;
FEnhCode2: Integer;
FEnhCode3: Integer;
FSystemName: string;
FAutoTLS: Boolean;
FFullSSL: Boolean;
procedure EnhancedCode(const Value: string);
function ReadResult: Integer;
function AuthLogin: Boolean;
function AuthCram: Boolean;
function AuthPlain: Boolean;
function Helo: Boolean;
function Ehlo: Boolean;
function Connect: Boolean;
public
constructor Create;
destructor Destroy; override;
{:Connects to SMTP server (defined in @link(TSynaClient.TargetHost)) and
begin SMTP session. (First try ESMTP EHLO, next old HELO handshake). Parses
ESMTP capabilites and if you specified Username and password and remote
server can handle AUTH command, try login by AUTH command. Preffered login
method is CRAM-MD5 (if safer!). If all OK, result is @true, else result is
@false.}
function Login: Boolean;
{:Close SMTP session (QUIT command) and disconnect from SMTP server.}
function Logout: Boolean;
{:Send RSET SMTP command for reset SMTP session. If all OK, result is @true,
else result is @false.}
function Reset: Boolean;
{:Send NOOP SMTP command for keep SMTP session. If all OK, result is @true,
else result is @false.}
function NoOp: Boolean;
{:Send MAIL FROM SMTP command for set sender e-mail address. If sender's
e-mail address is empty string, transmited message is error message.
If size not 0 and remote server can handle SIZE parameter, append SIZE
parameter to request. If all OK, result is @true, else result is @false.}
function MailFrom(const Value: string; Size: Integer): Boolean;
{:Send RCPT TO SMTP command for set receiver e-mail address. It cannot be an
empty string. If all OK, result is @true, else result is @false.}
function MailTo(const Value: string): Boolean;
{:Send DATA SMTP command and transmit message data. If all OK, result is
@true, else result is @false.}
function MailData(const Value: Tstrings): Boolean;
{:Send ETRN SMTP command for start sending of remote queue for domain in
Value. If all OK, result is @true, else result is @false.}
function Etrn(const Value: string): Boolean;
{:Send VRFY SMTP command for check receiver e-mail address. It cannot be
an empty string. If all OK, result is @true, else result is @false.}
function Verify(const Value: string): Boolean;
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean;
{:Return string descriptive text for enhanced result codes stored in
@link(EnhCode1), @link(EnhCode2) and @link(EnhCode3).}
function EnhCodeString: string;
{:Try to find specified capability in ESMTP response.}
function FindCap(const Value: string): string;
published
{:result code of last SMTP command.}
property ResultCode: Integer read FResultCode;
{:result string of last SMTP command (begin with string representation of
result code).}
property ResultString: string read FResultString;
{:All result strings of last SMTP command (result is maybe multiline!).}
property FullResult: TStringList read FFullResult;
{:List of ESMTP capabilites of remote ESMTP server. (If you connect to ESMTP
server only!).}
property ESMTPcap: TStringList read FESMTPcap;
{:@TRUE if you successfuly logged to ESMTP server.}
property ESMTP: Boolean read FESMTP;
{:@TRUE if you successfuly pass authorisation to remote server.}
property AuthDone: Boolean read FAuthDone;
{:@TRUE if remote server can handle SIZE parameter.}
property ESMTPSize: Boolean read FESMTPSize;
{:When @link(ESMTPsize) is @TRUE, contains max length of message that remote
server can handle.}
property MaxSize: Integer read FMaxSize;
{:First digit of Enhanced result code. If last operation does not have
enhanced result code, values is 0.}
property EnhCode1: Integer read FEnhCode1;
{:Second digit of Enhanced result code. If last operation does not have
enhanced result code, values is 0.}
property EnhCode2: Integer read FEnhCode2;
{:Third digit of Enhanced result code. If last operation does not have
enhanced result code, values is 0.}
property EnhCode3: Integer read FEnhCode3;
{:name of our system used in HELO and EHLO command. Implicit value is
internet address of your machine.}
property SystemName: string read FSystemName Write FSystemName;
{:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
end;
{:A very useful function and example of its use would be found in the TSMTPsend
object. Send maildata (text of e-mail with all SMTP headers! For example when
text of message is created by @link(TMimemess) object) from "MailFrom" e-mail
address to "MailTo" e-mail address (If you need more then one receiver, then
separate their addresses by comma).
Function sends e-mail to a SMTP server defined in "SMTPhost" parameter.
Username and password are used for authorization to the "SMTPhost". If you
don't want authorization, set "Username" and "Password" to empty strings. If
e-mail message is successfully sent, the result returns @true.
If you need use different port number then standard, then add this port number
to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
{:A very useful function and example of its use would be found in the TSMTPsend
object. Send "Maildata" (text of e-mail without any SMTP headers!) from
"MailFrom" e-mail address to "MailTo" e-mail address with "Subject". (If you
need more then one receiver, then separate their addresses by comma).
This function constructs all needed SMTP headers (with DATE header) and sends
the e-mail to the SMTP server defined in the "SMTPhost" parameter. If the
e-mail message is successfully sent, the result will be @TRUE.
If you need use different port number then standard, then add this port number
to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings): Boolean;
{:A very useful function and example of its use would be found in the TSMTPsend
object. Sends "MailData" (text of e-mail without any SMTP headers!) from
"MailFrom" e-mail address to "MailTo" e-mail address (If you need more then one
receiver, then separate their addresses by comma).
This function sends the e-mail to the SMTP server defined in the "SMTPhost"
parameter. Username and password are used for authorization to the "SMTPhost".
If you dont want authorization, set "Username" and "Password" to empty Strings.
If the e-mail message is successfully sent, the result will be @TRUE.
If you need use different port number then standard, then add this port number
to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
implementation
constructor TSMTPSend.Create;
begin
inherited Create;
FFullResult := TStringList.Create;
FESMTPcap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := true;
FTimeout := 60000;
FTargetPort := cSmtpProtocol;
FSystemName := FSock.LocalName;
FAutoTLS := False;
FFullSSL := False;
end;
destructor TSMTPSend.Destroy;
begin
FSock.Free;
FESMTPcap.Free;
FFullResult.Free;
inherited Destroy;
end;
procedure TSMTPSend.EnhancedCode(const Value: string);
var
s, t: string;
e1, e2, e3: Integer;
begin
FEnhCode1 := 0;
FEnhCode2 := 0;
FEnhCode3 := 0;
s := Copy(Value, 5, Length(Value) - 4);
t := Trim(SeparateLeft(s, '.'));
s := Trim(SeparateRight(s, '.'));
if t = '' then
Exit;
if Length(t) > 1 then
Exit;
e1 := StrToIntDef(t, 0);
if e1 = 0 then
Exit;
t := Trim(SeparateLeft(s, '.'));
s := Trim(SeparateRight(s, '.'));
if t = '' then
Exit;
if Length(t) > 3 then
Exit;
e2 := StrToIntDef(t, 0);
t := Trim(SeparateLeft(s, ' '));
if t = '' then
Exit;
if Length(t) > 3 then
Exit;
e3 := StrToIntDef(t, 0);
FEnhCode1 := e1;
FEnhCode2 := e2;
FEnhCode3 := e3;
end;
function TSMTPSend.ReadResult: Integer;
var
s: String;
begin
Result := 0;
FFullResult.Clear;
repeat
s := FSock.RecvString(FTimeout);
FResultString := s;
FFullResult.Add(s);
if FSock.LastError <> 0 then
Break;
until Pos('-', s) <> 4;
s := FFullResult[0];
if Length(s) >= 3 then
Result := StrToIntDef(Copy(s, 1, 3), 0);
FResultCode := Result;
EnhancedCode(s);
end;
function TSMTPSend.AuthLogin: Boolean;
begin
Result := False;
FSock.SendString('AUTH LOGIN' + CRLF);
if ReadResult <> 334 then
Exit;
FSock.SendString(EncodeBase64(FUsername) + CRLF);
if ReadResult <> 334 then
Exit;
FSock.SendString(EncodeBase64(FPassword) + CRLF);
Result := ReadResult = 235;
end;
function TSMTPSend.AuthCram: Boolean;
var
s: ansistring;
begin
Result := False;
FSock.SendString('AUTH CRAM-MD5' + CRLF);
if ReadResult <> 334 then
Exit;
s := Copy(FResultString, 5, Length(FResultString) - 4);
s := DecodeBase64(s);
s := HMAC_MD5(s, FPassword);
s := FUsername + ' ' + StrToHex(s);
FSock.SendString(EncodeBase64(s) + CRLF);
Result := ReadResult = 235;
end;
function TSMTPSend.AuthPlain: Boolean;
var
s: ansistring;
begin
Result := False;
s := ansichar(0) + FUsername + ansichar(0) + FPassword;
FSock.SendString('AUTH PLAIN ' + EncodeBase64(s) + CRLF);
Result := ReadResult = 235;
end;
function TSMTPSend.Connect: Boolean;
begin
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError = 0 then
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError = 0 then
if FFullSSL then
FSock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
function TSMTPSend.Helo: Boolean;
var
x: Integer;
begin
FSock.SendString('HELO ' + FSystemName + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
function TSMTPSend.Ehlo: Boolean;
var
x: Integer;
begin
FSock.SendString('EHLO ' + FSystemName + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
function TSMTPSend.Login: Boolean;
var
n: Integer;
auths: string;
s: string;
begin
Result := False;
FESMTP := True;
FAuthDone := False;
FESMTPcap.clear;
FESMTPSize := False;
FMaxSize := 0;
if not Connect then
Exit;
if ReadResult <> 220 then
Exit;
if not Ehlo then
begin
FESMTP := False;
if not Helo then
Exit;
end;
Result := True;
if FESMTP then
begin
for n := 1 to FFullResult.Count - 1 do
FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
if StartTLS then
begin
Ehlo;
FESMTPcap.Clear;
for n := 1 to FFullResult.Count - 1 do
FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
end
else
begin
Result := False;
Exit;
end;
if not ((FUsername = '') and (FPassword = '')) then
begin
s := FindCap('AUTH ');
if s = '' then
s := FindCap('AUTH=');
auths := UpperCase(s);
if s <> '' then
begin
if Pos('CRAM-MD5', auths) > 0 then
FAuthDone := AuthCram;
if (not FauthDone) and (Pos('PLAIN', auths) > 0) then
FAuthDone := AuthPlain;
if (not FauthDone) and (Pos('LOGIN', auths) > 0) then
FAuthDone := AuthLogin;
end;
end;
s := FindCap('SIZE');
if s <> '' then
begin
FESMTPsize := True;
FMaxSize := StrToIntDef(Copy(s, 6, Length(s) - 5), 0);
end;
end;
end;
function TSMTPSend.Logout: Boolean;
begin
FSock.SendString('QUIT' + CRLF);
Result := ReadResult = 221;
FSock.CloseSocket;
end;
function TSMTPSend.Reset: Boolean;
begin
FSock.SendString('RSET' + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.NoOp: Boolean;
begin
FSock.SendString('NOOP' + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.MailFrom(const Value: string; Size: Integer): Boolean;
var
s: string;
begin
s := 'MAIL FROM:<' + Value + '>';
if FESMTPsize and (Size > 0) then
s := s + ' SIZE=' + IntToStr(Size);
FSock.SendString(s + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.MailTo(const Value: string): Boolean;
begin
FSock.SendString('RCPT TO:<' + Value + '>' + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.MailData(const Value: TStrings): Boolean;
var
n: Integer;
s: string;
t: string;
x: integer;
begin
Result := False;
FSock.SendString('DATA' + CRLF);
if ReadResult <> 354 then
Exit;
t := '';
x := 1500;
for n := 0 to Value.Count - 1 do
begin
s := Value[n];
if Length(s) >= 1 then
if s[1] = '.' then
s := '.' + s;
if Length(t) + Length(s) >= x then
begin
FSock.SendString(t);
t := '';
end;
t := t + s + CRLF;
end;
if t <> '' then
FSock.SendString(t);
FSock.SendString('.' + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.Etrn(const Value: string): Boolean;
var
x: Integer;
begin
FSock.SendString('ETRN ' + Value + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
function TSMTPSend.Verify(const Value: string): Boolean;
var
x: Integer;
begin
FSock.SendString('VRFY ' + Value + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
function TSMTPSend.StartTLS: Boolean;
begin
Result := False;
if FindCap('STARTTLS') <> '' then
begin
FSock.SendString('STARTTLS' + CRLF);
if (ReadResult = 220) and (FSock.LastError = 0) then
begin
Fsock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
end;
function TSMTPSend.EnhCodeString: string;
var
s, t: string;
begin
s := IntToStr(FEnhCode2) + '.' + IntToStr(FEnhCode3);
t := '';
if s = '0.0' then t := 'Other undefined Status';
if s = '1.0' then t := 'Other address status';
if s = '1.1' then t := 'Bad destination mailbox address';
if s = '1.2' then t := 'Bad destination system address';
if s = '1.3' then t := 'Bad destination mailbox address syntax';
if s = '1.4' then t := 'Destination mailbox address ambiguous';
if s = '1.5' then t := 'Destination mailbox address valid';
if s = '1.6' then t := 'Mailbox has moved';
if s = '1.7' then t := 'Bad sender''s mailbox address syntax';
if s = '1.8' then t := 'Bad sender''s system address';
if s = '2.0' then t := 'Other or undefined mailbox status';
if s = '2.1' then t := 'Mailbox disabled, not accepting messages';
if s = '2.2' then t := 'Mailbox full';
if s = '2.3' then t := 'Message Length exceeds administrative limit';
if s = '2.4' then t := 'Mailing list expansion problem';
if s = '3.0' then t := 'Other or undefined mail system status';
if s = '3.1' then t := 'Mail system full';
if s = '3.2' then t := 'System not accepting network messages';
if s = '3.3' then t := 'System not capable of selected features';
if s = '3.4' then t := 'Message too big for system';
if s = '3.5' then t := 'System incorrectly configured';
if s = '4.0' then t := 'Other or undefined network or routing status';
if s = '4.1' then t := 'No answer from host';
if s = '4.2' then t := 'Bad connection';
if s = '4.3' then t := 'Routing server failure';
if s = '4.4' then t := 'Unable to route';
if s = '4.5' then t := 'Network congestion';
if s = '4.6' then t := 'Routing loop detected';
if s = '4.7' then t := 'Delivery time expired';
if s = '5.0' then t := 'Other or undefined protocol status';
if s = '5.1' then t := 'Invalid command';
if s = '5.2' then t := 'Syntax error';
if s = '5.3' then t := 'Too many recipients';
if s = '5.4' then t := 'Invalid command arguments';
if s = '5.5' then t := 'Wrong protocol version';
if s = '6.0' then t := 'Other or undefined media error';
if s = '6.1' then t := 'Media not supported';
if s = '6.2' then t := 'Conversion required and prohibited';
if s = '6.3' then t := 'Conversion required but not supported';
if s = '6.4' then t := 'Conversion with loss performed';
if s = '6.5' then t := 'Conversion failed';
if s = '7.0' then t := 'Other or undefined security status';
if s = '7.1' then t := 'Delivery not authorized, message refused';
if s = '7.2' then t := 'Mailing list expansion prohibited';
if s = '7.3' then t := 'Security conversion required but not possible';
if s = '7.4' then t := 'Security features not supported';
if s = '7.5' then t := 'Cryptographic failure';
if s = '7.6' then t := 'Cryptographic algorithm not supported';
if s = '7.7' then t := 'Message integrity failure';
s := '???-';
if FEnhCode1 = 2 then s := 'Success-';
if FEnhCode1 = 4 then s := 'Persistent Transient Failure-';
if FEnhCode1 = 5 then s := 'Permanent Failure-';
Result := s + t;
end;
function TSMTPSend.FindCap(const Value: string): string;
var
n: Integer;
s: string;
begin
s := UpperCase(Value);
Result := '';
for n := 0 to FESMTPcap.Count - 1 do
if Pos(s, UpperCase(FESMTPcap[n])) = 1 then
begin
Result := FESMTPcap[n];
Break;
end;
end;
{==============================================================================}
function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
var
SMTP: TSMTPSend;
s, t: string;
begin
Result := False;
SMTP := TSMTPSend.Create;
try
// if you need SOCKS5 support, uncomment next lines:
// SMTP.Sock.SocksIP := '127.0.0.1';
// SMTP.Sock.SocksPort := '1080';
// if you need support for upgrade session to TSL/SSL, uncomment next lines:
// SMTP.AutoTLS := True;
// if you need support for TSL/SSL tunnel, uncomment next lines:
// SMTP.FullSSL := True;
SMTP.TargetHost := Trim(SeparateLeft(SMTPHost, ':'));
s := Trim(SeparateRight(SMTPHost, ':'));
if (s <> '') and (s <> SMTPHost) then
SMTP.TargetPort := s;
SMTP.Username := Username;
SMTP.Password := Password;
if SMTP.Login then
begin
if SMTP.MailFrom(GetEmailAddr(MailFrom), Length(MailData.Text)) then
begin
s := MailTo;
repeat
t := GetEmailAddr(Trim(FetchEx(s, ',', '"')));
if t <> '' then
Result := SMTP.MailTo(t);
if not Result then
Break;
until s = '';
if Result then
Result := SMTP.MailData(MailData);
end;
SMTP.Logout;
end;
finally
SMTP.Free;
end;
end;
function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
var
t: TStrings;
begin
t := TStringList.Create;
try
t.Assign(MailData);
t.Insert(0, '');
t.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer');
t.Insert(0, 'Subject: ' + Subject);
t.Insert(0, 'Date: ' + Rfc822DateTime(now));
t.Insert(0, 'To: ' + MailTo);
t.Insert(0, 'From: ' + MailFrom);
Result := SendToRaw(MailFrom, MailTo, SMTPHost, t, Username, Password);
finally
t.Free;
end;
end;
function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings): Boolean;
begin
Result := SendToEx(MailFrom, MailTo, Subject, SMTPHost, MailData, '', '');
end;
end.
TransGUI/synapse/source/lib/imapsend.pas 0000644 0000000 0000000 00000062165 11366572451 017271 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 002.005.002 |
|==============================================================================|
| Content: IMAP4rev1 client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(IMAP4 rev1 protocol client)
Used RFC: RFC-2060, RFC-2595
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit imapsend;
interface
uses
SysUtils, Classes,
blcksock, synautil;
const
cIMAPProtocol = '143';
type
{:@abstract(Implementation of IMAP4 protocol.)
Note: Are you missing properties for setting Username and Password? Look to
parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TIMAPSend = class(TSynaClient)
protected
FSock: TTCPBlockSocket;
FTagCommand: integer;
FResultString: string;
FFullResult: TStringList;
FIMAPcap: TStringList;
FAuthDone: Boolean;
FSelectedFolder: string;
FSelectedCount: integer;
FSelectedRecent: integer;
FSelectedUIDvalidity: integer;
FUID: Boolean;
FAutoTLS: Boolean;
FFullSSL: Boolean;
function ReadResult: string;
function AuthLogin: Boolean;
function Connect: Boolean;
procedure ParseMess(Value:TStrings);
procedure ParseFolderList(Value:TStrings);
procedure ParseSelect;
procedure ParseSearch(Value:TStrings);
procedure ProcessLiterals;
public
constructor Create;
destructor Destroy; override;
{:By this function you can call any IMAP command. Result of this command is
in adequate properties.}
function IMAPcommand(Value: string): string;
{:By this function you can call any IMAP command what need upload any data.
Result of this command is in adequate properties.}
function IMAPuploadCommand(Value: string; const Data:TStrings): string;
{:Call CAPABILITY command and fill IMAPcap property by new values.}
function Capability: Boolean;
{:Connect to IMAP server and do login to this server. This command begin
session.}
function Login: Boolean;
{:Disconnect from IMAP server and terminate session session. If exists some
deleted and non-purged messages, these messages are not deleted!}
function Logout: Boolean;
{:Do NOOP. It is for prevent disconnect by timeout.}
function NoOp: Boolean;
{:Lists folder names. You may specify level of listing. If you specify
FromFolder as empty string, return is all folders in system.}
function List(FromFolder: string; const FolderList: TStrings): Boolean;
{:Lists folder names what match search criteria. You may specify level of
listing. If you specify FromFolder as empty string, return is all folders
in system.}
function ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
{:Lists subscribed folder names. You may specify level of listing. If you
specify FromFolder as empty string, return is all subscribed folders in
system.}
function ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
{:Lists subscribed folder names what matching search criteria. You may
specify level of listing. If you specify FromFolder as empty string, return
is all subscribed folders in system.}
function ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
{:Create a new folder.}
function CreateFolder(FolderName: string): Boolean;
{:Delete a folder.}
function DeleteFolder(FolderName: string): Boolean;
{:Rename folder names.}
function RenameFolder(FolderName, NewFolderName: string): Boolean;
{:Subscribe folder.}
function SubscribeFolder(FolderName: string): Boolean;
{:Unsubscribe folder.}
function UnsubscribeFolder(FolderName: string): Boolean;
{:Select folder.}
function SelectFolder(FolderName: string): Boolean;
{:Select folder, but only for reading. Any changes are not allowed!}
function SelectROFolder(FolderName: string): Boolean;
{:Close a folder. (end of Selected state)}
function CloseFolder: Boolean;
{:Ask for given status of folder. I.e. if you specify as value 'UNSEEN',
result is number of unseen messages in folder. For another status
indentificator check IMAP documentation and documentation of your IMAP
server (each IMAP server can have their own statuses.)}
function StatusFolder(FolderName, Value: string): integer;
{:Hardly delete all messages marked as 'deleted' in current selected folder.}
function ExpungeFolder: Boolean;
{:Touch to folder. (use as update status of folder, etc.)}
function CheckFolder: Boolean;
{:Append given message to specified folder.}
function AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
{:'Delete' message from current selected folder. It mark message as Deleted.
Real deleting will be done after sucessfull @link(CloseFolder) or
@link(ExpungeFolder)}
function DeleteMess(MessID: integer): boolean;
{:Get full message from specified message in selected folder.}
function FetchMess(MessID: integer; const Mess: TStrings): Boolean;
{:Get message headers only from specified message in selected folder.}
function FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
{:Return message size of specified message from current selected folder.}
function MessageSize(MessID: integer): integer;
{:Copy message from current selected folder to another folder.}
function CopyMess(MessID: integer; ToFolder: string): Boolean;
{:Return message numbers from currently selected folder as result
of searching. Search criteria is very complex language (see to IMAP
specification) similar to SQL (but not same syntax!).}
function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
{:Sets flags of message from current selected folder.}
function SetFlagsMess(MessID: integer; Flags: string): Boolean;
{:Gets flags of message from current selected folder.}
function GetFlagsMess(MessID: integer; var Flags: string): Boolean;
{:Add flags to message's flags.}
function AddFlagsMess(MessID: integer; Flags: string): Boolean;
{:Remove flags from message's flags.}
function DelFlagsMess(MessID: integer; Flags: string): Boolean;
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean;
{:return UID of requested message ID.}
function GetUID(MessID: integer; var UID : Integer): Boolean;
{:Try to find given capabily in capabilty string returned from IMAP server.}
function FindCap(const Value: string): string;
published
{:Status line with result of last operation.}
property ResultString: string read FResultString;
{:Full result of last IMAP operation.}
property FullResult: TStringList read FFullResult;
{:List of server capabilites.}
property IMAPcap: TStringList read FIMAPcap;
{:Authorization is successful done.}
property AuthDone: Boolean read FAuthDone;
{:Turn on or off usage of UID (unicate identificator) of messages instead
only sequence numbers.}
property UID: Boolean read FUID Write FUID;
{:Name of currently selected folder.}
property SelectedFolder: string read FSelectedFolder;
{:Count of messages in currently selected folder.}
property SelectedCount: integer read FSelectedCount;
{:Count of not-visited messages in currently selected folder.}
property SelectedRecent: integer read FSelectedRecent;
{:This number with name of folder is unique indentificator of folder.
(If someone delete folder and next create new folder with exactly same name
of folder, this number is must be different!)}
property SelectedUIDvalidity: integer read FSelectedUIDvalidity;
{:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
end;
implementation
constructor TIMAPSend.Create;
begin
inherited Create;
FFullResult := TStringList.Create;
FIMAPcap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := True;
FSock.SizeRecvBuffer := 32768;
FSock.SizeSendBuffer := 32768;
FTimeout := 60000;
FTargetPort := cIMAPProtocol;
FTagCommand := 0;
FSelectedFolder := '';
FSelectedCount := 0;
FSelectedRecent := 0;
FSelectedUIDvalidity := 0;
FUID := False;
FAutoTLS := False;
FFullSSL := 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
s := FSock.RecvBufferStr(l, FTimeout);
FFullResult.Add(s);
end;
end;
until FSock.LastError <> 0;
s := Trim(separateright(FResultString, ' '));
Result:=uppercase(Trim(separateleft(s, ' ')));
end;
procedure TIMAPSend.ProcessLiterals;
var
l: TStringList;
n, x: integer;
b: integer;
s: string;
begin
l := TStringList.Create;
try
l.Assign(FFullResult);
FFullResult.Clear;
b := 0;
for n := 0 to l.Count - 1 do
begin
s := l[n];
if b > 0 then
begin
FFullResult[FFullresult.Count - 1] :=
FFullResult[FFullresult.Count - 1] + s;
inc(b);
if b > 2 then
b := 0;
end
else
begin
if (s <> '') and (s[Length(s)]='}') then
begin
x := RPos('{', s);
Delete(s, x, Length(s) - x + 1);
b := 1;
end
else
b := 0;
FFullResult.Add(s);
end;
end;
finally
l.Free;
end;
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('S' + IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF);
FSock.RecvString(FTimeout);
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
ProcessLiterals;
Value.Clear;
for n := 0 to FFullResult.Count - 1 do
begin
s := FFullResult[n];
if (s <> '') and (Pos('\NOSELECT', UpperCase(s)) = 0) then
begin
if s[Length(s)] = '"' then
begin
Delete(s, Length(s), 1);
x := RPos('"', s);
end
else
x := RPos(' ', s);
if (x > 0) then
Value.Add(Copy(s, x + 1, Length(s) - x));
end;
end;
end;
procedure TIMAPSend.ParseSelect;
var
n: integer;
s, t: string;
begin
ProcessLiterals;
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 := Trim(separateleft(s, ' EXISTS'));
t := Trim(separateright(t, '* '));
FSelectedCount := StrToIntDef(t, 0);
end;
if Pos(' RECENT', s) > 0 then
begin
t := Trim(separateleft(s, ' RECENT'));
t := Trim(separateright(t, '* '));
FSelectedRecent := StrToIntDef(t, 0);
end;
if Pos('UIDVALIDITY', s) > 0 then
begin
t := Trim(separateright(s, 'UIDVALIDITY '));
t := Trim(separateleft(t, ']'));
FSelectedUIDvalidity := StrToIntDef(t, 0);
end;
end;
end;
procedure TIMAPSend.ParseSearch(Value:TStrings);
var
n: integer;
s: string;
begin
ProcessLiterals;
Value.Clear;
for n := 0 to FFullResult.Count - 1 do
begin
s := uppercase(FFullResult[n]);
if Pos('* SEARCH', s) = 1 then
begin
s := Trim(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.Bind(FIPInterface, cAnyPort);
if FSock.LastError = 0 then
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError = 0 then
if FFullSSL then
FSock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
function TIMAPSend.Capability: Boolean;
var
n: Integer;
s, t: string;
begin
Result := False;
FIMAPcap.Clear;
s := IMAPcommand('CAPABILITY');
if s = 'OK' then
begin
ProcessLiterals;
for n := 0 to FFullResult.Count - 1 do
if Pos('* CAPABILITY ', FFullResult[n]) = 1 then
begin
s := Trim(SeparateRight(FFullResult[n], '* CAPABILITY '));
while not (s = '') do
begin
t := Trim(separateleft(s, ' '));
s := Trim(separateright(s, ' '));
if s = t then
s := '';
FIMAPcap.Add(t);
end;
end;
Result := True;
end;
end;
function TIMAPSend.Login: Boolean;
var
s: 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;
if Capability then
begin
if Findcap('IMAP4rev1') = '' then
Exit;
if FAutoTLS and (Findcap('STARTTLS') <> '') then
if StartTLS then
Capability;
end;
Result := AuthLogin;
end;
function TIMAPSend.Logout: Boolean;
begin
Result := IMAPcommand('LOGOUT') = 'OK';
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.ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
begin
Result := IMAPcommand('LIST "' + FromFolder + '" "' + Search +'"') = 'OK';
ParseFolderList(FolderList);
end;
function TIMAPSend.ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
begin
Result := IMAPcommand('LSUB "' + FromFolder + '" *') = 'OK';
ParseFolderList(FolderList);
end;
function TIMAPSend.ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
begin
Result := IMAPcommand('LSUB "' + FromFolder + '" "' + Search +'"') = '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
begin
ProcessLiterals;
for n := 0 to FFullResult.Count - 1 do
begin
s := FFullResult[n];
// s := UpperCase(FFullResult[n]);
if (Pos('* ', s) = 1) and (Pos(FolderName, 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;
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
begin
ProcessLiterals;
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 := Trim(SeparateLeft(t, ')'));
t := Trim(SeparateLeft(t, ' '));
Result := StrToIntDef(t, -1);
Break;
end;
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.AddFlagsMess(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.DelFlagsMess(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';
ProcessLiterals;
for n := 0 to FFullResult.Count - 1 do
begin
s := uppercase(FFullResult[n]);
if (Pos('* ', s) = 1) and (Pos('FLAGS', s) > 0 ) then
begin
s := SeparateRight(s, 'FLAGS');
s := Separateright(s, '(');
Flags := Trim(SeparateLeft(s, ')'));
end;
end;
end;
function TIMAPSend.StartTLS: Boolean;
begin
Result := False;
if FindCap('STARTTLS') <> '' then
begin
if IMAPcommand('STARTTLS') = 'OK' then
begin
Fsock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
end;
//Paul Buskermolen
function TIMAPSend.GetUID(MessID: integer; var UID : Integer): boolean;
var
s, sUid: string;
n: integer;
begin
sUID := '';
s := 'FETCH ' + IntToStr(MessID) + ' UID';
Result := IMAPcommand(s) = 'OK';
ProcessLiterals;
for n := 0 to FFullResult.Count - 1 do
begin
s := uppercase(FFullResult[n]);
if Pos('FETCH (UID', s) >= 1 then
begin
s := Separateright(s, '(UID ');
sUID := Trim(SeparateLeft(s, ')'));
end;
end;
UID := StrToIntDef(sUID, 0);
end;
{==============================================================================}
end.
TransGUI/synapse/source/lib/synaicnv.pas 0000644 0000000 0000000 00000025451 11366572451 017320 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.001.001 |
|==============================================================================|
| Content: ICONV support for Win32, Linux and .NET |
|==============================================================================|
| Copyright (c)2004-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2004-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{:@abstract(LibIconv support)
This unit is Pascal interface to LibIconv library for charset translations.
LibIconv is loaded dynamicly on-demand. If this library is not found in system,
requested LibIconv function just return errorcode.
}
unit synaicnv;
interface
uses
{$IFDEF CIL}
System.Runtime.InteropServices,
System.Text,
{$ENDIF}
synafpc,
{$IFNDEF MSWINDOWS}
{$IFNDEF FPC}
Libc,
{$ENDIF}
SysUtils;
{$ELSE}
Windows;
{$ENDIF}
const
{$IFNDEF MSWINDOWS}
DLLIconvName = 'libiconv.so';
{$ELSE}
DLLIconvName = 'iconv.dll';
{$ENDIF}
type
size_t = Cardinal;
{$IFDEF CIL}
iconv_t = IntPtr;
{$ELSE}
iconv_t = Pointer;
{$ENDIF}
argptr = iconv_t;
var
iconvLibHandle: TLibHandle = 0;
function SynaIconvOpen(const tocode, fromcode: Ansistring): iconv_t;
function SynaIconvOpenTranslit(const tocode, fromcode: Ansistring): iconv_t;
function SynaIconvOpenIgnore(const tocode, fromcode: Ansistring): iconv_t;
function SynaIconv(cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer;
function SynaIconvClose(var cd: iconv_t): integer;
function SynaIconvCtl(cd: iconv_t; request: integer; argument: argptr): integer;
function IsIconvloaded: Boolean;
function InitIconvInterface: Boolean;
function DestroyIconvInterface: Boolean;
const
ICONV_TRIVIALP = 0; // int *argument
ICONV_GET_TRANSLITERATE = 1; // int *argument
ICONV_SET_TRANSLITERATE = 2; // const int *argument
ICONV_GET_DISCARD_ILSEQ = 3; // int *argument
ICONV_SET_DISCARD_ILSEQ = 4; // const int *argument
implementation
uses SyncObjs;
{$IFDEF CIL}
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'libiconv_open')]
function _iconv_open(tocode: string; fromcode: string): iconv_t; external;
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'libiconv')]
function _iconv(cd: iconv_t; var inbuf: IntPtr; var inbytesleft: size_t;
var outbuf: IntPtr; var outbytesleft: size_t): size_t; external;
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'libiconv_close')]
function _iconv_close(cd: iconv_t): integer; external;
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'libiconvctl')]
function _iconvctl(cd: iconv_t; request: integer; argument: argptr): integer; external;
{$ELSE}
type
Ticonv_open = function(tocode: pAnsichar; fromcode: pAnsichar): iconv_t; cdecl;
Ticonv = function(cd: iconv_t; var inbuf: pointer; var inbytesleft: size_t;
var outbuf: pointer; var outbytesleft: size_t): size_t; cdecl;
Ticonv_close = function(cd: iconv_t): integer; cdecl;
Ticonvctl = function(cd: iconv_t; request: integer; argument: argptr): integer; cdecl;
var
_iconv_open: Ticonv_open = nil;
_iconv: Ticonv = nil;
_iconv_close: Ticonv_close = nil;
_iconvctl: Ticonvctl = nil;
{$ENDIF}
var
IconvCS: TCriticalSection;
Iconvloaded: boolean = false;
function SynaIconvOpen (const tocode, fromcode: Ansistring): iconv_t;
begin
{$IFDEF CIL}
try
Result := _iconv_open(tocode, fromcode);
except
on Exception do
Result := iconv_t(-1);
end;
{$ELSE}
if InitIconvInterface and Assigned(_iconv_open) then
Result := _iconv_open(PAnsiChar(tocode), PAnsiChar(fromcode))
else
Result := iconv_t(-1);
{$ENDIF}
end;
function SynaIconvOpenTranslit (const tocode, fromcode: Ansistring): iconv_t;
begin
Result := SynaIconvOpen(tocode + '//IGNORE//TRANSLIT', fromcode);
end;
function SynaIconvOpenIgnore (const tocode, fromcode: Ansistring): iconv_t;
begin
Result := SynaIconvOpen(tocode + '//IGNORE', fromcode);
end;
function SynaIconv (cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer;
var
{$IFDEF CIL}
ib, ob: IntPtr;
ibsave, obsave: IntPtr;
l: integer;
{$ELSE}
ib, ob: Pointer;
{$ENDIF}
ix, ox: size_t;
begin
{$IFDEF CIL}
l := Length(inbuf) * 4;
ibsave := IntPtr.Zero;
obsave := IntPtr.Zero;
try
ibsave := Marshal.StringToHGlobalAnsi(inbuf);
obsave := Marshal.AllocHGlobal(l);
ib := ibsave;
ob := obsave;
ix := Length(inbuf);
ox := l;
_iconv(cd, ib, ix, ob, ox);
Outbuf := Marshal.PtrToStringAnsi(obsave, l);
setlength(Outbuf, l - ox);
Result := Length(inbuf) - ix;
finally
Marshal.FreeCoTaskMem(ibsave);
Marshal.FreeHGlobal(obsave);
end;
{$ELSE}
if InitIconvInterface and Assigned(_iconv) then
begin
setlength(Outbuf, Length(inbuf) * 4);
ib := Pointer(inbuf);
ob := Pointer(Outbuf);
ix := Length(inbuf);
ox := Length(Outbuf);
_iconv(cd, ib, ix, ob, ox);
setlength(Outbuf, cardinal(Length(Outbuf)) - ox);
Result := Cardinal(Length(inbuf)) - ix;
end
else
begin
Outbuf := '';
Result := 0;
end;
{$ENDIF}
end;
function SynaIconvClose(var cd: iconv_t): integer;
begin
if cd = iconv_t(-1) then
begin
Result := 0;
Exit;
end;
{$IFDEF CIL}
try;
Result := _iconv_close(cd)
except
on Exception do
Result := -1;
end;
cd := iconv_t(-1);
{$ELSE}
if InitIconvInterface and Assigned(_iconv_close) then
Result := _iconv_close(cd)
else
Result := -1;
cd := iconv_t(-1);
{$ENDIF}
end;
function SynaIconvCtl (cd: iconv_t; request: integer; argument: argptr): integer;
begin
{$IFDEF CIL}
Result := _iconvctl(cd, request, argument)
{$ELSE}
if InitIconvInterface and Assigned(_iconvctl) then
Result := _iconvctl(cd, request, argument)
else
Result := 0;
{$ENDIF}
end;
function InitIconvInterface: Boolean;
begin
IconvCS.Enter;
try
if not IsIconvloaded then
begin
{$IFDEF CIL}
IconvLibHandle := 1;
{$ELSE}
IconvLibHandle := LoadLibrary(PChar(DLLIconvName));
{$ENDIF}
if (IconvLibHandle <> 0) then
begin
{$IFNDEF CIL}
_iconv_open := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_open')));
_iconv := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv')));
_iconv_close := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_close')));
_iconvctl := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconvctl')));
{$ENDIF}
Result := True;
Iconvloaded := True;
end
else
begin
//load failed!
if IconvLibHandle <> 0 then
begin
{$IFNDEF CIL}
FreeLibrary(IconvLibHandle);
{$ENDIF}
IconvLibHandle := 0;
end;
Result := False;
end;
end
else
//loaded before...
Result := true;
finally
IconvCS.Leave;
end;
end;
function DestroyIconvInterface: Boolean;
begin
IconvCS.Enter;
try
Iconvloaded := false;
if IconvLibHandle <> 0 then
begin
{$IFNDEF CIL}
FreeLibrary(IconvLibHandle);
{$ENDIF}
IconvLibHandle := 0;
end;
{$IFNDEF CIL}
_iconv_open := nil;
_iconv := nil;
_iconv_close := nil;
_iconvctl := nil;
{$ENDIF}
finally
IconvCS.Leave;
end;
Result := True;
end;
function IsIconvloaded: Boolean;
begin
Result := IconvLoaded;
end;
initialization
begin
IconvCS:= TCriticalSection.Create;
end;
finalization
begin
{$IFNDEF CIL}
DestroyIconvInterface;
{$ENDIF}
IconvCS.Free;
end;
end.
TransGUI/synapse/source/lib/synadbg.pas 0000644 0000000 0000000 00000013447 11366572451 017117 0 ustar root root {==============================================================================|
| Project : Ararat Synapse | 001.001.001 |
|==============================================================================|
| Content: Socket debug tools |
|==============================================================================|
| Copyright (c)2008-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2008-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(Socket debug tools)
Routines for help with debugging of events on the Sockets.
}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit synadbg;
interface
uses
blcksock, synsock, synautil, classes, sysutils;
type
TSynaDebug = class(TObject)
class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
end;
procedure AppendToLog(const value: Ansistring);
var
LogFile: string;
implementation
procedure AppendToLog(const value: Ansistring);
var
st: TFileStream;
s: string;
h, m, ss, ms: word;
dt: Tdatetime;
begin
if fileexists(LogFile) then
st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite)
else
st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite);
try
st.Position := st.Size;
dt := now;
decodetime(dt, h, m, ss, ms);
s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value;
WriteStrToStream(st, s);
finally
st.free;
end;
end;
class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
var
s: string;
begin
case Reason of
HR_ResolvingBegin:
s := 'HR_ResolvingBegin';
HR_ResolvingEnd:
s := 'HR_ResolvingEnd';
HR_SocketCreate:
s := 'HR_SocketCreate';
HR_SocketClose:
s := 'HR_SocketClose';
HR_Bind:
s := 'HR_Bind';
HR_Connect:
s := 'HR_Connect';
HR_CanRead:
s := 'HR_CanRead';
HR_CanWrite:
s := 'HR_CanWrite';
HR_Listen:
s := 'HR_Listen';
HR_Accept:
s := 'HR_Accept';
HR_ReadCount:
s := 'HR_ReadCount';
HR_WriteCount:
s := 'HR_WriteCount';
HR_Wait:
s := 'HR_Wait';
HR_Error:
s := 'HR_Error';
else
s := '-unknown-';
end;
s := inttohex(integer(Sender), 8) + s + ': ' + value + CRLF;
AppendToLog(s);
end;
class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
var
s, d: Ansistring;
begin
setlength(s, len);
move(Buffer^, pointer(s)^, len);
if writing then
d := '-> '
else
d := '<- ';
s :=inttohex(integer(Sender), 8) + d + s + CRLF;
AppendToLog(s);
end;
initialization
begin
Logfile := changefileext(paramstr(0), '.slog');
end;
end.
TransGUI/rpc.pas 0000644 0000000 0000000 00000056722 12261763702 012523 0 ustar root root {*************************************************************************************
This file is part of Transmission Remote GUI.
Copyright (c) 2008-2014 by Yury Sidorov.
Transmission Remote GUI is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
Transmission Remote GUI is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Transmission Remote GUI; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*************************************************************************************}
unit rpc;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, httpsend, syncobjs, fpjson, jsonparser, ssl_openssl;
resourcestring
sTransmissionAt = 'Transmission%s at %s:%s';
const
DefaultRpcPath = '/transmission/rpc';
type
TAdvInfoType = (aiNone, aiGeneral, aiFiles, aiPeers, aiTrackers, aiStats);
TRefreshTypes = (rtTorrents, rtDetails, rtSession);
TRefreshType = set of TRefreshTypes;
TRpc = class;
{ TRpcThread }
TRpcThread = class(TThread)
private
ResultData: TJSONData;
FRpc: TRpc;
function GetAdvInfo: TAdvInfoType;
function GetCurTorrentId: cardinal;
function GetRefreshInterval: TDateTime;
function GetStatus: string;
procedure SetStatus(const AValue: string);
function GetTorrents: boolean;
procedure GetPeers(TorrentId: integer);
procedure GetFiles(TorrentId: integer);
procedure GetTrackers(TorrentId: integer);
procedure GetStats;
procedure GetInfo(TorrentId: integer);
procedure GetSessionInfo;
procedure DoFillTorrentsList;
procedure DoFillPeersList;
procedure DoFillFilesList;
procedure DoFillInfo;
procedure DoFillTrackersList;
procedure DoFillStats;
procedure DoFillSessionInfo;
procedure NotifyCheckStatus;
procedure CheckStatusHandler(Data: PtrInt);
protected
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
property Status: string read GetStatus write SetStatus;
property RefreshInterval: TDateTime read GetRefreshInterval;
property CurTorrentId: cardinal read GetCurTorrentId;
property AdvInfo: TAdvInfoType read GetAdvInfo;
end;
TRpc = class
private
FLock: TCriticalSection;
FStatus: string;
FInfoStatus: string;
FConnected: boolean;
FTorrentFields: string;
FRPCVersion: integer;
XTorrentSession: string;
FMainThreadId: TThreadID;
FRpcPath: string;
function GetConnected: boolean;
function GetConnecting: boolean;
function GetInfoStatus: string;
function GetStatus: string;
function GetTorrentFields: string;
procedure SetInfoStatus(const AValue: string);
procedure SetStatus(const AValue: string);
procedure SetTorrentFields(const AValue: string);
procedure CreateHttp;
public
Http: THTTPSend;
HttpLock: TCriticalSection;
RpcThread: TRpcThread;
Url: string;
RefreshInterval: TDateTime;
CurTorrentId: cardinal;
AdvInfo: TAdvInfoType;
RefreshNow: TRefreshType;
RequestFullInfo: boolean;
ReconnectAllowed: boolean;
RequestStartTime: TDateTime;
constructor Create;
destructor Destroy; override;
procedure InitSSL;
procedure Lock;
procedure Unlock;
procedure Connect;
procedure Disconnect;
function SendRequest(req: TJSONObject; ReturnArguments: boolean = True; ATimeOut: integer = -1): TJSONObject;
function RequestInfo(TorrentId: integer; const Fields: array of const; const ExtraFields: array of string): TJSONObject;
function RequestInfo(TorrentId: integer; const Fields: array of const): TJSONObject;
property Status: string read GetStatus write SetStatus;
property InfoStatus: string read GetInfoStatus write SetInfoStatus;
property Connected: boolean read GetConnected;
property Connecting: boolean read GetConnecting;
property TorrentFields: string read GetTorrentFields write SetTorrentFields;
property RPCVersion: integer read FRPCVersion;
property RpcPath: string read FRpcPath write FRpcPath;
end;
var
RemotePathDelimiter: char = '/';
implementation
uses Main, ssl_openssl_lib, synafpc, blcksock;
{ TRpcThread }
procedure TRpcThread.Execute;
var
t, tt: TDateTime;
i: integer;
ai: TAdvInfoType;
begin
try
GetSessionInfo;
NotifyCheckStatus;
if not FRpc.FConnected then
Terminate;
t:=Now - 1;
tt:=Now;
while not Terminated do begin
if Now - t >= RefreshInterval then begin
FRpc.RefreshNow:=FRpc.RefreshNow + [rtTorrents, rtDetails];
t:=Now;
end;
if Now - tt >= RefreshInterval*5 then begin
Include(FRpc.RefreshNow, rtSession);
tt:=Now;
end;
if Status = '' then
if rtTorrents in FRpc.RefreshNow then begin
GetTorrents;
Exclude(FRpc.RefreshNow, rtTorrents);
t:=Now;
end
else
if rtDetails in FRpc.RefreshNow then begin
i:=CurTorrentId;
ai:=AdvInfo;
if i <> 0 then begin
case ai of
aiGeneral:
GetInfo(i);
aiPeers:
GetPeers(i);
aiFiles:
GetFiles(i);
aiTrackers:
GetTrackers(i);
end;
end;
case ai of
aiStats:
GetStats;
end;
if (i = CurTorrentId) and (ai = AdvInfo) then
Exclude(FRpc.RefreshNow, rtDetails);
end
else
if rtSession in FRpc.RefreshNow then begin
GetSessionInfo;
Exclude(FRpc.RefreshNow, rtSession);
end;
if Status <> '' then begin
NotifyCheckStatus;
Sleep(100);
end;
if FRpc.RefreshNow = [] then
Sleep(50);
end;
except
Status:=Exception(ExceptObject).Message;
FRpc.RpcThread:=nil;
NotifyCheckStatus;
end;
FRpc.RpcThread:=nil;
FRpc.FConnected:=False;
FRpc.FRPCVersion:=0;
Sleep(20);
end;
constructor TRpcThread.Create;
begin
inherited Create(True);
end;
destructor TRpcThread.Destroy;
begin
inherited Destroy;
end;
procedure TRpcThread.SetStatus(const AValue: string);
begin
FRpc.Status:=AValue;
end;
procedure TRpcThread.DoFillTorrentsList;
begin
MainForm.FillTorrentsList(ResultData as TJSONArray);
end;
procedure TRpcThread.DoFillPeersList;
begin
MainForm.FillPeersList(ResultData as TJSONArray);
end;
procedure TRpcThread.DoFillFilesList;
var
t: TJSONObject;
dir: widestring;
begin
if ResultData = nil then begin
MainForm.ClearDetailsInfo;
exit;
end;
t:=ResultData as TJSONObject;
if RpcObj.RPCVersion >= 4 then
dir:=t.Strings['downloadDir']
else
dir:='';
MainForm.FillFilesList(t.Integers['id'], t.Arrays['files'], t.Arrays['priorities'], t.Arrays['wanted'], dir);
end;
procedure TRpcThread.DoFillInfo;
begin
MainForm.FillGeneralInfo(ResultData as TJSONObject);
end;
procedure TRpcThread.DoFillTrackersList;
begin
MainForm.FillTrackersList(ResultData as TJSONObject);
end;
procedure TRpcThread.DoFillStats;
begin
MainForm.FillStatistics(ResultData as TJSONObject);
end;
procedure TRpcThread.DoFillSessionInfo;
begin
MainForm.FillSessionInfo(ResultData as TJSONObject);
end;
procedure TRpcThread.NotifyCheckStatus;
begin
if not Terminated then
Application.QueueAsyncCall(@CheckStatusHandler, 0);
end;
procedure TRpcThread.CheckStatusHandler(Data: PtrInt);
begin
if csDestroying in MainForm.ComponentState then exit;
MainForm.CheckStatus;
end;
procedure TRpcThread.GetSessionInfo;
var
req, args, args2: TJSONObject;
s: string;
begin
req:=TJSONObject.Create;
try
req.Add('method', 'session-get');
args:=FRpc.SendRequest(req);
if args <> nil then
try
FRpc.FConnected:=True;
if args.IndexOfName('rpc-version') >= 0 then
FRpc.FRPCVersion := args.Integers['rpc-version']
else
FRpc.FRPCVersion := 0;
if args.IndexOfName('version') >= 0 then
s:=' ' + args.Strings['version']
else
s:='';
FRpc.InfoStatus:=Format(sTransmissionAt, [s, FRpc.Http.TargetHost, FRpc.Http.TargetPort]);
if FRpc.RPCVersion >= 15 then begin
// Requesting free space in download dir
req.Free;
req:=TJSONObject.Create;
req.Add('method', 'free-space');
args2:=TJSONObject.Create;
try
args2.Add('path', args.Strings['download-dir']);
req.Add('arguments', args2);
args2:=FRpc.SendRequest(req);
if args2 <> nil then
args.Floats['download-dir-free-space']:=args2.Floats['size-bytes']
else begin
args.Floats['download-dir-free-space']:=-1;
FRpc.Status:='';
end;
finally
args2.Free;
end;
end;
ResultData:=args;
if not Terminated then
Synchronize(@DoFillSessionInfo);
finally
args.Free;
end
else
ASSERT(FRpc.Status <> '');
finally
req.Free;
end;
end;
function TRpcThread.GetTorrents: boolean;
var
args: TJSONObject;
ExtraFields: array of string;
sl: TStringList;
i: integer;
begin
Result:=False;
sl:=TStringList.Create;
try
FRpc.Lock;
try
sl.CommaText:=FRpc.FTorrentFields;
finally
FRpc.Unlock;
end;
if FRpc.RPCVersion < 7 then begin
i:=sl.IndexOf('trackers');
if FRpc.RequestFullInfo then begin
if i < 0 then
sl.Add('trackers');
end
else
if i >= 0 then
sl.Delete(i);
end;
i:=sl.IndexOf('downloadDir');
if FRpc.RequestFullInfo then begin
if i < 0 then
sl.Add('downloadDir');
end
else
if i >= 0 then
sl.Delete(i);
SetLength(ExtraFields, sl.Count);
for i:=0 to sl.Count - 1 do
ExtraFields[i]:=sl[i];
finally
sl.Free;
end;
args:=FRpc.RequestInfo(0, ['id', 'name', 'status', 'errorString', 'announceResponse', 'recheckProgress',
'sizeWhenDone', 'leftUntilDone', 'rateDownload', 'rateUpload', 'trackerStats',
'metadataPercentComplete'], ExtraFields);
try
if (args <> nil) and not Terminated then begin
FRpc.RequestFullInfo:=False;
ResultData:=args.Arrays['torrents'];
Synchronize(@DoFillTorrentsList);
Result:=True;
end;
finally
args.Free;
end;
end;
procedure TRpcThread.GetPeers(TorrentId: integer);
var
args: TJSONObject;
t: TJSONArray;
begin
args:=FRpc.RequestInfo(TorrentId, ['peers']);
try
if args <> nil then begin
t:=args.Arrays['torrents'];
if t.Count > 0 then
ResultData:=t.Objects[0].Arrays['peers']
else
ResultData:=nil;
if not Terminated then
Synchronize(@DoFillPeersList);
end;
finally
args.Free;
end;
end;
procedure TRpcThread.GetFiles(TorrentId: integer);
var
args: TJSONObject;
t: TJSONArray;
begin
args:=FRpc.RequestInfo(TorrentId, ['id', 'files','priorities','wanted','downloadDir']);
try
if args <> nil then begin
t:=args.Arrays['torrents'];
if t.Count > 0 then
ResultData:=t.Objects[0]
else
ResultData:=nil;
if not Terminated then
Synchronize(@DoFillFilesList);
end;
finally
args.Free;
end;
end;
procedure TRpcThread.GetTrackers(TorrentId: integer);
var
args: TJSONObject;
t: TJSONArray;
begin
args:=FRpc.RequestInfo(TorrentId, ['id','trackers','trackerStats', 'nextAnnounceTime']);
try
if args <> nil then begin
t:=args.Arrays['torrents'];
if t.Count > 0 then
ResultData:=t.Objects[0]
else
ResultData:=nil;
if not Terminated then
Synchronize(@DoFillTrackersList);
end;
finally
args.Free;
end;
end;
procedure TRpcThread.GetStats;
var
req, args: TJSONObject;
begin
req:=TJSONObject.Create;
try
req.Add('method', 'session-stats');
args:=FRpc.SendRequest(req);
if args <> nil then
try
ResultData:=args;
if not Terminated then
Synchronize(@DoFillStats);
finally
args.Free;
end;
finally
req.Free;
end;
end;
procedure TRpcThread.GetInfo(TorrentId: integer);
var
args: TJSONObject;
t: TJSONArray;
begin
args:=FRpc.RequestInfo(TorrentId, ['totalSize', 'sizeWhenDone', 'leftUntilDone', 'pieceCount', 'pieceSize', 'haveValid',
'hashString', 'comment', 'downloadedEver', 'uploadedEver', 'corruptEver', 'errorString',
'announceResponse', 'downloadLimit', 'downloadLimitMode', 'uploadLimit', 'uploadLimitMode',
'maxConnectedPeers', 'nextAnnounceTime', 'dateCreated', 'creator', 'eta', 'peersSendingToUs',
'seeders','peersGettingFromUs','leechers', 'uploadRatio', 'addedDate', 'doneDate',
'activityDate', 'downloadLimited', 'uploadLimited', 'downloadDir', 'id', 'pieces',
'trackerStats', 'secondsDownloading', 'secondsSeeding']);
try
if args <> nil then begin
t:=args.Arrays['torrents'];
if t.Count > 0 then
ResultData:=t.Objects[0]
else
ResultData:=nil;
if not Terminated then
Synchronize(@DoFillInfo);
end;
finally
args.Free;
end;
end;
function TRpcThread.GetAdvInfo: TAdvInfoType;
begin
FRpc.Lock;
try
Result:=FRpc.AdvInfo;
finally
FRpc.Unlock;
end;
end;
function TRpcThread.GetCurTorrentId: cardinal;
begin
FRpc.Lock;
try
Result:=FRpc.CurTorrentId;
finally
FRpc.Unlock;
end;
end;
function TRpcThread.GetRefreshInterval: TDateTime;
begin
FRpc.Lock;
try
Result:=FRpc.RefreshInterval;
finally
FRpc.Unlock;
end;
end;
function TRpcThread.GetStatus: string;
begin
Result:=FRpc.Status;
end;
{ TRpc }
constructor TRpc.Create;
begin
inherited;
FMainThreadId:=GetCurrentThreadId;
FLock:=TCriticalSection.Create;
HttpLock:=TCriticalSection.Create;
RefreshNow:=[];
CreateHttp;
end;
destructor TRpc.Destroy;
begin
Http.Free;
HttpLock.Free;
FLock.Free;
inherited Destroy;
end;
procedure TRpc.InitSSL;
{$ifdef unix}
{$ifndef darwin}
procedure CheckOpenSSL;
const
OpenSSLVersions: array[1..2] of string =
('0.9.8', '1.0.0');
var
hLib1, hLib2: TLibHandle;
i: integer;
begin
for i:=Low(OpenSSLVersions) to High(OpenSSLVersions) do begin
hlib1:=LoadLibrary(PChar('libssl.so.' + OpenSSLVersions[i]));
hlib2:=LoadLibrary(PChar('libcrypto.so.' + OpenSSLVersions[i]));
if hLib2 <> 0 then
FreeLibrary(hLib2);
if hLib1 <> 0 then
FreeLibrary(hLib1);
if (hLib1 <> 0) and (hLib2 <> 0) then begin
DLLSSLName:='libssl.so.' + OpenSSLVersions[i];
DLLUtilName:='libcrypto.so.' + OpenSSLVersions[i];
break;
end;
end;
end;
{$endif darwin}
{$endif unix}
begin
if IsSSLloaded then exit;
{$ifdef unix}
{$ifndef darwin}
CheckOpenSSL;
{$endif darwin}
{$endif unix}
if InitSSLInterface then
SSLImplementation := TSSLOpenSSL;
CreateHttp;
end;
function TRpc.SendRequest(req: TJSONObject; ReturnArguments: boolean; ATimeOut: integer): TJSONObject;
var
obj: TJSONData;
res: TJSONObject;
jp: TJSONParser;
s: string;
i, j, OldTimeOut, RetryCnt: integer;
locked, r: boolean;
begin
if FRpcPath = '' then
FRpcPath:=DefaultRpcPath;
Status:='';
Result:=nil;
RetryCnt:=2;
i:=0;
repeat
Inc(i);
HttpLock.Enter;
locked:=True;
try
OldTimeOut:=Http.Timeout;
RequestStartTime:=Now;
Http.Document.Clear;
s:=req.AsJSON;
Http.Document.Write(PChar(s)^, Length(s));
s:='';
Http.Headers.Clear;
if XTorrentSession <> '' then
Http.Headers.Add(XTorrentSession);
if ATimeOut >= 0 then
Http.Timeout:=ATimeOut;
try
r:=Http.HTTPMethod('POST', Url + FRpcPath);
finally
Http.Timeout:=OldTimeOut;
end;
if not r then begin
if FMainThreadId <> GetCurrentThreadId then
ReconnectAllowed:=True;
Status:=Http.Sock.LastErrorDesc;
break;
end
else begin
if Http.ResultCode = 409 then begin
XTorrentSession:='';
for j:=0 to Http.Headers.Count - 1 do
if Pos('x-transmission-session-id:', AnsiLowerCase(Http.Headers[j])) > 0 then begin
XTorrentSession:=Http.Headers[j];
break;
end;
if XTorrentSession <> '' then begin
if i = RetryCnt then begin
if FMainThreadId <> GetCurrentThreadId then
ReconnectAllowed:=True;
Status:='Session ID error.';
end;
continue;
end;
end;
if Http.ResultCode = 301 then begin
s:=Trim(Http.Headers.Values['Location']);
if (s <> '') and (i = 1) then begin
j:=Length(s);
if Copy(s, j - 4, MaxInt) = '/web/' then
SetLength(s, j - 4)
else
if Copy(s, j - 3, MaxInt) = '/web' then
SetLength(s, j - 3);
FRpcPath:=s + 'rpc';
Inc(RetryCnt);
continue;
end;
end;
if Http.ResultCode <> 200 then begin
if Http.Headers.Count > 0 then begin
SetString(s, Http.Document.Memory, Http.Document.Size);
j:=Pos('', LowerCase(s));
if j > 0 then
System.Delete(s, 1, j - 1);
s:=StringReplace(s, #13#10, '', [rfReplaceAll]);
s:=StringReplace(s, #13, '', [rfReplaceAll]);
s:=StringReplace(s, #10, '', [rfReplaceAll]);
s:=StringReplace(s, #9, ' ', [rfReplaceAll]);
s:=StringReplace(s, '"', '"', [rfReplaceAll, rfIgnoreCase]);
s:=StringReplace(s, '
', LineEnding, [rfReplaceAll, rfIgnoreCase]);
s:=StringReplace(s, '
', LineEnding, [rfReplaceAll, rfIgnoreCase]);
s:=StringReplace(s, '', LineEnding, [rfReplaceAll, rfIgnoreCase]);
s:=StringReplace(s, '', LineEnding+'* ', [rfReplaceAll, rfIgnoreCase]);
j:=1;
while j <= Length(s) do begin
if s[j] = '<' then begin
while (j <= Length(s)) and (s[j] <> '>') do
System.Delete(s, j, 1);
System.Delete(s, j, 1);
end
else
Inc(j);
end;
while Pos(' ', s) > 0 do
s:=StringReplace(s, ' ', ' ', [rfReplaceAll]);
while Pos(LineEnding + ' ', s) > 0 do
s:=StringReplace(s, LineEnding + ' ', LineEnding, [rfReplaceAll]);
s:=Trim(s);
end
else
s:='';
if s = '' then begin
s:=Http.ResultString;
if s = '' then
if Http.ResultCode = 0 then
s:='Invalid server response.'
else
s:=Format('HTTP error: %d', [Http.ResultCode]);
end;
Status:=s;
break;
end;
Http.Document.Position:=0;
jp:=TJSONParser.Create(Http.Document);
HttpLock.Leave;
locked:=False;
RequestStartTime:=0;
try
try
obj:=jp.Parse;
Http.Document.Clear;
finally
jp.Free;
end;
except
on E: Exception do
begin
Status:=e.Message;
break;
end;
end;
try
if obj is TJSONObject then begin
res:=obj as TJSONObject;
s:=res.Strings['result'];
if AnsiCompareText(s, 'success') <> 0 then begin
if Trim(s) = '' then
s:='Unknown error.';
Status:=s;
end
else begin
if ReturnArguments then begin
Result:=res.Objects['arguments'];
if Result = nil then
Status:='Arguments object not found.'
else begin
res.Extract(Result);
FreeAndNil(obj);
end;
end
else
Result:=res;
if Result <> nil then
obj:=nil;
end;
break;
end
else begin
Status:='Invalid server response.';
break;
end;
finally
obj.Free;
end;
end;
finally
RequestStartTime:=0;
if locked then
HttpLock.Leave;
end;
until i >= RetryCnt;
end;
function TRpc.RequestInfo(TorrentId: integer; const Fields: array of const; const ExtraFields: array of string): TJSONObject;
var
req, args: TJSONObject;
_fields: TJSONArray;
i: integer;
begin
Result:=nil;
req:=TJSONObject.Create;
try
req.Add('method', 'torrent-get');
args:=TJSONObject.Create;
if TorrentId <> 0 then
args.Add('ids', TJSONArray.Create([TorrentId]));
_fields:=TJSONArray.Create(Fields);
for i:=Low(ExtraFields) to High(ExtraFields) do
_fields.Add(ExtraFields[i]);
args.Add('fields', _fields);
req.Add('arguments', args);
Result:=SendRequest(req);
finally
req.Free;
end;
end;
function TRpc.RequestInfo(TorrentId: integer; const Fields: array of const): TJSONObject;
begin
Result:=RequestInfo(TorrentId, Fields, []);
end;
function TRpc.GetStatus: string;
begin
Lock;
try
Result:=FStatus;
UniqueString(Result);
finally
Unlock;
end;
end;
function TRpc.GetTorrentFields: string;
begin
Lock;
try
Result:=FTorrentFields;
UniqueString(Result);
finally
Unlock;
end;
end;
procedure TRpc.SetInfoStatus(const AValue: string);
begin
Lock;
try
FInfoStatus:=AValue;
UniqueString(FStatus);
finally
Unlock;
end;
end;
function TRpc.GetConnected: boolean;
begin
Result:=Assigned(RpcThread) and FConnected;
end;
function TRpc.GetConnecting: boolean;
begin
Result:=not FConnected and Assigned(RpcThread);
end;
function TRpc.GetInfoStatus: string;
begin
Lock;
try
Result:=FInfoStatus;
UniqueString(Result);
finally
Unlock;
end;
end;
procedure TRpc.SetStatus(const AValue: string);
begin
Lock;
try
FStatus:=AValue;
UniqueString(FStatus);
finally
Unlock;
end;
end;
procedure TRpc.SetTorrentFields(const AValue: string);
begin
Lock;
try
FTorrentFields:=AValue;
UniqueString(FTorrentFields);
finally
Unlock;
end;
end;
procedure TRpc.CreateHttp;
begin
Http.Free;
Http:=THTTPSend.Create;
Http.Protocol:='1.1';
Http.Timeout:=30000;
Http.Headers.NameValueSeparator:=':';
end;
procedure TRpc.Lock;
begin
FLock.Enter;
end;
procedure TRpc.Unlock;
begin
FLock.Leave;
end;
procedure TRpc.Connect;
begin
CurTorrentId:=0;
XTorrentSession:='';
RequestFullInfo:=True;
ReconnectAllowed:=False;
RefreshNow:=[];
RpcThread:=TRpcThread.Create;
with RpcThread do begin
FreeOnTerminate:=True;
FRpc:=Self;
Suspended:=False;
end;
end;
procedure TRpc.Disconnect;
begin
if Assigned(RpcThread) then begin
RpcThread.Terminate;
while Assigned(RpcThread) do begin
Application.ProcessMessages;
try
Http.Sock.CloseSocket;
except
end;
Sleep(20);
end;
end;
Status:='';
RequestStartTime:=0;
FRpcPath:='';
end;
end.
TransGUI/vargrid.pas 0000644 0000000 0000000 00000122731 12261763702 013367 0 ustar root root {*************************************************************************************
This file is part of Transmission Remote GUI.
Copyright (c) 2008-2014 by Yury Sidorov.
Transmission Remote GUI is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
Transmission Remote GUI is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Transmission Remote GUI; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*************************************************************************************}
unit VarGrid;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Grids, VarList, Graphics, Controls, LMessages, Forms, StdCtrls, LCLType, ExtCtrls;
type
TVarGrid = class;
TCellOption = (coDrawCheckBox, coDrawTreeButton);
TCellOptions = set of TCellOption;
TCellAttributes = record
Text: string;
ImageIndex: integer;
Indent: integer;
Options: TCellOptions;
State: TCheckBoxState;
Expanded: boolean;
end;
TOnCellAttributes = procedure (Sender: TVarGrid; ACol, ARow, ADataCol: integer; AState: TGridDrawState; var CellAttribs: TCellAttributes) of object;
TOnDrawCellEvent = procedure (Sender: TVarGrid; ACol, ARow, ADataCol: integer; AState: TGridDrawState; const R: TRect; var ADefaultDrawing: boolean) of object;
TOnSortColumnEvent = procedure (Sender: TVarGrid; var ASortCol: integer) of object;
TCellNotifyEvent = procedure (Sender: TVarGrid; ACol, ARow, ADataCol: integer) of object;
TOnQuickSearch = procedure (Sender: TVarGrid; var SearchText: string; var ARow: integer) of object;
{ TVarGridStringEditor }
TVarGridStringEditor = class(TStringCellEditor)
protected
procedure msg_SetGrid(var Msg: TGridMessage); message GM_SETGRID;
procedure msg_SetBounds(var Msg: TGridMessage); message GM_SETBOUNDS;
end;
{ TVarGrid }
TVarGrid = class(TCustomDrawGrid)
private
FFirstVisibleColumn: integer;
FHideSelection: boolean;
FImages: TImageList;
FItems: TVarList;
FItemsChanging: boolean;
FColumnsMap: array of integer;
FMultiSelect: boolean;
FOnAfterSort: TNotifyEvent;
FOnCellAttributes: TOnCellAttributes;
FOnCheckBoxClick: TCellNotifyEvent;
FOnDrawCell: TOnDrawCellEvent;
FOnEditorHide: TNotifyEvent;
FOnEditorShow: TNotifyEvent;
FOnQuickSearch: TOnQuickSearch;
FOnTreeButtonClick: TCellNotifyEvent;
FSelCount: integer;
FAnchor: integer;
FSortColumn: integer;
FOnSortColumn: TOnSortColumnEvent;
FRow: integer;
FHintCell: TPoint;
FCurSearch: string;
FSearchTimer: TTimer;
FOldOpt: TGridOptions;
FNoDblClick: boolean;
FStrEditor: TVarGridStringEditor;
function GetRow: integer;
function GetRowSelected(RowIndex: integer): boolean;
function GetRowVisible(RowIndex: integer): boolean;
function GetSortOrder: TSortOrder;
procedure ItemsChanged(Sender: TObject);
procedure SetHideSelection(const AValue: boolean);
procedure SetRow(const AValue: integer);
procedure SetRowSelected(RowIndex: integer; const AValue: boolean);
procedure SetRowVisible(RowIndex: integer; const AValue: boolean);
procedure SetSortColumn(const AValue: integer);
procedure SetSortOrder(const AValue: TSortOrder);
procedure UpdateColumnsMap;
procedure UpdateSelCount;
procedure SelectRange(OldRow, NewRow: integer);
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
function CellNeedsCheckboxBitmaps(const aCol,aRow: Integer): boolean;
procedure DrawCellCheckboxBitmaps(const aCol,aRow: Integer; const aRect: TRect);
function FindRow(const SearchStr: string; StartRow: integer): integer;
procedure DoSearchTimer(Sender: TObject);
protected
procedure SizeChanged(OldColCount, OldRowCount: Integer); override;
procedure DrawCell(aCol,aRow: Integer; aRect: TRect; aState:TGridDrawState); override;
procedure ColRowMoved(IsColumn: Boolean; FromIndex,ToIndex: Integer); override;
procedure PrepareCanvas(aCol,aRow: Integer; aState:TGridDrawState); override;
procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
procedure MouseMove(Shift: TShiftState; X,Y: Integer);override;
procedure KeyDown(var Key : Word; Shift : TShiftState); override;
procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
procedure DoOnCellAttributes(ACol, ARow, ADataCol: integer; AState: TGridDrawState; var CellAttribs: TCellAttributes);
procedure HeaderClick(IsColumn: Boolean; index: Integer); override;
procedure AutoAdjustColumn(aCol: Integer); override;
procedure VisualChange; override;
procedure DrawColumnText(aCol,aRow: Integer; aRect: TRect; aState:TGridDrawState); override;
procedure DblClick; override;
procedure Click; override;
procedure GetCheckBoxState(const aCol, aRow:Integer; var aState:TCheckboxState); override;
procedure SetCheckboxState(const aCol, aRow:Integer; const aState: TCheckboxState); override;
procedure SetupCell(ACol, ARow: integer; AState: TGridDrawState; out CellAttribs: TCellAttributes);
procedure DoOnCheckBoxClick(ACol, ARow: integer);
procedure DoOnTreeButtonClick(ACol, ARow: integer);
function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;
procedure DrawRow(aRow: Integer); override;
function GetCells(ACol, ARow: Integer): string; override;
function GetEditText(ACol, ARow: Longint): string; override;
procedure SetEditText(ACol, ARow: Longint; const Value: string); override;
procedure DoEditorShow; override;
procedure DoEditorHide; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function EditorByStyle(Style: TColumnButtonStyle): TWinControl; override;
procedure RemoveSelection;
procedure SelectAll;
procedure Sort; reintroduce;
function ColToDataCol(ACol: integer): integer;
function DataColToCol(ADataCol: integer): integer;
procedure EnsureSelectionVisible;
procedure EnsureRowVisible(ARow: integer);
procedure BeginUpdate; reintroduce;
procedure EndUpdate(aRefresh: boolean = true); reintroduce;
procedure EditCell(ACol, ARow: integer);
property Items: TVarList read FItems;
property RowSelected[RowIndex: integer]: boolean read GetRowSelected write SetRowSelected;
property RowVisible[RowIndex: integer]: boolean read GetRowVisible write SetRowVisible;
property SelCount: integer read FSelCount;
property Row: integer read GetRow write SetRow;
property FirstVisibleColumn: integer read FFirstVisibleColumn;
published
property Align;
property AlternateColor;
property Anchors;
property BorderSpacing;
property BorderStyle;
property Color;
property Columns;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property FixedCols;
property FixedRows;
property Font;
property GridLineWidth;
property Options;
property ParentColor default false;
property ParentFont;
property ParentShowHint default false;
property PopupMenu;
property RowCount;
property ScrollBars;
property ShowHint default True;
property TabOrder;
property TabStop;
property TitleFont;
property TitleImageList;
property TitleStyle default tsNative;
property Visible;
property OnClick;
property OnDblClick;
property OnEnter;
property OnExit;
property OnHeaderClick;
property OnHeaderSized;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnContextPopup;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnStartDock;
property OnStartDrag;
property OnUTF8KeyPress;
property OnResize;
property OnGetEditText;
property OnSetEditText;
property Images: TImageList read FImages write FImages;
property MultiSelect: boolean read FMultiSelect write FMultiSelect default False;
property SortColumn: integer read FSortColumn write SetSortColumn default -1;
property SortOrder: TSortOrder read GetSortOrder write SetSortOrder default soAscending;
property HideSelection: boolean read FHideSelection write SetHideSelection default False;
property OnCellAttributes: TOnCellAttributes read FOnCellAttributes write FOnCellAttributes;
property OnDrawCell: TOnDrawCellEvent read FOnDrawCell write FOnDrawCell;
property OnSortColumn: TOnSortColumnEvent read FOnSortColumn write FOnSortColumn;
property OnAfterSort: TNotifyEvent read FOnAfterSort write FOnAfterSort;
property OnCheckBoxClick: TCellNotifyEvent read FOnCheckBoxClick write FOnCheckBoxClick;
property OnTreeButtonClick: TCellNotifyEvent read FOnTreeButtonClick write FOnTreeButtonClick;
property OnQuickSearch: TOnQuickSearch read FOnQuickSearch write FOnQuickSearch;
property OnEditorShow: TNotifyEvent read FOnEditorShow write FOnEditorShow;
property OnEditorHide: TNotifyEvent read FOnEditorHide write FOnEditorHide;
end;
procedure Register;
implementation
uses Variants, Math, GraphType, lclintf, Themes, types, lclproc
{$ifdef LCLcarbon} , carbonproc {$endif LCLcarbon};
const
roSelected = 1;
roCurRow = 2;
procedure Register;
begin
RegisterComponents('TransGUI', [TVarGrid]);
end;
{ TVarGridStringEditor }
procedure TVarGridStringEditor.msg_SetGrid(var Msg: TGridMessage);
begin
inherited;
Msg.Options:=Msg.Options and not EO_AUTOSIZE;
end;
procedure TVarGridStringEditor.msg_SetBounds(var Msg: TGridMessage);
var
ca: TCellAttributes;
begin
with Msg do begin
TVarGrid(Grid).SetupCell(Col, Row, [], ca);
with CellRect do begin
Inc(Left, ca.Indent);
if coDrawTreeButton in ca.Options then
Inc(Left, Bottom - Top);
if coDrawCheckBox in ca.Options then
Inc(Left, Bottom - Top);
if (ca.ImageIndex <> -1) and Assigned(TVarGrid(Grid).Images) then
Inc(Left, TVarGrid(Grid).Images.Width + 2);
Dec(Left, 3);
Dec(Top, 1);
SetBounds(Left, Top, Right-Left, Bottom-Top);
end;
end;
end;
{ TVarGrid }
procedure TVarGrid.ItemsChanged(Sender: TObject);
var
i, OldRows, OldCols: integer;
pt: TPoint;
begin
FItemsChanging:=True;
try
Perform(CM_MouseLeave, 0, 0); // Hack to call ResetHotCell to workaround a bug
OldRows:=RowCount;
OldCols:=Columns.Count;
i:=FItems.RowCnt + FixedRows;
if (FRow = -1) and (inherited Row >= i) and (i > FixedRows) then
inherited Row:=i - 1;
RowCount:=i;
if FRow <> -1 then begin
Row:=FRow;
FRow:=-1;
end;
UpdateSelCount;
while Columns.Count > FItems.ColCnt do
Columns.Delete(Columns.Count - 1);
if Columns.Count <> FItems.ColCnt then begin
Columns.BeginUpdate;
try
for i:=Columns.Count to FItems.ColCnt - 1 do
Columns.Add;
finally
Columns.EndUpdate;
end;
end;
if (OldRows <> RowCount) or (OldCols <> Columns.Count) then begin
if Parent <> nil then
HandleNeeded;
ResetSizes;
end
else
Invalidate;
pt:=ScreenToClient(Mouse.CursorPos);
if PtInRect(ClientRect, pt) then
MouseMove([], pt.x, pt.y);
finally
FItemsChanging:=False;
end;
end;
procedure TVarGrid.SetHideSelection(const AValue: boolean);
begin
if FHideSelection=AValue then exit;
FHideSelection:=AValue;
Invalidate;
end;
procedure TVarGrid.SetRow(const AValue: integer);
var
i, r: integer;
begin
if FItems.IsUpdating then
FRow:=AValue
else begin
r:=AValue + FixedRows;
if r <> inherited Row then begin
i:=LeftCol;
inherited Row:=r;
LeftCol:=i;
end;
end;
end;
function TVarGrid.GetRowSelected(RowIndex: integer): boolean;
begin
Result:=LongBool(FItems.RowOptions[RowIndex] and roSelected);
end;
function TVarGrid.GetRowVisible(RowIndex: integer): boolean;
begin
Result:=RowHeights[RowIndex + FixedRows] > 0;
end;
function TVarGrid.GetSortOrder: TSortOrder;
begin
Result:=inherited SortOrder;
end;
function TVarGrid.GetRow: integer;
begin
if FItems.IsUpdating and (FRow <> -1) then
Result:=FRow
else begin
Result:=inherited Row - FixedRows;
end;
end;
procedure TVarGrid.SetRowSelected(RowIndex: integer; const AValue: boolean);
var
i, j: integer;
begin
i:=FItems.RowOptions[RowIndex];
if AValue then begin
j:=i or roSelected;
if j <> i then
Inc(FSelCount);
end
else begin
j:=i and not roSelected;
if j <> i then
Dec(FSelCount);
end;
FItems.RowOptions[RowIndex]:=j;
InvalidateRow(RowIndex + FixedRows);
if FSelCount <= 1 then
InvalidateRow(inherited Row);
end;
procedure TVarGrid.SetRowVisible(RowIndex: integer; const AValue: boolean);
begin
if AValue then
RowHeights[RowIndex + FixedRows]:=DefaultRowHeight
else
RowHeights[RowIndex + FixedRows]:=0;
end;
procedure TVarGrid.SetSortColumn(const AValue: integer);
begin
if FSortColumn=AValue then exit;
FSortColumn:=AValue;
if FSortColumn >= 0 then
Options:=Options + [goHeaderPushedLook, goHeaderHotTracking]
else
Options:=Options - [goHeaderPushedLook, goHeaderHotTracking];
Sort;
end;
procedure TVarGrid.SetSortOrder(const AValue: TSortOrder);
begin
if SortOrder = AValue then exit;
inherited SortOrder:=AValue;
Sort;
end;
procedure TVarGrid.UpdateColumnsMap;
var
i, j: integer;
begin
FFirstVisibleColumn:=-1;
SetLength(FColumnsMap, Columns.Count);
j:=0;
for i:=0 to Columns.Count - 1 do
with Columns[i] do begin
if (FFirstVisibleColumn < 0) and Visible then
FFirstVisibleColumn:=i;
FColumnsMap[j]:=ID - 1;
Inc(j);
end;
SetLength(FColumnsMap, j);
end;
procedure TVarGrid.UpdateSelCount;
var
i: integer;
begin
FSelCount:=0;
for i:=0 to FItems.Count - 1 do
if RowSelected[i] then
Inc(FSelCount);
end;
procedure TVarGrid.SelectRange(OldRow, NewRow: integer);
var
dir: integer;
sel: boolean;
begin
if OldRow = NewRow then
exit;
if FAnchor = -1 then
FAnchor:=OldRow;
dir:=Sign(NewRow - OldRow);
if Sign(FAnchor - OldRow) <> Sign(FAnchor - NewRow) then
while OldRow <> FAnchor do begin
RowSelected[OldRow]:=False;
Inc(OldRow, dir);
end;
sel:=Abs(FAnchor - OldRow) < Abs(FAnchor - NewRow);
while OldRow <> NewRow do begin
RowSelected[OldRow]:=sel;
Inc(OldRow, dir);
end;
RowSelected[NewRow]:=True;
end;
procedure TVarGrid.CMHintShow(var Message: TCMHintShow);
var
ca: TCellAttributes;
pt: TPoint;
wd: integer;
R: TRect;
begin
with Message.HintInfo^ do begin
pt:=MouseToCell(CursorPos);
if (pt.x >= FixedCols) and (pt.y >= 0) then begin
R:=CellRect(pt.x, pt.y);
if PtInRect(R, CursorPos) then begin
SetupCell(pt.x, pt.y, [], ca);
if ca.Text <> '' then begin
wd:=Canvas.TextWidth(ca.Text);
Inc(R.Left, ca.Indent);
if coDrawTreeButton in ca.Options then
Inc(R.Left, R.Bottom - R.Top);
if coDrawCheckBox in ca.Options then
Inc(R.Left, R.Bottom - R.Top);
if (ca.ImageIndex <> -1) and Assigned(FImages) then
Inc(R.Left, FImages.Width + 2);
if (R.Right <= R.Left) or (R.Right - R.Left < wd + 5) then begin
HintStr:=ca.Text;
R.Top:=(R.Top + R.Bottom - Canvas.TextHeight(ca.Text)) div 2 - 4;
Dec(R.Left);
HintPos:=ClientToScreen(R.TopLeft);
end;
FHintCell:=pt;
end
else
Message.Result:=1;
end
else
Message.Result:=1;
end;
end;
end;
function TVarGrid.CellNeedsCheckboxBitmaps(const aCol, aRow: Integer): boolean;
var
C: TGridColumn;
begin
Result := false;
if (aRow>=FixedRows) and Columns.Enabled then begin
C := ColumnFromGridColumn(aCol);
result := (C<>nil) and (C.ButtonStyle=cbsCheckboxColumn)
end;
end;
procedure TVarGrid.DrawCellCheckboxBitmaps(const aCol, aRow: Integer; const aRect: TRect);
var
AState: TCheckboxState;
begin
AState := cbUnchecked;
GetCheckBoxState(aCol, aRow, aState);
DrawGridCheckboxBitmaps(aCol, aRow, aRect, aState);
end;
function TVarGrid.FindRow(const SearchStr: string; StartRow: integer): integer;
var
i, c: integer;
s, ss: string;
v: variant;
begin
Result:=-1;
if Columns.Count = 0 then
exit;
c:=SortColumn;
if (c < 0) or (c >= Items.ColCnt) then
c:=0;
ss:=UTF8UpperCase(SearchStr);
for i:=StartRow to Items.Count - 1 do begin
v:=Items[c, i];
if VarIsNull(v) or VarIsEmpty(v) then
s:=''
else
s:=UTF8UpperCase(UTF8Encode(widestring(v)));
if Copy(s, 1, Length(ss)) = ss then begin
Result:=i;
break;
end;
end;
end;
procedure TVarGrid.DoSearchTimer(Sender: TObject);
begin
FSearchTimer.Enabled:=False;
FCurSearch:='';
end;
procedure TVarGrid.SizeChanged(OldColCount, OldRowCount: Integer);
begin
if not FItemsChanging and (FItems <> nil) then begin
FItems.ColCnt:=Columns.Count;
FItems.RowCnt:=RowCount - FixedRows;
UpdateColumnsMap;
end;
inherited;
end;
procedure TVarGrid.DrawCell(aCol, aRow: Integer; aRect: TRect; aState: TGridDrawState);
var
ca: TCellAttributes;
// ts: TTextStyle;
dd, IsHeader: boolean;
R, RR: TRect;
det: TThemedElementDetails;
sz: TSize;
i: integer;
begin
RR:=aRect;
IsHeader:=(gdFixed in aState) and (aRow=0) and (aCol>=FirstGridColumn);
if not IsHeader and MultiSelect and (FSelCount > 0) then
if (aRow >= FixedRows) and (aCol >= FixedCols) and RowSelected[aRow - FixedRows] then
Include(aState, gdSelected)
else
Exclude(aState, gdSelected);
PrepareCanvas(aCol, aRow, aState);
if DefaultDrawing then
SetupCell(aCol, aRow, aState, ca);
if not IsHeader or (TitleStyle<>tsNative) then
Canvas.FillRect(aRect);
if not IsHeader then begin
dd:=True;
if Assigned(FOnDrawCell) then begin
R:=CellRect(aCol, aRow);
if goVertLine in Options then
Dec(R.Right, 1);
if goHorzLine in Options then
Dec(R.Bottom, 1);
FOnDrawCell(Self, aCol, aRow - FixedRows, ColToDataCol(aCol), aState, R, dd);
end;
if DefaultDrawing and dd then begin
if CellNeedsCheckboxBitmaps(aCol,aRow) then
DrawCellCheckboxBitmaps(aCol,aRow,aRect)
else begin
Inc(aRect.Left, ca.Indent);
if coDrawTreeButton in ca.Options then begin
R:=aRect;
R.Right:=R.Left + (R.Bottom - R.Top);
aRect.Left:=R.Right;
if ThemeServices.ThemesEnabled then begin
if ca.Expanded then
det:=ThemeServices.GetElementDetails(ttGlyphOpened)
else
det:=ThemeServices.GetElementDetails(ttGlyphClosed);
sz:=ThemeServices.GetDetailSize(det);
with R do begin
Left:=(Left + Right - sz.cx) div 2;
Top:=(Top + Bottom - sz.cy) div 2;
R:=Bounds(Left, Top, sz.cx, sz.cy);
end;
ThemeServices.DrawElement(Canvas.Handle, det, R, nil);
end
else
with Canvas do begin
i:=(R.Bottom - R.Top) div 4;
InflateRect(R, -i, -i);
if (R.Right - R.Left) and 1 = 0 then
Dec(R.Right);
if (R.Bottom - R.Top) and 1 = 0 then
Dec(R.Bottom);
Pen.Color:=clWindowText;
Rectangle(R);
InflateRect(R, -1, -1);
Brush.Color:=clWindow;
FillRect(R);
InflateRect(R, -1, -1);
i:=(R.Top + R.Bottom) div 2;
MoveTo(R.Left, i);
LineTo(R.Right, i);
if not ca.Expanded then begin
i:=(R.Left + R.Right) div 2;
MoveTo(i, R.Top);
LineTo(i, R.Bottom);
end;
end;
end;
if coDrawCheckBox in ca.Options then begin
R:=aRect;
R.Right:=R.Left + (R.Bottom - R.Top);
aRect.Left:=R.Right;
DrawGridCheckboxBitmaps(aCol, aRow, R, ca.State);
end;
if (ca.ImageIndex <> -1) and Assigned(FImages) then begin
FImages.Draw(Canvas, aRect.Left + 2, (aRect.Bottom + aRect.Top - FImages.Height) div 2, ca.ImageIndex, gdeNormal);
Inc(aRect.Left, FImages.Width + 2);
end;
if ca.Text <> '' then begin
{
if Canvas.TextStyle.Alignment <> taLeftJustify then
if (aRect.Right <= aRect.Left) or (aRect.Right - aRect.Left < Canvas.TextWidth(ca.Text) + 9) then begin
ts:=Canvas.TextStyle;
ts.Alignment:=taLeftJustify;
Canvas.TextStyle:=ts;
end;
DrawCellText(aCol, aRow, aRect, aState, ca.Text);
}
with aRect do begin
Inc(Top, 2);
Inc(Left, constCellPadding);
Dec(Right, constCellPadding);
if RightRight then
Left:=Right;
if BottomBottom then
Top:=Bottom;
if (Left <> Right) and (Top <> Bottom) then begin
if Canvas.TextStyle.Alignment <> taLeftJustify then begin
i:=Canvas.TextWidth(ca.Text);
if i < Right - Left then
case Canvas.TextStyle.Alignment of
taRightJustify:
Left:=Right - i;
taCenter:
Left:=(Left + Right - i) div 2;
end;
end;
ExtUTF8Out(Canvas.Handle, Left, Top, ETO_OPAQUE or ETO_CLIPPED, @aRect, PChar(ca.Text), Length(ca.Text), nil);
end;
end;
end;
end;
end;
end;
if gdFixed in aState then
DefaultDrawCell(aCol, aRow, RR, aState)
else
DrawCellGrid(aCol, aRow, RR, aState);
end;
procedure TVarGrid.ColRowMoved(IsColumn: Boolean; FromIndex, ToIndex: Integer);
begin
inherited ColRowMoved(IsColumn, FromIndex, ToIndex);
UpdateColumnsMap;
end;
procedure TVarGrid.PrepareCanvas(aCol, aRow: Integer; aState: TGridDrawState);
var
F: TCustomForm;
begin
if FHideSelection and (FSelCount = 0) then begin
F:=GetParentForm(Self);
if (F <> nil) and (F.ActiveControl <> Self) then
aState:=aState - [gdSelected];
end;
inherited PrepareCanvas(aCol, aRow, aState);
with Canvas do
if (Font.Color = clWindow) and (Brush.Color = clHighlight) then begin
Font.Color:=clHighlightText;
{$ifdef LCLgtk2}
Brush.Color:=ColorToRGB(Brush.Color); // Workaround for LCL bug
{$endif LCLgtk2}
end;
end;
procedure TVarGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
pt: TPoint;
IsCtrl, CheckBoxClicked: boolean;
ca: TCellAttributes;
R, RR: TRect;
begin
{$ifdef LCLcarbon}
IsCtrl:=ssMeta in GetCarbonShiftState;
{$else}
IsCtrl:=ssCtrl in Shift;
{$endif LCLcarbon}
CheckBoxClicked:=False;
pt:=MouseToCell(Point(X,Y));
if ssLeft in Shift then begin
SetupCell(pt.x, pt.y, [], ca);
RR:=CellRect(pt.x, pt.y);
Inc(RR.Left, ca.Indent);
if (RR.Left <= RR.Right) and (coDrawTreeButton in ca.Options) then begin
R:=RR;
R.Right:=R.Left + (R.Bottom - R.Top);
if R.Right > RR.Right then
R.Right:=RR.Right;
if PtInRect(R, Point(X,Y)) then begin
DoOnTreeButtonClick(pt.x, pt.y);
InvalidateCell(pt.x, pt.y);
if Assigned(OnDblClick) and (ssDouble in Shift) then
FNoDblClick:=True;
end;
Inc(RR.Left, RR.Bottom - RR.Top);
end;
if (RR.Left <= RR.Right) and (coDrawCheckBox in ca.Options) then begin
R:=RR;
R.Right:=R.Left + (R.Bottom - R.Top);
if R.Right > RR.Right then
R.Right:=RR.Right;
if PtInRect(R, Point(X,Y)) then begin
DoOnCheckBoxClick(pt.x, pt.y);
InvalidateCell(pt.x, pt.y);
CheckBoxClicked:=True;
if Assigned(OnDblClick) and (ssDouble in Shift) then
FNoDblClick:=True;
end;
end;
end;
if (ssRight in Shift) {$ifdef darwin} or (Shift*[ssLeft, ssCtrl] = [ssLeft, ssCtrl]) {$endif} then begin
SetFocus;
if (pt.x >= FixedCols) and (pt.y >= FixedRows) then begin
if MultiSelect and (SelCount > 0) and not RowSelected[pt.y - FixedRows] then
RemoveSelection;
Row:=pt.y - FixedRows;
end;
end
else
if MultiSelect and (ssLeft in Shift) and (pt.x >= FixedCols) and (pt.y >= FixedRows) then begin
if IsCtrl then begin
if SelCount = 0 then
RowSelected[Row]:=True;
RowSelected[pt.y - FixedRows]:=not RowSelected[pt.y - FixedRows];
FAnchor:=-1;
end
else
if ssShift in Shift then
SelectRange(Row, pt.y - FixedRows)
else begin
if (SelCount > 0) and not CheckBoxClicked then
RemoveSelection;
FAnchor:=-1;
end;
end;
inherited MouseDown(Button, Shift, X, Y);
end;
procedure TVarGrid.MouseMove(Shift: TShiftState; X, Y: Integer);
var
pt: TPoint;
begin
inherited MouseMove(Shift, X, Y);
pt:=MouseToCell(Point(x, y));
if (FHintCell.x <> -1) and ((FHintCell.x <> pt.x) or (FHintCell.y <> pt.y)) then begin
Application.CancelHint;
FHintCell.x:=-1;
end;
end;
procedure TVarGrid.KeyDown(var Key: Word; Shift: TShiftState);
var
r, k: integer;
ca: TCellAttributes;
begin
if EditorMode then begin
if Key = VK_ESCAPE then begin
EditorHide;
SetFocus;
end;
exit;
end;
r:=Row;
k:=Key;
if (Shift = []) and ( (k = VK_SPACE) or (k = VK_LEFT) or (k = VK_RIGHT) or (k = VK_ADD) or (k = VK_SUBTRACT) ) then begin
SetupCell(FixedCols, inherited Row, [], ca);
case k of
VK_SPACE:
if coDrawCheckBox in ca.Options then begin
DoOnCheckBoxClick(FixedCols, inherited Row);
Key:=0;
exit;
end;
VK_LEFT, VK_SUBTRACT:
if (coDrawTreeButton in ca.Options) and ca.Expanded then begin
DoOnTreeButtonClick(FixedCols, inherited Row);
Key:=0;
exit;
end;
VK_RIGHT, VK_ADD:
if (coDrawTreeButton in ca.Options) and not ca.Expanded then begin
DoOnTreeButtonClick(FixedCols, inherited Row);
Key:=0;
exit;
end;
end;
end;
inherited KeyDown(Key, Shift);
if MultiSelect then begin
if ssCtrl in Shift then begin
if k = VK_SPACE then
RowSelected[Row]:=not RowSelected[Row];
FAnchor:=-1;
end
else
if ssShift in Shift then begin
SelectRange(r, Row);
end
else
if k in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN, VK_HOME, VK_END, VK_NEXT, VK_PRIOR] then begin
if SelCount > 0 then
RemoveSelection;
FAnchor:=-1;
end;
end;
if (Key = VK_RETURN) and (Shift = []) and Assigned(OnDblClick) then
OnDblClick(Self);
end;
procedure TVarGrid.UTF8KeyPress(var UTF8Key: TUTF8Char);
var
i, r: integer;
begin
inherited UTF8KeyPress(UTF8Key);
if UTF8Key = #0 then
exit;
FSearchTimer.Enabled:=False;
FSearchTimer.Enabled:=True;
if FCurSearch = '' then
i:=0
else
i:=Row;
FCurSearch:=FCurSearch + UTF8Key;
if Assigned(FOnQuickSearch) then begin
r:=i;
FOnQuickSearch(Self, FCurSearch, r);
if r <> i then
Row:=r;
end
else begin
i:=FindRow(FCurSearch, i);
if i >= 0 then
Row:=i;
end;
end;
procedure TVarGrid.DoOnCellAttributes(ACol, ARow, ADataCol: integer; AState: TGridDrawState; var CellAttribs: TCellAttributes);
begin
if Assigned(FOnCellAttributes) then
FOnCellAttributes(Self, ACol, ARow, ADataCol, AState, CellAttribs);
end;
procedure TVarGrid.HeaderClick(IsColumn: Boolean; index: Integer);
var
i: integer;
begin
inherited HeaderClick(IsColumn, index);
if IsColumn and (FSortColumn >= 0) then begin
fGridState:=gsNormal;
i:=ColToDataCol(index);
if FSortColumn = i then begin
if SortOrder = soAscending then
SortOrder:=soDescending
else
SortOrder:=soAscending;
end
else begin
SortOrder:=soAscending;
SortColumn:=i;
end;
end;
end;
procedure TVarGrid.AutoAdjustColumn(aCol: Integer);
var
i, j, wd, h, fr: integer;
ca: TCellAttributes;
begin
wd:=4;
fr:=FixedRows;
for i:=0 to FItems.Count - 1 do begin
h:=RowHeights[i + fr];
if h > 0 then begin
SetupCell(aCol, i + fr, [], ca);
j:=Canvas.TextWidth(ca.Text) + 6;
Inc(j, ca.Indent);
if coDrawTreeButton in ca.Options then
Inc(j, h);
if coDrawCheckBox in ca.Options then
Inc(j, h);
if (ca.ImageIndex <> -1) and Assigned(FImages) then
Inc(j, FImages.Width + 2);
if j > wd then
wd:=j;
end;
end;
ColumnFromGridColumn(aCol).Width:=wd;
end;
procedure TVarGrid.VisualChange;
begin
inherited VisualChange;
if HandleAllocated then
DefaultRowHeight:=Canvas.TextHeight('Xy') + 5;
UpdateColumnsMap;
end;
procedure TVarGrid.DrawColumnText(aCol, aRow: Integer; aRect: TRect; aState: TGridDrawState);
var
R: TRect;
i: integer;
begin
if (gdFixed in aState) and (aRow=0) and (aCol>=FirstGridColumn) then begin
R:=aRect;
if FSortColumn = ColToDataCol(aCol) then begin
R.Right:=R.Left + R.Bottom - R.Top;
InflateRect(R, -5, -5);
OffsetRect(R, -3, 0);
Dec(R.Bottom, 2);
aRect.Left:=R.Right + 2;
end;
inherited DrawColumnText(aCol, aRow, aRect, aState);
if FSortColumn = ColToDataCol(aCol) then
with Canvas do begin
Pen.Color:=clGrayText;
i:=(R.Left + R.Right) div 2;
if SortOrder = soAscending then begin
MoveTo(i, R.Top);
LineTo(R.Right, R.Bottom);
LineTo(R.Left, R.Bottom);
LineTo(i, R.Top);
end
else begin
MoveTo(R.TopLeft);
LineTo(R.Right, R.Top);
LineTo(i, R.Bottom);
LineTo(R.TopLeft);
end;
end;
end;
end;
procedure TVarGrid.DblClick;
var
pt: TPoint;
begin
if FNoDblClick then begin
FNoDblClick:=False;
exit;
end;
pt:=MouseToCell(ScreenToClient(Mouse.CursorPos));
if (pt.y < FixedRows) and (pt.y = 0) and (Cursor <> crHSplit) then
exit;
inherited DblClick;
end;
procedure TVarGrid.Click;
begin
if Assigned(OnClick) then
OnClick(Self);
end;
procedure TVarGrid.GetCheckBoxState(const aCol, aRow: Integer; var aState: TCheckboxState);
var
s: string;
begin
if (aCol >= FixedCols) and (aRow >= FixedRows) then begin
s:=Items[ColToDataCol(aCol), aRow - FixedRows];
with Columns[GridColumnFromColumnIndex(aCol)] do
if s = ValueChecked then
aState:=cbChecked
else
if s = ValueUnchecked then
aState:=cbUnchecked
else
aState:=cbGrayed;
end;
inherited GetCheckBoxState(aCol, aRow, aState);
end;
procedure TVarGrid.SetCheckboxState(const aCol, aRow: Integer; const aState: TCheckboxState);
var
s: string;
begin
if (aCol >= FixedCols) and (aRow >= FixedRows) then begin
with Columns[GridColumnFromColumnIndex(aCol)] do
case aState of
cbUnchecked:
s:=ValueUnchecked;
cbChecked:
s:=ValueChecked;
else
s:='?';
end;
Items[ColToDataCol(aCol), aRow - FixedRows]:=s;
end;
inherited SetCheckboxState(aCol, aRow, aState);
end;
procedure TVarGrid.SetupCell(ACol, ARow: integer; AState: TGridDrawState; out CellAttribs: TCellAttributes);
var
v: variant;
dc: integer;
begin
if (ACol < 0) or (ARow < 0) then
exit;
CellAttribs.ImageIndex:=-1;
CellAttribs.Indent:=0;
CellAttribs.Options:=[];
CellAttribs.State:=cbUnchecked;
CellAttribs.Expanded:=True;
if ACol >= FixedCols then begin
dc:=ColToDataCol(ACol);
if ARow >= FixedRows then begin
v:=Items[dc, ARow - FixedRows];
if not VarIsNull(v) and not VarIsEmpty(v) then
CellAttribs.Text:=UTF8Encode(WideString(v))
else
CellAttribs.Text:='';
end
else
CellAttribs.Text:=ColumnFromGridColumn(ACol).Title.Caption;
end
else
dc:=-1;
DoOnCellAttributes(ACol - FixedCols, ARow - FixedRows, dc, AState, CellAttribs);
end;
procedure TVarGrid.DoOnCheckBoxClick(ACol, ARow: integer);
var
i, dc, c: integer;
ca: TCellAttributes;
st: TCheckBoxState;
begin
if Assigned(FOnCheckBoxClick) then begin
dc:=ColToDataCol(ACol);
c:=ACol - FixedCols;
FOnCheckBoxClick(Self, c, ARow - FixedRows, dc);
if (SelCount > 0) and RowSelected[ARow - FixedRows] then begin
SetupCell(ACol, ARow, [], ca);
st:=ca.State;
for i:=0 to Items.Count - 1 do
if RowSelected[i] then begin
SetupCell(ACol, i + FixedRows, [], ca);
if (coDrawCheckBox in ca.Options) and (ca.State <> st) then
FOnCheckBoxClick(Self, c, i, dc);
end;
end;
end;
end;
procedure TVarGrid.DoOnTreeButtonClick(ACol, ARow: integer);
begin
if Assigned(FOnTreeButtonClick) then
FOnTreeButtonClick(Self, ACol - FixedCols, ARow - FixedRows, ColToDataCol(ACol));
end;
function TVarGrid.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
Result := False;
if Assigned(OnMouseWheelDown) then
OnMouseWheelDown(Self, Shift, MousePos, Result);
end;
function TVarGrid.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
Result := False;
if Assigned(OnMouseWheelUp) then
OnMouseWheelUp(Self, Shift, MousePos, Result);
end;
function TVarGrid.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean;
begin
Result:=inherited DoMouseWheel(Shift, WheelDelta, MousePos);
if not Result then begin
if Mouse.WheelScrollLines = -1 then
GridMouseWheel(Shift, -WheelDelta*VisibleRowCount div 120)
else
GridMouseWheel(Shift, -WheelDelta*Mouse.WheelScrollLines div 120);
Result := True;
end;
end;
constructor TVarGrid.Create(AOwner: TComponent);
begin
FRow:=-1;
FHintCell.x:=-1;
inherited Create(AOwner);
FixedRows:=1;
FixedCols:=0;
Options:=[goRowSelect, goThumbTracking, goVertLine, goHorzLine, goColSizing, goColMoving, goDblClickAutoSize, goFixedHorzLine, goFixedVertLine];
MouseWheelOption:=mwGrid;
FItems:=TVarList.Create(1, 0);
FItems.OnDataChanged:=@ItemsChanged;
ItemsChanged(nil);
TitleStyle:=tsNative;
FAnchor:=-1;
FSortColumn:=-1;
ShowHint:=True;
SetLength(FColumnsMap, 1);
FColumnsMap[0]:=0;
FSearchTimer:=TTimer.Create(Self);
with FSearchTimer do begin
Enabled:=False;
Interval:=1500;
OnTimer:=@DoSearchTimer;
end;
FastEditing:=False;
EditorBorderStyle:=bsSingle;
end;
destructor TVarGrid.Destroy;
begin
inherited Destroy;
FItems.Free;
end;
function TVarGrid.EditorByStyle(Style: TColumnButtonStyle): TWinControl;
begin
if Style = cbsAuto then begin
if FStrEditor = nil then begin
FStrEditor:=TVarGridStringEditor.Create(Self);
FStrEditor.Name :='VGStringEditor';
FStrEditor.Text:='';
FStrEditor.Visible:=False;
FStrEditor.Align:=alNone;
FStrEditor.BorderStyle:=bsSingle;
end;
Result:=FStrEditor;
end
else
Result:=inherited EditorByStyle(Style);
end;
procedure TVarGrid.RemoveSelection;
var
i: integer;
begin
for i:=0 to FItems.Count - 1 do
RowSelected[i]:=False;
FSelCount:=0;
end;
procedure TVarGrid.SelectAll;
var
i: integer;
begin
for i:=0 to FItems.Count - 1 do
RowSelected[i]:=True;
end;
procedure TVarGrid.Sort;
var
i, c: integer;
begin
if (FSortColumn >= 0) and (FItems.Count > 0) then begin
c:=FSortColumn;
if Assigned(FOnSortColumn) then
FOnSortColumn(Self, c);
if not FItems.IsUpdating and (Row >= 0) and (Row < FItems.Count) then
FItems.RowOptions[Row]:=FItems.RowOptions[Row] or roCurRow;
FItems.Sort(c, SortOrder = soDescending);
if not FItems.IsUpdating then begin
if Assigned(FOnAfterSort) then
FOnAfterSort(Self);
for i:=0 to FItems.Count - 1 do
if LongBool(FItems.RowOptions[i] and roCurRow) then begin
FItems.RowOptions[i]:=FItems.RowOptions[i] and not roCurRow;
Row:=i;
break;
end;
Invalidate;
end;
end;
end;
function TVarGrid.ColToDataCol(ACol: integer): integer;
begin
if (ACol >= FixedCols) and (ACol <= High(FColumnsMap)) then
Result:=FColumnsMap[ACol]
else
Result:=-1;
end;
function TVarGrid.DataColToCol(ADataCol: integer): integer;
var
i: integer;
begin
for i:=FixedCols to High(FColumnsMap) do
if FColumnsMap[i] = ADataCol then begin
Result:=i;
exit;
end;
Result:=-1;
end;
procedure TVarGrid.EnsureSelectionVisible;
var
i: integer;
begin
if FSelCount > 0 then
for i:=0 to FItems.Count - 1 do
if RowSelected[i] then begin
Row:=i;
break;
end;
EnsureRowVisible(Row);
end;
procedure TVarGrid.EnsureRowVisible(ARow: integer);
begin
ARow:=ARow + FixedRows;
if ARow < TopRow then
TopRow:=ARow
else
if ARow > GCache.FullVisibleGrid.Bottom then
TopRow:=ARow - (GCache.FullVisibleGrid.Bottom - GCache.FullVisibleGrid.Top);
end;
procedure TVarGrid.BeginUpdate;
begin
inherited BeginUpdate;
Items.BeginUpdate;
end;
procedure TVarGrid.EndUpdate(aRefresh: boolean);
begin
inherited EndUpdate(aRefresh);
Items.EndUpdate;
end;
procedure TVarGrid.EditCell(ACol, ARow: integer);
begin
SetFocus;
FOldOpt:=Options;
Options:=Options + [goEditing];
EditorShowInCell(DataColToCol(ACol), ARow + FixedRows);
end;
procedure TVarGrid.DrawRow(aRow: Integer);
var
Gds: TGridDrawState;
aCol: Integer;
Rs: Boolean;
R: TRect;
ClipArea: Trect;
{$ifdef LCLgtk2}
Rgn: HRGN;
{$endif LCLgtk2}
procedure DoDrawCell;
begin
with GCache do begin
if (aCol=HotCell.x) and (aRow=HotCell.y) and not ((PushedCell.X<>-1) and (PushedCell.Y<>-1)) then begin
Include(gds, gdHot);
HotCellPainted:=True;
end;
if ClickCellPushed and (aCol=PushedCell.x) and (aRow=PushedCell.y) then begin
Include(gds, gdPushed);
end;
end;
{$ifdef LCLgtk2}
Rgn := CreateRectRgn(R.Left, R.Top, R.Right, R.Bottom);
SelectClipRgn(Canvas.Handle, Rgn);
DeleteObject(Rgn);
{$endif LCLgtk2}
DrawCell(aCol, aRow, R, gds);
end;
function HorizontalIntersect(const aRect,bRect: TRect): boolean;
begin
result := (aRect.Left < bRect.Right) and (aRect.Right > bRect.Left);
end;
begin
// Upper and Lower bounds for this row
R.Left:=0;
ColRowToOffSet(False, True, aRow, R.Top, R.Bottom);
if R.Bottom <= R.Top then
exit;
// is this row within the ClipRect?
ClipArea := Canvas.ClipRect;
if (R.Top >= ClipArea.Bottom) or (R.Bottom < ClipArea.Top) then
exit;
// Draw columns in this row
with GCache.VisibleGrid do begin
for aCol:=left to Right do begin
ColRowToOffset(True, True, aCol, R.Left, R.Right);
if (R.Right <= R.Left) or not HorizontalIntersect(R, ClipArea) then
continue;
gds := [];
Rs := (goRowSelect in Options);
if ARow R.Left) and HorizontalIntersect(R, ClipArea) then
DoDrawCell;
end;
{$ifdef LCLgtk2}
with ClipArea do
Rgn := CreateRectRgn(Left, Top, Right, Bottom);
SelectClipRgn(Canvas.Handle, Rgn);
DeleteObject(Rgn);
{$endif LCLgtk2}
// Draw the focus Rect
if FocusRectVisible and (ARow=inherited Row) and
((Rs and (ARow>=Top) and (ARow<=Bottom)) or IsCellVisible(Col,ARow))
then begin
if EditorMode then begin
//if EditorAlwaysShown and (FEditor<>nil) and FEditor.Visible then begin
//DebugLn('No Draw Focus Rect');
end else begin
ColRowToOffset(True, True, Col, R.Left, R.Right);
// is this column within the ClipRect?
if HorizontalIntersect(R, ClipArea) then
DrawFocusRect(Col,inherited Row, R);
end;
end;
end;
end;
function TVarGrid.GetCells(ACol, ARow: Integer): string;
var
dc: integer;
v: variant;
begin
Result:='';
dc:=ColToDataCol(ACol);
if ARow >= FixedRows then begin
v:=Items[dc, ARow - FixedRows];
if not VarIsNull(v) and not VarIsEmpty(v) then
Result:=UTF8Encode(WideString(v));
end;
end;
function TVarGrid.GetEditText(ACol, ARow: Longint): string;
begin
Result:=GetCells(ACol, ARow);
if Assigned(OnGetEditText) then
OnGetEditText(self, aCol - FixedCols, aRow - FixedRows, Result);
end;
procedure TVarGrid.SetEditText(ACol, ARow: Longint; const Value: string);
var
dc: integer;
begin
if not (gfEditingDone in GridFlags) then
exit;
if Assigned(OnSetEditText) then
OnSetEditText(Self, aCol - FixedCols, aRow - FixedRows, Value)
else begin
dc:=ColToDataCol(ACol);
if ARow >= FixedRows then
Items[dc, ARow - FixedRows]:=UTF8Decode(Value);
end;
end;
procedure TVarGrid.DoEditorShow;
begin
inherited DoEditorShow;
if Assigned(OnEditorShow) then
OnEditorShow(Self);
end;
procedure TVarGrid.DoEditorHide;
begin
try
inherited DoEditorHide;
finally
Options:=FOldOpt;
end;
if Assigned(OnEditorHide) then
OnEditorHide(Self);
end;
end.
TransGUI/VERSION.txt 0000644 0000000 0000000 00000000005 12261612702 013070 0 ustar root root 5.0.1 TransGUI/daemonoptions.pas 0000644 0000000 0000000 00000017611 12261763702 014610 0 ustar root root {*************************************************************************************
This file is part of Transmission Remote GUI.
Copyright (c) 2008-2014 by Yury Sidorov.
Transmission Remote GUI is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
Transmission Remote GUI is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Transmission Remote GUI; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*************************************************************************************}
unit DaemonOptions;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls, Spin, ComCtrls, CheckLst, EditBtn, MaskEdit,
ButtonPanel, BaseForm;
resourcestring
sPortTestSuccess = 'Incoming port tested successfully.';
sPortTestFailed = 'Incoming port is closed. Check your firewall settings.';
sEncryptionDisabled = 'Encryption disabled';
sEncryptionEnabled = 'Encryption enabled';
sEncryptionRequired = 'Encryption required';
SNoDownloadDir = 'The downloads directory was not specified.';
SNoIncompleteDir = 'The directory for incomplete files was not specified.';
// SNoBlocklistURL = 'The blocklist URL was not specified.';
SInvalidTime = 'The invalid time value was entered.';
type
{ TDaemonOptionsForm }
TDaemonOptionsForm = class(TBaseForm)
btTestPort: TButton;
Buttons: TButtonPanel;
cbBlocklist: TCheckBox;
cbDHT: TCheckBox;
cbUpQueue: TCheckBox;
cbEncryption: TComboBox;
cbMaxDown: TCheckBox;
cbMaxUp: TCheckBox;
cbPEX: TCheckBox;
cbPortForwarding: TCheckBox;
cbRandomPort: TCheckBox;
cbIncompleteDir: TCheckBox;
cbPartExt: TCheckBox;
cbSeedRatio: TCheckBox;
cbLPD: TCheckBox;
cbIdleSeedLimit: TCheckBox;
cbAltEnabled: TCheckBox;
cbAutoAlt: TCheckBox;
cbStalled: TCheckBox;
cbUTP: TCheckBox;
cbDownQueue: TCheckBox;
edAltTimeEnd: TMaskEdit;
edDownQueue: TSpinEdit;
edUpQueue: TSpinEdit;
edStalledTime: TSpinEdit;
tabQueue: TTabSheet;
txDays: TLabel;
txFrom: TLabel;
edDownloadDir: TEdit;
edIncompleteDir: TEdit;
edBlocklistURL: TEdit;
edMaxDown: TSpinEdit;
edAltDown: TSpinEdit;
edMaxPeers: TSpinEdit;
edMaxUp: TSpinEdit;
edAltUp: TSpinEdit;
edPort: TSpinEdit;
edSeedRatio: TFloatSpinEdit;
gbBandwidth: TGroupBox;
edIdleSeedLimit: TSpinEdit;
gbAltSpeed: TGroupBox;
edAltTimeBegin: TMaskEdit;
txAltUp: TLabel;
txAltDown: TLabel;
txMinutes1: TLabel;
txTo: TLabel;
txKbs3: TLabel;
txKbs4: TLabel;
txMinutes: TLabel;
txMB: TLabel;
txCacheSize: TLabel;
Page: TPageControl;
edCacheSize: TSpinEdit;
tabNetwork: TTabSheet;
tabBandwidth: TTabSheet;
tabDownload: TTabSheet;
txDownloadDir: TLabel;
txEncryption: TLabel;
txKbs1: TLabel;
txKbs2: TLabel;
txPeerLimit: TLabel;
txPort: TLabel;
procedure btOKClick(Sender: TObject);
procedure btTestPortClick(Sender: TObject);
procedure cbAutoAltClick(Sender: TObject);
procedure cbBlocklistClick(Sender: TObject);
procedure cbIdleSeedLimitClick(Sender: TObject);
procedure cbIncompleteDirClick(Sender: TObject);
procedure cbMaxDownClick(Sender: TObject);
procedure cbMaxUpClick(Sender: TObject);
procedure cbRandomPortClick(Sender: TObject);
procedure cbSeedRatioClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
implementation
uses main, utils, fpjson;
{ TDaemonOptionsForm }
procedure TDaemonOptionsForm.cbMaxDownClick(Sender: TObject);
begin
edMaxDown.Enabled:=cbMaxDown.Checked;
end;
procedure TDaemonOptionsForm.btTestPortClick(Sender: TObject);
var
req, res: TJSONObject;
begin
AppBusy;
req:=TJSONObject.Create;
try
req.Add('method', 'port-test');
res:=RpcObj.SendRequest(req, False);
AppNormal;
if res = nil then
MainForm.CheckStatus(False)
else
if res.Objects['arguments'].Integers['port-is-open'] <> 0 then
MessageDlg(sPortTestSuccess, mtInformation, [mbOk], 0)
else
MessageDlg(sPortTestFailed, mtError, [mbOK], 0);
res.Free;
finally
req.Free;
end;
end;
procedure TDaemonOptionsForm.cbAutoAltClick(Sender: TObject);
var
i: integer;
begin
edAltTimeBegin.Enabled:=cbAutoAlt.Checked;
edAltTimeEnd.Enabled:=cbAutoAlt.Checked;
txFrom.Enabled:=cbAutoAlt.Checked;
txTo.Enabled:=cbAutoAlt.Checked;
txDays.Enabled:=cbAutoAlt.Checked;
for i:=1 to 7 do
gbAltSpeed.FindChildControl(Format('cbDay%d', [i])).Enabled:=cbAutoAlt.Checked;
end;
procedure TDaemonOptionsForm.cbBlocklistClick(Sender: TObject);
begin
if not edBlocklistURL.Visible then
exit;
edBlocklistURL.Enabled:=cbBlocklist.Checked;
if edBlocklistURL.Enabled then
edBlocklistURL.Color:=clWindow
else
edBlocklistURL.ParentColor:=True;
end;
procedure TDaemonOptionsForm.cbIdleSeedLimitClick(Sender: TObject);
begin
edIdleSeedLimit.Enabled:=cbIdleSeedLimit.Checked;
end;
procedure TDaemonOptionsForm.btOKClick(Sender: TObject);
begin
edDownloadDir.Text:=Trim(edDownloadDir.Text);
if edDownloadDir.Text = '' then begin
Page.ActivePage:=tabDownload;
edDownloadDir.SetFocus;
MessageDlg(SNoDownloadDir, mtError, [mbOK], 0);
exit;
end;
edIncompleteDir.Text:=Trim(edIncompleteDir.Text);
if cbIncompleteDir.Checked and (edIncompleteDir.Text = '') then begin
Page.ActivePage:=tabDownload;
edIncompleteDir.SetFocus;
MessageDlg(SNoIncompleteDir, mtError, [mbOK], 0);
exit;
end;
edBlocklistURL.Text:=Trim(edBlocklistURL.Text);
if cbAutoAlt.Checked then begin
if StrToTimeDef(edAltTimeBegin.Text, -1) < 0 then begin
Page.ActivePage:=tabBandwidth;
edAltTimeBegin.SetFocus;
MessageDlg(SInvalidTime, mtError, [mbOK], 0);
exit;
end;
if StrToTimeDef(edAltTimeEnd.Text, -1) < 0 then begin
Page.ActivePage:=tabBandwidth;
edAltTimeEnd.SetFocus;
MessageDlg(SInvalidTime, mtError, [mbOK], 0);
exit;
end;
end;
ModalResult:=mrOK;
end;
procedure TDaemonOptionsForm.cbIncompleteDirClick(Sender: TObject);
begin
edIncompleteDir.Enabled:=cbIncompleteDir.Checked;
if edIncompleteDir.Enabled then
edIncompleteDir.Color:=clWindow
else
edIncompleteDir.ParentColor:=True;
end;
procedure TDaemonOptionsForm.cbMaxUpClick(Sender: TObject);
begin
edMaxUp.Enabled:=cbMaxUp.Checked;
end;
procedure TDaemonOptionsForm.cbRandomPortClick(Sender: TObject);
begin
edPort.Enabled:=not cbRandomPort.Checked;
end;
procedure TDaemonOptionsForm.cbSeedRatioClick(Sender: TObject);
begin
edSeedRatio.Enabled:=cbSeedRatio.Checked;
end;
procedure TDaemonOptionsForm.FormCreate(Sender: TObject);
var
i, j, x, wd: integer;
cb: TCheckBox;
begin
Page.ActivePageIndex:=0;
cbEncryption.Items.Add(sEncryptionDisabled);
cbEncryption.Items.Add(sEncryptionEnabled);
cbEncryption.Items.Add(sEncryptionRequired);
Buttons.OKButton.ModalResult:=mrNone;
Buttons.OKButton.OnClick:=@btOKClick;
x:=edAltTimeBegin.Left;
wd:=(gbAltSpeed.ClientWidth - x - BorderWidth) div 7;
for i:=1 to 7 do begin
cb:=TCheckBox.Create(gbAltSpeed);
cb.Parent:=gbAltSpeed;
j:=i + 1;
if j > 7 then
Dec(j, 7);
cb.Caption:=SysToUTF8(FormatSettings.ShortDayNames[j]);
cb.Name:=Format('cbDay%d', [j]);
cb.Left:=x;
cb.Top:=txDays.Top - (cb.Height - txDays.Height) div 2;
Inc(x, wd);
end;
end;
initialization
{$I daemonoptions.lrs}
end.
TransGUI/transgui.res 0000644 0000000 0000000 00000261200 12261763702 013566 0 ustar root root ÿÿ ÿÿ ÿÿ ÿÿ
Your application description here.
true