From 87c496ca855cd17d9404cf1e7b1463e850705df5 Mon Sep 17 00:00:00 2001 From: Raymond Date: Sat, 13 Feb 2010 16:56:46 +0000 Subject: [PATCH] Fixed issue with settings file being saved in the wrong directory. 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 --- trunk/Projects/SAMufasaGUI/simbasettings.pas | 4 +- trunk/Projects/SAMufasaGUI/testunit.pas | 55 +++- .../MMLAddon/PSInc/Wrappers/internets.inc | 44 ++++ .../MMLAddon/PSInc/psexportedmethods.inc | 10 + trunk/Units/MMLAddon/internets.pas | 164 +++++++++++- trunk/Units/MMLAddon/mmlpsthread.pas | 6 +- trunk/Units/MMLCore/client.pas | 1 - trunk/Units/MMLCore/tpa.pas | 3 + trunk/Units/Synapse/asn1util.pas | 5 + trunk/Units/Synapse/blcksock.pas | 158 +++++++++--- trunk/Units/Synapse/clamsend.pas | 14 +- trunk/Units/Synapse/dnssend.pas | 17 +- trunk/Units/Synapse/ftpsend.pas | 36 +-- trunk/Units/Synapse/ftptsend.pas | 12 +- trunk/Units/Synapse/httpsend.pas | 20 +- trunk/Units/Synapse/imapsend.pas | 12 +- trunk/Units/Synapse/ldapsend.pas | 25 +- trunk/Units/Synapse/mimeinln.pas | 5 + trunk/Units/Synapse/mimepart.pas | 5 + trunk/Units/Synapse/nntpsend.pas | 13 +- trunk/Units/Synapse/pingsend.pas | 62 +++-- trunk/Units/Synapse/pop3send.pas | 15 +- trunk/Units/Synapse/slogsend.pas | 7 +- trunk/Units/Synapse/smtpsend.pas | 14 +- trunk/Units/Synapse/snmpsend.pas | 12 +- trunk/Units/Synapse/sntpsend.pas | 9 +- trunk/Units/Synapse/ssfpc.pas | 7 +- trunk/Units/Synapse/ssl_openssl.pas | 14 +- trunk/Units/Synapse/ssl_openssl_lib.pas | 37 ++- trunk/Units/Synapse/sslinux.pas | 7 +- trunk/Units/Synapse/sswin32.pas | 68 +++-- trunk/Units/Synapse/synachar.pas | 5 + trunk/Units/Synapse/synacode.pas | 14 +- trunk/Units/Synapse/synacrypt.pas | 11 +- trunk/Units/Synapse/synadbg.pas | 10 +- trunk/Units/Synapse/synafpc.pas | 16 +- trunk/Units/Synapse/synaicnv.pas | 16 +- trunk/Units/Synapse/synaip.pas | 16 +- trunk/Units/Synapse/synamisc.pas | 9 +- trunk/Units/Synapse/synaser.pas | 234 ++++++++++-------- trunk/Units/Synapse/synautil.pas | 53 ++-- trunk/Units/Synapse/synsock.pas | 36 ++- trunk/Units/Synapse/tlntsend.pas | 12 +- 43 files changed, 948 insertions(+), 345 deletions(-) diff --git a/trunk/Projects/SAMufasaGUI/simbasettings.pas b/trunk/Projects/SAMufasaGUI/simbasettings.pas index e10bb83..8045c48 100644 --- a/trunk/Projects/SAMufasaGUI/simbasettings.pas +++ b/trunk/Projects/SAMufasaGUI/simbasettings.pas @@ -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 diff --git a/trunk/Projects/SAMufasaGUI/testunit.pas b/trunk/Projects/SAMufasaGUI/testunit.pas index 1f6bdbe..9facd54 100644 --- a/trunk/Projects/SAMufasaGUI/testunit.pas +++ b/trunk/Projects/SAMufasaGUI/testunit.pas @@ -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); diff --git a/trunk/Units/MMLAddon/PSInc/Wrappers/internets.inc b/trunk/Units/MMLAddon/PSInc/Wrappers/internets.inc index f41d91f..4c9c384 100644 --- a/trunk/Units/MMLAddon/PSInc/Wrappers/internets.inc +++ b/trunk/Units/MMLAddon/PSInc/Wrappers/internets.inc @@ -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; diff --git a/trunk/Units/MMLAddon/PSInc/psexportedmethods.inc b/trunk/Units/MMLAddon/PSInc/psexportedmethods.inc index afc2129..677545d 100644 --- a/trunk/Units/MMLAddon/PSInc/psexportedmethods.inc +++ b/trunk/Units/MMLAddon/PSInc/psexportedmethods.inc @@ -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 } diff --git a/trunk/Units/MMLAddon/internets.pas b/trunk/Units/MMLAddon/internets.pas index c94732d..223fdeb 100644 --- a/trunk/Units/MMLAddon/internets.pas +++ b/trunk/Units/MMLAddon/internets.pas @@ -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. diff --git a/trunk/Units/MMLAddon/mmlpsthread.pas b/trunk/Units/MMLAddon/mmlpsthread.pas index 538fc38..40347a4 100644 --- a/trunk/Units/MMLAddon/mmlpsthread.pas +++ b/trunk/Units/MMLAddon/mmlpsthread.pas @@ -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; diff --git a/trunk/Units/MMLCore/client.pas b/trunk/Units/MMLCore/client.pas index 000bb8f..8ed4fc3 100644 --- a/trunk/Units/MMLCore/client.pas +++ b/trunk/Units/MMLCore/client.pas @@ -51,7 +51,6 @@ It binds all the components together. MBitmaps : TMBitmaps; MDTM: TMDTM; MOCR: TMOCR; - end; implementation diff --git a/trunk/Units/MMLCore/tpa.pas b/trunk/Units/MMLCore/tpa.pas index 3bfd689..ef7bc28 100644 --- a/trunk/Units/MMLCore/tpa.pas +++ b/trunk/Units/MMLCore/tpa.pas @@ -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; diff --git a/trunk/Units/Synapse/asn1util.pas b/trunk/Units/Synapse/asn1util.pas index 55d0892..e0419c7 100644 --- a/trunk/Units/Synapse/asn1util.pas +++ b/trunk/Units/Synapse/asn1util.pas @@ -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 diff --git a/trunk/Units/Synapse/blcksock.pas b/trunk/Units/Synapse/blcksock.pas index 3ac6b6a..5f41f02 100644 --- a/trunk/Units/Synapse/blcksock.pas +++ b/trunk/Units/Synapse/blcksock.pas @@ -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; diff --git a/trunk/Units/Synapse/clamsend.pas b/trunk/Units/Synapse/clamsend.pas index 91a9f56..8d3c2d6 100644 --- a/trunk/Units/Synapse/clamsend.pas +++ b/trunk/Units/Synapse/clamsend.pas @@ -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 diff --git a/trunk/Units/Synapse/dnssend.pas b/trunk/Units/Synapse/dnssend.pas index f7684ce..84c14cc 100644 --- a/trunk/Units/Synapse/dnssend.pas +++ b/trunk/Units/Synapse/dnssend.pas @@ -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; diff --git a/trunk/Units/Synapse/ftpsend.pas b/trunk/Units/Synapse/ftpsend.pas index 49b2a00..cbbfb35 100644 --- a/trunk/Units/Synapse/ftpsend.pas +++ b/trunk/Units/Synapse/ftpsend.pas @@ -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; diff --git a/trunk/Units/Synapse/ftptsend.pas b/trunk/Units/Synapse/ftptsend.pas index 9cf7bab..6ab4173 100644 --- a/trunk/Units/Synapse/ftptsend.pas +++ b/trunk/Units/Synapse/ftptsend.pas @@ -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; diff --git a/trunk/Units/Synapse/httpsend.pas b/trunk/Units/Synapse/httpsend.pas index feef6b0..21d1240 100644 --- a/trunk/Units/Synapse/httpsend.pas +++ b/trunk/Units/Synapse/httpsend.pas @@ -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; diff --git a/trunk/Units/Synapse/imapsend.pas b/trunk/Units/Synapse/imapsend.pas index 1e91b08..55f5339 100644 --- a/trunk/Units/Synapse/imapsend.pas +++ b/trunk/Units/Synapse/imapsend.pas @@ -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; diff --git a/trunk/Units/Synapse/ldapsend.pas b/trunk/Units/Synapse/ldapsend.pas index 1067d4a..ece52d6 100644 --- a/trunk/Units/Synapse/ldapsend.pas +++ b/trunk/Units/Synapse/ldapsend.pas @@ -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; diff --git a/trunk/Units/Synapse/mimeinln.pas b/trunk/Units/Synapse/mimeinln.pas index 4f0331a..924dd5f 100644 --- a/trunk/Units/Synapse/mimeinln.pas +++ b/trunk/Units/Synapse/mimeinln.pas @@ -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 diff --git a/trunk/Units/Synapse/mimepart.pas b/trunk/Units/Synapse/mimepart.pas index 5c29aaf..93e0b91 100644 --- a/trunk/Units/Synapse/mimepart.pas +++ b/trunk/Units/Synapse/mimepart.pas @@ -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 diff --git a/trunk/Units/Synapse/nntpsend.pas b/trunk/Units/Synapse/nntpsend.pas index ef35f77..d0c1960 100644 --- a/trunk/Units/Synapse/nntpsend.pas +++ b/trunk/Units/Synapse/nntpsend.pas @@ -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; diff --git a/trunk/Units/Synapse/pingsend.pas b/trunk/Units/Synapse/pingsend.pas index ddab79e..1a4e331 100644 --- a/trunk/Units/Synapse/pingsend.pas +++ b/trunk/Units/Synapse/pingsend.pas @@ -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; diff --git a/trunk/Units/Synapse/pop3send.pas b/trunk/Units/Synapse/pop3send.pas index a261c56..05c5ac0 100644 --- a/trunk/Units/Synapse/pop3send.pas +++ b/trunk/Units/Synapse/pop3send.pas @@ -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; diff --git a/trunk/Units/Synapse/slogsend.pas b/trunk/Units/Synapse/slogsend.pas index 9c0625d..900f6c0 100644 --- a/trunk/Units/Synapse/slogsend.pas +++ b/trunk/Units/Synapse/slogsend.pas @@ -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; diff --git a/trunk/Units/Synapse/smtpsend.pas b/trunk/Units/Synapse/smtpsend.pas index f597ef9..532af07 100644 --- a/trunk/Units/Synapse/smtpsend.pas +++ b/trunk/Units/Synapse/smtpsend.pas @@ -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; diff --git a/trunk/Units/Synapse/snmpsend.pas b/trunk/Units/Synapse/snmpsend.pas index d8909cf..431f5e4 100644 --- a/trunk/Units/Synapse/snmpsend.pas +++ b/trunk/Units/Synapse/snmpsend.pas @@ -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 := ''; diff --git a/trunk/Units/Synapse/sntpsend.pas b/trunk/Units/Synapse/sntpsend.pas index c4958b2..4aa0bbf 100644 --- a/trunk/Units/Synapse/sntpsend.pas +++ b/trunk/Units/Synapse/sntpsend.pas @@ -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; diff --git a/trunk/Units/Synapse/ssfpc.pas b/trunk/Units/Synapse/ssfpc.pas index 072d7c7..aa275e7 100644 --- a/trunk/Units/Synapse/ssfpc.pas +++ b/trunk/Units/Synapse/ssfpc.pas @@ -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; diff --git a/trunk/Units/Synapse/ssl_openssl.pas b/trunk/Units/Synapse/ssl_openssl.pas index b3659f5..1629bab 100644 --- a/trunk/Units/Synapse/ssl_openssl.pas +++ b/trunk/Units/Synapse/ssl_openssl.pas @@ -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; diff --git a/trunk/Units/Synapse/ssl_openssl_lib.pas b/trunk/Units/Synapse/ssl_openssl_lib.pas index 23d33ec..b9fe056 100644 --- a/trunk/Units/Synapse/ssl_openssl_lib.pas +++ b/trunk/Units/Synapse/ssl_openssl_lib.pas @@ -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 (*$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; diff --git a/trunk/Units/Synapse/sslinux.pas b/trunk/Units/Synapse/sslinux.pas index c337281..2a23146 100644 --- a/trunk/Units/Synapse/sslinux.pas +++ b/trunk/Units/Synapse/sslinux.pas @@ -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; diff --git a/trunk/Units/Synapse/sswin32.pas b/trunk/Units/Synapse/sswin32.pas index 9661ef4..30848d8 100644 --- a/trunk/Units/Synapse/sswin32.pas +++ b/trunk/Units/Synapse/sswin32.pas @@ -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} \ No newline at end of file +end; \ No newline at end of file diff --git a/trunk/Units/Synapse/synachar.pas b/trunk/Units/Synapse/synachar.pas index da7c7f7..af889f0 100644 --- a/trunk/Units/Synapse/synachar.pas +++ b/trunk/Units/Synapse/synachar.pas @@ -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 diff --git a/trunk/Units/Synapse/synacode.pas b/trunk/Units/Synapse/synacode.pas index f183c8c..18c9040 100644 --- a/trunk/Units/Synapse/synacode.pas +++ b/trunk/Units/Synapse/synacode.pas @@ -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 = diff --git a/trunk/Units/Synapse/synacrypt.pas b/trunk/Units/Synapse/synacrypt.pas index c80e891..dc43b9b 100644 --- a/trunk/Units/Synapse/synacrypt.pas +++ b/trunk/Units/Synapse/synacrypt.pas @@ -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 diff --git a/trunk/Units/Synapse/synadbg.pas b/trunk/Units/Synapse/synadbg.pas index ef84626..a8e7f26 100644 --- a/trunk/Units/Synapse/synadbg.pas +++ b/trunk/Units/Synapse/synadbg.pas @@ -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; diff --git a/trunk/Units/Synapse/synafpc.pas b/trunk/Units/Synapse/synafpc.pas index a3d580b..cd39e70 100644 --- a/trunk/Units/Synapse/synafpc.pas +++ b/trunk/Units/Synapse/synafpc.pas @@ -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} diff --git a/trunk/Units/Synapse/synaicnv.pas b/trunk/Units/Synapse/synaicnv.pas index 8d01b74..3dd79c5 100644 --- a/trunk/Units/Synapse/synaicnv.pas +++ b/trunk/Units/Synapse/synaicnv.pas @@ -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'; diff --git a/trunk/Units/Synapse/synaip.pas b/trunk/Units/Synapse/synaip.pas index 01c0691..82a7da4 100644 --- a/trunk/Units/Synapse/synaip.pas +++ b/trunk/Units/Synapse/synaip.pas @@ -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; diff --git a/trunk/Units/Synapse/synamisc.pas b/trunk/Units/Synapse/synamisc.pas index 354fa45..1bcfe6d 100644 --- a/trunk/Units/Synapse/synamisc.pas +++ b/trunk/Units/Synapse/synamisc.pas @@ -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 diff --git a/trunk/Units/Synapse/synaser.pas b/trunk/Units/Synapse/synaser.pas index a9eec96..5ea07c1 100644 --- a/trunk/Units/Synapse/synaser.pas +++ b/trunk/Units/Synapse/synaser.pas @@ -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; diff --git a/trunk/Units/Synapse/synautil.pas b/trunk/Units/Synapse/synautil.pas index 0bd1cd4..db7f483 100644 --- a/trunk/Units/Synapse/synautil.pas +++ b/trunk/Units/Synapse/synautil.pas @@ -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 diff --git a/trunk/Units/Synapse/synsock.pas b/trunk/Units/Synapse/synsock.pas index c4bc977..c1cad2e 100644 --- a/trunk/Units/Synapse/synsock.pas +++ b/trunk/Units/Synapse/synsock.pas @@ -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. diff --git a/trunk/Units/Synapse/tlntsend.pas b/trunk/Units/Synapse/tlntsend.pas index 0fdb9e0..557266c 100644 --- a/trunk/Units/Synapse/tlntsend.pas +++ b/trunk/Units/Synapse/tlntsend.pas @@ -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;