moparisthebest/Simba
1
0
Fork 0
mirror of https://github.com/moparisthebest/Simba synced 2024-11-25 10:42:20 -05:00
Code Issues Releases Wiki Activity

Fixed issue with settings file being saved in the wrong directory.

Browse Source 
Simba now has some parameters (-o/--open to open a file and -r/--run to run that file at startup).
Simba now opens a file correctly if you double click an associated .simb file.
Initalized several TPA-functions-results.. (BoxFromTPA could return random values when sending an empty TPA).
Opening/Creating a 'script' will now happen in a new tab (unless the current tab is the same as the default script)
Restructured the internets unit (+ implemented all of the HTTP-client stuff).
And updated the Synapse units.


git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@538 3f818213-9676-44b0-a9b4-5e4c4e03d09d
This commit is contained in:
Raymond 2010-02-13 16:56:46 +00:00
parent 1865e848e2
commit 87c496ca85
43 changed files with 948 additions and 345 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
trunk/Projects/SAMufasaGUI/simbasettings.pas
View File

@ -8,9 +8,6 @@ uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
ComCtrls, StdCtrls, settings;
const
SimbaSettingsFile = 'settings.xml';
type
{ TSettingsForm }
@ -34,6 +31,7 @@ type
var
SettingsForm: TSettingsForm;
SimbaSettingsFile : string;
implementation

55
trunk/Projects/SAMufasaGUI/testunit.pas
View File

@ -43,7 +43,7 @@ uses
ColorBox , about, framefunctionlist, ocr, updateform, simbasettings;
const
SimbaVersion = 537;
SimbaVersion = 538;
type
@ -342,6 +342,7 @@ type
procedure RefreshTabSender(sender : PtrInt);
procedure CreateDefaultEnvironment;
procedure InitalizeTMThread(var Thread : TMThread);
procedure HandleParameters;
end;
procedure formWriteln( S : String);
@ -838,6 +839,7 @@ begin
CreateSetting('Settings/Interpreter/UseCPascal', 'False');
CreateSetting('Settings/Fonts/LoadOnStartUp', 'True');
CreateSetting('Settings/Tabs/OpenNextOnClose','False');
CreateSetting('Settings/Tabs/OpenScriptInNewTab','True');
CreateSetting('Settings/ColourPicker/ShowHistoryOnPick', 'True');
CreateSetting('Settings/Updater/RemoteLink',
'http://old.villavu.com/merlijn/Simba'{$IFDEF WINDOWS}+'.exe'{$ENDIF});
@ -928,6 +930,34 @@ begin
end;
procedure TForm1.HandleParameters;
var
DoRun : Boolean;
ErrorMsg : string;
begin
DoRun := false;
if Paramcount = 1 then
begin
if FileExists(ParamStr(1)) then
LoadScriptFile(paramstr(1));
end else
begin;
ErrorMsg:=Application.CheckOptions('ro:','run open:');
if ErrorMsg <> '' then
writeln(ErrorMSG)
else
begin
if Application.HasOption('o','open') then
begin;
LoadScriptFile(Application.GetOptionValue('o','open'));
DoRun:= Application.HasOption('r','run');
end;
end;
end;
if DoRun then
Self.RunScript;
end;
procedure TForm1.ActionTabLastExecute(Sender: TObject);
var
@ -1015,7 +1045,8 @@ end;
procedure TForm1.ActionNewExecute(Sender: TObject);
begin
Self.ClearScript;
//Self.ClearScript;
Self.AddTab;
end;
procedure TForm1.ActionNewTabExecute(Sender: TObject);
@ -1336,7 +1367,8 @@ procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
MainDir:= ExtractFileDir(Application.ExeName);
if FileExists(MainDir + DS + SimbaSettingsFile) then
SimbaSettingsFile := MainDir + DS + 'settings.xml';
if FileExists(SimbaSettingsFile) then
Application.CreateForm(TSettingsForm,SettingsForm)
else begin
Application.CreateForm(TSettingsForm,SettingsForm);
@ -1368,6 +1400,7 @@ begin
{$endif}
frmFunctionList.OnEndDock:= @frmFunctionList.FrameEndDock;
FirstRun := true;//Our next run is the first run.
HandleParameters;
end;
procedure TForm1.FormDestroy(Sender: TObject);
@ -1827,24 +1860,34 @@ begin
end;
function TForm1.OpenScript: boolean;
var
OpenInNewTab : boolean;
begin
Result := False;
if CanExitOrOpen = false then
Exit;
OpenInNewTab:= (LowerCase(LoadSettingDef('Settings/Tabs/OpenScriptInNewTab','True')) = 'true');
if not OpenInNewTab then
if CanExitOrOpen = false then
Exit;
with TOpenDialog.Create(nil) do
try
Filter:= 'Simba Files|*.simb;*.cogat;*.mufa;*.txt|Any files|*.*';
if Execute then
result := LoadScriptFile(filename);
if FileExists(filename) then
result := LoadScriptFile(filename);
finally
Free;
end;
end;
function TForm1.LoadScriptFile(FileName : string): boolean;
var
OpenInNewTab : boolean;
begin
OpenInNewTab:= (LowerCase(LoadSettingDef('Settings/Tabs/OpenScriptInNewTab','True')) = 'true');
if FileExists(FileName) then
begin;
if OpenInNewTab and (CurrScript.SynEdit.Text <> CurrScript.ScriptDefault) then //Add la tab!
self.addtab;
with CurrScript do
begin
filename := SetDirSeparators(filename);

44
trunk/Units/MMLAddon/PSInc/Wrappers/internets.inc
View File

@ -2,3 +2,47 @@ function ps_GetPage(S: String): String; extdecl;
begin
result := GetPage(S);
end;
function ps_InitializeHTTPClient(HandleCookies, HandleRedirects: Boolean): Integer; extdecl;
begin
result := CurrThread.MInternet.CreateHTTPClient(HandleCookies); extdecl;
end;
procedure ps_FreeHTTPClient(Client: Integer); extdecl;
begin;
CurrThread.MInternet.GetHTTPClient(Client).Free;
end;
function ps_GetHTTPPage(Client: Integer; URL: string): string; extdecl;
begin
result := CurrThread.MInternet.GetHTTPClient(Client).GetHTTPPage(url);
end;
procedure ps_SetHTTPUserAgent(Client: Integer; Agent: string); extdecl;
begin
CurrThread.MInternet.GetHTTPClient(Client).SetHTTPUserAgent(agent);
end;
function ps_PostHTTPPage(Client: Integer; Url: string; PostData: string): string; extdecl;
begin
result := CurrThread.MInternet.GetHTTPClient(Client).PostHTTPPage(url,postdata);
end;
function ps_PostHTTPPageEx(Client: Integer; Url: string): string; extdecl;
begin
result := CurrThread.MInternet.GetHTTPClient(Client).PostHTTPPage(url);
end;
procedure ps_ClearPostData(Client: Integer); extdecl;
begin
CurrThread.MInternet.GetHTTPClient(Client).ClearPostData;
end;
procedure ps_AddPostVariable(Client: Integer; VarName, VarValue: string); extdecl;
begin
CurrThread.MInternet.GetHTTPClient(Client).AddPostVariable(varname,varvalue);
end;
function ps_GetRawHeaders(Client: Integer): string; extdecl;
begin
result := CurrThread.MInternet.GetHTTPClient(client).GetRawHeaders;
end;

10
trunk/Units/MMLAddon/PSInc/psexportedmethods.inc
View File

@ -150,6 +150,16 @@ AddFunction(@ps_Replace,'function ReplaceWrap(Text, FindStr, ReplaceStr: string;
SetCurrSection('Web');
AddFunction(@OpenWebPage,'procedure OpenWebPage(url : string);');
AddFunction(@ps_GetPage,'function GetPage(url : string): string;');
AddFunction(@ps_InitializeHTTPClient,'function InitializeHTTPClient(HandleCookies, HandleRedirects: Boolean): Integer;');
AddFunction(@ps_FreeHTTPClient,'procedure FreeHTTPClient(Client: Integer);');
AddFunction(@ps_GetHTTPPage,'function GetHTTPPage(Client: Integer; URL: string): string;');
AddFunction(@ps_SetHTTPUserAgent,'procedure SetHTTPUserAgent(Client: Integer; Agent: string);');
AddFunction(@ps_PostHTTPPage,'function PostHTTPPage(Client: Integer; Url: string; PostData: string): string;');
AddFunction(@ps_PostHTTPPageEx,'function PostHTTPPageEx(Client: Integer; Url: string): string;');
AddFunction(@ps_ClearPostData,'procedure ClearPostData(Client: Integer);');
AddFunction(@ps_AddPostVariable,'procedure AddPostVariable(Client: Integer; VarName, VarValue: string);');
AddFunction(@ps_GetRawHeaders,'function GetRawHeaders(Client: Integer): string;');
{ Color Conversions and Speed }

164
trunk/Units/MMLAddon/internets.pas
View File

@ -5,13 +5,47 @@ unit internets;
interface
uses
Classes, SysUtils;
Classes, SysUtils,httpsend;
function GetPage(URL: String): String;
type
{ THTTPClient }
THTTPClient = class(TObject)
private
HTTPSend : THTTPSend;
fHandleCookies : boolean;
PostVariables : TStringList;
public
procedure SetHTTPUserAgent(agent : string);
function GetHTTPPage(url : string ) : string;
function PostHTTPPage(Url: string; PostData: string): string;overload;
function PostHTTPPage(Url: string): string;overload;
function GetRawHeaders: string;
procedure ClearPostData;
procedure AddPostVariable(VarName, VarValue: string);
constructor Create(HandleCookies : boolean = true);
destructor Destroy;override;
end;
{ TMInternet }
TMInternet = class(TObject)
protected
Client : TObject;
Connections : TList;
HTTPClients : TList;
public
function CreateHTTPClient(HandleCookies : boolean = true) : integer;
function GetHTTPClient(Index : integer) : THTTPClient;
procedure FreeHTTPClient(Index: Integer);
constructor Create(Owner : TObject);
destructor Destroy;override;
end;
implementation
uses
httpsend;
synacode;
{ OTHER }
function GetPage(URL: String): String;
@ -20,9 +54,133 @@ var
begin
s:=TStringList.Create;
HttpGetText(URL, s);
result := String(s.GetText);
result := s.Text;
s.Free;
end;
{ TMInternet }
function TMInternet.CreateHTTPClient(HandleCookies: boolean = true): integer;
begin;
Result := HTTPClients.Add(THTTPClient.Create(HandleCookies));
end;
function TMInternet.GetHTTPClient(Index: integer): THTTPClient;
begin
if (index < 0) or (index >= HTTPClients.Count) then
raise exception.CreateFmt('GetHTTPClient: Trying to acces an index(%d) that is out of range',[index]);
if HTTPClients[index] = nil then
raise exception.CreateFmt('GetHTTPClient: Trying to acces an index(%d) that is freed',[index]);
result := THTTPClient(httpclients[index]);
end;
procedure TMInternet.FreeHTTPClient(Index: Integer);
begin
if (index < 0) or (index >= HTTPClients.Count) then
raise exception.CreateFmt('FreeHTTPClient: Trying to free an index(%d) that is out of range',[index]);
if HTTPClients[index] = nil then
raise exception.CreateFmt('FreeHTTPClient: Trying to free an index(%d) that is already freed',[index]);
THTTPClient(HTTPClients[index]).Free;
end;
constructor TMInternet.Create(Owner: TObject);
begin
inherited Create;
client := Owner;
Connections := TList.Create;
HTTPClients := TList.Create;
end;
destructor TMInternet.Destroy;
var
i : integer;
begin
for i := Connections.Count -1 downto 0 do
if Connections[i] <> nil then
TObject(Connections[i]).Free;
for i := HTTPClients.Count -1 downto 0 do
if HTTPClients[i] <> nil then
THTTPClient(HTTPClients[i]).Free;
Connections.Free;
HTTPClients.Free;
inherited Destroy;
end;
{ THTTPClient }
procedure THTTPClient.SetHTTPUserAgent(agent: string);
begin
HTTPSend.UserAgent := agent;
end;
function THTTPClient.GetHTTPPage(url: string): string;
begin
if not fHandleCookies then
HTTPSend.Cookies.Clear;
HTTPSend.MimeType := 'text/html';
if HTTPSend.HTTPMethod('GET',url) then
begin;
SetLength(result,HTTPSend.Document.Size);
HTTPSend.Document.Read(result[1],length(result));
end else
result := '';
end;
function THTTPClient.PostHTTPPage(Url: string; PostData: string): string;
begin
HTTPSend.MimeType := 'application/x-www-form-urlencoded';
HTTPSend.Document.Clear;
HTTPSend.Document.Write(Postdata[1],length(postdata));
if HTTPSend.HTTPMethod('POST',url) then
begin;
SetLength(result,HTTPSend.Document.Size);
HTTPSend.Document.Read(result[1],Length(result));
end else
result := '';
end;
function THTTPClient.PostHTTPPage(Url: string): string;
var
PostData : string;
i : integer;
begin
PostData := '';
for i := 0 to PostVariables.Count - 1 do
PostData := PostData + PostVariables[i] +'&';
if Length(PostData) > 1 then
setlength(postdata,length(postdata) - 1); //Wipe away that last &
result := PostHTTPPage(url,postdata);
end;
function THTTPClient.GetRawHeaders: string;
begin
Result := HTTPSend.Headers.Text;
end;
procedure THTTPClient.ClearPostData;
begin
PostVariables.Clear;
end;
procedure THTTPClient.AddPostVariable(VarName, VarValue: string);
begin
PostVariables.Add(Varname + '=' + VarValue);
end;
constructor THTTPClient.Create(HandleCookies : boolean = true);
begin
inherited Create;
HTTPSend := THTTPSend.Create;
fHandleCookies:= HandleCookies;
PostVariables := TStringList.Create;
end;
destructor THTTPClient.Destroy;
begin
HTTPSend.Free;
PostVariables.Free;
inherited Destroy;
end;
end.

6
trunk/Units/MMLAddon/mmlpsthread.pas
View File

@ -32,7 +32,7 @@ interface
uses
Classes, SysUtils, client, uPSComponent,uPSCompiler,
uPSRuntime,stdCtrls, uPSPreProcessor,MufasaTypes, web,
bitmaps, plugins, libloader, dynlibs;
bitmaps, plugins, libloader, dynlibs,internets;
type
@ -82,6 +82,7 @@ type
public
Client : TClient;
MInternet : TMInternet;
StartTime : LongWord;
DebugMemo : TMemo;
@ -184,7 +185,6 @@ uses
uPSR_extctrls, //Runtime-libs
Graphics, //For Graphics types
math, //Maths!
internets, // internets
strutils,
tpa, //Tpa stuff
forms,//Forms
@ -265,6 +265,7 @@ end;
constructor TMThread.Create(CreateSuspended: boolean; TheSyncInfo: PSyncInfo; plugin_dir: string);
begin
Client := TClient.Create(plugin_dir);
MInternet := TMInternet.Create(Client);
SyncInfo:= TheSyncInfo;
ExportedMethods:= GetExportedMethods;
FreeOnTerminate := True;
@ -276,6 +277,7 @@ end;
destructor TMThread.Destroy;
begin
MInternet.Free;
Client.Free;
inherited Destroy;
end;

1
trunk/Units/MMLCore/client.pas
View File

@ -51,7 +51,6 @@ It binds all the components together.
MBitmaps : TMBitmaps;
MDTM: TMDTM;
MOCR: TMOCR;
end;
implementation

3
trunk/Units/MMLCore/tpa.pas
View File

@ -672,6 +672,7 @@ function MiddleTPA(tpa: TPointArray): TPoint;
var
i, l: Integer;
begin
FillChar(result,sizeof(TPoint),0);
l := High(tpa);
if (l < 0) then Exit;
Result.x := 0;
@ -1073,6 +1074,7 @@ function GetATPABounds(ATPA: T2DPointArray): TBox;
var
I,II,L2,L : Integer;
begin;
FillChar(result,sizeof(TBox),0);
L := High(ATPA);
if (l < 0) then Exit;
For I := 0 to L do
@ -1108,6 +1110,7 @@ function GetTPABounds(TPA: TPointArray): TBox;
var
I,L : Integer;
begin;
FillChar(result,sizeof(TBox),0);
L := High(TPA);
if (l < 0) then Exit;
Result.x1 := TPA[0].x;

5
trunk/Units/Synapse/asn1util.pas
View File

@ -62,6 +62,11 @@ For sample of using, look to @link(TSnmpSend) or @link(TLdapSend)class.
{$MODE DELPHI}
{$ENDIF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit asn1util;
interface

158
trunk/Units/Synapse/blcksock.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 009.006.000 |
| Project : Ararat Synapse | 009.008.002 |
|==============================================================================|
| Content: Library base |
|==============================================================================|
| Copyright (c)1999-2008, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)1999-2008. |
| Portions created by Lukas Gebauer are Copyright (c)1999-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -82,6 +82,18 @@ Core with implementation basic socket classes.
{$H+}
{$M+}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit blcksock;
interface
@ -309,6 +321,7 @@ type
FSocket: TSocket;
FLastError: Integer;
FLastErrorDesc: string;
FOwner: TObject;
procedure SetDelayedOption(const Value: TSynaOption);
procedure DelayedOption(const Value: TSynaOption);
procedure ProcessDelayedOptions;
@ -383,6 +396,16 @@ type
address. (Not work properly on prilimitary winsock IPv6 support!)}
procedure Connect(IP, Port: string); virtual;
{:Sets socket to receive mode for new incoming connections. It is necessary
to use @link(TBlockSocket.BIND) function call before this method to select
receiving port!}
procedure Listen; virtual;
{:Waits until new incoming connection comes. After it comes a new socket is
automatically created (socket handler is returned by this function as
result).}
function Accept: TSocket; virtual;
{:Sends data of LENGTH from BUFFER address via connected socket. System
automatically splits data to packets.}
function SendBuffer(Buffer: Tmemory; Length: Integer): Integer; virtual;
@ -672,10 +695,13 @@ type
{:Return value of protocol type for socket creation.}
function GetSocketProtocol: integer; Virtual;
{:WSA structure with information about socket provider. On linux is this
structure simulated!}
{:WSA structure with information about socket provider. On non-windows
platforms this structure is simulated!}
property WSAData: TWSADATA read GetWsaData;
{:FDset structure prepared for usage with this socket.}
property FDset: TFDSet read FFDset;
{:Structure describing local socket side.}
property LocalSin: TVarSin read FLocalSin write FLocalSin;
@ -821,6 +847,8 @@ type
on real socket operations too!
Note: Each heartbeat slowing socket processing.}
property HeartbeatRate: integer read FHeartbeatRate Write FHeartbeatRate;
{:What class own this socket? Used by protocol implementation classes.}
property Owner: TObject read FOwner Write FOwner;
end;
{:@abstract(Support for SOCKS4 and SOCKS5 proxy)
@ -923,10 +951,6 @@ type
constructor CreateWithSSL(SSLPlugin: TSSLClass);
destructor Destroy; override;
{:Return descriptive string for @link(LastError). On case of error
in SSL/TLS subsystem, it returns right error description.}
function GetErrorDescEx: string; override;
{:See @link(TBlockSocket.CloseSocket)}
procedure CloseSocket; override;
@ -939,7 +963,7 @@ type
If you use SOCKS, activate incoming TCP connection by this proxy. (By BIND
method of SOCKS.)}
procedure Listen; virtual;
procedure Listen; override;
{:Waits until new incoming connection comes. After it comes a new socket is
automatically created (socket handler is returned by this function as
@ -948,7 +972,7 @@ type
If you use SOCKS, new socket is not created! In this case is used same
socket as socket for listening! So, you can accept only one connection in
SOCKS mode.}
function Accept: TSocket;
function Accept: TSocket; override;
{:Connects socket to remote IP address and PORT. The same rules as with
@link(TBlockSocket.BIND) method are valid. The only exception is that PORT
@ -1017,6 +1041,10 @@ type
{:@True if is used HTTP tunnel mode.}
property HTTPTunnel: Boolean read FHTTPTunnel;
published
{:Return descriptive string for @link(LastError). On case of error
in SSL/TLS subsystem, it returns right error description.}
function GetErrorDescEx: string; override;
{:Specify IP address of HTTP proxy. Assingning non-empty value to this
property enable HTTP-tunnel mode. This mode is for tunnelling any outgoing
TCP connection through HTTP proxy server. (If policy on HTTP proxy server
@ -1136,6 +1164,30 @@ type
function GetSocketProtocol: integer; override;
end;
{:@abstract(Implementation of PGM-message socket.)
Not all systems supports this protocol!}
TPGMMessageBlockSocket = class(TBlockSocket)
public
{:Return value of socket type. For PGM-message return SOCK_RDM.}
function GetSocketType: integer; override;
{:Return value of protocol type for socket creation. For PGM-message returns
IPPROTO_RM.}
function GetSocketProtocol: integer; override;
end;
{:@abstract(Implementation of PGM-stream socket.)
Not all systems supports this protocol!}
TPGMStreamBlockSocket = class(TBlockSocket)
public
{:Return value of socket type. For PGM-stream return SOCK_STREAM.}
function GetSocketType: integer; override;
{:Return value of protocol type for socket creation. For PGM-stream returns
IPPROTO_RM.}
function GetSocketProtocol: integer; override;
end;
{:@abstract(Parent class for all SSL plugins.)
This is abstract class defining interface for other SSL plugins.
@ -1457,6 +1509,7 @@ begin
FStopFlag := False;
FNonblockSendTimeout := 15000;
FHeartbeatRate := 0;
FOwner := nil;
{$IFNDEF ONCEWINSOCK}
if Stub = '' then
Stub := DLLStackName;
@ -1508,7 +1561,7 @@ var
li: TLinger;
x: integer;
buf: TMemory;
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
timeval: TTimeval;
{$ENDIF}
begin
@ -1558,7 +1611,7 @@ begin
synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
buf, SizeOf(Value.Value));
{$ELSE}
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
buf := @Value.Value;
synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
buf, SizeOf(Value.Value));
@ -1575,7 +1628,7 @@ begin
{$IFDEF CIL}
buf := System.BitConverter.GetBytes(value.Value);
{$ELSE}
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
buf := @Value.Value;
synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO),
buf, SizeOf(Value.Value));
@ -1840,6 +1893,22 @@ begin
DoStatus(HR_Connect, IP + ':' + Port);
end;
procedure TBlockSocket.Listen;
begin
SockCheck(synsock.Listen(FSocket, SOMAXCONN));
GetSins;
ExceptCheck;
DoStatus(HR_Listen, '');
end;
function TBlockSocket.Accept: TSocket;
begin
Result := synsock.Accept(FSocket, FRemoteSin);
/// SockCheck(Result);
ExceptCheck;
DoStatus(HR_Accept, '');
end;
procedure TBlockSocket.GetSinLocal;
begin
synsock.GetSockName(FSocket, FLocalSin);
@ -2014,6 +2083,7 @@ var
{$ENDIF}
begin
b := true;
l := 0;
if WithSize then
begin
l := Stream.Size - Stream.Position;;
@ -2189,7 +2259,7 @@ begin
end
else
begin
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
//not drain CPU on large downloads...
Sleep(0);
{$ENDIF}
@ -3145,7 +3215,7 @@ end;
function TSocksBlockSocket.SocksOpen: boolean;
var
Buf: string;
Buf: AnsiString;
n: integer;
begin
Result := False;
@ -3175,8 +3245,8 @@ begin
;
2:
begin
Buf := #1 + char(Length(FSocksUsername)) + FSocksUsername
+ char(Length(FSocksPassword)) + FSocksPassword;
Buf := #1 + AnsiChar(Length(FSocksUsername)) + FSocksUsername
+ AnsiChar(Length(FSocksPassword)) + FSocksPassword;
SendString(Buf);
Buf := RecvBufferStr(2, FSocksTimeout);
if Length(Buf) < 2 then
@ -3199,14 +3269,14 @@ end;
function TSocksBlockSocket.SocksRequest(Cmd: Byte;
const IP, Port: string): Boolean;
var
Buf: string;
Buf: AnsiString;
begin
FBypassFlag := True;
try
if FSocksType <> ST_Socks5 then
Buf := #4 + char(Cmd) + SocksCode(IP, Port)
Buf := #4 + AnsiChar(Cmd) + SocksCode(IP, Port)
else
Buf := #5 + char(Cmd) + #0 + SocksCode(IP, Port);
Buf := #5 + AnsiChar(Cmd) + #0 + SocksCode(IP, Port);
SendString(Buf);
Result := FLastError = 0;
finally
@ -3216,7 +3286,7 @@ end;
function TSocksBlockSocket.SocksResponse: Boolean;
var
Buf, s: string;
Buf, s: AnsiString;
x: integer;
begin
Result := False;
@ -3249,7 +3319,7 @@ begin
x := RecvByte(FSocksTimeout);
if FLastError <> 0 then
Exit;
s := char(x) + RecvBufferStr(x, FSocksTimeout);
s := AnsiChar(x) + RecvBufferStr(x, FSocksTimeout);
end;
4:
s := RecvBufferStr(16, FSocksTimeout);
@ -3304,10 +3374,10 @@ begin
ip6 := StrToIP6(IP);
Result := #4;
for n := 0 to 15 do
Result := Result + char(ip6[n]);
Result := Result + AnsiChar(ip6[n]);
end
else
Result := #3 + char(Length(IP)) + IP;
Result := #3 + AnsiChar(Length(IP)) + IP;
Result := Result + CodeInt(ResolvePort(Port));
end;
end;
@ -3667,8 +3737,7 @@ var
begin
if FSocksIP = '' then
begin
SockCheck(synsock.Listen(FSocket, SOMAXCONN));
GetSins;
inherited Listen;
end
else
begin
@ -3690,9 +3759,9 @@ begin
FSocksLocalPort := FSocksResponsePort;
FSocksRemoteIP := '';
FSocksRemotePort := '';
ExceptCheck;
DoStatus(HR_Listen, '');
end;
ExceptCheck;
DoStatus(HR_Listen, '');
end;
function TTCPBlockSocket.Accept: TSocket;
@ -3704,14 +3773,13 @@ begin
FSocksRemoteIP := FSocksResponseIP;
FSocksRemotePort := FSocksResponsePort;
Result := FSocket;
ExceptCheck;
DoStatus(HR_Accept, '');
end
else
begin
Result := synsock.Accept(FSocket, FRemoteSin);
/// SockCheck(Result);
result := inherited Accept;
end;
ExceptCheck;
DoStatus(HR_Accept, '');
end;
procedure TTCPBlockSocket.Connect(IP, Port: string);
@ -3956,6 +4024,30 @@ end;
{======================================================================}
function TPGMmessageBlockSocket.GetSocketType: integer;
begin
Result := integer(SOCK_RDM);
end;
function TPGMmessageBlockSocket.GetSocketProtocol: integer;
begin
Result := integer(IPPROTO_RM);
end;
{======================================================================}
function TPGMstreamBlockSocket.GetSocketType: integer;
begin
Result := integer(SOCK_STREAM);
end;
function TPGMstreamBlockSocket.GetSocketProtocol: integer;
begin
Result := integer(IPPROTO_RM);
end;
{======================================================================}
constructor TSynaClient.Create;
begin
inherited Create;

14
trunk/Units/Synapse/clamsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.000 |
| Project : Ararat Synapse | 001.001.001 |
|==============================================================================|
| Content: ClamAV-daemon client |
|==============================================================================|
| Copyright (c)2005-2009, Lukas Gebauer |
| Copyright (c)2005-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005-2009. |
| Portions created by Lukas Gebauer are Copyright (c)2005-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -54,6 +54,11 @@ daemon from ClamAV. See more about ClamAV on @LINK(http://www.clamav.net)
{$Q-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit clamsend;
interface
@ -121,7 +126,9 @@ constructor TClamSend.Create;
begin
inherited Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FDSock := TTCPBlockSocket.Create;
FDSock.Owner := self;
FTimeout := 60000;
FTargetPort := cClamProtocol;
FSession := false;
@ -247,7 +254,6 @@ end;
function TClamSend.ScanStream2(const Value: TStream): AnsiString;
var
i: integer;
s: AnsiString;
begin
Result := '';
if not FSession then

17
trunk/Units/Synapse/dnssend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 002.007.004 |
| Project : Ararat Synapse | 002.007.006 |
|==============================================================================|
| Content: DNS client |
|==============================================================================|
| Copyright (c)1999-2007, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2007. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -54,6 +54,11 @@ Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230
{$Q-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit dnssend;
interface
@ -212,7 +217,9 @@ constructor TDNSSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FTCPSock := TTCPBlockSocket.Create;
FTCPSock.Owner := self;
FUseTCP := False;
FTimeout := 10000;
FTargetPort := cDnsProtocol;
@ -246,13 +253,13 @@ begin
for n := 1 to Length(Value) do
if Value[n] = '.' then
begin
Result := Result + Char(Length(s)) + s;
Result := Result + AnsiChar(Length(s)) + s;
s := '';
end
else
s := s + Value[n];
if s <> '' then
Result := Result + Char(Length(s)) + s;
Result := Result + AnsiChar(Length(s)) + s;
Result := Result + #0;
end;
end;

36
trunk/Units/Synapse/ftpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 003.005.001 |
| Project : Ararat Synapse | 003.005.003 |
|==============================================================================|
| Content: FTP client |
|==============================================================================|
| Copyright (c)1999-2008, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2008. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -53,6 +53,11 @@ Used RFC: RFC-959, RFC-2228, RFC-2428
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit ftpsend;
interface
@ -84,18 +89,17 @@ type
listing of FTP server.}
TFTPListRec = class(TObject)
private
FFileName: string;
FFileName: String;
FDirectory: Boolean;
FReadable: Boolean;
FFileSize: Longint;
FFileTime: TDateTime;
FOriginalLine: string;
FMask: string;
FPermission: string;
FPermission: String;
public
{: You can assign another TFTPListRec to this object.}
procedure Assign(Value: TFTPListRec); virtual;
published
{:name of file}
property FileName: string read FFileName write FFileName;
{:if name is subdirectory not file.}
@ -135,16 +139,16 @@ type
YearTime: string;
Year: string;
Hours: string;
HoursModif: string;
HoursModif: Ansistring;
Minutes: string;
Seconds: string;
Size: string;
Permissions: string;
Size: Ansistring;
Permissions: Ansistring;
DirFlag: string;
function GetListItem(Index: integer): TFTPListRec; virtual;
function ParseEPLF(Value: string): Boolean; virtual;
procedure ClearStore; virtual;
function ParseByMask(Value, NextValue, Mask: string): Integer; virtual;
function ParseByMask(Value, NextValue, Mask: ansistring): Integer; virtual;
function CheckValues: Boolean; virtual;
procedure FillRecord(const Value: TFTPListRec); virtual;
public
@ -465,8 +469,10 @@ begin
FFullResult := TStringList.Create;
FDataStream := TMemoryStream.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := True;
FDSock := TTCPBlockSocket.Create;
FDSock.Owner := self;
FFtpList := TFTPList.Create;
FTimeout := 300000;
FTargetPort := cFtpProtocol;
@ -508,7 +514,7 @@ end;
function TFTPSend.ReadResult: Integer;
var
s, c: string;
s, c: AnsiString;
begin
FFullResult.Clear;
c := '';
@ -818,7 +824,7 @@ end;
procedure TFTPSend.ParseRemoteEPSV(Value: string);
var
n: integer;
s, v: string;
s, v: AnsiString;
begin
s := SeparateRight(Value, '(');
s := Trim(SeparateLeft(s, ')'));
@ -1336,11 +1342,11 @@ begin
DirFlag := '';
end;
function TFTPList.ParseByMask(Value, NextValue, Mask: string): Integer;
function TFTPList.ParseByMask(Value, NextValue, Mask: AnsiString): Integer;
var
Ivalue, IMask: integer;
MaskC, LastMaskC: Char;
c: char;
MaskC, LastMaskC: AnsiChar;
c: AnsiChar;
s: string;
begin
ClearStore;

12
trunk/Units/Synapse/ftptsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.000 |
| Project : Ararat Synapse | 001.001.001 |
|==============================================================================|
| Content: Trivial FTP (TFTP) client and server |
|==============================================================================|
| Copyright (c)1999-2004, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003-2004. |
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -53,6 +53,11 @@ Used RFC: RFC-1350
{$Q-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit ftptsend;
interface
@ -134,6 +139,7 @@ constructor TTFTPSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FTargetPort := cTFTPProtocol;
FData := TMemoryStream.Create;
FErrorCode := 0;

20
trunk/Units/Synapse/httpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 003.012.002 |
| Project : Ararat Synapse | 003.012.004 |
|==============================================================================|
| Content: HTTP client |
|==============================================================================|
| Copyright (c)1999-2008, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2008. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -51,6 +51,17 @@ Used RFC: RFC-1867, RFC-1947, RFC-2388, RFC-2616
{$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;
@ -264,6 +275,7 @@ begin
FCookies := TStringList.Create;
FDocument := TMemoryStream.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := True;
FSock.SizeRecvBuffer := c64k;
FSock.SizeSendBuffer := c64k;
@ -321,7 +333,7 @@ begin
if FProtocol = '0.9' then
Result := FHeaders[0] + CRLF
else
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
Result := AdjustLineBreaks(FHeaders.Text, tlbsCRLF);
{$ELSE}
Result := FHeaders.Text;

12
trunk/Units/Synapse/imapsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 002.005.001 |
| Project : Ararat Synapse | 002.005.002 |
|==============================================================================|
| Content: IMAP4rev1 client |
|==============================================================================|
| Copyright (c)1999-2004, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2004. |
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -52,6 +52,11 @@ Used RFC: RFC-2060, RFC-2595
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit imapsend;
interface
@ -269,6 +274,7 @@ begin
FFullResult := TStringList.Create;
FIMAPcap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := True;
FSock.SizeRecvBuffer := 32768;
FSock.SizeSendBuffer := 32768;

25
trunk/Units/Synapse/ldapsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 001.006.001 |
| Project : Ararat Synapse | 001.007.000 |
|==============================================================================|
| Content: LDAP client |
|==============================================================================|
| Copyright (c)1999-2009, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003-2009. |
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -52,6 +52,11 @@ Used RFC: RFC-2251, RFC-2254, RFC-2829, RFC-2830
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit ldapsend;
interface
@ -124,6 +129,8 @@ type
procedure Del(Index: integer);
{:Find and return attribute with requested name. Returns nil if not found.}
function Find(AttributeName: AnsiString): TLDAPAttribute;
{:Find and return attribute value with requested name. Returns empty string if not found.}
function Get(AttributeName: AnsiString): string;
{:List of TLDAPAttribute objects.}
property Items[Index: Integer]: TLDAPAttribute read GetAttribute; default;
end;
@ -391,6 +398,17 @@ begin
Result := FAttributeList.Count;
end;
function TLDAPAttributeList.Get(AttributeName: AnsiString): string;
var
x: TLDAPAttribute;
begin
Result := '';
x := self.Find(AttributeName);
if x <> nil then
if x.Count > 0 then
Result := x[0];
end;
function TLDAPAttributeList.GetAttribute(Index: integer): TLDAPAttribute;
begin
Result := nil;
@ -499,6 +517,7 @@ begin
FReferals := TStringList.Create;
FFullResult := '';
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FTimeout := 60000;
FTargetPort := cLDAPProtocol;
FAutoTLS := False;

5
trunk/Units/Synapse/mimeinln.pas
View File

@ -53,6 +53,11 @@ Used RFC: RFC-2047, RFC-2231
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit mimeinln;
interface

5
trunk/Units/Synapse/mimepart.pas
View File

@ -55,6 +55,11 @@ Used RFC: RFC-2045
{$Q-}
{$R-}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit mimepart;
interface

13
trunk/Units/Synapse/nntpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 001.005.001 |
| Project : Ararat Synapse | 001.005.002 |
|==============================================================================|
| Content: NNTP client |
|==============================================================================|
| Copyright (c)1999-2007, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2007. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -53,6 +53,12 @@ Used RFC: RFC-977, RFC-2980
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$WARN SUSPICIOUS_TYPECAST OFF}
{$ENDIF}
unit nntpsend;
interface
@ -195,6 +201,7 @@ constructor TNNTPSend.Create;
begin
inherited Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FData := TStringList.Create;
FDataToSend := TStringList.Create;
FNNTPcap := TStringList.Create;

62
trunk/Units/Synapse/pingsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 004.000.000 |
| Project : Ararat Synapse | 004.000.002 |
|==============================================================================|
| Content: PING sender |
|==============================================================================|
| Copyright (c)1999-2007, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2007. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -66,6 +66,17 @@ Note: This unit is NOT portable to .NET!
{$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;
@ -74,7 +85,7 @@ interface
uses
SysUtils,
synsock, blcksock, synautil, synafpc, synaip
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
, windows
{$ENDIF}
;
@ -107,7 +118,7 @@ type
TPINGSend = class(TSynaClient)
private
FSock: TICMPBlockSocket;
FBuffer: string;
FBuffer: Ansistring;
FSeq: Integer;
FId: Integer;
FPacketSize: Integer;
@ -122,8 +133,8 @@ type
FReplyErrorDesc: string;
FTTL: Byte;
Fsin: TVarSin;
function Checksum(Value: string): Word;
function Checksum6(Value: string): Word;
function Checksum(Value: AnsiString): Word;
function Checksum6(Value: AnsiString): Word;
function ReadPacket: Boolean;
procedure TranslateError;
procedure TranslateErrorIpHlp(value: integer);
@ -184,7 +195,7 @@ implementation
type
{:Record for ICMP ECHO packet header.}
TIcmpEchoHeader = record
TIcmpEchoHeader = packed record
i_type: Byte;
i_code: Byte;
i_checkSum: Word;
@ -195,7 +206,7 @@ type
{:record used internally by TPingSend for compute checksum of ICMPv6 packet
pseudoheader.}
TICMP6Packet = record
TICMP6Packet = packed record
in_source: TInAddr6;
in_dest: TInAddr6;
Length: integer;
@ -205,20 +216,20 @@ type
proto: Byte;
end;
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
const
DLLIcmpName = 'iphlpapi.dll';
type
TIP_OPTION_INFORMATION = packed record
TIP_OPTION_INFORMATION = record
TTL: Byte;
TOS: Byte;
Flags: Byte;
OptionsSize: Byte;
OptionsData: PChar;
OptionsData: PAnsiChar;
end;
PIP_OPTION_INFORMATION = ^TIP_OPTION_INFORMATION;
TICMP_ECHO_REPLY = packed record
TICMP_ECHO_REPLY = record
Address: TInAddr;
Status: integer;
RoundTripTime: integer;
@ -229,7 +240,7 @@ type
end;
PICMP_ECHO_REPLY = ^TICMP_ECHO_REPLY;
TICMPV6_ECHO_REPLY = packed record
TICMPV6_ECHO_REPLY = record
Address: TSockAddrIn6;
Status: integer;
RoundTripTime: integer;
@ -264,6 +275,7 @@ constructor TPINGSend.Create;
begin
inherited Create;
FSock := TICMPBlockSocket.Create;
FSock.Owner := self;
FTimeout := 5000;
FPacketSize := 32;
FSeq := 0;
@ -331,7 +343,7 @@ begin
FReplyError := IE_Other;
GenErrorDesc;
FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize);
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
b := IsHostIP6(host);
if not(b) and IcmpHelper4 then
result := InternalPingIpHlp(host)
@ -399,7 +411,7 @@ begin
break;
if fSock.IP6used then
begin
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
IcmpEchoHeaderPtr := Pointer(FBuffer);
{$ELSE}
//WinXP SP1 with networking update doing this think by another way ;-O
@ -436,7 +448,7 @@ begin
end;
end;
function TPINGSend.Checksum(Value: string): Word;
function TPINGSend.Checksum(Value: AnsiString): Word;
var
CkSum: integer;
Num, Remain: Integer;
@ -458,7 +470,7 @@ begin
Result := Word(not CkSum);
end;
function TPINGSend.Checksum6(Value: string): Word;
function TPINGSend.Checksum6(Value: AnsiString): Word;
const
IOC_OUT = $40000000;
IOC_IN = $80000000;
@ -467,13 +479,13 @@ const
SIO_ROUTING_INTERFACE_QUERY = 20 or IOC_WS2 or IOC_INOUT;
var
ICMP6Ptr: ^TICMP6Packet;
s: string;
s: AnsiString;
b: integer;
ip6: TSockAddrIn6;
x: integer;
begin
Result := 0;
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
s := StringOfChar(#0, SizeOf(TICMP6Packet)) + Value;
ICMP6Ptr := Pointer(s);
x := synsock.WSAIoctl(FSock.Socket, SIO_ROUTING_INTERFACE_QUERY,
@ -565,13 +577,13 @@ begin
end;
function TPINGSend.InternalPingIpHlp(const Host: string): Boolean;
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
var
PingIp6: boolean;
PingHandle: integer;
r: integer;
ipo: TIP_OPTION_INFORMATION;
RBuff: string;
RBuff: Ansistring;
ip4reply: PICMP_ECHO_REPLY;
ip6reply: PICMPV6_ECHO_REPLY;
ip6: TSockAddrIn6;
@ -595,7 +607,7 @@ begin
begin
FillChar(ip6, sizeof(ip6), 0);
r := Icmp6SendEcho2(PingHandle, nil, nil, nil, @ip6, @Fsin,
Pchar(FBuffer), length(FBuffer), @ipo, pchar(RBuff), length(RBuff), FTimeout);
PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout);
if r > 0 then
begin
RBuff := #0 + #0 + RBuff;
@ -610,7 +622,7 @@ begin
else
begin
r := IcmpSendEcho2(PingHandle, nil, nil, nil, Fsin.sin_addr,
Pchar(FBuffer), length(FBuffer), @ipo, pchar(RBuff), length(RBuff), FTimeout);
PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout);
if r > 0 then
begin
ip4reply := PICMP_ECHO_REPLY(pointer(RBuff));
@ -678,7 +690,7 @@ begin
end;
end;
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
initialization
begin
IcmpHelper4 := false;

15
trunk/Units/Synapse/pop3send.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 002.006.000 |
| Project : Ararat Synapse | 002.006.002 |
|==============================================================================|
| Content: POP3 client |
|==============================================================================|
| Copyright (c)1999-2007, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2007. |
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -51,6 +51,12 @@ Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$M+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit pop3send;
@ -203,6 +209,7 @@ begin
FFullResult := TStringList.Create;
FPOP3cap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := true;
FTimeout := 60000;
FTargetPort := cPop3Protocol;
@ -224,7 +231,7 @@ end;
function TPOP3Send.ReadResult(Full: Boolean): Integer;
var
s: string;
s: AnsiString;
begin
Result := 0;
FFullResult.Clear;

7
trunk/Units/Synapse/slogsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 001.002.002 |
| Project : Ararat Synapse | 001.002.003 |
|==============================================================================|
| Content: SysLog client |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2003. |
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -264,6 +264,7 @@ constructor TSyslogSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FSysLogMessage := TSysLogMessage.Create;
FTargetPort := cSysLogProtocol;
end;

14
trunk/Units/Synapse/smtpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 003.005.000 |
| Project : Ararat Synapse | 003.005.001 |
|==============================================================================|
| Content: SMTP client |
|==============================================================================|
| Copyright (c)1999-2009, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2009. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -53,6 +53,11 @@ Used RFC: RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487,
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit smtpsend;
interface
@ -261,6 +266,7 @@ begin
FFullResult := TStringList.Create;
FESMTPcap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := true;
FTimeout := 60000;
FTargetPort := cSmtpProtocol;
@ -315,7 +321,7 @@ end;
function TSMTPSend.ReadResult: Integer;
var
s: string;
s: String;
begin
Result := 0;
FFullResult.Clear;

12
trunk/Units/Synapse/snmpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 003.000.009 |
| Project : Ararat Synapse | 003.000.010 |
|==============================================================================|
| Content: SNMP client |
|==============================================================================|
| Copyright (c)1999-2007, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2007. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -56,6 +56,11 @@ Used RFC: RFC-1157, RFC-1901, RFC-3412, RFC-3414, RFC-3416
{$Q-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit snmpsend;
interface
@ -771,6 +776,7 @@ begin
FQuery.Clear;
FReply.Clear;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FTimeout := 5000;
FTargetPort := cSnmpProtocol;
FHostIP := '';

9
trunk/Units/Synapse/sntpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 003.000.002 |
| Project : Ararat Synapse | 003.000.003 |
|==============================================================================|
| Content: SNTP client |
|==============================================================================|
| Copyright (c)1999-2007, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2007. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -101,7 +101,7 @@ type
FMaxSyncDiff: double;
FSyncTime: Boolean;
FSock: TUDPBlockSocket;
FBuffer: string;
FBuffer: AnsiString;
FLi, FVn, Fmode : byte;
function StrToNTP(const Value: AnsiString): TNtp;
function NTPtoStr(const Value: Tntp): AnsiString;
@ -162,6 +162,7 @@ constructor TSNTPSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FTimeout := 5000;
FTargetPort := cNtpProtocol;
FMaxSyncDiff := 3600;

7
trunk/Units/Synapse/ssfpc.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.000 |
| Project : Ararat Synapse | 001.001.001 |
|==============================================================================|
| Content: Socket Independent Platform Layer - FreePascal definition include |
|==============================================================================|
| Copyright (c)2006-2009, Lukas Gebauer |
| Copyright (c)2006-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2006-2009. |
| Portions created by Lukas Gebauer are Copyright (c)2006-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -113,6 +113,7 @@ const
IPPROTO_UDP = 17; { User Datagram Protocol }
IPPROTO_IPV6 = 41;
IPPROTO_ICMPV6 = 58;
IPPROTO_RM = 113;
IPPROTO_RAW = 255;
IPPROTO_MAX = 256;

14
trunk/Units/Synapse/ssl_openssl.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.000 |
| Project : Ararat Synapse | 001.001.001 |
|==============================================================================|
| Content: SSL support by OpenSSL |
|==============================================================================|
@ -80,6 +80,11 @@ accepting of new connections!
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit ssl_openssl;
interface
@ -615,10 +620,9 @@ begin
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;
Result := 0;
if (err <> 0) then
FLastError := err;
end;
function TSSLOpenSSL.WaitingData: Integer;

37
trunk/Units/Synapse/ssl_openssl_lib.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 003.005.000 |
| Project : Ararat Synapse | 003.006.001 |
|==============================================================================|
| Content: SSL support by OpenSSL |
|==============================================================================|
| Copyright (c)1999-2008, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2002-2008. |
| Portions created by Lukas Gebauer are Copyright (c)2002-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -60,6 +60,13 @@ Special thanks to Gregor Ibic <gregor.ibic@intelicom.si>
(*$HPPEMIT 'namespace ssl_openssl_lib { using System::Shortint; }' *)
{$ENDIF}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{:@abstract(OpenSSL support)
This unit is Pascal interface to OpenSSL library (used by @link(ssl_openssl) unit).
@ -77,7 +84,7 @@ uses
{$ENDIF}
Classes,
synafpc,
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
Libc, SysUtils;
{$ELSE}
Windows;
@ -95,7 +102,7 @@ const
{$ENDIF}
{$ELSE}
var
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
DLLSSLName: string = 'libssl.so';
DLLUtilName: string = 'libcrypto.so';
{$ELSE}
@ -319,6 +326,11 @@ var
EntryPoint = 'SSL_CTX_load_verify_locations')]
function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; CAfile: string; CApath: String):Integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_CTX_ctrl')]
function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: IntPtr): integer; external;
[DllImport(DLLSSLName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'SSL_new')]
@ -674,6 +686,7 @@ var
procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr);
// function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer;
function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: AnsiString; const CApath: AnsiString):Integer;
function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer;
function SslNew(ctx: PSSL_CTX):PSSL;
procedure SslFree(ssl: PSSL);
function SslAccept(ssl: PSSL):Integer;
@ -782,6 +795,7 @@ type
TSslCtxSetDefaultPasswdCb = procedure(ctx: PSSL_CTX; cb: SslPtr); cdecl;
TSslCtxSetDefaultPasswdCbUserdata = procedure(ctx: PSSL_CTX; u: SslPtr); cdecl;
TSslCtxLoadVerifyLocations = function(ctx: PSSL_CTX; const CAfile: PAnsiChar; const CApath: PAnsiChar):Integer; cdecl;
TSslCtxCtrl = function(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; cdecl;
TSslNew = function(ctx: PSSL_CTX):PSSL; cdecl;
TSslFree = procedure(ssl: PSSL); cdecl;
TSslAccept = function(ssl: PSSL):Integer; cdecl;
@ -880,6 +894,7 @@ var
_SslCtxSetDefaultPasswdCb: TSslCtxSetDefaultPasswdCb = nil;
_SslCtxSetDefaultPasswdCbUserdata: TSslCtxSetDefaultPasswdCbUserdata = nil;
_SslCtxLoadVerifyLocations: TSslCtxLoadVerifyLocations = nil;
_SslCtxCtrl: TSslCtxCtrl = nil;
_SslNew: TSslNew = nil;
_SslFree: TSslFree = nil;
_SslAccept: TSslAccept = nil;
@ -1135,6 +1150,14 @@ begin
Result := 0;
end;
function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer;
begin
if InitSSLInterface and Assigned(_SslCtxCtrl) then
Result := _SslCtxCtrl(ctx, cmd, larg, parg)
else
Result := 0;
end;
function SslNew(ctx: PSSL_CTX):PSSL;
begin
if InitSSLInterface and Assigned(_SslNew) then
@ -1352,7 +1375,7 @@ procedure ErrErrorString(e: integer; var buf: Ansistring; len: integer);
begin
if InitSSLInterface and Assigned(_ErrErrorString) then
_ErrErrorString(e, Pointer(buf), len);
buf := PChar(Buf);
buf := PAnsiChar(Buf);
end;
function ErrGetError: integer;
@ -1736,6 +1759,7 @@ begin
_SslCtxSetDefaultPasswdCb := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb');
_SslCtxSetDefaultPasswdCbUserdata := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb_userdata');
_SslCtxLoadVerifyLocations := GetProcAddr(SSLLibHandle, 'SSL_CTX_load_verify_locations');
_SslCtxCtrl := GetProcAddr(SSLLibHandle, 'SSL_CTX_ctrl');
_SslNew := GetProcAddr(SSLLibHandle, 'SSL_new');
_SslFree := GetProcAddr(SSLLibHandle, 'SSL_free');
_SslAccept := GetProcAddr(SSLLibHandle, 'SSL_accept');
@ -1919,6 +1943,7 @@ begin
_SslCtxSetDefaultPasswdCb := nil;
_SslCtxSetDefaultPasswdCbUserdata := nil;
_SslCtxLoadVerifyLocations := nil;
_SslCtxCtrl := nil;
_SslNew := nil;
_SslFree := nil;
_SslAccept := nil;

7
trunk/Units/Synapse/sslinux.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 002.000.008 |
| Project : Ararat Synapse | 002.000.009 |
|==============================================================================|
| Content: Socket Independent Platform Layer - Linux definition include |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003. |
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -129,6 +129,7 @@ const
IPPROTO_UDP = 17; { User Datagram Protocol }
IPPROTO_IPV6 = 41;
IPPROTO_ICMPV6 = 58;
IPPROTO_RM = 113;
IPPROTO_RAW = 255;
IPPROTO_MAX = 256;

68
trunk/Units/Synapse/sswin32.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 002.002.000 |
| Project : Ararat Synapse | 002.002.003 |
|==============================================================================|
| Content: Socket Independent Platform Layer - Win32 definition include |
|==============================================================================|
| Copyright (c)1999-2008, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003. |
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -44,8 +44,6 @@
{:@exclude}
{$IFDEF WIN32}
//{$DEFINE WINSOCK1}
{Note about define WINSOCK1:
If you activate this compiler directive, then socket interface level 1.1 is
@ -260,7 +258,11 @@ type
u_long = Longint;
pu_long = ^u_long;
pu_short = ^u_short;
{$IFDEF FPC}
TSocket = ptruint;
{$ELSE}
TSocket = u_int;
{$ENDIF}
TAddrFamily = integer;
TMemory = pointer;
@ -286,7 +288,7 @@ const
FD_SETSIZE = 64;
type
PFDSet = ^TFDSet;
TFDSet = packed record
TFDSet = record
fd_count: u_int;
fd_array: array[0..FD_SETSIZE-1] of TSocket;
end;
@ -298,7 +300,7 @@ const
type
PTimeVal = ^TTimeVal;
TTimeVal = packed record
TTimeVal = record
tv_sec: Longint;
tv_usec: Longint;
end;
@ -311,6 +313,7 @@ const
IPPROTO_UDP = 17; { User Datagram Protocol }
IPPROTO_IPV6 = 41;
IPPROTO_ICMPV6 = 58;
IPPROTO_RM = 113;
IPPROTO_RAW = 255;
IPPROTO_MAX = 256;
@ -318,14 +321,14 @@ const
type
PInAddr = ^TInAddr;
TInAddr = packed record
TInAddr = record
case integer of
0: (S_bytes: packed array [0..3] of byte);
1: (S_addr: u_long);
end;
PSockAddrIn = ^TSockAddrIn;
TSockAddrIn = packed record
TSockAddrIn = record
case Integer of
0: (sin_family: u_short;
sin_port: u_short;
@ -341,7 +344,7 @@ type
end;
PInAddr6 = ^TInAddr6;
TInAddr6 = packed record
TInAddr6 = record
case integer of
0: (S6_addr: packed array [0..15] of byte);
1: (u6_addr8: packed array [0..15] of byte);
@ -350,7 +353,7 @@ type
end;
PSockAddrIn6 = ^TSockAddrIn6;
TSockAddrIn6 = packed record
TSockAddrIn6 = record
sin6_family: u_short; // AF_INET6
sin6_port: u_short; // Transport level port number
sin6_flowinfo: u_long; // IPv6 flow information
@ -366,7 +369,7 @@ type
end;
PHostEnt = ^THostEnt;
THostEnt = packed record
THostEnt = record
h_name: PAnsiChar;
h_aliases: ^PAnsiChar;
h_addrtype: Smallint;
@ -377,7 +380,7 @@ type
end;
PNetEnt = ^TNetEnt;
TNetEnt = packed record
TNetEnt = record
n_name: PAnsiChar;
n_aliases: ^PAnsiChar;
n_addrtype: Smallint;
@ -385,15 +388,20 @@ type
end;
PServEnt = ^TServEnt;
TServEnt = packed record
TServEnt = record
s_name: PAnsiChar;
s_aliases: ^PAnsiChar;
{$ifdef WIN64}
s_proto: PAnsiChar;
s_port: Smallint;
{$else}
s_port: Smallint;
s_proto: PAnsiChar;
{$endif}
end;
PProtoEnt = ^TProtoEnt;
TProtoEnt = packed record
TProtoEnt = record
p_name: PAnsiChar;
p_aliases: ^PAnsichar;
p_proto: Smallint;
@ -526,7 +534,7 @@ type
{ Structure used by kernel to pass protocol information in raw sockets. }
PSockProto = ^TSockProto;
TSockProto = packed record
TSockProto = record
sp_family: u_short;
sp_protocol: u_short;
end;
@ -553,7 +561,7 @@ const
type
{ Structure used for manipulating linger option. }
PLinger = ^TLinger;
TLinger = packed record
TLinger = record
l_onoff: u_short;
l_linger: u_short;
end;
@ -715,14 +723,22 @@ const
WSASYS_STATUS_LEN = 128;
type
PWSAData = ^TWSAData;
TWSAData = packed record
TWSAData = record
wVersion: Word;
wHighVersion: Word;
{$ifdef win64}
iMaxSockets : Word;
iMaxUdpDg : Word;
lpVendorInfo : PAnsiChar;
szDescription : array[0..WSADESCRIPTION_LEN] of AnsiChar;
szSystemStatus : array[0..WSASYS_STATUS_LEN] of AnsiChar;
{$else}
szDescription: array[0..WSADESCRIPTION_LEN] of AnsiChar;
szSystemStatus: array[0..WSASYS_STATUS_LEN] of AnsiChar;
iMaxSockets: Word;
iMaxUdpDg: Word;
lpVendorInfo: PAnsiChar;
{$endif}
end;
function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
@ -1167,10 +1183,10 @@ begin
Sin.sin_family := AF_INET;
ProtoEnt := synsock.GetProtoByNumber(SockProtocol);
ServEnt := nil;
if ProtoEnt <> nil then
if (ProtoEnt <> nil) and (StrToIntDef(string(Port),-1) =-1) then
ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name);
if ServEnt = nil then
Sin.sin_port := synsock.htons(StrToIntDef(Port, 0))
Sin.sin_port := synsock.htons(StrToIntDef(string(Port), 0))
else
Sin.sin_port := ServEnt^.s_port;
if IP = cBroadcast then
@ -1282,7 +1298,7 @@ var
IP: u_long;
PAdrPtr: PaPInAddr;
i: Integer;
s: AnsiString;
s: String;
InAddr: TInAddr;
begin
IPList.Clear;
@ -1312,7 +1328,7 @@ begin
end;
end
else
IPList.Add(Name);
IPList.Add(string(Name));
end
else
begin
@ -1342,7 +1358,7 @@ begin
if r = 0 then
begin
host := PAnsiChar(host);
IPList.Add(host);
IPList.Add(string(host));
end;
end;
AddrNext := AddrNext^.ai_next;
@ -1375,7 +1391,7 @@ begin
if ProtoEnt <> nil then
ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name);
if ServEnt = nil then
Result := StrToIntDef(Port, 0)
Result := StrToIntDef(string(Port), 0)
else
Result := synsock.htons(ServEnt^.s_port);
finally
@ -1580,6 +1596,4 @@ end;
finalization
begin
SynSockCS.Free;
end;
{$ENDIF}
end;

5
trunk/Units/Synapse/synachar.pas
View File

@ -60,6 +60,11 @@ Internal routines knows all major charsets for Europe or America. For East-Asian
{$Q-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit synachar;
interface

14
trunk/Units/Synapse/synacode.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 002.002.000 |
| Project : Ararat Synapse | 002.002.001 |
|==============================================================================|
| Content: Coding and decoding support |
|==============================================================================|
| Copyright (c)1999-2007, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2007. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -50,6 +50,12 @@
{$R-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$WARN SUSPICIOUS_TYPECAST OFF}
{$ENDIF}
unit synacode;
interface
@ -66,7 +72,7 @@ const
['=', '(', ')', '[', ']', '<', '>', ':', ';', ',', '@', '/', '?', '\',
'"', '_'];
NonAsciiChar: TSpecials =
[Char(0)..Char(31), Char(127)..Char(255)];
[#0..#31, #127..#255];
URLFullSpecialChar: TSpecials =
[';', '/', '?', ':', '@', '=', '&', '#', '+'];
URLSpecialChar: TSpecials =

11
trunk/Units/Synapse/synacrypt.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 001.000.000 |
| Project : Ararat Synapse | 001.000.001 |
|==============================================================================|
| Content: Encryption support |
|==============================================================================|
| Copyright (c)2007, Lukas Gebauer |
| Copyright (c)2007-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2007. |
| Portions created by Lukas Gebauer are Copyright (c)2007-2010. |
| All Rights Reserved. |
| Based on work of David Barton and Eric Young |
|==============================================================================|
@ -56,6 +56,11 @@ Implemented are DES and 3DES encryption/decryption by ECB, CBC, CFB-8bit,
{$R-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit synacrypt;
interface

10
trunk/Units/Synapse/synadbg.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.000 |
| Project : Ararat Synapse | 001.001.001 |
|==============================================================================|
| Content: Socket debug tools |
|==============================================================================|
| Copyright (c)2008, Lukas Gebauer |
| Copyright (c)2008-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2008. |
| Portions created by Lukas Gebauer are Copyright (c)2008-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -47,6 +47,10 @@
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;

16
trunk/Units/Synapse/synafpc.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.001 |
| Project : Ararat Synapse | 001.001.002 |
|==============================================================================|
| Content: Utils for FreePascal compatibility |
|==============================================================================|
| Copyright (c)1999-2007, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003-2007. |
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -48,6 +48,12 @@
{$MODE DELPHI}
{$ENDIF}
{$H+}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
unit synafpc;
@ -57,7 +63,7 @@ uses
{$IFDEF FPC}
dynlibs, sysutils;
{$ELSE}
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
Windows;
{$ELSE}
SysUtils;
@ -116,7 +122,7 @@ end;
procedure Sleep(milliseconds: Cardinal);
begin
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
{$IFDEF FPC}
sysutils.sleep(milliseconds);
{$ELSE}

16
trunk/Units/Synapse/synaicnv.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.000 |
| Project : Ararat Synapse | 001.001.001 |
|==============================================================================|
| Content: ICONV support for Win32, Linux and .NET |
|==============================================================================|
| Copyright (c)2004-2008, Lukas Gebauer |
| Copyright (c)2004-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2004-2008. |
| Portions created by Lukas Gebauer are Copyright (c)2004-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -46,6 +46,12 @@
{$MODE DELPHI}
{$ENDIF}
{$H+}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{:@abstract(LibIconv support)
@ -63,7 +69,7 @@ uses
System.Text,
{$ENDIF}
synafpc,
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
{$IFNDEF FPC}
Libc,
{$ENDIF}
@ -74,7 +80,7 @@ uses
const
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
DLLIconvName = 'libiconv.so';
{$ELSE}
DLLIconvName = 'iconv.dll';

16
trunk/Units/Synapse/synaip.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 001.002.000 |
| Project : Ararat Synapse | 001.002.001 |
|==============================================================================|
| Content: IP address support procedures and functions |
|==============================================================================|
| Copyright (c)2006-2009, Lukas Gebauer |
| Copyright (c)2006-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 2006-2008. |
| Portions created by Lukas Gebauer are Copyright (c) 2006-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -51,6 +51,12 @@
{$R-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$WARN SUSPICIOUS_TYPECAST OFF}
{$ENDIF}
unit synaip;
interface
@ -112,7 +118,7 @@ var
// i.e. "$80"
if Result then
for n := 1 to length(Value) do
if not (Value[n] in ['0'..'9']) then
if not (AnsiChar(Value[n]) in ['0'..'9']) then
begin
Result := False;
Break;
@ -193,7 +199,7 @@ begin
begin
s := Fetch(Host, '.');
i := StrToIntDef(s, 0);
Result := Result + Chr(i);
Result := Result + AnsiChar(i);
end;
end;

9
trunk/Units/Synapse/synamisc.pas
View File

@ -3,7 +3,7 @@
|==============================================================================|
| Content: misc. procedures and functions |
|==============================================================================|
| Copyright (c)1999-2008, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 2002-2008. |
| Portions created by Lukas Gebauer are Copyright (c) 2002-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -50,6 +50,11 @@
{$Q-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit synamisc;
interface

234
trunk/Units/Synapse/synaser.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 007.003.000 |
| Project : Ararat Synapse | 007.004.000 |
|==============================================================================|
| Content: Serial port support |
|==============================================================================|
| Copyright (c)2001-2008, Lukas Gebauer |
| Copyright (c)2001-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2008. |
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -69,9 +69,16 @@ case with my USB modem):
#)
}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{$IFDEF FPC}
{$MODE DELPHI}
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
{$ASMMODE intel}
{$ENDIF}
{define working mode w/o LIBC for fpc}
@ -86,7 +93,7 @@ unit synaser;
interface
uses
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
{$IFNDEF NO_LIBC}
Libc,
KernelIoctl,
@ -156,13 +163,13 @@ const
{:stopbit value for 2 stopbits}
SB2 = 2;
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
const
INVALID_HANDLE_VALUE = THandle(-1);
CS7fix = $0000020;
type
TDCB = packed record
TDCB = record
DCBlength: DWORD;
BaudRate: DWORD;
Flags: Longint;
@ -182,8 +189,11 @@ type
PDCB = ^TDCB;
const
// MaxRates = 30;
{$IFDEF LINUX}
MaxRates = 30;
{$ELSE}
MaxRates = 19; //FPC on some platforms not know high speeds?
{$ENDIF}
Rates: array[0..MaxRates, 0..1] of cardinal =
(
(0, B0),
@ -205,8 +215,9 @@ const
(57600, B57600),
(115200, B115200),
(230400, B230400),
(460800, B460800){,
(500000, B500000),
(460800, B460800)
{$IFDEF LINUX}
,(500000, B500000),
(576000, B576000),
(921600, B921600),
(1000000, B1000000),
@ -216,7 +227,8 @@ const
(2500000, B2500000),
(3000000, B3000000),
(3500000, B3500000),
(4000000, B4000000)}
(4000000, B4000000)
{$ENDIF}
);
{$ENDIF}
@ -257,7 +269,7 @@ type
FDevice: string;
FLastError: integer;
FLastErrorDesc: string;
FBuffer: string;
FBuffer: AnsiString;
FRaiseExcept: boolean;
FRecvBuffer: integer;
FSendBuffer: integer;
@ -280,7 +292,7 @@ type
FAtTimeout: integer;
FInterPacketTimeout: Boolean;
FComNr: integer;
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
FPortAddr: Word;
function CanEvent(Event: dword; Timeout: integer): boolean;
procedure DecodeCommError(Error: DWord); virtual;
@ -298,7 +310,7 @@ type
procedure GetComNr(Value: string); virtual;
function PreTestFailing: boolean; virtual;{HGJ}
function TestCtrlLine: Boolean; virtual;
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual;
procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual;
{$ENDIF}
@ -313,7 +325,7 @@ type
{: data Control Block with communication parameters. Usable only when you
need to call API directly.}
DCB: Tdcb;
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
TermiosStruc: termios;
{$ENDIF}
{:Object constructor.}
@ -386,14 +398,14 @@ type
Since no terminator is appended, you can use this function for sending
binary data too.}
procedure SendString(data: string); virtual;
procedure SendString(data: AnsiString); virtual;
{:send four bytes as integer.}
procedure SendInteger(Data: integer); virtual;
{:send data as one block. Each block begins with integer value with Length
of block.}
procedure SendBlock(const Data: string); virtual;
procedure SendBlock(const Data: AnsiString); virtual;
{:send content of stream from current position}
procedure SendStreamRaw(const Stream: TStream); virtual;
@ -424,12 +436,12 @@ type
{:It is like recvBufferEx, but data is readed to dynamicly allocated binary
string.}
function RecvBufferStr(Length: Integer; Timeout: Integer): string; virtual;
function RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; virtual;
{:Read all available data and return it in the function result string. This
function may be combined with @link(RecvString), @link(RecvByte) or related
methods.}
function RecvPacket(Timeout: Integer): string; virtual;
function RecvPacket(Timeout: Integer): AnsiString; virtual;
{:Waits until one data byte is received which is returned as the function
result. If no data is received within the Timeout (in milliseconds) period,
@ -440,7 +452,7 @@ type
is terminated by the Terminator string. The resulting string is returned
without this termination string! If no data is received within the Timeout
(in milliseconds) period, @link(LastError) is set to @link(ErrTimeout).}
function RecvTerminated(Timeout: Integer; const Terminator: string): string; virtual;
function RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; virtual;
{:This method waits until a terminated data string is received. The string
is terminated by a CR/LF sequence. The resulting string is returned without
@ -453,7 +465,7 @@ type
This method serves for line protocol implementation and uses its own
buffers to maximize performance. Therefore do NOT use this method with the
@link(RecvBuffer) method to receive data as it may cause data loss.}
function Recvstring(timeout: integer): string; virtual;
function Recvstring(timeout: integer): AnsiString; virtual;
{:Waits until four data bytes are received which is returned as the function
integer result. If no data is received within the Timeout (in milliseconds) period,
@ -463,7 +475,7 @@ type
{:Waits until one data block is received. See @link(sendblock). If no data
is received within the Timeout (in milliseconds) period, @link(LastError)
is set to @link(ErrTimeout).}
function RecvBlock(Timeout: Integer): string; virtual;
function RecvBlock(Timeout: Integer): AnsiString; virtual;
{:Receive all data to stream, until some error occured. (for example timeout)}
procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual;
@ -554,7 +566,7 @@ type
Now you can send AT commands to the modem. If you need to transfer data to
the modem on the other side of the line, you must first switch to data mode
using the @link(ATConnect) method.}
function ATCommand(value: string): string; virtual;
function ATCommand(value: AnsiString): AnsiString; virtual;
{:This function is used to send connect type AT commands to the modem. It is
for commands to switch to connected state. (ATD, ATA, ATO,...)
@ -573,7 +585,7 @@ type
modem on other side of the line. Now you can transfer your data.
If the connection attempt failed (@link(ATResult) is @False), then the
modem is still in AT command mode.}
function ATConnect(value: string): string; virtual;
function ATConnect(value: AnsiString): AnsiString; virtual;
{:If you "manually" call API functions, forward their return code in
the SerialResult parameter to this function, which evaluates it and sets
@ -660,7 +672,7 @@ type
property Handle: THandle read Fhandle write FHandle;
{:Internally used read buffer.}
property LineBuffer: string read FBuffer write FBuffer;
property LineBuffer: AnsiString read FBuffer write FBuffer;
{:If @true, communication errors raise exceptions. If @false (default), only
the @link(LastError) value is set.}
@ -752,7 +764,7 @@ end;
class function TBlockSerial.GetVersion: string;
begin
Result := 'SynaSer 6.3.5';
Result := 'SynaSer 7.4.0';
end;
procedure TBlockSerial.CloseSocket;
@ -762,7 +774,7 @@ begin
Purge;
RTS := False;
DTR := False;
FileClose(integer(FHandle));
FileClose(FHandle);
end;
if InstanceActive then
begin
@ -778,7 +790,7 @@ begin
DoStatus(HR_SerialClose, FDevice);
end;
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
function TBlockSerial.GetPortAddr: Word;
begin
Result := 0;
@ -849,6 +861,7 @@ procedure TBlockSerial.Config(baud, bits: integer; parity: char; stop: integer;
softflow, hardflow: boolean);
begin
FillChar(dcb, SizeOf(dcb), 0);
GetCommState;
dcb.DCBlength := SizeOf(dcb);
dcb.BaudRate := baud;
dcb.ByteSize := bits;
@ -878,7 +891,7 @@ begin
end;
procedure TBlockSerial.Connect(comport: string);
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
var
CommTimeouts: TCommTimeouts;
{$ENDIF}
@ -892,7 +905,7 @@ begin
FBuffer := '';
FDevice := comport;
GetComNr(comport);
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
SetLastError (sOK);
{$ELSE}
{$IFNDEF FPC}
@ -901,7 +914,7 @@ begin
fpSetErrno(sOK);
{$ENDIF}
{$ENDIF}
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
if FComNr <> PortIsClosed then
FDevice := '/dev/ttyS' + IntToStr(FComNr);
// Comport already owned by another process? {HGJ}
@ -916,7 +929,10 @@ begin
{$ELSE}
FHandle := THandle(fpOpen(FDevice, O_RDWR or O_SYNC));
{$ENDIF}
SerialCheck(integer(FHandle));
if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms!
SerialCheck(-1)
else
SerialCheck(0);
{$IFDEF LINUX}
if FLastError <> sOK then
if FLinuxLock then
@ -930,7 +946,10 @@ begin
FDevice := '\\.\COM' + IntToStr(FComNr + 1);
FHandle := THandle(CreateFile(PChar(FDevice), GENERIC_READ or GENERIC_WRITE,
0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0));
SerialCheck(integer(FHandle));
if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms!
SerialCheck(-1)
else
SerialCheck(0);
ExceptCheck;
if FLastError <> sOK then
Exit;
@ -948,7 +967,7 @@ begin
if not TestCtrlLine then {HGJ}
begin
SetSynaError(ErrNoDeviceAnswer);
FileClose(integer(FHandle)); {HGJ}
FileClose(FHandle); {HGJ}
{$IFDEF LINUX}
if FLinuxLock then
cpomReleaseComport; {HGJ}
@ -968,7 +987,7 @@ begin
end;
function TBlockSerial.SendBuffer(buffer: pointer; length: integer): integer;
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
var
Overlapped: TOverlapped;
x, y, Err: DWord;
@ -983,8 +1002,8 @@ begin
Flush;
RTS := True;
end;
{$IFNDEF WIN32}
result := FileWrite(integer(Fhandle), Buffer^, Length);
{$IFNDEF MSWINDOWS}
result := FileWrite(Fhandle, Buffer^, Length);
serialcheck(result);
{$ELSE}
FillChar(Overlapped, Sizeof(Overlapped), 0);
@ -1023,7 +1042,7 @@ begin
SendBuffer(@Data, 1);
end;
procedure TBlockSerial.SendString(data: string);
procedure TBlockSerial.SendString(data: AnsiString);
begin
SendBuffer(Pointer(Data), Length(Data));
end;
@ -1033,7 +1052,7 @@ begin
SendBuffer(@data, SizeOf(Data));
end;
procedure TBlockSerial.SendBlock(const Data: string);
procedure TBlockSerial.SendBlock(const Data: AnsiString);
begin
SendInteger(Length(data));
SendString(Data);
@ -1043,7 +1062,7 @@ procedure TBlockSerial.SendStreamRaw(const Stream: TStream);
var
si: integer;
x, y, yr: integer;
s: string;
s: AnsiString;
begin
si := Stream.Size - Stream.Position;
x := 0;
@ -1053,7 +1072,7 @@ begin
if y > cSerialChunk then
y := cSerialChunk;
Setlength(s, y);
yr := Stream.read(Pchar(s)^, y);
yr := Stream.read(PAnsiChar(s)^, y);
if yr > 0 then
begin
SetLength(s, yr);
@ -1085,13 +1104,13 @@ begin
end;
function TBlockSerial.RecvBuffer(buffer: pointer; length: integer): integer;
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
result := FileRead(integer(FHandle), Buffer^, length);
result := FileRead(FHandle, Buffer^, length);
serialcheck(result);
{$ELSE}
var
@ -1129,7 +1148,7 @@ end;
function TBlockSerial.RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer;
var
s: string;
s: AnsiString;
rl, l: integer;
ti: LongWord;
begin
@ -1165,7 +1184,7 @@ begin
Result := rl;
end;
function TBlockSerial.RecvBufferStr(Length: Integer; Timeout: Integer): string;
function TBlockSerial.RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString;
var
x: integer;
begin
@ -1176,7 +1195,7 @@ begin
if Length > 0 then
begin
Setlength(Result, Length);
x := RecvBufferEx(PChar(Result), Length , Timeout);
x := RecvBufferEx(PAnsiChar(Result), Length , Timeout);
if FLastError = sOK then
SetLength(Result, x)
else
@ -1184,7 +1203,7 @@ begin
end;
end;
function TBlockSerial.RecvPacket(Timeout: Integer): string;
function TBlockSerial.RecvPacket(Timeout: Integer): AnsiString;
var
x: integer;
begin
@ -1248,10 +1267,10 @@ begin
ExceptCheck;
end;
function TBlockSerial.RecvTerminated(Timeout: Integer; const Terminator: string): string;
function TBlockSerial.RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString;
var
x: Integer;
s: string;
s: AnsiString;
l: Integer;
CorCRLF: Boolean;
t: ansistring;
@ -1325,9 +1344,9 @@ begin
end;
function TBlockSerial.RecvString(Timeout: Integer): string;
function TBlockSerial.RecvString(Timeout: Integer): AnsiString;
var
s: string;
s: AnsiString;
begin
Result := '';
s := RecvTerminated(Timeout, #13 + #10);
@ -1337,7 +1356,7 @@ end;
function TBlockSerial.RecvInteger(Timeout: Integer): Integer;
var
s: string;
s: AnsiString;
begin
Result := 0;
s := RecvBufferStr(4, Timeout);
@ -1345,7 +1364,7 @@ begin
Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536;
end;
function TBlockSerial.RecvBlock(Timeout: Integer): string;
function TBlockSerial.RecvBlock(Timeout: Integer): AnsiString;
var
x: integer;
begin
@ -1357,7 +1376,7 @@ end;
procedure TBlockSerial.RecvStreamRaw(const Stream: TStream; Timeout: Integer);
var
s: string;
s: AnsiString;
begin
repeat
s := RecvPacket(Timeout);
@ -1368,7 +1387,7 @@ end;
procedure TBlockSerial.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer);
var
s: string;
s: AnsiString;
n: integer;
begin
for n := 1 to (Size div cSerialChunk) do
@ -1376,7 +1395,7 @@ begin
s := RecvBufferStr(cSerialChunk, Timeout);
if FLastError <> 0 then
Exit;
Stream.Write(Pchar(s)^, cSerialChunk);
Stream.Write(PAnsichar(s)^, cSerialChunk);
end;
n := Size mod cSerialChunk;
if n > 0 then
@ -1384,7 +1403,7 @@ begin
s := RecvBufferStr(n, Timeout);
if FLastError <> 0 then
Exit;
Stream.Write(Pchar(s)^, n);
Stream.Write(PAnsichar(s)^, n);
end;
end;
@ -1407,11 +1426,11 @@ begin
RecvStreamSize(Stream, Timeout, x);
end;
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
function TBlockSerial.WaitingData: integer;
begin
{$IFNDEF FPC}
serialcheck(ioctl(integer(FHandle), FIONREAD, @result));
serialcheck(ioctl(FHandle, FIONREAD, @result));
{$ELSE}
serialcheck(fpIoctl(FHandle, FIONREAD, @result));
{$ENDIF}
@ -1447,7 +1466,7 @@ begin
Result := Waitingdata;
end;
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
function TBlockSerial.SendingData: integer;
begin
SetSynaError(sOK);
@ -1467,7 +1486,7 @@ begin
end;
{$ENDIF}
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
procedure TBlockSerial.DcbToTermios(const dcb: TDCB; var term: termios);
var
n: integer;
@ -1590,11 +1609,11 @@ begin
end;
{$ENDIF}
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
procedure TBlockSerial.SetCommState;
begin
DcbToTermios(dcb, termiosstruc);
SerialCheck(tcsetattr(integer(FHandle), TCSANOW, termiosstruc));
SerialCheck(tcsetattr(FHandle, TCSANOW, termiosstruc));
ExceptCheck;
end;
{$ELSE}
@ -1607,10 +1626,10 @@ begin
end;
{$ENDIF}
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
procedure TBlockSerial.GetCommState;
begin
SerialCheck(tcgetattr(integer(FHandle), termiosstruc));
SerialCheck(tcgetattr(FHandle, termiosstruc));
ExceptCheck;
TermiostoDCB(termiosstruc, dcb);
end;
@ -1626,7 +1645,7 @@ end;
procedure TBlockSerial.SetSizeRecvBuffer(size: integer);
begin
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
SetupComm(Fhandle, size, 0);
GetCommState;
dcb.XonLim := size div 4;
@ -1639,7 +1658,7 @@ end;
function TBlockSerial.GetDSR: Boolean;
begin
ModemStatus;
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
Result := (FModemWord and TIOCM_DSR) > 0;
{$ELSE}
Result := (FModemWord and MS_DSR_ON) > 0;
@ -1648,16 +1667,16 @@ end;
procedure TBlockSerial.SetDTRF(Value: Boolean);
begin
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
ModemStatus;
if Value then
FModemWord := FModemWord or TIOCM_DTR
else
FModemWord := FModemWord and not TIOCM_DTR;
{$IFNDEF FPC}
ioctl(integer(FHandle), TIOCMSET, @FModemWord);
ioctl(FHandle, TIOCMSET, @FModemWord);
{$ELSE}
fpioctl(integer(FHandle), TIOCMSET, @FModemWord);
fpioctl(FHandle, TIOCMSET, @FModemWord);
{$ENDIF}
{$ELSE}
if Value then
@ -1670,7 +1689,7 @@ end;
function TBlockSerial.GetCTS: Boolean;
begin
ModemStatus;
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
Result := (FModemWord and TIOCM_CTS) > 0;
{$ELSE}
Result := (FModemWord and MS_CTS_ON) > 0;
@ -1679,16 +1698,16 @@ end;
procedure TBlockSerial.SetRTSF(Value: Boolean);
begin
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
ModemStatus;
if Value then
FModemWord := FModemWord or TIOCM_RTS
else
FModemWord := FModemWord and not TIOCM_RTS;
{$IFNDEF FPC}
ioctl(integer(FHandle), TIOCMSET, @FModemWord);
ioctl(FHandle, TIOCMSET, @FModemWord);
{$ELSE}
fpioctl(integer(FHandle), TIOCMSET, @FModemWord);
fpioctl(FHandle, TIOCMSET, @FModemWord);
{$ENDIF}
{$ELSE}
if Value then
@ -1701,7 +1720,7 @@ end;
function TBlockSerial.GetCarrier: Boolean;
begin
ModemStatus;
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
Result := (FModemWord and TIOCM_CAR) > 0;
{$ELSE}
Result := (FModemWord and MS_RLSD_ON) > 0;
@ -1711,14 +1730,14 @@ end;
function TBlockSerial.GetRing: Boolean;
begin
ModemStatus;
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
Result := (FModemWord and TIOCM_RNG) > 0;
{$ELSE}
Result := (FModemWord and MS_RING_ON) > 0;
{$ENDIF}
end;
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
function TBlockSerial.CanEvent(Event: dword; Timeout: integer): boolean;
var
ex: DWord;
@ -1753,7 +1772,7 @@ begin
end;
{$ENDIF}
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
function TBlockSerial.CanRead(Timeout: integer): boolean;
var
FDSet: TFDSet;
@ -1768,12 +1787,12 @@ begin
TimeVal := nil;
{$IFNDEF FPC}
FD_ZERO(FDSet);
FD_SET(integer(FHandle), FDSet);
x := Select(integer(FHandle) + 1, @FDSet, nil, nil, TimeVal);
FD_SET(FHandle, FDSet);
x := Select(FHandle + 1, @FDSet, nil, nil, TimeVal);
{$ELSE}
fpFD_ZERO(FDSet);
fpFD_SET(integer(FHandle), FDSet);
x := fpSelect(integer(FHandle) + 1, @FDSet, nil, nil, TimeVal);
fpFD_SET(FHandle, FDSet);
x := fpSelect(FHandle + 1, @FDSet, nil, nil, TimeVal);
{$ENDIF}
SerialCheck(x);
if FLastError <> sOK then
@ -1794,7 +1813,7 @@ begin
end;
{$ENDIF}
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
function TBlockSerial.CanWrite(Timeout: integer): boolean;
var
FDSet: TFDSet;
@ -1809,12 +1828,12 @@ begin
TimeVal := nil;
{$IFNDEF FPC}
FD_ZERO(FDSet);
FD_SET(integer(FHandle), FDSet);
x := Select(integer(FHandle) + 1, nil, @FDSet, nil, TimeVal);
FD_SET(FHandle, FDSet);
x := Select(FHandle + 1, nil, @FDSet, nil, TimeVal);
{$ELSE}
fpFD_ZERO(FDSet);
fpFD_SET(integer(FHandle), FDSet);
x := fpSelect(integer(FHandle) + 1, nil, @FDSet, nil, TimeVal);
fpFD_SET(FHandle, FDSet);
x := fpSelect(FHandle + 1, nil, @FDSet, nil, TimeVal);
{$ENDIF}
SerialCheck(x);
if FLastError <> sOK then
@ -1858,7 +1877,7 @@ end;
procedure TBlockSerial.EnableRTSToggle(Value: boolean);
begin
SetSynaError(sOK);
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
FRTSToggle := Value;
if Value then
RTS:=False;
@ -1883,8 +1902,8 @@ end;
procedure TBlockSerial.Flush;
begin
{$IFNDEF WIN32}
SerialCheck(tcdrain(integer(FHandle)));
{$IFNDEF MSWINDOWS}
SerialCheck(tcdrain(FHandle));
{$ELSE}
SetSynaError(sOK);
if not Flushfilebuffers(FHandle) then
@ -1893,13 +1912,13 @@ begin
ExceptCheck;
end;
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
procedure TBlockSerial.Purge;
begin
{$IFNDEF FPC}
SerialCheck(ioctl(integer(FHandle), TCFLSH, TCIOFLUSH));
SerialCheck(ioctl(FHandle, TCFLSH, TCIOFLUSH));
{$ELSE}
SerialCheck(fpioctl(integer(FHandle), TCFLSH, TCIOFLUSH));
SerialCheck(fpioctl(FHandle, TCFLSH, TCIOFLUSH));
{$ENDIF}
FBuffer := '';
ExceptCheck;
@ -1921,11 +1940,11 @@ end;
function TBlockSerial.ModemStatus: integer;
begin
Result := 0;
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
{$IFNDEF FPC}
SerialCheck(ioctl(integer(FHandle), TIOCMGET, @Result));
SerialCheck(ioctl(FHandle, TIOCMGET, @Result));
{$ELSE}
SerialCheck(fpioctl(integer(FHandle), TIOCMGET, @Result));
SerialCheck(fpioctl(FHandle, TIOCMGET, @Result));
{$ENDIF}
{$ELSE}
SetSynaError(sOK);
@ -1938,8 +1957,8 @@ end;
procedure TBlockSerial.SetBreak(Duration: integer);
begin
{$IFNDEF WIN32}
SerialCheck(tcsendbreak(integer(FHandle), Duration));
{$IFNDEF MSWINDOWS}
SerialCheck(tcsendbreak(FHandle, Duration));
{$ELSE}
SetCommBreak(FHandle);
Sleep(Duration);
@ -1949,7 +1968,7 @@ begin
{$ENDIF}
end;
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
procedure TBlockSerial.DecodeCommError(Error: DWord);
begin
if (Error and DWord(CE_FRAME)) > 1 then
@ -1984,9 +2003,9 @@ begin
result := ((not FTestDSR) or DSR) and ((not FTestCTS) or CTS);
end;
function TBlockSerial.ATCommand(value: string): string;
function TBlockSerial.ATCommand(value: AnsiString): AnsiString;
var
s: string;
s: AnsiString;
ConvSave: Boolean;
begin
result := '';
@ -2013,9 +2032,9 @@ begin
end;
function TBlockSerial.ATConnect(value: string): string;
function TBlockSerial.ATConnect(value: AnsiString): AnsiString;
var
s: string;
s: AnsiString;
ConvSave: Boolean;
begin
result := '';
@ -2050,7 +2069,7 @@ end;
function TBlockSerial.SerialCheck(SerialResult: integer): integer;
begin
if SerialResult = integer(INVALID_HANDLE_VALUE) then
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
result := GetLastError
{$ELSE}
{$IFNDEF FPC}
@ -2166,7 +2185,8 @@ begin
// Allow all users to enjoy the benefits of cpom
s := 'chmod a+rw ' + LockfileName;
{$IFNDEF FPC}
Libc.system(pchar(s));
FileSetReadOnly( LockfileName, False ) ;
// Libc.system(pchar(s));
{$ELSE}
fpSystem(s);
{$ENDIF}
@ -2236,7 +2256,7 @@ end;
{$ENDIF}
{----------------------------------------------------------------}
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
function GetSerialPortNames: string;
var
reg: TRegistry;
@ -2265,7 +2285,7 @@ begin
end;
end;
{$ENDIF}
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
function GetSerialPortNames: string;
var
Index: Integer;

53
trunk/Units/Synapse/synautil.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 004.013.000 |
| Project : Ararat Synapse | 004.014.000 |
|==============================================================================|
| Content: support procedures and functions |
|==============================================================================|
| Copyright (c)1999-2008, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2008. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
| Portions created by Hernan Sanchez are Copyright (c) 2000. |
| All Rights Reserved. |
|==============================================================================|
@ -53,18 +53,31 @@
{$R-}
{$H+}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$WARN SUSPICIOUS_TYPECAST OFF}
{$ENDIF}
unit synautil;
interface
uses
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
Windows,
{$ELSE}
{$IFDEF FPC}
UnixUtil, Unix, BaseUnix,
UnixUtil, Unix, BaseUnix,
{$ELSE}
Libc,
Libc,
{$ENDIF}
{$ENDIF}
{$IFDEF CIL}
@ -102,7 +115,7 @@ function AnsiCDateTime(t: TDateTime): string;
{:Decode three-letter string with name of month to their month number. If string
not match any month name, then is returned 0. For parsing are used predefined
names for English, French and German and names from system locale too.}
function GetMonthNumber(Value: AnsiString): integer;
function GetMonthNumber(Value: String): integer;
{:Return decoded time from given string. Time must be witch separator ':'. You
can use "hh:mm" or "hh:mm:ss".}
@ -251,7 +264,7 @@ function FetchEx(var Value: string; const Delimiter, Quotation: string): string;
{:If string is binary string (contains non-printable characters), then is
returned true.}
function IsBinaryString(const Value: string): Boolean;
function IsBinaryString(const Value: AnsiString): Boolean;
{:return position of string terminator in string. If terminator found, then is
returned in terminator parameter.
@ -327,7 +340,7 @@ const
MyDayNames: array[1..7] of AnsiString =
('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
var
MyMonthNames: array[0..6, 1..12] of AnsiString =
MyMonthNames: array[0..6, 1..12] of String =
(
('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //rewrited by system locales
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'),
@ -349,7 +362,7 @@ var
{==============================================================================}
function TimeZoneBias: integer;
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
{$IFNDEF FPC}
var
t: TTime_T;
@ -526,10 +539,10 @@ end;
{==============================================================================}
function GetMonthNumber(Value: AnsiString): integer;
function GetMonthNumber(Value: String): integer;
var
n: integer;
function TestMonth(Value: AnsiString; Index: Integer): Boolean;
function TestMonth(Value: String; Index: Integer): Boolean;
var
n: integer;
begin
@ -700,7 +713,7 @@ end;
{==============================================================================}
function GetUTTime: TDateTime;
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
{$IFNDEF FPC}
var
st: TSystemTime;
@ -742,7 +755,7 @@ end;
{==============================================================================}
function SetUTTime(Newdt: TDateTime): Boolean;
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
{$IFNDEF FPC}
var
st: TSystemTime;
@ -795,7 +808,7 @@ end;
{==============================================================================}
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
function GetTick: LongWord;
var
Stamp: TTimeStamp;
@ -1405,7 +1418,7 @@ end;
{==============================================================================}
function IsBinaryString(const Value: string): Boolean;
function IsBinaryString(const Value: AnsiString): Boolean;
var
n: integer;
begin
@ -1413,7 +1426,7 @@ begin
for n := 1 to Length(Value) do
if Value[n] in [#0..#8, #10..#31] then
//ignore null-terminated strings
if not ((n = Length(value)) and (Value[n] = #0)) then
if not ((n = Length(value)) and (Value[n] = AnsiChar(#0))) then
begin
Result := True;
Break;
@ -1720,7 +1733,7 @@ end;
{==============================================================================}
function GetTempFile(const Dir, prefix: AnsiString): AnsiString;
{$IFNDEF FPC}
{$IFDEF WIN32}
{$IFDEF MSWINDOWS}
var
Path: AnsiString;
x: integer;
@ -1730,7 +1743,7 @@ begin
{$IFDEF FPC}
Result := GetTempFileName(Dir, Prefix);
{$ELSE}
{$IFNDEF WIN32}
{$IFNDEF MSWINDOWS}
Result := tempnam(Pointer(Dir), Pointer(prefix));
{$ELSE}
{$IFDEF CIL}
@ -1784,7 +1797,7 @@ begin
for n := 1 to Length(t) do
if t[n] = #9 then
t[n] := ' ';
if not(t[1] in [' ', '"', ':', '=']) then
if not(AnsiChar(t[1]) in [' ', '"', ':', '=']) then
Break
else
begin

36
trunk/Units/Synapse/synsock.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 005.001.000 |
| Project : Ararat Synapse | 005.002.000 |
|==============================================================================|
| Content: Socket Independent Platform Layer |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2003. |
| Portions created by Lukas Gebauer are Copyright (c)2001-20010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -48,20 +48,30 @@ unit synsock;
{$MINENUMSIZE 4}
{$IFDEF CIL}
{$I ssdotnet.pas}
{$ENDIF}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$I sswin32.pas}
{$ELSE}
{$IFDEF FPC}
{$I ssfpc.pas}
{$ELSE}
{$I sslinux.pas}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{$IFDEF CIL}
{$I ssdotnet.pas}
{$ELSE}
{$IFDEF MSWINDOWS}
{$I sswin32.pas}
{$ELSE}
{$IFDEF WINCE}
{$I sswin32.pas} //not complete yet!
{$ELSE}
{$IFDEF FPC}
{$I ssfpc.pas}
{$ELSE}
{$I sslinux.pas}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
end.

12
trunk/Units/Synapse/tlntsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 001.003.000 |
| Project : Ararat Synapse | 001.003.001 |
|==============================================================================|
| Content: TELNET and SSH2 client |
|==============================================================================|
| Copyright (c)1999-2008, Lukas Gebauer |
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2002-2008. |
| Portions created by Lukas Gebauer are Copyright (c)2002-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -52,6 +52,11 @@ Used RFC: RFC-854
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit tlntsend;
interface
@ -148,6 +153,7 @@ constructor TTelnetSend.Create;
begin
inherited Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.OnReadFilter := FilterHook;
FTimeout := 60000;
FTargetPort := cTelnetProtocol;