fatalerrors/0linux
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

initial commit from lost SVN repo

Browse Source
This commit is contained in:
fatalerrors
2023-10-06 15:59:41 +02:00
parent 8186c7b10e
commit f600f5706a
1496 changed files with 666909 additions and 73 deletions
Download Patch File Download Diff File Expand all files Collapse all files
common/defines.inc
+90
View File
@@ -0,0 +1,90 @@
{
********************************************************************************
SPackGui
Copyright (C) 2013 Geoffray Levasseur <jeff.levasseur@free.fr>.
Copyright (C) <date> <add your name and mail address here>
http://jeff.levasseur.tuxfamily.org/
http://0.tuxfamilly.org/
This software is governed by the CeCILL license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/ or redistribute the software under the terms of the CeCILL
license as circulated by CEA, CNRS and INRIA at the following URL
"http://www.cecill.info".
As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided only
with a limited warranty and the software's author, the holder of the
economic rights, and the successive licensors have only limited
liability.
In this respect, the user's attention is drawn to the risks associated
with loading, using, modifying and/or developing or reproducing the
software by the user in light of its specific status of free software,
that may mean that it is complicated to manipulate, and that also
therefore means that it is reserved for developers and experienced
professionals having in-depth computer knowledge. Users are therefore
encouraged to load and test the software's suitability as regards their
requirements in conditions enabling the security of their systems and/or
data to be ensured and, more generally, to use and operate it in the
same conditions as regards security.
The fact that you are presently reading this means that you have had
knowledge of the CeCILL license and that you accept its terms.
********************************************************************************
Description:
Global defines for the project
********************************************************************************
}
//Be carreful: any boolean defines specified on command line is overriden by
//defines in that file.
//Uncomment fixed defines only
{$IFNDEF Unix}
{$FATAL A unix package manager compiled on non Unix system... Huhu crazy man!}
{$ENDIF}
{$IFDEF LCLGTK}
{$FATAL GTK 1 support is deprecated. Please use GTK 2 instead.}
{$ENDIF}
{.$IFDEF LCLGTK3}
{.$FATAL GTK 3 support is totally experimental and may result your computer}
{.$FATAL to explode and cause a lot of sufferings.}
{.$FATAL Commenting this means you are a real fearless warrior...}
{.$ENDIF}
{$mode objfpc}
{$MACRO ON}
{$H+} //default to Ansi strings
{$I+} //it's alwais a good idea to have I/O checkings
{$GOTO OFF} //goto is forbidden (and should never have existed in Pascal...)
{$define UseCThreads} //we absolutely need cthreads (so we depends on libc) so
//do not try to comment this
//uncomment the following line to force debugging functionnality
{$DEFINE DEBUG}
//the following is set to use test path instead of real system path and
//override paths definitions, needed for developpers
{$DEFINE TEST}
// installation paths defines (FHS standard)
{$if not defined(PREFIX)}
{$DEFINE PREFIX:='/usr/local'}
{$endif}
{$if not defined(BINDIR)}
{$DEFINE BINDIR:=(PREFIX) + '/bin'}
{$endif}
{$if not defined(SYSCONFDIR)}
{$DEFINE SYSCONFDIR:=(PREFIX) + '/etc'}
{$endif}
{$if not defined(LOCALSTATEDIR)}
{$DEFINE LOCALSTATEDIR=(PREFIX) + '/var'}
{$endif}
//end of global defines
common/frmprogress.lfm
+67
View File
@@ -0,0 +1,67 @@
object fProgress: TfProgress
Left = 3292
Height = 188
Top = 620
Width = 615
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'fProgress'
ClientHeight = 188
ClientWidth = 615
DesignTimePPI = 108
FormStyle = fsStayOnTop
OnCloseQuery = FormCloseQuery
OnCreate = FormCreate
Position = poMainFormCenter
ShowInTaskBar = stNever
LCLVersion = '1.9.0.0'
object lbProgressionMessage: TLabel
Left = 11
Height = 20
Top = 11
Width = 140
Caption = 'lbProgressionMessage'
ParentColor = False
ParentFont = False
end
object ProgressBar: TProgressBar
Left = 11
Height = 22
Top = 38
Width = 593
Anchors = [akTop, akLeft, akRight]
ParentFont = False
TabOrder = 0
end
object btnCancel: TBitBtn
Left = 482
Height = 34
Top = 144
Width = 122
Anchors = [akRight, akBottom]
Cancel = True
Caption = 'Cancel'
Default = True
OnClick = btnCancelClick
ParentFont = False
TabOrder = 1
end
object lbProgressionMessage2: TLabel
Left = 11
Height = 20
Top = 76
Width = 148
Caption = 'lbProgressionMessage2'
ParentColor = False
ParentFont = False
end
object ProgressBar2: TProgressBar
Left = 11
Height = 22
Top = 104
Width = 593
Anchors = [akTop, akLeft, akRight]
ParentFont = False
TabOrder = 2
end
end
common/frmprogress.pas
+198
View File
@@ -0,0 +1,198 @@
{
********************************************************************************
SPackGui (common files)
Copyright (C) 2007-2013 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
Copyright (C) <date> <add your name and mail address here>
http://0.tuxfamilly.org/
http://www.geoffray-levasseur.org/
This software is governed by the CeCILL license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/ or redistribute the software under the terms of the CeCILL
license as circulated by CEA, CNRS and INRIA at the following URL
"http://www.cecill.info".
As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided only
with a limited warranty and the software's author, the holder of the
economic rights, and the successive licensors have only limited
liability.
In this respect, the user's attention is drawn to the risks associated
with loading, using, modifying and/or developing or reproducing the
software by the user in light of its specific status of free software,
that may mean that it is complicated to manipulate, and that also
therefore means that it is reserved for developers and experienced
professionals having in-depth computer knowledge. Users are therefore
encouraged to load and test the software's suitability as regards their
requirements in conditions enabling the security of their systems and/or
data to be ensured and, more generally, to use and operate it in the
same conditions as regards security.
The fact that you are presently reading this means that you have had
knowledge of the CeCILL license and that you accept its terms.
********************************************************************************
Description:
progression dialog (this is standard and can be reused easyly)
********************************************************************************
}
unit frmProgress;
{$include defines.inc}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
ComCtrls, Buttons;
type
{ TfProgress }
TfProgress = class(TForm)
btnCancel: TBitBtn;
lbProgressionMessage: TLabel;
lbProgressionMessage2: TLabel;
ProgressBar: TProgressBar;
ProgressBar2: TProgressBar;
procedure btnCancelClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
procedure FormCreate(Sender: TObject);
private
{ private declarations }
FCanCancel: Boolean;
FCancelPressed: Boolean;
FDoubleBar: Boolean;
procedure SetCanCancel(const Value: Boolean);
procedure SetDoubleBar(const Value: Boolean);
public
{ public declarations }
constructor Create(TheOwner: TComponent); override;
property CancelPressed: Boolean read FCancelPressed default False;
property CanCancel: Boolean read FCanCancel write SetCanCancel default True;
property DoubleBar: Boolean read FDoubleBar write SetDoubleBar
default False;
procedure ForceCancel; //this force a cancel pressed event despite CanCancel state
procedure CancelCancellation;
end;
function CreateProgress(const Title, Message: string;
const Min, Max: integer): TfProgress;
function CreateProgress(const Title, Msg1, Msg2: string;
const Min1, Max1, Min2, Max2: integer): TfProgress;
implementation
{$R *.lfm}
uses
uIconManager;
resourcestring
rsExceptNotCancelled = 'The expected "Cancel" event was not triggered.';
{ TfProgress }
function CreateProgress(const Title, Message: string;
const Min, Max: integer): TfProgress;
begin
Result := TfProgress.Create(Application);
Result.lbProgressionMessage.Caption := Message;
Result.Caption := Title;
Result.ProgressBar.Min := Min;
Result.ProgressBar.Max := Max;
Result.ProgressBar.Position := Min;
end;
function CreateProgress(const Title, Msg1, Msg2: string;
const Min1, Max1, Min2, Max2: integer): TfProgress;
begin
Result := CreateProgress(Title, Msg1, Min1, Max1);
Result.DoubleBar := True;
Result.lbProgressionMessage2.Caption := Msg2;
Result.ProgressBar2.Min := Min2;
Result.ProgressBar2.Max := Max2;
Result.ProgressBar2.Position := Min2;
end;
constructor TfProgress.Create(TheOwner: TComponent);
begin
inherited Create(Owner);
SetDoubleBar(False);
end;
procedure TfProgress.SetDoubleBar(const Value: Boolean);
begin
if Value then
begin
Height := 166;
btnCancel.Top := 128;
lbProgressionMessage2.Visible := True;
ProgressBar2.Visible := True;
end else
begin
Height := 103;
btnCancel.Top := 64;
lbProgressionMessage2.Visible := False;
ProgressBar2.Visible := False;
end;
FDoubleBar := Value;
end;
procedure TfProgress.SetCanCancel(const Value: Boolean);
begin
FCanCancel := Value;
btnCancel.Enabled := FCanCancel;
end;
procedure TfProgress.ForceCancel;
begin
FCancelPressed := True;
end;
procedure TfProgress.CancelCancellation;
begin
if FCancelPressed then
FCancelPressed := False
else
Exception.Create(rsExceptNotCancelled);
end;
procedure TfProgress.FormCreate(Sender: TObject);
begin
inherited;
try
btnCancel.Tag := icCancel;
InitBtnGlyphs(Self);
finally
FCancelPressed := False;
end;
end;
procedure TfProgress.btnCancelClick(Sender: TObject);
begin
if FCanCancel then
FCancelPressed := True;
end;
procedure TfProgress.FormCloseQuery(Sender: TObject; var CanClose: boolean);
begin
CanClose := False; //this window can't be closed manually
if FCanCancel then
fCancelPressed := True; //...but this is equivalent to a cancel event
end;
end.
common/synapse/asn1util.pas
+510
View File
@@ -0,0 +1,510 @@
{==============================================================================|
| 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.
common/synapse/blcksock.pas
+4333
View File
File diff suppressed because it is too large Load Diff
common/synapse/clamsend.pas
+277
View File
@@ -0,0 +1,277 @@
{==============================================================================|
| 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.
common/synapse/dnssend.pas
+603
View File
@@ -0,0 +1,603 @@
{==============================================================================|
| 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 <ml@mutox.org>
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.
common/synapse/ftpsend.pas
+1964
View File
File diff suppressed because it is too large Load Diff
common/synapse/ftptsend.pas
+403
View File
@@ -0,0 +1,403 @@
{==============================================================================|
| 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.
common/synapse/httpsend.pas
+845
View File
@@ -0,0 +1,845 @@
{==============================================================================|
| Project : Ararat Synapse | 003.012.006 |
|==============================================================================|
| Content: HTTP client |
|==============================================================================|
| Copyright (c)1999-2011, 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-2011. |
| 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
if (FSock.SSL.SNIHost='') then
FSock.SSL.SNIHost:=FTargetHost;
FSock.SSLDoConnect;
FSock.SSL.SNIHost:=''; //don't need it anymore and don't wan't to reuse it in next connection
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);
User := DecodeURL(user);
Pass := DecodeURL(pass);
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: ansistring;
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: ansistring;
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.
common/synapse/imapsend.pas
+869
View File
@@ -0,0 +1,869 @@
{==============================================================================|
| Project : Ararat Synapse | 002.005.003 |
|==============================================================================|
| Content: IMAP4rev1 client |
|==============================================================================|
| Copyright (c)1999-2012, 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-2012. |
| 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 (length(FFullResult[n]) > 0) and (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 <p.buskermolen@pinkroccade.com>
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.
common/synapse/laz_synapse.lpk
+170
View File
@@ -0,0 +1,170 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="3">
<Name Value="laz_synapse"/>
<CompilerOptions>
<Version Value="8"/>
<SearchPaths>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)/"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<UseAnsiStrings Value="True"/>
</SyntaxOptions>
</Parsing>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Files Count="33">
<Item1>
<Filename Value="asn1util.pas"/>
<UnitName Value="asn1util"/>
</Item1>
<Item2>
<Filename Value="blcksock.pas"/>
<UnitName Value="blcksock"/>
</Item2>
<Item3>
<Filename Value="clamsend.pas"/>
<UnitName Value="clamsend"/>
</Item3>
<Item4>
<Filename Value="dnssend.pas"/>
<UnitName Value="dnssend"/>
</Item4>
<Item5>
<Filename Value="ftpsend.pas"/>
<UnitName Value="ftpsend"/>
</Item5>
<Item6>
<Filename Value="ftptsend.pas"/>
<UnitName Value="ftptsend"/>
</Item6>
<Item7>
<Filename Value="httpsend.pas"/>
<UnitName Value="httpsend"/>
</Item7>
<Item8>
<Filename Value="imapsend.pas"/>
<UnitName Value="imapsend"/>
</Item8>
<Item9>
<Filename Value="ldapsend.pas"/>
<UnitName Value="ldapsend"/>
</Item9>
<Item10>
<Filename Value="mimeinln.pas"/>
<UnitName Value="mimeinln"/>
</Item10>
<Item11>
<Filename Value="mimemess.pas"/>
<UnitName Value="mimemess"/>
</Item11>
<Item12>
<Filename Value="mimepart.pas"/>
<UnitName Value="mimepart"/>
</Item12>
<Item13>
<Filename Value="nntpsend.pas"/>
<UnitName Value="nntpsend"/>
</Item13>
<Item14>
<Filename Value="pingsend.pas"/>
<UnitName Value="pingsend"/>
</Item14>
<Item15>
<Filename Value="pop3send.pas"/>
<UnitName Value="pop3send"/>
</Item15>
<Item16>
<Filename Value="slogsend.pas"/>
<UnitName Value="slogsend"/>
</Item16>
<Item17>
<Filename Value="smtpsend.pas"/>
<UnitName Value="smtpsend"/>
</Item17>
<Item18>
<Filename Value="snmpsend.pas"/>
<UnitName Value="snmpsend"/>
</Item18>
<Item19>
<Filename Value="sntpsend.pas"/>
<UnitName Value="sntpsend"/>
</Item19>
<Item20>
<Filename Value="ssfpc.pas"/>
<AddToUsesPkgSection Value="False"/>
<UnitName Value="ssfpc"/>
</Item20>
<Item21>
<Filename Value="sswin32.pas"/>
<AddToUsesPkgSection Value="False"/>
<UnitName Value="sswin32"/>
</Item21>
<Item22>
<Filename Value="synachar.pas"/>
<UnitName Value="synachar"/>
</Item22>
<Item23>
<Filename Value="synacode.pas"/>
<UnitName Value="synacode"/>
</Item23>
<Item24>
<Filename Value="synacrypt.pas"/>
<UnitName Value="synacrypt"/>
</Item24>
<Item25>
<Filename Value="synadbg.pas"/>
<UnitName Value="synadbg"/>
</Item25>
<Item26>
<Filename Value="synafpc.pas"/>
<UnitName Value="synafpc"/>
</Item26>
<Item27>
<Filename Value="synaicnv.pas"/>
<UnitName Value="synaicnv"/>
</Item27>
<Item28>
<Filename Value="synaip.pas"/>
<UnitName Value="synaip"/>
</Item28>
<Item29>
<Filename Value="synamisc.pas"/>
<UnitName Value="synamisc"/>
</Item29>
<Item30>
<Filename Value="synaser.pas"/>
<UnitName Value="synaser"/>
</Item30>
<Item31>
<Filename Value="synautil.pas"/>
<UnitName Value="synautil"/>
</Item31>
<Item32>
<Filename Value="synsock.pas"/>
<UnitName Value="synsock"/>
</Item32>
<Item33>
<Filename Value="tlntsend.pas"/>
<UnitName Value="tlntsend"/>
</Item33>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="1">
<Item1>
<PackageName Value="FCL"/>
<MinVersion Major="1" Valid="True"/>
</Item1>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
</Package>
</CONFIG>
common/synapse/laz_synapse.pas
+24
View File
@@ -0,0 +1,24 @@
{ 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.
common/synapse/ldapsend.pas
+1208
View File
File diff suppressed because it is too large Load Diff
common/synapse/mimeinln.pas
+263
View File
@@ -0,0 +1,263 @@
{==============================================================================|
| 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.
common/synapse/mimemess.pas
+851
View File
@@ -0,0 +1,851 @@
{==============================================================================|
| Project : Ararat Synapse | 002.006.000 |
|==============================================================================|
| Content: MIME message object |
|==============================================================================|
| Copyright (c)1999-2012, 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-2012. |
| Portions created by Petr Fejfar are Copyright (c)2011-2012. |
| 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+}
{$M+}
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;
{pf}
{: HTTP message is received by @link(THTTPSend) component in two parts:
headers are stored in @link(THTTPSend.Headers) and a body in memory stream
@link(THTTPSend.Document).
On the top of it, HTTP connections are always 8-bit, hence data are
transferred in native format i.e. no transfer encoding is applied.
This method operates the similiar way and produces the same
result as @link(DecodeMessage).
}
procedure DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream);
{/pf}
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;
{pf}
procedure TMimeMess.DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream);
begin
FHeader.Clear;
FLines.Clear;
FLines.Assign(AHeader);
FHeader.DecodeHeaders(FLines);
FMessagePart.DecomposePartsBinary(AHeader,PANSIChar(AData.Memory),PANSIChar(AData.Memory)+AData.Size);
end;
{/pf}
end.
common/synapse/mimepart.pas
+1227
View File
File diff suppressed because it is too large Load Diff
common/synapse/nntpsend.pas
+483
View File
@@ -0,0 +1,483 @@
{==============================================================================|
| Project : Ararat Synapse | 001.005.003 |
|==============================================================================|
| Content: NNTP client |
|==============================================================================|
| Copyright (c)1999-2011, 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-2011. |
| 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;
if Result then
begin
ListExtensions;
FNNTPcap.Assign(Fdata);
if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
Result := StartTLS;
end;
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.
common/synapse/pingsend.pas
+720
View File
@@ -0,0 +1,720 @@
{==============================================================================|
| 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.
common/synapse/pop3send.pas
+483
View File
@@ -0,0 +1,483 @@
{==============================================================================|
| 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.
common/synapse/slogsend.pas
+320
View File
@@ -0,0 +1,320 @@
{==============================================================================|
| 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.
common/synapse/smtpsend.pas
+724
View File
@@ -0,0 +1,724 @@
{==============================================================================|
| 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
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.
common/synapse/snmpsend.pas
+1266
View File
File diff suppressed because it is too large Load Diff
common/synapse/sntpsend.pas
+374
View File
@@ -0,0 +1,374 @@
{==============================================================================|
| 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.
common/synapse/ssdotnet.inc
+1099
View File
File diff suppressed because it is too large Load Diff
common/synapse/ssfpc.inc
+909
View File
@@ -0,0 +1,909 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.004 |
|==============================================================================|
| Content: Socket Independent Platform Layer - FreePascal definition include |
|==============================================================================|
| Copyright (c)2006-2011, 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-2011. |
| 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}
common/synapse/ssl_cryptlib.pas
+677
View File
@@ -0,0 +1,677 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.000 |
|==============================================================================|
| Content: SSL/SSH support by Peter Gutmann's CryptLib |
|==============================================================================|
| Copyright (c)1999-2012, 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-2012. |
| 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
Windows,
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;
FTrustedCAs: array of integer;
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;
{:Load trusted CA's in PEM format}
procedure SetCertCAFile(const Value: string); 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;
{:See @inherited}
function GetVerifyCert: integer; 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;
FTrustedCAs := nil;
end;
destructor TSSLCryptLib.Destroy;
begin
SetCertCAFile(''); // destroy certificates
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;
{$IF CRYPTLIB_VERSION >= 3400}
FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_ERRORMESSAGE);
{$ELSE}
FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE);
{$IFEND}
end;
end;
function TSSLCryptLib.CreateSelfSignedCert(Host: string): Boolean;
var
privateKey: CRYPT_CONTEXT;
keyset: CRYPT_KEYSET;
cert: CRYPT_CERTIFICATE;
publicKey: CRYPT_CONTEXT;
begin
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 (FCertComplianceLevel <> -1) then
if not SSLCheck(cryptSetAttribute (CRYPT_UNUSED, CRYPT_OPTION_CERT_COMPLIANCELEVEL,
FCertComplianceLevel)) 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
SysUtils.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;
if FverifyCert then
if (GetVerifyCert <> 0) or (not DoVerifyCert) 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;
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_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
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_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
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_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_ISSUERNAME);
Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME);
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);
cryptDestroyCert(cert);
end;
procedure TSSLCryptLib.SetCertCAFile(const Value: string);
var F:textfile;
bInCert:boolean;
s,sCert:string;
cert: CRYPT_CERTIFICATE;
idx:integer;
begin
if assigned(FTrustedCAs) then
begin
for idx := 0 to High(FTrustedCAs) do
cryptDestroyCert(FTrustedCAs[idx]);
FTrustedCAs:=nil;
end;
if Value<>'' then
begin
AssignFile(F,Value);
reset(F);
bInCert:=false;
idx:=0;
while not eof(F) do
begin
readln(F,s);
if pos('-----END CERTIFICATE-----',s)>0 then
begin
bInCert:=false;
cert:=0;
if (cryptImportCert(PAnsiChar(sCert),length(sCert)-2,CRYPT_UNUSED,cert)=CRYPT_OK) then
begin
cryptSetAttribute( cert, CRYPT_CERTINFO_TRUSTED_IMPLICIT, 1 );
SetLength(FTrustedCAs,idx+1);
FTrustedCAs[idx]:=cert;
idx:=idx+1;
end;
end;
if bInCert then
sCert:=sCert+s+#13#10;
if pos('-----BEGIN CERTIFICATE-----',s)>0 then
begin
bInCert:=true;
sCert:='';
end;
end;
CloseFile(F);
end;
end;
function TSSLCryptLib.GetVerifyCert: integer;
var
cert: CRYPT_CERTIFICATE;
itype,ilocus:integer;
begin
Result := -1;
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
result:=cryptCheckCert(cert,CRYPT_UNUSED);
if result<>CRYPT_OK then
begin
//get extended error info if available
cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORtype,itype);
cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORLOCUS,ilocus);
cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
FLastError := Result;
FLastErrorDesc := format('SSL/TLS certificate verification failed for "%s"'#13#10'Status: %d. ERRORTYPE: %d. ERRORLOCUS: %d.',
[GetString(cert, CRYPT_CERTINFO_COMMONNAME),result,itype,ilocus]);
end;
cryptDestroyCert(cert);
end;
{==============================================================================}
var imajor,iminor,iver:integer;
// e: ESynapseError;
initialization
if cryptInit = CRYPT_OK then
SSLImplementation := TSSLCryptLib;
cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL);
cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION,imajor);
cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION,iminor);
// according to the documentation CRYPTLIB version has 3 digits. recent versions use 4 digits
if CRYPTLIB_VERSION >1000 then
iver:=CRYPTLIB_VERSION div 100
else
iver:=CRYPTLIB_VERSION div 10;
if (iver <> imajor*10+iminor) then
begin
SSLImplementation :=TSSLNone;
// e := ESynapseError.Create(format('Error wrong cryptlib version (is %d.%d expected %d.%d). ',
// [imajor,iminor,iver div 10, iver mod 10]));
// e.ErrorCode := 0;
// e.ErrorMessage := format('Error wrong cryptlib version (%d.%d expected %d.%d)',
// [imajor,iminor,iver div 10, iver mod 10]);
// raise e;
end;
finalization
cryptEnd;
end.
common/synapse/ssl_openssl.pas
+896
View File
@@ -0,0 +1,896 @@
{==============================================================================|
| Project : Ararat Synapse | 001.002.000 |
|==============================================================================|
| 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-2012. |
| Portions created by Petr Fejfar are Copyright (c)2011-2012. |
| 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 GetPeerSerialNo: integer; override; {pf}
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerNameHash: cardinal; override; {pf}
{: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;
try {pf}
if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then
if SSLCTXusecertificate(Fctx, cert) > 0 then
if SSLCTXusePrivateKey(Fctx, pkey) > 0 then
Result := True;
{pf}
finally
EvpPkeyFree(pkey);
X509free(cert);
SkX509PopFree(ca,_X509Free); // for ca=nil a new STACK was allocated...
end;
{/pf}
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;
if SNIHost<>'' then
SSLCtrl(Fssl, SSL_CTRL_SET_TLSEXT_HOSTNAME, TLSEXT_NAMETYPE_host_name, PAnsiChar(SNIHost));
x := sslconnect(FSsl);
if x < 1 then
begin
SSLcheck;
Exit;
end;
if FverifyCert then
if (GetVerifyCert <> 0) or (not DoVerifyCert) 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
{pf}// Verze 1.1.0 byla s else tak jak to ted mam,
// ve verzi 1.1.1 bylo ELSE zruseno, ale pak je SSL_ERROR_ZERO_RETURN
// propagovano jako Chyba.
{pf} else {/pf} 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.GetPeerSerialNo: integer; {pf}
var
cert: PX509;
SN: PASN1_INTEGER;
begin
if not assigned(FSsl) then
begin
Result := -1;
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
try
if not assigned(cert) then
begin
Result := -1;
Exit;
end;
SN := X509GetSerialNumber(cert);
Result := Asn1IntegerGet(SN);
finally
X509Free(cert);
end;
end;
function TSSLOpenSSL.GetPeerName: string;
var
s: ansistring;
begin
s := GetPeerSubject;
s := SeparateRight(s, '/CN=');
Result := Trim(SeparateLeft(s, '/'));
end;
function TSSLOpenSSL.GetPeerNameHash: cardinal; {pf}
var
cert: PX509;
begin
if not assigned(FSsl) then
begin
Result := 0;
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
try
if not assigned(cert) then
begin
Result := 0;
Exit;
end;
Result := X509NameHash(X509GetSubjectName(cert));
finally
X509Free(cert);
end;
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;
try {pf}
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;
{pf}
finally
X509Free(cert);
end;
{/pf}
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.
common/synapse/ssl_openssl_lib.pas
+2138
View File
File diff suppressed because it is too large Load Diff
common/synapse/ssl_sbb.pas
+697
View File
@@ -0,0 +1,697 @@
{==============================================================================|
| 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)<Len then
begin
Result:=Length(FRecvDecodedBuffers);
Move(FRecvDecodedBuffers[1],Buffer^,Result);
FRecvDecodedBuffers:='';
end
else
begin
Result:=Len;
Move(FRecvDecodedBuffers[1],Buffer^,Result);
Delete(FRecvDecodedBuffers,1,Result);
end;
except
// ignore
end;
end;
function TSSLSBB.WaitingData: Integer;
var
lResult:Integer;
lRecvBuffers:Boolean;
begin
Result:=0;
if FSocket.Socket=INVALID_SOCKET then
Exit;
// 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
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.
common/synapse/ssl_streamsec.pas
+539
View File
@@ -0,0 +1,539 @@
{==============================================================================|
| 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 <henrick@streamsec.se> |
|==============================================================================|
| 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.
common/synapse/sslinux.inc
+1314
View File
File diff suppressed because it is too large Load Diff
common/synapse/sswin32.inc
+1615
View File
File diff suppressed because it is too large Load Diff
common/synapse/synachar.pas
+2035
View File
File diff suppressed because it is too large Load Diff
common/synapse/synacode.pas
+1461
View File
File diff suppressed because it is too large Load Diff
common/synapse/synacrypt.pas
+2412
View File
File diff suppressed because it is too large Load Diff
common/synapse/synadbg.pas
+156
View File
@@ -0,0 +1,156 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.002 |
|==============================================================================|
| Content: Socket debug tools |
|==============================================================================|
| Copyright (c)2008-2011, 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-2011. |
| 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, synafpc;
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(PtrInt(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(PtrInt(Sender), 8) + d + s + CRLF;
AppendToLog(s);
end;
initialization
begin
Logfile := changefileext(paramstr(0), '.slog');
end;
end.
common/synapse/synafpc.pas
+141
View File
@@ -0,0 +1,141 @@
{==============================================================================|
| Project : Ararat Synapse | 001.002.000 |
|==============================================================================|
| Content: Utils for FreePascal compatibility |
|==============================================================================|
| Copyright (c)1999-2011, 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-2011. |
| 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;
PtrInt = Integer;
{$ELSE}
TLibHandle = HModule;
{$IFNDEF WIN64}
PtrInt = Integer;
{$ENDIF}
{$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.
common/synapse/synaicnv.pas
+363
View File
@@ -0,0 +1,363 @@
{==============================================================================|
| 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.
common/synapse/synaip.pas
+422
View File
@@ -0,0 +1,422 @@
{==============================================================================|
| 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.
common/synapse/synamisc.pas
+406
View File
@@ -0,0 +1,406 @@
{==============================================================================|
| 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}
{$TYPEDADDRESS OFF}
{$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.
common/synapse/synaser.pas
+2339
View File
File diff suppressed because it is too large Load Diff
common/synapse/synautil.pas
+2065
View File
File diff suppressed because it is too large Load Diff
common/synapse/synsock.pas
+77
View File
@@ -0,0 +1,77 @@
{==============================================================================|
| Project : Ararat Synapse | 005.002.001 |
|==============================================================================|
| Content: Socket Independent Platform Layer |
|==============================================================================|
| Copyright (c)1999-2011, 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-2011. |
| 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.inc}
{$ELSE}
{$IFDEF MSWINDOWS}
{$I sswin32.inc}
{$ELSE}
{$IFDEF WINCE}
{$I sswin32.inc} //not complete yet!
{$ELSE}
{$IFDEF FPC}
{$I ssfpc.inc}
{$ELSE}
{$I sslinux.inc}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
end.
common/synapse/tlntsend.pas
+364
View File
@@ -0,0 +1,364 @@
{==============================================================================|
| 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.
common/ucommon.pas
+685
View File
@@ -0,0 +1,685 @@
{
********************************************************************************
SPackGui (common files)
Copyright (C) 2013 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
Copyright (C) <date> <add your name and mail address here>
http://www.geoffray-levasseur.org/
http://0.tuxfamilly.org/
This software is governed by the CeCILL license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/ or redistribute the software under the terms of the CeCILL
license as circulated by CEA, CNRS and INRIA at the following URL
"http://www.cecill.info".
As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided only
with a limited warranty and the software's author, the holder of the
economic rights, and the successive licensors have only limited
liability.
In this respect, the user's attention is drawn to the risks associated
with loading, using, modifying and/or developing or reproducing the
software by the user in light of its specific status of free software,
that may mean that it is complicated to manipulate, and that also
therefore means that it is reserved for developers and experienced
professionals having in-depth computer knowledge. Users are therefore
encouraged to load and test the software's suitability as regards their
requirements in conditions enabling the security of their systems and/or
data to be ensured and, more generally, to use and operate it in the
same conditions as regards security.
The fact that you are presently reading this means that you have had
knowledge of the CeCILL license and that you accept its terms.
********************************************************************************
Description:
some common vars and functions
********************************************************************************
}
unit uCommon;
{$include defines.inc}
interface
uses
Classes, IniFiles, Forms;
type
TCharSet = set of Char;
const
//for test we don't touch to real system files
{$IFDEF TEST}
//you need to change everything before the ELSE compiler directive
//accordingly to your own test path
sDefaultLogFileName = '/share/src/pascal/0linux/log/spackgui.log';
sLockFile = '/share/src/pascal/0linux/log/spackgui.lock';
sIconBaseDir = '/share/src/pascal/0linux/icons';
sRootUserName = 'fatalerrors'; //when testing we want to make change even if non root
sDefaultSpackPkgDir = '/share/src/pascal/0linux/testpack';
sDefaultConfDir = '/share/src/pascal/0linux/testconf';
sDefaultRepoIndexDir = sDefaultConfDir;
sDefaultDwlDir = '/share/src/pascal/0linux/packages';
sRepoConfFile = 'depots.conf';
sMainConfFile = 'spackgui.conf';
{$ELSE}
sDefaultLogFileName = {$LOCALSTATEDIR}'/log/spackgui.log';
sLockFile = {$LOCALSTATEDIR}'/lock/spackgui.lock';
sIconBaseDir = {$PREFIX}'/share/spackgui/icons';
sRootUserName = 'root';
sDefaultSpackPkgDir = {$LOCALSTATEDIR}'/lib/spack';
sDefaultConfDir = {$SYSCONFDIR}'/spackgui';
sDefaultRepoIndexDir = sDefaultConfDir;
sDefaultDwlDir = {$LOCALSTATEDIR}'/cache/spack';
sRepoConfFile = 'depots.conf';
sMainConfFile = 'spackgui.conf';
{$ENDIF}
sDefaultInstallPackage = 'spackadd %s';
sDefaultReinstallPackage = 'spackadd -f %s';
sDefaultRemovePackage = 'spackrm %s';
sDefaultUpdatePackage = 'spackadd %s';
AnsiLineFeed = AnsiChar(#10);
AnsiCarriageReturn = AnsiChar(#13);
AnsiCrLf = AnsiString(#13#10);
iDefaultProxyPort = 3128;
RegExprOperator: TCharSet = ['&', '|', '#'];
var
sConfDir: string; //place where configuration files will be stored
sSpackPkgDir: string; //installed packages repository
sRepoIndexDir: string; //place where repositories metadata are stored
sDwlDir: string; //place where packages are downloaded before install
sDefaultRepo: string; //default repo used for upgrades
bChangeAllowed: Boolean; //global saying if change are allowed or not
bUnitsAreDecimal: Boolean; //user may want decimal
cThousandSep: Char; //thousand separator (#0 means none)
cDecimalSep: Char; //decimal separator
bNoColors: Boolean; //colorize listview or not
bShowGrig: Boolean; //show a grid in listview or not
sInstallPackage: string; //command to install a package
sReinstallPackage: string; //command to reinstall an installed package
sRemovePackage: string; //command to remove an installed package
sUpdatePackage: string; //command to update an installed package
tLockFile: Text; //pointer to lockfile
iniMain: TIniFile; //main configuration file object
iniRepo: TIniFile; //repositories configuration file object
bReadOnly: Boolean; //when non-root we are read-only
slRepoList: TStringList; //list of non installed packages repository
slDeprecated: TStringList; //list of deprecated packages
sArch: string; //used architecture
//proxy settings
sHttpProxyAddress: string;
iHttpProxyPort: Integer;
sHttpProxyUser: string;
sHttpProxyPass: string;
sFtpProxyAddress: string;
iFtpProxyPort: Integer;
sFtpProxyUser: string;
sFtpProxyPass: string;
//write a string list in an ini file, the TInifile must be initialized
procedure IniWriteStrings(IniFile: TIniFile; const Section, Ident: string;
Str: TStrings);
//read a string list in an ini file, the TInifile must be initialized
procedure IniReadStrings(IniFile: TIniFile; const Section, Ident: string;
Str: TStrings);
// SPack use that format: pkgname-version-arch-build{,.spack}
procedure DecomposePackageName(const S: ansistring;
out Name, Version: ansistring; out Build: Byte; out Arch: ansistring);
// Extract package name a full spack format string
function ExtractPackageName(const S: ansistring): ansistring;
// Format numbers for file size display (with units)
// the base unit is Byte but spack have KB as base unit
function DispSize(const Size: integer): string;
//convert strings generated by the previous function to LongInt
function SizeStrToInt(const SzStr: string): LongInt;
// Get Major, minor and release number (sometimes there's letters so we keep that
// string)... Exotic version numbering gets remainings information in rem var
procedure DecomposeVersion(const V: string; out Maj, Min, Rel, Rem: string);
// If V1 > V2 result is 1, 0 if equal and -1 if V1 < V2
function CompareVersion(const V1, V2: string): ShortInt;
// Load/save window geometry in main ini file
procedure LoadWindowGeometry(Form: TForm);
procedure SaveWindowGeometry(Form: TForm);
// Load/save repository configuration informations
procedure LoadRepoSettings;
procedure SaveRepoSettings;
// Initialize config dir and inifiles
procedure InitConf;
// Get address of a repository from it's name
function GetRepoAddress(const RepoName: string): string;
implementation
uses
SysUtils, uStrings, uUtils, uDebug, Controls;
procedure IniWriteStrings(IniFile: TIniFile; const Section, Ident: string;
Str: TStrings);
var
I: integer;
OldCount: Integer;
begin
//old number of line as needed
OldCount := IniFile.ReadInteger(Section, Ident + rsConfNameCount, 0);
if OldCount > Str.Count then //more lines in old config ?
for I := Str.Count to OldCount do
IniFile.DeleteKey(Section, Ident + IntToStr(I)); //erase old keys
IniFile.WriteInteger(Section, Ident + rsConfNameCount, Str.Count); //new count
for I := 0 to Str.Count - 1 do
IniFile.WriteString(Section, Ident + IntToStr(I), Str[I]); //write each line
end;
procedure IniReadStrings(IniFile: TIniFile; const Section, Ident: string;
Str: TStrings);
var
I, N: Integer;
begin
Str.Clear;
N := IniFile.ReadInteger(Section, Ident + rsConfNameCount, 0);
for I := 0 to N - 1 do
Str.Add(IniFile.ReadString(Section, Ident + IntToStr(I), ''));
end;
procedure DecomposePackageName(const S: ansistring;
out Name, Version: ansistring; out Build: Byte; out Arch: ansistring);
var
I, J: integer;
Tmp: string;
begin
I := Length(S);
while S[I] <> '-' do
Dec(I);
Tmp := Copy(S, I + 1, Length(S) - I + 1);
if Trim(Tmp) <> '' then
Build := StrToInt(Tmp)
else
Build := 0;
Dec(I);
J := I;
while S[I] <> '-' do
Dec(I);
Arch := Copy(S, I + 1, J - I);
Dec(I);
J := I;
while S[I] <> '-' do
Dec(I);
Version := Copy(S, I + 1, J - I);
Name := Copy(S, 1, I - 1);
//the following is unneeded as we shouldn't have '-' in versions
//--------------------------------------------------------------
//I := Length(Name);
//while (I > 1) and (Name[I] <> '-') do //still some '-' in the name ?
// Dec(I);
//if I > 1 then //name or version contains '-': try to analyse this correctly...
// if (Name[I + 1] in ['0'..'9']) and (Name[Length(Name)] in ['0'..'9']) then
// begin
// Tmp := Copy(Name, I + 1, Length(Name) - I + 1);
// Version := Tmp + '-' + Version;
// Name := Copy(S, 1, I - 1);
// end;
end;
function ExtractPackageName(const S: ansistring): ansistring;
var
I, P: integer;
Tmp: string;
begin
if UpperCase(ExtractFileExt(S)) = rsSpackExt then
Tmp := RemoveFileExt(S)
else
Tmp := S;
P := Pos(' ', S);
if P <> 0 then
begin
Tmp := Copy(Tmp, P + 1, Length(Tmp) - P);
P := Pos(' ', Tmp);
Tmp := Copy(Tmp, 1, P - 1);
end;
I := Length(Tmp);
//skip build
while Tmp[I] <> '-' do
Dec(I);
Dec(I);
//skip arch
while Tmp[I] <> '-' do
Dec(I);
Dec(I);
//skip version
while Tmp[I] <> '-' do
Dec(I);
Result := Copy(S, 1, I - 1);
end;
function DispSize(const Size: LongInt): string;
var
Diviser, I, N: Integer;
Unt: string;
begin
if bUnitsAreDecimal then
Diviser := 1000
else
Diviser := 1024;
// we go up to GB as bigger is probably not needed for now in that kind of app
if Size > (Diviser * 10) then //if true at least 10KB
if (Size div Diviser) > (Diviser * 10) then //10MB
if ((Size div Diviser) div Diviser) > (Diviser * 10) then //10GB
begin
Result := IntToStr(((Size div Diviser) div Diviser) div Diviser);
if ((Size div Diviser) div Diviser) mod Diviser <> 0 then
Result := Result + cDecimalSep +
Copy(IntToStr(((Size div Diviser) div Diviser) mod Diviser), 1, 2);
if bUnitsAreDecimal then
Unt := rsGB
else
Unt := rsGiB;
end else
begin
Result := IntToStr((Size div Diviser) div Diviser);
if (Size div Diviser) mod Diviser <> 0 then
Result := Result + cDecimalSep +
Copy(IntToStr((Size div Diviser) mod Diviser), 1, 2);
if bUnitsAreDecimal then
Unt := rsMB
else
Unt := rsMiB;
end
else
begin
Result := IntToStr(Size div Diviser);
if Size mod Diviser <> 0 then
Result := Result + cDecimalSep + Copy(IntToStr(Size mod Diviser), 1, 2);
if bUnitsAreDecimal then
Unt := rsKB
else
Unt := rsKiB;
end else
begin
Unt := rsByte;
Result := IntToStr(Size);
end;
if (((Length(Result) > 3) and (Pos(cDecimalSep, Result) = 0)) or
((Pos(cDecimalSep, Result) <> 0) and (Length(Result) > 5))) and
(cThousandSep <> #0) then
begin
N := Pos(cDecimalSep, Result) - 1;
if N <= 0 then
N := Length(Result);
I := 0;
while N >= 1 do
begin
if (I <> 0) and (I mod 3 = 0) then
Insert(cThousandSep, Result, N + 1);
Inc(I);
Dec(N);
end;
end;
Result := Result + ' ' + Unt;
end;
function SizeStrToInt(const SzStr: string): LongInt;
var
Mul: Integer;
Val: Single;
S: string;
begin
S := Trim(SzStr);
if S = '' then
begin
Result := 0;
Exit;
end;
Mul := 1;
if Pos(rsKiB, S) > 1 then
begin
Mul := 1024;
S := Copy(S, 1, Length(S) - 4);
end else
if Pos(rsKB, S) > 1 then
begin
Mul := 1000;
S := Copy(S, 1, Length(S) - 3);
end else
if Pos(rsMiB, S) > 1 then
begin
Mul := 1024 * 1024;
S := Copy(S, 1, Length(S) - 4);
end else
if Pos(rsMB, S) > 1 then
begin
Mul := 1000 * 1000;
S := Copy(S, 1, Length(S) - 3);
end else
if Pos(rsGiB, S) > 1 then
begin
Mul := 1024 * 1024 * 1024;
S := Copy(S, 1, Length(S) - 4);
end else
if Pos(rsGB, S) > 1 then
begin
Mul := 1000 * 1000 * 1000;
S := Copy(S, 1, Length(S) - 3);
end else
if Pos(rsByte, S) > 1 then
S := Copy(S, 1, Length(S) - 2);
while Pos(cThousandSep, S) <> 0 do
Delete(S, Pos(cThousandSep, S), 1);
if Pos(cDecimalSep, S) <> 0 then
S[Pos(cDecimalSep, S)] := '.';
try
Val := StrToFloat(S);
except
PrintLnDbg(Format('E Error while converting %s with intermediate %s to float',
[SzStr, S]));
Result := 0;
Exit;
end;
try
Result := Round(Val * Mul);
except
PrintLnDbg(Format('E Error while converting %s: float is to big',
[SzStr, S]));
Result := 0;
end;
end;
procedure DecomposeVersion(const V: string; out Maj, Min, Rel, Rem: string);
var
I: integer;
Tmp: string;
begin
Rem := '';
Tmp := '';
I := Pos('.', V);
if (I = 0) then
I := Pos('_', V);
if I > 0 then
begin
Maj := Copy(V, 1, I - 1);
Tmp := Copy(V, I + 1, Length(V) - I);
if Length(V) = 0 then
begin
Min := '';
Rel := '';
Rem := '';
Exit;
end;
I := Pos('.', Tmp);
if (I = 0) then
I := Pos('_', Tmp);
if I > 0 then
begin
Min := Copy(Tmp, 1, I - 1);
Tmp := Copy(Tmp, I + 1, Length(Tmp) - I);
if Length(Tmp) = 0 then
begin
Rel := '';
Rem := '';
Exit;
end;
I := Pos('.', Tmp);
if (I = 0) then
I := Pos('_', Tmp);
if I > 0 then
begin
Rel := Copy(Tmp, 1, I - 1);
Tmp := Copy(Tmp, I + 1, Length(Tmp) - I);
if Length(Tmp) = 0 then
Exit;
Rem := Tmp;
end else
Rel := Tmp;
end else
Min := Tmp;
end else
Maj := V;
end;
function CompareVersion(const V1, V2: string): ShortInt;
var
Maj1, Maj2: string;
Min1, Min2: string;
Rel1, Rel2: string;
Rem1, Rem2: string;
begin
DecomposeVersion(V1, Maj1, Min1, Rel1, Rem1);
DecomposeVersion(V2, Maj2, Min2, Rel2, Rem2);
Result := 0;
//test remainning informations
if Rem1 > Rem2 then
Result := 1
else
if Rem1 < Rem2 then
Result := -1;
//test release (overide previous test)
if Rel1 > Rel2 then
Result := 1
else
if Rel1 < Rel2 then
Result := -1;
//test minor
if Min1 > Min2 then
Result := 1
else
if Min1 < Min2 then
Result := -1;
//test major
if Maj1 > Maj2 then
Result := 1
else
if Maj1 < Maj2 then
Result := -1;
end;
procedure LoadWindowGeometry(Form: TForm);
begin
Form.Left := iniMain.ReadInteger(Form.Name, rsConfNameLeft, Form.Left);
Form.Top := iniMain.ReadInteger(Form.Name, rsConfNameTop, Form.Top);
if Form.BorderStyle <> bsDialog then
begin
Form.Width := iniMain.ReadInteger(Form.Name, rsConfNameWidth, Form.Width);
Form.Height := iniMain.ReadInteger(Form.Name, rsConfNameHeight, Form.Height);
if iniMain.ReadBool(Form.Name, rsConfNameMaximized, False) then
Form.WindowState := wsMaximized;
end;
end;
procedure SaveWindowGeometry(Form: TForm);
var
Maxi: Boolean;
begin
iniMain.WriteInteger(Form.Name, rsConfNameLeft, Form.Left);
iniMain.WriteInteger(Form.Name, rsConfNameTop, Form.Top);
if Form.BorderStyle <> bsDialog then
begin
iniMain.WriteInteger(Form.Name, rsConfNameWidth, Form.Width);
iniMain.WriteInteger(Form.Name, rsConfNameHeight, Form.Height);
Maxi := Form.WindowState = wsMaximized;
iniMain.WriteBool(Form.Name, rsConfNameMaximized, Maxi);
end;
end;
procedure InitConf;
var
UseHome: Boolean;
ProxyTmp, Port: string;
begin
bReadOnly := False;
sConfDir := sDefaultConfDir;
if not DirectoryExists(sConfDir) then
if DirectoryIsReadOnly(ExtractFileDir(sConfDir)) then
UseHome := True
else
MkDir(sConfDir)
else
if DirectoryIsReadOnly(sConfDir) then
UseHome := True;
if UseHome then
if not DirectoryIsReadOnly(GetHomePath) then
begin
sConfDir := GetHomePath + rsFreeDesktopConfig + '/' + rsHomeConfDir; //freedestop compliant
if not DirectoryExists(sConfDir) then
begin
if not DirectoryExists(GetHomePath + rsFreeDesktopConfig) then
MkDir(GetHomePath + rsFreeDesktopConfig);
MkDir(sConfDir);
end
end else
bReadOnly := True;
iniMain := TIniFile.Create(sConfDir + '/' + sMainConfFile);
PrintLnDbg(Format(rsInfoInitConfFile, [iniMain.FileName]), vlLow);
iniRepo := TIniFile.Create(sConfDir + '/' + sRepoConfFile);
PrintLnDbg(Format(rsInfoInitConfFile, [iniRepo.FileName]), vlLow);
case GetUsedCPU of
cpu386: sArch := 'i686';
cpuX86_64: sArch := 'x86_64';
cpuArm: sArch := 'arm';
end;
//environment settings
sInstallPackage := iniMain.ReadString(rsConfSectionCommand,
rsConfNameInstallCommand, sDefaultInstallPackage);
sReinstallPackage := iniMain.ReadString(rsConfSectionCommand,
rsConfNameReinstallCommand, sDefaultReinstallPackage);
sRemovePackage := iniMain.ReadString(rsConfSectionCommand,
rsConfNameRemoveCommand, sDefaultRemovePackage);
sUpdatePackage := iniMain.ReadString(rsConfSectionCommand,
rsConfNameUpdateCommand, sDefaultUpdatePackage);
sSpackPkgDir := iniMain.ReadString(rsConfSectionPaths, rsConfNameInstPkgPath,
sDefaultSpackPkgDir);
sDwlDir := iniMain.ReadString(rsConfSectionPaths, rsConfNamePkgDownloadPath,
sDefaultDwlDir);
sRepoIndexDir := iniMain.ReadString(rsConfSectionPaths,
rsConfNameRepoDownloadPath, sDefaultRepoIndexDir);
ProxyTmp := iniMain.ReadString(rsConfSectionProxy, rsConfNameHttpProxy, '');
GetProxyInfo(ProxyTmp, sHttpProxyUser, sHttpProxyPass, sHttpProxyAddress, Port);
try
if Trim(Port) <> '' then
iHttpProxyPort := StrToInt(Port);
finally
//do nothing
end;
ProxyTmp := iniMain.ReadString(rsConfSectionProxy, rsConfNameFtpProxy, '');
GetProxyInfo(ProxyTmp, sFtpProxyUser, sFtpProxyPass, sFtpProxyAddress, Port);
try
if Trim(Port) <> '' then
iFtpProxyPort := StrToInt(Port);
finally
//do nothing
end;
//display settings
try
cThousandSep := Chr(iniMain.ReadInteger(rsConfSectionDisplay,
rsConfNameThousandsSep, Ord(' ')));
except
cThousandSep := ' ';
end;
try
cDecimalSep := Chr(iniMain.ReadInteger(rsConfSectionDisplay,
rsConfNameDecimalSep, Ord(',')));
except
cDecimalSep := ',';
end;
bUnitsAreDecimal := iniMain.ReadBool(rsConfSectionDisplay,
rsConfNameDecimalUnits, False);
bShowGrig := iniMain.ReadBool(rsConfSectionDisplay, rsConfNameShowGrid, False);
bNoColors := iniMain.ReadBool(rsConfSectionDisplay, rsConfNameNoColors, False);
end;
procedure LoadRepoSettings;
var
I: Integer;
begin
PrintLnDbg(rsInfoLoadingRepoSettings, vlLow);
if iniRepo = nil then
Exit; //exception goes here
if slRepoList = nil then
slRepoList := TStringList.Create
else
slRepoList.Clear;
iniRepo.ReadSections(slRepoList);
for I := 0 to slRepoList.Count - 1 do
begin
if iniRepo.ReadBool(slRepoList[I], rsConfNameDefault, False) then
sDefaultRepo := slRepoList[I];
slRepoList[I] := slRepoList[I] + '=' +
iniRepo.ReadString(slRepoList[I], rsConfNameAddress, '');
end;
PrintLnDbg(Format(rsInfoDefaultRepo, [sDefaultRepo]), vlLow);
end;
procedure SaveRepoSettings;
var
I, N: Integer;
Name, Address: string;
begin
if bReadOnly then
Exit; //this should not happen: trigger an exception when conception is over
if (slRepoList = nil) or (iniRepo = nil) then
Exit; //should not happen: an exception goes here
for I := 0 to slRepoList.Count - 1 do
begin
N := Pos('=', slRepoList[I]);
if N = 0 then
Continue; //show an error message
Name := Trim(Copy(slRepoList[I], 1, N - 1));
Address := Trim(Copy(slRepoList[I], N + 1, Length(slRepoList[I]) - N));
iniRepo.WriteString(Name, rsConfNameAddress, Address);
iniRepo.WriteBool(Name, rsConfNameDefault, Name = sDefaultRepo);
end;
iniRepo.UpdateFile;
end;
function GetRepoAddress(const RepoName: string): string;
var
I: Integer;
begin
for I := 0 to slRepoList.Count - 1 do
if Pos(RepoName, slRepoList[I]) = 1 then
Result := Copy(slRepoList[I], Pos('=', slRepoList[I]) + 1,
Length(slRepoList[I]) - Pos('=', slRepoList[I]) + 1);
end;
end.
common/udebug.pas
+517
View File
@@ -0,0 +1,517 @@
{
********************************************************************************
SPackGui (common files)
Copyright (C) 2009-2013 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
Copyright (C) <date> <add your name and mail address here>
http://www.geoffray-levasseur.org/
http://0.tuxfamilly.org/
This software is governed by the CeCILL license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/ or redistribute the software under the terms of the CeCILL
license as circulated by CEA, CNRS and INRIA at the following URL
"http://www.cecill.info".
As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided only
with a limited warranty and the software's author, the holder of the
economic rights, and the successive licensors have only limited
liability.
In this respect, the user's attention is drawn to the risks associated
with loading, using, modifying and/or developing or reproducing the
software by the user in light of its specific status of free software,
that may mean that it is complicated to manipulate, and that also
therefore means that it is reserved for developers and experienced
professionals having in-depth computer knowledge. Users are therefore
encouraged to load and test the software's suitability as regards their
requirements in conditions enabling the security of their systems and/or
data to be ensured and, more generally, to use and operate it in the
same conditions as regards security.
The fact that you are presently reading this means that you have had
knowledge of the CeCILL license and that you accept its terms.
********************************************************************************
Description:
Console debuging facilities
********************************************************************************
}
unit uDebug;
{$include defines.inc}
interface
uses
Classes, syncobjs, SysUtils, CustApp;
type
TVerboseLevel = (vlFull, vlHigh, vlLow, vlNone);
THandleException = class
private
FHandleExceptionLock: TCriticalSection;
FHandleExceptionMessage: String;
FHandleExceptionBackTrace: TStringList;
FOldExceptionHandler: TExceptionEvent;
procedure ShowException;
public
constructor Create; reintroduce;
destructor Destroy; override;
procedure HandleException(Sender: TObject; E: Exception);
procedure ThreadException(E: Exception; AThread: TThread);
end;
var
iDebugLevel: Integer;
vlVerboseLevel: TVerboseLevel;
bLogError: Boolean;
sLogFileName: string;
tLogFile: Text;
heHandleException: THandleException;
ExceptionProc: TExceptionEvent;
DebugLock: TCriticalSection;
// init logging facilities
function InitDbg(const FileName: string): Boolean;
// close logging file
procedure TerminateDbg;
// print and log messages
procedure PrintDbg(Mes: string; Verbosity: TVerboseLevel);
procedure PrintDbg(Mes: string);
procedure PrintLnDbg(Mes: string; Verbosity: TVerboseLevel);
procedure PrintLnDbg(Mes: TStringList; Verbosity: TVerboseLevel);
procedure PrintLnDbg(Verbosity: TVerboseLevel);
procedure PrintLnDbg(Mes: string);
procedure PrintDbgStat(Stat: Boolean; Verbosity: TVerboseLevel);
procedure PrintDbgResult(Res: Boolean; Verbosity: TVerboseLevel);
procedure PrintDbgResult(Res: string; Verbosity: TVerboseLevel);
// handle manual exceptions when we want
procedure HandleManualException(E: Exception);
// show the call stack
procedure DumpCallStack;
// put full informations about heap inside a string
function GetHeapStatus(aHS: THeapStatus): string;
implementation
uses
Crt, Dialogs, Forms, uStrings;
procedure DumpCallStack;
var
I: Longint;
prevbp: Pointer;
CallerFrame, CallerAddress, bp: Pointer;
Report: TStringList;
const
MaxDepth = 30;
begin
Report := TStringList.Create;
bp := get_frame;
// This trick skip SendCallstack item
// bp:= get_caller_frame(get_frame);
try
prevbp := bp - 1;
I := 0;
while bp > prevbp do
begin
CallerAddress := get_caller_addr(bp);
CallerFrame := get_caller_frame(bp);
if CallerAddress = nil then
Break;
Report.Add(BackTraceStrFunc(CallerAddress));
Inc(I);
if (I >= MaxDepth) or (CallerFrame = nil) then
Break;
prevbp := bp;
bp := CallerFrame;
end;
except
{ prevent endless dump if an exception occured }
end;
PrintLnDbg(Report, vlNone);
Report.Free;
end;
procedure DumpExceptionCallStack(E: Exception);
var
I: Integer;
Frames: PPointer;
Report: TStringList;
begin
Report := TStringList.Create;
Report.Add(rsErrorUnhandledException);
if E <> nil then
begin
Report.Add(rsExceptionClass + E.ClassName);
Report.Add(rsMessage + E.Message);
end;
Report.Add(rsStackTrace);
Report.Add(BackTraceStrFunc(ExceptAddr));
Frames := ExceptFrames;
for I := 0 to ExceptFrameCount - 1 do
Report.Add(BackTraceStrFunc(Frames[I]));
PrintLnDbg(Report, vlNone);
Report.Free;
{$IFNDEF Debug}
Halt; // End of program execution (if not debugging)
{$ENDIF}
end;
procedure HandleManualException(E: Exception);
begin
heHandleException.HandleException(nil, E);
end;
constructor THandleException.Create;
begin
FHandleExceptionLock := TCriticalSection.Create;
FOldExceptionHandler := ExceptionProc;
ExceptionProc := @HandleException;
end;
destructor THandleException.Destroy;
begin
inherited;
ExceptionProc := FOldExceptionHandler;
FreeAndNil(FHandleExceptionLock);
end;
procedure THandleException.HandleException(Sender: TObject; E: Exception);
begin
if MainThreadID = GetCurrentThreadId then
begin
DumpExceptionCallStack(E);
MessageDlg(E.Message, mtError, [MBOK], 0); //create something better
end else
begin
FHandleExceptionLock.Acquire;
try
FHandleExceptionMessage := E.Message;
DumpExceptionCallStack(E);
DumpCallStack;
MessageDlg(FHandleExceptionMessage, mtError, [MBOK], 0); //same
finally
FHandleExceptionLock.Release;
end;
end;
end;
procedure THandleException.ThreadException(E: Exception; AThread: TThread);
var
Frames: PPointer;
I: Integer;
begin
PrintLnDbg(Format(rsErrorInThread, [AThread.ClassName]));
if MainThreadID = GetCurrentThreadId then
begin
DumpExceptionCallStack(E);
MessageDlg(E.Message, mtError, [MBOK], 0); //create something better
end else
begin
FHandleExceptionLock.Acquire;
try
FHandleExceptionBackTrace := TStringList.Create;
FHandleExceptionMessage := E.Message;
FHandleExceptionBackTrace.Add(rsErrorUnhandledException);
if E <> nil then
begin
FHandleExceptionBackTrace.Add(rsExceptionClass + E.ClassName);
FHandleExceptionBackTrace.Add(rsMessage + E.Message);
end;
FHandleExceptionBackTrace.Add(rsStackTrace);
FHandleExceptionBackTrace.Add(BackTraceStrFunc(ExceptAddr));
Frames := ExceptFrames;
for I := 0 to ExceptFrameCount - 1 do
FHandleExceptionBackTrace.Add(BackTraceStrFunc(Frames[I]));
TThread.Synchronize(AThread, @ShowException);
finally
FHandleExceptionLock.Release;
end;
end;
end;
procedure THandleException.ShowException;
begin
PrintLnDbg(FHandleExceptionBackTrace, vlNone);
MessageDlg(FHandleExceptionMessage, mtError, [MBOK], 0); //create something better
end;
procedure LoggingError(Msg: string);
begin
bLogError := True;
PrintLnDbg(Msg, vlLow);
PrintLnDbg(rsWarningNoLogfile, vlLow);
end;
//create logfile and rotate old ones (10 max)
function InitDbg(const FileName: string): Boolean;
var
Count: Byte;
I: Integer;
F: File;
Orig, Dest: string;
begin
{$I-}
//init some vars
Count := 1;
Result := True;
//first step: do the logrotate (10 logfile max fixed)
if FileExists(Trim(FileName)) then
while FileExists(Trim(FileName) + '.' + IntToStr(Count)) do
Inc(Count)
else
Count := 0;
if Count > 0 then
for I := Count downto 1 do
begin
Assign(F, Trim(FileName) + '.' + IntToStr(I - 1));
if I = 1 then
Orig := Trim(FileName)
else
Orig := Trim(FileName) + '.' + IntToStr(I - 1);
Dest := Trim(FileName) + '.' + IntToStr(I);
if I >= 10 then
if not FileIsReadOnly(Orig) then
Erase(F)
else
begin
LoggingError(Format(rsErrorLogrotate, [Trim(FileName)]));
Result := False;
Exit;
end
else
if (not FileIsReadOnly(Orig)) and (not FileExists(Dest)) then
RenameFile(Orig, Dest)
else
begin
LoggingError(Format(rsErrorLogrotate, [Trim(FileName)]));
Result := False;
Exit;
end;
end;
{$I+}
//second step: check if file can be safely created and create it
if FileExists(Trim(FileName)) then
begin
LoggingError(Format(rsErrorButLogrotate, [Trim(FileName)]));
Result := False;
Exit;
end;
Assign(tLogFile, Trim(FileName));
{$I-}
Rewrite(tLogFile);
{$I+}
if IOResult <> 0 then
begin
LoggingError(Format(rsErrorCreatingLogfile, [Trim(FileName)]));
Result := False;
Exit;
end;
//third step: write header and assign vars
bLogError := False;
sLogFileName := Trim(FileName);
PrintLnDbg(Format(rsInfoLoggingStarted, [sLogFileName]), vlLow);
end;
procedure TerminateDbg;
begin
PrintLnDbg(Format(rsInfoLoggingTerminated, [sLogFileName]), vlLow);
if (not bLogError) and (Trim(sLogFileName) <> '') then
CloseFile(tLogFile);
end;
function VerbosityToInt(V: TVerboseLevel): integer;
begin
Result := 4; //default is all the messages to be shown
case V of
vlFull: Result := 4;
vlHigh: Result := 2;
vlLow: Result := 1;
vlNone: Result := 0; //nothing is displayed
end;
end;
procedure PrintDbg(Mes: string; Verbosity: TVerboseLevel);
var
I: integer;
Err: Boolean;
C: Char;
LineBegining: Boolean;
begin
//showing debugging message only if Debug is defined
{$IFNDEF Debug}
if LineBegining and (Length(Mes) > 2) and (Mes[2] = ' ') and
(Mes[1] = 'D') then
Exit;
{$ENDIF}
//if it's not meant to be displayed get out of here
if VerbosityToInt(Verbosity) > VerbosityToInt(vlVerboseLevel) then
Exit;
//init error state
{$I-}
Err := False;
DebugLock.Acquire;
//display time only if we are on a new line
try
LineBegining := WhereX <= 1;
if LineBegining or ((Length(Mes) > Length(sTimeJump)) and
(Copy(Mes, 1, Length(sTimeJump)) = sTimeJump)) then
begin
Write('[' + TimeToStr(Time) + '] ');
if (not bLogError) and (Trim(sLogFileName) <> '') then
begin
Write(tLogFile, '[' + TimeToStr(Time) + '] ');
Err := (IOResult <> 0) or Err;
end;
//this is used in case where indentation is needed in log
if iDebugLevel > 0 then
for I := 0 to iDebugLevel do
begin
Write(' '); //this is 3 spaces
if (not bLogError) and (Trim(sLogFileName) <> '') then
begin
Write(tLogFile, ' '); //this is 3 spaces
Err := (IOResult <> 0) or Err;
end;
end;
end;
// we use the first char to know if it's error warning or info
if LineBegining and (Length(Mes) > 2) and (Mes[2] = ' ') and
(Mes[1] in ['E', 'W', 'i'{$IFDEF Debug}, 'D'{$ENDIF}]) then
begin
C := Mes[1];
Mes := Copy(Mes, 3, Length(Mes) - 2);
case C of
'E': Mes := rsBaseError + Mes;
'W': Mes := rsBaseWarning + Mes;
'i': Mes := rsBaseInfo + Mes;
{$IFDEF Debug}
'D': Mes := rsBaseDebug + Mes;
{$ENDIF}
end;
end;
//write the message
Write(Mes);
if (not bLogError) and (Trim(sLogFileName) <> '') then
begin
Write(tLogFile, Mes);
Err := (IOResult <> 0) or Err;
end;
except
Err := True;
end;
{$I+}
//if error occurs somewhere, trigger an error
if Err then
LoggingError(Format(rsErrorWritingLogFile, [sLogFileName]));
//force truely writing the file
if (not bLogError) and (Trim(sLogFileName) <> '') then
Flush(tLogFile);
DebugLock.Release;
end;
procedure PrintDbg(Mes: string);
begin
PrintDbg(Mes, vlFull);
end;
procedure PrintLnDbg(Mes: TStringList; Verbosity: TVerboseLevel);
var
I: Integer;
begin
if VerbosityToInt(Verbosity) > VerbosityToInt(vlVerboseLevel) then
Exit;
for I := 0 to Mes.Count - 1 do
if I = 0 then
PrintLnDbg(Mes[I], Verbosity)
else
PrintDbg(sTimeJump + Mes[I] + sLineBreak, Verbosity);
end;
procedure PrintLnDbg(Mes: string);
begin
PrintLnDbg(Mes, vlFull);
end;
procedure PrintLnDbg(Mes: string; Verbosity: TVerboseLevel);
begin
if VerbosityToInt(Verbosity) > VerbosityToInt(vlVerboseLevel) then
Exit;
PrintDbg(Mes + sLineBreak, Verbosity);
end;
procedure PrintLnDbg(Verbosity: TVerboseLevel);
begin
if VerbosityToInt(Verbosity) > VerbosityToInt(vlVerboseLevel) then
Exit;
Writeln;
if (not bLogError) and (Trim(sLogFileName) <> '') then
Writeln(tLogFile);
end;
procedure PrintDbgStat(Stat: Boolean; Verbosity: TVerboseLevel);
begin
if VerbosityToInt(Verbosity) > VerbosityToInt(vlVerboseLevel) then
Exit;
if Stat then
PrintDbg(dbgStatOk, Verbosity)
else
PrintDbg(dbgStatWarn, Verbosity);
end;
procedure PrintDbgResult(Res: Boolean; Verbosity: TVerboseLevel);
begin
if VerbosityToInt(Verbosity) > VerbosityToInt(vlVerboseLevel) then
Exit;
if Res then
PrintLnDbg(dbgOk, Verbosity)
else
PrintLnDbg(dbgFail, Verbosity);
end;
procedure PrintDbgResult(Res: string; Verbosity: TVerboseLevel);
begin
if VerbosityToInt(Verbosity) > VerbosityToInt(vlVerboseLevel) then
Exit;
PrintLnDbg(Res, Verbosity);
end;
function GetHeapStatus(aHS: THeapStatus): string;
begin
Result := Format(rsHeapStatusDetails,
[aHS.TotalAddrSpace, aHS.TotalUncommitted, aHS.TotalCommitted,
aHS.TotalAllocated, aHS.TotalFree, aHS.FreeSmall, aHS.FreeBig,
aHS.Unused, aHS.Overhead, aHS.HeapErrorCode]);
end;
initialization
ExceptionProc := Application.OnException;
{$IFDEF DEBUG}
vlVerboseLevel := vlFull;
{$ELSE}
vlVerboseLevel := vlLow;
{$ENDIF}
iDebugLevel := 0;
bLogError := True; //means that we can't write in the log file as it's not opened
sLogFileName := '';
heHandleException := THandleException.Create;
DebugLock := TCriticalSection.Create;
finalization
DebugLock.Free;
FreeAndNil(heHandleException);
end.
common/udownload.pas
+567
View File
@@ -0,0 +1,567 @@
{
********************************************************************************
SPackGui
Copyright (C) 2012-2013 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
Copyright (C) <date> <add your name and mail address here>
Parts inspired from AstroSurf souce code:
Copyright (C) 2006 Patrick Chevalley <pch@freesurf.ch>
http://www.geoffray-levasseur.org/
http://0.tuxfamilly.org/
This software is governed by the CeCILL license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/ or redistribute the software under the terms of the CeCILL
license as circulated by CEA, CNRS and INRIA at the following URL
"http://www.cecill.info".
As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided only
with a limited warranty and the software's author, the holder of the
economic rights, and the successive licensors have only limited
liability.
In this respect, the user's attention is drawn to the risks associated
with loading, using, modifying and/or developing or reproducing the
software by the user in light of its specific status of free software,
that may mean that it is complicated to manipulate, and that also
therefore means that it is reserved for developers and experienced
professionals having in-depth computer knowledge. Users are therefore
encouraged to load and test the software's suitability as regards their
requirements in conditions enabling the security of their systems and/or
data to be ensured and, more generally, to use and operate it in the
same conditions as regards security.
The fact that you are presently reading this means that you have had
knowledge of the CeCILL license and that you accept its terms.
********************************************************************************
Description:
simple downloader class
********************************************************************************
}
unit uDownload;
{$include defines.inc}
interface
uses
Classes, SysUtils, HTTPsend, FTPSend, blcksock;
type
TDownloadProtocol = (prHttp, prFtp);
TDownloadProc = procedure of object;
TDownloadFeedback = procedure (Txt: string) of object;
TDownloadResult = (drNone, drDownloading, drError, drDone,
drCanceled, drPaused);
TDownloader = class(TObject)
private
FDownloadFeedback: TDownloadFeedback;
FProtocol: TDownloadProtocol;
FSockReadCount, FSockWriteCount: Integer;
FLastRead, FLastWrite: integer;
FUrl, FFirstUrl: string;
FDwlOk: Boolean;
FHttp: THTTPSend;
FFtp: TFTPSend;
FResponse: string;
FFile: string;
FProxy, FProxyPort, FProxyUser, FProxyPass: string;
FSocksProxy, FSocksType: string;
FFWMode: Integer;
FFWPassive: Boolean;
FUserName, FPassword: string;
FFWhost, FFWport, FFWUsername, FFWPassword: string;
FFileSize: LongInt;
FStatus: string;
FFtpDir, FFtpFile: string;
FState: TDownloadResult;
FPaused: Boolean;
FProgressText: string;
FOnDownloadComplete: TDownloadProc;
FOnProgress: TDownloadProc;
function InitHttp(const GetSize: Boolean): Boolean;
function InitFtp(const GetSize: Boolean): Boolean;
function GetDownloadedSize: LongInt;
procedure SetUrl(const Value: string);
procedure DoDownload;
procedure SockStatus(Sender: TObject; Reason: THookSocketReason;
const Value: string);
procedure FTPStatus(Sender: TObject; Response: Boolean;
const Value: string);
protected
procedure HTTPComplete;
procedure FTPComplete;
procedure ProgressReport;
public
constructor Create;
destructor Destroy; override;
function StartDownload: Boolean;
procedure Cancel;
procedure Pause;
property URL: string read FUrl write SetUrl;
property SaveToFile: string read FFile write FFile;
property ResponseText: string read FResponse;
property HttpProxy: string read FProxy write FProxy ;
property HttpProxyPort: string read FProxyPort write FProxyPort;
property HttpProxyUser: string read FProxyUser write FProxyUser;
property HttpProxyPass: string read FProxyPass write FProxyPass;
property SocksProxy: string read FSocksproxy write FSocksProxy;
property SocksType: string read FSocksType write FSocksType;
property FtpUserName: string read FUserName write FUserName;
property FtpPassword: string read FPassword write FPassword;
property FtpFwMode: integer read FFWMode write FFWMode;
property FtpFwPassive: Boolean read FFWpassive write FFWpassive;
property FtpFwHost: string read FFWhost write FFWhost;
property FtpFwPort: string read FFWport write FFWport;
property FtpFwUserName: string read FFWUsername write FFWUsername;
property FtpFwPassword: string read FFWPassword write FFWPassword;
property FileSize: LongInt read FFileSize;
property Status: string read FStatus;
property DownloadedSize: LongInt read GetDownloadedSize;
property State: TDownloadResult read FState;
property OnFeedback: TDownloadFeedback read FDownloadFeedback
write FDownloadFeedback;
property OnDownloadComplete: TDownloadProc read FOnDownloadComplete
write FOnDownloadComplete;
property OnProgress: TDownloadProc read FOnProgress write FOnProgress;
end;
implementation
uses
uDebug, uCommon, uStrings, Forms;
procedure TDownloader.DoDownload;
begin
PrintLnDbg(rsDebugDownloadStarted);
try
FSockReadCount := 0;
FSockWriteCount := 0;
FLastRead := 0;
FLastWrite := 0;
if FProtocol = prHttp then
begin
FHttp.Sock.OnStatus := @SockStatus;
FDwlOk := FHttp.HTTPMethod('GET', FUrl);
end;
if FProtocol = prFtp then
begin
FFtp.OnStatus := @FTPStatus;
if FFtp.Login then
begin
FFtp.ChangeWorkingDir(FFtpDir);
FDwlOk := FFtp.RetrieveFile(FFtpFile, False);
end;
end;
if Assigned(FOnDownloadComplete) then
FOnDownloadComplete;
except
if FProtocol = prHttp then
PrintLnDbg(Format(rsErrorDownloadingFailed, [FUrl]), vlLow);
if FProtocol = prFtp then
PrintLnDbg(Format(rsErrorDownloadingFailed, [FFtpFile]), vlLow);
FState := drError;
end;
PrintLnDbg(rsDebugDownloadFinished);
end;
procedure TDownloader.SockStatus(Sender: TObject;
Reason: THookSocketReason; const Value: string);
var
ReasonTxt: string;
begin
ReasonTxt := '';
case Reason of
HR_ResolvingBegin: ReasonTxt := rsNetStatResolving + Value;
HR_Connect: ReasonTxt := rsNetStatConnect + Value;
HR_Accept: ReasonTxt := rsNetStatAccept + Value;
HR_ReadCount: begin
FSockReadCount := FSockReadCount + StrToInt(Value);
if (FSockReadCount - FLastRead) > 100000 then
begin
ReasonTxt := rsNetStatReadBytes + IntToStr(FSockReadCount);
FLastRead := FSockReadCount;
end;
end;
HR_WriteCount: begin
FSockWriteCount := FSockWriteCount + StrToInt(Value);
ReasonTxt := rsNetStatRequesting;
end;
else
ReasonTxt := '';
end;
if (ReasonTxt > '') and assigned(FOnProgress) then
begin
FProgressText := ReasonTxt;
FOnProgress;
end;
end;
procedure TDownloader.FTPStatus(Sender: TObject; Response: Boolean;
const Value: string);
begin
if Response and Assigned(FOnProgress) then
begin
FProgressText := Value;
FOnProgress;
end;
end;
function TDownloader.InitHttp(const GetSize: Boolean): Boolean;
var
I, N: integer;
const
CL = 'CONTENT-LENGTH';
begin
Result := True;
try
FResponse := '';
FHttp.Clear;
FHttp.Sock.SocksIP := '';
FHttp.ProxyHost := '';
if FSocksProxy <> '' then
begin
FHttp.Sock.SocksIP := FSocksProxy;
if FProxyPort <> '' then
FHttp.Sock.SocksPort := FProxyPort;
if FSocksType = 'Socks4' then
FHttp.Sock.SocksType := ST_Socks4
else
FHttp.Sock.SocksType := ST_Socks5;
if FProxyUser <> '' then
FHttp.Sock.SocksUsername := FProxyUser;
if FProxyPass <> '' then
FHttp.Sock.SocksPassword := FProxyPass;
end else
if FProxy <> '' then
begin
FHttp.ProxyHost := FProxy;
if FProxyPort <> '' then
FHttp.ProxyPort := FProxyPort;
if FProxyUser <> '' then
FHttp.ProxyUser := FProxyUser;
if FProxyPass <> '' then
FHttp.ProxyPass := FProxyPass;
end;
if GetSize then
if FHttp.HTTPMethod('HEAD', FUrl) then
try
for I := 0 to FHttp.Headers.Count - 1 do
begin
N := Pos(CL, UpperCase(FHttp.Headers[I]));
if N <> 0 then
begin
FFileSize := StrToInt(Trim(Copy(FHttp.Headers[I],
N + Length(CL) + 1,
Length(FHttp.Headers[I]) - Length(CL) - N)));
PrintLnDbg(Format(rsInfoInitializedDownload, [FUrl,
DispSize(FFileSize)]), vlLow);
Break;
end;
end;
except
FFileSize := -1;
end else //can't get the filesize from the server
FFileSize := -1;
except
Result := False;
FState := drError;
end;
end;
function TDownloader.InitFtp(const GetSize: Boolean): Boolean;
var
Buf: string;
I: integer;
begin
Result := True;
try
FResponse := '';
I := Pos('://', FUrl);
Buf := Copy(Furl, I + 3, Length(FUrl) - I - 2);
I := Pos('/', Buf);
FFtp.TargetHost := Copy(Buf, 1, I - 1);
FFtp.PassiveMode := FFWpassive;
if FUserName <> '' then
FFtp.UserName := FUserName
else
FFtp.UserName := 'anonymous';
FFtp.Password := FPassword;
FFtp.FWMode := FFWMode;
if FFWhost <> '' then
FFtp.FWHost := FFWHost;
if FFWport <> '' then
FFtp.FWPort := FFWPort;
if FFWUsername <> '' then
FFtp.FWUsername := FFWUsername;
if FFWPassword <> '' then
FFtp.FWPassword := FFWPassword;
Buf := Copy(Buf, I, Length(Buf) - I + 1);
I := LastDelimiter('/', Buf);
FFtpDir := Copy(Buf, 1, I);
FFtpFile := Copy(Buf, I + 1, Length(Buf) - I);
FFtp.DirectFile := True;
FFtp.DirectFileName := FFile;
if GetSize then
begin
if FFtp.Login then
begin
FFtp.ChangeWorkingDir(FFtpDir);
FFileSize := FFtp.FileSize(FFtpFile);
FFtp.Logout;
end else
FFileSize := -1;
PrintLnDbg(Format(rsInfoInitializedDownload, [FUrl,
DispSize(FFileSize)]), vlLow);
end;
except
Result := False;
FState := drError;
end;
end;
function TDownloader.GetDownloadedSize: Longint;
begin
Result := 0;
case FProtocol of
prHttp: Result := FHttp.Sock.RecvCounter;
prFtp: Result := FFtp.DSock.RecvCounter;
end
end;
procedure TDownloader.SetUrl(const Value: string);
begin
FUrl := Value;
if Trim(FUrl) <> '' then
if Copy(FUrl, 1, 7) = sHttpPrefix then
InitHttp(True)
else
if Copy(Furl, 1, 6) = sFtpPrefix then {$warning What about sftp ?}
InitFtp(True);
end;
constructor TDownloader.Create;
begin
inherited Create;
FHttp := THTTPSend.Create;
FFtp := TFTPSend.Create;
FProxy := '';
FSocksProxy := '';
FFWMode := 0;
FFWpassive := True;
FStatus := '';
FResponse := '';
FState := drNone;
FUserName := '';
FPassword := '';
FPaused := False;
FDwlOk := False;
end;
destructor TDownloader.Destroy;
begin
FHttp.Free;
FFtp.Free;
inherited Destroy;
end;
procedure TDownloader.Cancel;
begin
if FProtocol = prHttp then
begin
FHttp.Sock.OnStatus := nil;
FHttp.Abort;
end;
if FProtocol = prFtp then
begin
FFtp.Sock.OnStatus := nil;
FFtp.OnStatus := nil;
FFtp.Abort;
end;
FState := drCanceled;
FOnProgress := nil;
FOnDownloadComplete := nil;
end;
procedure TDownloader.Pause;
begin
if (FState <> drDownloading) and (FState <> drPaused) then
Exit;
{ if FPaused then
begin
FDownloadDaemon.Resume;
FPaused := False;
end else
begin
FDownloadDaemon.Suspend;
FPaused := True;
end;
if FPaused then
FState := drPaused
else
FState := drDownloading;} {$warning pause system need complete rewrite}
end;
function TDownloader.StartDownload: Boolean;
begin
Result := True;
if Trim(FUrl) = '' then
raise Exception.Create(rsExceptEmptyAddress);
if Copy(FUrl, 1, 7) = sHttpPrefix then
begin // HTTP protocol
if InitHttp(False) then
try
FProtocol := prHttp;
FOnProgress := @ProgressReport;
FOnDownloadComplete := @HTTPComplete;
FState := drDownloading;
DoDownload;
except
FState := drError;
Result := False;
end else
begin
FState := drError;
Result := False;
end;
end else
begin // FTP protocol
if Copy(Furl, 1, 6) <> sFtpPrefix then
begin
FState := drError;
Result := False;
raise Exception.Create(rsExceptUnsupportedProtocol);
end;
if InitFtp(False) then
try
FProtocol := prFtp;
FOnProgress := @ProgressReport;
FOnDownloadComplete := @FTPComplete;
FState := drDownloading;
DoDownload;
except
FState := drError;
Result := False;
end else
begin
FState := drError;
Result := False;
end;
end;
end;
procedure TDownloader.HTTPComplete;
var
Ok: Boolean;
I: Integer;
NewUrl: string;
begin
Ok := FDwlOk;
if Ok and (((FHttp.ResultCode >= 100) and (FHttp.ResultCode <= 299)) or
(FHttp.ResultCode = 0)) then
begin // success
FHttp.Document.Position := 0;
FHttp.Document.SaveToFile(FFile);
FResponse := 'Finished: ' + FStatus;
if Assigned(FDownloadFeedback) then
FDownloadFeedback(FResponse);
FHttp.Clear;
if Assigned(FDownloadFeedback) then
FDownloadFeedback(FStatus);
FState := drDone;
end else
if (FHttp.ResultCode = 301) or (FHttp.ResultCode = 302) or
(FHttp.ResultCode = 307) then
begin
for I := 0 to FHttp.Headers.Count - 1 do
begin
if UpperCase(Copy(FHttp.Headers[I], 1, 9)) = 'LOCATION:' then
begin
NewUrl := Trim(Copy(FHttp.Headers[I], 10, 9999));
if (NewUrl = FUrl) or (NewUrl = FFirstUrl) then
begin
Ok := False;
FState := drError;
end else
begin
FStatus := 'Redirect to: ' + NewUrl;
if Assigned(FDownloadFeedback) then
FDownloadFeedback(FStatus);
FUrl := NewUrl;
StartDownload;
Exit;
end;
end;
end;
Ok := False;
end else
begin // error
Ok := False;
if FHttp.ResultCode = 0 then
FResponse := 'Finished: '+ FStatus +' / Error: Timeout '+
FHttp.ResultString
else
FResponse := 'Finished: '+ FStatus + ' / Error: '+
IntToStr(FHttp.ResultCode) + ' ' + FHttp.ResultString;
FStatus := FResponse;
FHttp.Clear;
if FState <> drCanceled then
FState := drError;
end;
end;
procedure TDownloader.FTPComplete;
var
Ok: Boolean;
begin
Ok := FDwlOk;
FResponse := FStatus;
if Ok then
begin
FFtp.Sock.OnStatus := nil;
FFtp.OnStatus := nil;
FFtp.Logout;
FState := drDone;
end else
begin
FFtp.Sock.OnStatus := nil;
FFtp.OnStatus := nil;
FFtp.Abort;
FStatus := FResponse;
if FState <> drCanceled then
FState := drError;
end;
end;
procedure TDownloader.ProgressReport;
begin
FStatus := FProgressText;
if Assigned(FDownloadFeedback) then
FDownloadFeedback(FStatus);
end;
initialization
end.
common/udownloadmanager.pas
+518
View File
@@ -0,0 +1,518 @@
{
********************************************************************************
SPackGui
Copyright (C) 2012-2013 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
Copyright (C) <date> <add your name and mail address here>
http://www.geoffray-levasseur.org/
http://0.tuxfamilly.org/
This software is governed by the CeCILL license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/ or redistribute the software under the terms of the CeCILL
license as circulated by CEA, CNRS and INRIA at the following URL
"http://www.cecill.info".
As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided only
with a limited warranty and the software's author, the holder of the
economic rights, and the successive licensors have only limited
liability.
In this respect, the user's attention is drawn to the risks associated
with loading, using, modifying and/or developing or reproducing the
software by the user in light of its specific status of free software,
that may mean that it is complicated to manipulate, and that also
therefore means that it is reserved for developers and experienced
professionals having in-depth computer knowledge. Users are therefore
encouraged to load and test the software's suitability as regards their
requirements in conditions enabling the security of their systems and/or
data to be ensured and, more generally, to use and operate it in the
same conditions as regards security.
The fact that you are presently reading this means that you have had
knowledge of the CeCILL license and that you accept its terms.
********************************************************************************
Description:
full download manager class
********************************************************************************
}
unit uDownloadManager;
{$include defines.inc}
interface
uses
Classes, SysUtils, uDownload, ExtCtrls;
type
TProxy = record
Address: string;
Port: Integer;
User: string;
Pass: string;
end;
TDownloadListLoop = class(TThread)
private
FOnNextFile: TDownloadProc;
FOnTerminate: TDownloadProc;
FOnProgress: TDownloadProc;
FOnError: TDownloadProc;
FOnNewDownload: TDownloadProc;
public
FTargetDir: string;
PDownloadIndex: ^Integer;
PDownloadList: ^TStringList;
PDownloader: ^TDownloader;
constructor Create; virtual;
procedure Execute; override;
property OnNextFile: TDownloadProc read FOnNextFile write FOnNextFile;
property OnTerminate: TDownloadProc read FOnTerminate write FOnTerminate;
property OnProgress: TDownloadProc read FOnProgress write FOnProgress;
property OnError: TDownloadProc read FOnError write FOnError;
property OnNewDownload: TDownloadProc read FOnNewDownload
write FOnNewDownload;
end;
TStateChangeEvent = procedure(Sender: TObject;
var State: TDownloadResult) of object;
TDownloadManager = class(TComponent)
private
FOnCreate: TNotifyEvent;
FOnDestroy: TNotifyEvent;
FOnNextFile: TNotifyEvent;
FOnNewDownload: TNotifyEvent;
FOnProgress: TNotifyEvent;
FOnError: TNotifyEvent;
FOnStartDownload: TNotifyEvent;
FOnEndDownload: TNotifyEvent;
FOnCalcSpeeds: TNotifyEvent;
FOnGetSize: TNotifyEvent;
FOnStateChange: TStateChangeEvent;
FOnCancelFile: TNotifyEvent;
FOnCancelAll: TNotifyEvent;
FDownloadList: TStringList;
FErrorList: TStringList;
FDwlLoop: TDownloadListLoop;
FDestination: string;
FTotalSize: LongInt;
FFileSize: LongInt;
FTotalDownloadedSize: LongInt;
FDwlSizeSum: LongInt;
FFileDownloadedSize: LongInt;
FPause: Boolean;
FDownloadIndex: Integer;
FDownloader: TDownloader;
FState, FOldState: TDownloadResult;
FCurrentSpeed: LongInt; // calculated every seconds in B/s
FTotalTime: LongInt; //in seconds
FFileTime: LongInt;
FFileMaxSpeed: LongInt;
FFileMinSpeed: LongInt;
FFileAverageSpeed: LongInt;
FTotalMaxSpeed: LongInt;
FTotalMinSpeed: LongInt;
FTotalAverageSpeed: LongInt;
FTimer: TTimer; // used to calculate speeds
FHttpProxy: TProxy;
FFtpProxy: TProxy;
FFtpUser: string;
FFtpPassword: string;
FDownloaderStatusText: string;
procedure ResetFileVars;
procedure DwlNextFile;
procedure DwlTerminate;
procedure DwlProgress;
procedure DwlError;
procedure DwlNewFile;
procedure CheckState;
procedure SetDwlList(Value: TStringList);
procedure SetDownloadIndex(Value: Integer);
procedure TimerExecute(Sender: TObject);
procedure DownloadFeedback(Txt: string);
public
constructor Create(AOwner: TComponent); virtual;
destructor Destroy; override;
procedure Cancel(OnlyCurrent: Boolean);
procedure StartDownload;
function GetFileSize(Index: integer): LongInt;
procedure GetTotalSize;
procedure Pause;
property DownloadList: TStringList read FDownloadList write SetDwlList;
property DownloadIndex: Integer read FDownloadIndex write SetDownLoadIndex;
property ErrorList: TStringList read FErrorList;
property Destination: string read FDestination write FDestination;
property Status: TDownloadResult read FState;
property TotalSize: LongInt read FTotalSize;
property CurrentSpeed: LongInt read FCurrentSpeed;
property FileDownloadedSize: LongInt read FFileDownloadedSize;
property FileMinSpeed: LongInt read FFileMinSpeed;
property FileMaxSpeed: LongInt read FFileMaxSpeed;
property FileAverageSpeed: LongInt read FFileAverageSpeed;
property TotalDownloadedSize: LongInt read FTotalDownloadedSize;
property TotalMinSpeed: LongInt read FTotalMinSpeed;
property TotalMaxSpeed: LongInt read FTotalMaxSpeed;
property TotalAverageSpeed: LongInt read FTotalAverageSpeed;
property DownloaderStatus: string read FDownloaderStatusText;
property HttpProxy: TProxy read FHttpProxy write FHttpProxy;
property FtpProxy: TProxy read FFtpProxy write FFtpProxy;
property FtpUser: string read FFtpUser write FFtpUser;
property FtpPassword: string read FFtpPassword write FFtpPassword;
property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
property OnNextFile: TNotifyEvent read FOnNextFile write FOnNextFile;
property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
property OnNewDownload: TNotifyEvent read FOnNewDownload
write FOnNewDownload;
property OnError: TNotifyEvent read FOnError write FOnError;
property OnCalcSpeeds: TNotifyEvent read FOnCalcSpeeds write FOnCalcSpeeds;
property OnStartDownload: TNotifyEvent read FOnStartDownload
write FOnStartDownload;
property OnEndDownload: TNotifyEvent read FOnEndDownload
write FOnEndDownload;
property OnGetSize: TNotifyEvent read FOnGetSize write FOnGetSize;
property OnStateChange: TStateChangeEvent read FOnStateChange
write FOnStateChange;
property OnCancelFile: TNotifyEvent read FOnCancelFile write FOnCancelFile;
property OnCancelAll: TNotifyEvent read FOnCancelAll write FOnCancelAll;
end;
implementation
uses
uDebug, uStrings;
constructor TDownloadListLoop.Create;
begin
FreeOnTerminate := True;
inherited Create(True);
end;
procedure TDownloadListLoop.Execute;
var
I, J: integer;
begin
PrintLnDbg(rsDebugDownloadListLoopStarted);
try
while PDownloadIndex^ <= PDownloadList^.Count - 1 do
begin
if Terminated then
Break;
if PDownloadIndex^ < 0 then
begin
PrintLnDbg(Format(rsErrorDownloadIndex, [PDownloadIndex^]), vlLow);
Exit;
end;
if Assigned(FOnNewDownload) then
Synchronize(FOnNewDownload);
PDownloader^.StartDownload;
repeat
if Assigned(FOnProgress) then
Synchronize(FOnProgress);
until (PDownloader^.State = drDone) or (PDownloader^.State = drError) or
(PDownloader^.State = drCanceled);
if PDownloader^.State = drError then
if Assigned(FOnError) then
Synchronize(FOnError); //downloading again needs manual index management
if PDownloadIndex^ < 0 then //in case of cancellation
Break;
if Assigned(FOnNextFile) then
Synchronize(FOnNextFile) //manual management of download index
else
Inc(PDownloadIndex^); //or automatic (forced)
end;
if Assigned(FOnTerminate) then
Synchronize(FOnTerminate);
except
on E: Exception do
heHandleException.ThreadException(E, Self);
end;
PrintLnDbg(rsDebugDownloadListLoopStopped);
end;
constructor TDownloadManager.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDownloader := TDownloader.Create;
FDownloadList := TStringList.Create;
FErrorList := TStringList.Create;
FTimer := TTimer.Create(nil);
FTimer.Interval := 1000;
FTimer.Enabled := False;
FTimer.OnTimer := @TimerExecute;
FFtpPassword := '';
FFtpUser := '';
FHttpProxy.Address := '';
FHttpProxy.Port := 0;
FHttpProxy.User := '';
FHttpProxy.Pass := '';
FFtpProxy.Address := '';
FFtpProxy.Port := 0;
FFtpProxy.User := '';
FFtpProxy.Pass := '';
FDownloadIndex := -1;
FDestination := '';
ResetFileVars;
FTotalDownloadedSize := 0;
FTotalSize := 0;
FTotalTime := 0;
FTotalAverageSpeed := 0;
FTotalMaxSpeed := 0;
FTotalMinSpeed := 0;
FCurrentSpeed := 0;
FState := drNone;
FDownloader.OnFeedback := @DownloadFeedback;
FDownloaderStatusText := '';
if Assigned(FOnCreate) then
FOnCreate(Self);
end;
procedure TDownloadManager.DownloadFeedback(Txt: string);
begin
FDownloaderStatusText := Txt;
{$IFDEF Debug}
PrintLnDbg(rsDebugDownloadFeedback + Txt, vlHigh);
{$ENDIF}
end;
destructor TDownloadManager.Destroy;
begin
if Assigned(FOnDestroy) then
FOnDestroy(Self);
if (FState = drDownloading) or (FState = drPaused) then
FDownloader.Cancel;
FDownloader.Free;
FDownloadList.Free;
FTimer.Free;
inherited Destroy;
end;
procedure TDownloadManager.CheckState;
begin
if FState <> FDownloader.State then
begin
FState := FDownloader.State;
if Assigned(FOnStateChange) then
FOnStateChange(Self, FState);
end;
end;
procedure TDownloadManager.ResetFileVars;
begin
FFileTime := 0;
FFileSize := 0;
FFileAverageSpeed := 0;
FFileMaxSpeed := 0;
FFileMinSpeed := 0;
FFileDownloadedSize := 0;
end;
procedure TDownloadManager.DwlNextFile;
begin
CheckState;
if (FState = drDone) or (FState = drError) then
begin
FTimer.Enabled := False;
FDwlSizeSum := FDwlSizeSum + FFileSize;
if Assigned(FOnNextFile) then
FOnNextFile(Self)
else
Inc(FDownloadIndex);
end;
end;
procedure TDownloadManager.DwlTerminate;
begin
CheckState;
ResetFileVars;
if Assigned(FOnEndDownload) then
FOnEndDownload(Self);
FDwlLoop.OnError := nil;
FDwlLoop.OnNewDownload := nil;
FDwlLoop.OnNextFile := nil;
FDwlLoop.OnProgress := nil;
FDwlLoop.OnTerminate := nil;
FDownloaderStatusText := '';
end;
procedure TDownloadManager.DwlProgress;
begin
CheckState;
FFileDownloadedSize := FDownloader.DownloadedSize;
FTotalDownloadedSize := FDwlSizeSum + FFileDownloadedSize;
if Assigned(FOnProgress) then
FOnProgress(Self);
end;
procedure TDownloadManager.DwlError;
begin
FErrorList.Add(FDownloadList[FDownloadIndex]);
if Assigned(FOnError) then
FOnError(Self);
FDownloaderStatusText := '';
end;
procedure TDownloadManager.DwlNewFile;
begin
ResetFileVars;
if Assigned(FOnNewDownload) then
FOnNewDownload(Self);
FDownloader.URL := FDownloadList[FDownloadIndex];
FFileSize := FDownloader.FileSize;
FTimer.Enabled := True;
FDownloader.SaveToFile := FDestination;
FDownloader.FtpUserName := FFtpUser;
FDownloader.FtpPassword := FFtpPassword;
end;
procedure TDownloadManager.SetDwlList(Value: TStringList);
begin
if Value <> FDownloadList then
if (FState = drDownloading) or (FState = drPaused) then
begin
raise
Exception.Create('Can''t change of StringList while downloading.');
Exit;
end else
FDownloadList := Value;
end;
procedure TDownloadManager.SetDownloadIndex(Value: integer);
begin
if (FState = drDownloading) or (FState = drPaused) then
begin
raise
Exception.Create('Can''t change index while downloading.');
Exit;
end;
FDownloadIndex := Value;
end;
procedure TDownloadManager.Cancel(OnlyCurrent: Boolean);
begin
if (FState = drDownloading) or (FState = drPaused) then
if OnlyCurrent then
begin
FDownloader.Cancel;
if Assigned(FOnCancelFile) then
FOnCancelFile(Self);
end else
begin
FDownloadIndex := -1;
FDwlLoop.OnError := nil;
FDwlLoop.OnNewDownload := nil;
FDwlLoop.OnNextFile := nil;
FDwlLoop.OnProgress := nil;
FDwlLoop.OnTerminate := nil;
FDownloader.Cancel;
end;
FDownloaderStatusText := '';
end;
procedure TDownloadManager.StartDownload;
begin
FTotalDownloadedSize := 0;
FTotalSize := 0;
FTotalTime := 0;
FTotalAverageSpeed := 0;
FTotalMaxSpeed := 0;
FTotalMinSpeed := 0;
FCurrentSpeed := 0;
if DownloadList.Count > 0 then
begin
FDownloader.HttpProxy := FHttpProxy.Address;
FDownloader.HttpProxyPass := FHttpProxy.Pass;
FDownloader.HttpProxyPort := IntToStr(FHttpProxy.Port);
FDownloader.HttpProxyUser := FHttpProxy.User;
FDownloader.FtpFwHost := FFtpProxy.Address;
FDownloader.FtpFwPort := IntToStr(FFtpProxy.Port);
FDownloader.FtpFwUserName := FFtpProxy.User;
FDownloader.FtpFwPassword := FFtpProxy.Pass;
FErrorList.Clear;
FDwlLoop := TDownloadListLoop.Create;
FDwlLoop.OnError := @DwlError;
FDwlLoop.OnNewDownload := @DwlNewFile;
FDwlLoop.OnNextFile := @DwlNextFile;
FDwlLoop.OnProgress := @DwlProgress;
FDwlLoop.OnTerminate := @DwlTerminate;
FDwlLoop.PDownloader := @FDownloader;
FDwlLoop.PDownloadIndex := @FDownloadIndex;
FDwlLoop.PDownloadList := @FDownloadList;
if Assigned(FOnStartDownload) then
FOnStartDownload(Self)
else
FDownloadIndex := 0;
FDwlLoop.PDownloadIndex := @FDownloadIndex;
FTimer.Enabled := True;
FDwlLoop.Execute;
end;
end;
function TDownloadManager.GetFileSize(Index: Integer): LongInt;
begin
FDownloader.URL := FDownloadList[Index];
Result := FDownloader.FileSize;
end;
procedure TDownloadManager.GetTotalSize;
var
I, Size: Integer;
begin
FTotalSize := 0;
for I := 0 to FDownloadList.Count - 1 do
try
Size := GetFileSize(I);
if (Size < 0) and Assigned(FOnError) then
FOnError(Self);
FTotalSize := FTotalSize + Size;
if Assigned(FOnGetSize) then
FOnGetSize(Self);
except
PrintLnDbg(Format(rsErrorCantGetFileSze, [FDownloadList[I]]), vlLow);
end;
end;
procedure TDownloadManager.Pause;
begin
CheckState;
FDownloader.Pause;
FTimer.Enabled := FDownloader.State <> drDownloading;
CheckState;
end;
procedure TDownloadManager.TimerExecute(Sender: TObject);
begin
Inc(FTotalTime);
Inc(FFileTime);
//do the stuff
if Assigned(FOnCalcSpeeds) then
FOnCalcSpeeds(Self);
end;
end.
common/uiconmanager.pas
+251
View File
@@ -0,0 +1,251 @@
{
********************************************************************************
SPackGui (common files)
Copyright (C) 2009-2013 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
Copyright (C) <date> <add your name and mail address here>
http://0.tuxfamilly.org/
http://www.geoffray-levasseur.org/
This software is governed by the CeCILL license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/ or redistribute the software under the terms of the CeCILL
license as circulated by CEA, CNRS and INRIA at the following URL
"http://www.cecill.info".
As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided only
with a limited warranty and the software's author, the holder of the
economic rights, and the successive licensors have only limited
liability.
In this respect, the user's attention is drawn to the risks associated
with loading, using, modifying and/or developing or reproducing the
software by the user in light of its specific status of free software,
that may mean that it is complicated to manipulate, and that also
therefore means that it is reserved for developers and experienced
professionals having in-depth computer knowledge. Users are therefore
encouraged to load and test the software's suitability as regards their
requirements in conditions enabling the security of their systems and/or
data to be ensured and, more generally, to use and operate it in the
same conditions as regards security.
The fact that you are presently reading this means that you have had
knowledge of the CeCILL license and that you accept its terms.
********************************************************************************
Description:
Icons "on the fly" manager
********************************************************************************
}
unit uIconManager;
{$include defines.inc}
interface
uses
Controls, Classes, SysUtils, Forms, Graphics;
const
DefaultButtonIcon = 'dialog-cancel.png';
NumberOfIcons = 49;
//the following is actual freedesktop standard :
NewIconNames: array[0..NumberOfIcons - 1] of string =
('document-new.png', 'document-new-from-template.png', //0
'document-open.png', 'view-refresh.png', //2
'document-save.png', 'document-save-all.png', //4
'dialog-close.png', 'document-print.png', //6
'document-preview.png', 'application-exit.png', //8
'document-print-preview.png', 'edit-undo.png', //10
'edit-redo.png', 'edit-cut.png', //12
'edit-copy.png', 'edit-paste.png', //14
'preferences-system-time.png', 'insert-text.png', //16
'mail-send.png', 'document-save-as.png', //18
'document-export.png', 'document-open-recent.png', //20
'dialog-ok.png', 'dialog-cancel.png', //22
'dialog-ok-apply.png', 'dialog-close.png', //24
'help-about.png', 'edit-find.png', //26
'go-next.png', 'go-previous.png', //28
'go-jump.png', 'help-contents.png', //30
'edit-clear.png', 'applications-system.png', //32
'configure.png', 'help-hint.png', //34
'list-add.png', 'list-remove.png', //36
'im-status-message-edit.png', 'arrow-down.png', //38
'arrow-up.png', 'media-playback-pause.png', //40
'document-properties.png', 'edit-select-all.png', //42
'video-display.png', 'tools-report-bug.png', //44
'help-contents.png', 'repository.png', //46
'preferences-desktop-font.png');
//this is more easy than learning icon's index
const
icClose = 6;
icCancel = 23;
icYes = 22;
icNo = 6;
icOk = 22;
icApply = 24;
icNew = 0;
icOpen = 2;
icSave = 4;
icSaveAll = 5;
icExit = 9;
icUndo = 11;
icRedo = 12;
icCopy = 14;
icCut = 13;
icPaste = 15;
icRefresh = 3;
icAbout = 26;
icSearch = 27;
icAdd = 36;
icChange = 38;
icRemove = 37;
icDelete = icRemove;
icUp = 34;
icDown = 39;
icSystem = 33;
icProperties = 42;
icSettings = 34;
icParameters = icSettings;
icPause = 41;
icDisplay = 44;
icSelectAll = 43;
icReportBug = 45;
icManual = 46;
icRepository = 47;
icFontSettings = 48;
var
ilDefault: TImageList;
//load a new theme and apply the changes
procedure LoadIconSet(Path: string);
//set button icons on the fly
procedure InitBtnGlyphs(Form: TForm);
//for color configuration create an icon on the fly showing the selected color
function CreateColorGlyph(Color: TColor; Width, Height: integer): TBitmap;
implementation
uses
Dialogs, Buttons, uUtils, uDebug;
function CreateColorGlyph(Color: TColor; Width, Height: integer): TBitmap;
var
X, Y: integer;
begin
//create an empty bitmap and set its size
Result := TBitmap.Create;
Result.SetSize(Width, Height);
//fill it with the given color
for X := 0 to Width do
for Y := 0 to Height do
Result.Canvas.Pixels[X, Y] := Color;
end;
function AddIcon(Index: Integer; Path: string): Boolean;
var
Bitmap: TPortableNetworkGraphic;
X, Y: integer;
begin
PrintDbg('i Add icon "' + Path + NewIconNames[Index] + '"... ', vlHigh);
//only png format is supported
try
Result := True;
try
Bitmap := TPortableNetworkGraphic.Create;
if not FileExists(Path + NewIconNames[Index]) then //the icon is not present
begin
//we have to create an empty bitmap (and hopping it's gonna be seen as all transparent)
PrintDbg('not fount, create empty one: ', vlHigh);
Bitmap.SetSize(ilDefault.Width, ilDefault.Height);
for X := 0 to ilDefault.Width do
for Y := 0 to ilDefault.Height do
//actually this draw a boxed X
if (X = Y) or (ilDefault.Width - X = Y + 1) or (X = 0) or (Y = 0) or
(X = ilDefault.Width - 1) or (Y = ilDefault.Height - 1) then
Bitmap.Canvas.Pixels[X, Y] := clBtnText
else
Bitmap.Canvas.Pixels[X, Y] := clBtnFace;
//set transparancy settings
Bitmap.TransparentColor := clBtnFace;
Bitmap.Transparent := True;
end else
begin
//load the bitmap and set transparency on
Bitmap.LoadFromFile(Path + NewIconNames[Index]);
Bitmap.Transparent := True;
end;
//add this to the image list
ilDefault.Add(Bitmap, nil);
except
Result := False;
end;
finally
Bitmap.Free;
end;
PrintDbgResult(Result, vlHigh)
end;
procedure LoadIconSet(Path: string);
var
IconBaseDir: string;
I: Integer;
begin
IconBaseDir := Path;
if IconBaseDir[Length(IconBaseDir)] <> DirectorySeparator then
IconBaseDir := IconBaseDir + DirectorySeparator;
//check iconset existance
if not DirectoryExists(IconBaseDir) then
begin
//if unavailable rolling back to Oxygen
PrintLnDbg('E uIconManager.LoadIconSet: "' + IconBaseDir +
'" directory does not exists!', vlHigh);
PrintLnDbg('W uIconManager.LoadIconSet: The application ' +
'may look uggly but should be usable.', vlHigh);
end;
try
//free the image list to be sure it'll not poluted with previous datas
ilDefault.Free;
finally
//create an image liste with the good size
ilDefault := TImageList.CreateSize(22, 22);
end;
PrintLnDbg('i Initializing icon set done.', vlHigh);
//add the icons in the newly created image list
for I:= 0 to NumberOfIcons - 1 do
AddIcon(I, IconBaseDir);
end;
procedure InitBtnGlyphs(Form: TForm);
var
I: integer;
Bitmap: TBitmap;
begin
for I := 0 to Form.ComponentCount - 1 do
if (Form.Components[I] is TBitBtn) and (Form.Components[I].Tag <> -1) then
try
PrintDbg('i Init "' + Form.Components[I].Name + '" button glyph... ',
vlHigh);
Bitmap := TBitmap.Create;
ilDefault.GetBitmap((Form.Components[I] as TBitBtn).Tag, Bitmap);
(Form.Components[I] as TBitBtn).Glyph := Bitmap;
PrintDbgResult(True, vlHigh);
except
PrintDbgResult(False, vlHigh);
end;
end;
initialization
end.
common/ulistviewcolors.pas
+141
View File
@@ -0,0 +1,141 @@
{
********************************************************************************
SPackGui
Copyright (C) 2000-2012 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
http://www.geoffray-levasseur.org/
This software is governed by the CeCILL license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/ or redistribute the software under the terms of the CeCILL
license as circulated by CEA, CNRS and INRIA at the following URL
"http://www.cecill.info".
As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided only
with a limited warranty and the software's author, the holder of the
economic rights, and the successive licensors have only limited
liability.
In this respect, the user's attention is drawn to the risks associated
with loading, using, modifying and/or developing or reproducing the
software by the user in light of its specific status of free software,
that may mean that it is complicated to manipulate, and that also
therefore means that it is reserved for developers and experienced
professionals having in-depth computer knowledge. Users are therefore
encouraged to load and test the software's suitability as regards their
requirements in conditions enabling the security of their systems and/or
data to be ensured and, more generally, to use and operate it in the
same conditions as regards security.
The fact that you are presently reading this means that you have had
knowledge of the CeCILL license and that you accept its terms.
********************************************************************************
Description:
Some colors declaration and manipulation along ListView and SPack
********************************************************************************
}
unit uListViewColors;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Graphics, uSpackPackage;
var
clUpdatablePackageFont: TColor;
clOutdatedPackageFont: TColor;
clPackageToInstallFont: TColor;
clPackageToUpgradeFont: TColor;
clPackageToRemoveFont: TColor;
clUpdatablePackageBack: TColor;
clOutdatedPackageBack: TColor;
clPackageToInstallBack: TColor;
clPackageToUpgradeBack: TColor;
clPackageToRemoveBack: TColor;
procedure LoadColors;
procedure SaveColors;
//give colors depending on pkgstatus
procedure GetColorFromState(const State: TPkgState; out FG, BG: TColor);
implementation
uses
uCommon, uStrings;
procedure LoadColors;
begin
clUpdatablePackageFont := iniMain.ReadInteger(rsConfSectionListViewColors,
rsConfNameUpdatablePackageFont, clGreen);
clUpdatablePackageBack := iniMain.ReadInteger(rsConfSectionListViewColors,
rsConfNameUpdatablePackageBack, clDefault);
clOutdatedPackageFont := iniMain.ReadInteger(rsConfSectionListViewColors,
rsConfNameOutdatedPackageFont, clRed);
clOutdatedPackageBack := iniMain.ReadInteger(rsConfSectionListViewColors,
rsConfNameOutdatedPackageBack, clDefault);
clPackageToInstallFont := iniMain.ReadInteger(rsConfSectionListViewColors,
rsConfNamePackageToInstallFont, clWhite);
clPackageToInstallBack := iniMain.ReadInteger(rsConfSectionListViewColors,
rsConfNamePackageToInstallBack, clGreen);
clPackageToUpgradeFont := iniMain.ReadInteger(rsConfSectionListViewColors,
rsConfNamePackageToUpgradeFont, clBlack);
clPackageToUpgradeBack := iniMain.ReadInteger(rsConfSectionListViewColors,
rsConfNamePackageToUpgradeBack, clYellow);
clPackageToRemoveFont := iniMain.ReadInteger(rsConfSectionListViewColors,
rsConfNamePackageToRemoveFont, clWhite);
clPackageToRemoveBack := iniMain.ReadInteger(rsConfSectionListViewColors,
rsConfNamePackageToRemoveBack, clRed);
end;
procedure SaveColors;
begin
iniMain.WriteInteger(rsConfSectionListViewColors,
rsConfNameUpdatablePackageFont, clUpdatablePackageFont);
iniMain.WriteInteger(rsConfSectionListViewColors,
rsConfNameUpdatablePackageBack, clUpdatablePackageBack);
iniMain.WriteInteger(rsConfSectionListViewColors,
rsConfNameOutdatedPackageFont, clOutdatedPackageFont);
iniMain.WriteInteger(rsConfSectionListViewColors,
rsConfNameOutdatedPackageBack, clOutdatedPackageBack);
iniMain.WriteInteger(rsConfSectionListViewColors,
rsConfNamePackageToInstallFont, clPackageToInstallFont);
iniMain.WriteInteger(rsConfSectionListViewColors,
rsConfNamePackageToInstallBack, clPackageToInstallBack);
iniMain.WriteInteger(rsConfSectionListViewColors,
rsConfNamePackageToUpgradeFont, clPackageToUpgradeFont);
iniMain.WriteInteger(rsConfSectionListViewColors,
rsConfNamePackageToUpgradeBack, clPackageToUpgradeBack);
iniMain.WriteInteger(rsConfSectionListViewColors,
rsConfNamePackageToRemoveFont, clPackageToRemoveFont);
iniMain.WriteInteger(rsConfSectionListViewColors,
rsConfNamePackageToRemoveBack, clPackageToRemoveBack);
end;
procedure GetColorFromState(const State: TPkgState; out FG, BG: TColor);
begin
//keep widget set default color
FG := clDefault;
BG := clDefault;
if psDeprecated in State then
begin
FG := clOutdatedPackageFont;
Bg := clOutdatedPackageBack;
end else
if psUpdatable in State then
begin
FG := clUpdatablePackageFont;
BG := clUpdatablePackageBack;
end;
//actions overide the previous declarations
//get action to be done here if any
end;
end.
common/upackagemanager.pas
+885
View File
@@ -0,0 +1,885 @@
{
********************************************************************************
SPackGui
Copyright (C) 2012-2013 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
Copyright (C) <date> <add your name and mail address here>
http://www.geoffray-levasseur.org/
http://0.tuxfamilly.org/
This software is governed by the CeCILL license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/ or redistribute the software under the terms of the CeCILL
license as circulated by CEA, CNRS and INRIA at the following URL
"http://www.cecill.info".
As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided only
with a limited warranty and the software's author, the holder of the
economic rights, and the successive licensors have only limited
liability.
In this respect, the user's attention is drawn to the risks associated
with loading, using, modifying and/or developing or reproducing the
software by the user in light of its specific status of free software,
that may mean that it is complicated to manipulate, and that also
therefore means that it is reserved for developers and experienced
professionals having in-depth computer knowledge. Users are therefore
encouraged to load and test the software's suitability as regards their
requirements in conditions enabling the security of their systems and/or
data to be ensured and, more generally, to use and operate it in the
same conditions as regards security.
The fact that you are presently reading this means that you have had
knowledge of the CeCILL license and that you accept its terms.
********************************************************************************
Description:
Package manager class
********************************************************************************
}
unit uPackageManager;
{$include defines.inc}
interface
uses
Classes, SysUtils, uDownloadManager, uSpackPackage;
type
TPackageList = class;
TPackageListSortCompare = function(List: TPackageList;
Index1, Index2: Integer): Integer;
TSortType = (stName, stVersion, stBuild, stDesc, stState, stCat, stSize,
stInstSize, stSource, stSourceType);
PPkgItem = ^TPkgItem;
TPkgItem = record
FPkg: TSPackPackage;
FObject: TObject;
end;
PPkgItemList = ^TPkgItemList;
TPkgItemList = array[0..MaxListSize] of TPkgItem; //maxlistsize depends on arch
TProgressProc = procedure(const Min, Max, Pos: LongInt; const Msg: string);
TPackageList = class(TPersistent)
private
FList: PPkgItemList;
FCount: Integer;
FCapacity: Integer;
FOwnsObjects: Boolean;
FUpdateCount: Integer;
FOnChange: TNotifyEvent;
FOnChanging: TNotifyEvent;
FUpdating: Boolean;
FCaseSensitive: Boolean;
FInstPackageDir: string;
FInstPackageLoaded: Boolean;
FProgressProc: TProgressProc;
FDistantRepoList: TStringList;
FLocalRepoList: TStringList;
FDownloadManager: TDownloadManager;
FConfigDir: string;
procedure Grow;
procedure InternalClear;
procedure SetInstPackageDir(const ADir: string);
procedure Error(Msg: string; Index: Integer);
procedure DwlManProgress(AOwner: TObject);
procedure DwlManError(AOwner: TObject);
procedure DwlManNewFile(AOwner: TObject);
procedure DwlManNextFile(AOwner: TObject);
procedure DwlManStartDownload(AOwner: TObject);
function DoCompareText(const S1, S2 : string) : PtrInt;
procedure GetDistantRepoInfo(const Repo: string; out Name, Address: string);
protected
procedure SetUpdateState(Updating: Boolean);
procedure Changed; virtual;
procedure Changing; virtual;
function GetCapacity: Integer; virtual;
function GetCount: Integer; virtual;
procedure SetCapacity(NewCapacity: Integer); virtual;
function GetObject(Index: Integer): TObject; virtual;
procedure PutObject(Index: Integer; AObject: TObject); virtual;
function GetPackage(Index: Integer): TSPackPackage;
procedure PutPackage(Index: Integer; const Pkg: TSPackPackage); virtual;
procedure InsertItem(Index: Integer; const Pkg: TSPackPackage);
procedure InsertItem(Index: Integer; const Pkg: TSPackPackage;
Obj: TObject);
procedure SetCaseSensitive(B: Boolean);
public
procedure BeginUpdate; //usefull if threaded
procedure EndUpdate;
destructor Destroy; override;
constructor Create;
function Add(const Pkg: TSPackPackage): Integer;
function Find(const S: string; Out Index: Integer): Boolean;
procedure Clear;
procedure Delete(Index: Integer);
function GetPkgFromName(const Name: string): TSPackPackage;
procedure GetInstalledPackages;
function GetInstalledCount: integer;
procedure LoadLocalRepo;
function LoadLocalRepoCount: Integer;
procedure DownloadDistantRepo;
function DownloadDistantRepoCount: integer;
procedure LoadDistantRepo(const Name: string);
function LoadDistantRepoCount(const Name: string): Integer;
procedure SetDeprecated(DeprecatedList: TStrings);
property Capacity: Integer read GetCapacity write SetCapacity;
property Packages[Index: Integer]: TSPackPackage read GetPackage
write PutPackage;
property Objects[Index: Integer]: TObject read GetObject write PutObject;
property Count: Integer read GetCount;
property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive;
property InstPackageLoaded: Boolean read FInstPackageLoaded;
property InstPackageDir: string read FInstPackageDir write SetInstPackageDir;
property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;
property DistantRepoList: TStringList read FDistantRepoList
write FDistantRepoList;
property LocalRepoList: TStringList read FLocalRepoList write FLocalRepoList;
property ConfigDir: string read FConfigDir write FConfigDir;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
property OnProgress: TProgressProc read FProgressProc write FProgressProc;
end;
implementation
uses
uDebug, uStrings, uCommon, uUtils, FileUtil, Forms, uDownload;
const
WordRatio = SizeOf(Pointer) div SizeOf(Word);
///////////////////////////////////////////////////////////// TPackageList class
//______________________________________________________________________________
procedure TPackageList.Error(Msg: string; Index: Integer);
begin
{$warning Error management to be done}
end;
procedure TPackageList.SetUpdateState(Updating: Boolean);
begin
FUpdating := Updating;
end;
procedure TPackageList.BeginUpdate;
begin
if FUpdateCount = 0 then
SetUpdateState(True);
Inc(FUpdateCount);
end;
procedure TPackageList.EndUpdate;
begin
if FUpdateCount > 0 then
Dec(FUpdateCount);
if FUpdateCount = 0 then
SetUpdateState(False);
end;
procedure TPackageList.InternalClear;
var
I: Integer;
begin
if FOwnsObjects then
begin
for I := 0 to FCount - 1 do
begin
FreeAndNil(FList^[I].FPkg);
FreeAndNil(FList^[I].FObject);
end;
end else
begin
for I := 0 to FCount - 1 do
FreeAndNil(FList^[I].FPkg);
end;
FCount := 0;
SetCapacity(0);
end;
function TPackageList.GetCapacity: Integer;
begin
Result := FCapacity;
end;
procedure TPackageList.SetCapacity(NewCapacity: Integer);
var
NewList: Pointer;
MSize: Longint;
begin
if (NewCapacity < 0) then
Error(rsErrorCapacity, NewCapacity);
if NewCapacity > FCapacity then
begin
GetMem(NewList, NewCapacity * SizeOf(TPkgItem));
if NewList = nil then
Error(rsErrorCapacity, NewCapacity);
if Assigned(FList) then
begin
MSize := FCapacity * Sizeof(TPkgItem);
System.Move(FList^, NewList^, MSize);
FillWord(Pchar(NewList)[MSize], (NewCapacity - FCapacity) * WordRatio, 0);
FreeMem(Flist, MSize);
end;
Flist := NewList;
FCapacity := NewCapacity;
end else
if NewCapacity<FCapacity then
begin
if NewCapacity = 0 then
begin
FreeMem(FList);
FList := nil;
end else
begin
GetMem(NewList, NewCapacity * SizeOf(TPkgItem));
System.Move(FList^, NewList^, NewCapacity * SizeOf(TPkgItem));
FreeMem(FList);
FList := NewList;
end;
FCapacity := NewCapacity;
end;
end;
function TPackageList.GetCount: Integer;
begin
Result := FCount;
end;
function TPackageList.GetObject(Index: Integer): TObject;
begin
if (Index < 0) or (Index >= FCount) then
Error(rsErrorPkgListIndex, Index);
Result := Flist^[Index].FObject;
end;
procedure TPackageList.PutObject(Index: Integer; AObject: TObject);
begin
If (Index < 0) or (Index >= FCount) then
Error(rsErrorPkgListIndex, Index);
Changing;
Flist^[Index].FObject := AObject;
Changed;
end;
procedure TPackageList.Grow;
var
NewCapacity: Integer;
begin
NewCapacity := FCapacity;
if NewCapacity >= 256 then
NewCapacity := NewCapacity + (NewCapacity div 4)
else
if NewCapacity = 0 then
NewCapacity := 4
else
NewCapacity := NewCapacity * 4;
SetCapacity(NewCapacity);
end;
function TPackageList.GetPackage(Index: Integer): TSPackPackage;
begin
if (Index < 0) or (Index >= FCount) then
Error(rsErrorPkgListIndex, Index);
Result := FList^[Index].FPkg;
end;
procedure TPackageList.PutPackage(Index: Integer; const Pkg: TSPackPackage);
var
I: integer;
PSt: TPkgState;
begin
if (Index < 0) or (Index >= FCount) then
Error(rsErrorPkgListIndex, Index);
Changing;
Flist^[Index].FPkg := Pkg;
//get global state
PSt := Pkg.State;
for I := 0 to FCount - 1 do
if Pkg.Name = FList^[I].FPkg.Name then
if Pkg.State <> FList^[I].FPkg.State then
PSt := PSt + FList^[I].FPkg.State;
//dispatch it
for I := 0 to FCount - 1 do
if Pkg.Name = FList^[I].FPkg.Name then
FList^[I].FPkg.State := PSt;
Changed;
end;
procedure TPackageList.Changing;
begin
if FUpdateCount = 0 then
if Assigned(FOnChanging) then
FOnChanging(Self);
end;
procedure TPackageList.Changed;
begin
if (FUpdateCount = 0) Then
begin
if Assigned(FOnChange) then
FOnChange(Self);
SetUpdateState(False);
end;
end;
procedure TPackageList.InsertItem(Index: Integer; const Pkg: TSPackPackage);
begin
Changing;
if FCount = FCapacity then
Grow;
if Index < FCount then
System.Move(FList^[Index], FList^[Index + 1],
(FCount - Index) * SizeOf(TPkgItem));
Pointer(FList^[Index].FPkg) := nil; // Needed to initialize...
FList^[Index].FPkg := Pkg;
FList^[Index].FObject := nil;
Inc(FCount);
Changed;
end;
procedure TPackageList.InsertItem(Index: Integer; const Pkg: TSPackPackage;
Obj: TObject);
begin
Changing;
if FCount = FCapacity then
Grow;
if Index < FCount then
System.Move(FList^[Index], FList^[Index + 1],
(FCount - Index) * SizeOf(TStringItem));
Pointer(Flist^[Index].FPkg) := nil; // Needed to initialize...
FList^[Index].FPkg := Pkg;
FList^[Index].FObject := Obj;
Inc(FCount);
Changed;
end;
constructor TPackageList.Create;
begin
FProgressProc := nil;
FLocalRepoList := TStringList.Create;
FDistantRepoList := TStringList.Create;
inherited Create;
end;
destructor TPackageList.Destroy;
begin
InternalClear;
FreeAndNil(FLocalRepoList);
FreeAndNil(FDistantRepoList);
inherited Destroy;
end;
function TPackageList.Add(const Pkg: TSPackPackage): Integer;
begin
Result := Count;
InsertItem(Result, Pkg);
end;
procedure TPackageList.SetCaseSensitive(B: boolean);
begin
if B <> FCaseSensitive then
begin
FCaseSensitive := B;
{$warning ask here for a reload of package list}
end;
end;
function TPackageList.DoCompareText(const S1, S2 : string) : PtrInt;
begin
if FCaseSensitive then
Result := AnsiCompareStr(S1, S2)
else
Result := AnsiCompareText(S1, S2);
end;
function TPackageList.Find(const S: string; out Index: Integer): Boolean;
var
L, R, I: Integer;
CompareRes: PtrInt;
begin
Result := false;
// Use binary search.
L := 0;
R := Count - 1;
while (L <= R) do
begin
I := L + (R - L) div 2;
CompareRes := DoCompareText(S, Flist^[I].FPkg.Name);
if (CompareRes > 0) then
L := I + 1
else begin
R := I - 1;
if (CompareRes = 0) then
Result := true;
end;
end;
Index := L;
end;
procedure TPackageList.Clear;
begin
if FCount = 0 then
Exit;
Changing;
InternalClear;
Changed;
end;
procedure TPackageList.Delete(Index: Integer);
begin
if (Index < 0) or (Index >= FCount) then
Error(rsErrorPkgListIndex, Index);
Changing;
FreeAndNil(Flist^[Index].FPkg);
if FOwnsObjects then
FreeAndNil(Flist^[Index].FObject);
Dec(FCount);
if Index < FCount then
System.Move(Flist^[Index + 1], Flist^[Index],
(Fcount - Index) * SizeOf(TStringItem));
Changed;
end;
function TPackageList.GetPkgFromName(const Name: string): TSPackPackage;
var
I: Integer;
begin
Result := nil;
for I := 0 to FCount - 1 do
if Packages[I].Name = Name then
begin
Result := Packages[I];
Break;
end;
end;
procedure TPackageList.SetInstPackageDir(const ADir: string);
begin
FInstPackageDir := ADir;
if FInstPackageLoaded then
begin
Clear;
GetInstalledPackages;
end;
end;
procedure TPackageList.GetInstalledPackages;
var
Dir: TSearchRec;
Pkg: TSPackPackage;
I: integer;
N: Integer;
begin
I := 0;
if FProgressProc <> nil then
N := GetInstalledCount;
PrintLnDbg(Format(rsInfoLoadingPackages, [FInstPackageDir, N]), vlLow);
if FindFirst(FInstPackageDir + '/*', faAnyFile, Dir) = 0 then
begin
repeat
if Dir.Name[1] <> '.' then //exlude hidden and '.' and '..'
begin
Pkg := GetPkgFromName(Dir.Name);
if Pkg = nil then
begin
Pkg := TSPackPackage.Create;
Add(Pkg);
end;
Pkg.ReadInstalledPackage(FInstPackageDir + '/' + Dir.Name);
Inc(I);
if FProgressProc <> nil then
FProgressProc(0, N, I, Pkg.Name);
end;
until FindNext(Dir) <> 0;
FInstPackageLoaded := True;
end else
FInstPackageLoaded := False;
FindClose(Dir);
end;
function TPackageList.GetInstalledCount: integer;
begin
Result := GetNumberOfFiles(FInstPackageDir, []);
end;
procedure TPackageList.LoadLocalRepo;
var
Dir: TSearchRec;
I, J, N: Integer;
Path: string;
procedure LoadDir(const S: string);
var
Rec: TSearchRec;
Pkg: TSPackPackage;
begin
if FindFirst(S + '/*', faAnyFile, Rec) = 0 then
repeat
if (Rec.Name[1] <> '.') then //no hidden things or '.' and '..' dirs
//load subdirectoies if any
if (Rec.Attr and faDirectory) = faDirectory then
begin
PrintLnDbg(Format(rsInfoDirLoadingPackages, [S + Rec.Name]), vlFull);
LoadDir(S + Rec.Name + '/'); //recursive
end else
begin
if UpperCase(ExtractFileExt(Rec.Name)) = rsSpackExt then
begin
if FileExists(S + Rec.Name) then
begin
Pkg := GetPkgFromName(ExtractPackageName(Rec.Name));
if (not Assigned(Pkg)) or (Pkg = nil) then
begin
Pkg := TSPackPackage.Create;
Add(Pkg);
end;
Pkg.ReadPackageFile(Path, S + Rec.Name);
end;
end;
Inc(J);
if FProgressProc <> nil then
FProgressProc(0, N, J, Pkg.Name);
end;
until FindNext(Rec) <> 0;
end;
begin
if FLocalRepoList.Count <= 0 then
begin
PrintLnDbg(rsWarningNoLocalRepository, vlLow);
Exit;
end;
if FProgressProc <> nil then
N := LoadLocalRepoCount;
Path := '';
for I := 0 to FLocalRepoList.Count - 1 do
begin
Path := Copy(FLocalRepoList[I], Pos('=', FLocalRepoList[I]) + 1,
Length(FLocalRepoList[I]) - Pos('=', FLocalRepoList[I]));
J := 0;
if not DirectoryExists(Path) then
begin
PrintLnDbg(rsErrorLocalRepoNotFound + Path, vlLow);
Continue;
end;
if FindFirst(Path + '/*', faDirectory, Dir) = 0 then
repeat
if Dir.Name[1] <> '.' then //ignore hidden, '.' and '..' dirs
begin
PrintLnDbg(Format(rsInfoDirLoadingPackages, [Path + Dir.Name]), vlFull);
LoadDir(Path + Dir.Name + '/');
end;
until FindNext(Dir) <> 0;
end;
end;
function TPackageList.LoadLocalRepoCount: Integer;
var
I: Integer;
begin
Result := 0;
for I := 0 to FLocalRepoList.Count - 1 do
Result := Result + GetNumberOfFiles(Copy(FLocalRepoList[I],
Pos('=', FLocalRepoList[I]) + 1,
Length(FLocalRepoList[I]) - Pos('=', FLocalRepoList[I])),
[fcIncludeSubdirs]);
end;
procedure TPackageList.DwlManProgress(AOwner: TObject);
begin
// if Assigned(FProgressProc) then
// FProgressProc(0, FDownloadManager.TotalSize,
// FDownloadManager.TotalDownloadedSize, Format('Downloading %s (%d / %d)...',
// [FDownloadManager.DownloadList[FDownloadManager.DownloadIndex],
// FDownloadManager.TotalDownloadedSize, FDownloadManager.TotalSize]));
end;
procedure TPackageList.DwlManError(AOwner: TObject);
begin
PrintLnDbg(Format(rsErrorDownloadRepoFailed,
[FDownloadManager.DownloadList[FDownloadManager.DownloadIndex]]), vlLow);
FDownloadManager.DownloadIndex := FDownloadManager.DownloadIndex + 1;
end;
procedure TPackageList.DwlManNewFile(AOwner: TObject);
var
S: string;
I, N: Integer;
begin
PrintLnDbg(Format(rsDebugInitializingNewFileForDownload,
[FDownloadManager.DownloadList[FDownloadManager.DownloadIndex]]));
S := ExtractFilePath(FDownloadManager.DownloadList[FDownloadManager.DownloadIndex]);
if S[Length(S)] = '/' then
S := Copy(S, 1, Length(S) - 1);
for I := 0 to FDistantRepoList.Count - 1 do
begin
if Pos(S, FDistantRepoList[I]) <> 0 then
begin
N := Pos('=', DistantRepoList[I]);
if N <> 0 then
FDownloadManager.Destination := sConfDir + '/' +
Copy(FDistantRepoList[I], 1, N - 1) + '/' +
ExtractFileName(FDownloadManager.DownloadList[FDownloadManager.DownloadIndex])
else
FDownloadManager.Destination := sConfDir +
ExtractFileName(FDownloadManager.DownloadList[FDownloadManager.DownloadIndex]);
end;
end;
if Trim(FDownloadManager.Destination) = '' then
FDownloadManager.Destination := sConfDir + '/' + ExtractHostName(S) + '/' +
ExtractFileName(FDownloadManager.DownloadList[FDownloadManager.DownloadIndex]);
PrintLnDbg(Format(rsInfoDownloadingFile,
[FDownloadManager.DownloadList[FDownloadManager.DownloadIndex],
FDownloadManager.Destination]), vlLow);
{$I-}
if not DirectoryExists(ExtractFilePath(FDownloadManager.Destination)) then
MkDir(ExtractFilePath(FDownloadManager.Destination));
{$I+}
end;
procedure TPackageList.DwlManNextFile(AOwner: TObject);
begin
FDownloadManager.DownloadIndex := FDownloadManager.DownloadIndex + 1;
PrintLnDbg(Format(rsDebugSwitchedToNextFileForDownload,
[FDownloadManager.DownloadIndex]));
end;
procedure TPackageList.DwlManStartDownload(AOwner: TObject);
begin
FDownloadManager.DownloadIndex := 0;
end;
procedure TPackageList.GetDistantRepoInfo(const Repo: string;
out Name, Address: string);
var
P: integer;
begin
Name := '';
Address := '';
P := Pos('=', Repo);
if P = 0 then
begin
PrintLnDbg(Format(rsErrorMalformedRepoDecl, [Repo]), vlLow);
Exit;
end;
Name := Copy(Repo, 1, P);
Address := Copy(Repo, P + 1, Length(Repo) - P);
FDownloadManager.DownloadList.Add(Address + rsPackageListFile);
PrintLnDbg(Format(rsDebugAddedToDownloadList, [Address + rsPackageListFile]));
FDownloadManager.DownloadList.Add(Address + rsAppListFile);
PrintLnDbg(Format(rsDebugAddedToDownloadList, [Address + rsAppListFile]));
FDownloadManager.DownloadList.Add(Address + rsDeprecatedFile);
PrintLnDbg(Format(rsDebugAddedToDownloadList, [Address + rsDeprecatedFile]));
end;
procedure TPackageList.DownloadDistantRepo;
var
I: Integer;
Name: string;
Address: string;
begin
if FDistantRepoList.Count <= 0 then
begin
PrintLnDbg(rsWarningNoDistantRepository, vlLow);
Exit;
end;
FDownloadManager := TDownloadManager.Create(nil);
FDownloadManager.OnProgress := @DwlManProgress;
FDownloadManager.OnNewDownload := @DwlManNewFile;
FDownloadManager.OnNextFile := @DwlManNextFile;
FDownloadManager.OnError := @DwlManError;
for I := 0 to FDistantRepoList.Count - 1 do
GetDistantRepoInfo(FDistantRepoList[I], Name, Address);
if FDownloadManager.DownloadList.Count <= 0 then
begin
PrintLnDbg(rsWarningNoPackageInfo, vlLow);
FreeAndNil(FDownloadManager);
Exit;
end;
FDownloadManager.GetTotalSize;
FDownloadManager.StartDownload;
repeat
if (FProgressProc <> nil) and
(FDownloadManager.DownloadIndex < FDownloadManager.DownloadList.Count) then
FProgressProc(1, 0, FDownloadManager.GetFileSize(FDownloadManager.DownloadIndex),
Format(rsDownloadingFile,
[FDownloadManager.DownloadList[FDownloadManager.DownloadIndex]]));
Application.ProcessMessages;
until (FDownloadManager.Status = drDone) or
(FDownloadManager.Status = drCanceled);
FDownloadManager.Free;
end;
function TPackageList.DownloadDistantRepoCount: integer;
var
I: Integer;
Name: string;
Address: string;
begin
FDownloadManager := TDownloadManager.Create(nil);
for I := 0 to FDistantRepoList.Count - 1 do
GetDistantRepoInfo(FDistantRepoList[I], Name, Address);
if FDownloadManager.DownloadList.Count <= 0 then
begin
PrintLnDbg(rsWarningNoPackageInfo, vlLow);
FreeAndNil(FDownloadManager);
Exit;
end;
FDownloadManager.GetTotalSize;
Result := FDownloadManager.TotalSize;
FDownloadManager.Free;
end;
procedure TPackageList.LoadDistantRepo(const Name: string);
var
I: Integer;
Txt: Text;
FName, S: string;
Pkg: TSPackPackage;
Line, N: Integer;
begin
I := 0;
while (I < slRepoList.Count) and
(Copy(slRepoList[I], 1, Length(Name)) <> Name) do
Inc(I);
if Copy(slRepoList[I], 1, Length(Name)) = Name then
begin
FName := sConfDir + '/' + Name + '/' + rsPackageListFile;
N := LoadDistantRepoCount(Name);
PrintLnDbg(Format(rsInfoLoadingDistPackageInfo, [FName]));
if FileExists(FName) then
begin
AssignFile(Txt, FName);
Reset(Txt);
Line := 0;
while not EOF(Txt) do
begin
Inc(Line);
Readln(Txt, S);
Pkg := GetPkgFromName(ExtractPackageName(S));
if (not Assigned(Pkg)) or (Pkg = nil) then
begin
Pkg := TSPackPackage.Create;
Add(Pkg);
end;
Pkg.ReadDistRepoPackage(Copy(slRepoList[I], Pos(slRepoList[I], '=') + 1,
Length(slRepoList[I]) - Pos(slRepoList[I], '=')), S);
if Trim(Pkg.Name) = '' then
PrintLnDbg(Format(rsErrorInvalidLine, [FName, Line]));
if FProgressProc <> nil then
FProgressProc(1, N, Line, Pkg.Name);
end;
CloseFile(Txt);
end;
if Name = sDefaultRepo then
begin
FName := sConfDir + '/' + Name + '/' + rsDeprecatedFile;
if FileExists(FName) then
begin
PrintLnDbg(Format(rsInfoLoadingDeprecated, [Name, FName]), vlLow);
if not Assigned(slDeprecated) or (slDeprecated = nil) then
slDeprecated := TStringList.Create
else
slDeprecated.Clear;
AssignFile(Txt, FName);
Reset(Txt);
while not EOF(Txt) do
begin
ReadLn(Txt, S);
slDeprecated.Add(Trim(S));
end;
CloseFile(Txt);
end else
PrintLnDbg(Format(rsErrorCantFindDeprecationFile, [Name, FName]), vlLow);
end;
end;
end;
function TPackageList.LoadDistantRepoCount(const Name: string): Integer;
var
I: Integer;
FName: string;
Txt: Text;
begin
I := 0;
FName := sConfDir + '/' + Name + '/' + rsPackageListFile;
if FileExists(FName) then
begin
AssignFile(Txt, FName);
Reset(Txt);
while not EOF(Txt) do
begin
Readln(Txt);
Inc(I);
end;
CloseFile(Txt);
end;
Result := I;
end;
procedure TPackageList.SetDeprecated(DeprecatedList: TStrings);
var
I: Integer;
Pkg: TSPackPackage;
begin
if Assigned(DeprecatedList) and (DeprecatedList <> nil) then
for I := 0 to DeprecatedList.Count - 1 do
begin
Pkg := GetPkgFromName(DeprecatedList[I]);
if Pkg <> nil then
Pkg.State := Pkg.State + [psDeprecated];
end;
end;
end.
common/uspackpackage.pas
+361
View File
@@ -0,0 +1,361 @@
{
********************************************************************************
SPackGui
Copyright (C) 2012-2013 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
Copyright (C) <date> <add your name and mail address here>
http://www.geoffray-levasseur.org/
http://0.tuxfamilly.org/
This software is governed by the CeCILL license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/ or redistribute the software under the terms of the CeCILL
license as circulated by CEA, CNRS and INRIA at the following URL
"http://www.cecill.info".
As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided only
with a limited warranty and the software's author, the holder of the
economic rights, and the successive licensors have only limited
liability.
In this respect, the user's attention is drawn to the risks associated
with loading, using, modifying and/or developing or reproducing the
software by the user in light of its specific status of free software,
that may mean that it is complicated to manipulate, and that also
therefore means that it is reserved for developers and experienced
professionals having in-depth computer knowledge. Users are therefore
encouraged to load and test the software's suitability as regards their
requirements in conditions enabling the security of their systems and/or
data to be ensured and, more generally, to use and operate it in the
same conditions as regards security.
The fact that you are presently reading this means that you have had
knowledge of the CeCILL license and that you accept its terms.
********************************************************************************
Description:
Base SPack functions
********************************************************************************
}
unit uSpackPackage;
{$include defines.inc}
interface
uses
Classes, SysUtils;
const
MaxPackAlt = 16;
type
TPkgState = set of (psInstalled, psAvailable, psUpdatable, psDeprecated);
TSourceType = (srtNone, srtLocal, srtHTTP, srtFTP);
TPackageProperties = record
Version: string;
Build: Byte;
Size: LongInt; //due to spack limitation all the sizes are in Ko
SourceType: TSourceType;
SourceAddress: string;
Installed: Boolean;
end;
TPackageAlternatives = array[1..MaxPackAlt] of TPackageProperties;
TSPackPackage = class(TObject)
public
Name: string;
Desc: string;
State: TPkgState;
InstSize: LongInt;
Cat: string;
FileList: Boolean;
Alternatives: TPackageAlternatives;
constructor Create;
destructor Destroy; override;
function AddNewSource(const Ver: string; const Bld: Byte;
const Sz: LongInt; const SrcType: TSourceType;
const SrcAddr: string): Integer;
procedure ReadInstalledPackage(const S: string);
procedure ReadPackageFile(const Repo, FileName: string);
procedure ReadDistRepoPackage(const Repo, S: string);
function LoadFileList(InstDir: string): TStringList;
function GetInstalled: Byte;
function GetDefaultVer: Byte;
function GetLatest: Byte;
end;
implementation
uses
uStrings, uCommon, uUtils, uDebug, FileUtil;
constructor TSPackPackage.Create;
var
I: Integer;
begin
Name := '';
Desc := '';
State := [];
Cat := '';
InstSize := 0;
for I := 1 to MaxPackAlt do
begin
Alternatives[I].Version := '';
Alternatives[I].Build := 0;
Alternatives[I].SourceType := srtNone;
Alternatives[I].SourceAddress := '';
Alternatives[I].Size := 0;
Alternatives[I].Installed := False;
end;
FileList := False;
end;
destructor TSPackPackage.Destroy;
begin
//for now, nothing to destroy
end;
function TSPackPackage.AddNewSource(const Ver: string; const Bld: Byte;
const Sz: LongInt; const SrcType: TSourceType;
const SrcAddr: string): Integer;
var
I: Byte;
begin
if Trim(Ver) = '' then
raise Exception.Create(rsExceptEmptyVersion);
I := 1;
while Alternatives[I].Version <> '' do
if I <= MaxPackAlt then
Inc(I)
else
raise Exception.Create(rsExceptMaxPackageAlt);
Alternatives[I].Version := Ver;
Alternatives[I].Build := Bld;
Alternatives[I].Size := Sz;
Alternatives[I].SourceType := SrcType;
Alternatives[I].SourceAddress := SrcAddr;
// the following works only if installed packages are loaded first
if GetInstalled <> 0 then
if (SrcAddr = GetRepoAddress(sDefaultRepo)) and
((Ver <> Alternatives[GetInstalled].Version) or
(Bld <> Alternatives[GetInstalled].Build)) then
State := State + [psUpdatable];
Result := I;
end;
procedure TSPackPackage.ReadInstalledPackage(const S: string);
const
Sep = ':';
var
Txt: Text;
Tmp: string;
I, ASize: Integer;
ABuild: Byte;
Arch, AName, AVersion, ASourceAddress: string;
ASourceType: TSourceType;
begin
if not FileExists(S) then
Exit;
AssignFile(Txt, S);
{$I-}
Reset(Txt);
{$I+}
try
//first line is package name, with version and arch
Readln(Txt, Tmp);
I := Pos(Sep, Tmp) + 2; // + 1 for the space after
DecomposePackageName(Copy(Tmp, I, Length(Tmp) - I + 1),
AName, AVersion, ABuild, Arch);
if Name = '' then
Name := AName;
//second line is compressed size (we convert in Byte)
Readln(Txt, Tmp);
I := Pos(Sep, Tmp) + 2;
ASize := StrToInt(Copy(Tmp, I, Length(Tmp) - I)) * 1024;
//third line is uncompressed size
Readln(Txt, Tmp);
I := Pos(Sep, Tmp) + 2;
InstSize := StrToInt(Copy(Tmp, I, Length(Tmp) - I )) * 1024;
//fourth line is the full path of the spack file (may not be in a repository)
Readln(Txt, Tmp);
I := Pos(Sep, Tmp) + 2;
ASourceAddress := Copy(Tmp, I, Length(Tmp) - I + 1);
if FileExists(ASourceAddress) then
ASourceType := srtLocal
else
ASourceType := srtNone;
//fifth line marks the beginning of package description
Readln(Txt, Tmp);
Readln(Txt, Tmp);
I := Pos('(', Tmp) + 1;
Desc := Copy(Tmp, I, Length(Tmp) - I);
//seventh line mark the beginning of filelist (just say it's available)
FileList := True;
State := State + [psInstalled];
I := AddNewSource(AVersion, ABuild, ASize, ASourceType, ASourceAddress);
Alternatives[I].Installed := True;
CloseFile(Txt);
except
PrintLnDbg(Format(rsErrorLoadingPackage, [S]), vlLow);
try
CloseFile(Txt);
finally
end;
end;
end;
procedure TSPackPackage.ReadPackageFile(const Repo, FileName: string);
var
Arch: string;
ASourceType: TSourceType;
AName, AVersion, ASourceAddress: string;
ABuild: Byte;
ASize: Longint;
begin
if (Pos(sHttpPrefix, Repo) = 1) then
ASourceType := srtHTTP
else
if (Pos(sFtpPrefix, Repo) = 1) then
ASourceType := srtFTP
else
ASourceType := srtLocal;
DecomposePackageName(Copy(ExtractFileName(FileName), 1,
Length(ExtractFileName(FileName)) - Length(ExtractFileExt(FileName))),
AName, AVersion, ABuild, Arch);
Cat := Copy(ExtractFilePath(FileName), Length(Repo),
Length(ExtractFilePath(FileName)) - Length(Repo));
if Cat[1] = '/' then
Cat := Copy(Cat, 2, Length(Cat) - 1);
if Cat[Length(Cat)] = '/' then
Cat := Copy(Cat, 1, Length(Cat) - 1);
if bUnitsAreDecimal then
ASize := FileSize(FileName)
else
ASize := FileSize(FileName);
ASourceAddress := Repo;
FileList := Filelist or False;
if Name = '' then
Name := AName;
if (Name <> AName) then
raise Exception.Create(rsExceptPackageNameMismatch);
AddNewSource(AVersion, ABuild, ASize, ASourceType, ASourceAddress);
end;
procedure TSPackPackage.ReadDistRepoPackage(const Repo, S: string);
var
P: Integer;
Tmp, Name2, Arch: string;
AName, AVersion, ASourceAddress: string;
ASourceType: TSourceType;
ABuild: Byte;
begin
ASourceAddress := Copy(Repo, Pos('=', Repo) + 1, Length(Repo) - Pos('=', Repo));
if (Pos(sHttpPrefix, Repo) = 1) then
ASourceType := srtHTTP
else
if (Pos(sFtpPrefix, Repo) = 1) then
ASourceType := srtFTP
else
ASourceType := srtLocal;
P := Pos(' ', S);
Name2 := Copy(S, 1, P - 1);
Tmp := Copy(S, P + 1, Length(S) - P);
P := Pos(' ', Tmp);
//if you uncomment the following you'll get huge log files
//PrintLnDbg('D Adding package ' + Copy(Tmp, 1, P - 1) + ' (' + Name +
// ') from ' + Repo + '...');
DecomposePackageName(Copy(Tmp, 1, P - 1), AName, AVersion, ABuild, Arch);
if Name = '' then
Name := AName;
Cat := Copy(Tmp, P + 1, Length(Tmp) - P - 1);
if (AName <> Name2) or ((Name <> '') and (Name <> AName)) then
raise Exception.Create(rsExceptPackageNameMismatch);
AddNewSource(AVersion, ABuild, 0, ASourceType, ASourceAddress);
FileList := Filelist or False;
end;
function TSPackPackage.LoadFileList(InstDir: string): TStringList;
var
T: Text;
I: Integer;
Tmp, FName: string;
begin
Result := TStringList.Create;
if FileList then
begin
I := GetInstalled;
FName := InstDir + '/' + Name + '-' + Alternatives[I].Version + '-' +
sArch + '-' + IntToStr(Alternatives[I].Build);
PrintLnDbg(Format(rsInfoGetFileList, [FName]));
if FileExists(FName) then
begin
AssignFile(T, FName);
Reset(T);
//we don't care the 8 first lines
for I := 0 to 8 do
Readln(T, Tmp);
while not EOF(T) do
begin
Readln(T, Tmp);
Result.Add(Tmp);
end;
end;
end else
PrintLnDbg(rsWarningNoFileList, vlLow);
end;
function TSPackPackage.GetInstalled: Byte;
var
I: Integer;
begin
Result := 0;
for I := 1 to MaxPackAlt do
if Alternatives[I].Installed then
Result := I;
end;
function TSPackPackage.GetDefaultVer: Byte;
var
I: Integer;
begin
Result := 0;
for I := 1 to MaxPackAlt do
if (Alternatives[I].Version <> '') and
(GetRepoAddress(sDefaultRepo) = Alternatives[I].SourceAddress) then
Result := I;
end;
function TSPackPackage.GetLatest: Byte;
var
I: Integer;
begin
Result := 1;
for I := 2 to MaxPackAlt do
if Alternatives[I].Version <> '' then
if CompareVersion(Alternatives[I].Version,
Alternatives[Result].Version) >= 1 then
Result := I
else
if (CompareVersion(Alternatives[Result].Version,
Alternatives[I].Version) = 0) and
(Alternatives[Result].Build < Alternatives[I].Build) then
Result := I;
end;
end.
common/ustrings.pas
+399
View File
@@ -0,0 +1,399 @@
{
********************************************************************************
SPackGui
Copyright (C) 2012-2013 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
Copyright (C) <date> <add your name and mail address here>
http://0.tuxfamilly.org/
http://www.geoffray-levasseur.org/
This software is governed by the CeCILL license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/ or redistribute the software under the terms of the CeCILL
license as circulated by CEA, CNRS and INRIA at the following URL
"http://www.cecill.info".
As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided only
with a limited warranty and the software's author, the holder of the
economic rights, and the successive licensors have only limited
liability.
In this respect, the user's attention is drawn to the risks associated
with loading, using, modifying and/or developing or reproducing the
software by the user in light of its specific status of free software,
that may mean that it is complicated to manipulate, and that also
therefore means that it is reserved for developers and experienced
professionals having in-depth computer knowledge. Users are therefore
encouraged to load and test the software's suitability as regards their
requirements in conditions enabling the security of their systems and/or
data to be ensured and, more generally, to use and operate it in the
same conditions as regards security.
The fact that you are presently reading this means that you have had
knowledge of the CeCILL license and that you accept its terms.
********************************************************************************
Description:
Message and other non changeable string constant
********************************************************************************
}
unit uStrings;
{$include defines.inc}
interface
uses
uCommon;
const //some logfile const
dbgStatOk = '-';
dbgStatWarn = '!';
dbgOk = 'Ok';
dbgFail = 'Fail';
sTimeJump = ' '; //number of space = time length with braces
resourcestring //in case we use automatic i18n translation in the future
rsFullAppTitle = 'SPackGui';
//paths and files
rsSpackExt = '.SPACK';
rsPackageListFile = 'paquets.db';
rsAppListFile = 'applications.db';
rsDeprecatedFile = 'obsoletes.db';
rsFreeDesktopConfig = '.config';
rsHomeConfDir = 'spackgui';
//logfile prefixes
rsBaseError = '*** ERROR: ';
rsBaseWarning = '! WARNING: ';
rsBaseInfo = 'Info: ';
rsBaseDebug = '[Debug]: ';
//logfile messages
rsStackTrace = 'Stack trace:';
rsExceptionClass = 'Exception class: ';
rsMessage = 'Message: ';
rsHeapStatusDetails = 'Heap Status:' + LineEnding +
sTimeJump + ' - Addr Space: ' + #9 + ' %d ' + LineEnding +
sTimeJump + ' - Uncommitted: ' + #9 + ' %d ' + LineEnding +
sTimeJump + ' - Committed: ' + #9 + ' %d ' + LineEnding +
sTimeJump + ' - Allocated: ' + #9 + ' %d ' + LineEnding +
sTimeJump + ' - Free: ' + #9 + ' %d ' + LineEnding +
sTimeJump + ' - Free Small: ' + #9 + ' %d ' + LineEnding +
sTimeJump + ' - Free Big: ' + #9 + ' %d ' + LineEnding +
sTimeJump + ' - Unused: ' + #9 + ' %d ' + LineEnding +
sTimeJump + ' - Overhead: ' + #9 + ' %d ' + LineEnding +
sTimeJump + ' - Heap Errorcode: ' + #9 + ' %d ';
//units
rsByte = 'o';
rsGB = 'Go';
rsGiB = 'Gio';
rsMB = 'Mo';
rsMiB = 'Mio';
rsKB = 'ko';
rsKiB = 'Kio';
//configuration sections (should not be translated)
rsConfSectionCommand = 'Commands';
rsConfSectionPaths = 'Paths';
rsConfSectionProxy = 'Proxy';
rsConfSectionDisplay = 'Display';
rsConfSectionListViewColors = 'ListViewColors';
rsConfNameUpdatablePackageFont = 'UpdatablePackageFont';
rsConfNameUpdatablePackageBack = 'UpdatablePackageBack';
rsConfNameOutdatedPackageFont = 'OutdatedPackageFont';
rsConfNameOutdatedPackageBack = 'OutdatedPackageBack';
rsConfNamePackageToInstallFont = 'PackageToInstallFont';
rsConfNamePackageToInstallBack = 'PackageToInstallBack';
rsConfNamePackageToUpgradeFont = 'PackageToUpgradeFont';
rsConfNamePackageToUpgradeBack = 'PackageToUpgradeBack';
rsConfNamePackageToRemoveFont = 'PackageToRemoveFont';
rsConfNamePackageToRemoveBack = 'PackageToRemoveBack';
rsConfNameAddress = 'Address';
rsConfNameInstallCommand = 'Install';
rsConfNameReinstallCommand = 'Reinstall';
rsConfNameRemoveCommand = 'Remove';
rsConfNameUpdateCommand = 'Update';
rsConfNameInstPkgPath = 'InstalledPackages';
rsConfNamePkgDownloadPath = 'PackageDownload';
rsConfNameRepoDownloadPath = 'RepositoriesIndex';
rsConfNameHttpProxy = 'Http';
rsConfNameFtpProxy = 'Ftp';
rsConfNameLogFontName = 'LogFont.Name';
rsConfNameLogFontSize = 'LogFont.Size';
rsConfNameDefault = 'Default';
rsConfNameRepoDesc = 'Desc';
rsConfNameLeft = 'Left';
rsConfNameWidth = 'Width';
rsConfNameTop = 'Top';
rsConfNameHeight = 'Height';
rsConfNameMaximized = 'Maximized';
rsConfNameCount = 'Count';
rsConfNameDecimalUnits = 'DecimalUnits';
rsConfNameThousandsSep = 'ThousandsSeparator';
rsConfNameDecimalSep = 'DecimalSeparator';
rsConfNameListViewColumn = 'ListViewColumn';
rsConfNameHorizPanelLeft = 'HorizPanelLeft';
rsConfNameVertPanelTop = 'VertPanelTop';
rsConfNameFindHistory = 'FindHistory';
rsConfNameSortColumn = 'SortColumn';
rsConfNameSortAscending = 'SortAscending';
rsConfNameShowGrid = 'ShowGrid';
rsConfNameNoColors = 'NoColors';
//log messages (use english only)
rsInfoLoggingStarted = 'Logging started: "%s"';
rsInfoLoggingTerminated = 'Closing log file "%s": application terminated';
rsInfoShowingLogWin = 'i TfMain: Showing log window...';
rsInfoLoadingPackages = 'i TPackageList: Loading package list in "%s" ' +
'(%d found)...';
rsInfoDirLoadingPackages = 'i TPackageList: Loading packages in: "%s"...';
rsInfoDownloadingFile = 'i TPackageList: Downloading file "%s" in "%s"...';
rsInfoAddingDistantRepo = 'i TPackageList: Loading remote repo: "%s".';
rsInfoAddingLocalRepo = 'i TPackageList: Loading local repo: "%s".';
rsInfoAddedFileToDowload = 'i TPackageList: The file "%s" is now added to ' +
'download list.';
rsInfoLoadingLogFile = 'i TfLogFile: Loading log file: "%s".';
rsInfoInitializedDownload = 'i TDownloader: Initialized download of "%s": %s.';
rsInfoInitConfFile = 'i uCommon: Configuration file %s initialized.';
rsInfoRunningTest = 'i Main: Running in test mode.';
rsInfoRunningDebug = 'i Main: Running if debug mode.';
rsInfoShowingPackageInfo = 'i TfPackageProperty: Showing informations ' +
'about package "%s".';
rsInfoLoadingDistPackageInfo = 'i TPackageList: Loading package ' +
'informations in "%s"...';
rsInfoGetHttpProxySettings = 'i TfEnvironmentSettings: Getting HTTP proxy ' +
'settings from "%s".';
rsInfoGetFtpProxySettings = 'i TfEnvironmentSettings: Getting FTP proxy ' +
'settings from "%s".';
rsInfoDefaultRepo = 'i uCommon: Default repository is "%s"';
rsInfoLoadingRepoSettings = 'i uCommon: Loading repositories settings...';
rsInfoGetFileList = 'i TSPackPackage: Getting file list for package in "%s"...';
rsInfoFoundBrowser = 'i uUtils: Found browser: "%s"';
rsInfoStartLoggingDb = 'i TfMain: Logging of the full database starts here...';
rsInfoEndLoggingDb = 'i TfMain: Logging of the full database ends here...';
rsInfoLoadingDeprecated = 'i TPackageList: Loading deprecated package from ' +
'default repository "%s" in "%s".';
rsWarningNoLogfile = 'W uDebug: No log file will be created, ' +
'logging on stdout (console) only';
rsWarningDbgNotRoot = 'W Main: Running in non root mode.';
rsWarningConfWillBeLost = 'W Main: Any change in configuration will be lost.';
rsWarningNoPackageInfo = 'W TPackageList: No package information files ' +
'to download.';
rsWarningNoLocalRepository = 'W TPackageList: No local repository ' +
'configured yet.';
rsWarningNoDistantRepository = 'W TPackageList: No distant repository ' +
'configured yet.';
rsWarningNoFileList = 'W TSPackPackage: That package have no file list.';
rsErrorLogrotate = 'E uDebug: logrotate failed on file "%s"';
rsErrorUnhandledException = 'E uDebug: Unhandled exception:';
rsErrorButLogrotate = 'E uDebug: logrotate worked but the log file "%s" '+
'still exists';
rsErrorCreatingLogfile = 'E uDebug: could not create log file "%s"';
rsErrorWritingLogFile = 'E uDebug: unable to write in logfile "%s"';
rsErrorInThread = 'E uDebug: In thread: "%s"';
rsErrorPkgListIndex = 'E TPackageList: Index %n out of bounds.';
rsErrorCapacity = 'E TPackageList: Trying to set a wrong capacity %n.';
rsErrorUnableToLock = 'E Main: cannot lock the program: change will not be ' +
'allowed.';
rsErrorLoadingPackage = 'E TSpackPackage: Failed to load package ' +
'informations in %s.';
rsErrorLocalRepoNotFound = 'E TPackageList: Unavailable local repository "%s".';
rsErrorReadOnly = 'E Main: SPackGui was unable to find a path where it ' +
'can write its configuration files.';
rsErrorNoPackage = 'E TfMain: No packages have been found in "%s".';
rsErrorDownloadRepoFailed = 'E TPackageList: Downloading "%s" failed.';
rsErrorMalformedRepoDecl = 'E TPackageList: Malformed repository ' +
'declaration "%s".';
rsErrorCantGetFileSze = 'E TDownloadManager: Can''t get size of the file ' +
'at address "%s".';
rsErrorDownloadingFailed = 'E TDownloader: Can''t download the file at ' +
'address "%s".';
rsErrorDownloadIndex = 'E TDownloadListLoop: The download index %d is out ' +
'of range (< 0).';
rsErrorInvalidLine = 'E TPackageList: The file "%s" contains an invalid ' +
'line %d.';
rsErrorCantFindDeprecationFile = 'E TPackageList: Can''t find file "%s" for ' +
'deprecated packages of the default "%s" repository.';
rsErrorCannotSaveConf = 'E Unable to save configuration informations.';
rsDebugDownloadStarted = 'D TDownloader: Download started.';
rsDebugDownloadFinished = 'D TDownloader: Download terminated.';
rsDebugDownloadListLoopStarted = 'D TDownloadListLoop: Thread started.';
rsDebugDownloadListLoopStopped = 'D TDownloadListLoop: Thread terminated.';
rsDebugAddedToDownloadList = 'D TPackageManager: Added file "%s" to download ' +
'list.';
rsDebugInitializingNewFileForDownload = 'D TPackageManager: Initializing ' +
'informations for downloading file "%s".';
rsDebugSwitchedToNextFileForDownload = 'D TPackageManager: Switching to ' +
'next file index %d for download.';
rsDebugNodeAdded = 'D TfMain: Adding node "%s" to "%s".';
rsDebugDisplayingCategory = 'D TfMain: Selected category "%s" to display.';
rsDebugDownloadFeedback = 'D TDownloadManager: ';
//messagebox titles
rsDone = 'Done';
rsError = 'Error';
rsWarning = 'Warning';
rsQuestion = 'Question';
rsHelp = 'Help';
//messagebox contents
rsWarningNotRoot = 'It seems SPackGui have not been launched with ' +
'administrator permition (' + sRootUserName + '). Thus, You won''t be ' +
'authorized to apply any change to the system.' +
LineEnding + LineEnding +
'Log file will be placed in your personal directory instead of /var/log.';
rsWarningOtherInstance = 'An other instance of the program is running. ' +
'No change will be possible.';
rsErrorEqualForbidden = 'Symbol « = » (equal) is forbidden in object names.';
rsErrorDuplicateRepoName = 'Impossible to add a repository where name is ' +
'already in use.';
rsErrorQuoteForbidden = 'Symbol « " » (quote) is forbidden in addresses.';
rsErrorSearchSynthax = 'Syntax error in research field: an expression ' +
'can''t begin or end with an operator.';
rsLooseRepoChanges = 'You have made changes in repository list. Do you ' +
'want to loose those changes and close the window?';
rsNoPackageFound = 'No installed package have been found. ' + LineEnding +
'Unless you use that software for the very first time on a system not ' +
'using SPack as primary package manager, that situation is not normal.' +
'Anyway, you should check now your configuration before beginning.';
rsRegExprHelp = 'Regular expressions allows to do precise search using ' +
'inclusions, exclutions or complex strings. With a classic search every ' +
'word is independently search and they all must be present in then ' +
'package name or its description.' +
LineEnding + LineEnding +
'A regular expression admit the following operators:' + LineEnding +
' - The + symbol sticked to a word make it necessary' + LineEnding +
' - The - symbol sticked to a word exclude it' + LineEnding +
' - The & symbol between two words force presence of both words' +
LineEnding +
' - The | symbol between two words means we want at least one of the ' +
'two words ' + LineEnding +
' - The symbol # between two words we want one or the other word but ' +
'not both' + LineEnding +
' - Everything placed between two " (quotes) is evaluated as a single ' +
'word' + LineEnding + LineEnding +
'Exemples :' + LineEnding +
' +phonon -vlc: will look for anything containing phonon but not vlc' +
LineEnding +
' nvidia | ati: will look for anything containing nvidia or ati or both' +
LineEnding +
' vl | vd & lib: will look for anything containing vl or vd or both ' +
'and in any case will contain lib';
rsReloadPackagesAfterRepoChange = 'The repositories configuration have ' +
'been changed.' + LineEnding + LineEnding +
'If you want to take it into account, it is necessary to reload entirely ' +
'the package list.' + LineEnding + LineEnding +
'Do you want to reload package list now?';
rsReloadPackagesAfterEnvChange = 'You have changed one or more vital SPack ' +
'paths.' + LineEnding + LineEnding +
'If you want to take changes into account, it is required to reload ' +
'entirely the package list.' + LineEnding + LineEnding +
'Do you want to reload package list now?';
//Custom exception message
rsExceptPackageNameMismatch = 'TSPackPackage: Package name mismatch.';
rsExceptEmptyVersion = 'TSPackPackage: Empty package version is forbidden.';
rsExceptMaxPackageAlt = 'TSPackPackage: Reached maximum package alternatives.';
rsExceptEmptyAddress = 'TDownloader: The given URL is empty.';
rsExceptUnsupportedProtocol = 'TDownloader: The given protocol is not '+
'supported.';
rsExceptTest = 'TfMain: Test exception.';
rsExceptUnnamedPackage = 'TfMain: Found a package without name. Your ' +
'database is probably broken.';
rsExceptStringlistChange = 'Can''t change StringList while downloading.';
rsExceptChangeIndex = 'Can''t change index while downloading.';
//interface items
rsNewRepo = 'New repository';
rsChangeRepo = 'Change repository settings';
rsUnknowPackage = 'unknow';
rsStateAvailable = 'Available';
rsStateNotInstalled = 'Not installed';
rsStateInstalled = 'Installed';
rsStateUpgradable = 'To upgrade to version %s';
rsStateDeprecated = 'Deprecated: to be uninstalled with next upgrade';
rsSymlink = 'Symbolic link';
rsDirectory = 'Directory';
rsNotFound = 'Not found';
rsAllPackages = 'All the packages';
rsUncategorized = 'Uncategorized';
rsDownloadingFile = 'Downloading %s...';
rsDescNotInstalledPackage = 'Package description is available only for ' +
'installed package.';
rsUnitExample = 'Example: 5000 bytes are %s.';
{$IFDEF LCLQT}
rsQtVersion = 'You are using Qt version %s.';
{$ENDIF}
{$IFDEF LCLGTK2}
rsGtkVersion = 'You are using GTK version %d.%d.%d.';
{$ENDIF}
//address for package info search
rsGoogleSearch = 'http://www.google.fr/search?q=%s';
rsDebianSearch = 'http://packages.debian.org/search?keywords=%s';
rsLFSSearch = 'http://www.google.com/custom?client=pub-1920546463376456&' +
'cof=GALT%3A%23008000%3BGL%3A1%3BDIV%3A%23336699%3BVLC%3A663399%3BAH%3A' +
'center%3BBGC%3AFFFFFF%3BLBGC%3A336699%3BALC%3A0000FF%3BLC%3A0000FF%3BT' +
'%3A000000%3BGFNT%3A0000FF%3BGIMP%3A0000FF%3BLH%3A50%3BLW%3A128%3BL%3A' +
'http%3A%2F%2Fwww.linuxfromscratch.org%2Fimages%2Flfs-logo.png%3BS%3A' +
'http%3A%2F%2Fwww.traduc.org%3BFORID%3A1&domains=traduc.org&' +
'sa=Google+Search&sitesearch=traduc.org&q=';
rsArchSearch = 'https://www.archlinux.org/packages/?q=%s';
rsWikipediaSearch = 'http://en.wikipedia.org/w/index.php?search=%s';
rsSlackwareSearch = 'http://slackfind.net/en/packages/search/?name=%s';
rsGentooSearch = 'http://gpo.zugaina.org/Search?search=%s';
rsDebianPatchTracker = 'http://patch-tracker.debian.org/package/%s';
//Network status
rsNetStatResolving = 'Resolving ';
rsNetStatConnect = 'Connect ';
rsNetStatAccept = 'Accept ';
rsNetStatReadBytes = 'Read Bytes: ';
rsNetStatRequesting = 'Request sent, waiting for response';
//environment variables
rsEnvHttpProxy = 'http_proxy';
rsEnvFtpProxy = 'ftp_proxy';
rsEnvUser = 'USER';
rsEnvPath = 'PATH';
rsEnvGnomeSession = 'GNOME_DESKTOP_SESSION_ID';
rsEnvKDESession = 'KDE_FULL_SESSION';
rsEnvDesktopSession = 'DESKTOP_SESSION';
rsEnvUnixHomeDir = 'HOME';
//Database logging
rsLogNewPackage = '-- Package %s/%s';
rsLogDescription = 'Description: %s';
rsLogPackageAlt = '%d) Version: %s-%d sized %s from %s';
rsLogInstalled = ' (installed)';
rsLogDefault = ' (default)';
rsLogLatest = ' (latest)';
rsLogSep = '-----------------------';
//progression messages
rsProgressTidyPackageList = 'Tidying package list...';
rsProgressLoading = 'Loading...';
rsProgressInitDB = 'Initialization of the package database...';
rsProgressReadingInstalled = 'Reading installed packages...';
rsProgressReadingLocal = 'Reading local repositories...';
rsProgressDownloadingIndex = 'Downloading index files...';
rsProgressReadingDistant = 'Loading distant repositories...';
const
sCecillAddress = 'http://www.cecill.info/licences/Licence_CeCILL_V2-en.html';
sHttpPrefix = 'http://';
sFtpPrefix = 'ftp://';
implementation
end.
common/uutils.pas
+844
View File
@@ -0,0 +1,844 @@
{
********************************************************************************
SPackGui (common files)
Copyright (C) 2008-2013 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
Copyright (C) <date> <add your name and mail address here>
Parts inspired from PeaZip souce code:
Copyright (C) 2006 Giorgio Tani <giorgiotani@interfree.it>
Parts inspired from Lazarus source code:
Copyright (C) 2001-2010 The Lazarus developpers
http://www.geoffray-levasseur.org/
http://0.tuxfamilly.org/
This software is governed by the CeCILL license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/ or redistribute the software under the terms of the CeCILL
license as circulated by CEA, CNRS and INRIA at the following URL
"http://www.cecill.info".
As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided only
with a limited warranty and the software's author, the holder of the
economic rights, and the successive licensors have only limited
liability.
In this respect, the user's attention is drawn to the risks associated
with loading, using, modifying and/or developing or reproducing the
software by the user in light of its specific status of free software,
that may mean that it is complicated to manipulate, and that also
therefore means that it is reserved for developers and experienced
professionals having in-depth computer knowledge. Users are therefore
encouraged to load and test the software's suitability as regards their
requirements in conditions enabling the security of their systems and/or
data to be ensured and, more generally, to use and operate it in the
same conditions as regards security.
The fact that you are presently reading this means that you have had
knowledge of the CeCILL license and that you accept its terms.
********************************************************************************
Description:
Various utilities and functions
********************************************************************************
}
unit uUtils;
{$include defines.inc}
interface
uses
Classes, SysUtils, Graphics, StdCtrls;
type
TOperatingSystem = (osWindows, osWin32, osWin64, osWinCE, osGo32V2, osOS2,
osGenUnix, osFreeBSD, osNetBSD, osLinux, osBeOS, osQNX, osSun, osDarwin,
osAmiga, osAtari, osMacOS, osPalmOS, osUnknow);
TPathType = (ptIsDircetory, ptIsFile, ptIsExecutable, ptNotExists,
ptInvalid, ptDosPathOnUnix, ptUnixPathOnDos);
TDesktopEnv = (deUnknow, deGnome, deKDE, deMacOSX, deWindows, deLXDE, deXFCE);
Str4 = string[4];
TFileCountOpt = set of (fcIncludeSubDirs, fcIncludeDirs);
const {$warning we should be able to detect more desktop environment}
ADescEnvDesc: array[TDesktopEnv] of string = ('Unknow', 'Gnome', 'KDE',
'Mac OS X', 'Microsoft Windows', 'LXDE', 'XFCE');
AOSDesc: array[TOperatingSystem] of string = ('Microsoft Windows (generic)',
'Microsoft Windows (32 bits)', 'Microsoft Windows (64 bits)',
'Microsoft Windows CE', 'Microsoft Windows with Go32 v2', 'IBM OS/2',
'Generic Unix', 'Free BSD', 'Net BSD', 'Linux', 'BeOS', 'QNX',
'Sun Solaris', 'Mac OS X (Darwin)', 'Amiga OS', 'Atari OS', 'MacOS',
'Palm OS', 'Unknow Operating System');
cpuUnknow = $00;
cpu32Bit = $10;
cpu64Bit = $20;
cpuGenericMoto = $30;
cpuMiscRisc = $40;
cpuGenericPPC = $50;
cpu86 = $11;
cpu87 = $12;
cpu386 = $13;
cpuX86_64 = $21;
cpu68k = $31;
cpuM68020 = $32;
cpu68 = $33;
cpuAlpha = $41;
cpuSparc = $42;
cpuMips = $43;
cpuPowerPC = $51;
cpuArm = $60;
cpuBigEndian = $80;
var //default values and variable declaration for configuration
DateFormat: string = 'dd/mm/yyyy';
TwoDigitDateLimit: integer = 30;
//get the user name from personal directory path (multiplatform way)
//note that builtin FPC GetUserName function is for Windows only
//on unix su command is keeping the username as before launching it: find a workarround
function GetUserName: string;
//get computer name
function GetComputerName: string;
//Get the running operating system
function GetCurrentOS: TOperatingSystem;
//get CPU type and endianness (in MSB)
function GetUsedCPU: Word;
//Find the default browser according system configuration
function FindDefaultBrowser(out ABrowser, AParams: String): Boolean;
//Open URL in the default browser
function OpenURL(AURL: String): Boolean;
//convert a 4 char string (maximum) into a Word
function StrToWord(const S: Str4): Word;
//Convert a 3 number date into a string (deprecated)
function DateToStr(Y, M, D: Word): string; deprecated;
//Remove the extention of a file name
function RemoveFileExt(const aFileName: string): string;
//Get the executable path of the program with final /
function GetProgramPath: string;
//Get the active user working directory
function GetHomePath: string;
//Give the number of items present in a listed string for the given separator
function CountItemsInStr(Str: string; Separator: Char): integer;
//Return the item in a listed string at the given index
function GetItemInStr(Str: string; Separator: Char; Index: integer): string;
//find which desktop environment is currently running
function GetDesktopEnv: TDesktopEnv; //0 unknown, 1 Gnome, 2 KDE, 20 MS Windows, 30 OSX
//return the position of a string in a stringlist, -1 if no occurence
function StrExistsInList(const StrList: TStringList; S: string): integer;
function StrExistsInListBox(const StrList: TListBox; S: string): integer;
//remove and change (repectively) a string from a StringList, returning position
//of the change in the SL, -1 if no occurence
function StrRemove(var StrList: TStringList; S: string): integer;
function StrChange(var StrList: TStringList; const sOld, sNew: string): integer;
//check filename before use regarding the environment
function FormatFileName(S: String; out VS: string): Integer;
//check if a directory is empty
function DirectoryIsEmpty(ADir: string): Boolean;
//check for possible problematic chars in a string that could be used as filename
function RemoveSpecialChar(const S: UnicodeString): UnicodeString;
//create a lock file containing the computer name and user name of the locker
function CreateLockFile(const AName: string): Boolean;
//count the number of files in a directory and optionnally its subdirs
function GetNumberOfFiles(const ADir: string;
const AOpt: TFileCountOpt): LongWord;
//check if we can write in a directory
function DirectoryIsReadOnly(const ADirName: string): Boolean;
//get the host name of an URL/URI
function ExtractHostName(const S: string): string;
//get proxy settings from http_proxy or ftp_proxy environment variables
procedure GetProxyInfo(const S: string; out User, Pass, Address, Port: string);
implementation
uses
BaseUnix, Forms, FileUtil, UTF8Process, Dialogs, uDebug, uStrings;
function GetUserName: string;
begin
{$warning Find a workarround to get the good username in case where su or sudo is being used}
Result := GetEnvironmentVariable(rsEnvUser);
end;
function GetComputerName: String;
var
AUtsName: UtsName;
begin
Result := '';
AUtsName.Nodename[0] := #0; //this is just to avoid the compiler warning
FillChar(AUtsName, SizeOf(AUtsName), 0);
if FpUname(AUtsName) <> -1 then
Result := AUtsName.Nodename;
end;
function GetCurrentOS: TOperatingSystem;
begin
//unrecognized system, it is overwritten if one of the following conditions is met
Result := osUnknow;
// that software is useless and would not work on DOS/Windows type systems so it's bypassed
// Unix type systems
{$IFDEF UNIX}
//generic UNIX, replaced with some following codes
//if a more specific match is found
Result := osGenUnix;
{$ENDIF}
{$IFDEF FREEBSD}
Result := osFreeBSD;
{$ENDIF}
{$IFDEF NETBSD}
Result := osNetBSD;
{$ENDIF}
{$IFDEF LINUX}
Result := osLinux;
{$ENDIF}
{$IFDEF BEOS}
Result := osBeOS;
{$ENDIF}
{$IFDEF QNX}
Result := osQNX;
{$ENDIF}
{$IFDEF SUNOS}
Result := osSunOS;
{$ENDIF}
//Other systems are also ignored for the same reason as for DOS/Windows
end;
//if cpu type, < $80 (encoded in ls 7 bit);
//0 if unrecognized, replaced if a match is found
function GetUsedCPU: Word; //CPU and endianness (in MSB)
begin
Result := cpuUnknow; //cpu type, < $80 (encoded in ls 7 bit); 0: unrecognized, replaced if a match is found
{$IFDEF CPU32}
//generic 32 bit CPU, replaced if a more specific match is found
Result := cpu32Bit;
{$ENDIF}
{$IFDEF CPU64}
//generic 64 bit CPU, replaced if a more specific match is found
Result := cpu64Bit;
{$ENDIF}
{$IFDEF CPU86}
Result := cpu86;
{$ENDIF}
{$IFDEF CPU87}
Result := cpu87;
{$ENDIF}
{$IFDEF CPUI386}
Result := cpu386;
{$ENDIF}
{$IFDEF CPUX86_64}
Result := cpuX86_64;
{$ENDIF}
{$IFDEF CPU68k}
Result := cpu68k;
{$ENDIF}
{$IFDEF CPUM68020}
Result := cpuM68020;
{$ENDIF}
{$IFDEF CPU68}
Result := cpu68;
{$ENDIF}
{$IFDEF CPUSPARC}
Result := cpuSpark;
{$ENDIF}
{$IFDEF CPUALPHA}
Result := cpuAlpha;
{$ENDIF}
{$IFDEF CPUMIPS}
Result := cpuMips;
{$ENDIF}
{$IFDEF CPUPOWERPC}
Result := cpuPowerPC;
{$ENDIF}
{$IFDEF CPUARM}
Result := cpuArm;
{$ENDIF}
{$IFDEF ENDIAN_BIG}
//if processor is declared big endian (some processors don't have a fixed
//endian setting) the msb is set to 1, otherwise is 0
Result := Result + cpuBigEndian;
{$ENDIF}
end;
//This is a somewhat altered version of the Lazarus' source code
//FindDefaultBrowser function
function FindDefaultBrowser(out ABrowser, AParams: String): Boolean;
function Find(const ShortFilename: String; out ABrowser: String): Boolean; inline;
begin
ABrowser := SearchFileInPath(ShortFilename + GetExeExt, '',
GetEnvironmentVariable(rsEnvPath), PathSeparator,
[sffDontSearchInBasePath]);
Result := ABrowser <> '';
end;
begin
if ABrowser = '' then
begin
AParams := '%s';
// Then search in path. Firsts are prefered ;)
if Find('xdg-open', ABrowser) // Portland OSDL/FreeDesktop standard on Linux
or Find('htmlview', ABrowser) // some redhat systems
or Find('konqueror', ABrowser)
or Find('firefox', ABrowser)
or Find('mozilla', ABrowser)
or Find('midori', ABrowser)
or Find('rekonq', ABrowser)
or Find('galeon', ABrowser)
or Find('safari', ABrowser)
or Find('netscape', ABrowser)
or Find('opera', ABrowser) then
PrintLnDbg(Format(rsInfoFoundBrowser, [ABrowser]), vlHigh);
end;
Result := ABrowser <> '';
end;
//each system has a different OpenURL working. this is mainly took from
//Lazarus source code with minor changes
//we suppose here a Unix system... exotic or very old OS not supported.
function OpenURL(AURL: String): Boolean;
var
ABrowser, AParams: String;
BrowserProcess: TProcessUTF8;
begin
Result := FindDefaultBrowser(ABrowser, AParams) and
FileExists(ABrowser) {and FileIsExecutable(ABrowser)};
if not Result then
Exit;
//run
BrowserProcess := TProcessUTF8.Create(nil);
try
{$warning test if @ exists and add mailto to open it with default mail composer!}
BrowserProcess.CommandLine := ABrowser + ' ' + Format(AParams, [AURL]);
BrowserProcess.Execute;
finally
BrowserProcess.Free;
end;
end;
//if your string is more than 4 char you may have a range error
function StrToWord(const S: Str4): Word;
var
I: Integer;
begin
Result := 0;
I := 1;
while I <= Length(S) do
begin
Result := Result * 10 + Ord(S[I]) - Ord('0');
Inc(I);
end;
end;
// Deprecated with Lazarus > 0.9.27: use FormatDateTime for further development
function DateToStr(Y, M, D: Word): string; deprecated;
begin
if Y < TwoDigitDateLimit then
Inc(Y, 2000);
if (Y < 100) and (Y > TwoDigitDateLimit) then
Inc(Y, 1900);
Result := FormatDateTime(DateFormat, EncodeDate(Y, M, D));
end;
function RemoveFileExt(const aFileName: string): string;
var
I: integer;
begin
I := Length(aFileName);
while aFileName[I] <> '.' do
Dec(I);
if I > 1 then
Result := Copy(aFileName, 1, I - 1)
else
Result := aFileName; //on unix this is not an extention but an hidden file
end;
function GetProgramPath: string; //this may work on all platform
begin
Result := Trim(ExtractFilePath(Application.ExeName));
if Result[Length(Result)] <> DirectorySeparator then
Result := Result + DirectorySeparator;
end;
function CountItemsInStr(Str: string; Separator: Char): integer;
var
I: integer;
begin
if Str = '' then
begin
Result := 0;
Exit;
end;
Result := 1;
for I := 1 to Length(Str) do
if Str[I] = Separator then
Inc(Result);
if Str[Length(Str)] = Separator then
Dec(Result);
end;
function GetItemInStr(Str: string; Separator: Char; Index: integer): string;
var
I, J: integer;
S: string;
begin
//note that result = '' is equivalent to an error
S := '';
if Str = '' then
Exit;
I := 1;
J := 1;
while (I < Index) and (J < Length(Str)) do
begin
if Str[J] = Separator then
Inc(I);
Inc(J);
end;
if J >= Length(Str) then //in case of a terminal separator
Exit;
if Str[J] = Separator then
Inc(J);
repeat
S := S + Str[J];
Inc(J);
until (J > Length(Str)) or (Str[J] = Separator);
Result := Trim(S);
end;
function GetDesktopEnv: TDesktopEnv;
begin
Result := deUnknow; //unrecognized desktop environment
//if this Gnome specific env variable is set, probably the user is running Gnome
if GetEnvironmentVariable(rsEnvGnomeSession) <> '' then
Result := deGnome;
//if this KDE specific env variable is set, probably the user is running KDE
if GetEnvironmentVariable(rsEnvKDESession) <> '' then
Result := deKDE;
//if gnome or kde is explicitely declared in DESKTOP_SESSION env variable,
//override previously assumed result
{$warning Complete with other unixes desktop environment}
if GetEnvironmentVariable(rsEnvDesktopSession) = 'gnome' then
Result := deGnome
else
if getenvironmentvariable(rsEnvDesktopSession) = 'kde' then
Result := deKDE
else
if GetEnvironmentVariable(rsEnvDesktopSession) = 'xfce' then
Result := deXFCE
else
if GetEnvironmentVariable(rsEnvDesktopSession) = 'lxde' then
Result := deLXDE;
end;
function GetDesktopPath: string;
//superseeded in Windows
begin
{$IFDEF LINUX} //this should work on every unixes but have to be tested
Result := GetEnvironmentVariable(rsEnvUnixHomeDir) + '/Desktop/';
{$ENDIF}
{$IFDEF FREEBSD}
Result := GetEnvironmentVariable(rsEnvUnixHomeDir) + '/Desktop/';
{$ENDIF}
{$IFDEF NETBSD}
Result := GetEnvironmentVariable(rsEnvUnixHomeDir) + '/Desktop/';
{$ENDIF}
//generic, superseeded by system specific values, if not empty
if Result = '' then
Result := GetCurrentDir;
if Result[Length(Result)] <> DirectorySeparator then
Result := Result + DirectorySeparator;
end;
function GetHomePath: string;
begin
{$IFDEF LINUX} //this should work on every unixes but have to be tested
Result := GetEnvironmentVariable(rsEnvUnixHomeDir);
{$ENDIF}
{$IFDEF FREEBSD}
Result := GetEnvironmentVariable(rsEnvUnixHomeDir);
{$ENDIF}
{$IFDEF NETBSD}
Result := GetEnvironmentVariable(rsEnvUnixHomeDir);
{$ENDIF}
//generic, superseeded by system specific values, if not empty
if Result = '' then
Result := GetCurrentDir;
if Result[Length(Result)] <> DirectorySeparator then
Result := Result + DirectorySeparator;
end;
//return the first occurence index, not usefull if you need multiple ones
function StrExistsInList(const StrList: TStringList; S: string): integer;
var
I: Integer;
begin
Result := -1;
if not Assigned(StrList) then
Exit;
I := 0;
while (I < StrList.Count - 1) and (StrList[I] <> S) do
Inc(I); //increase until we have an occurence or we get to the end of the string
if StrList[I] = S then
Result := I;
end;
function StrExistsInListBox(const StrList: TListBox; S: string): integer;
var
SL: TStringList;
begin
SL := TStringList.Create;
SL.Assign(StrList.Items);
Result := StrExistsInList(SL, S);
end;
//for both following functions a "repeat [...] until StrXXX(<...>) = -1;"
//will make it happen on every possible occurence if any
function StrRemove(var StrList: TStringList; S: string): integer;
begin
Result := StrExistsInList(StrList, S);
StrList.Delete(Result);
end;
function StrChange(var StrList: TStringList; const sOld, sNew: string): integer;
begin
Result := StrExistsInList(StrList, sOld);
StrList[Result] := sNew;
end;
////////////////////////////////////////////////////////////////////////////////
//in Linux and BSDs if filename contains delimiter ' change the character in ",
//and checking special cases for Gnome and KDE in Windows delimiter is " and it's
//not a valid character in filenames, so this control returns the input string
//(which doesn't need to be variable) on other systems filenames are not escaped
//
//- convert %XX (where XX is an hexa value) to the equivalent char by code
//- braces management (' on unix and " on Windows) as unneeded with Lazarus.
//- deleting « file:// » if present.
//- Supporting environnement variables (eg. $(USER)\MonProg).
//- deleting double directory separators (eg. \\ or // -> \ or /).
//- automatic separator convertion (eg. with Windows a / would be \)
//- adds terminal \ or / for directories if not exists.
//- detect invalid chars (depending on the OS)
//
//Returns: Negative when errors, positive when Ok where
//Low(Result) is pos of the error when applicable and High(Result) the error code
//
//List of error codes:
//-$01XX: error in %XX convertion (mostly non hexa value)
//-$02XX: "$(" found but no ")" while checking environment (XX pos of "$(")
//-$0300: directory separator in a filename
//-$0400: Comma in a filename
//-$0500: windows only: use of a system reserved file extention
//-$10XX: empty env var (XX pos of "$(")
//-$20XX: invalid char where XX is the invalid char code
//+$0000: valid filename, no such file or directory
//+$1000: valid filename, directory exists
//+$2000: valid filename, file exist
function FormatFileName(S: String; out VS: string): Integer;
{$warning This should be splited in several functions for selective checkings}
var
Str, TmpS, EnvVar: String;
I, J: Integer;
Ch: Char;
const
FilePrefix = 'file://';
procedure InvalidChar(C: Char);
begin
VS := Str;
Result := $2000 + Ord(C);
end;
begin
Result := $0000;
Str := Trim(S);
// Delete ' on Unix or " on Windows as it is not needed when assuming there's
// one file path per string
I := 1;
repeat
I := Pos('''', Str);
if I > 0 then
Delete(Str, I, 1);
until I = 0;
//find and delete 'file://' (and any part before) if it is passed as part of
//filename (it happens sometimes in Gnome, i.e. using "open with" context
//menu entry) or if it has been entered as is by the user
I := Pos(FilePrefix, Str);
if I > 0 then
Str := Copy(Str, I + Length(FilePrefix), Length(Str) - I - Length(FilePrefix) - 1);
//replace %xx with the appropriate character used sometimes to pass non
//available keyboards char or spaces. xx must be 2 hexa char
repeat
I := Pos('%', Str);
if I <> 0 then
try //if there's synthax error like non hexa char
Ch := Char(StrToWord(Str[I + 1] + Str[I + 2]));
Delete(Str, I, 3);
Insert(Ch, Str, I);
except
Result := $0100 + I;
end;
//if error leave everything else as is as it's not valid path anyway
until (I = 0) or (Result <> 0);
//the application support the use of environment variable in filenames just
//like Unix command line does, so this extract environment variable when $()
//symbol is found
repeat
I := Pos('$(', Str);
if I <> 0 then
try
J := I;
while Str[J] <> ')' do
Inc(J);
//on windows we use Windows unt that have an incompatible GetEnvironmentVariable
EnvVar := SysUtils.GetEnvironmentVariable(Copy(Str, I + 2, J - I - 2));
if EnvVar <> '' then
begin
Delete(Str, I, I - J);
Insert(EnvVar, Str, I);
end else
Result := $1000 + I;
except
Result := $0200 + I;
end;
until (I = 0) or (Result <> 0);
// remove double / on unix or double \\ on windows
{$warning This is not working when we have network address}
repeat
I := Pos('//', Str);
if I = 1 then
I := 0;
if I <> 0 then
if Str[I - 1] <> ':' then //it's looking like an URL so don't erase it
Delete(Str, I, 1);
until I = 0;
// check for remaining invalid char
for I := 0 to 31 do
if (Pos(Char(I), Str) <> 0) then
InvalidChar(Char(I));
if Pos('*', Str) <> 0 then
InvalidChar('*');
if Pos('?' , Str) <> 0 then
InvalidChar('?');
if Pos('''', Str) <> 0 then
InvalidChar('''');
if Pos(':', Str) <> 0 then
InvalidChar(':');
if Pos('<', Str) <> 0 then
InvalidChar('<');
if Pos('>', Str) <> 0 then
InvalidChar('>');
if Pos('|', Str) <> 0 then
InvalidChar('|');
TmpS := ExtractFileName(Str);
//reserved characters, filename only (others are checked for the full name)
if (Pos('\', TmpS) <> 0) or (Pos('/', TmpS) <> 0) then
Result := $0300; //we should get the pos for low(result)
if Pos(':', TmpS) <> 0 then
Result := $0400; //we should get the pos for low(result)
//reserved filename extentions (Windows)
if Result <> $0000 then
Result := -Result
else
if DirectoryExists(Str) then
begin
if Str[Length(Str)] <> '/' then
Str := Str + '/';
Result := $1000;
end else
if FileExists(Str) then
Result := $2000;
VS := Str;
end;
function DirectoryIsEmpty(ADir: string): Boolean;
var
SR: TSearchRec;
Mask: string;
begin
Mask := '*';
if ADir[Length(ADir)] <> DirectorySeparator then
ADir := ADir + DirectorySeparator;
Result := FindFirst(ADir + Mask, faAnyFile, SR) <> 0;
FindClose(SR);
end;
function RemoveSpecialChar(const S: UnicodeString): UnicodeString;
var
I: Integer;
Tmp: UnicodeString;
begin
Tmp := S;
for I := 1 to Length(S) do
if not (S[I] in ['0'..'9', '.', '-', '_', 'A'..'Z', 'a'..'z']) then
Tmp[I] := '_'
else
Tmp[I] := S[I];
Result := Tmp;
end;
function CreateLockFile(const AName: string): Boolean;
var
AFile: Text;
begin
Result := True;
try
if FileExists(AName) then
if not DeleteFile(AName) then
begin
Result := False;
Exit;
end;
{$I-}
Assign(AFile, AName);
Rewrite(AFile);
if IOResult = 0 then
begin
Writeln(AFile, GetUserName + '@' + GetComputerName);
Writeln(AFile, IntToStr(GetProcessID));
Close(AFile);
Result := IOResult = 0;
end else
Result := False;
{$I+}
except
Result := False;
end;
end;
function GetNumberOfFiles(const ADir: string;
const AOpt: TFileCountOpt): LongWord;
var
Rec: TSearchRec;
S: string;
begin
Result := 0;
if ADir[Length(ADir)] <> DirectorySeparator then
S := ADir + DirectorySeparator
else
S := ADir;
if FindFirst(S + '*', faAnyFile, Rec) = 0 then
begin
repeat
if ((Rec.Attr and faDirectory) <> faDirectory) then //file ?
Inc(Result)
else //directories:
if Rec.Name[1] <> '.' then //don't count '.' and '..'
begin
if fcIncludeDirs in AOpt then
Inc(Result);
if fcIncludeSubDirs in AOpt then
Result := Result + GetNumberOfFiles(S + '/' + Rec.Name, AOpt);
end;
until FindNext(Rec) <> 0;
FindClose(Rec);
end;
end;
function DirectoryIsReadOnly(const ADirName: string): Boolean;
begin
//pure Unix type checking (will not work on anything else)
Result := fpAccess(PChar(pointer(ADirName)), W_OK) <> 0;
end;
function ExtractHostName(const S: string): string;
var
Start: integer;
Delim: Char;
Tmp: string;
begin
Result := '';
Delim := '/';
Start := Pos('//', S);
if Start = 0 then
begin
Start := Pos('\\', S); //this is for some windows servers
Delim := '\';
end;
if Start = 0 then
Exit;
Tmp := Copy(S, Start + 1, Length(S) - Start);
if Pos(Delim, Tmp) <> 0 then
Result := Copy(Tmp, 1, Pos(Delim, Tmp))
else
Result := Tmp;
end;
procedure GetProxyInfo(const S: string; out User, Pass, Address, Port: string);
var
Tmp, UsrInfo, AddrInfo: string;
begin
if Pos(sHttpPrefix, S) = 1 then
Tmp := Copy(S, Length(sHttpPrefix) + 1, Length(S) - Length(sHttpPrefix))
else
if Pos( sFtpPrefix, S) = 1 then
Tmp := Copy(S, Length(sFtpPrefix) + 1, Length(S) - Length(sFtpPrefix));
if Pos('@', S) <> 0 then
begin
UsrInfo := Copy(Tmp, 1, Pos('@', Tmp) - 1);
AddrInfo := Copy(Tmp, Pos('@', Tmp) + 1, Length(Tmp) - Pos('@', Tmp));
end else
begin
UsrInfo := '';
AddrInfo := Tmp;
end;
if (AddrInfo <> '') and ((AddrInfo[Length(AddrInfo)] = '/') or
(AddrInfo[Length(AddrInfo)] = ';')) then
AddrInfo := Copy(AddrInfo, 1, Length(AddrInfo) - 1);
if UsrInfo <> '' then
if Pos(':', UsrInfo) <> 0 then
begin
User := Copy(UsrInfo, 1, Pos(':', UsrInfo) - 1);
Pass := Copy(UsrInfo, Pos(':', UsrInfo) + 1,
Length(UsrInfo) - Pos(':', UsrInfo));
end else
begin
User := UsrInfo;
Pass := '';
end;
if Pos(':', AddrInfo) <> 0 then
begin
Address := Copy(AddrInfo, 1, Pos(':', AddrInfo) - 1);
Port := Copy(AddrInfo, Pos(':', AddrInfo) + 1,
Length(AddrInfo) - Pos(':', AddrInfo));
end else
begin
Address := AddrInfo;
Port := '';
end;
end;
end.