diff --git a/addons/synapse/synamisc.pas b/addons/synapse/synamisc.pas index c60ce35..22a3274 100644 --- a/addons/synapse/synamisc.pas +++ b/addons/synapse/synamisc.pas @@ -1,415 +1,5 @@ -<<<<<<< HEAD -<<<<<<< HEAD -======= ->>>>>>> remotes/origin/master -{==============================================================================| -| Project : Ararat Synapse | 001.003.001 | -|==============================================================================| -| Content: misc. procedures and functions | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 2002-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(Misc. network based utilities)} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -//Kylix does not known UNIX define -{$IFDEF LINUX} - {$IFNDEF UNIX} - {$DEFINE UNIX} - {$ENDIF} -{$ENDIF} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit synamisc; - -interface - -{$IFDEF VER125} - {$DEFINE BCB} -{$ENDIF} -{$IFDEF BCB} - {$ObjExportAll On} - {$HPPEMIT '#pragma comment( lib , "wininet.lib" )'} -{$ENDIF} - -uses - synautil, blcksock, SysUtils, Classes -{$IFDEF UNIX} - {$IFNDEF FPC} - , Libc - {$ENDIF} -{$ELSE} - , Windows -{$ENDIF} -; - -Type - {:@abstract(This record contains information about proxy setting.)} - TProxySetting = record - Host: string; - Port: string; - Bypass: string; - end; - -{:By this function you can turn-on computer on network, if this computer - supporting Wake-on-lan feature. You need MAC number (network card indentifier) - of computer for turn-on. You can also assign target IP addres. If you not - specify it, then is used broadcast for delivery magic wake-on packet. However - broadcasts workinh only on your local network. When you need to wake-up - computer on another network, you must specify any existing IP addres on same - network segment as targeting computer.} -procedure WakeOnLan(MAC, IP: string); - -{:Autodetect current DNS servers used by system. If is defined more then one DNS - server, then result is comma-delimited.} -function GetDNS: string; - -{:Autodetect InternetExplorer proxy setting for given protocol. This function -working only on windows!} -function GetIEProxy(protocol: string): TProxySetting; - -{:Return all known IP addresses on local system. Addresses are divided by comma.} -function GetLocalIPs: string; - -implementation - -{==============================================================================} -procedure WakeOnLan(MAC, IP: string); -var - sock: TUDPBlockSocket; - HexMac: Ansistring; - data: Ansistring; - n: integer; - b: Byte; -begin - if MAC <> '' then - begin - MAC := ReplaceString(MAC, '-', ''); - MAC := ReplaceString(MAC, ':', ''); - if Length(MAC) < 12 then - Exit; - HexMac := ''; - for n := 0 to 5 do - begin - b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0); - HexMac := HexMac + char(b); - end; - if IP = '' then - IP := cBroadcast; - sock := TUDPBlockSocket.Create; - try - sock.CreateSocket; - sock.EnableBroadcast(true); - sock.Connect(IP, '9'); - data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF; - for n := 1 to 16 do - data := data + HexMac; - sock.SendString(data); - finally - sock.Free; - end; - end; -end; - -{==============================================================================} - -{$IFNDEF UNIX} -function GetDNSbyIpHlp: string; -type - PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING; - TIP_ADDRESS_STRING = array[0..15] of Ansichar; - PTIP_ADDR_STRING = ^TIP_ADDR_STRING; - TIP_ADDR_STRING = packed record - Next: PTIP_ADDR_STRING; - IpAddress: TIP_ADDRESS_STRING; - IpMask: TIP_ADDRESS_STRING; - Context: DWORD; - end; - PTFixedInfo = ^TFixedInfo; - TFixedInfo = packed record - HostName: array[1..128 + 4] of Ansichar; - DomainName: array[1..128 + 4] of Ansichar; - CurrentDNSServer: PTIP_ADDR_STRING; - DNSServerList: TIP_ADDR_STRING; - NodeType: UINT; - ScopeID: array[1..256 + 4] of Ansichar; - EnableRouting: UINT; - EnableProxy: UINT; - EnableDNS: UINT; - end; -const - IpHlpDLL = 'IPHLPAPI.DLL'; -var - IpHlpModule: THandle; - FixedInfo: PTFixedInfo; - InfoSize: Longint; - PDnsServer: PTIP_ADDR_STRING; - err: integer; - GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall; -begin - InfoSize := 0; - Result := '...'; - IpHlpModule := LoadLibrary(IpHlpDLL); - if IpHlpModule = 0 then - exit; - try - GetNetworkParams := GetProcAddress(IpHlpModule,PAnsiChar(AnsiString('GetNetworkParams'))); - if @GetNetworkParams = nil then - Exit; - err := GetNetworkParams(Nil, @InfoSize); - if err <> ERROR_BUFFER_OVERFLOW then - Exit; - Result := ''; - GetMem (FixedInfo, InfoSize); - try - err := GetNetworkParams(FixedInfo, @InfoSize); - if err <> ERROR_SUCCESS then - exit; - with FixedInfo^ do - begin - Result := DnsServerList.IpAddress; - PDnsServer := DnsServerList.Next; - while PDnsServer <> Nil do - begin - if Result <> '' then - Result := Result + ','; - Result := Result + PDnsServer^.IPAddress; - PDnsServer := PDnsServer.Next; - end; - end; - finally - FreeMem(FixedInfo); - end; - finally - FreeLibrary(IpHlpModule); - end; -end; - -function ReadReg(SubKey, Vn: PChar): string; -var - OpenKey: HKEY; - DataType, DataSize: integer; - Temp: array [0..2048] of char; -begin - Result := ''; - if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE, - KEY_READ, OpenKey) = ERROR_SUCCESS then - begin - DataType := REG_SZ; - DataSize := SizeOf(Temp); - if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then - SetString(Result, Temp, DataSize div SizeOf(Char) - 1); - RegCloseKey(OpenKey); - end; -end ; -{$ENDIF} - -function GetDNS: string; -{$IFDEF UNIX} -var - l: TStringList; - n: integer; -begin - Result := ''; - l := TStringList.Create; - try - l.LoadFromFile('/etc/resolv.conf'); - for n := 0 to l.Count - 1 do - if Pos('NAMESERVER', uppercase(l[n])) = 1 then - begin - if Result <> '' then - Result := Result + ','; - Result := Result + SeparateRight(l[n], ' '); - end; - finally - l.Free; - end; -end; -{$ELSE} -const - NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary'; - NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters'; - W9xfix = 'System\CurrentControlSet\Services\MSTCP'; -begin - Result := GetDNSbyIpHlp; - if Result = '...' then - begin - if Win32Platform = VER_PLATFORM_WIN32_NT then - begin - Result := ReadReg(NTdyn, 'NameServer'); - if result = '' then - Result := ReadReg(NTfix, 'NameServer'); - if result = '' then - Result := ReadReg(NTfix, 'DhcpNameServer'); - end - else - Result := ReadReg(W9xfix, 'NameServer'); - Result := ReplaceString(trim(Result), ' ', ','); - end; -end; -{$ENDIF} - -{==============================================================================} - -function GetIEProxy(protocol: string): TProxySetting; -{$IFDEF UNIX} -begin - Result.Host := ''; - Result.Port := ''; - Result.Bypass := ''; -end; -{$ELSE} -type - PInternetProxyInfo = ^TInternetProxyInfo; - TInternetProxyInfo = packed record - dwAccessType: DWORD; - lpszProxy: LPCSTR; - lpszProxyBypass: LPCSTR; - end; -const - INTERNET_OPTION_PROXY = 38; - INTERNET_OPEN_TYPE_PROXY = 3; - WininetDLL = 'WININET.DLL'; -var - WininetModule: THandle; - ProxyInfo: PInternetProxyInfo; - Err: Boolean; - Len: DWORD; - Proxy: string; - DefProxy: string; - ProxyList: TStringList; - n: integer; - InternetQueryOption: function (hInet: Pointer; dwOption: DWORD; - lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall; -begin - Result.Host := ''; - Result.Port := ''; - Result.Bypass := ''; - WininetModule := LoadLibrary(WininetDLL); - if WininetModule = 0 then - exit; - try - InternetQueryOption := GetProcAddress(WininetModule,PAnsiChar(AnsiString('InternetQueryOptionA'))); - if @InternetQueryOption = nil then - Exit; - - if protocol = '' then - protocol := 'http'; - Len := 4096; - GetMem(ProxyInfo, Len); - ProxyList := TStringList.Create; - try - Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len); - if Err then - if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then - begin - ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ','); - Proxy := ''; - DefProxy := ''; - for n := 0 to ProxyList.Count -1 do - begin - if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then - begin - Proxy := SeparateRight(ProxyList[n], '='); - break; - end; - if Pos('=', ProxyList[n]) < 1 then - DefProxy := ProxyList[n]; - end; - if Proxy = '' then - Proxy := DefProxy; - if Proxy <> '' then - begin - Result.Host := Trim(SeparateLeft(Proxy, ':')); - Result.Port := Trim(SeparateRight(Proxy, ':')); - end; - Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ','); - end; - finally - ProxyList.Free; - FreeMem(ProxyInfo); - end; - finally - FreeLibrary(WininetModule); - end; -end; -{$ENDIF} - -{==============================================================================} - -function GetLocalIPs: string; -var - TcpSock: TTCPBlockSocket; - ipList: TStringList; -begin - Result := ''; - ipList := TStringList.Create; - try - TcpSock := TTCPBlockSocket.create; - try - TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList); - Result := ipList.CommaText; - finally - TcpSock.Free; - end; - finally - ipList.Free; - end; -end; - -{==============================================================================} - -end. -<<<<<<< HEAD -======= {==============================================================================| -| Project : Ararat Synapse | 001.003.000 | +| Project : Ararat Synapse | 001.003.001 | |==============================================================================| | Content: misc. procedures and functions | |==============================================================================| @@ -460,6 +50,13 @@ function GetLocalIPs: string; {$Q-} {$H+} +//Kylix does not known UNIX define +{$IFDEF LINUX} + {$IFNDEF UNIX} + {$DEFINE UNIX} + {$ENDIF} +{$ENDIF} + {$IFDEF UNICODE} {$WARN IMPLICIT_STRING_CAST OFF} {$WARN IMPLICIT_STRING_CAST_LOSS OFF} @@ -479,7 +76,7 @@ interface uses synautil, blcksock, SysUtils, Classes -{$IFDEF LINUX} +{$IFDEF UNIX} {$IFNDEF FPC} , Libc {$ENDIF} @@ -558,7 +155,7 @@ procedure WakeOnLan(MAC, IP: string); {==============================================================================} -{$IFNDEF LINUX} +{$IFNDEF UNIX} function GetDNSbyIpHlp: string; type PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING; @@ -650,7 +247,7 @@ function ReadReg(SubKey, Vn: PChar): string; {$ENDIF} function GetDNS: string; -{$IFDEF LINUX} +{$IFDEF UNIX} var l: TStringList; n: integer; @@ -697,7 +294,7 @@ function GetDNS: string; {==============================================================================} function GetIEProxy(protocol: string): TProxySetting; -{$IFDEF LINUX} +{$IFDEF UNIX} begin Result.Host := ''; Result.Port := ''; @@ -805,6 +402,3 @@ function GetLocalIPs: string; {==============================================================================} end. ->>>>>>> remotes/origin/NMD -======= ->>>>>>> remotes/origin/master diff --git a/addons/synapse/synaser.pas b/addons/synapse/synaser.pas index e390baf..6082b70 100644 --- a/addons/synapse/synaser.pas +++ b/addons/synapse/synaser.pas @@ -1,2350 +1,5 @@ -<<<<<<< HEAD -<<<<<<< HEAD -======= ->>>>>>> remotes/origin/master -{==============================================================================| -| Project : Ararat Synapse | 007.005.000 | -|==============================================================================| -| Content: Serial port support | -|==============================================================================| -| Copyright (c)2001-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2001-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| (c)2002, Hans-Georg Joepgen (cpom Comport Ownership Manager and bugfixes) | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{: @abstract(Serial port communication library) -This unit contains a class that implements serial port communication - for Windows, Linux, Unix or MacOSx. This class provides numerous methods with - same name and functionality as methods of the Ararat Synapse TCP/IP library. - -The following is a small example how establish a connection by modem (in this -case with my USB modem): -@longcode(# - ser:=TBlockSerial.Create; - try - ser.Connect('COM3'); - ser.config(460800,8,'N',0,false,true); - ser.ATCommand('AT'); - if (ser.LastError <> 0) or (not ser.ATResult) then - Exit; - ser.ATConnect('ATDT+420971200111'); - if (ser.LastError <> 0) or (not ser.ATResult) then - Exit; - // you are now connected to a modem at +420971200111 - // you can transmit or receive data now - finally - ser.free; - end; -#) -} - -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -//Kylix does not known UNIX define -{$IFDEF LINUX} - {$IFNDEF UNIX} - {$DEFINE UNIX} - {$ENDIF} -{$ENDIF} - -{$IFDEF FPC} - {$MODE DELPHI} - {$IFDEF MSWINDOWS} - {$ASMMODE intel} - {$ENDIF} - {define working mode w/o LIBC for fpc} - {$DEFINE NO_LIBC} -{$ENDIF} -{$Q-} -{$H+} -{$M+} - -unit synaser; - -interface - -uses -{$IFNDEF MSWINDOWS} - {$IFNDEF NO_LIBC} - Libc, - KernelIoctl, - {$ELSE} - termio, baseunix, unix, - {$ENDIF} - {$IFNDEF FPC} - Types, - {$ENDIF} -{$ELSE} - Windows, registry, - {$IFDEF FPC} - winver, - {$ENDIF} -{$ENDIF} - synafpc, - Classes, SysUtils, synautil; - -const - CR = #$0d; - LF = #$0a; - CRLF = CR + LF; - cSerialChunk = 8192; - - LockfileDirectory = '/var/lock'; {HGJ} - PortIsClosed = -1; {HGJ} - ErrAlreadyOwned = 9991; {HGJ} - ErrAlreadyInUse = 9992; {HGJ} - ErrWrongParameter = 9993; {HGJ} - ErrPortNotOpen = 9994; {HGJ} - ErrNoDeviceAnswer = 9995; {HGJ} - ErrMaxBuffer = 9996; - ErrTimeout = 9997; - ErrNotRead = 9998; - ErrFrame = 9999; - ErrOverrun = 10000; - ErrRxOver = 10001; - ErrRxParity = 10002; - ErrTxFull = 10003; - - dcb_Binary = $00000001; - dcb_ParityCheck = $00000002; - dcb_OutxCtsFlow = $00000004; - dcb_OutxDsrFlow = $00000008; - dcb_DtrControlMask = $00000030; - dcb_DtrControlDisable = $00000000; - dcb_DtrControlEnable = $00000010; - dcb_DtrControlHandshake = $00000020; - dcb_DsrSensivity = $00000040; - dcb_TXContinueOnXoff = $00000080; - dcb_OutX = $00000100; - dcb_InX = $00000200; - dcb_ErrorChar = $00000400; - dcb_NullStrip = $00000800; - dcb_RtsControlMask = $00003000; - dcb_RtsControlDisable = $00000000; - dcb_RtsControlEnable = $00001000; - dcb_RtsControlHandshake = $00002000; - dcb_RtsControlToggle = $00003000; - dcb_AbortOnError = $00004000; - dcb_Reserveds = $FFFF8000; - - {:stopbit value for 1 stopbit} - SB1 = 0; - {:stopbit value for 1.5 stopbit} - SB1andHalf = 1; - {:stopbit value for 2 stopbits} - SB2 = 2; - -{$IFNDEF MSWINDOWS} -const - INVALID_HANDLE_VALUE = THandle(-1); - CS7fix = $0000020; - -type - TDCB = record - DCBlength: DWORD; - BaudRate: DWORD; - Flags: Longint; - wReserved: Word; - XonLim: Word; - XoffLim: Word; - ByteSize: Byte; - Parity: Byte; - StopBits: Byte; - XonChar: CHAR; - XoffChar: CHAR; - ErrorChar: CHAR; - EofChar: CHAR; - EvtChar: CHAR; - wReserved1: Word; - end; - PDCB = ^TDCB; - -const -{$IFDEF UNIX} - {$IFDEF DARWIN} - MaxRates = 18; //MAC - {$ELSE} - MaxRates = 30; //UNIX - {$ENDIF} -{$ELSE} - MaxRates = 19; //WIN -{$ENDIF} - Rates: array[0..MaxRates, 0..1] of cardinal = - ( - (0, B0), - (50, B50), - (75, B75), - (110, B110), - (134, B134), - (150, B150), - (200, B200), - (300, B300), - (600, B600), - (1200, B1200), - (1800, B1800), - (2400, B2400), - (4800, B4800), - (9600, B9600), - (19200, B19200), - (38400, B38400), - (57600, B57600), - (115200, B115200), - (230400, B230400) -{$IFNDEF DARWIN} - ,(460800, B460800) - {$IFDEF UNIX} - ,(500000, B500000), - (576000, B576000), - (921600, B921600), - (1000000, B1000000), - (1152000, B1152000), - (1500000, B1500000), - (2000000, B2000000), - (2500000, B2500000), - (3000000, B3000000), - (3500000, B3500000), - (4000000, B4000000) - {$ENDIF} -{$ENDIF} - ); -{$ENDIF} - -{$IFDEF DARWIN} -const // From fcntl.h - O_SYNC = $0080; { synchronous writes } -{$ENDIF} - -const - sOK = 0; - sErr = integer(-1); - -type - - {:Possible status event types for @link(THookSerialStatus)} - THookSerialReason = ( - HR_SerialClose, - HR_Connect, - HR_CanRead, - HR_CanWrite, - HR_ReadCount, - HR_WriteCount, - HR_Wait - ); - - {:procedural prototype for status event hooking} - THookSerialStatus = procedure(Sender: TObject; Reason: THookSerialReason; - const Value: string) of object; - - {:@abstract(Exception type for SynaSer errors)} - ESynaSerError = class(Exception) - public - ErrorCode: integer; - ErrorMessage: string; - end; - - {:@abstract(Main class implementing all communication routines)} - TBlockSerial = class(TObject) - protected - FOnStatus: THookSerialStatus; - Fhandle: THandle; - FTag: integer; - FDevice: string; - FLastError: integer; - FLastErrorDesc: string; - FBuffer: AnsiString; - FRaiseExcept: boolean; - FRecvBuffer: integer; - FSendBuffer: integer; - FModemWord: integer; - FRTSToggle: Boolean; - FDeadlockTimeout: integer; - FInstanceActive: boolean; {HGJ} - FTestDSR: Boolean; - FTestCTS: Boolean; - FLastCR: Boolean; - FLastLF: Boolean; - FMaxLineLength: Integer; - FLinuxLock: Boolean; - FMaxSendBandwidth: Integer; - FNextSend: LongWord; - FMaxRecvBandwidth: Integer; - FNextRecv: LongWord; - FConvertLineEnd: Boolean; - FATResult: Boolean; - FAtTimeout: integer; - FInterPacketTimeout: Boolean; - FComNr: integer; -{$IFDEF MSWINDOWS} - FPortAddr: Word; - function CanEvent(Event: dword; Timeout: integer): boolean; - procedure DecodeCommError(Error: DWord); virtual; - function GetPortAddr: Word; virtual; - function ReadTxEmpty(PortAddr: Word): Boolean; virtual; -{$ENDIF} - procedure SetSizeRecvBuffer(size: integer); virtual; - function GetDSR: Boolean; virtual; - procedure SetDTRF(Value: Boolean); virtual; - function GetCTS: Boolean; virtual; - procedure SetRTSF(Value: Boolean); virtual; - function GetCarrier: Boolean; virtual; - function GetRing: Boolean; virtual; - procedure DoStatus(Reason: THookSerialReason; const Value: string); virtual; - procedure GetComNr(Value: string); virtual; - function PreTestFailing: boolean; virtual;{HGJ} - function TestCtrlLine: Boolean; virtual; -{$IFDEF UNIX} - procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual; - procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual; - function ReadLockfile: integer; virtual; - function LockfileName: String; virtual; - procedure CreateLockfile(PidNr: integer); virtual; -{$ENDIF} - procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); virtual; - procedure SetBandwidth(Value: Integer); virtual; - public - {: data Control Block with communication parameters. Usable only when you - need to call API directly.} - DCB: Tdcb; -{$IFDEF UNIX} - TermiosStruc: termios; -{$ENDIF} - {:Object constructor.} - constructor Create; - {:Object destructor.} - destructor Destroy; override; - - {:Returns a string containing the version number of the library.} - class function GetVersion: string; virtual; - - {:Destroy handle in use. It close connection to serial port.} - procedure CloseSocket; virtual; - - {:Reconfigure communication parameters on the fly. You must be connected to - port before! - @param(baud Define connection speed. Baud rate can be from 50 to 4000000 - bits per second. (it depends on your hardware!)) - @param(bits Number of bits in communication.) - @param(parity Define communication parity (N - None, O - Odd, E - Even, M - Mark or S - Space).) - @param(stop Define number of stopbits. Use constants @link(SB1), - @link(SB1andHalf) and @link(SB2).) - @param(softflow Enable XON/XOFF handshake.) - @param(hardflow Enable CTS/RTS handshake.)} - procedure Config(baud, bits: integer; parity: char; stop: integer; - softflow, hardflow: boolean); virtual; - - {:Connects to the port indicated by comport. Comport can be used in Windows - style (COM2), or in Linux style (/dev/ttyS1). When you use windows style - in Linux, then it will be converted to Linux name. And vice versa! However - you can specify any device name! (other device names then standart is not - converted!) - - After successfull connection the DTR signal is set (if you not set hardware - handshake, then the RTS signal is set, too!) - - Connection parameters is predefined by your system configuration. If you - need use another parameters, then you can use Config method after. - Notes: - - - Remember, the commonly used serial Laplink cable does not support - hardware handshake. - - - Before setting any handshake you must be sure that it is supported by - your hardware. - - - Some serial devices are slow. In some cases you must wait up to a few - seconds after connection for the device to respond. - - - when you connect to a modem device, then is best to test it by an empty - AT command. (call ATCommand('AT'))} - procedure Connect(comport: string); virtual; - - {:Set communication parameters from the DCB structure (the DCB structure is - simulated under Linux).} - procedure SetCommState; virtual; - - {:Read communication parameters into the DCB structure (DCB structure is - simulated under Linux).} - procedure GetCommState; virtual; - - {:Sends Length bytes of data from Buffer through the connected port.} - function SendBuffer(buffer: pointer; length: integer): integer; virtual; - - {:One data BYTE is sent.} - procedure SendByte(data: byte); virtual; - - {:Send the string in the data parameter. No terminator is appended by this - method. If you need to send a string with CR/LF terminator, you must append - the CR/LF characters to the data string! - - Since no terminator is appended, you can use this function for sending - binary data too.} - procedure SendString(data: AnsiString); virtual; - - {:send four bytes as integer.} - procedure SendInteger(Data: integer); virtual; - - {:send data as one block. Each block begins with integer value with Length - of block.} - procedure SendBlock(const Data: AnsiString); virtual; - - {:send content of stream from current position} - procedure SendStreamRaw(const Stream: TStream); virtual; - - {:send content of stream as block. see @link(SendBlock)} - procedure SendStream(const Stream: TStream); virtual; - - {:send content of stream as block, but this is compatioble with Indy library. - (it have swapped lenght of block). See @link(SendStream)} - procedure SendStreamIndy(const Stream: TStream); virtual; - - {:Waits until the allocated buffer is filled by received data. Returns number - of data bytes received, which equals to the Length value under normal - operation. If it is not equal, the communication channel is possibly broken. - - This method not using any internal buffering, like all others receiving - methods. You cannot freely combine this method with all others receiving - methods!} - function RecvBuffer(buffer: pointer; length: integer): integer; virtual; - - {:Method waits until data is received. If no data is received within - the Timeout (in milliseconds) period, @link(LastError) is set to - @link(ErrTimeout). This method is used to read any amount of data - (e. g. 1MB), and may be freely combined with all receviving methods what - have Timeout parameter, like the @link(RecvString), @link(RecvByte) or - @link(RecvTerminated) methods.} - function RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer; virtual; - - {:It is like recvBufferEx, but data is readed to dynamicly allocated binary - string.} - function RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; virtual; - - {:Read all available data and return it in the function result string. This - function may be combined with @link(RecvString), @link(RecvByte) or related - methods.} - function RecvPacket(Timeout: Integer): AnsiString; virtual; - - {:Waits until one data byte is received which is returned as the function - result. If no data is received within the Timeout (in milliseconds) period, - @link(LastError) is set to @link(ErrTimeout).} - function RecvByte(timeout: integer): byte; virtual; - - {:This method waits until a terminated data string is received. This string - is terminated by the Terminator string. The resulting string is returned - without this termination string! If no data is received within the Timeout - (in milliseconds) period, @link(LastError) is set to @link(ErrTimeout).} - function RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; virtual; - - {:This method waits until a terminated data string is received. The string - is terminated by a CR/LF sequence. The resulting string is returned without - the terminator (CR/LF)! If no data is received within the Timeout (in - milliseconds) period, @link(LastError) is set to @link(ErrTimeout). - - If @link(ConvertLineEnd) is used, then the CR/LF sequence may not be exactly - CR/LF. See the description of @link(ConvertLineEnd). - - This method serves for line protocol implementation and uses its own - buffers to maximize performance. Therefore do NOT use this method with the - @link(RecvBuffer) method to receive data as it may cause data loss.} - function Recvstring(timeout: integer): AnsiString; virtual; - - {:Waits until four data bytes are received which is returned as the function - integer result. If no data is received within the Timeout (in milliseconds) period, - @link(LastError) is set to @link(ErrTimeout).} - function RecvInteger(Timeout: Integer): Integer; virtual; - - {:Waits until one data block is received. See @link(sendblock). If no data - is received within the Timeout (in milliseconds) period, @link(LastError) - is set to @link(ErrTimeout).} - function RecvBlock(Timeout: Integer): AnsiString; virtual; - - {:Receive all data to stream, until some error occured. (for example timeout)} - procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual; - - {:receive requested count of bytes to stream} - procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); virtual; - - {:receive block of data to stream. (Data can be sended by @link(sendstream)} - procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual; - - {:receive block of data to stream. (Data can be sended by @link(sendstreamIndy)} - procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual; - - {:Returns the number of received bytes waiting for reading. 0 is returned - when there is no data waiting.} - function WaitingData: integer; virtual; - - {:Same as @link(WaitingData), but in respect to data in the internal - @link(LineBuffer).} - function WaitingDataEx: integer; virtual; - - {:Returns the number of bytes waiting to be sent in the output buffer. - 0 is returned when the output buffer is empty.} - function SendingData: integer; virtual; - - {:Enable or disable RTS driven communication (half-duplex). It can be used - to communicate with RS485 converters, or other special equipment. If you - enable this feature, the system automatically controls the RTS signal. - - Notes: - - - On Windows NT (or higher) ir RTS signal driven by system driver. - - - On Win9x family is used special code for waiting until last byte is - sended from your UART. - - - On Linux you must have kernel 2.1 or higher!} - procedure EnableRTSToggle(value: boolean); virtual; - - {:Waits until all data to is sent and buffers are emptied. - Warning: On Windows systems is this method returns when all buffers are - flushed to the serial port controller, before the last byte is sent!} - procedure Flush; virtual; - - {:Unconditionally empty all buffers. It is good when you need to interrupt - communication and for cleanups.} - procedure Purge; virtual; - - {:Returns @True, if you can from read any data from the port. Status is - tested for a period of time given by the Timeout parameter (in milliseconds). - If the value of the Timeout parameter is 0, the status is tested only once - and the function returns immediately. If the value of the Timeout parameter - is set to -1, the function returns only after it detects data on the port - (this may cause the process to hang).} - function CanRead(Timeout: integer): boolean; virtual; - - {:Returns @True, if you can write any data to the port (this function is not - sending the contents of the buffer). Status is tested for a period of time - given by the Timeout parameter (in milliseconds). If the value of - the Timeout parameter is 0, the status is tested only once and the function - returns immediately. If the value of the Timeout parameter is set to -1, - the function returns only after it detects that it can write data to - the port (this may cause the process to hang).} - function CanWrite(Timeout: integer): boolean; virtual; - - {:Same as @link(CanRead), but the test is against data in the internal - @link(LineBuffer) too.} - function CanReadEx(Timeout: integer): boolean; virtual; - - {:Returns the status word of the modem. Decoding the status word could yield - the status of carrier detect signaland other signals. This method is used - internally by the modem status reading properties. You usually do not need - to call this method directly.} - function ModemStatus: integer; virtual; - - {:Send a break signal to the communication device for Duration milliseconds.} - procedure SetBreak(Duration: integer); virtual; - - {:This function is designed to send AT commands to the modem. The AT command - is sent in the Value parameter and the response is returned in the function - return value (may contain multiple lines!). - If the AT command is processed successfully (modem returns OK), then the - @link(ATResult) property is set to True. - - This function is designed only for AT commands that return OK or ERROR - response! To call connection commands the @link(ATConnect) method. - Remember, when you connect to a modem device, it is in AT command mode. - Now you can send AT commands to the modem. If you need to transfer data to - the modem on the other side of the line, you must first switch to data mode - using the @link(ATConnect) method.} - function ATCommand(value: AnsiString): AnsiString; virtual; - - {:This function is used to send connect type AT commands to the modem. It is - for commands to switch to connected state. (ATD, ATA, ATO,...) - It sends the AT command in the Value parameter and returns the modem's - response (may be multiple lines - usually with connection parameters info). - If the AT command is processed successfully (the modem returns CONNECT), - then the ATResult property is set to @True. - - This function is designed only for AT commands which respond by CONNECT, - BUSY, NO DIALTONE NO CARRIER or ERROR. For other AT commands use the - @link(ATCommand) method. - - The connect timeout is 90*@link(ATTimeout). If this command is successful - (@link(ATresult) is @true), then the modem is in data state. When you now - send or receive some data, it is not to or from your modem, but from the - modem on other side of the line. Now you can transfer your data. - If the connection attempt failed (@link(ATResult) is @False), then the - modem is still in AT command mode.} - function ATConnect(value: AnsiString): AnsiString; virtual; - - {:If you "manually" call API functions, forward their return code in - the SerialResult parameter to this function, which evaluates it and sets - @link(LastError) and @link(LastErrorDesc).} - function SerialCheck(SerialResult: integer): integer; virtual; - - {:If @link(Lasterror) is not 0 and exceptions are enabled, then this procedure - raises an exception. This method is used internally. You may need it only - in special cases.} - procedure ExceptCheck; virtual; - - {:Set Synaser to error state with ErrNumber code. Usually used by internal - routines.} - procedure SetSynaError(ErrNumber: integer); virtual; - - {:Raise Synaser error with ErrNumber code. Usually used by internal routines.} - procedure RaiseSynaError(ErrNumber: integer); virtual; -{$IFDEF UNIX} - function cpomComportAccessible: boolean; virtual;{HGJ} - procedure cpomReleaseComport; virtual; {HGJ} -{$ENDIF} - {:True device name of currently used port} - property Device: string read FDevice; - - {:Error code of last operation. Value is defined by the host operating - system, but value 0 is always OK.} - property LastError: integer read FLastError; - - {:Human readable description of LastError code.} - property LastErrorDesc: string read FLastErrorDesc; - - {:Indicates if the last @link(ATCommand) or @link(ATConnect) method was successful} - property ATResult: Boolean read FATResult; - - {:Read the value of the RTS signal.} - property RTS: Boolean write SetRTSF; - - {:Indicates the presence of the CTS signal} - property CTS: boolean read GetCTS; - - {:Use this property to set the value of the DTR signal.} - property DTR: Boolean write SetDTRF; - - {:Exposes the status of the DSR signal.} - property DSR: boolean read GetDSR; - - {:Indicates the presence of the Carrier signal} - property Carrier: boolean read GetCarrier; - - {:Reflects the status of the Ring signal.} - property Ring: boolean read GetRing; - - {:indicates if this instance of SynaSer is active. (Connected to some port)} - property InstanceActive: boolean read FInstanceActive; {HGJ} - - {:Defines maximum bandwidth for all sending operations in bytes per second. - If this value is set to 0 (default), bandwidth limitation is not used.} - property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth; - - {:Defines maximum bandwidth for all receiving operations in bytes per second. - If this value is set to 0 (default), bandwidth limitation is not used.} - property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth; - - {:Defines maximum bandwidth for all sending and receiving operations - in bytes per second. If this value is set to 0 (default), bandwidth - limitation is not used.} - property MaxBandwidth: Integer Write SetBandwidth; - - {:Size of the Windows internal receive buffer. Default value is usually - 4096 bytes. Note: Valid only in Windows versions!} - property SizeRecvBuffer: integer read FRecvBuffer write SetSizeRecvBuffer; - published - {:Returns the descriptive text associated with ErrorCode. You need this - method only in special cases. Description of LastError is now accessible - through the LastErrorDesc property.} - class function GetErrorDesc(ErrorCode: integer): string; - - {:Freely usable property} - property Tag: integer read FTag write FTag; - - {:Contains the handle of the open communication port. - You may need this value to directly call communication functions outside - SynaSer.} - property Handle: THandle read Fhandle write FHandle; - - {:Internally used read buffer.} - property LineBuffer: AnsiString read FBuffer write FBuffer; - - {:If @true, communication errors raise exceptions. If @false (default), only - the @link(LastError) value is set.} - property RaiseExcept: boolean read FRaiseExcept write FRaiseExcept; - - {:This event is triggered when the communication status changes. It can be - used to monitor communication status.} - property OnStatus: THookSerialStatus read FOnStatus write FOnStatus; - - {:If you set this property to @true, then the value of the DSR signal - is tested before every data transfer. It can be used to detect the presence - of a communications device.} - property TestDSR: boolean read FTestDSR write FTestDSR; - - {:If you set this property to @true, then the value of the CTS signal - is tested before every data transfer. It can be used to detect the presence - of a communications device. Warning: This property cannot be used if you - need hardware handshake!} - property TestCTS: boolean read FTestCTS write FTestCTS; - - {:Use this property you to limit the maximum size of LineBuffer - (as a protection against unlimited memory allocation for LineBuffer). - Default value is 0 - no limit.} - property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength; - - {:This timeout value is used as deadlock protection when trying to send data - to (or receive data from) a device that stopped communicating during data - transmission (e.g. by physically disconnecting the device). - The timeout value is in milliseconds. The default value is 30,000 (30 seconds).} - property DeadlockTimeout: Integer read FDeadlockTimeout Write FDeadlockTimeout; - - {:If set to @true (default value), port locking is enabled (under Linux only). - WARNING: To use this feature, the application must run by a user with full - permission to the /var/lock directory!} - property LinuxLock: Boolean read FLinuxLock write FLinuxLock; - - {:Indicates if non-standard line terminators should be converted to a CR/LF pair - (standard DOS line terminator). If @TRUE, line terminators CR, single LF - or LF/CR are converted to CR/LF. Defaults to @FALSE. - This property has effect only on the behavior of the RecvString method.} - property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd; - - {:Timeout for AT modem based operations} - property AtTimeout: integer read FAtTimeout Write FAtTimeout; - - {:If @true (default), then all timeouts is timeout between two characters. - If @False, then timeout is overall for whoole reading operation.} - property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout; - end; - -{:Returns list of existing computer serial ports. Working properly only in Windows!} -function GetSerialPortNames: string; - -implementation - -constructor TBlockSerial.Create; -begin - inherited create; - FRaiseExcept := false; - FHandle := INVALID_HANDLE_VALUE; - FDevice := ''; - FComNr:= PortIsClosed; {HGJ} - FInstanceActive:= false; {HGJ} - Fbuffer := ''; - FRTSToggle := False; - FMaxLineLength := 0; - FTestDSR := False; - FTestCTS := False; - FDeadlockTimeout := 30000; - FLinuxLock := True; - FMaxSendBandwidth := 0; - FNextSend := 0; - FMaxRecvBandwidth := 0; - FNextRecv := 0; - FConvertLineEnd := False; - SetSynaError(sOK); - FRecvBuffer := 4096; - FLastCR := False; - FLastLF := False; - FAtTimeout := 1000; - FInterPacketTimeout := True; -end; - -destructor TBlockSerial.Destroy; -begin - CloseSocket; - inherited destroy; -end; - -class function TBlockSerial.GetVersion: string; -begin - Result := 'SynaSer 7.5.0'; -end; - -procedure TBlockSerial.CloseSocket; -begin - if Fhandle <> INVALID_HANDLE_VALUE then - begin - Purge; - RTS := False; - DTR := False; - FileClose(FHandle); - end; - if InstanceActive then - begin - {$IFDEF UNIX} - if FLinuxLock then - cpomReleaseComport; - {$ENDIF} - FInstanceActive:= false - end; - Fhandle := INVALID_HANDLE_VALUE; - FComNr:= PortIsClosed; - SetSynaError(sOK); - DoStatus(HR_SerialClose, FDevice); -end; - -{$IFDEF MSWINDOWS} -function TBlockSerial.GetPortAddr: Word; -begin - Result := 0; - if Win32Platform <> VER_PLATFORM_WIN32_NT then - begin - EscapeCommFunction(FHandle, 10); - asm - MOV @Result, DX; - end; - end; -end; - -function TBlockSerial.ReadTxEmpty(PortAddr: Word): Boolean; -begin - Result := True; - if Win32Platform <> VER_PLATFORM_WIN32_NT then - begin - asm - MOV DX, PortAddr; - ADD DX, 5; - IN AL, DX; - AND AL, $40; - JZ @K; - MOV AL,1; - @K: MOV @Result, AL; - end; - end; -end; -{$ENDIF} - -procedure TBlockSerial.GetComNr(Value: string); -begin - FComNr := PortIsClosed; - if pos('COM', uppercase(Value)) = 1 then - FComNr := StrToIntdef(copy(Value, 4, Length(Value) - 3), PortIsClosed + 1) - 1; - if pos('/DEV/TTYS', uppercase(Value)) = 1 then - FComNr := StrToIntdef(copy(Value, 10, Length(Value) - 9), PortIsClosed - 1); -end; - -procedure TBlockSerial.SetBandwidth(Value: Integer); -begin - MaxSendBandwidth := Value; - MaxRecvBandwidth := Value; -end; - -procedure TBlockSerial.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); -var - x: LongWord; - y: LongWord; -begin - if MaxB > 0 then - begin - y := GetTick; - if Next > y then - begin - x := Next - y; - if x > 0 then - begin - DoStatus(HR_Wait, IntToStr(x)); - sleep(x); - end; - end; - Next := GetTick + Trunc((Length / MaxB) * 1000); - end; -end; - -procedure TBlockSerial.Config(baud, bits: integer; parity: char; stop: integer; - softflow, hardflow: boolean); -begin - FillChar(dcb, SizeOf(dcb), 0); - GetCommState; - dcb.DCBlength := SizeOf(dcb); - dcb.BaudRate := baud; - dcb.ByteSize := bits; - case parity of - 'N', 'n': dcb.parity := 0; - 'O', 'o': dcb.parity := 1; - 'E', 'e': dcb.parity := 2; - 'M', 'm': dcb.parity := 3; - 'S', 's': dcb.parity := 4; - end; - dcb.StopBits := stop; - dcb.XonChar := #17; - dcb.XoffChar := #19; - dcb.XonLim := FRecvBuffer div 4; - dcb.XoffLim := FRecvBuffer div 4; - dcb.Flags := dcb_Binary; - if softflow then - dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX; - if hardflow then - dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake - else - dcb.Flags := dcb.Flags or dcb_RtsControlEnable; - dcb.Flags := dcb.Flags or dcb_DtrControlEnable; - if dcb.Parity > 0 then - dcb.Flags := dcb.Flags or dcb_ParityCheck; - SetCommState; -end; - -procedure TBlockSerial.Connect(comport: string); -{$IFDEF MSWINDOWS} -var - CommTimeouts: TCommTimeouts; -{$ENDIF} -begin - // Is this TBlockSerial Instance already busy? - if InstanceActive then {HGJ} - begin {HGJ} - RaiseSynaError(ErrAlreadyInUse); - Exit; {HGJ} - end; {HGJ} - FBuffer := ''; - FDevice := comport; - GetComNr(comport); -{$IFDEF MSWINDOWS} - SetLastError (sOK); -{$ELSE} - {$IFNDEF FPC} - SetLastError (sOK); - {$ELSE} - fpSetErrno(sOK); - {$ENDIF} -{$ENDIF} -{$IFNDEF MSWINDOWS} - if FComNr <> PortIsClosed then - FDevice := '/dev/ttyS' + IntToStr(FComNr); - // Comport already owned by another process? {HGJ} - if FLinuxLock then - if not cpomComportAccessible then - begin - RaiseSynaError(ErrAlreadyOwned); - Exit; - end; -{$IFNDEF FPC} - FHandle := THandle(Libc.open(pchar(FDevice), O_RDWR or O_SYNC)); -{$ELSE} - FHandle := THandle(fpOpen(FDevice, O_RDWR or O_SYNC)); -{$ENDIF} - if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms! - SerialCheck(-1) - else - SerialCheck(0); - {$IFDEF UNIX} - if FLastError <> sOK then - if FLinuxLock then - cpomReleaseComport; - {$ENDIF} - ExceptCheck; - if FLastError <> sOK then - Exit; -{$ELSE} - if FComNr <> PortIsClosed then - FDevice := '\\.\COM' + IntToStr(FComNr + 1); - FHandle := THandle(CreateFile(PChar(FDevice), GENERIC_READ or GENERIC_WRITE, - 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0)); - if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms! - SerialCheck(-1) - else - SerialCheck(0); - ExceptCheck; - if FLastError <> sOK then - Exit; - SetCommMask(FHandle, 0); - SetupComm(Fhandle, FRecvBuffer, 0); - CommTimeOuts.ReadIntervalTimeout := MAXWORD; - CommTimeOuts.ReadTotalTimeoutMultiplier := 0; - CommTimeOuts.ReadTotalTimeoutConstant := 0; - CommTimeOuts.WriteTotalTimeoutMultiplier := 0; - CommTimeOuts.WriteTotalTimeoutConstant := 0; - SetCommTimeOuts(FHandle, CommTimeOuts); - FPortAddr := GetPortAddr; -{$ENDIF} - SetSynaError(sOK); - if not TestCtrlLine then {HGJ} - begin - SetSynaError(ErrNoDeviceAnswer); - FileClose(FHandle); {HGJ} - {$IFDEF UNIX} - if FLinuxLock then - cpomReleaseComport; {HGJ} - {$ENDIF} {HGJ} - Fhandle := INVALID_HANDLE_VALUE; {HGJ} - FComNr:= PortIsClosed; {HGJ} - end - else - begin - FInstanceActive:= True; - RTS := True; - DTR := True; - Purge; - end; - ExceptCheck; - DoStatus(HR_Connect, FDevice); -end; - -function TBlockSerial.SendBuffer(buffer: pointer; length: integer): integer; -{$IFDEF MSWINDOWS} -var - Overlapped: TOverlapped; - x, y, Err: DWord; -{$ENDIF} -begin - Result := 0; - if PreTestFailing then {HGJ} - Exit; {HGJ} - LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); - if FRTSToggle then - begin - Flush; - RTS := True; - end; -{$IFNDEF MSWINDOWS} - result := FileWrite(Fhandle, Buffer^, Length); - serialcheck(result); -{$ELSE} - FillChar(Overlapped, Sizeof(Overlapped), 0); - SetSynaError(sOK); - y := 0; - if not WriteFile(FHandle, Buffer^, Length, DWord(Result), @Overlapped) then - y := GetLastError; - if y = ERROR_IO_PENDING then - begin - x := WaitForSingleObject(FHandle, FDeadlockTimeout); - if x = WAIT_TIMEOUT then - begin - PurgeComm(FHandle, PURGE_TXABORT); - SetSynaError(ErrTimeout); - end; - GetOverlappedResult(FHandle, Overlapped, Dword(Result), False); - end - else - SetSynaError(y); - ClearCommError(FHandle, err, nil); - if err <> 0 then - DecodeCommError(err); -{$ENDIF} - if FRTSToggle then - begin - Flush; - CanWrite(255); - RTS := False; - end; - ExceptCheck; - DoStatus(HR_WriteCount, IntToStr(Result)); -end; - -procedure TBlockSerial.SendByte(data: byte); -begin - SendBuffer(@Data, 1); -end; - -procedure TBlockSerial.SendString(data: AnsiString); -begin - SendBuffer(Pointer(Data), Length(Data)); -end; - -procedure TBlockSerial.SendInteger(Data: integer); -begin - SendBuffer(@data, SizeOf(Data)); -end; - -procedure TBlockSerial.SendBlock(const Data: AnsiString); -begin - SendInteger(Length(data)); - SendString(Data); -end; - -procedure TBlockSerial.SendStreamRaw(const Stream: TStream); -var - si: integer; - x, y, yr: integer; - s: AnsiString; -begin - si := Stream.Size - Stream.Position; - x := 0; - while x < si do - begin - y := si - x; - if y > cSerialChunk then - y := cSerialChunk; - Setlength(s, y); - yr := Stream.read(PAnsiChar(s)^, y); - if yr > 0 then - begin - SetLength(s, yr); - SendString(s); - Inc(x, yr); - end - else - break; - end; -end; - -procedure TBlockSerial.SendStreamIndy(const Stream: TStream); -var - si: integer; -begin - si := Stream.Size - Stream.Position; - si := Swapbytes(si); - SendInteger(si); - SendStreamRaw(Stream); -end; - -procedure TBlockSerial.SendStream(const Stream: TStream); -var - si: integer; -begin - si := Stream.Size - Stream.Position; - SendInteger(si); - SendStreamRaw(Stream); -end; - -function TBlockSerial.RecvBuffer(buffer: pointer; length: integer): integer; -{$IFNDEF MSWINDOWS} -begin - Result := 0; - if PreTestFailing then {HGJ} - Exit; {HGJ} - LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); - result := FileRead(FHandle, Buffer^, length); - serialcheck(result); -{$ELSE} -var - Overlapped: TOverlapped; - x, y, Err: DWord; -begin - Result := 0; - if PreTestFailing then {HGJ} - Exit; {HGJ} - LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); - FillChar(Overlapped, Sizeof(Overlapped), 0); - SetSynaError(sOK); - y := 0; - if not ReadFile(FHandle, Buffer^, length, Dword(Result), @Overlapped) then - y := GetLastError; - if y = ERROR_IO_PENDING then - begin - x := WaitForSingleObject(FHandle, FDeadlockTimeout); - if x = WAIT_TIMEOUT then - begin - PurgeComm(FHandle, PURGE_RXABORT); - SetSynaError(ErrTimeout); - end; - GetOverlappedResult(FHandle, Overlapped, Dword(Result), False); - end - else - SetSynaError(y); - ClearCommError(FHandle, err, nil); - if err <> 0 then - DecodeCommError(err); -{$ENDIF} - ExceptCheck; - DoStatus(HR_ReadCount, IntToStr(Result)); -end; - -function TBlockSerial.RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer; -var - s: AnsiString; - rl, l: integer; - ti: LongWord; -begin - Result := 0; - if PreTestFailing then {HGJ} - Exit; {HGJ} - SetSynaError(sOK); - rl := 0; - repeat - ti := GetTick; - s := RecvPacket(Timeout); - l := System.Length(s); - if (rl + l) > Length then - l := Length - rl; - Move(Pointer(s)^, IncPoint(Buffer, rl)^, l); - rl := rl + l; - if FLastError <> sOK then - Break; - if rl >= Length then - Break; - if not FInterPacketTimeout then - begin - Timeout := Timeout - integer(TickDelta(ti, GetTick)); - if Timeout <= 0 then - begin - SetSynaError(ErrTimeout); - Break; - end; - end; - until False; - delete(s, 1, l); - FBuffer := s; - Result := rl; -end; - -function TBlockSerial.RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; -var - x: integer; -begin - Result := ''; - if PreTestFailing then {HGJ} - Exit; {HGJ} - SetSynaError(sOK); - if Length > 0 then - begin - Setlength(Result, Length); - x := RecvBufferEx(PAnsiChar(Result), Length , Timeout); - if FLastError = sOK then - SetLength(Result, x) - else - Result := ''; - end; -end; - -function TBlockSerial.RecvPacket(Timeout: Integer): AnsiString; -var - x: integer; -begin - Result := ''; - if PreTestFailing then {HGJ} - Exit; {HGJ} - SetSynaError(sOK); - if FBuffer <> '' then - begin - Result := FBuffer; - FBuffer := ''; - end - else - begin - //not drain CPU on large downloads... - Sleep(0); - x := WaitingData; - if x > 0 then - begin - SetLength(Result, x); - x := RecvBuffer(Pointer(Result), x); - if x >= 0 then - SetLength(Result, x); - end - else - begin - if CanRead(Timeout) then - begin - x := WaitingData; - if x = 0 then - SetSynaError(ErrTimeout); - if x > 0 then - begin - SetLength(Result, x); - x := RecvBuffer(Pointer(Result), x); - if x >= 0 then - SetLength(Result, x); - end; - end - else - SetSynaError(ErrTimeout); - end; - end; - ExceptCheck; -end; - - -function TBlockSerial.RecvByte(timeout: integer): byte; -begin - Result := 0; - if PreTestFailing then {HGJ} - Exit; {HGJ} - SetSynaError(sOK); - if FBuffer = '' then - FBuffer := RecvPacket(Timeout); - if (FLastError = sOK) and (FBuffer <> '') then - begin - Result := Ord(FBuffer[1]); - System.Delete(FBuffer, 1, 1); - end; - ExceptCheck; -end; - -function TBlockSerial.RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; -var - x: Integer; - s: AnsiString; - l: Integer; - CorCRLF: Boolean; - t: ansistring; - tl: integer; - ti: LongWord; -begin - Result := ''; - if PreTestFailing then {HGJ} - Exit; {HGJ} - SetSynaError(sOK); - l := system.Length(Terminator); - if l = 0 then - Exit; - tl := l; - CorCRLF := FConvertLineEnd and (Terminator = CRLF); - s := ''; - x := 0; - repeat - ti := GetTick; - //get rest of FBuffer or incomming new data... - s := s + RecvPacket(Timeout); - if FLastError <> sOK then - Break; - x := 0; - if Length(s) > 0 then - if CorCRLF then - begin - if FLastCR and (s[1] = LF) then - Delete(s, 1, 1); - if FLastLF and (s[1] = CR) then - Delete(s, 1, 1); - FLastCR := False; - FLastLF := False; - t := ''; - x := PosCRLF(s, t); - tl := system.Length(t); - if t = CR then - FLastCR := True; - if t = LF then - FLastLF := True; - end - else - begin - x := pos(Terminator, s); - tl := l; - end; - if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then - begin - SetSynaError(ErrMaxBuffer); - Break; - end; - if x > 0 then - Break; - if not FInterPacketTimeout then - begin - Timeout := Timeout - integer(TickDelta(ti, GetTick)); - if Timeout <= 0 then - begin - SetSynaError(ErrTimeout); - Break; - end; - end; - until False; - if x > 0 then - begin - Result := Copy(s, 1, x - 1); - System.Delete(s, 1, x + tl - 1); - end; - FBuffer := s; - ExceptCheck; -end; - - -function TBlockSerial.RecvString(Timeout: Integer): AnsiString; -var - s: AnsiString; -begin - Result := ''; - s := RecvTerminated(Timeout, #13 + #10); - if FLastError = sOK then - Result := s; -end; - -function TBlockSerial.RecvInteger(Timeout: Integer): Integer; -var - s: AnsiString; -begin - Result := 0; - s := RecvBufferStr(4, Timeout); - if FLastError = 0 then - Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536; -end; - -function TBlockSerial.RecvBlock(Timeout: Integer): AnsiString; -var - x: integer; -begin - Result := ''; - x := RecvInteger(Timeout); - if FLastError = 0 then - Result := RecvBufferStr(x, Timeout); -end; - -procedure TBlockSerial.RecvStreamRaw(const Stream: TStream; Timeout: Integer); -var - s: AnsiString; -begin - repeat - s := RecvPacket(Timeout); - if FLastError = 0 then - WriteStrToStream(Stream, s); - until FLastError <> 0; -end; - -procedure TBlockSerial.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); -var - s: AnsiString; - n: integer; -begin - for n := 1 to (Size div cSerialChunk) do - begin - s := RecvBufferStr(cSerialChunk, Timeout); - if FLastError <> 0 then - Exit; - Stream.Write(PAnsichar(s)^, cSerialChunk); - end; - n := Size mod cSerialChunk; - if n > 0 then - begin - s := RecvBufferStr(n, Timeout); - if FLastError <> 0 then - Exit; - Stream.Write(PAnsichar(s)^, n); - end; -end; - -procedure TBlockSerial.RecvStreamIndy(const Stream: TStream; Timeout: Integer); -var - x: integer; -begin - x := RecvInteger(Timeout); - x := SwapBytes(x); - if FLastError = 0 then - RecvStreamSize(Stream, Timeout, x); -end; - -procedure TBlockSerial.RecvStream(const Stream: TStream; Timeout: Integer); -var - x: integer; -begin - x := RecvInteger(Timeout); - if FLastError = 0 then - RecvStreamSize(Stream, Timeout, x); -end; - -{$IFNDEF MSWINDOWS} -function TBlockSerial.WaitingData: integer; -begin -{$IFNDEF FPC} - serialcheck(ioctl(FHandle, FIONREAD, @result)); -{$ELSE} - serialcheck(fpIoctl(FHandle, FIONREAD, @result)); -{$ENDIF} - if FLastError <> 0 then - Result := 0; - ExceptCheck; -end; -{$ELSE} -function TBlockSerial.WaitingData: integer; -var - stat: TComStat; - err: DWORD; -begin - if ClearCommError(FHandle, err, @stat) then - begin - SetSynaError(sOK); - Result := stat.cbInQue; - end - else - begin - SerialCheck(sErr); - Result := 0; - end; - ExceptCheck; -end; -{$ENDIF} - -function TBlockSerial.WaitingDataEx: integer; -begin - if FBuffer <> '' then - Result := Length(FBuffer) - else - Result := Waitingdata; -end; - -{$IFNDEF MSWINDOWS} -function TBlockSerial.SendingData: integer; -begin - SetSynaError(sOK); - Result := 0; -end; -{$ELSE} -function TBlockSerial.SendingData: integer; -var - stat: TComStat; - err: DWORD; -begin - SetSynaError(sOK); - if not ClearCommError(FHandle, err, @stat) then - serialcheck(sErr); - ExceptCheck; - result := stat.cbOutQue; -end; -{$ENDIF} - -{$IFNDEF MSWINDOWS} -procedure TBlockSerial.DcbToTermios(const dcb: TDCB; var term: termios); -var - n: integer; - x: cardinal; -begin - //others - cfmakeraw(term); - term.c_cflag := term.c_cflag or CREAD; - term.c_cflag := term.c_cflag or CLOCAL; - term.c_cflag := term.c_cflag or HUPCL; - //hardware handshake - if (dcb.flags and dcb_RtsControlHandshake) > 0 then - term.c_cflag := term.c_cflag or CRTSCTS - else - term.c_cflag := term.c_cflag and (not CRTSCTS); - //software handshake - if (dcb.flags and dcb_OutX) > 0 then - term.c_iflag := term.c_iflag or IXON or IXOFF or IXANY - else - term.c_iflag := term.c_iflag and (not (IXON or IXOFF or IXANY)); - //size of byte - term.c_cflag := term.c_cflag and (not CSIZE); - case dcb.bytesize of - 5: - term.c_cflag := term.c_cflag or CS5; - 6: - term.c_cflag := term.c_cflag or CS6; - 7: -{$IFDEF FPC} - term.c_cflag := term.c_cflag or CS7; -{$ELSE} - term.c_cflag := term.c_cflag or CS7fix; -{$ENDIF} - 8: - term.c_cflag := term.c_cflag or CS8; - end; - //parity - if (dcb.flags and dcb_ParityCheck) > 0 then - term.c_cflag := term.c_cflag or PARENB - else - term.c_cflag := term.c_cflag and (not PARENB); - case dcb.parity of - 1: //'O' - term.c_cflag := term.c_cflag or PARODD; - 2: //'E' - term.c_cflag := term.c_cflag and (not PARODD); - end; - //stop bits - if dcb.stopbits > 0 then - term.c_cflag := term.c_cflag or CSTOPB - else - term.c_cflag := term.c_cflag and (not CSTOPB); - //set baudrate; - x := 0; - for n := 0 to Maxrates do - if rates[n, 0] = dcb.BaudRate then - begin - x := rates[n, 1]; - break; - end; - cfsetospeed(term, x); - cfsetispeed(term, x); -end; - -procedure TBlockSerial.TermiosToDcb(const term: termios; var dcb: TDCB); -var - n: integer; - x: cardinal; -begin - //set baudrate; - dcb.baudrate := 0; - {$IFDEF FPC} - //why FPC not have cfgetospeed??? - x := term.c_oflag and $0F; - {$ELSE} - x := cfgetospeed(term); - {$ENDIF} - for n := 0 to Maxrates do - if rates[n, 1] = x then - begin - dcb.baudrate := rates[n, 0]; - break; - end; - //hardware handshake - if (term.c_cflag and CRTSCTS) > 0 then - dcb.flags := dcb.flags or dcb_RtsControlHandshake or dcb_OutxCtsFlow - else - dcb.flags := dcb.flags and (not (dcb_RtsControlHandshake or dcb_OutxCtsFlow)); - //software handshake - if (term.c_cflag and IXOFF) > 0 then - dcb.flags := dcb.flags or dcb_OutX or dcb_InX - else - dcb.flags := dcb.flags and (not (dcb_OutX or dcb_InX)); - //size of byte - case term.c_cflag and CSIZE of - CS5: - dcb.bytesize := 5; - CS6: - dcb.bytesize := 6; - CS7fix: - dcb.bytesize := 7; - CS8: - dcb.bytesize := 8; - end; - //parity - if (term.c_cflag and PARENB) > 0 then - dcb.flags := dcb.flags or dcb_ParityCheck - else - dcb.flags := dcb.flags and (not dcb_ParityCheck); - dcb.parity := 0; - if (term.c_cflag and PARODD) > 0 then - dcb.parity := 1 - else - dcb.parity := 2; - //stop bits - if (term.c_cflag and CSTOPB) > 0 then - dcb.stopbits := 2 - else - dcb.stopbits := 0; -end; -{$ENDIF} - -{$IFNDEF MSWINDOWS} -procedure TBlockSerial.SetCommState; -begin - DcbToTermios(dcb, termiosstruc); - SerialCheck(tcsetattr(FHandle, TCSANOW, termiosstruc)); - ExceptCheck; -end; -{$ELSE} -procedure TBlockSerial.SetCommState; -begin - SetSynaError(sOK); - if not windows.SetCommState(Fhandle, dcb) then - SerialCheck(sErr); - ExceptCheck; -end; -{$ENDIF} - -{$IFNDEF MSWINDOWS} -procedure TBlockSerial.GetCommState; -begin - SerialCheck(tcgetattr(FHandle, termiosstruc)); - ExceptCheck; - TermiostoDCB(termiosstruc, dcb); -end; -{$ELSE} -procedure TBlockSerial.GetCommState; -begin - SetSynaError(sOK); - if not windows.GetCommState(Fhandle, dcb) then - SerialCheck(sErr); - ExceptCheck; -end; -{$ENDIF} - -procedure TBlockSerial.SetSizeRecvBuffer(size: integer); -begin -{$IFDEF MSWINDOWS} - SetupComm(Fhandle, size, 0); - GetCommState; - dcb.XonLim := size div 4; - dcb.XoffLim := size div 4; - SetCommState; -{$ENDIF} - FRecvBuffer := size; -end; - -function TBlockSerial.GetDSR: Boolean; -begin - ModemStatus; -{$IFNDEF MSWINDOWS} - Result := (FModemWord and TIOCM_DSR) > 0; -{$ELSE} - Result := (FModemWord and MS_DSR_ON) > 0; -{$ENDIF} -end; - -procedure TBlockSerial.SetDTRF(Value: Boolean); -begin -{$IFNDEF MSWINDOWS} - ModemStatus; - if Value then - FModemWord := FModemWord or TIOCM_DTR - else - FModemWord := FModemWord and not TIOCM_DTR; - {$IFNDEF FPC} - ioctl(FHandle, TIOCMSET, @FModemWord); - {$ELSE} - fpioctl(FHandle, TIOCMSET, @FModemWord); - {$ENDIF} -{$ELSE} - if Value then - EscapeCommFunction(FHandle, SETDTR) - else - EscapeCommFunction(FHandle, CLRDTR); -{$ENDIF} -end; - -function TBlockSerial.GetCTS: Boolean; -begin - ModemStatus; -{$IFNDEF MSWINDOWS} - Result := (FModemWord and TIOCM_CTS) > 0; -{$ELSE} - Result := (FModemWord and MS_CTS_ON) > 0; -{$ENDIF} -end; - -procedure TBlockSerial.SetRTSF(Value: Boolean); -begin -{$IFNDEF MSWINDOWS} - ModemStatus; - if Value then - FModemWord := FModemWord or TIOCM_RTS - else - FModemWord := FModemWord and not TIOCM_RTS; - {$IFNDEF FPC} - ioctl(FHandle, TIOCMSET, @FModemWord); - {$ELSE} - fpioctl(FHandle, TIOCMSET, @FModemWord); - {$ENDIF} -{$ELSE} - if Value then - EscapeCommFunction(FHandle, SETRTS) - else - EscapeCommFunction(FHandle, CLRRTS); -{$ENDIF} -end; - -function TBlockSerial.GetCarrier: Boolean; -begin - ModemStatus; -{$IFNDEF MSWINDOWS} - Result := (FModemWord and TIOCM_CAR) > 0; -{$ELSE} - Result := (FModemWord and MS_RLSD_ON) > 0; -{$ENDIF} -end; - -function TBlockSerial.GetRing: Boolean; -begin - ModemStatus; -{$IFNDEF MSWINDOWS} - Result := (FModemWord and TIOCM_RNG) > 0; -{$ELSE} - Result := (FModemWord and MS_RING_ON) > 0; -{$ENDIF} -end; - -{$IFDEF MSWINDOWS} -function TBlockSerial.CanEvent(Event: dword; Timeout: integer): boolean; -var - ex: DWord; - y: Integer; - Overlapped: TOverlapped; -begin - FillChar(Overlapped, Sizeof(Overlapped), 0); - Overlapped.hEvent := CreateEvent(nil, True, False, nil); - try - SetCommMask(FHandle, Event); - SetSynaError(sOK); - if (Event = EV_RXCHAR) and (Waitingdata > 0) then - Result := True - else - begin - y := 0; - if not WaitCommEvent(FHandle, ex, @Overlapped) then - y := GetLastError; - if y = ERROR_IO_PENDING then - begin - //timedout - WaitForSingleObject(Overlapped.hEvent, Timeout); - SetCommMask(FHandle, 0); - GetOverlappedResult(FHandle, Overlapped, DWord(y), True); - end; - Result := (ex and Event) = Event; - end; - finally - SetCommMask(FHandle, 0); - CloseHandle(Overlapped.hEvent); - end; -end; -{$ENDIF} - -{$IFNDEF MSWINDOWS} -function TBlockSerial.CanRead(Timeout: integer): boolean; -var - FDSet: TFDSet; - TimeVal: PTimeVal; - TimeV: TTimeVal; - x: Integer; -begin - TimeV.tv_usec := (Timeout mod 1000) * 1000; - TimeV.tv_sec := Timeout div 1000; - TimeVal := @TimeV; - if Timeout = -1 then - TimeVal := nil; - {$IFNDEF FPC} - FD_ZERO(FDSet); - FD_SET(FHandle, FDSet); - x := Select(FHandle + 1, @FDSet, nil, nil, TimeVal); - {$ELSE} - fpFD_ZERO(FDSet); - fpFD_SET(FHandle, FDSet); - x := fpSelect(FHandle + 1, @FDSet, nil, nil, TimeVal); - {$ENDIF} - SerialCheck(x); - if FLastError <> sOK then - x := 0; - Result := x > 0; - ExceptCheck; - if Result then - DoStatus(HR_CanRead, ''); -end; -{$ELSE} -function TBlockSerial.CanRead(Timeout: integer): boolean; -begin - Result := WaitingData > 0; - if not Result then - Result := CanEvent(EV_RXCHAR, Timeout) or (WaitingData > 0); - //check WaitingData again due some broken virtual ports - if Result then - DoStatus(HR_CanRead, ''); -end; -{$ENDIF} - -{$IFNDEF MSWINDOWS} -function TBlockSerial.CanWrite(Timeout: integer): boolean; -var - FDSet: TFDSet; - TimeVal: PTimeVal; - TimeV: TTimeVal; - x: Integer; -begin - TimeV.tv_usec := (Timeout mod 1000) * 1000; - TimeV.tv_sec := Timeout div 1000; - TimeVal := @TimeV; - if Timeout = -1 then - TimeVal := nil; - {$IFNDEF FPC} - FD_ZERO(FDSet); - FD_SET(FHandle, FDSet); - x := Select(FHandle + 1, nil, @FDSet, nil, TimeVal); - {$ELSE} - fpFD_ZERO(FDSet); - fpFD_SET(FHandle, FDSet); - x := fpSelect(FHandle + 1, nil, @FDSet, nil, TimeVal); - {$ENDIF} - SerialCheck(x); - if FLastError <> sOK then - x := 0; - Result := x > 0; - ExceptCheck; - if Result then - DoStatus(HR_CanWrite, ''); -end; -{$ELSE} -function TBlockSerial.CanWrite(Timeout: integer): boolean; -var - t: LongWord; -begin - Result := SendingData = 0; - if not Result then - Result := CanEvent(EV_TXEMPTY, Timeout); - if Result and (Win32Platform <> VER_PLATFORM_WIN32_NT) then - begin - t := GetTick; - while not ReadTxEmpty(FPortAddr) do - begin - if TickDelta(t, GetTick) > 255 then - Break; - Sleep(0); - end; - end; - if Result then - DoStatus(HR_CanWrite, ''); -end; -{$ENDIF} - -function TBlockSerial.CanReadEx(Timeout: integer): boolean; -begin - if Fbuffer <> '' then - Result := True - else - Result := CanRead(Timeout); -end; - -procedure TBlockSerial.EnableRTSToggle(Value: boolean); -begin - SetSynaError(sOK); -{$IFNDEF MSWINDOWS} - FRTSToggle := Value; - if Value then - RTS:=False; -{$ELSE} - if Win32Platform = VER_PLATFORM_WIN32_NT then - begin - GetCommState; - if value then - dcb.Flags := dcb.Flags or dcb_RtsControlToggle - else - dcb.flags := dcb.flags and (not dcb_RtsControlToggle); - SetCommState; - end - else - begin - FRTSToggle := Value; - if Value then - RTS:=False; - end; -{$ENDIF} -end; - -procedure TBlockSerial.Flush; -begin -{$IFNDEF MSWINDOWS} - SerialCheck(tcdrain(FHandle)); -{$ELSE} - SetSynaError(sOK); - if not Flushfilebuffers(FHandle) then - SerialCheck(sErr); -{$ENDIF} - ExceptCheck; -end; - -{$IFNDEF MSWINDOWS} -procedure TBlockSerial.Purge; -begin - {$IFNDEF FPC} - SerialCheck(ioctl(FHandle, TCFLSH, TCIOFLUSH)); - {$ELSE} - {$IFDEF DARWIN} - SerialCheck(fpioctl(FHandle, TCIOflush, TCIOFLUSH)); - {$ELSE} - SerialCheck(fpioctl(FHandle, TCFLSH, TCIOFLUSH)); - {$ENDIF} - {$ENDIF} - FBuffer := ''; - ExceptCheck; -end; -{$ELSE} -procedure TBlockSerial.Purge; -var - x: integer; -begin - SetSynaError(sOK); - x := PURGE_TXABORT or PURGE_TXCLEAR or PURGE_RXABORT or PURGE_RXCLEAR; - if not PurgeComm(FHandle, x) then - SerialCheck(sErr); - FBuffer := ''; - ExceptCheck; -end; -{$ENDIF} - -function TBlockSerial.ModemStatus: integer; -begin - Result := 0; -{$IFNDEF MSWINDOWS} - {$IFNDEF FPC} - SerialCheck(ioctl(FHandle, TIOCMGET, @Result)); - {$ELSE} - SerialCheck(fpioctl(FHandle, TIOCMGET, @Result)); - {$ENDIF} -{$ELSE} - SetSynaError(sOK); - if not GetCommModemStatus(FHandle, dword(Result)) then - SerialCheck(sErr); -{$ENDIF} - ExceptCheck; - FModemWord := Result; -end; - -procedure TBlockSerial.SetBreak(Duration: integer); -begin -{$IFNDEF MSWINDOWS} - SerialCheck(tcsendbreak(FHandle, Duration)); -{$ELSE} - SetCommBreak(FHandle); - Sleep(Duration); - SetSynaError(sOK); - if not ClearCommBreak(FHandle) then - SerialCheck(sErr); -{$ENDIF} -end; - -{$IFDEF MSWINDOWS} -procedure TBlockSerial.DecodeCommError(Error: DWord); -begin - if (Error and DWord(CE_FRAME)) > 1 then - FLastError := ErrFrame; - if (Error and DWord(CE_OVERRUN)) > 1 then - FLastError := ErrOverrun; - if (Error and DWord(CE_RXOVER)) > 1 then - FLastError := ErrRxOver; - if (Error and DWord(CE_RXPARITY)) > 1 then - FLastError := ErrRxParity; - if (Error and DWord(CE_TXFULL)) > 1 then - FLastError := ErrTxFull; -end; -{$ENDIF} - -//HGJ -function TBlockSerial.PreTestFailing: Boolean; -begin - if not FInstanceActive then - begin - RaiseSynaError(ErrPortNotOpen); - result:= true; - Exit; - end; - Result := not TestCtrlLine; - if result then - RaiseSynaError(ErrNoDeviceAnswer) -end; - -function TBlockSerial.TestCtrlLine: Boolean; -begin - result := ((not FTestDSR) or DSR) and ((not FTestCTS) or CTS); -end; - -function TBlockSerial.ATCommand(value: AnsiString): AnsiString; -var - s: AnsiString; - ConvSave: Boolean; -begin - result := ''; - FAtResult := False; - ConvSave := FConvertLineEnd; - try - FConvertLineEnd := True; - SendString(value + #$0D); - repeat - s := RecvString(FAtTimeout); - if s <> Value then - result := result + s + CRLF; - if s = 'OK' then - begin - FAtResult := True; - break; - end; - if s = 'ERROR' then - break; - until FLastError <> sOK; - finally - FConvertLineEnd := Convsave; - end; -end; - - -function TBlockSerial.ATConnect(value: AnsiString): AnsiString; -var - s: AnsiString; - ConvSave: Boolean; -begin - result := ''; - FAtResult := False; - ConvSave := FConvertLineEnd; - try - FConvertLineEnd := True; - SendString(value + #$0D); - repeat - s := RecvString(90 * FAtTimeout); - if s <> Value then - result := result + s + CRLF; - if s = 'NO CARRIER' then - break; - if s = 'ERROR' then - break; - if s = 'BUSY' then - break; - if s = 'NO DIALTONE' then - break; - if Pos('CONNECT', s) = 1 then - begin - FAtResult := True; - break; - end; - until FLastError <> sOK; - finally - FConvertLineEnd := Convsave; - end; -end; - -function TBlockSerial.SerialCheck(SerialResult: integer): integer; -begin - if SerialResult = integer(INVALID_HANDLE_VALUE) then -{$IFDEF MSWINDOWS} - result := GetLastError -{$ELSE} - {$IFNDEF FPC} - result := GetLastError - {$ELSE} - result := fpGetErrno - {$ENDIF} -{$ENDIF} - else - result := sOK; - FLastError := result; - FLastErrorDesc := GetErrorDesc(FLastError); -end; - -procedure TBlockSerial.ExceptCheck; -var - e: ESynaSerError; - s: string; -begin - if FRaiseExcept and (FLastError <> sOK) then - begin - s := GetErrorDesc(FLastError); - e := ESynaSerError.CreateFmt('Communication error %d: %s', [FLastError, s]); - e.ErrorCode := FLastError; - e.ErrorMessage := s; - raise e; - end; -end; - -procedure TBlockSerial.SetSynaError(ErrNumber: integer); -begin - FLastError := ErrNumber; - FLastErrorDesc := GetErrorDesc(FLastError); -end; - -procedure TBlockSerial.RaiseSynaError(ErrNumber: integer); -begin - SetSynaError(ErrNumber); - ExceptCheck; -end; - -procedure TBlockSerial.DoStatus(Reason: THookSerialReason; const Value: string); -begin - if assigned(OnStatus) then - OnStatus(Self, Reason, Value); -end; - -{======================================================================} - -class function TBlockSerial.GetErrorDesc(ErrorCode: integer): string; -begin - Result:= ''; - case ErrorCode of - sOK: Result := 'OK'; - ErrAlreadyOwned: Result := 'Port owned by other process';{HGJ} - ErrAlreadyInUse: Result := 'Instance already in use'; {HGJ} - ErrWrongParameter: Result := 'Wrong paramter at call'; {HGJ} - ErrPortNotOpen: Result := 'Instance not yet connected'; {HGJ} - ErrNoDeviceAnswer: Result := 'No device answer detected'; {HGJ} - ErrMaxBuffer: Result := 'Maximal buffer length exceeded'; - ErrTimeout: Result := 'Timeout during operation'; - ErrNotRead: Result := 'Reading of data failed'; - ErrFrame: Result := 'Receive framing error'; - ErrOverrun: Result := 'Receive Overrun Error'; - ErrRxOver: Result := 'Receive Queue overflow'; - ErrRxParity: Result := 'Receive Parity Error'; - ErrTxFull: Result := 'Tranceive Queue is full'; - end; - if Result = '' then - begin - Result := SysErrorMessage(ErrorCode); - end; -end; - - -{---------- cpom Comport Ownership Manager Routines ------------- - by Hans-Georg Joepgen of Stuttgart, Germany. - Copyright (c) 2002, by Hans-Georg Joepgen - - Stefan Krauss of Stuttgart, Germany, contributed literature and Internet - research results, invaluable advice and excellent answers to the Comport - Ownership Manager. -} - -{$IFDEF UNIX} - -function TBlockSerial.LockfileName: String; -var - s: string; -begin - s := SeparateRight(FDevice, '/dev/'); - result := LockfileDirectory + '/LCK..' + s; -end; - -procedure TBlockSerial.CreateLockfile(PidNr: integer); -var - f: TextFile; - s: string; -begin - // Create content for file - s := IntToStr(PidNr); - while length(s) < 10 do - s := ' ' + s; - // Create file - try - AssignFile(f, LockfileName); - try - Rewrite(f); - writeln(f, s); - finally - CloseFile(f); - end; - // Allow all users to enjoy the benefits of cpom - s := 'chmod a+rw ' + LockfileName; -{$IFNDEF FPC} - FileSetReadOnly( LockfileName, False ) ; - // Libc.system(pchar(s)); -{$ELSE} - fpSystem(s); -{$ENDIF} - except - // not raise exception, if you not have write permission for lock. - on Exception do - ; - end; -end; - -function TBlockSerial.ReadLockfile: integer; -{Returns PID from Lockfile. Lockfile must exist.} -var - f: TextFile; - s: string; -begin - AssignFile(f, LockfileName); - Reset(f); - try - readln(f, s); - finally - CloseFile(f); - end; - Result := StrToIntDef(s, -1) -end; - -function TBlockSerial.cpomComportAccessible: boolean; -var - MyPid: integer; - Filename: string; -begin - Filename := LockfileName; - {$IFNDEF FPC} - MyPid := Libc.getpid; - {$ELSE} - MyPid := fpGetPid; - {$ENDIF} - // Make sure, the Lock Files Directory exists. We need it. - if not DirectoryExists(LockfileDirectory) then - CreateDir(LockfileDirectory); - // Check the Lockfile - if not FileExists (Filename) then - begin // comport is not locked. Lock it for us. - CreateLockfile(MyPid); - result := true; - exit; // done. - end; - // Is port owned by orphan? Then it's time for error recovery. - //FPC forgot to add getsid.. :-( - {$IFNDEF FPC} - if Libc.getsid(ReadLockfile) = -1 then - begin // Lockfile was left from former desaster - DeleteFile(Filename); // error recovery - CreateLockfile(MyPid); - result := true; - exit; - end; - {$ENDIF} - result := false // Sorry, port is owned by living PID and locked -end; - -procedure TBlockSerial.cpomReleaseComport; -begin - DeleteFile(LockfileName); -end; - -{$ENDIF} -{----------------------------------------------------------------} - -{$IFDEF MSWINDOWS} -function GetSerialPortNames: string; -var - reg: TRegistry; - l, v: TStringList; - n: integer; -begin - l := TStringList.Create; - v := TStringList.Create; - reg := TRegistry.Create; - try -{$IFNDEF VER100} -{$IFNDEF VER120} - reg.Access := KEY_READ; -{$ENDIF} -{$ENDIF} - reg.RootKey := HKEY_LOCAL_MACHINE; - reg.OpenKey('\HARDWARE\DEVICEMAP\SERIALCOMM', false); - reg.GetValueNames(l); - for n := 0 to l.Count - 1 do - v.Add(reg.ReadString(l[n])); - Result := v.CommaText; - finally - reg.Free; - l.Free; - v.Free; - end; -end; -{$ENDIF} -{$IFNDEF MSWINDOWS} -function GetSerialPortNames: string; -var - Index: Integer; - Data: string; - TmpPorts: String; - sr : TSearchRec; -begin - try - TmpPorts := ''; - if FindFirst('/dev/ttyS*', $FFFFFFFF, sr) = 0 then - begin - repeat - if (sr.Attr and $FFFFFFFF) = Sr.Attr then - begin - data := sr.Name; - index := length(data); - while (index > 1) and (data[index] <> '/') do - index := index - 1; - TmpPorts := TmpPorts + ' ' + copy(data, 1, index + 1); - end; - until FindNext(sr) <> 0; - end; - FindClose(sr); - finally - Result:=TmpPorts; - end; -end; -{$ENDIF} - -end. -<<<<<<< HEAD -======= {==============================================================================| -| Project : Ararat Synapse | 007.004.000 | +| Project : Ararat Synapse | 007.005.000 | |==============================================================================| | Content: Serial port support | |==============================================================================| @@ -2389,9 +44,9 @@ function GetSerialPortNames: string; |==============================================================================} {: @abstract(Serial port communication library) -This unit contains a class that implements serial port communication for Windows - or Linux. This class provides numerous methods with same name and functionality - as methods of the Ararat Synapse TCP/IP library. +This unit contains a class that implements serial port communication + for Windows, Linux, Unix or MacOSx. This class provides numerous methods with + same name and functionality as methods of the Ararat Synapse TCP/IP library. The following is a small example how establish a connection by modem (in this case with my USB modem): @@ -2421,6 +76,13 @@ function GetSerialPortNames: string; {$ENDIF} {$ENDIF} +//Kylix does not known UNIX define +{$IFDEF LINUX} + {$IFNDEF UNIX} + {$DEFINE UNIX} + {$ENDIF} +{$ENDIF} + {$IFDEF FPC} {$MODE DELPHI} {$IFDEF MSWINDOWS} @@ -2534,10 +196,14 @@ TDCB = record PDCB = ^TDCB; const -{$IFDEF LINUX} - MaxRates = 30; +{$IFDEF UNIX} + {$IFDEF DARWIN} + MaxRates = 18; //MAC + {$ELSE} + MaxRates = 30; //UNIX + {$ENDIF} {$ELSE} - MaxRates = 19; //FPC on some platforms not know high speeds? + MaxRates = 19; //WIN {$ENDIF} Rates: array[0..MaxRates, 0..1] of cardinal = ( @@ -2559,9 +225,10 @@ TDCB = record (38400, B38400), (57600, B57600), (115200, B115200), - (230400, B230400), - (460800, B460800) -{$IFDEF LINUX} + (230400, B230400) +{$IFNDEF DARWIN} + ,(460800, B460800) + {$IFDEF UNIX} ,(500000, B500000), (576000, B576000), (921600, B921600), @@ -2573,10 +240,16 @@ TDCB = record (3000000, B3000000), (3500000, B3500000), (4000000, B4000000) + {$ENDIF} {$ENDIF} ); {$ENDIF} +{$IFDEF DARWIN} +const // From fcntl.h + O_SYNC = $0080; { synchronous writes } +{$ENDIF} + const sOK = 0; sErr = integer(-1); @@ -2655,11 +328,9 @@ TBlockSerial = class(TObject) procedure GetComNr(Value: string); virtual; function PreTestFailing: boolean; virtual;{HGJ} function TestCtrlLine: Boolean; virtual; -{$IFNDEF MSWINDOWS} +{$IFDEF UNIX} procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual; procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual; -{$ENDIF} -{$IFDEF LINUX} function ReadLockfile: integer; virtual; function LockfileName: String; virtual; procedure CreateLockfile(PidNr: integer); virtual; @@ -2670,7 +341,7 @@ TBlockSerial = class(TObject) {: data Control Block with communication parameters. Usable only when you need to call API directly.} DCB: Tdcb; -{$IFNDEF MSWINDOWS} +{$IFDEF UNIX} TermiosStruc: termios; {$ENDIF} {:Object constructor.} @@ -2948,7 +619,7 @@ TBlockSerial = class(TObject) {:Raise Synaser error with ErrNumber code. Usually used by internal routines.} procedure RaiseSynaError(ErrNumber: integer); virtual; -{$IFDEF LINUX} +{$IFDEF UNIX} function cpomComportAccessible: boolean; virtual;{HGJ} procedure cpomReleaseComport; virtual; {HGJ} {$ENDIF} @@ -3109,7 +780,7 @@ destructor TBlockSerial.Destroy; class function TBlockSerial.GetVersion: string; begin - Result := 'SynaSer 7.4.0'; + Result := 'SynaSer 7.5.0'; end; procedure TBlockSerial.CloseSocket; @@ -3123,7 +794,7 @@ procedure TBlockSerial.CloseSocket; end; if InstanceActive then begin - {$IFDEF LINUX} + {$IFDEF UNIX} if FLinuxLock then cpomReleaseComport; {$ENDIF} @@ -3278,7 +949,7 @@ procedure TBlockSerial.Connect(comport: string); SerialCheck(-1) else SerialCheck(0); - {$IFDEF LINUX} + {$IFDEF UNIX} if FLastError <> sOK then if FLinuxLock then cpomReleaseComport; @@ -3313,7 +984,7 @@ procedure TBlockSerial.Connect(comport: string); begin SetSynaError(ErrNoDeviceAnswer); FileClose(FHandle); {HGJ} - {$IFDEF LINUX} + {$IFDEF UNIX} if FLinuxLock then cpomReleaseComport; {HGJ} {$ENDIF} {HGJ} @@ -4152,7 +1823,8 @@ function TBlockSerial.CanRead(Timeout: integer): boolean; begin Result := WaitingData > 0; if not Result then - Result := CanEvent(EV_RXCHAR, Timeout); + Result := CanEvent(EV_RXCHAR, Timeout) or (WaitingData > 0); + //check WaitingData again due some broken virtual ports if Result then DoStatus(HR_CanRead, ''); end; @@ -4263,7 +1935,11 @@ procedure TBlockSerial.Purge; {$IFNDEF FPC} SerialCheck(ioctl(FHandle, TCFLSH, TCIOFLUSH)); {$ELSE} - SerialCheck(fpioctl(FHandle, TCFLSH, TCIOFLUSH)); + {$IFDEF DARWIN} + SerialCheck(fpioctl(FHandle, TCIOflush, TCIOFLUSH)); + {$ELSE} + SerialCheck(fpioctl(FHandle, TCFLSH, TCIOFLUSH)); + {$ENDIF} {$ENDIF} FBuffer := ''; ExceptCheck; @@ -4499,7 +2175,7 @@ class function TBlockSerial.GetErrorDesc(ErrorCode: integer): string; Ownership Manager. } -{$IFDEF LINUX} +{$IFDEF UNIX} function TBlockSerial.LockfileName: String; var @@ -4660,7 +2336,4 @@ function GetSerialPortNames: string; end; {$ENDIF} -end. ->>>>>>> remotes/origin/NMD -======= ->>>>>>> remotes/origin/master +end. \ No newline at end of file diff --git a/demos/gmail_demo/Unit2.pas b/demos/gmail_demo/Unit2.pas index 61931a0..40b7003 100644 --- a/demos/gmail_demo/Unit2.pas +++ b/demos/gmail_demo/Unit2.pas @@ -1,120 +1,112 @@ -<<<<<<< HEAD unit Unit2; -======= -unit Unit2; ->>>>>>> remotes/origin/master - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, Menus, GMailSMTP, synachar,TypInfo, ComCtrls,blcksock; - -type - TForm2 = class(TForm) - Label7: TLabel; - Memo1: TMemo; - Button1: TButton; - Button2: TButton; - Label8: TLabel; - ListBox2: TListBox; - OpenDialog1: TOpenDialog; - Button3: TButton; - Label1: TLabel; - Edit1: TEdit; - lbl1: TLabel; - lbl2: TLabel; - Edit2: TEdit; - lbl3: TLabel; - lbl4: TLabel; - Edit3: TEdit; - btn1: TButton; - btn2: TButton; - lbl5: TLabel; - Edit4: TEdit; - lbl6: TLabel; - Edit5: TEdit; - chk1: TCheckBox; - GMailSMTP1: TGMailSMTP; - StatusBar1: TStatusBar; - procedure Button1Click(Sender: TObject); - procedure Button2Click(Sender: TObject); - procedure Button3Click(Sender: TObject); - procedure btn1Click(Sender: TObject); - procedure btn2Click(Sender: TObject); - procedure GMailSMTP1Status(Sender: TObject; Reason: THookSocketReason; - const Value: string); - private - { Private declarations } - public - - end; - -var - Form2: TForm2; - -implementation - -{$R *.dfm} - -procedure TForm2.btn1Click(Sender: TObject); -begin -if OpenDialog1.Execute then - begin - ListBox2.Items.Add(OpenDialog1.FileName); - GMailSMTP1.AttachFiles.Add(OpenDialog1.FileName); - ShowMessage(' '); - end; -end; - -procedure TForm2.btn2Click(Sender: TObject); -begin -if ListBox2.ItemIndex>0 then - begin - GMailSMTP1.AttachFiles.Delete(ListBox2.ItemIndex); - ListBox2.Items.Delete(ListBox2.ItemIndex); - ShowMessage(' '); - end; -end; - -procedure TForm2.Button1Click(Sender: TObject); -var i:integer; -begin - GMailSMTP1.AddText(Memo1.Text); - Memo1.Lines.Clear; - ShowMessage(' '); -end; - -procedure TForm2.Button2Click(Sender: TObject); -begin - GMailSMTP1.AddHTML(Memo1.Text); - Memo1.Lines.Clear; - ShowMessage(' '); -end; - -procedure TForm2.Button3Click(Sender: TObject); -begin -GMailSMTP1.Login:=Edit4.Text; -GMailSMTP1.Password:=Edit5.Text; -GMailSMTP1.FromEmail:=Edit1.Text; -GMailSMTP1.Recipients.Clear; -GMailSMTP1.Recipients.Add(Edit2.Text); -if GMailSMTP1.SendMessage(Edit3.Text, chk1.Checked) then - ShowMessage(' ') -else - ShowMessage(' ') -end; - -procedure TForm2.GMailSMTP1Status(Sender: TObject; Reason: THookSocketReason; - const Value: string); -begin - Application.ProcessMessages; - StatusBar1.Panels[0].Text:=GetEnumName(TypeInfo(THookSocketReason),ord(Reason))+ - ' '+Value; -end; - -end. -<<<<<<< HEAD -======= ->>>>>>> remotes/origin/master +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, Menus, GMailSMTP, synachar,TypInfo, ComCtrls,blcksock; + +type + TForm2 = class(TForm) + Label7: TLabel; + Memo1: TMemo; + Button1: TButton; + Button2: TButton; + Label8: TLabel; + ListBox2: TListBox; + OpenDialog1: TOpenDialog; + Button3: TButton; + Label1: TLabel; + Edit1: TEdit; + lbl1: TLabel; + lbl2: TLabel; + Edit2: TEdit; + lbl3: TLabel; + lbl4: TLabel; + Edit3: TEdit; + btn1: TButton; + btn2: TButton; + lbl5: TLabel; + Edit4: TEdit; + lbl6: TLabel; + Edit5: TEdit; + chk1: TCheckBox; + GMailSMTP1: TGMailSMTP; + StatusBar1: TStatusBar; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure btn1Click(Sender: TObject); + procedure btn2Click(Sender: TObject); + procedure GMailSMTP1Status(Sender: TObject; Reason: THookSocketReason; + const Value: string); + private + { Private declarations } + public + + end; + +var + Form2: TForm2; + +implementation + +{$R *.dfm} + +procedure TForm2.btn1Click(Sender: TObject); +begin +if OpenDialog1.Execute then + begin + ListBox2.Items.Add(OpenDialog1.FileName); + GMailSMTP1.AttachFiles.Add(OpenDialog1.FileName); + ShowMessage('Новый файл добавлен в сообщение'); + end; +end; + +procedure TForm2.btn2Click(Sender: TObject); +begin +if ListBox2.ItemIndex>0 then + begin + GMailSMTP1.AttachFiles.Delete(ListBox2.ItemIndex); + ListBox2.Items.Delete(ListBox2.ItemIndex); + ShowMessage('Файл удален из сообщения'); + end; +end; + +procedure TForm2.Button1Click(Sender: TObject); +var i:integer; +begin + GMailSMTP1.AddText(Memo1.Text); + Memo1.Lines.Clear; + ShowMessage('Фрагмент сообщения успешно добавлен'); +end; + +procedure TForm2.Button2Click(Sender: TObject); +begin + GMailSMTP1.AddHTML(Memo1.Text); + Memo1.Lines.Clear; + ShowMessage('Фрагмент сообщения успешно добавлен'); +end; + +procedure TForm2.Button3Click(Sender: TObject); +begin +GMailSMTP1.Login:=Edit4.Text; +GMailSMTP1.Password:=Edit5.Text; +GMailSMTP1.FromEmail:=Edit1.Text; +GMailSMTP1.Recipients.Clear; +GMailSMTP1.Recipients.Add(Edit2.Text); +if GMailSMTP1.SendMessage(Edit3.Text, chk1.Checked) then + ShowMessage('Письмо отправлено') +else + ShowMessage('Отправка не удалась') +end; + +procedure TForm2.GMailSMTP1Status(Sender: TObject; Reason: THookSocketReason; + const Value: string); +begin + Application.ProcessMessages; + StatusBar1.Panels[0].Text:=GetEnumName(TypeInfo(THookSocketReason),ord(Reason))+ + ' '+Value; +end; + +end. \ No newline at end of file diff --git a/demos/googlelogin_demo/Demo.dpr b/demos/googlelogin_demo/Demo.dpr index f0723d5..0039e8f 100644 --- a/demos/googlelogin_demo/Demo.dpr +++ b/demos/googlelogin_demo/Demo.dpr @@ -2,7 +2,8 @@ program Demo; uses Forms, - main in 'main.pas' {Form11}; + main in 'main.pas' {Form11}, + uGoogleLogin in '..\..\packages\googleLogin_pack\uGoogleLogin.pas'; {$R *.res} diff --git a/demos/googlelogin_demo/Demo.dproj b/demos/googlelogin_demo/Demo.dproj index 17346ec..bb66e61 100644 --- a/demos/googlelogin_demo/Demo.dproj +++ b/demos/googlelogin_demo/Demo.dproj @@ -1,10 +1,14 @@  {A9DD61E1-1C1A-4F97-801D-FA2DE517335B} - 12.0 + 12.2 Demo.dpr Debug DCC32 + True + Win32 + Application + VCL true @@ -42,29 +46,27 @@
Form11
 - - Base - + Cfg_2 Base + + Base + Cfg_1 Base - + + Delphi.Personality.12 - - False - True - False - + False False @@ -97,6 +99,9 @@ Demo.dpr + + True + 12 diff --git a/demos/googlelogin_demo/main.dfm b/demos/googlelogin_demo/main.dfm index 1353e39..758006e 100644 --- a/demos/googlelogin_demo/main.dfm +++ b/demos/googlelogin_demo/main.dfm @@ -220,14 +220,9 @@ object Form11: TForm11 OnClick = Button3Click end object GoogleLogin1: TGoogleLogin - AppName = - 'Mozilla/5.0 (Windows; U; Windows NT 5.1; ru; rv:1.9.2.6) Gecko/2' + - '0100625 Firefox/3.6.6' + AppName = 'My-Application' AccountType = atNone - OnAutorization = GoogleLogin1Autorization - OnAutorizCaptcha = GoogleLogin1AutorizCaptcha - OnProgressAutorization = GoogleLogin1ProgressAutorization - Left = 193 - Top = 75 + Left = 172 + Top = 184 end end diff --git a/demos/googlelogin_demo/main.pas b/demos/googlelogin_demo/main.pas index f753593..0725e3f 100644 --- a/demos/googlelogin_demo/main.pas +++ b/demos/googlelogin_demo/main.pas @@ -21,7 +21,6 @@ TForm11 = class(TForm) AuthEdit: TEdit; ResultEdit: TEdit; Button2: TButton; - GoogleLogin1: TGoogleLogin; Edit1: TEdit; Label7: TLabel; ProgressBar1: TProgressBar; @@ -33,6 +32,7 @@ TForm11 = class(TForm) Button3: TButton; Label11: TLabel; Label12: TLabel; + GoogleLogin1: TGoogleLogin; procedure Button1Click(Sender: TObject); procedure GoogleLogin1Autorization(const LoginResult: TLoginResult; Result: TResultRec); diff --git a/demos/translate_demo/main.dfm b/demos/translate_demo/main.dfm index 49641b0..24279fe 100644 --- a/demos/translate_demo/main.dfm +++ b/demos/translate_demo/main.dfm @@ -2,7 +2,7 @@ object Form6: TForm6 Left = 0 Top = 0 Caption = 'Form6' - ClientHeight = 208 + ClientHeight = 250 ClientWidth = 428 Color = clBtnFace Font.Charset = DEFAULT_CHARSET @@ -17,50 +17,57 @@ object Form6: TForm6 TextHeight = 13 object Label1: TLabel Left = 10 - Top = 8 + Top = 52 Width = 31 Height = 13 Caption = #1060#1088#1072#1079#1072 end object Label2: TLabel Left = 8 - Top = 87 + Top = 131 Width = 44 Height = 13 Caption = #1055#1077#1088#1077#1074#1086#1076 end object Label3: TLabel Left = 10 - Top = 35 + Top = 79 Width = 7 Height = 13 Caption = 'C' end object Label4: TLabel Left = 10 - Top = 63 + Top = 107 Width = 13 Height = 13 Caption = #1053#1072 end + object Label5: TLabel + Left = 8 + Top = 16 + Width = 48 + Height = 13 + Caption = #1050#1083#1102#1095' API' + end object Edit1: TEdit Left = 58 - Top = 5 + Top = 49 Width = 365 Height = 21 TabOrder = 0 Text = 'Edit1' end object Memo1: TMemo - Left = 6 - Top = 106 - Width = 417 + Left = 4 + Top = 154 + Width = 421 Height = 95 TabOrder = 1 end object Button1: TButton Left = 308 - Top = 41 + Top = 85 Width = 75 Height = 25 Caption = #1055#1077#1088#1077#1074#1077#1089#1090#1080 @@ -69,7 +76,7 @@ object Form6: TForm6 end object ComboBox1: TComboBox Left = 58 - Top = 32 + Top = 76 Width = 239 Height = 21 Style = csDropDownList @@ -78,19 +85,25 @@ object Form6: TForm6 end object ComboBox2: TComboBox Left = 58 - Top = 55 + Top = 99 Width = 239 Height = 21 Style = csDropDownList TabOrder = 4 OnChange = ComboBox2Change end + object Edit2: TEdit + Left = 58 + Top = 13 + Width = 367 + Height = 21 + TabOrder = 5 + Text = 'Edit2' + end object Translator1: TTranslator SourceLang = unknown DestLang = lng_ru - OnTranslate = Translator1Translate - OnTranslateError = Translator1TranslateError - Left = 192 - Top = 132 + Left = 328 + Top = 136 end end diff --git a/demos/translate_demo/main.pas b/demos/translate_demo/main.pas index d4ebe17..9a2d0ed 100644 --- a/demos/translate_demo/main.pas +++ b/demos/translate_demo/main.pas @@ -14,10 +14,13 @@ TForm6 = class(TForm) Memo1: TMemo; Button1: TButton; ComboBox1: TComboBox; - Translator1: TTranslator; + //Translator1: TTranslator; Label3: TLabel; Label4: TLabel; ComboBox2: TComboBox; + Label5: TLabel; + Edit2: TEdit; + Translator1: TTranslator; procedure Button1Click(Sender: TObject); procedure Translator1Translate(const SourceStr, TranslateStr: string; LangDetected: TLanguageEnum); @@ -39,6 +42,7 @@ implementation procedure TForm6.Button1Click(Sender: TObject); begin + Translator1.Key:=Edit2.Text; Translator1.Translate(Edit1.Text) end; diff --git a/demos/translate_demo/translate_demo.dpr b/demos/translate_demo/translate_demo.dpr index 64238a6..cce612a 100644 --- a/demos/translate_demo/translate_demo.dpr +++ b/demos/translate_demo/translate_demo.dpr @@ -3,7 +3,8 @@ program translate_demo; uses Forms, main in 'main.pas' {Form6}, - GTranslate in '..\..\source\GTranslate.pas'; + GTranslate in '..\..\source\GTranslate.pas', + superobject in '..\..\addons\superobject\superobject.pas'; {$R *.res} diff --git a/demos/translate_demo/translate_demo.dproj b/demos/translate_demo/translate_demo.dproj index d1d7eed..3f2243c 100644 --- a/demos/translate_demo/translate_demo.dproj +++ b/demos/translate_demo/translate_demo.dproj @@ -4,7 +4,11 @@ translate_demo.dpr Debug DCC32 - 12.0 + 12.3 + True + Win32 + Application + VCL true @@ -20,7 +24,7 @@ true - WinTypes=Windows;WinProcs=Windows;$(DCC_UnitAlias) + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias) translate_demo.exe 00400000 x86 @@ -42,19 +46,21 @@
Form6
- - Base - + Cfg_2 Base + + Base + Cfg_1 Base - + + Delphi.Personality.12 VCLApplication @@ -63,11 +69,7 @@ translate_demo.dpr - - False - True - False - + False False @@ -97,9 +99,12 @@ File G:\notepad gnu\SynEdit\Source\SynEdit_D5.bpl not found - Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office 2000 Sample Automation Server Wrapper Components + + True + 12 diff --git a/packages/googleLogin_pack/GoogleLogin.dproj b/packages/googleLogin_pack/GoogleLogin.dproj index 390c75b..253d7d1 100644 --- a/packages/googleLogin_pack/GoogleLogin.dproj +++ b/packages/googleLogin_pack/GoogleLogin.dproj @@ -2,9 +2,13 @@ {DA3343F7-B6E3-4BC9-B427-4D5119728B14} GoogleLogin.dpk - 12.0 + 12.3 Debug DCC32 + True + Win32 + Package + VCL true @@ -45,19 +49,20 @@ - - Base - Cfg_2 Base + + Base + Cfg_1 Base - + + Delphi.Personality.12 Package @@ -66,11 +71,7 @@ GoogleLogin.dpk - - False - True - False - + True False @@ -100,6 +101,9 @@ + + True + 12 diff --git a/packages/googleLogin_pack/GoogleLogin.identcache b/packages/googleLogin_pack/GoogleLogin.identcache index e52352b..2c2ce82 100644 Binary files a/packages/googleLogin_pack/GoogleLogin.identcache and b/packages/googleLogin_pack/GoogleLogin.identcache differ diff --git a/packages/googleLogin_pack/GoogleLogin.res b/packages/googleLogin_pack/GoogleLogin.res index 653aa54..ee38ccb 100644 Binary files a/packages/googleLogin_pack/GoogleLogin.res and b/packages/googleLogin_pack/GoogleLogin.res differ diff --git a/packages/googleLogin_pack/uGoogleLogin.pas b/packages/googleLogin_pack/uGoogleLogin.pas index 14d087d..1a9a3a6 100644 --- a/packages/googleLogin_pack/uGoogleLogin.pas +++ b/packages/googleLogin_pack/uGoogleLogin.pas @@ -1,26 +1,8 @@ -{ ******************************************************* } -{ } -{ Delphi & Google API } -{ } -{ File: uGoogleLogin } -{ Copyright (c) WebDelphi.ru } -{ All Rights Reserved. } -{ не обижайтесь писал на большом мониторе} -{ на счет комментариев, пишу много чтоб было понятно всем} -{ NMD} -{ ******************************************************* } - -{ ******************************************************* } -{ GoogleLogin Component } -{ ******************************************************* } - -unit uGoogleLogin; +unit uGoogleLogin; interface -uses WinInet, StrUtils,Graphics, SysUtils, Classes, Windows, TypInfo,jpeg; -//jpeg для поддержки формата jpeg -//Graphics для поддержки формата TPicture +uses WinInet, Graphics, Classes, Windows, TypInfo,jpeg, SysUtils; resourcestring rcNone = 'Аутентификация не производилась или сброшена'; @@ -40,10 +22,8 @@ interface rcErrDont = 'Не могу получить описание ошибки'; const - // дефолное название приложение через которое якобы происходит соединение с сервером гугла - DefaultAppName ='Mozilla/5.0 (Windows; U; Windows NT 5.1; ru; rv:1.9.2.6) Gecko/20100625 Firefox/3.6.6'; + DefaultAppName ='My-Application'; - // настройки wininet для работы с ssl Flags_Connection = INTERNET_DEFAULT_HTTPS_PORT; Flags_Request =INTERNET_FLAG_RELOAD or @@ -52,10 +32,6 @@ interface INTERNET_FLAG_SECURE or INTERNET_FLAG_PRAGMA_NOCACHE or INTERNET_FLAG_KEEP_CONNECTION; - // ошибки при авторизации - Errors: array [0 .. 8] of string = ('BadAuthentication', 'NotVerified', - 'TermsNotAgreed', 'CaptchaRequired', 'Unknown', 'AccountDeleted', - 'AccountDisabled', 'ServiceDisabled', 'ServiceUnavailable'); type TAccountType = (atNone, atGOOGLE, atHOSTED, atHOSTED_OR_GOOGLE); @@ -66,136 +42,93 @@ interface lrAccountDisabled, lrServiceDisabled, lrServiceUnavailable); type - // xapi - это универсальное имя - когда юзер не знает какой сервис ему нужен, то втыкает xapi и просто коннектится к Гуглу TServices = (xapi, analytics, apps, gbase, jotspot, blogger, print, cl, codesearch, cp, writely, finance, mail, health, local, lh2, annotateweb, - wise, sitemaps, youtube,gtrans); -type - TStatusThread = (sttActive,sttNoActive);//статус потока - + wise, sitemaps, youtube, gtrans,urlshortener); type TResultRec = packed record - LoginStr: string; // текстовый результат авторизации - SID: string; // в настоящее время не используется - LSID: string; // в настоящее время не используется + LoginStr: string; + SID: string; + LSID: string; Auth: string; end; type - TAutorization = procedure(const LoginResult: TLoginResult; Result: TResultRec) of object; // авторизировались - //непосредственно само изображение капчи - TAutorizCaptcha = procedure(PicCaptcha:TPicture) of object; // не авторизировались нужно ввести капчу - - //Progress,MaxProgress переменные которые специально заведены для прогрессбара Progress-текущее состояние MaxProgress-максимальное значение - TProgressAutorization = procedure(const Progress,MaxProgress:Integer)of object;//показываем прогресс при авторизации - TErrorAutorization = procedure(const ErrorStr: string) of object; // а это не авторизировались)) + TAutorization = procedure(const LoginResult: TLoginResult; Result: TResultRec) of object; + TAutorizCaptcha = procedure(PicCaptcha:TPicture) of object; + TProgressAutorization = procedure(const Progress,MaxProgress:Integer)of object; + TErrorAutorization = procedure(const ErrorStr: string) of object; TDisconnect = procedure(const ResultStr: string) of object; - TDoneThread = procedure(const Status: TStatusThread) of object; type - // поток используется только для получения HTML страницы TGoogleLoginThread = class(TThread) private FParentComp:TComponent; { private declarations } - FParamStr: string; // параметры запроса - - // данные ответа/запроса - FResultRec: TResultRec; // структура для передачи результатов - FLastResult: TLoginResult; // результаты авторизации - - FCaptchaPic:TPicture;//изображение капчи + FParamStr: string; + FResultRec: TResultRec; + FLastResult: TLoginResult; + FCaptchaPic:TPicture; FCaptchaURL: string; FCapthaToken: string; - //для прогресса FProgress,FMaxProgress:Integer; - //переменные для событий - FAutorization: TAutorization; // авторизация - FAutorizCaptcha:TAutorizCaptcha;//не авторизировались необходимо ввести капчу - FProgressAutorization:TProgressAutorization;//прогресс при авторизации для показа часиков и подобных вещей - FErrorAutorization: TErrorAutorization;//ошибка при авторизации - - function ExpertLoginResult(const LoginResult: string): TLoginResult; // анализ результата авторизации - function GetLoginError(const str: string): TLoginResult;// получаем тип ошибки - - function GetCaptchaURL(const cList: TStringList): string; // ссылка на капчу + FAutorization: TAutorization; + FAutorizCaptcha:TAutorizCaptcha; + FProgressAutorization:TProgressAutorization; + FErrorAutorization: TErrorAutorization; + function ExpertLoginResult(const LoginResult: string): TLoginResult; + function GetLoginError(const str: string): TLoginResult; + function GetCaptchaURL(const cList: TStringList): string; function GetCaptchaToken(const cList: TStringList): String; - function GetResultText: string; - - function GetErrorText(const FromServer: BOOLEAN): string;// получаем текст ошибки - function LoadCaptcha(aCaptchaURL:string):Boolean;//загрузка капчи - - - procedure SynAutoriz; // передача значения авторизации в главную форму как положено в потоке - procedure SynCaptcha; //передача значения авторизации в главную форму как положено в потоке о том что необходимо ввести капчу - procedure SynCapchaToken;//передача значения в свойство шкурки - procedure SynProgressAutoriz;// передача текушего прогресса авторизации в главную форму как положено в потоке - procedure SynErrAutoriz; // передача значения ошибки в главную форму как положено в потоке + function GetErrorText(const FromServer: BOOLEAN): string; + function LoadCaptcha(aCaptchaURL:string):Boolean; + procedure SynAutoriz; + procedure SynCaptcha; + procedure SynCapchaToken; + procedure SynProgressAutoriz; + procedure SynErrAutoriz; protected { protected declarations } - procedure Execute; override; // выполняем непосредственно авторизацию на сайте + procedure Execute; override; public { public declarations } - constructor Create(CreateSuspennded: BOOLEAN; aParamStr: string;aParentComp:TComponent); // используем для передачи логина и пароля и подобного + constructor Create(CreateSuspennded: BOOLEAN; aParamStr: string;aParentComp:TComponent); published { published declarations } - // события property OnAutorization:TAutorization read FAutorization write FAutorization; // авторизировались property OnAutorizCaptcha:TAutorizCaptcha read FAutorizCaptcha write FAutorizCaptcha; //не авторизировались необходимо ввести капчу property OnProgressAutorization: TProgressAutorization read FProgressAutorization write FProgressAutorization;//прогресс авторизации property OnError: TErrorAutorization read FErrorAutorization write FErrorAutorization; // возникла ошибка (( end; - // "шкурка" компонента TGoogleLogin = class(TComponent) private - // Поток - FThread: TGoogleLoginThread; - // регистрационные данные - FAppname: string; // строка символов, которая передается серверу и идентифицирует программное обеспечение, пославшее запрос. + FAppname: string; FAccountType: TAccountType; FLastResult: TLoginResult; FEmail: string; FPassword: string; - // данные ответа/запроса - FService: TServices; // сервис к которому необходимо получить доступ - // параметры Captcha -// FCaptchaURL: string;//ссылка на капчу - FCaptcha: string; //Captcha + FService: TServices; + FCaptcha: string; FCapchaToken: string; - //FStatus:TStatusThread;//статус потока - //переменные для событий - FAfterLogin: TAutorization;//авторизировались - FAutorizCaptcha:TAutorizCaptcha;//не авторизировались необходимо ввести капчу - FProgressAutorization:TProgressAutorization;//прогресс при авторизации для показа часиков и подобных вещей + FAfterLogin: TAutorization; + FAutorizCaptcha:TAutorizCaptcha; + FProgressAutorization:TProgressAutorization; FErrorAutorization: TErrorAutorization; FDisconnect: TDisconnect; - - function SendRequest(const ParamStr: string): AnsiString; - // отправляем запрос на сервер procedure SetEmail(cEmail: string); procedure SetPassword(cPassword: string); procedure SetService(cService: TServices); procedure SetCaptcha(cCaptcha: string); procedure SetAppName(value: string); - /// /////////////вспомогательные функции////////////////////////// function DigitToHex(Digit: Integer): Char; - // кодирование url function URLEncode(const S: string): string; - // декодирование url - function URLDecode(const S: string): string; // не используется public constructor Create(AOwner: TComponent); override; - destructor Destroy;//глушим все + destructor Destroy; procedure Login(aLoginToken: string = ''; aLoginCaptcha: string = ''); - // формируем запрос - procedure Disconnect; // удаляет все данные по авторизации - //property LastResult: TLoginResult read FLastResult;//убрал за ненадобностью по причине того что все передается в SynAutoriz - // property Auth: string read FAuth; - // property SID: string read FSID; - // property LSID: string read FLSID; - // property CaptchaURL: string read FCaptchaURL; + procedure Disconnect; property CapchaToken: string read FCapchaToken; published property AppName: string read FAppname write SetAppName; @@ -204,11 +137,10 @@ TGoogleLogin = class(TComponent) property Password: string read FPassword write SetPassword; property Captcha: string read FCaptcha write SetCaptcha; property Service: TServices read FService write SetService default xapi; - //property Status:TStatusThread read FStatus default sttNoActive;//статус потока - property OnAutorization: TAutorization read FAfterLogin write FAfterLogin;// авторизировались - property OnAutorizCaptcha:TAutorizCaptcha read FAutorizCaptcha write FAutorizCaptcha; //не авторизировались необходимо ввести капчу - property OnProgressAutorization:TProgressAutorization read FProgressAutorization write FProgressAutorization;//прогресс авторизации - property OnError: TErrorAutorization read FErrorAutorization write FErrorAutorization; // возникла ошибка (( + property OnAutorization: TAutorization read FAfterLogin write FAfterLogin; + property OnAutorizCaptcha:TAutorizCaptcha read FAutorizCaptcha write FAutorizCaptcha; + property OnProgressAutorization:TProgressAutorization read FProgressAutorization write FProgressAutorization; + property OnError: TErrorAutorization read FErrorAutorization write FErrorAutorization; property OnDisconnect: TDisconnect read FDisconnect write FDisconnect; end; @@ -218,7 +150,7 @@ implementation procedure Register; begin - RegisterComponents('WebDelphi.ru', [TGoogleLogin]); + RegisterComponents('BuBa Group', [TGoogleLogin]); end; { TGoogleLogin } @@ -239,37 +171,29 @@ procedure TGoogleLogin.Disconnect; begin FAccountType := atNone; FLastResult := lrNone; - // FSID:=''; - //FLSID:=''; - //FAuth:=''; FCapchaToken := ''; FCaptcha := ''; - //FCaptchaURL := ''; - if Assigned(FThread) then - FThread.Terminate; if Assigned(FDisconnect) then OnDisconnect(rcDisconnect) end; destructor TGoogleLogin.Destroy; begin - if Assigned(FThread) then - FThread.Terminate; inherited Destroy; end; constructor TGoogleLogin.Create(AOwner: TComponent); begin inherited Create(AOwner); - FAppname := DefaultAppName; // дефолтное значение - //FStatus:=sttNoActive;//неактивен ни один поток + FAppname := DefaultAppName; end; procedure TGoogleLogin.Login(aLoginToken, aLoginCaptcha: string); var cBody: TStringStream; - ResponseText: string; +// ResponseText: string; begin +try cBody := TStringStream.Create(''); case FAccountType of atNone, atHOSTED_OR_GOOGLE: @@ -292,25 +216,20 @@ procedure TGoogleLogin.Login(aLoginToken, aLoginCaptcha: string); cBody.WriteString('&logintoken=' + aLoginToken); cBody.WriteString('&logincaptcha=' + aLoginCaptcha); end; - // отправляем запрос на сервер - ResponseText := SendRequest(cBody.DataString); + with TGoogleLoginThread.Create(True, cBody.DataString,Self) do + begin + OnAutorization := Self.OnAutorization; + OnAutorizCaptcha:=Self.OnAutorizCaptcha; + OnProgressAutorization:=Self.OnProgressAutorization; + OnError := Self.OnError; + FreeOnTerminate := True; + Start; + end; +finally + FreeAndNil(cBody); end; - -// отправляем запрос на сервер в отдельном потоке -function TGoogleLogin.SendRequest(const ParamStr: string): AnsiString; -begin - FThread := TGoogleLoginThread.Create(True, ParamStr,Self); - FThread.OnAutorization := Self.OnAutorization; - FThread.OnAutorizCaptcha:=Self.OnAutorizCaptcha;//не авторизировались необходимо ввести капчу - FThread.OnProgressAutorization:=Self.OnProgressAutorization;//прогресс авторизации - FThread.OnError := Self.OnError; - FThread.FreeOnTerminate := True; // чтобы сам себя грухнул после окончания операции - FThread.Start; // запуск - // тут делать смысла что то нет так как данные еще не получены(они ведь будут получены в другом потоке) end; -// устанавливаем значение строки символов, которая передается серверу -// идентифицирует программное обеспечение, пославшее запрос. procedure TGoogleLogin.SetAppName(value: string); begin if not(value = '') then @@ -322,21 +241,21 @@ procedure TGoogleLogin.SetAppName(value: string); procedure TGoogleLogin.SetCaptcha(cCaptcha: string); begin FCaptcha := cCaptcha; - Login(FCapchaToken, FCaptcha); // перелогиниваемся с каптчей + Login(FCapchaToken, FCaptcha); end; procedure TGoogleLogin.SetEmail(cEmail: string); begin FEmail := cEmail; if FLastResult = lrOk then - Disconnect; // обнуляем результаты + Disconnect; end; procedure TGoogleLogin.SetPassword(cPassword: string); begin FPassword := cPassword; if FLastResult = lrOk then - Disconnect; // обнуляем результаты + Disconnect; end; procedure TGoogleLogin.SetService(cService: TServices); @@ -344,82 +263,11 @@ procedure TGoogleLogin.SetService(cService: TServices); FService := cService; if FLastResult = lrOk then begin - Disconnect; // обнуляем результаты - Login; // перелогиниваемся + Disconnect; + Login; end; end; -function TGoogleLogin.URLDecode(const S: string): string; -var - i, idx, len, n_coded: Integer; - function WebHexToInt(HexChar: Char): Integer; - begin - if HexChar < '0' then - Result := Ord(HexChar) + 256 - Ord('0') - else if HexChar <= Chr(Ord('A') - 1) then - Result := Ord(HexChar) - Ord('0') - else if HexChar <= Chr(Ord('a') - 1) then - Result := Ord(HexChar) - Ord('A') + 10 - else - Result := Ord(HexChar) - Ord('a') + 10; - end; - -begin - len := 0; - n_coded := 0; - for i := 1 to Length(S) do - if n_coded >= 1 then - begin - n_coded := n_coded + 1; - if n_coded >= 3 then - n_coded := 0; - end - else - begin - len := len + 1; - if S[i] = '%' then - n_coded := 1; - end; - SetLength(Result, len); - idx := 0; - n_coded := 0; - for i := 1 to Length(S) do - if n_coded >= 1 then - begin - n_coded := n_coded + 1; - if n_coded >= 3 then - begin - Result[idx] := Chr((WebHexToInt(S[i - 1]) * 16 + WebHexToInt(S[i])) - mod 256); - n_coded := 0; - end; - end - else - begin - idx := idx + 1; - if S[i] = '%' then - n_coded := 1; - if S[i] = '+' then - Result[idx] := ' ' - else - Result[idx] := S[i]; - end; - -end; - -{ - RUS - кодирование URL исправило проблему с тем, что если в пароле пользователя есть - спец символ то теперь, он проходит авторизацию корректно - просто при отправке запроса серверу спец символ просто отбрасывался - на счет логина не проверял! - US google translator - URL encoding correct a problem with the fact that if a user password is - special character but now he goes through the authorization correctly - just when you query the server special character is simply discarded - the account login is not checked! -} - function TGoogleLogin.URLEncode(const S: string): string; var i, idx, len: Integer; @@ -468,12 +316,9 @@ constructor TGoogleLoginThread.Create(CreateSuspennded: BOOLEAN; aParamStr: stri FResultRec.SID := ''; FResultRec.LSID := ''; FResultRec.Auth := ''; - //переменные для прогресса FProgress:=0; FMaxProgress:=0; - //изображение капчи FCaptchaPic:=TPicture.Create; - end; procedure TGoogleLoginThread.Execute; @@ -485,46 +330,43 @@ procedure TGoogleLoginThread.Execute; var hInternet, hConnect, hRequest: pointer; dwBytesRead, i, L: cardinal; - sTemp: AnsiString; // текст страницы + sTemp: AnsiString; begin try hInternet := InternetOpen(PChar('GoogleLogin'),INTERNET_OPEN_TYPE_PRECONFIG, Nil, Nil, 0); if Assigned(hInternet) then begin - // Открываем сессию hConnect := InternetConnect(hInternet, PChar('www.google.com'), Flags_Connection, nil, nil, INTERNET_SERVICE_HTTP, 0, 1); if Assigned(hConnect) then begin - // Формируем запрос hRequest := HttpOpenRequest(hConnect, PChar(uppercase('post')), PChar('accounts/ClientLogin?' + FParamStr), HTTP_VERSION, nil, Nil, Flags_Request, 1); if Assigned(hRequest) then begin - // Отправляем запрос i := 1; if HttpSendRequest(hRequest, nil, 0, nil, 0) then begin repeat - DataAvailable(hRequest, L); // Получаем кол-во принимаемых данных + DataAvailable(hRequest, L); if L = 0 then break; SetLength(sTemp, L + i); if not InternetReadFile(hRequest, @sTemp[i], sizeof(L),dwBytesRead) then - break; // Получаем данные с сервера + break; inc(i, dwBytesRead); - if Terminated then // проверка для экстренного закрытия потока + if Terminated then begin InternetCloseHandle(hRequest); InternetCloseHandle(hConnect); InternetCloseHandle(hInternet); Exit; end; - FProgress:=i;//текущее значение прогресса авторизации - if FMaxProgress=0 then//зачем постоянно забивать максимальное значение + FProgress:=i; + if FMaxProgress=0 then FMaxProgress:=L+1; - Synchronize(SynProgressAutoriz);//синхронизация прогресса + Synchronize(SynProgressAutoriz); until dwBytesRead = 0; sTemp[i] := #0; end; @@ -533,23 +375,19 @@ procedure TGoogleLoginThread.Execute; end; except Synchronize(SynErrAutoriz); - Exit; // сваливаем отсюда + Exit; end; InternetCloseHandle(hRequest); InternetCloseHandle(hConnect); InternetCloseHandle(hInternet); - // получаем результаты авторизации FLastResult := ExpertLoginResult(sTemp); - // текстовый результат авторизации FResultRec.LoginStr := GetResultText; - //требует ввести капчу if FLastResult=lrCaptchaRequired then begin LoadCaptcha(FCaptchaURL); Synchronize(SynCaptcha); Synchronize(SynCapchaToken); end; - //если все хорошо, авторизировались if FLastResult<>lrCaptchaRequired then begin Synchronize(SynAutoriz); @@ -562,21 +400,20 @@ function TGoogleLoginThread.ExpertLoginResult(const LoginResult: string) List: TStringList; i: Integer; begin - // грузим ответ сервера в список +try List := TStringList.Create; List.Text := LoginResult; - // анализируем построчно - if pos('error', LowerCase(LoginResult)) > 0 then // есть сообщение об ошибке + if pos('error', LowerCase(LoginResult)) > 0 then begin for i := 0 to List.Count - 1 do begin - if pos('error', LowerCase(List[i])) > 0 then // строка с ошибкой + if pos('error', LowerCase(List[i])) > 0 then begin - Result := GetLoginError(List[i]); // получили тип ошибки + Result := GetLoginError(List[i]); break; end; end; - if Result = lrCaptchaRequired then // требуется ввод каптчи + if Result = lrCaptchaRequired then begin FCaptchaURL := GetCaptchaURL(List); FCapthaToken := GetCaptchaToken(List); @@ -598,8 +435,10 @@ function TGoogleLoginThread.ExpertLoginResult(const LoginResult: string) Length(List[i]) - pos('=', List[i]))); end; end; +finally FreeAndNil(List); end; +end; function TGoogleLoginThread.GetCaptchaToken(const cList: TStringList): String; var @@ -631,7 +470,6 @@ function TGoogleLoginThread.GetCaptchaURL(const cList: TStringList): string; end; end; -// Если параметр FromServer TRUE, то код ошибки и её текст берется с сервера, в противном случае берется текст локальной ошибки. function TGoogleLoginThread.GetErrorText(const FromServer: BOOLEAN): string; var Msg: array [0 .. 1023] of Char; @@ -655,9 +493,8 @@ function TGoogleLoginThread.GetLoginError(const str: string): TLoginResult; var ErrorText: string; begin - // получили текст ошибки ErrorText := Trim(copy(str, pos('=', str) + 1, Length(str) - pos('=', str))); - Result := TLoginResult(AnsiIndexStr(ErrorText, Errors) + 2); + Result:=TLoginResult(GetEnumValue(TypeInfo(TLoginResult),'lr'+ErrorText)); end; function TGoogleLoginThread.GetResultText: string; @@ -688,7 +525,6 @@ function TGoogleLoginThread.GetResultText: string; end; end; -//загрузка капчи function TGoogleLoginThread.LoadCaptcha(aCaptchaURL: string): Boolean; function DataAvailable(hRequest: pointer; out Size: cardinal): BOOLEAN; begin @@ -697,14 +533,14 @@ function TGoogleLoginThread.LoadCaptcha(aCaptchaURL: string): Boolean; var hInternet, hConnect,hRequest: pointer; dwBytesRead, i, L: cardinal; - sTemp: AnsiString; // текст страницы + sTemp: AnsiString; memStream: TMemoryStream; jpegimg: TJPEGImage; url:string; begin Result:=False;; url:='http://www.google.com/accounts/'+aCaptchaURL; - hInternet := InternetOpen('MyApp', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); + hInternet := InternetOpen('GoogleLogin', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); try if Assigned(hInternet) then begin @@ -715,10 +551,9 @@ function TGoogleLoginThread.LoadCaptcha(aCaptchaURL: string): Boolean; repeat SetLength(sTemp, L + i); if not InternetReadFile(hConnect, @sTemp[i], sizeof(L),dwBytesRead) then - break; // Получаем данные с сервера + break; inc(i, dwBytesRead); until dwBytesRead = 0; - //sTemp[i] := #0; finally InternetCloseHandle(hConnect); end; @@ -731,11 +566,9 @@ function TGoogleLoginThread.LoadCaptcha(aCaptchaURL: string): Boolean; try memStream.Write(sTemp[1], Length(sTemp)); memStream.Position := 0; - //загрузка изображения из потока jpegimg.LoadFromStream(memStream); FCaptchaPic.Assign(jpegimg); finally - //очистка memStream.Free; jpegimg.Free; end; @@ -748,7 +581,6 @@ procedure TGoogleLoginThread.SynAutoriz; OnAutorization(FLastResult, FResultRec); end; -//необходимо ввести капчу procedure TGoogleLoginThread.SynCapchaToken; begin if Assigned(FParentComp) then @@ -764,14 +596,13 @@ procedure TGoogleLoginThread.SynCaptcha; procedure TGoogleLoginThread.SynErrAutoriz; begin if Assigned(FErrorAutorization) then - OnError(GetErrorText(true)); // получаем текст ошибки + OnError(GetErrorText(true)); end; - procedure TGoogleLoginThread.SynProgressAutoriz; begin if Assigned(FProgressAutorization) then - OnProgressAutorization(FProgress,FMaxProgress); // передаем прогресс авторизации + OnProgressAutorization(FProgress,FMaxProgress); end; end. diff --git a/packages/translator_pack/Translator_pack.dpk b/packages/translator_pack/Translator_pack.dpk index 001c4a0..487cdb9 100644 --- a/packages/translator_pack/Translator_pack.dpk +++ b/packages/translator_pack/Translator_pack.dpk @@ -25,6 +25,11 @@ package Translator_pack; {$IMPLICITBUILD ON} requires - rtl; + rtl, + vcl; + +contains + GTranslate in '..\..\source\GTranslate.pas', + superobject in '..\..\addons\superobject\superobject.pas'; end. diff --git a/packages/translator_pack/Translator_pack.dproj b/packages/translator_pack/Translator_pack.dproj index a2e715e..a268786 100644 --- a/packages/translator_pack/Translator_pack.dproj +++ b/packages/translator_pack/Translator_pack.dproj @@ -2,9 +2,13 @@ {A8A6F560-7E36-46FD-9177-49EC16EFFD9B} Translator_pack.dpk - 12.0 + 12.3 Debug DCC32 + True + Win32 + Package + VCL true @@ -42,29 +46,29 @@ MainSource - - Base - + + + Cfg_2 Base + + Base + Cfg_1 Base - + + Delphi.Personality.12 Package - - False - True - False - + True False @@ -94,12 +98,15 @@ File G:\notepad gnu\SynEdit\Source\SynEdit_D5.bpl not found - Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office 2000 Sample Automation Server Wrapper Components Translator_pack.dpk + + True + 12 diff --git a/packages/translator_pack/Translator_pack.res b/packages/translator_pack/Translator_pack.res index fc1937e..7940876 100644 Binary files a/packages/translator_pack/Translator_pack.res and b/packages/translator_pack/Translator_pack.res differ diff --git a/source/GData.pas b/source/GData.pas index b29871d..9ab1598 100644 --- a/source/GData.pas +++ b/source/GData.pas @@ -1,5 +1,3 @@ -<<<<<<< HEAD -<<<<<<< HEAD unit GData; interface @@ -7,7 +5,7 @@ interface uses strutils, GHelper, XMLIntf,SysUtils, Variants, Classes, StdCtrls, XMLDoc, xmldom, GDataCommon; -// +// элемены протокола type TAuthorElement = record Email: string; @@ -217,10 +215,10 @@ function TEntryElement.FindGDElement(aElementName: TgdEnum; resNode := nil; FindName := GetNodeName(aElementName); i := 0; - iNode := FCommonElements[0]; // + iNode := FCommonElements[0]; // стартуем с первого элемента while (i > Length(FCommonElements)) or (resNode = nil) do begin - ProcessNode(iNode); // + ProcessNode(iNode); // Рекурсия i := i + 1; iNode := FCommonElements[i]; end; @@ -358,11 +356,11 @@ procedure TEntryElement.GetGDList; begin // i:=0; -// iNode := FCommonElements[0]; // +// iNode := FCommonElements[0]; // стартуем с первого элемента for I := 0 to Length(FCommonElements) - 1 do begin iNode:=FCommonElements[i]; - ProcessNode(iNode); // + ProcessNode(iNode); // Рекурсия end; end; @@ -510,1035 +508,4 @@ procedure TGDElemntList.SetRecord(index: Integer; Ptr: PGDElement); end; end; -end. -======= -======= ->>>>>>> remotes/origin/NMD -unit GData; - -interface - -uses strutils, GHelper, XMLIntf,SysUtils, Variants, Classes, - StdCtrls, XMLDoc, xmldom, GDataCommon; - -// -type - TAuthorElement = record - Email: string; - Name: string; - end; - -type - TLinkElement = record - rel: string; - typ: string; - href: string; - end; - -type - PLinkElement = ^TLinkElement; - -type - TLinkElementList = class(TList) - private - procedure SetRecord(index: Integer; Ptr: PLinkElement); - function GetRecord(index: Integer): PLinkElement; - public - constructor Create; - procedure Clear; - destructor Destroy; override; - property LinkElement[i: Integer] - : PLinkElement read GetRecord write SetRecord; - end; - -type - TGeneratorElement = record - varsion: string; - uri: string; - name: string; - end; - -type - TCategoryElement = record - scheme: string; - term: string; - clabel: string; - end; - -type - TCommonElements = array of IXMLNode; - -type - TGDElement = record - ElementType : TgdEnum; - XMLNode: IXMLNode; -end; - -type - PGDElement = ^TGDElement; - -type - TGDElemntList = class(TList) - private - procedure SetRecord(index: Integer; Ptr: PGDElement); - function GetRecord(index: Integer): PGDElement; - public - constructor Create; - procedure Clear; - destructor Destroy; override; - property GDElement[i: Integer]: PGDElement read GetRecord write SetRecord; - -end; - -type - TEntryElement = class - private - FXMLNode: IXMLNode; - FTerm: TEntryTerms; - FEtag: string; - FId: string; - FTitle: string; - FSummary: string; - FContent: string; - FAuthor: TAuthorElement; - FCategory: TCategoryElement; - FPublicationDate: TDateTime; - FUpdateDate: TDateTime; - FLinks: TLinkElementList; - FCommonElements: TCommonElements; - FGDElemntList:TGDElemntList; - procedure GetBasicElements; - function GetNodeName(aElementName: TgdEnum): string; - procedure GetGDList; - function GetEntryTerm: TEntryTerms; - public - constructor Create(aXMLNode: IXMLNode); - function FindGDElement(aElementName: TgdEnum; var resNode: IXMLNode) - : boolean; - property ETag: string read FEtag; - property ID: string read FId; - property Title: string read FTitle; - property Summary: string read FSummary; - property Content: string read FContent; - property Author: TAuthorElement read FAuthor; - property Category: TCategoryElement read FCategory; - property Publication: TDateTime read FPublicationDate; - property Update: TDateTime read FUpdateDate; - property Links: TLinkElementList read FLinks; - property CommonElements: TCommonElements read FCommonElements; - property GDElemntList:TGDElemntList read FGDElemntList; - property Term: TEntryTerms read GetEntryTerm; - end; - - - - -implementation - - - -{ TLinkElementList } - -procedure TLinkElementList.Clear; -var - i: Integer; - p: PLinkElement; -begin - for i := 0 to Pred(Count) do - begin - p := LinkElement[i]; - if p <> nil then - Dispose(p); - end; - inherited Clear; -end; - -constructor TLinkElementList.Create; -begin - inherited Create; -end; - -destructor TLinkElementList.Destroy; -begin - Clear; - inherited Destroy; - -end; - -function TLinkElementList.GetRecord(index: Integer): PLinkElement; -begin - Result := PLinkElement(Items[index]); -end; - -procedure TLinkElementList.SetRecord(index: Integer; Ptr: PLinkElement); -var - p: PLinkElement; -begin - p := LinkElement[index]; - if p <> Ptr then - begin - if p <> nil then - Dispose(p); - Items[index] := Ptr; - end; -end; - -{ TEntryElemet } - -constructor TEntryElement.Create(aXMLNode: IXMLNode); -var - i: TgdEnum; -begin - if aXMLNode = nil then - Exit; - FXMLNode := aXMLNode; - FLinks := TLinkElementList.Create; - FGDElemntList:=TGDElemntList.Create; - GetBasicElements; - GetGDList; -end; - -function TEntryElement.FindGDElement(aElementName: TgdEnum; - var resNode: IXMLNode): boolean; -var - FindName: string; - i: Integer; - iNode: IXMLNode; - - procedure ProcessNode(Node: IXMLNode); - var - cNode: IXMLNode; - begin - if Node = nil then - Exit; - if LowerCase(FCommonElements[i].NodeName) = LowerCase(FindName) then - begin - resNode := FCommonElements[i]; - Exit; - end - else - begin - cNode := Node.ChildNodes.First; - while cNode <> nil do - begin - ProcessNode(cNode); - cNode := cNode.NextSibling; - end; - end; - end; - -begin - resNode := nil; - FindName := GetNodeName(aElementName); - i := 0; - iNode := FCommonElements[0]; // - while (i > Length(FCommonElements)) or (resNode = nil) do - begin - ProcessNode(iNode); // - i := i + 1; - iNode := FCommonElements[i]; - end; -end; - -procedure TEntryElement.GetBasicElements; -var - i: Integer; - LinkElement: PLinkElement; -begin - if FXMLNode.Attributes['gd:etag'] <> null then - FEtag := FXMLNode.Attributes['gd:etag']; - for i := 0 to FXMLNode.ChildNodes.Count - 1 do - begin - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'id' then - FId := FXMLNode.ChildNodes[i].Text - else - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'published' then - FPublicationDate := ServerDateToDateTime(FXMLNode.ChildNodes[i].Text) - else - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'updated' then - FUpdateDate := ServerDateToDateTime(FXMLNode.ChildNodes[i].Text) - else - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'category' then - begin - if FXMLNode.ChildNodes[i].Attributes['scheme'] <> null then - FCategory.scheme := FXMLNode.ChildNodes[i].Attributes['scheme']; - if FXMLNode.ChildNodes[i].Attributes['term'] <> null then - FCategory.term := FXMLNode.ChildNodes[i].Attributes['term']; - end - else - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'title' then - FTitle := FXMLNode.ChildNodes[i].Text - else - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'content' then - FContent := FXMLNode.ChildNodes[i].Text - else - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'link' then - begin - New(LinkElement); - with LinkElement^ do - begin - if FXMLNode.ChildNodes[i].Attributes['rel'] <> null then - rel := FXMLNode.ChildNodes[i].Attributes['rel']; - if FXMLNode.ChildNodes[i].Attributes['type'] <> null then - typ := FXMLNode.ChildNodes[i].Attributes['type']; - if FXMLNode.ChildNodes[i].Attributes['href'] <> null then - href := FXMLNode.ChildNodes[i].Attributes['href']; - end; - FLinks.Add(LinkElement); - end - else - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'author' then - begin - if FXMLNode.ChildNodes[i].ChildNodes.FindNode('name') - <> nil then - FAuthor.Name := FXMLNode.ChildNodes[i].ChildNodes.FindNode - ('name').Text; - if FXMLNode.ChildNodes[i].ChildNodes.FindNode('email') - <> nil then - FAuthor.Name := FXMLNode.ChildNodes[i].ChildNodes.FindNode - ('email').Text; - end - else - if (LowerCase(FXMLNode.ChildNodes[i].NodeName) - = 'description') or - (LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'summary') - then - FSummary := FXMLNode.ChildNodes[i].Text - else - begin - SetLength(FCommonElements, Length(FCommonElements) + 1); - FCommonElements[Length(FCommonElements) - 1] := - FXMLNode.ChildNodes[i]; - end; - end; -end; - -function TEntryElement.GetEntryTerm: TEntryTerms; -var - TermStr: string; -begin - FTerm := ttAny; - if Length(FCategory.term) = 0 then - Exit; - TermStr := copy(FCategory.term, pos('#', FCategory.term) + 1, Length - (FCategory.term) - pos('#', FCategory.term)); - if LowerCase(TermStr) = 'contact' then - Result := ttContact - else - if LowerCase(TermStr) = 'event' then - Result := ttEvent - else - if LowerCase(TermStr) = 'message' then - Result := ttMessage - else - if LowerCase(TermStr) = 'type' then - Result := ttType -end; - -procedure TEntryElement.GetGDList; -var - i: Integer; - iNode: IXMLNode; - - procedure ProcessNode(Node: IXMLNode); - var - cNode: IXMLNode; - Index: integer; - NodeType: TgdEnum; - GDElemet: PGDElement; - begin - if (Node = nil)or(pos('gd:',Node.NodeName)<=0) then Exit; - Index:=GetGDNodeType(Node.NodeName); - if index>-1 then - begin - NodeType:=TgdEnum(index); - New(GDElemet); - with GDElemet^ do - begin - ElementType:=NodeType; - XMLNode:=Node; - end; - FGDElemntList.Add(GDElemet); - // ShowMessage(IntToStr(FGDElemntList.Count)); - end; - - cNode := Node.ChildNodes.First; - while cNode <> nil do - begin - ProcessNode(cNode); - cNode := cNode.NextSibling; - end; - end; - -begin -// i:=0; -// iNode := FCommonElements[0]; // - for I := 0 to Length(FCommonElements) - 1 do - begin - iNode:=FCommonElements[i]; - ProcessNode(iNode); // - end; - -end; - -function TEntryElement.GetNodeName(aElementName: TgdEnum): string; -begin -Result:=cGDTagNames[ord(aElementName)]; -// case aElementName of -// gdCountry: -// Result := 'gd:country'; -// gdAdditionalName: -// Result := 'gd:additionalName'; -// gdName: -// Result := 'gd:country'; -// gdEmail: -// Result := 'gd:email'; -// gdExtendedProperty: -// Result := 'gd:extendedProperty'; -// gdGeoPt: -// Result := 'gd:geoPt'; -// gdIm: -// Result := 'gd:im'; -// gdOrgName: -// Result := 'gd:orgName'; -// gdOrgTitle: -// Result := 'gd:orgTitle'; -// gdOrganization: -// Result := 'gd:organization'; -// gdOriginalEvent: -// Result := 'gd:originalEvent'; -// gdPhoneNumber: -// Result := 'gd:phoneNumber'; -// gdPostalAddress: -// Result := 'gd:postalAddress'; -// gdRating: -// Result := 'gd:rating'; -// gdRecurrence: -// Result := 'gd:recurrence'; -// gdReminder: -// Result := 'gd:reminder'; -// gdResourceId: -// Result := 'gd:resourceId'; -// gdWhen: -// Result := 'gd:when'; -// gdAgent: -// Result := 'gd:agent'; -// gdHousename: -// Result := 'gd:housename'; -// gdStreet: -// Result := 'gd:street'; -// gdPobox: -// Result := 'gd:pobox'; -// gdNeighborhood: -// Result := 'gd:neighborhood'; -// gdCity: -// Result := 'gd:city'; -// gdSubregion: -// Result := 'gd:subregion'; -// gdRegion: -// Result := 'gd:region'; -// gdPostcode: -// Result := 'gd:postcode'; -// gdFormattedAddress: -// Result := 'gd:formattedaddress'; -// gdStructuredPostalAddress: -// Result := 'gd:structuredPostalAddress'; -// gdEntryLink: -// Result := 'gd:entryLink'; -// gdWhere: -// Result := 'gd:where'; -// gdFamilyName: -// Result := 'gd:familyName'; -// gdGivenName: -// Result := 'gd:givenName'; -// gdFamileName: -// Result := 'gd:FamileName'; -// gdNamePrefix: -// Result := 'gd:namePrefix'; -// gdNameSuffix: -// Result := 'gd:nameSuffix'; -// gdFullName: -// Result := 'gd:fullName'; -// gdOrgDepartment: -// Result := 'gd:orgDepartment'; -// gdOrgJobDescription: -// Result := 'gd:orgJobDescription'; -// gdOrgSymbol: -// Result := 'gd:orgSymbol'; -// gdEventStatus: -// Result := 'gd:eventStatus'; -// gdVisibility: -// Result := 'gd:visibility'; -// gdTransparency: -// Result := 'gd:transparency'; -// gdAttendeeType: -// Result := 'gd:attendeeType'; -// gdAttendeeStatus: -// Result := 'gd:attendeeStatus'; -// end; -end; - -{ GDElemntList } - -procedure TGDElemntList.Clear; -var - i: Integer; - p: PGDElement; -begin - for i := 0 to Pred(Count) do - begin - p := GDElement[i]; - if p <> nil then - Dispose(p); - end; - inherited Clear; -end; - - -constructor TGDElemntList.Create; -begin - inherited Create; -end; - -destructor TGDElemntList.Destroy; -begin - Clear; - inherited Destroy; -end; - -function TGDElemntList.GetRecord(index: Integer): PGDElement; -begin - Result:= PGDElement(Items[index]); -end; - -procedure TGDElemntList.SetRecord(index: Integer; Ptr: PGDElement); -var - p: PGDElement; -begin - p := GDElement[index]; - if p <> Ptr then - begin - if p <> nil then - Dispose(p); - Items[index] := Ptr; - end; -end; - -end. -<<<<<<< HEAD ->>>>>>> remotes/origin/NMD -======= -======= -unit GData; - -interface - -uses strutils, GHelper, XMLIntf,SysUtils, Variants, Classes, - StdCtrls, XMLDoc, xmldom, GDataCommon; - -// -type - TAuthorElement = record - Email: string; - Name: string; - end; - -type - TLinkElement = record - rel: string; - typ: string; - href: string; - end; - -type - PLinkElement = ^TLinkElement; - -type - TLinkElementList = class(TList) - private - procedure SetRecord(index: Integer; Ptr: PLinkElement); - function GetRecord(index: Integer): PLinkElement; - public - constructor Create; - procedure Clear; - destructor Destroy; override; - property LinkElement[i: Integer] - : PLinkElement read GetRecord write SetRecord; - end; - -type - TGeneratorElement = record - varsion: string; - uri: string; - name: string; - end; - -type - TCategoryElement = record - scheme: string; - term: string; - clabel: string; - end; - -type - TCommonElements = array of IXMLNode; - -type - TGDElement = record - ElementType : TgdEnum; - XMLNode: IXMLNode; -end; - -type - PGDElement = ^TGDElement; - -type - TGDElemntList = class(TList) - private - procedure SetRecord(index: Integer; Ptr: PGDElement); - function GetRecord(index: Integer): PGDElement; - public - constructor Create; - procedure Clear; - destructor Destroy; override; - property GDElement[i: Integer]: PGDElement read GetRecord write SetRecord; - -end; - -type - TEntryElement = class - private - FXMLNode: IXMLNode; - FTerm: TEntryTerms; - FEtag: string; - FId: string; - FTitle: string; - FSummary: string; - FContent: string; - FAuthor: TAuthorElement; - FCategory: TCategoryElement; - FPublicationDate: TDateTime; - FUpdateDate: TDateTime; - FLinks: TLinkElementList; - FCommonElements: TCommonElements; - FGDElemntList:TGDElemntList; - procedure GetBasicElements; - function GetNodeName(aElementName: TgdEnum): string; - procedure GetGDList; - function GetEntryTerm: TEntryTerms; - public - constructor Create(aXMLNode: IXMLNode); - function FindGDElement(aElementName: TgdEnum; var resNode: IXMLNode) - : boolean; - property ETag: string read FEtag; - property ID: string read FId; - property Title: string read FTitle; - property Summary: string read FSummary; - property Content: string read FContent; - property Author: TAuthorElement read FAuthor; - property Category: TCategoryElement read FCategory; - property Publication: TDateTime read FPublicationDate; - property Update: TDateTime read FUpdateDate; - property Links: TLinkElementList read FLinks; - property CommonElements: TCommonElements read FCommonElements; - property GDElemntList:TGDElemntList read FGDElemntList; - property Term: TEntryTerms read GetEntryTerm; - end; - - - - -implementation - - - -{ TLinkElementList } - -procedure TLinkElementList.Clear; -var - i: Integer; - p: PLinkElement; -begin - for i := 0 to Pred(Count) do - begin - p := LinkElement[i]; - if p <> nil then - Dispose(p); - end; - inherited Clear; -end; - -constructor TLinkElementList.Create; -begin - inherited Create; -end; - -destructor TLinkElementList.Destroy; -begin - Clear; - inherited Destroy; - -end; - -function TLinkElementList.GetRecord(index: Integer): PLinkElement; -begin - Result := PLinkElement(Items[index]); -end; - -procedure TLinkElementList.SetRecord(index: Integer; Ptr: PLinkElement); -var - p: PLinkElement; -begin - p := LinkElement[index]; - if p <> Ptr then - begin - if p <> nil then - Dispose(p); - Items[index] := Ptr; - end; -end; - -{ TEntryElemet } - -constructor TEntryElement.Create(aXMLNode: IXMLNode); -var - i: TgdEnum; -begin - if aXMLNode = nil then - Exit; - FXMLNode := aXMLNode; - FLinks := TLinkElementList.Create; - FGDElemntList:=TGDElemntList.Create; - GetBasicElements; - GetGDList; -end; - -function TEntryElement.FindGDElement(aElementName: TgdEnum; - var resNode: IXMLNode): boolean; -var - FindName: string; - i: Integer; - iNode: IXMLNode; - - procedure ProcessNode(Node: IXMLNode); - var - cNode: IXMLNode; - begin - if Node = nil then - Exit; - if LowerCase(FCommonElements[i].NodeName) = LowerCase(FindName) then - begin - resNode := FCommonElements[i]; - Exit; - end - else - begin - cNode := Node.ChildNodes.First; - while cNode <> nil do - begin - ProcessNode(cNode); - cNode := cNode.NextSibling; - end; - end; - end; - -begin - resNode := nil; - FindName := GetNodeName(aElementName); - i := 0; - iNode := FCommonElements[0]; // - while (i > Length(FCommonElements)) or (resNode = nil) do - begin - ProcessNode(iNode); // - i := i + 1; - iNode := FCommonElements[i]; - end; -end; - -procedure TEntryElement.GetBasicElements; -var - i: Integer; - LinkElement: PLinkElement; -begin - if FXMLNode.Attributes['gd:etag'] <> null then - FEtag := FXMLNode.Attributes['gd:etag']; - for i := 0 to FXMLNode.ChildNodes.Count - 1 do - begin - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'id' then - FId := FXMLNode.ChildNodes[i].Text - else - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'published' then - FPublicationDate := ServerDateToDateTime(FXMLNode.ChildNodes[i].Text) - else - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'updated' then - FUpdateDate := ServerDateToDateTime(FXMLNode.ChildNodes[i].Text) - else - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'category' then - begin - if FXMLNode.ChildNodes[i].Attributes['scheme'] <> null then - FCategory.scheme := FXMLNode.ChildNodes[i].Attributes['scheme']; - if FXMLNode.ChildNodes[i].Attributes['term'] <> null then - FCategory.term := FXMLNode.ChildNodes[i].Attributes['term']; - end - else - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'title' then - FTitle := FXMLNode.ChildNodes[i].Text - else - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'content' then - FContent := FXMLNode.ChildNodes[i].Text - else - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'link' then - begin - New(LinkElement); - with LinkElement^ do - begin - if FXMLNode.ChildNodes[i].Attributes['rel'] <> null then - rel := FXMLNode.ChildNodes[i].Attributes['rel']; - if FXMLNode.ChildNodes[i].Attributes['type'] <> null then - typ := FXMLNode.ChildNodes[i].Attributes['type']; - if FXMLNode.ChildNodes[i].Attributes['href'] <> null then - href := FXMLNode.ChildNodes[i].Attributes['href']; - end; - FLinks.Add(LinkElement); - end - else - if LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'author' then - begin - if FXMLNode.ChildNodes[i].ChildNodes.FindNode('name') - <> nil then - FAuthor.Name := FXMLNode.ChildNodes[i].ChildNodes.FindNode - ('name').Text; - if FXMLNode.ChildNodes[i].ChildNodes.FindNode('email') - <> nil then - FAuthor.Name := FXMLNode.ChildNodes[i].ChildNodes.FindNode - ('email').Text; - end - else - if (LowerCase(FXMLNode.ChildNodes[i].NodeName) - = 'description') or - (LowerCase(FXMLNode.ChildNodes[i].NodeName) = 'summary') - then - FSummary := FXMLNode.ChildNodes[i].Text - else - begin - SetLength(FCommonElements, Length(FCommonElements) + 1); - FCommonElements[Length(FCommonElements) - 1] := - FXMLNode.ChildNodes[i]; - end; - end; -end; - -function TEntryElement.GetEntryTerm: TEntryTerms; -var - TermStr: string; -begin - FTerm := ttAny; - if Length(FCategory.term) = 0 then - Exit; - TermStr := copy(FCategory.term, pos('#', FCategory.term) + 1, Length - (FCategory.term) - pos('#', FCategory.term)); - if LowerCase(TermStr) = 'contact' then - Result := ttContact - else - if LowerCase(TermStr) = 'event' then - Result := ttEvent - else - if LowerCase(TermStr) = 'message' then - Result := ttMessage - else - if LowerCase(TermStr) = 'type' then - Result := ttType -end; - -procedure TEntryElement.GetGDList; -var - i: Integer; - iNode: IXMLNode; - - procedure ProcessNode(Node: IXMLNode); - var - cNode: IXMLNode; - Index: integer; - NodeType: TgdEnum; - GDElemet: PGDElement; - begin - if (Node = nil)or(pos('gd:',Node.NodeName)<=0) then Exit; - Index:=ord(GetGDNodeType(Node.NodeName)); - if index>-1 then - begin - NodeType:=TgdEnum(index); - New(GDElemet); - with GDElemet^ do - begin - ElementType:=NodeType; - XMLNode:=Node; - end; - FGDElemntList.Add(GDElemet); - // ShowMessage(IntToStr(FGDElemntList.Count)); - end; - - cNode := Node.ChildNodes.First; - while cNode <> nil do - begin - ProcessNode(cNode); - cNode := cNode.NextSibling; - end; - end; - -begin -// i:=0; -// iNode := FCommonElements[0]; // - for I := 0 to Length(FCommonElements) - 1 do - begin - iNode:=FCommonElements[i]; - ProcessNode(iNode); // - end; - -end; - -function TEntryElement.GetNodeName(aElementName: TgdEnum): string; -begin -Result:=GetGDNodeName(aElementName); -// case aElementName of -// gdCountry: -// Result := 'gd:country'; -// gdAdditionalName: -// Result := 'gd:additionalName'; -// gdName: -// Result := 'gd:country'; -// gdEmail: -// Result := 'gd:email'; -// gdExtendedProperty: -// Result := 'gd:extendedProperty'; -// gdGeoPt: -// Result := 'gd:geoPt'; -// gdIm: -// Result := 'gd:im'; -// gdOrgName: -// Result := 'gd:orgName'; -// gdOrgTitle: -// Result := 'gd:orgTitle'; -// gdOrganization: -// Result := 'gd:organization'; -// gdOriginalEvent: -// Result := 'gd:originalEvent'; -// gdPhoneNumber: -// Result := 'gd:phoneNumber'; -// gdPostalAddress: -// Result := 'gd:postalAddress'; -// gdRating: -// Result := 'gd:rating'; -// gdRecurrence: -// Result := 'gd:recurrence'; -// gdReminder: -// Result := 'gd:reminder'; -// gdResourceId: -// Result := 'gd:resourceId'; -// gdWhen: -// Result := 'gd:when'; -// gdAgent: -// Result := 'gd:agent'; -// gdHousename: -// Result := 'gd:housename'; -// gdStreet: -// Result := 'gd:street'; -// gdPobox: -// Result := 'gd:pobox'; -// gdNeighborhood: -// Result := 'gd:neighborhood'; -// gdCity: -// Result := 'gd:city'; -// gdSubregion: -// Result := 'gd:subregion'; -// gdRegion: -// Result := 'gd:region'; -// gdPostcode: -// Result := 'gd:postcode'; -// gdFormattedAddress: -// Result := 'gd:formattedaddress'; -// gdStructuredPostalAddress: -// Result := 'gd:structuredPostalAddress'; -// gdEntryLink: -// Result := 'gd:entryLink'; -// gdWhere: -// Result := 'gd:where'; -// gdFamilyName: -// Result := 'gd:familyName'; -// gdGivenName: -// Result := 'gd:givenName'; -// gdFamileName: -// Result := 'gd:FamileName'; -// gdNamePrefix: -// Result := 'gd:namePrefix'; -// gdNameSuffix: -// Result := 'gd:nameSuffix'; -// gdFullName: -// Result := 'gd:fullName'; -// gdOrgDepartment: -// Result := 'gd:orgDepartment'; -// gdOrgJobDescription: -// Result := 'gd:orgJobDescription'; -// gdOrgSymbol: -// Result := 'gd:orgSymbol'; -// gdEventStatus: -// Result := 'gd:eventStatus'; -// gdVisibility: -// Result := 'gd:visibility'; -// gdTransparency: -// Result := 'gd:transparency'; -// gdAttendeeType: -// Result := 'gd:attendeeType'; -// gdAttendeeStatus: -// Result := 'gd:attendeeStatus'; -// end; -end; - -{ GDElemntList } - -procedure TGDElemntList.Clear; -var - i: Integer; - p: PGDElement; -begin - for i := 0 to Pred(Count) do - begin - p := GDElement[i]; - if p <> nil then - Dispose(p); - end; - inherited Clear; -end; - - -constructor TGDElemntList.Create; -begin - inherited Create; -end; - -destructor TGDElemntList.Destroy; -begin - Clear; - inherited Destroy; -end; - -function TGDElemntList.GetRecord(index: Integer): PGDElement; -begin - Result:= PGDElement(Items[index]); -end; - -procedure TGDElemntList.SetRecord(index: Integer; Ptr: PGDElement); -var - p: PGDElement; -begin - p := GDElement[index]; - if p <> Ptr then - begin - if p <> nil then - Dispose(p); - Items[index] := Ptr; - end; -end; - -end. ->>>>>>> remotes/origin/Vlad55 ->>>>>>> remotes/origin/NMD +end. \ No newline at end of file diff --git a/source/GTasksAPI.pas b/source/GTasksAPI.pas new file mode 100644 index 0000000..3bca777 --- /dev/null +++ b/source/GTasksAPI.pas @@ -0,0 +1,343 @@ +unit GTasksAPI; + +interface + +uses Classes, SysUtils, httpsend, GoogleOAuth, synacode, ssl_openssl,Dialogs; + +const + /// Версия API + APIVersion = '1'; + /// Точка доступа к API для чтения и записи данных + APIScope = 'https://www.googleapis.com/auth/tasks'; + /// Точка доступа к API только для чтения данных + APIScopeReadOnly = 'https://www.googleapis.com/auth/tasks.readonly'; + /// шаблон составления URL для обращения к ресурсам API + URI = 'https://www.googleapis.com/tasks/v%s/%s/%s/%s%s'; + /// Шаблон авторизации по протоколу OAuth 2.0 + // AuthHeader = 'Authorization: OAuth %s'; + /// Список с заданиями по умолчанию + DefaultList = '@default'; + /// Пользователь по умолчанию + DefaultUser = '@me'; + +type + {$REGION 'Описание класса'} + /// + /// Базовый класс для отправки запросов к API и получения ответов сервера. + /// Все результаты выполнения функций передаются в виде строки, содержащей + /// JSON-объекты, определенные в официальной документации: + /// + /// http://code.google.com/intl/ru-RU/apis/tasks/v1/reference.html + /// + {$ENDREGION} + TGTaskAPI = class + private + FOAuthClient: TOAuth; + function GetVersion: string; + procedure SetOAuthClient(const Value: TOAuth); + public + constructor Create; + destructor Destroy;override; + {$REGION 'Описание метода Lists.List'} + /// Возвращает все списки заданий для пользователя. + /// Набор свойств каждого спска заданий описан в официальной документации, + /// находящейся по адресу + /// + /// http://code.google.com/intl/ru-RU/apis/tasks/v1/reference.html#resource_tasklists + /// + /// + /// Максимальное количество элементов, возвращаемых в результате + /// + /// + /// Токен страницы, которую необходимо вернуть в результате + /// + /// + /// string + /// Возвращает JSON-объект, содержащий коллекцию списков заданий пользователя. + /// Пример: + /// в официальной документации + /// + {$ENDREGION} + function ListsList(maxResults: string = ''; + pageToken: string = ''): string; + {$REGION 'Описание метода Lists.Get'} + /// Возвращает данные по одному списку заданий пользователя + /// Набор свойств каждого спска заданий описан в официальной документации, + /// находящейся по адресу + /// + /// http://code.google.com/intl/ru-RU/apis/tasks/v1/reference.html#resource_tasklists + /// + /// + /// Идентификатор списка + /// + /// + /// stringВозвращает JSON-объект, содержащий свойства списка + /// Пример: + /// в официальной документации + /// + {$ENDREGION} + function ListsGet(const ListID: string): string; + {$REGION 'Описание метода List.Insert'} + /// Добавляет новый список заданий к аккаунту пользователя + /// Список должен формироваться в JSON-формате и содержать одно или несколько свойств, + /// определенных в официальной документации, расположенной по адресу: + /// + /// http://code.google.com/intl/ru-RU/apis/tasks/v1/reference.html#resource_tasklists + /// + /// + /// Поток, содержащий JSON-объект списка заданий + /// + /// + /// stringВозвращает JSON-объект, содержащий свойства созданного списка + /// Пример: + /// в официальной документации + /// + {$ENDREGION} + function ListsInsert(JSONStream: TStringStream):string; + {$REGION 'Описание метода Tasks.List'} + /// Возвращает набор всех заданий из определенного списка. + /// Набор свойств для каждого задания определен в официальной документации, + /// расположенной по адресу: + /// + /// http://code.google.com/intl/ru-RU/apis/tasks/v1/reference.html#resource_tasks + /// + /// + /// Идентификатор списка + /// + /// + /// string + /// Возвращает JSON-объект, содержащий коллекцию заданий из списка пользователя + /// Пример: + /// в официальной документации + /// + {$ENDREGION} + function TasksList(const ListID: string):string;overload; + {$REGION 'Описание метода Tasks.List'} + /// Возвращает набор всех заданий из определенного списка. + /// Набор свойств для каждого задания определен в официальной документации, + /// расположенной по адресу: + /// + /// http://code.google.com/intl/ru-RU/apis/tasks/v1/reference.html#resource_tasks + /// + {$ENDREGION} + function TasksList(const ListID: string; Params:TStrings):string;overload; + {$REGION 'Описание метода Tasks.Get'} + /// Возвращает набор свойств определенного задания из списка пользователя + /// Набор свойств для каждого задания определен в официальной документации, + /// расположенной по адресу: + /// + /// http://code.google.com/intl/ru-RU/apis/tasks/v1/reference.html#resource_tasks + /// + /// + /// Идентификатор списка + /// + {$ENDREGION} + function TasksGet(const ListID: string; TaskID:string):string;overload; + function TasksGet(const TaskID: string):string;overload; + {$REGION 'Описание метода Tasks.Insert'} + /// Добавляет новое задание к списку пользователя + /// Задание должно формироваться в JSON-формате и содержать одно или несколько свойств, + /// определенных в официальной документации, расположенной по адресу: + /// + /// http://code.google.com/intl/ru-RU/apis/tasks/v1/reference.html#resource_tasks + /// + /// + /// Идентификатор списка + /// + /// + /// + /// + /// + /// + /// + /// + /// + /// + {$ENDREGION} + function TasksInsert(const ListID, Parent, Previous: string; JSONStream: TStringStream):string; overload; + function TasksInsert(const ListID: string; JSONStream: TStringStream):string; overload; + function TasksInsert(const JSONStream: TStringStream):string; overload; + {$REGION 'Описание метода Tasks.Insert'} + /// + /// + /// + /// + /// Идентификатор списка + /// + /// + /// + /// + /// + /// + /// + /// + /// + /// + {$ENDREGION} function TasksMove(const ListID, TaskID, parentTaskID, previousTaskID:string):string;overload; + function TasksMove(const TaskID, parentTaskID, previousTaskID:string):string;overload; + + function TasksUpdate(const ListID,TaskID:string; JSONStream: TStringStream):string;overload; + function TasksUpdate(const TaskID:string; JSONStream: TStringStream):string;overload; + + function TasksDelete(const ListID,TaskID:string):boolean;overload; + function TasksDelete(const TaskID:string):boolean;overload; + + {$REGION 'Описание свойства Version'} + /// + {$ENDREGION} + property Version: string read GetVersion; + + property OAuthClient: TOAuth read FOAuthClient write SetOAuthClient; + end; + +implementation + +{ TGTaskAPI } + +constructor TGTaskAPI.Create; +begin + inherited Create; + FOAuthClient:=TOAuth.Create(nil); +end; + +destructor TGTaskAPI.Destroy; +begin + FOAuthClient.Free; + inherited Destroy; +end; + +function TGTaskAPI.GetVersion: string; +begin + Result := APIVersion; +end; + +function TGTaskAPI.ListsGet(const ListID: string): string; +begin + Result := UTF8ToString(OAuthClient.GETCommand(Format(URI, [Version, 'users', DefaultUser, + 'lists', '/' + ListID]), nil)); +end; + +function TGTaskAPI.ListsInsert(JSONStream: TStringStream): string; +begin + Result:=UTF8ToString(OAuthClient.POSTCommand(Format(URI,[Version,'users',DefaultUser,'lists','']),nil,JSONStream)) +end; + +function TGTaskAPI.ListsList(maxResults, pageToken: string): string; +var + Params: TStrings; + URL: string; +begin + URL := Format(URI, [Version, 'users', DefaultUser, 'lists', '']); + Params := TStringList.Create; + try + if Length(Trim(maxResults)) > 0 then + Params.Add('maxResults=' + maxResults); + if Length(Trim(pageToken)) > 0 then + Params.Add('pageToken=' + pageToken); + Result := UTF8ToString(OAuthClient.GETCommand(URL, Params)); + finally + Params.Free; + end; +end; + +procedure TGTaskAPI.SetOAuthClient(const Value: TOAuth); +begin + FOAuthClient := Value; +end; + +function TGTaskAPI.TasksList(const ListID: string): string; +begin + Result:=TasksList(ListID,nil) +end; + +function TGTaskAPI.TasksGet(const ListID: string; TaskID: string): string; +begin +Result := UTF8ToString(OAuthClient.GETCommand(Format(URI, [Version, 'lists', ListID, + 'tasks', '/'+TaskID]), nil)); +end; + +function TGTaskAPI.TasksDelete(const ListID, TaskID: string): boolean; +begin + Result:=Length(OAuthClient.DELETECommand(Format(URI, [Version, 'lists', ListID, + 'tasks', '/'+TaskID])))=0 +end; + +function TGTaskAPI.TasksDelete(const TaskID: string): boolean; +begin + Result:=TasksDelete(DefaultList,TaskID); +end; + +function TGTaskAPI.TasksGet(const TaskID: string): string; +begin + Result:=TasksGet(DefaultList,TaskID); +end; + +function TGTaskAPI.TasksInsert(const JSONStream: TStringStream): string; +begin + Result:=TasksInsert(DefaultList,JSONStream) +end; + +function TGTaskAPI.TasksInsert(const ListID, Parent, Previous: string; + JSONStream: TStringStream): string; +var Params:TStrings; +begin + Params:=TStringList.Create; + try + if Length(Trim(Parent))>0 then + Params.Values['parent']:=Parent; + if Length(Trim(Previous))>0 then + Params.Values['previous']:=Previous; + Result:=UTF8ToString(OAuthClient.POSTCommand(Format(URI,[Version,'lists',ListId,'tasks','']),Params,JSONStream)); + finally + Params.Free; + end; +end; + +function TGTaskAPI.TasksInsert(const ListID: string; + JSONStream: TStringStream): string; +begin + Result:=TasksInsert(ListID,'','',JSONStream); +end; + +function TGTaskAPI.TasksList(const ListID: string; Params: TStrings): string; +begin + Result := UTF8ToString(OAuthClient.GETCommand(Format(URI, [Version, 'lists', ListID, + 'tasks', '']), Params)); +end; + +function TGTaskAPI.TasksMove(const TaskID, parentTaskID, + previousTaskID: string): string; +begin + Result:=TasksMove(DefaultList,TaskID,parentTaskID,previousTaskID) +end; + +function TGTaskAPI.TasksUpdate(const TaskID: string; + JSONStream: TStringStream): string; +begin + Result:=TasksUpdate(DefaultList,TaskID,JSONStream); +end; + +function TGTaskAPI.TasksUpdate(const ListID, TaskID: string;JSONStream: TStringStream): string; +begin + Result := UTF8ToString(OAuthClient.PUTCommand(Format(URI, [Version, 'lists', ListID, + 'tasks', '/'+TaskID]),JSONStream)); +end; + +function TGTaskAPI.TasksMove(const ListID, TaskID, parentTaskID, + previousTaskID: string): string; +var Params: TStrings; +begin +Params:=TStringList.Create; +try + if Length(Trim(parentTaskID))>0 then + Params.Values['parent']:=parentTaskID; + if Length(Trim(previousTaskID))>0 then + Params.Values['previous']:=previousTaskID; + Result:=UTF8ToString(OAuthClient.POSTCommand(Format(URI,[Version,'lists',ListID,'tasks',TaskID,'/move']),Params,nil)); +finally + Params.Free; +end; + +end; + +end. diff --git a/source/GTranslate.pas b/source/GTranslate.pas index 832c80a..344ffec 100644 --- a/source/GTranslate.pas +++ b/source/GTranslate.pas @@ -1,46 +1,49 @@ -{ ==============================================================================| -|: Google API Delphi | -|==============================================================================| -|unit: GTranslate | -|==============================================================================| -|: Google (AJAX Language API). | -|==============================================================================| -|: | -|1. JSON- SuperObject | -|==============================================================================| -| : Vlad. (vlad383@gmail.com) | -| : 09.08.2010 | -| : . | -| Copyright (c) 2009-2010 WebDelphi.ru | -|==============================================================================| -| | -|==============================================================================| -| ܻ, | -| , , , | -| , | -| . | -| , | -| , , , | -| | -| . | -| | -| This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF | -| ANY KIND, either express or implied. | -|==============================================================================| -| | -|==============================================================================| -| GFeedBurner : | -| http://github.com/googleapi | -|==============================================================================| -| | -|==============================================================================| -| | -|==============================================================================} +{ =============================================================================| + |: Google API Delphi | + |============================================================================| + |unit: GTranslate | + |============================================================================| + |: Google. | + |============================================================================| + |: | + |1. JSON- SuperObject | + |============================================================================| + | : Vlad. (vlad383@gmail.com) | + | : 09.08.2010 | + | : . | + | Copyright (c) 2009-2010 WebDelphi.ru | + |============================================================================| + | | + |============================================================================| + | ܻ, | + | , , , | + | , | + | . | + | , | + | , , , | + | | + | . | + | | + | This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF | + | ANY KIND, either express or implied. | + |============================================================================| + | | + |============================================================================| + | GFeedBurner :| + | http://github.com/googleapi | + |============================================================================| + | | + |============================================================================| + |v. 0.2 | + | + API v.2 | + | + key: string - API | + |============================================================================ } unit GTranslate; interface -uses windows, msxml, superobject, classes, variants, sysutils, typinfo; +uses windows, superobject, classes, variants, sysutils, typinfo,synacode, + ssl_openssl,httpsend,Dialogs; resourcestring rsLangUnknown = ' '; @@ -104,7 +107,9 @@ interface rsLang_ja = ''; rsErrorDestLng = ' .. '; - rsErrorTrnsl = ' : %s'; + rsErrorTrnsl = ' '; + rsErrLagrgeReq = + ' 5000'; type TLanguageEnum = (unknown, lng_af, lng_sq, lng_ar, lng_hy, lng_az, lng_eu, @@ -129,7 +134,7 @@ TLanguageRec = record const Languages: array [0 .. 57] of TLanguageRec = - ((Name:rsLangAuto; Ident: unknown), + ((Name: rsLangAuto; Ident: unknown), (Name: rsLang_en; Ident: lng_en), (Name: rsLang_ru; Ident: lng_ru), (Name: rsLang_it; Ident: lng_it), (Name: rsLang_az; Ident: lng_az), (Name: rsLang_sq; Ident: lng_sq), (Name: rsLang_ar; Ident: lng_ar), @@ -160,16 +165,14 @@ TLanguageRec = record (Name: rsLang_sv; Ident: lng_sv), (Name: rsLang_et; Ident: lng_et), (Name: rsLang_ja; Ident: lng_ja)); - cTranslateURL = 'http://ajax.googleapis.com/ajax/services/language/translate'; - cDetectURL = 'http://ajax.googleapis.com/ajax/services/language/detect'; - cTranslatedPath = 'responseData.translatedText'; - cDetectedLangPath = 'responseData.detectedSourceLanguage'; - cResponcePath = 'responseStatus'; - cResponceTextPath = 'responseDetails'; - APIVersion = '1.0'; - TranslatorVersion = '0.1'; - URLSpecialChar: TSpecials = [#$00 .. #$20, '_', '<', '>', '"', '%', '{', '}', - '|', '\', '^', '~', '[', ']', '`', #$7F .. #$FF]; + cTranslateURL = 'https://www.googleapis.com/language/translate/v'; + cMaxGet = 2000; + cMaxPost = 5000; + + APIVersion = '2'; + TranslatorVersion = '0.2'; +// URLSpecialChar: TSpecials = [#$00 .. #$20, '_', '<', '>', '"', '%', '{', '}', +// '|', '\', '^', '~', '[', ']', '`', #$7F .. #$FF]; type TOnTranslate = procedure(const SourceStr, TranslateStr: string; @@ -178,12 +181,19 @@ TLanguageRec = record TTranslator = class(TComponent) private + FVersion: string; FSourceLang: TLanguageEnum; FDestLang: TLanguageEnum; + FKey: string; FOnTranslate: TOnTranslate; FOnTranslateError: TOnTranslateError; function GetDetectedLanguage(const DetectStr: string): TLanguageEnum; function GetRequestURL(SourceStr: string): string; + function GetVersion: string; + function GetParams(const Text: TStringList): string; + function SendRequest(const aText: TStringList; + var Response: string): boolean; + function ParseError(const Response:string):boolean; public constructor Create(AOwner: TComponent); override; function Translate(const SourceStr: string): string; @@ -192,15 +202,17 @@ TTranslator = class(TComponent) published property SourceLang: TLanguageEnum read FSourceLang write FSourceLang; property DestLang: TLanguageEnum read FDestLang write FDestLang; + property Key: string read FKey write FKey; property OnTranslate: TOnTranslate read FOnTranslate write FOnTranslate; property OnTranslateError: TOnTranslateError read FOnTranslateError write FOnTranslateError; + property Version: string read GetVersion; end; procedure Register; -function EncodeURL(const Value: AnsiString): AnsiString; inline; -function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; - Specials: TSpecials): AnsiString; inline; +//function EncodeURL(const Value: AnsiString): AnsiString; inline; +//function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; +// Specials: TSpecials): AnsiString; inline; implementation @@ -209,42 +221,42 @@ procedure Register; RegisterComponents('WebDelphi.ru', [TTranslator]); end; -function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; - Specials: TSpecials): AnsiString; inline; -var - n, l: integer; - s: AnsiString; - c: AnsiChar; -begin - SetLength(Result, Length(Value) * 3); - l := 1; - for n := 1 to Length(Value) do - begin - c := Value[n]; - if c in Specials then - begin - Result[l] := Delimiter; - Inc(l); - s := IntToHex(Ord(c), 2); - Result[l] := s[1]; - Inc(l); - Result[l] := s[2]; - Inc(l); - end - else - begin - Result[l] := c; - Inc(l); - end; - end; - Dec(l); - SetLength(Result, l); -end; +//function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; +// Specials: TSpecials): AnsiString; inline; +//var +// n, l: integer; +// s: AnsiString; +// c: AnsiChar; +//begin +// SetLength(Result, Length(Value) * 3); +// l := 1; +// for n := 1 to Length(Value) do +// begin +// c := Value[n]; +// if c in Specials then +// begin +// Result[l] := Delimiter; +// Inc(l); +// s := IntToHex(Ord(c), 2); +// Result[l] := s[1]; +// Inc(l); +// Result[l] := s[2]; +// Inc(l); +// end +// else +// begin +// Result[l] := c; +// Inc(l); +// end; +// end; +// Dec(l); +// SetLength(Result, l); +//end; -function EncodeURL(const Value: AnsiString): AnsiString; inline; -begin - Result := EncodeTriplet(Value, '%', URLSpecialChar); -end; +//function EncodeURL(const Value: AnsiString): AnsiString; inline; +//begin +// Result := EncodeTriplet(Value, '%', URLSpecialChar); +//end; { TTranslator } @@ -275,13 +287,14 @@ function TTranslator.GetLangByName(const aName: string): TLanguageEnum; begin Result := unknown; for i := 0 to High(Languages) - 1 do - begin - if AnsiLowerCase(Trim(aName)) = AnsiLowerCase(Trim(Languages[i].Name)) then begin - Result := Languages[i].Ident; - break + if AnsiLowerCase(Trim(aName)) = AnsiLowerCase + (Trim(Languages[i].Name)) then + begin + Result := Languages[i].Ident; + break + end; end; - end; end; function TTranslator.GetLanguagesNames: TStringList; @@ -293,55 +306,132 @@ function TTranslator.GetLanguagesNames: TStringList; Result.Add(Languages[i].Name); end; +function TTranslator.GetParams(const Text: TStringList): string; +var + i: integer; + source, dest: string; +begin + source := ''; + if SourceLang <> unknown then + begin + source := StringReplace + (GetEnumName(TypeInfo(TLanguageEnum), Ord(FSourceLang)), '_', '-', + [rfReplaceAll]); + Delete(source, 1, 4); + end; + dest := StringReplace(GetEnumName(TypeInfo(TLanguageEnum), Ord(FDestLang)), + '_', '-', [rfReplaceAll]); + Delete(dest, 1, 4); + Result := 'key=' + Key; + for i := 0 to Text.Count - 1 do + Result := Result + '&q=' + Text[i]; + if SourceLang <> unknown then + Result := Result + '&source=' + source; + if DestLang <> unknown then + Result := Result + '&target=' + dest; + Result:=EncodeURL(AnsiString(Result)); +end; + function TTranslator.GetRequestURL(SourceStr: string): string; var source, dest: string; begin source := ''; if SourceLang <> unknown then - begin - source := StringReplace - (GetEnumName(TypeInfo(TLanguageEnum), Ord(FSourceLang)), '_', '-', - [rfReplaceAll]); - Delete(source, 1, 4); - end; + begin + source := StringReplace + (GetEnumName(TypeInfo(TLanguageEnum), Ord(FSourceLang)), '_', '-', + [rfReplaceAll]); + Delete(source, 1, 4); + end; dest := StringReplace(GetEnumName(TypeInfo(TLanguageEnum), Ord(FDestLang)), '_', '-', [rfReplaceAll]); Delete(dest, 1, 4); - Result := EncodeURL(cTranslateURL + '?v=' + APIVersion + '&q=' + UTF8Encode - (SourceStr) + '&langpair=' + source + '|' + dest); + Result := cTranslateURL + APIVersion + '?key=' + Key + '&q=' + + UTF8Encode(SourceStr); + if SourceLang <> unknown then + Result := Result + '&source=' + source; + if DestLang <> unknown then + Result := Result + '&target=' + dest; + EncodeURL(Result); +end; + +function TTranslator.GetVersion: string; +begin + Result := APIVersion; +end; + +function TTranslator.ParseError(const Response: string): boolean; +var obj: ISuperObject; + s: PSOChar; +begin + s := PwideChar(Response); + obj := TSuperObject.ParseString(s, true); + if not Assigned(obj) then Exit; + ShowMessage(obj.AsObject.GetNames.AsString); +end; + +function TTranslator.SendRequest(const aText: TStringList; + var Response: string): boolean; +var + i: integer; + PostData: TStringStream; + source, dest: string; +begin + Result := false; + PostData := TStringStream.Create; + if (aText = nil) OR (aText.Count = 0) then + Exit; + with THTTPSend.Create do + begin + if HTTPMethod('GET', cTranslateURL + Version + '?' + + GetParams(aText)) then + begin + PostData.LoadFromStream(Document); + Result := true; + Response := PostData.DataString; + ParseError(Response) + end + end; end; function TTranslator.Translate(const SourceStr: string): string; var obj: ISuperObject; - req: IXMLHttpRequest; s: PSOChar; + Text: TStringList; + Resp: string; begin if FDestLang = unknown then raise Exception.Create(rsErrorDestLng); - req := {$IFDEF VER210} CoXMLHTTP {$ELSE} CoXMLHTTPRequest {$ENDIF}.Create; - req.open('GET', GetRequestURL(SourceStr), false, EmptyParam, EmptyParam); - req.send(EmptyParam); - s := PwideChar(req.responseText); - obj := TSuperObject.ParseString(s, true); - if obj.i[cResponcePath] = 200 then - begin - Result := (obj.s[cTranslatedPath]); - if Assigned(FOnTranslate) then + Text := TStringList.Create; + Text.Add(SourceStr); + + if SendRequest(Text, Resp) then begin - if FSourceLang <> unknown then - FOnTranslate(SourceStr, Result, FSourceLang) - else - FOnTranslate(SourceStr, Result, GetDetectedLanguage - (obj.s[cDetectedLangPath])) - end; - end - else - begin - if Assigned(FOnTranslateError) then - FOnTranslateError(obj.i[cResponcePath], obj.s[cResponceTextPath]); - end; + s := PwideChar(Resp); + obj := TSuperObject.ParseString(s, true); + try + Result := UTF8ToString(obj.A['data.translations'].O[0].s['translatedText']); + if Assigned(FOnTranslate) then + begin + // if FSourceLang <> unknown then + FOnTranslate(SourceStr, Result, FSourceLang) + // else + // FOnTranslate(SourceStr, Result, GetDetectedLanguage + // (obj.s[cDetectedLangPath])) + end; + except + Text.Clear; + Text.Add(Resp); + Text.SaveToFile('Error.txt'); + raise Exception.Create(rsErrorTrnsl+' :'+Resp); + + end; + end + else + raise Exception.Create(Resp); + end; end. diff --git a/source/GoogleOAuth.pas b/source/GoogleOAuth.pas new file mode 100644 index 0000000..b96bdf6 --- /dev/null +++ b/source/GoogleOAuth.pas @@ -0,0 +1,250 @@ +unit GoogleOAuth; + +interface + +uses SysUtils, Classes, httpsend, ssl_Openssl,character,synacode; + +resourcestring + rsRequestError = 'Ошибка выполнения запроса: %d - %s'; + +const + redirect_uri='urn:ietf:wg:oauth:2.0:oob'; + oauth_url = 'https://accounts.google.com/o/oauth2/auth?client_id=%s&redirect_uri=%s&scope=%s&response_type=code'; + tokenurl='https://accounts.google.com/o/oauth2/token'; + tokenparams = 'client_id=%s&client_secret=%s&code=%s&redirect_uri=%s&grant_type=authorization_code'; + crefreshtoken = 'client_id=%s&client_secret=%s&refresh_token=%s&grant_type=refresh_token'; + AuthHeader = 'Authorization: OAuth %s'; + + DefaultMime = 'application/json; charset=UTF-8'; + + StripChars : set of char = ['"',':',',']; + +type + TOAuth = class(TComponent) + private + FClientID: string;//id клиента + FClientSecret: string;//секретный ключ клиента + FScope : string;//точка доступа + FResponseCode: string; + //Токен + FAccess_token: string; + FExpires_in: string; + FRefresh_token:string; + procedure SetClientID(const Value: string); + procedure SetResponseCode(const Value: string); + procedure SetScope(const Value: string);//код, который возвращает Google для доступа + function ParamValue(ParamName,JSONString: string):string; + procedure SetClientSecret(Value: string); + function PrepareParams(Params: TStrings): string; + public + constructor Create(AOwner: TComponent);override; + destructor destroy; override; + function AccessURL: string; //собирает URL для получения ResponseCode + function GetAccessToken: string; + function RefreshToken: string; + + function GETCommand(URL: string; Params: TStrings): RawBytestring; + function POSTCommand(URL:string; Params:TStrings; Body:TStream; Mime:string = DefaultMime):RawByteString; + function PUTCommand(URL:string; Body:TStream; Mime:string = DefaultMime):RawByteString; + function DELETECommand(URL:string):RawByteString; + + //Параметры токена (сам токен, время действия, ключ для обновления + property Access_token: string read FAccess_token; + property Expires_in: string read FExpires_in; + property Refresh_token:string read FRefresh_token; + property ResponseCode: string read FResponseCode write SetResponseCode; + published + property ClientID: string read FClientID write SetClientID; + property Scope : string read FScope write SetScope; + property ClientSecret: string read FClientSecret write SetClientSecret; +end; + +implementation + +{ TOAuth } + +function TOAuth.AccessURL: string; +begin + Result:=Format(oauth_url,[ClientID,redirect_uri,Scope]); +end; + +constructor TOAuth.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +end; + +function TOAuth.DELETECommand(URL: string): RawByteString; +begin +with THTTPSend.Create do + begin + Headers.Add(Format(AuthHeader, [Access_token])); + if HTTPMethod('DELETE', URL) then + begin + SetLength(Result, Document.Size); + Move(Document.Memory^, Pointer(Result)^, Document.Size); + end + else + raise Exception.CreateFmt(rsRequestError,[ResultCode,ResultString]); + end; +end; + +destructor TOAuth.destroy; +begin + + inherited; +end; + +function TOAuth.GetAccessToken: string; +var Params: TStringStream; + Response:string; +begin + Params:=TStringStream.Create(Format(tokenparams,[ClientID,ClientSecret,ResponseCode,redirect_uri])); + try + Response:=POSTCommand(tokenurl,nil,Params,'application/x-www-form-urlencoded'); + FAccess_token:=ParamValue('access_token',Response); + FExpires_in:=ParamValue('expires_in',Response); + FRefresh_token:=ParamValue('refresh_token',Response); + Result:=Access_token; + finally + Params.Free; + end; +end; + +function TOAuth.GETCommand(URL: string; Params: TStrings): RawBytestring; +var + ParamString: string; +begin + ParamString := PrepareParams(Params); + with THTTPSend.Create do + begin + Headers.Add(Format(AuthHeader, [Access_token])); + if HTTPMethod('GET', URL + ParamString) then + begin + SetLength(Result, Document.Size); + Move(Document.Memory^, Pointer(Result)^, Document.Size); + end + else + begin + raise Exception.CreateFmt(rsRequestError,[ResultCode,ResultString]); + end; + end; +end; + +function TOAuth.ParamValue(ParamName, JSONString: string): string; +var i,j:integer; +begin + i:=pos(ParamName,JSONString); + if i>0 then + begin + for j:= i+Length(ParamName) to Length(JSONString)-1 do + if not (JSONString[j] in StripChars) then + Result:=Result+JSONString[j] + else + if JSONString[j]=',' then + break; + end + else + Result:=''; +end; + +function TOAuth.POSTCommand(URL: string; Params: TStrings; + Body: TStream; Mime:string): RawByteString; +var ParamString: string; +begin +ParamString := PrepareParams(Params); + with THTTPSend.Create do + begin + MimeType:=Mime; + Headers.Add(Format(AuthHeader, [Access_token])); + if Body<>nil then + begin + Body.Position:=0; + Document.LoadFromStream(Body); + end; + if HTTPMethod('POST', URL + ParamString) then + begin + SetLength(Result, Document.Size); + Move(Document.Memory^, Pointer(Result)^, Document.Size); + end + else + begin + raise Exception.CreateFmt(rsRequestError,[ResultCode,ResultString]); + end; + end; +end; + +function TOAuth.PrepareParams(Params: TStrings): string; +var + S: string; +begin + if Assigned(Params) then + if Params.Count > 0 then + begin + for S in Params do + Result := Result + EncodeURL(S) + '&'; + Delete(Result, Length(Result), 1); + Result:='?'+Result; + Exit; + end; + Result := ''; +end; + +function TOAuth.PUTCommand(URL: string; Body: TStream; Mime:string): RawByteString; +begin +with THTTPSend.Create do + begin + MimeType:=Mime; + Headers.Add(Format(AuthHeader, [Access_token])); + if Body<>nil then + begin + Body.Position:=0; + Document.LoadFromStream(Body); + end; + if HTTPMethod('PUT', URL) then + begin + SetLength(Result, Document.Size); + Move(Document.Memory^, Pointer(Result)^, Document.Size); + end + else + begin + raise Exception.CreateFmt(rsRequestError,[ResultCode,ResultString]); + end; + end; +end; + +function TOAuth.RefreshToken: string; +var Params: TStringStream; + Response: string; +begin + Params:=TStringStream.Create(Format(crefreshtoken,[ClientID,ClientSecret,Refresh_token])); + try + Response:=POSTCommand(tokenurl,nil,Params,'application/x-www-form-urlencoded'); + FAccess_token:=ParamValue('access_token',Response); + FExpires_in:=ParamValue('expires_in',Response); + Result:=Access_token; + finally + Params.Free; + end; +end; + +procedure TOAuth.SetClientID(const Value: string); +begin + FClientID := Value; +end; + +procedure TOAuth.SetClientSecret(Value: string); +begin + FClientSecret:=EncodeURL(Value) +end; + +procedure TOAuth.SetResponseCode(const Value: string); +begin + FResponseCode := Value; +end; + +procedure TOAuth.SetScope(const Value: string); +begin + FScope := Value; +end; + +end. diff --git a/source/uLanguage.pas b/source/uLanguage.pas index 96faf1d..c4ad5bd 100644 --- a/source/uLanguage.pas +++ b/source/uLanguage.pas @@ -1,10 +1,5 @@ -<<<<<<< HEAD unit uLanguage; -======= -unit uLanguage; - ->>>>>>> remotes/origin/master interface const @@ -140,44 +135,4 @@ implementation {$R GStrings.res} -end. -<<<<<<< HEAD -======= -======= -<<<<<<< HEAD ->>>>>>> remotes/origin/NMD -unit uLanguage; - -{$DEFINE RUSSIAN} -const - -{$IFDEF RUSSIAN} -{I langusges/lang_russian.pas} -{$ENDIF} - - - -begin -<<<<<<< HEAD -end. ->>>>>>> remotes/origin/NMD -======= -======= -unit uLanguage; - -{$DEFINE RUSSIAN} - -interface - -{$IFDEF RUSSIAN} -{$I languages\lang_russian.inc} -{$ENDIF} - -implementation - -begin ->>>>>>> remotes/origin/Vlad55 -end. ->>>>>>> remotes/origin/NMD -======= ->>>>>>> remotes/origin/master +end. \ No newline at end of file