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 f1593a2..0039e8f 100644
--- a/demos/googlelogin_demo/Demo.dpr
+++ b/demos/googlelogin_demo/Demo.dpr
@@ -1,10 +1,10 @@
program Demo;
uses
- Forms,
- main in 'main.pas' {Form11},
- uGoogleLogin in '..\..\packages\googleLogin_pack\uGoogleLogin.pas';
-
+ Forms,
+ main in 'main.pas' {Form11},
+ uGoogleLogin in '..\..\packages\googleLogin_pack\uGoogleLogin.pas';
+
{$R *.res}
begin
diff --git a/demos/googlelogin_demo/Demo.dproj b/demos/googlelogin_demo/Demo.dproj
index d03b1cb..bb66e61 100644
--- a/demos/googlelogin_demo/Demo.dproj
+++ b/demos/googlelogin_demo/Demo.dproj
@@ -1,118 +1,14 @@
-<<<<<<< HEAD
-
-
- {A9DD61E1-1C1A-4F97-801D-FA2DE517335B}
- 12.0
- Demo.dpr
- Debug
- DCC32
-
-
- true
-
-
- true
- Base
- true
-
-
- true
- Base
- true
-
-
- WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)
- Demo.exe
- 00400000
- x86
-
-
- false
- RELEASE;$(DCC_Define)
- 0
- false
-
-
- DEBUG;$(DCC_Define)
-
-
-
- MainSource
-
-
-
-
-
-
- Base
-
-
- Cfg_2
- Base
-
-
- Cfg_1
- Base
-
-
-
-
- Delphi.Personality.12
-
-
-
-
- False
- True
- False
-
-
- False
- False
- 1
- 0
- 0
- 0
- False
- False
- False
- False
- False
- 1049
- 1251
-
-
-
-
- 1.0.0.0
-
-
-
-
-
- 1.0.0.0
-
-
-
- Microsoft Office 2000 Sample Automation Server Wrapper Components
- Microsoft Office XP Sample Automation Server Wrapper Components
-
-
- Demo.dpr
-
-
-
- 12
-
-
-=======
{A9DD61E1-1C1A-4F97-801D-FA2DE517335B}
- 12.0
+ 12.2
Demo.dpr
Debug
DCC32
+ True
+ Win32
+ Application
+ VCL
true
@@ -150,29 +46,27 @@
-
- Base
-
+
Cfg_2
Base
+
+ Base
+
Cfg_1
Base
-
+
+
Delphi.Personality.12
-
- False
- True
- False
-
+
False
False
@@ -205,8 +99,10 @@
Demo.dpr
+
+ True
+
12
->>>>>>> remotes/origin/NMD
diff --git a/demos/googlelogin_demo/main.dfm b/demos/googlelogin_demo/main.dfm
index e975923..758006e 100644
--- a/demos/googlelogin_demo/main.dfm
+++ b/demos/googlelogin_demo/main.dfm
@@ -2,8 +2,8 @@ object Form11: TForm11
Left = 0
Top = 0
Caption = 'Google Login'
- ClientHeight = 524
- ClientWidth = 355
+ ClientHeight = 353
+ ClientWidth = 600
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
@@ -21,8 +21,8 @@ object Form11: TForm11
Caption = 'Email'
end
object Label2: TLabel
- Left = 165
- Top = 31
+ Left = 175
+ Top = 30
Width = 46
Height = 13
Caption = 'Password'
@@ -36,7 +36,7 @@ object Form11: TForm11
end
object Label3: TLabel
Left = 8
- Top = 115
+ Top = 108
Width = 53
Height = 13
Caption = #1056#1077#1079#1091#1083#1100#1090#1072#1090
@@ -50,45 +50,58 @@ object Form11: TForm11
end
object Label6: TLabel
Left = 8
- Top = 141
+ Top = 134
Width = 27
Height = 13
Caption = 'AUTH'
end
object Label7: TLabel
Left = 8
- Top = 168
+ Top = 161
Width = 61
Height = 13
Caption = 'TLoginResult'
end
- object Label8: TLabel
- Left = 8
- Top = 195
- Width = 31
- Height = 13
- Caption = 'Label8'
- end
object Label9: TLabel
Left = 8
- Top = 264
+ Top = 257
Width = 162
Height = 13
Caption = #1051#1086#1075' '#1082#1086#1083'-'#1074#1072' '#1087#1086#1083#1091#1095#1077#1085#1085#1099#1093' '#1076#1072#1085#1085#1099#1093
end
object Label10: TLabel
Left = 8
- Top = 222
+ Top = 215
Width = 114
Height = 13
Caption = #1055#1088#1086#1075#1088#1077#1089#1089' '#1072#1074#1090#1086#1088#1080#1079#1072#1094#1080#1080
end
- object Image1: TImage
- Left = 8
- Top = 359
- Width = 241
- Height = 74
- AutoSize = True
+ object imgCaptcha: TImage
+ Left = 361
+ Top = 173
+ Width = 224
+ Height = 97
+ Proportional = True
+ Stretch = True
+ end
+ object Label11: TLabel
+ Left = 361
+ Top = 276
+ Width = 190
+ Height = 13
+ Caption = #1042#1074#1077#1076#1080#1090#1077' '#1090#1077#1082#1089#1090' '#1089' '#1082#1072#1088#1090#1080#1085#1082#1080' '#1074' '#1101#1090#1086' '#1087#1086#1083#1077
+ end
+ object Label12: TLabel
+ Left = 361
+ Top = 62
+ Width = 230
+ Height = 91
+ Caption =
+ #1044#1083#1103' '#1090#1086#1075#1086' '#1095#1090#1086#1073#1099' '#1091#1074#1080#1076#1077#1090' '#1082#1072#1087#1095#1091' '#1085#1077#1086#1073#1093#1086#1076#1080#1084#1086' '#1085#1077#1089#1082#1086#1083#1100#1082#1086' '#1088#1072#1079' '#1074#1074#1077#1089#1090#1080' '#1085#1077#1087#1088 +
+ #1072#1074#1080#1083#1100#1085#1099#1081' '#1087#1072#1088#1086#1083#1100' '#1080#1083#1080' '#1083#1086#1075#1080#1085'.'#13#10#1055#1086#1089#1083#1077' '#1090#1086#1075#1086' '#1082#1072#1082' '#1074#1074#1077#1083#1080' '#1082#1072#1087#1095#1091' '#1085#1077#1086#1073#1093#1086#1076#1080#1084 +
+ #1086' '#1087#1088#1086#1074#1077#1088#1080#1090#1100' '#1087#1072#1088#1086#1083#1100' '#1085#1072' '#1087#1088#1072#1074#1080#1083#1100#1085#1086#1089#1090#1100' '#1077#1089#1083#1080' '#1086#1085' '#1085#1077' '#1087#1088#1072#1074#1080#1083#1100#1085#1099#1081' '#1080#1089#1087#1088#1072#1074#1080 +
+ #1090#1100' '#1077#1075#1086'.'#13#10
+ WordWrap = True
end
object EmailEdit: TEdit
Left = 38
@@ -99,7 +112,7 @@ object Form11: TForm11
Text = 'GoLabApi@gmail.com'
end
object PassEdit: TEdit
- Left = 213
+ Left = 227
Top = 27
Width = 121
Height = 21
@@ -107,16 +120,16 @@ object Form11: TForm11
Text = '123456789her'
end
object Button1: TButton
- Left = 8
- Top = 84
- Width = 170
+ Left = 360
+ Top = 8
+ Width = 225
Height = 21
Caption = #1051#1086#1075#1080#1085#1080#1084#1089#1103
TabOrder = 2
OnClick = Button1Click
end
object ComboBox1: TComboBox
- Left = 50
+ Left = 64
Top = 57
Width = 284
Height = 21
@@ -148,93 +161,68 @@ object Form11: TForm11
end
object AuthEdit: TEdit
Left = 84
- Top = 138
+ Top = 131
Width = 264
Height = 21
TabOrder = 4
end
object ResultEdit: TEdit
Left = 84
- Top = 111
+ Top = 104
Width = 264
Height = 21
TabOrder = 5
end
object Button2: TButton
- Left = 184
- Top = 84
- Width = 163
+ Left = 360
+ Top = 35
+ Width = 225
Height = 21
- Caption = #1069#1082#1089#1090#1088#1077#1085#1085#1086#1077' '#1090#1086#1088#1084#1086#1078#1077#1085#1080#1077' '#1087#1086#1090#1086#1082#1072
+ Caption = #1069#1082#1089#1090#1088#1077#1085#1085#1086#1077' '#1090#1086#1088#1084#1086#1078#1077#1085#1080#1077' '#1087#1086#1090#1086#1082#1072' Destroy'
TabOrder = 6
OnClick = Button2Click
end
object Edit1: TEdit
Left = 84
- Top = 165
+ Top = 158
Width = 264
Height = 21
TabOrder = 7
end
- object Edit2: TEdit
- Left = 84
- Top = 192
- Width = 264
- Height = 21
- TabOrder = 8
- Text = 'Edit2'
- end
object ProgressBar1: TProgressBar
Left = 8
- Top = 241
+ Top = 234
Width = 339
Height = 17
- TabOrder = 9
+ TabOrder = 8
end
object Memo1: TMemo
Left = 8
- Top = 283
+ Top = 276
Width = 339
Height = 70
- TabOrder = 10
+ TabOrder = 9
end
- object Animate1: TAnimate
- Left = 8
- Top = 466
- Width = 80
- Height = 50
- CommonAVI = aviFindFolder
- DoubleBuffered = False
- ParentDoubleBuffered = False
- StopFrame = 29
- Timers = True
- end
- object Edit3: TEdit
- Left = 208
- Top = 456
- Width = 121
+ object edtCaptcha: TEdit
+ Left = 361
+ Top = 295
+ Width = 224
Height = 21
- TabOrder = 12
- Text = 'Edit3'
+ TabOrder = 10
end
object Button3: TButton
- Left = 216
- Top = 488
- Width = 75
+ Left = 361
+ Top = 322
+ Width = 224
Height = 25
- Caption = 'Button3'
- TabOrder = 13
+ Caption = #1040#1074#1090#1086#1088#1080#1079#1072#1094#1080#1103' '#1087#1086#1089#1083#1077' '#1074#1074#1086#1076#1072' '#1082#1072#1087#1095#1080
+ TabOrder = 11
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 = 176
- Top = 8
+ Left = 172
+ Top = 184
end
end
diff --git a/demos/googlelogin_demo/main.pas b/demos/googlelogin_demo/main.pas
index bb95c9d..0725e3f 100644
--- a/demos/googlelogin_demo/main.pas
+++ b/demos/googlelogin_demo/main.pas
@@ -21,19 +21,18 @@ TForm11 = class(TForm)
AuthEdit: TEdit;
ResultEdit: TEdit;
Button2: TButton;
- GoogleLogin1: TGoogleLogin;
Edit1: TEdit;
Label7: TLabel;
- Edit2: TEdit;
- Label8: TLabel;
ProgressBar1: TProgressBar;
Memo1: TMemo;
Label9: TLabel;
Label10: TLabel;
- Animate1: TAnimate;
- Image1: TImage;
- Edit3: TEdit;
+ imgCaptcha: TImage;
+ edtCaptcha: TEdit;
Button3: TButton;
+ Label11: TLabel;
+ Label12: TLabel;
+ GoogleLogin1: TGoogleLogin;
procedure Button1Click(Sender: TObject);
procedure GoogleLogin1Autorization(const LoginResult: TLoginResult;
Result: TResultRec);
@@ -59,6 +58,12 @@ implementation
procedure TForm11.Button1Click(Sender: TObject);
begin
+if not Assigned(GoogleLogin1) then
+begin
+ ShowMessage('Уже убили');
+ Exit;
+end;
+
GoogleLogin1.Email:=EmailEdit.Text;
GoogleLogin1.Password:=PassEdit.Text;
GoogleLogin1.Service:=TServices(ComboBox1.ItemIndex);
@@ -73,9 +78,13 @@ procedure TForm11.Button2Click(Sender: TObject);
procedure TForm11.Button3Click(Sender: TObject);
begin
- //Memo1.Lines.Add(GoogleLogin1.CapchaToken);
- GoogleLogin1.Captcha:=Edit3.Text;
-
+ if edtCaptcha.Text<>'' then
+ begin
+ imgCaptcha.Picture:=nil;
+ GoogleLogin1.Email:=EmailEdit.Text;
+ GoogleLogin1.Password:=PassEdit.Text;
+ GoogleLogin1.Captcha:=edtCaptcha.Text;
+ end;
end;
procedure TForm11.GoogleLogin1Autorization(const LoginResult: TLoginResult;Result: TResultRec);
@@ -86,7 +95,6 @@ procedure TForm11.GoogleLogin1Autorization(const LoginResult: TLoginResult;Resul
AuthEdit.Text:=Result.Auth;
temp:=GetEnumName(TypeInfo(TLoginResult),Integer(LoginResult));
Edit1.Text:=temp;
- Edit2.Text:=Result.SID;
if LoginResult =lrOk then
ShowMessage('Мы в гугле!!!!!!!!!')
else
@@ -96,12 +104,12 @@ procedure TForm11.GoogleLogin1Autorization(const LoginResult: TLoginResult;Resul
procedure TForm11.GoogleLogin1AutorizCaptcha(PicCaptcha: TPicture);
begin
- Image1.Picture:=PicCaptcha;
+ imgCaptcha .Picture:=PicCaptcha;
end;
procedure TForm11.GoogleLogin1Disconnect(const ResultStr: string);
begin
- ShowMessage('Disconnect');
+ ShowMessage('Disconnect');
end;
procedure TForm11.GoogleLogin1Error(const ErrorStr: string);
@@ -116,11 +124,6 @@ procedure TForm11.GoogleLogin1ProgressAutorization(const Progress, MaxProgress:
Memo1.Lines.Add('////////');
Memo1.Lines.Add('Progress '+IntToStr(Progress));
Memo1.Lines.Add('MaxProgress '+IntToStr(MaxProgress));
- //слишком уж быстро качает я не увидел чтоб анимация работала
- if (MaxProgress>Progress) then
- Animate1.Active:=True
- else
- Animate1.Active:=False;
end;
end.
diff --git a/demos/translate_demo/main.dfm b/demos/translate_demo/main.dfm
index 86ecc8f..24279fe 100644
--- a/demos/translate_demo/main.dfm
+++ b/demos/translate_demo/main.dfm
@@ -1,96 +1,109 @@
-object Form6: TForm6
- Left = 0
- Top = 0
- Caption = 'Form6'
- ClientHeight = 208
- ClientWidth = 428
- Color = clBtnFace
- Font.Charset = DEFAULT_CHARSET
- Font.Color = clWindowText
- Font.Height = -11
- Font.Name = 'Tahoma'
- Font.Style = []
- KeyPreview = True
- OldCreateOrder = False
- OnShow = FormShow
- PixelsPerInch = 96
- TextHeight = 13
- object Label1: TLabel
- Left = 10
- Top = 8
- Width = 31
- Height = 13
- Caption = #1060#1088#1072#1079#1072
- end
- object Label2: TLabel
- Left = 8
- Top = 87
- Width = 44
- Height = 13
- Caption = #1055#1077#1088#1077#1074#1086#1076
- end
- object Label3: TLabel
- Left = 10
- Top = 35
- Width = 7
- Height = 13
- Caption = 'C'
- end
- object Label4: TLabel
- Left = 10
- Top = 63
- Width = 13
- Height = 13
- Caption = #1053#1072
- end
- object Edit1: TEdit
- Left = 58
- Top = 5
- Width = 365
- Height = 21
- TabOrder = 0
- Text = 'Edit1'
- end
- object Memo1: TMemo
- Left = 6
- Top = 106
- Width = 417
- Height = 95
- TabOrder = 1
- end
- object Button1: TButton
- Left = 308
- Top = 41
- Width = 75
- Height = 25
- Caption = #1055#1077#1088#1077#1074#1077#1089#1090#1080
- TabOrder = 2
- OnClick = Button1Click
- end
- object ComboBox1: TComboBox
- Left = 58
- Top = 32
- Width = 239
- Height = 21
- Style = csDropDownList
- TabOrder = 3
- OnChange = ComboBox1Change
- end
- object ComboBox2: TComboBox
- Left = 58
- Top = 55
- Width = 239
- Height = 21
- Style = csDropDownList
- TabOrder = 4
- OnChange = ComboBox2Change
- end
- object Translator1: TTranslator
- SourceLang = unknown
- DestLang = lng_ru
- OnTranslate = Translator1Translate
- OnTranslateError = Translator1TranslateError
- Left = 192
- Top = 132
- end
-end
+object Form6: TForm6
+ Left = 0
+ Top = 0
+ Caption = 'Form6'
+ ClientHeight = 250
+ ClientWidth = 428
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'Tahoma'
+ Font.Style = []
+ KeyPreview = True
+ OldCreateOrder = False
+ OnShow = FormShow
+ PixelsPerInch = 96
+ TextHeight = 13
+ object Label1: TLabel
+ Left = 10
+ Top = 52
+ Width = 31
+ Height = 13
+ Caption = #1060#1088#1072#1079#1072
+ end
+ object Label2: TLabel
+ Left = 8
+ Top = 131
+ Width = 44
+ Height = 13
+ Caption = #1055#1077#1088#1077#1074#1086#1076
+ end
+ object Label3: TLabel
+ Left = 10
+ Top = 79
+ Width = 7
+ Height = 13
+ Caption = 'C'
+ end
+ object Label4: TLabel
+ Left = 10
+ 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 = 49
+ Width = 365
+ Height = 21
+ TabOrder = 0
+ Text = 'Edit1'
+ end
+ object Memo1: TMemo
+ Left = 4
+ Top = 154
+ Width = 421
+ Height = 95
+ TabOrder = 1
+ end
+ object Button1: TButton
+ Left = 308
+ Top = 85
+ Width = 75
+ Height = 25
+ Caption = #1055#1077#1088#1077#1074#1077#1089#1090#1080
+ TabOrder = 2
+ OnClick = Button1Click
+ end
+ object ComboBox1: TComboBox
+ Left = 58
+ Top = 76
+ Width = 239
+ Height = 21
+ Style = csDropDownList
+ TabOrder = 3
+ OnChange = ComboBox1Change
+ end
+ object ComboBox2: TComboBox
+ Left = 58
+ 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
+ Left = 328
+ Top = 136
+ end
+end
diff --git a/demos/translate_demo/main.pas b/demos/translate_demo/main.pas
index c00c013..9a2d0ed 100644
--- a/demos/translate_demo/main.pas
+++ b/demos/translate_demo/main.pas
@@ -1,75 +1,79 @@
-unit main;
-
-interface
-
-uses
- Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
- Dialogs, StdCtrls,GTranslate,typinfo, ExtCtrls, Clipbrd;
-
-type
- TForm6 = class(TForm)
- Label1: TLabel;
- Edit1: TEdit;
- Label2: TLabel;
- Memo1: TMemo;
- Button1: TButton;
- ComboBox1: TComboBox;
- Translator1: TTranslator;
- Label3: TLabel;
- Label4: TLabel;
- ComboBox2: TComboBox;
- procedure Button1Click(Sender: TObject);
- procedure Translator1Translate(const SourceStr, TranslateStr: string;
- LangDetected: TLanguageEnum);
- procedure Translator1TranslateError(const Code: Integer; Status: string);
- procedure FormShow(Sender: TObject);
- procedure ComboBox1Change(Sender: TObject);
- procedure ComboBox2Change(Sender: TObject);
- private
- public
-
- end;
-
-var
- Form6: TForm6;
-
-implementation
-
-{$R *.dfm}
-
-procedure TForm6.Button1Click(Sender: TObject);
-begin
- Translator1.Translate(Edit1.Text)
-end;
-
-
-procedure TForm6.ComboBox1Change(Sender: TObject);
-begin
- Translator1.SourceLang:=Translator1.GetLangByName(ComboBox1.Items[ComboBox1.ItemIndex]);
-end;
-
-procedure TForm6.ComboBox2Change(Sender: TObject);
-begin
- Translator1.DestLang:=Translator1.GetLangByName(ComboBox2.Items[ComboBox2.ItemIndex]);
-end;
-
-procedure TForm6.FormShow(Sender: TObject);
-begin
- ComboBox1.Items.Assign(Translator1.GetLanguagesNames);
- ComboBox2.Items.Assign(Translator1.GetLanguagesNames);
-end;
-
-procedure TForm6.Translator1Translate(const SourceStr, TranslateStr: string;
- LangDetected: TLanguageEnum);
-begin
- Memo1.Lines.Clear;
- Memo1.Lines.Add(' '+SourceStr);
- Memo1.Lines.Add(' '+TranslateStr);
-end;
-
-procedure TForm6.Translator1TranslateError(const Code: Integer; Status: string);
-begin
- Memo1.Lines.Add(' '+IntToStr(Code)+' '+Status)
-end;
-
-end.
+unit main;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
+ Dialogs, StdCtrls,GTranslate,typinfo, ExtCtrls, Clipbrd;
+
+type
+ TForm6 = class(TForm)
+ Label1: TLabel;
+ Edit1: TEdit;
+ Label2: TLabel;
+ Memo1: TMemo;
+ Button1: TButton;
+ ComboBox1: TComboBox;
+ //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);
+ procedure Translator1TranslateError(const Code: Integer; Status: string);
+ procedure FormShow(Sender: TObject);
+ procedure ComboBox1Change(Sender: TObject);
+ procedure ComboBox2Change(Sender: TObject);
+ private
+ public
+
+ end;
+
+var
+ Form6: TForm6;
+
+implementation
+
+{$R *.dfm}
+
+procedure TForm6.Button1Click(Sender: TObject);
+begin
+ Translator1.Key:=Edit2.Text;
+ Translator1.Translate(Edit1.Text)
+end;
+
+
+procedure TForm6.ComboBox1Change(Sender: TObject);
+begin
+ Translator1.SourceLang:=Translator1.GetLangByName(ComboBox1.Items[ComboBox1.ItemIndex]);
+end;
+
+procedure TForm6.ComboBox2Change(Sender: TObject);
+begin
+ Translator1.DestLang:=Translator1.GetLangByName(ComboBox2.Items[ComboBox2.ItemIndex]);
+end;
+
+procedure TForm6.FormShow(Sender: TObject);
+begin
+ ComboBox1.Items.Assign(Translator1.GetLanguagesNames);
+ ComboBox2.Items.Assign(Translator1.GetLanguagesNames);
+end;
+
+procedure TForm6.Translator1Translate(const SourceStr, TranslateStr: string;
+ LangDetected: TLanguageEnum);
+begin
+ Memo1.Lines.Clear;
+ Memo1.Lines.Add(' '+SourceStr);
+ Memo1.Lines.Add(' '+TranslateStr);
+end;
+
+procedure TForm6.Translator1TranslateError(const Code: Integer; Status: string);
+begin
+ Memo1.Lines.Add(' '+IntToStr(Code)+' '+Status)
+end;
+
+end.
diff --git a/demos/translate_demo/translate_demo.dpr b/demos/translate_demo/translate_demo.dpr
index 7fe4890..cce612a 100644
--- a/demos/translate_demo/translate_demo.dpr
+++ b/demos/translate_demo/translate_demo.dpr
@@ -1,15 +1,16 @@
-program translate_demo;
-
-uses
- Forms,
- main in 'main.pas' {Form6},
- GTranslate in '..\..\source\GTranslate.pas';
-
-{$R *.res}
-
-begin
- Application.Initialize;
- Application.MainFormOnTaskbar := True;
- Application.CreateForm(TForm6, Form6);
- Application.Run;
-end.
+program translate_demo;
+
+uses
+ Forms,
+ main in 'main.pas' {Form6},
+ GTranslate in '..\..\source\GTranslate.pas',
+ superobject in '..\..\addons\superobject\superobject.pas';
+
+{$R *.res}
+
+begin
+ Application.Initialize;
+ Application.MainFormOnTaskbar := True;
+ Application.CreateForm(TForm6, Form6);
+ Application.Run;
+end.
diff --git a/demos/translate_demo/translate_demo.dproj b/demos/translate_demo/translate_demo.dproj
index 86d8c05..3f2243c 100644
--- a/demos/translate_demo/translate_demo.dproj
+++ b/demos/translate_demo/translate_demo.dproj
@@ -1,106 +1,111 @@
-
-
- {DD410A90-3F79-4371-A128-0CC6D2D041B1}
- translate_demo.dpr
- Debug
- DCC32
- 12.0
-
-
- true
-
-
- true
- Base
- true
-
-
- true
- Base
- true
-
-
- WinTypes=Windows;WinProcs=Windows;$(DCC_UnitAlias)
- translate_demo.exe
- 00400000
- x86
-
-
- false
- RELEASE;$(DCC_Define)
- 0
- false
-
-
- DEBUG;$(DCC_Define)
-
-
-
- MainSource
-
-
-
-
-
-
- Base
-
-
- Cfg_2
- Base
-
-
- Cfg_1
- Base
-
-
-
-
- Delphi.Personality.12
- VCLApplication
-
-
-
- translate_demo.dpr
-
-
- False
- True
- False
-
-
- False
- False
- 1
- 0
- 0
- 0
- False
- False
- False
- False
- False
- 1049
- 1251
-
-
-
-
- 1.0.0.0
-
-
-
-
-
- 1.0.0.0
-
-
-
- File G:\notepad gnu\SynEdit\Source\SynEdit_D5.bpl not found
- Microsoft Office 2000 Sample Automation Server Wrapper Components
-
-
-
- 12
-
-
+
+
+ {DD410A90-3F79-4371-A128-0CC6D2D041B1}
+ translate_demo.dpr
+ Debug
+ DCC32
+ 12.3
+ True
+ Win32
+ Application
+ VCL
+
+
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)
+ translate_demo.exe
+ 00400000
+ x86
+
+
+ false
+ RELEASE;$(DCC_Define)
+ 0
+ false
+
+
+ DEBUG;$(DCC_Define)
+
+
+
+ MainSource
+
+
+
+
+
+
+
+ Cfg_2
+ Base
+
+
+ Base
+
+
+ Cfg_1
+ Base
+
+
+
+
+
+ Delphi.Personality.12
+ VCLApplication
+
+
+
+ translate_demo.dpr
+
+
+
+ False
+ False
+ 1
+ 0
+ 0
+ 0
+ False
+ False
+ False
+ False
+ False
+ 1049
+ 1251
+
+
+
+
+ 1.0.0.0
+
+
+
+
+
+ 1.0.0.0
+
+
+
+ File G:\notepad gnu\SynEdit\Source\SynEdit_D5.bpl not found
+ Microsoft Office 2000 Sample Automation Server Wrapper Components
+
+
+
+ True
+
+
+ 12
+
+
diff --git a/packages/feedburner_pack/FeedBurner_pack.dpk b/packages/feedburner_pack/FeedBurner_pack.dpk
index a535dc2..ab61974 100644
--- a/packages/feedburner_pack/FeedBurner_pack.dpk
+++ b/packages/feedburner_pack/FeedBurner_pack.dpk
@@ -1,35 +1,35 @@
-package FeedBurner_pack;
-
-{$R *.res}
-{$ALIGN 8}
-{$ASSERTIONS ON}
-{$BOOLEVAL OFF}
-{$DEBUGINFO ON}
-{$EXTENDEDSYNTAX ON}
-{$IMPORTEDDATA ON}
-{$IOCHECKS ON}
-{$LOCALSYMBOLS ON}
-{$LONGSTRINGS ON}
-{$OPENSTRINGS ON}
-{$OPTIMIZATION ON}
-{$OVERFLOWCHECKS OFF}
-{$RANGECHECKS OFF}
-{$REFERENCEINFO OFF}
-{$SAFEDIVIDE OFF}
-{$STACKFRAMES OFF}
-{$TYPEDADDRESS OFF}
-{$VARSTRINGCHECKS ON}
-{$WRITEABLECONST OFF}
-{$MINENUMSIZE 1}
-{$IMAGEBASE $400000}
-{$IMPLICITBUILD ON}
-
-requires
- rtl,
- vcl;
-
-contains
- GFeedBurner in '..\..\source\GFeedBurner.pas',
- NativeXml in '..\..\addons\nativexml\NativeXml.pas';
-
-end.
+package FeedBurner_pack;
+
+{$R *.res}
+{$ALIGN 8}
+{$ASSERTIONS ON}
+{$BOOLEVAL OFF}
+{$DEBUGINFO ON}
+{$EXTENDEDSYNTAX ON}
+{$IMPORTEDDATA ON}
+{$IOCHECKS ON}
+{$LOCALSYMBOLS ON}
+{$LONGSTRINGS ON}
+{$OPENSTRINGS ON}
+{$OPTIMIZATION ON}
+{$OVERFLOWCHECKS OFF}
+{$RANGECHECKS OFF}
+{$REFERENCEINFO OFF}
+{$SAFEDIVIDE OFF}
+{$STACKFRAMES OFF}
+{$TYPEDADDRESS OFF}
+{$VARSTRINGCHECKS ON}
+{$WRITEABLECONST OFF}
+{$MINENUMSIZE 1}
+{$IMAGEBASE $400000}
+{$IMPLICITBUILD ON}
+
+requires
+ rtl,
+ vcl;
+
+contains
+ GFeedBurner in '..\..\source\GFeedBurner.pas',
+ NativeXml in '..\..\addons\nativexml\NativeXml.pas';
+
+end.
diff --git a/packages/feedburner_pack/FeedBurner_pack.dproj b/packages/feedburner_pack/FeedBurner_pack.dproj
index 3c3430e..6a21aa2 100644
--- a/packages/feedburner_pack/FeedBurner_pack.dproj
+++ b/packages/feedburner_pack/FeedBurner_pack.dproj
@@ -1,109 +1,109 @@
-
-
- {11D03AA0-F05C-49FC-8C5F-C324D90108EB}
- FeedBurner_pack.dpk
- 12.0
- Debug
- DCC32
-
-
- true
-
-
- true
- Base
- true
-
-
- true
- Base
- true
-
-
- WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)
- C:\Users\Public\Documents\RAD Studio\7.0\Bpl\FeedBurner_pack.bpl
- 0
- true
- true
- 00400000
- x86
-
-
- false
- RELEASE;$(DCC_Define)
- 0
- false
-
-
- DEBUG;$(DCC_Define)
-
-
-
- MainSource
-
-
-
-
-
-
- Base
-
-
- Cfg_2
- Base
-
-
- Cfg_1
- Base
-
-
-
-
- Delphi.Personality.12
- Package
-
-
-
- FeedBurner_pack.dpk
-
-
- False
- True
- False
-
-
- True
- False
- 1
- 0
- 0
- 0
- False
- False
- False
- False
- False
- 1049
- 1251
-
-
-
-
- 1.0.0.0
-
-
-
-
-
- 1.0.0.0
-
-
-
- File G:\notepad gnu\SynEdit\Source\SynEdit_D5.bpl not found
- Microsoft Office 2000 Sample Automation Server Wrapper Components
-
-
-
- 12
-
-
+
+
+ {11D03AA0-F05C-49FC-8C5F-C324D90108EB}
+ FeedBurner_pack.dpk
+ 12.0
+ Debug
+ DCC32
+
+
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)
+ C:\Users\Public\Documents\RAD Studio\7.0\Bpl\FeedBurner_pack.bpl
+ 0
+ true
+ true
+ 00400000
+ x86
+
+
+ false
+ RELEASE;$(DCC_Define)
+ 0
+ false
+
+
+ DEBUG;$(DCC_Define)
+
+
+
+ MainSource
+
+
+
+
+
+
+ Base
+
+
+ Cfg_2
+ Base
+
+
+ Cfg_1
+ Base
+
+
+
+
+ Delphi.Personality.12
+ Package
+
+
+
+ FeedBurner_pack.dpk
+
+
+ False
+ True
+ False
+
+
+ True
+ False
+ 1
+ 0
+ 0
+ 0
+ False
+ False
+ False
+ False
+ False
+ 1049
+ 1251
+
+
+
+
+ 1.0.0.0
+
+
+
+
+
+ 1.0.0.0
+
+
+
+ File G:\notepad gnu\SynEdit\Source\SynEdit_D5.bpl not found
+ Microsoft Office 2000 Sample Automation Server Wrapper Components
+
+
+
+ 12
+
+
diff --git a/packages/gmail_pack/GMailSMTP.pas b/packages/gmail_pack/GMailSMTP.pas
index 8cf7f98..ff909fb 100644
--- a/packages/gmail_pack/GMailSMTP.pas
+++ b/packages/gmail_pack/GMailSMTP.pas
@@ -1,285 +1,285 @@
-{unit GContacts
-|==============================================================================|
-| Модуль содержит класс для отправки писем через электронную посту GMail.com |
-| с использованием класса бибилотеки Synapse - TSMTPSend. |
-|==============================================================================|
-| ВАЖНО! ВНИМАТЕЛЬНО ПРОЧТИТЕ! |
-|==============================================================================|
-| для нормальной работы компонента Вам необходимо скачать и сохранить |
-| в директории с программой две DLL: |
-| |
-| 1. libeay32.dll |
-| 2. ssleay32.dll |
-| |
-| Скачать их можна на сайте разработчиков Synapse: |
-| http://synapse.ararat.cz/files/crypt/ |
-|==============================================================================|
-| Если Вы планируете использовать компонент для других почтовых сервисов, |
-| которые ни используют шифрованных подключений TLS, то следуетт |
-| закомментировать вот эту строку: |
-| |
-| |
-| function TGMailSMTP.SendMessage([...]): boolean; |
-| var |
-| ... |
-| begin |
-| ... |
-| SMTP.AutoTLS:=True; |
-| ... |
-| |
-| |
-| Основной компонент для работы с почтой - TGMailSMTP. |
-|==============================================================================|
-| Автор: Vlad. (vlad383@gmail.com) |
-| Дата: 27 Июля 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. |
-|==============================================================================|
-| ОБНОВЛЕНИЯ КОМПОНЕНТА |
-|==============================================================================|
-| Последние обновления модуля можно найти в репозитории по адресу: |
-| http://github.com/googleapi |
-| |
-|==============================================================================|
-| История версий |
-|==============================================================================|
-|09.08.2010. Версия 0.21 |
-| + Немного подправлен Destructor компонента |
-|27.07.2010. Версия 0.2 |
-| + исправлена проблема с кодировками писем в Outlook |
-| + добавлено свойство Mailer для идентификацмм почтового клиента |
-| + добавлено событие OnStatus для отслеживания работы соккета |
-|==============================================================================|
-}
-
-unit GMailSMTP;
-
-interface
-
-uses mimemess, mimepart, smtpsend, classes, sysutils,
- controls,ssl_openssl,synautil,synachar, dialogs,blcksock;
-
-const
- {$REGION 'Константы'}
- GMailSMTPVersion = '0.21';
- GmailHost = 'smtp.gmail.com';
- GmailPort = 587;
- {$ENDREGION}
-
-type
- TGMailSMTP = class(TComponent)
- private
- FPort : integer; //порт
- FLogin : string; //логин для smtp-сервера
- FPassword : string; //пароль
- FEmail : string; //почтовый ящик с которого отправляется письмо
- FFromName : string; //от чьего имени отправляется письмо
- FHost : string; //хост (smtp-сервер)
- FFiles : TStrings; //прикрепленные файлы
- FRecipients: TStrings;//получатели
- FMsg : TMimeMess;
- FOnStatus : THookSocketStatus;
- procedure SetFiles(Value: TStrings);
- procedure SetRecepients(Value: TStrings);
- function GetMailer: string;
- procedure SetMailer(const Value: string);
- public
- constructor Create(AOwner: TComponent);override;
- destructor Destroy;override;
- function AddText(const aText: AnsiString):boolean;
- function AddHTML(const aHTML: AnsiString):boolean;
- function SendMessage(const aSubject:string; aClear:boolean=true):boolean;
- procedure Clear;
- //для работы c объектами Synapse
- property GMessage:TMimeMess read FMsg write FMsg;
- published
- property Login: string read FLogin write FLogin;
- property Password: string read FPassword write FPassword;
- property Host: string read FHost write FHost;
- property FromEmail: string read FEmail write FEmail;
- property FromName: string read FFromName write FFromName;
- property Port: integer read FPort write FPort;
- property AttachFiles: TStrings read FFiles write SetFiles;
- property Recipients: TStrings read FRecipients write SetRecepients;
- property Mailer: string read GetMailer write SetMailer;
- property OnStatus: THookSocketStatus read FOnStatus write FOnStatus;
-end;
-
-procedure Register;
-
-implementation
-
-procedure Register;
-begin
- RegisterComponents('WebDelphi.ru',[TGMailSMTP]);
-end;
-
-{ TGMailSMTP }
-
-function TGMailSMTP.AddHTML(const aHTML: AnsiString): boolean;
-var Part:TMimePart;
-begin
- Result:=false;
-try
- Part:= FMsg.AddPart(FMsg.MessagePart);
- with Part do
- begin
- DecodedLines.Write(Pointer(aHTML)^, Length(aHTML) * SizeOf(AnsiChar));
- Primary := 'text';
- Secondary := 'html';
- Description := 'HTML text';
- Disposition := 'inline';
- CharsetCode := TargetCharset;
- EncodingCode := ME_QUOTED_PRINTABLE;
- EncodePart;
- EncodePartHeader;
- Result:=true;
- end;
-except
- Result:=false;
-end;
-end;
-
-function TGMailSMTP.AddText(const aText: AnsiString): boolean;
-var Part:TMimePart;
-begin
-Result:=false;
-try
- Part:= FMsg.AddPart(FMsg.MessagePart);
- with Part do
- begin
- DecodedLines.Write(Pointer(aText)^, Length(aText) * SizeOf(AnsiChar));
- Primary := 'text';
- Secondary := 'plain';
- Description := 'Message text';
- Disposition := 'inline';
- CharsetCode :=TargetCharset;
- EncodingCode := ME_QUOTED_PRINTABLE;
- EncodePart;
- EncodePartHeader;
- Result:=true;
- end;
-except
- Result:=false;
-end;
-end;
-
-procedure TGMailSMTP.Clear;
-begin
- FMsg.Clear;
- FFiles.Clear;
- FRecipients.Clear;
-end;
-
-constructor TGMailSMTP.Create(AOwner: TComponent);
-begin
- inherited;
- FFiles:=TStringList.Create;
- FRecipients:=TStringList.Create;
- FMsg:=TMimeMess.Create;
- FMsg.AddPartMultipart('alternate',nil);
- FHost:=GmailHost;
- FPort:=GmailPort;
-end;
-
-destructor TGMailSMTP.Destroy;
-begin
- FFiles.Free;
- FRecipients.Free;
- FMsg.Free;
- inherited;
-end;
-
-function TGMailSMTP.GetMailer: string;
-begin
- Result:=FMsg.Header.XMailer;
-end;
-
-function TGMailSMTP.SendMessage(const aSubject: string; aClear:boolean): boolean;
-var i:integer;
- MailTo: string;
- MailFrom: string;
- SMTP: TSMTPSend;
- s, t: string;
-begin
-Result:=false;
-
-if Length(Trim(FFromName))>0 then
- MailFrom:='"'+FFromName+'" <'+FEmail+'>'
-else
- MailFrom:=FEmail;
- //добавляем заголовки
- FMsg.Header.Subject:=aSubject;
- FMsg.Header.From:=MailFrom;
- FMsg.Header.ToList.Assign(FRecipients);
- //добавляем файлы
- for i:=0 to FFiles.Count - 1 do
- FMsg.AddPartBinaryFromFile(FFiles[i],FMsg.MessagePart);
- MailTo:='';
- FRecipients.Delimiter:=',';
- MailTo:=FRecipients.DelimitedText;
-
- FMsg.EncodeMessage;
- SMTP := TSMTPSend.Create;
- SMTP.AutoTLS:=True;
- SMTP.TargetHost := Trim(FHost);
- SMTP.Sock.OnStatus:=FOnStatus;
- if FPort>0 then
- SMTP.TargetPort:=IntToStr(FPort);
- SMTP.Username := FLogin;
- SMTP.Password := FPassword;
-try
-if SMTP.Login then
- begin
- if SMTP.MailFrom(GetEmailAddr(MailFrom), Length(FMsg.Lines.Text)) then
- begin
- s:=MailTo;
- repeat
- t := GetEmailAddr(Trim(FetchEx(s, ',', '"')));
- if t <> '' then
- Result := SMTP.MailTo(t);
- if not Result then
- Break;
- until s = '';
- if Result then
- Result := SMTP.MailData(FMsg.Lines);
- end;
- SMTP.Logout;
- end;
- finally
- SMTP.Free;
- if aClear then
- Clear;
- end;
-end;
-
-procedure TGMailSMTP.SetFiles(Value: TStrings);
-begin
- FFiles.Assign(Value)
-end;
-
-procedure TGMailSMTP.SetMailer(const Value: string);
-begin
- FMsg.Header.XMailer:=Value;
-end;
-
-procedure TGMailSMTP.SetRecepients(Value: TStrings);
-begin
- FRecipients.Assign(Value);
-end;
-
-end.
+{unit GContacts
+|==============================================================================|
+| Модуль содержит класс для отправки писем через электронную посту GMail.com |
+| с использованием класса бибилотеки Synapse - TSMTPSend. |
+|==============================================================================|
+| ВАЖНО! ВНИМАТЕЛЬНО ПРОЧТИТЕ! |
+|==============================================================================|
+| для нормальной работы компонента Вам необходимо скачать и сохранить |
+| в директории с программой две DLL: |
+| |
+| 1. libeay32.dll |
+| 2. ssleay32.dll |
+| |
+| Скачать их можна на сайте разработчиков Synapse: |
+| http://synapse.ararat.cz/files/crypt/ |
+|==============================================================================|
+| Если Вы планируете использовать компонент для других почтовых сервисов, |
+| которые ни используют шифрованных подключений TLS, то следуетт |
+| закомментировать вот эту строку: |
+| |
+| |
+| function TGMailSMTP.SendMessage([...]): boolean; |
+| var |
+| ... |
+| begin |
+| ... |
+| SMTP.AutoTLS:=True; |
+| ... |
+| |
+| |
+| Основной компонент для работы с почтой - TGMailSMTP. |
+|==============================================================================|
+| Автор: Vlad. (vlad383@gmail.com) |
+| Дата: 27 Июля 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. |
+|==============================================================================|
+| ОБНОВЛЕНИЯ КОМПОНЕНТА |
+|==============================================================================|
+| Последние обновления модуля можно найти в репозитории по адресу: |
+| http://github.com/googleapi |
+| |
+|==============================================================================|
+| История версий |
+|==============================================================================|
+|09.08.2010. Версия 0.21 |
+| + Немного подправлен Destructor компонента |
+|27.07.2010. Версия 0.2 |
+| + исправлена проблема с кодировками писем в Outlook |
+| + добавлено свойство Mailer для идентификацмм почтового клиента |
+| + добавлено событие OnStatus для отслеживания работы соккета |
+|==============================================================================|
+}
+
+unit GMailSMTP;
+
+interface
+
+uses mimemess, mimepart, smtpsend, classes, sysutils,
+ controls,ssl_openssl,synautil,synachar, dialogs,blcksock;
+
+const
+ {$REGION 'Константы'}
+ GMailSMTPVersion = '0.21';
+ GmailHost = 'smtp.gmail.com';
+ GmailPort = 587;
+ {$ENDREGION}
+
+type
+ TGMailSMTP = class(TComponent)
+ private
+ FPort : integer; //порт
+ FLogin : string; //логин для smtp-сервера
+ FPassword : string; //пароль
+ FEmail : string; //почтовый ящик с которого отправляется письмо
+ FFromName : string; //от чьего имени отправляется письмо
+ FHost : string; //хост (smtp-сервер)
+ FFiles : TStrings; //прикрепленные файлы
+ FRecipients: TStrings;//получатели
+ FMsg : TMimeMess;
+ FOnStatus : THookSocketStatus;
+ procedure SetFiles(Value: TStrings);
+ procedure SetRecepients(Value: TStrings);
+ function GetMailer: string;
+ procedure SetMailer(const Value: string);
+ public
+ constructor Create(AOwner: TComponent);override;
+ destructor Destroy;override;
+ function AddText(const aText: AnsiString):boolean;
+ function AddHTML(const aHTML: AnsiString):boolean;
+ function SendMessage(const aSubject:string; aClear:boolean=true):boolean;
+ procedure Clear;
+ //для работы c объектами Synapse
+ property GMessage:TMimeMess read FMsg write FMsg;
+ published
+ property Login: string read FLogin write FLogin;
+ property Password: string read FPassword write FPassword;
+ property Host: string read FHost write FHost;
+ property FromEmail: string read FEmail write FEmail;
+ property FromName: string read FFromName write FFromName;
+ property Port: integer read FPort write FPort;
+ property AttachFiles: TStrings read FFiles write SetFiles;
+ property Recipients: TStrings read FRecipients write SetRecepients;
+ property Mailer: string read GetMailer write SetMailer;
+ property OnStatus: THookSocketStatus read FOnStatus write FOnStatus;
+end;
+
+procedure Register;
+
+implementation
+
+procedure Register;
+begin
+ RegisterComponents('WebDelphi.ru',[TGMailSMTP]);
+end;
+
+{ TGMailSMTP }
+
+function TGMailSMTP.AddHTML(const aHTML: AnsiString): boolean;
+var Part:TMimePart;
+begin
+ Result:=false;
+try
+ Part:= FMsg.AddPart(FMsg.MessagePart);
+ with Part do
+ begin
+ DecodedLines.Write(Pointer(aHTML)^, Length(aHTML) * SizeOf(AnsiChar));
+ Primary := 'text';
+ Secondary := 'html';
+ Description := 'HTML text';
+ Disposition := 'inline';
+ CharsetCode := TargetCharset;
+ EncodingCode := ME_QUOTED_PRINTABLE;
+ EncodePart;
+ EncodePartHeader;
+ Result:=true;
+ end;
+except
+ Result:=false;
+end;
+end;
+
+function TGMailSMTP.AddText(const aText: AnsiString): boolean;
+var Part:TMimePart;
+begin
+Result:=false;
+try
+ Part:= FMsg.AddPart(FMsg.MessagePart);
+ with Part do
+ begin
+ DecodedLines.Write(Pointer(aText)^, Length(aText) * SizeOf(AnsiChar));
+ Primary := 'text';
+ Secondary := 'plain';
+ Description := 'Message text';
+ Disposition := 'inline';
+ CharsetCode :=TargetCharset;
+ EncodingCode := ME_QUOTED_PRINTABLE;
+ EncodePart;
+ EncodePartHeader;
+ Result:=true;
+ end;
+except
+ Result:=false;
+end;
+end;
+
+procedure TGMailSMTP.Clear;
+begin
+ FMsg.Clear;
+ FFiles.Clear;
+ FRecipients.Clear;
+end;
+
+constructor TGMailSMTP.Create(AOwner: TComponent);
+begin
+ inherited;
+ FFiles:=TStringList.Create;
+ FRecipients:=TStringList.Create;
+ FMsg:=TMimeMess.Create;
+ FMsg.AddPartMultipart('alternate',nil);
+ FHost:=GmailHost;
+ FPort:=GmailPort;
+end;
+
+destructor TGMailSMTP.Destroy;
+begin
+ FFiles.Free;
+ FRecipients.Free;
+ FMsg.Free;
+ inherited;
+end;
+
+function TGMailSMTP.GetMailer: string;
+begin
+ Result:=FMsg.Header.XMailer;
+end;
+
+function TGMailSMTP.SendMessage(const aSubject: string; aClear:boolean): boolean;
+var i:integer;
+ MailTo: string;
+ MailFrom: string;
+ SMTP: TSMTPSend;
+ s, t: string;
+begin
+Result:=false;
+
+if Length(Trim(FFromName))>0 then
+ MailFrom:='"'+FFromName+'" <'+FEmail+'>'
+else
+ MailFrom:=FEmail;
+ //добавляем заголовки
+ FMsg.Header.Subject:=aSubject;
+ FMsg.Header.From:=MailFrom;
+ FMsg.Header.ToList.Assign(FRecipients);
+ //добавляем файлы
+ for i:=0 to FFiles.Count - 1 do
+ FMsg.AddPartBinaryFromFile(FFiles[i],FMsg.MessagePart);
+ MailTo:='';
+ FRecipients.Delimiter:=',';
+ MailTo:=FRecipients.DelimitedText;
+
+ FMsg.EncodeMessage;
+ SMTP := TSMTPSend.Create;
+ SMTP.AutoTLS:=True;
+ SMTP.TargetHost := Trim(FHost);
+ SMTP.Sock.OnStatus:=FOnStatus;
+ if FPort>0 then
+ SMTP.TargetPort:=IntToStr(FPort);
+ SMTP.Username := FLogin;
+ SMTP.Password := FPassword;
+try
+if SMTP.Login then
+ begin
+ if SMTP.MailFrom(GetEmailAddr(MailFrom), Length(FMsg.Lines.Text)) then
+ begin
+ s:=MailTo;
+ repeat
+ t := GetEmailAddr(Trim(FetchEx(s, ',', '"')));
+ if t <> '' then
+ Result := SMTP.MailTo(t);
+ if not Result then
+ Break;
+ until s = '';
+ if Result then
+ Result := SMTP.MailData(FMsg.Lines);
+ end;
+ SMTP.Logout;
+ end;
+ finally
+ SMTP.Free;
+ if aClear then
+ Clear;
+ end;
+end;
+
+procedure TGMailSMTP.SetFiles(Value: TStrings);
+begin
+ FFiles.Assign(Value)
+end;
+
+procedure TGMailSMTP.SetMailer(const Value: string);
+begin
+ FMsg.Header.XMailer:=Value;
+end;
+
+procedure TGMailSMTP.SetRecepients(Value: TStrings);
+begin
+ FRecipients.Assign(Value);
+end;
+
+end.
diff --git a/packages/gmail_pack/gmail_pack.dpk b/packages/gmail_pack/gmail_pack.dpk
index a28b7e0..1dcbd73 100644
--- a/packages/gmail_pack/gmail_pack.dpk
+++ b/packages/gmail_pack/gmail_pack.dpk
@@ -1,40 +1,40 @@
-package gmail_pack;
-
-{$R *.res}
-{$ALIGN 8}
-{$ASSERTIONS ON}
-{$BOOLEVAL OFF}
-{$DEBUGINFO ON}
-{$EXTENDEDSYNTAX ON}
-{$IMPORTEDDATA ON}
-{$IOCHECKS ON}
-{$LOCALSYMBOLS ON}
-{$LONGSTRINGS ON}
-{$OPENSTRINGS ON}
-{$OPTIMIZATION ON}
-{$OVERFLOWCHECKS OFF}
-{$RANGECHECKS OFF}
-{$REFERENCEINFO OFF}
-{$SAFEDIVIDE OFF}
-{$STACKFRAMES OFF}
-{$TYPEDADDRESS OFF}
-{$VARSTRINGCHECKS ON}
-{$WRITEABLECONST OFF}
-{$MINENUMSIZE 1}
-{$IMAGEBASE $400000}
-{$IMPLICITBUILD ON}
-
-requires
- rtl,
- vcl;
-
-contains
- GMailSMTP in 'GMailSMTP.pas',
- mimemess in '..\..\addons\synapse\mimemess.pas',
- mimepart in '..\..\addons\synapse\mimepart.pas',
- smtpsend in '..\..\addons\synapse\smtpsend.pas',
- synachar in '..\..\addons\synapse\synachar.pas',
- blcksock in '..\..\addons\synapse\blcksock.pas',
- synsock in '..\..\addons\synapse\synsock.pas';
-
-end.
+package gmail_pack;
+
+{$R *.res}
+{$ALIGN 8}
+{$ASSERTIONS ON}
+{$BOOLEVAL OFF}
+{$DEBUGINFO ON}
+{$EXTENDEDSYNTAX ON}
+{$IMPORTEDDATA ON}
+{$IOCHECKS ON}
+{$LOCALSYMBOLS ON}
+{$LONGSTRINGS ON}
+{$OPENSTRINGS ON}
+{$OPTIMIZATION ON}
+{$OVERFLOWCHECKS OFF}
+{$RANGECHECKS OFF}
+{$REFERENCEINFO OFF}
+{$SAFEDIVIDE OFF}
+{$STACKFRAMES OFF}
+{$TYPEDADDRESS OFF}
+{$VARSTRINGCHECKS ON}
+{$WRITEABLECONST OFF}
+{$MINENUMSIZE 1}
+{$IMAGEBASE $400000}
+{$IMPLICITBUILD ON}
+
+requires
+ rtl,
+ vcl;
+
+contains
+ GMailSMTP in 'GMailSMTP.pas',
+ mimemess in '..\..\addons\synapse\mimemess.pas',
+ mimepart in '..\..\addons\synapse\mimepart.pas',
+ smtpsend in '..\..\addons\synapse\smtpsend.pas',
+ synachar in '..\..\addons\synapse\synachar.pas',
+ blcksock in '..\..\addons\synapse\blcksock.pas',
+ synsock in '..\..\addons\synapse\synsock.pas';
+
+end.
diff --git a/packages/gmail_pack/gmail_pack.dproj b/packages/gmail_pack/gmail_pack.dproj
index b3d20bc..f3f54af 100644
--- a/packages/gmail_pack/gmail_pack.dproj
+++ b/packages/gmail_pack/gmail_pack.dproj
@@ -1,115 +1,115 @@
-
-
- {C7003DCA-7B41-4412-BA8B-09DB78A1BDA0}
- gmail_pack.dpk
- 12.0
- Debug
- DCC32
-
-
- true
-
-
- true
- Base
- true
-
-
- true
- Base
- true
-
-
- 00400000
- 0
- true
- WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)
- x86
- C:\Users\Public\Documents\RAD Studio\7.0\Bpl\gmail_pack.bpl
- false
- false
- true
- false
- false
- false
-
-
- false
- RELEASE;$(DCC_Define)
- 0
- false
-
-
- DEBUG;$(DCC_Define)
-
-
-
- MainSource
-
-
-
-
-
-
-
-
-
-
-
- Base
-
-
- Cfg_2
- Base
-
-
- Cfg_1
- Base
-
-
-
-
- Delphi.Personality.12
- Package
-
-
-
- gmail_pack.dpk
-
-
- False
- True
- False
-
-
- True
- False
- 1
- 0
- 0
- 0
- False
- False
- False
- False
- False
- 1049
- 1251
-
-
-
-
- 1.0.0.0
-
-
-
-
-
- 1.0.0.0
-
-
-
-
- 12
-
-
+
+
+ {C7003DCA-7B41-4412-BA8B-09DB78A1BDA0}
+ gmail_pack.dpk
+ 12.0
+ Debug
+ DCC32
+
+
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ 00400000
+ 0
+ true
+ WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)
+ x86
+ C:\Users\Public\Documents\RAD Studio\7.0\Bpl\gmail_pack.bpl
+ false
+ false
+ true
+ false
+ false
+ false
+
+
+ false
+ RELEASE;$(DCC_Define)
+ 0
+ false
+
+
+ DEBUG;$(DCC_Define)
+
+
+
+ MainSource
+
+
+
+
+
+
+
+
+
+
+
+ Base
+
+
+ Cfg_2
+ Base
+
+
+ Cfg_1
+ Base
+
+
+
+
+ Delphi.Personality.12
+ Package
+
+
+
+ gmail_pack.dpk
+
+
+ False
+ True
+ False
+
+
+ True
+ False
+ 1
+ 0
+ 0
+ 0
+ False
+ False
+ False
+ False
+ False
+ 1049
+ 1251
+
+
+
+
+ 1.0.0.0
+
+
+
+
+
+ 1.0.0.0
+
+
+
+
+ 12
+
+
diff --git a/packages/googleLogin_pack/GoogleLogin.dproj b/packages/googleLogin_pack/GoogleLogin.dproj
index a0afb16..253d7d1 100644
--- a/packages/googleLogin_pack/GoogleLogin.dproj
+++ b/packages/googleLogin_pack/GoogleLogin.dproj
@@ -1,11 +1,14 @@
-<<<<<<< HEAD
{DA3343F7-B6E3-4BC9-B427-4D5119728B14}
GoogleLogin.dpk
- 12.0
+ 12.3
Debug
DCC32
+ True
+ Win32
+ Package
+ VCL
true
@@ -46,19 +49,20 @@
-
- Base
-
Cfg_2
Base
+
+ Base
+
Cfg_1
Base
-
+
+
Delphi.Personality.12
Package
@@ -67,11 +71,7 @@
GoogleLogin.dpk
-
- False
- True
- False
-
+
True
False
@@ -101,117 +101,10 @@
+
+ True
+
12
-=======
-
-
- {DA3343F7-B6E3-4BC9-B427-4D5119728B14}
- GoogleLogin.dpk
- 12.0
- Debug
- DCC32
-
-
- true
-
-
- true
- Base
- true
-
-
- true
- Base
- true
-
-
- WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)
- C:\Users\Public\Documents\RAD Studio\7.0\Bpl\GoogleLogin.bpl
- 0
- true
- true
- 00400000
- x86
-
-
- false
- RELEASE;$(DCC_Define)
- 0
- false
-
-
- DEBUG;$(DCC_Define)
-
-
-
- MainSource
-
-
-
-
-
- Base
-
-
- Cfg_2
- Base
-
-
- Cfg_1
- Base
-
-
-
-
- Delphi.Personality.12
- Package
-
-
-
- GoogleLogin.dpk
-
-
- False
- True
- False
-
-
- True
- False
- 1
- 0
- 0
- 0
- False
- False
- False
- False
- False
- 1049
- 1251
-
-
-
-
- 1.0.0.0
-
-
-
-
-
- 1.0.0.0
-
-
-
- Microsoft Office 2000 Sample Automation Server Wrapper Components
- Microsoft Office XP Sample Automation Server Wrapper Components
-
-
-
- 12
-
-
->>>>>>> remotes/origin/master
diff --git a/packages/googleLogin_pack/GoogleLogin.identcache b/packages/googleLogin_pack/GoogleLogin.identcache
index 9f779a9..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 e396453..1a9a3a6 100644
--- a/packages/googleLogin_pack/uGoogleLogin.pas
+++ b/packages/googleLogin_pack/uGoogleLogin.pas
@@ -1,27 +1,8 @@
-<<<<<<< HEAD
-{ ******************************************************* }
-{ }
-{ 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 = 'Аутентификация не производилась или сброшена';
@@ -41,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
@@ -53,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);
@@ -67,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;
public
{ public declarations }
- constructor Create(CreateSuspennded: BOOLEAN; aParamStr: string;aParentComp:TComponent); // используем для передачи логина и пароля и подобного
- procedure Execute; override; // выполняем непосредственно авторизацию на сайте
+ 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;
@@ -205,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;
@@ -219,7 +150,7 @@ implementation
procedure Register;
begin
- RegisterComponents('WebDelphi.ru', [TGoogleLogin]);
+ RegisterComponents('BuBa Group', [TGoogleLogin]);
end;
{ TGoogleLogin }
@@ -240,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:
@@ -293,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.Resume; // запуск
- // тут делать смысла что то нет так как данные еще не получены(они ведь будут получены в другом потоке)
end;
-// устанавливаем значение строки символов, которая передается серверу
-// идентифицирует программное обеспечение, пославшее запрос.
procedure TGoogleLogin.SetAppName(value: string);
begin
if not(value = '') then
@@ -323,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);
@@ -345,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;
@@ -469,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;
@@ -486,47 +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);
+ 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;
@@ -535,28 +375,23 @@ 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;
- FLastResult:=FLastResult;
- //если все хорошо, авторизировались
- if FLastResult= lrOk then
+ if FLastResult<>lrCaptchaRequired then
begin
Synchronize(SynAutoriz);
end;
- Synchronize(SynCapchaToken);
end;
function TGoogleLoginThread.ExpertLoginResult(const LoginResult: string)
@@ -565,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);
@@ -601,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
@@ -634,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;
@@ -658,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;
@@ -691,7 +525,6 @@ function TGoogleLoginThread.GetResultText: string;
end;
end;
-//загрузка капчи
function TGoogleLoginThread.LoadCaptcha(aCaptchaURL: string): Boolean;
function DataAvailable(hRequest: pointer; out Size: cardinal): BOOLEAN;
begin
@@ -700,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
@@ -718,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;
@@ -734,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;
@@ -751,7 +581,6 @@ procedure TGoogleLoginThread.SynAutoriz;
OnAutorization(FLastResult, FResultRec);
end;
-//необходимо ввести капчу
procedure TGoogleLoginThread.SynCapchaToken;
begin
if Assigned(FParentComp) then
@@ -767,383 +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;
-=======
-{*******************************************************}
-{ }
-{ Delphi & Google API }
-{ }
-{ File: uGoogleLogin }
-{ Copyright (c) WebDelphi.ru }
-{ All Rights Reserved. }
-{ }
-{ }
-{ }
-{*******************************************************}
-
-{*******************************************************}
-{ GoogleLogin Component }
-{*******************************************************}
-
-unit uGoogleLogin;
-
-interface
-
-uses WinInet, StrUtils, SysUtils, Classes;
-
-resourcestring
- rcNone = ' ';
- rcOk = ' ';
- rcBadAuthentication =' , ';
- rcNotVerified =' , , ';
- rcTermsNotAgreed =' ';
- rcCaptchaRequired =' CAPTCHA';
- rcUnknown =' ';
- rcAccountDeleted =' ';
- rcAccountDisabled =' ';
- rcServiceDisabled =' ';
- rcServiceUnavailable =' , ';
- rcDisconnect =' ';
-
-const
- DefoultAppName = 'Noname-MyCompany-1.0';
-
- Flags_Connection = INTERNET_DEFAULT_HTTPS_PORT;
-
- Flags_Request = INTERNET_FLAG_RELOAD or
- INTERNET_FLAG_IGNORE_CERT_CN_INVALID or
- INTERNET_FLAG_NO_CACHE_WRITE or
- 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);
-
-type
- TLoginResult = (lrNone,lrOk, lrBadAuthentication, lrNotVerified,
- lrTermsNotAgreed, lrCaptchaRequired, lrUnknown,
- lrAccountDeleted, lrAccountDisabled, lrServiceDisabled,
- lrServiceUnavailable);
-
-type
- TServices = (tsNone,tsAnalytics,tsApps,tsGBase,tsSites,tsBlogger,tsBookSearch,
- tsCelendar,tcCodeSearch,tsContacts,tsDocLists,tsFinance,
- tsGMailFeed,tsHealth,tsMaps,tsPicasa,tsSidewiki,tsSpreadsheets,
- tsWebmaster,tsYouTube);
-
-const
- ServiceIDs: array[0..19]of string=('xapi','analytics','apps','gbase',
- 'jotspot','blogger','print','cl','codesearch','cp','writely','finance',
- 'mail','health','local','lh2','annotateweb','wise','sitemaps','youtube');
-
-type
- TAfterLogin = procedure (const LoginResult: TLoginResult; LoginStr:string)of object;
- TDisconnect = procedure (const ResultStr:string)of object;
-
-type
- TGoogleLogin = class(TComponent)
- private
- //
- FAccountType : TAccountType;
- FLastResult : TLoginResult;
- FEmail : string;
- FPassword : string;
- // /
- FSID : string;//
- FLSID : string;//
- FAuth : string;
- FService : TServices;//
- FSource : string;//
- FLogintoken : string;
- FLogincaptcha : string;
- // Captcha
- FCaptchaURL : string;
- FAfterLogin : TAfterLogin;
- FDisconnect : TDisconnect;
- function SendRequest(const ParamStr: string):AnsiString;
- function ExpertLoginResult(const LoginResult:string):TLoginResult;
- function GetLoginError(const str: string):TLoginResult;
- function GetCaptchaToken(const cList:TStringList):String;
- function GetCaptchaURL(const cList:TStringList):string;
- function GetResultText:string;
- procedure SetEmail(cEmail:string);
- procedure SetPassword(cPassword:string);
- procedure SetService(cService:TServices);
- procedure SetSource(cSource: string);
- procedure SetCaptcha(cCaptcha:string);
- public
- constructor Create(AOwner: TComponent);override;
- function Login(aLoginToken:string='';aLoginCaptcha:string=''):TLoginResult;overload;
- procedure Disconnect;//
- property LastResult: TLoginResult read FLastResult;
- property LastResultText:string read GetResultText;
- property Auth: string read FAuth;
- property SID: string read FSID;
- property LSID: string read FLSID;
- property CaptchaURL: string read FCaptchaURL;
- property LoginToken: string read FLogintoken;
- property LoginCaptcha: string read FLogincaptcha write FLogincaptcha;
- published
- property AccountType: TAccountType read FAccountType write FAccountType;
- property Email: string read FEmail write SetEmail;
- property Password:string read FPassword write SetPassword;
- property Service: TServices read FService write SetService;
- property Source: string read FSource write FSource;
- property OnAfterLogin :TAfterLogin read FAfterLogin write FAfterLogin;
- property OnDisconnect: TDisconnect read FDisconnect write FDisconnect;
-end;
-
-procedure Register;
-
-implementation
-
-procedure Register;
-begin
- RegisterComponents('WebDelphi.ru',[TGoogleLogin]);
-end;
-
-{ TGoogleLogin }
-
-procedure TGoogleLogin.Disconnect;
-begin
- FAccountType:=atNone;
- FLastResult:=lrNone;
- FSID:='';
- FLSID:='';
- FAuth:='';
- FLogintoken:='';
- FLogincaptcha:='';
- FCaptchaURL:='';
- FLogintoken:='';
- if Assigned(FDisconnect) then
- OnDisconnect(rcDisconnect)
-end;
-
-constructor TGoogleLogin.Create(AOwner: TComponent);
-begin
-inherited Create(AOwner);
-end;
-
-function TGoogleLogin.ExpertLoginResult(const LoginResult: string): TLoginResult;
-var List: TStringList;
- i:integer;
-begin
-//
- List:=TStringList.Create;
- List.Text:=LoginResult;
-//
-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 //
- begin
- Result:=GetLoginError(List[i]);//
- break;
- end;
- end;
- if Result=lrCaptchaRequired then //
- begin
- FCaptchaURL:=GetCaptchaURL(List);
- FLogintoken:=GetCaptchaToken(List);
- end;
- end
-else
- begin
- Result:=lrOk;
- for i:=0 to List.Count-1 do
- begin
- if pos('SID',UpperCase(List[i]))>0 then
- FSID:=Trim(copy(List[i],pos('=',List[i])+1,Length(List[i])-pos('=',List[i])))
- else
- if pos('LSID',UpperCase(List[i]))>0 then
- FLSID:=Trim(copy(List[i],pos('=',List[i])+1,Length(List[i])-pos('=',List[i])))
- else
- if pos('AUTH',UpperCase(List[i]))>0 then
- FAuth:=Trim(copy(List[i],pos('=',List[i])+1,Length(List[i])-pos('=',List[i])));
- end;
- end;
-FreeAndNil(List);
-end;
-
-function TGoogleLogin.GetCaptchaToken(const cList: TStringList): String;
-var i:integer;
-begin
- for I := 0 to cList.Count - 1 do
- begin
- if pos('captchatoken',lowerCase(cList[i]))>0 then
- begin
- Result:=Trim(copy(cList[i],pos('=',cList[i])+1,Length(cList[i])-pos('=',cList[i])));
- break;
- end;
- end;
-end;
-
-function TGoogleLogin.GetCaptchaURL(const cList: TStringList): string;
-var i:integer;
-begin
- for I := 0 to cList.Count - 1 do
- begin
- if pos('captchaurl',lowerCase(cList[i]))>0 then
- begin
- Result:=Trim(copy(cList[i],pos('=',cList[i])+1,Length(cList[i])-pos('=',cList[i])));
- break;
- end;
- end;
-end;
-
-function TGoogleLogin.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);
-end;
-
-function TGoogleLogin.GetResultText: string;
-begin
- case FLastResult of
- lrNone: Result:=rcNone;
- lrOk: Result:=rcOk;
- lrBadAuthentication: Result:=rcBadAuthentication;
- lrNotVerified: Result:=rcNotVerified;
- lrTermsNotAgreed: Result:=rcTermsNotAgreed;
- lrCaptchaRequired: Result:=rcCaptchaRequired;
- lrUnknown: Result:=rcUnknown;
- lrAccountDeleted: Result:=rcAccountDeleted;
- lrAccountDisabled: Result:=rcAccountDisabled;
- lrServiceDisabled: Result:=rcServiceDisabled;
- lrServiceUnavailable: Result:=rcServiceUnavailable;
- end;
-end;
-
-function TGoogleLogin.Login(aLoginToken, aLoginCaptcha: string): TLoginResult;
-var cBody: TStringStream;
- ResponseText: string;
-begin
- //
- cBody:=TStringStream.Create('');
- case FAccountType of
- atNone,atHOSTED_OR_GOOGLE:cBody.WriteString('accountType=HOSTED_OR_GOOGLE&');
- atGOOGLE:cBody.WriteString('accountType=GOOGLE&');
- atHOSTED:cBody.WriteString('accountType=HOSTED&');
- end;
- cBody.WriteString('Email='+FEmail+'&');
- cBody.WriteString('Passwd='+FPassword+'&');
- cBody.WriteString('service='+ServiceIDs[ord(FService)]+'&');
-
- if Length(Trim(FSource))>0 then
- cBody.WriteString('source='+FSource)
- else
- cBody.WriteString('source='+DefoultAppName);
- if Length(Trim(aLoginToken))>0 then
- begin
- cBody.WriteString('&logintoken='+aLoginToken);
- cBody.WriteString('&logincaptcha='+aLoginCaptcha);
- end;
-//
-ResponseText:=SendRequest(cBody.DataString);
-//
-Result:=ExpertLoginResult(ResponseText);
-FLastResult:=Result;
-if Assigned(FAfterLogin) then
- OnAfterLogin(FLastResult,GetResultText)
-end;
-
-function TGoogleLogin.SendRequest(const ParamStr: string): AnsiString;
- function DataAvailable(hRequest: pointer; out Size : cardinal): boolean;
- begin
- result := wininet.InternetQueryDataAvailable(hRequest, Size, 0, 0);
- end;
-var hInternet,hConnect,hRequest : Pointer;
- dwBytesRead,I,L : Cardinal;
-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?'+ParamStr),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);// -
- if L = 0 then break;
- SetLength(Result,L + I);
- if InternetReadFile(hRequest,@Result[I],sizeof(L),dwBytesRead) then//
- else break;
- inc(I,dwBytesRead);
- until dwBytesRead = 0;
- Result[I] := #0;
- end;
- end;
- end;
- end;
-finally
- InternetCloseHandle(hRequest);
- InternetCloseHandle(hConnect);
- InternetCloseHandle(hInternet);
-end;
-end;
-
-procedure TGoogleLogin.SetCaptcha(cCaptcha: string);
-begin
- FLogincaptcha:=cCaptcha;
- Login(FLogintoken,FLogincaptcha);//
-end;
-
-procedure TGoogleLogin.SetEmail(cEmail: string);
-begin
- FEmail:=cEmail;
- if FLastResult=lrOk then
- Disconnect;//
-end;
-
-procedure TGoogleLogin.SetPassword(cPassword: string);
-begin
- FPassword:=cPassword;
- if FLastResult=lrOk then
- Disconnect;//
-end;
-
-procedure TGoogleLogin.SetService(cService: TServices);
-begin
- FService:=cService;
- if FLastResult=lrOk then
- begin
- Disconnect;//
- Login; //
- end;
-end;
-
-procedure TGoogleLogin.SetSource(cSource: string);
-begin
-FSource:=cSource;
-if FLastResult=lrOk then
- Disconnect;//
-end;
-
->>>>>>> remotes/origin/master
end.
diff --git a/packages/translator_pack/Translator_pack.dpk b/packages/translator_pack/Translator_pack.dpk
index 79b2442..487cdb9 100644
--- a/packages/translator_pack/Translator_pack.dpk
+++ b/packages/translator_pack/Translator_pack.dpk
@@ -1,30 +1,35 @@
-package Translator_pack;
-
-{$R *.res}
-{$ALIGN 8}
-{$ASSERTIONS ON}
-{$BOOLEVAL OFF}
-{$DEBUGINFO ON}
-{$EXTENDEDSYNTAX ON}
-{$IMPORTEDDATA ON}
-{$IOCHECKS ON}
-{$LOCALSYMBOLS ON}
-{$LONGSTRINGS ON}
-{$OPENSTRINGS ON}
-{$OPTIMIZATION ON}
-{$OVERFLOWCHECKS OFF}
-{$RANGECHECKS OFF}
-{$REFERENCEINFO OFF}
-{$SAFEDIVIDE OFF}
-{$STACKFRAMES OFF}
-{$TYPEDADDRESS OFF}
-{$VARSTRINGCHECKS ON}
-{$WRITEABLECONST OFF}
-{$MINENUMSIZE 1}
-{$IMAGEBASE $400000}
-{$IMPLICITBUILD ON}
-
-requires
- rtl;
-
-end.
+package Translator_pack;
+
+{$R *.res}
+{$ALIGN 8}
+{$ASSERTIONS ON}
+{$BOOLEVAL OFF}
+{$DEBUGINFO ON}
+{$EXTENDEDSYNTAX ON}
+{$IMPORTEDDATA ON}
+{$IOCHECKS ON}
+{$LOCALSYMBOLS ON}
+{$LONGSTRINGS ON}
+{$OPENSTRINGS ON}
+{$OPTIMIZATION ON}
+{$OVERFLOWCHECKS OFF}
+{$RANGECHECKS OFF}
+{$REFERENCEINFO OFF}
+{$SAFEDIVIDE OFF}
+{$STACKFRAMES OFF}
+{$TYPEDADDRESS OFF}
+{$VARSTRINGCHECKS ON}
+{$WRITEABLECONST OFF}
+{$MINENUMSIZE 1}
+{$IMAGEBASE $400000}
+{$IMPLICITBUILD ON}
+
+requires
+ 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 cde64d9..a268786 100644
--- a/packages/translator_pack/Translator_pack.dproj
+++ b/packages/translator_pack/Translator_pack.dproj
@@ -1,106 +1,113 @@
-
-
- {A8A6F560-7E36-46FD-9177-49EC16EFFD9B}
- Translator_pack.dpk
- 12.0
- Debug
- DCC32
-
-
- true
-
-
- true
- Base
- true
-
-
- true
- Base
- true
-
-
- WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)
- C:\Users\Public\Documents\RAD Studio\7.0\Bpl\Translator_pack.bpl
- 0
- true
- true
- 00400000
- x86
-
-
- false
- RELEASE;$(DCC_Define)
- 0
- false
-
-
- DEBUG;$(DCC_Define)
-
-
-
- MainSource
-
-
-
- Base
-
-
- Cfg_2
- Base
-
-
- Cfg_1
- Base
-
-
-
-
- Delphi.Personality.12
- Package
-
-
-
- False
- True
- False
-
-
- True
- False
- 1
- 0
- 0
- 0
- False
- False
- False
- False
- False
- 1049
- 1251
-
-
-
-
- 1.0.0.0
-
-
-
-
-
- 1.0.0.0
-
-
-
- File G:\notepad gnu\SynEdit\Source\SynEdit_D5.bpl not found
- Microsoft Office 2000 Sample Automation Server Wrapper Components
-
-
- Translator_pack.dpk
-
-
-
- 12
-
-
+
+
+ {A8A6F560-7E36-46FD-9177-49EC16EFFD9B}
+ Translator_pack.dpk
+ 12.3
+ Debug
+ DCC32
+ True
+ Win32
+ Package
+ VCL
+
+
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)
+ C:\Users\Public\Documents\RAD Studio\7.0\Bpl\Translator_pack.bpl
+ 0
+ true
+ true
+ 00400000
+ x86
+
+
+ false
+ RELEASE;$(DCC_Define)
+ 0
+ false
+
+
+ DEBUG;$(DCC_Define)
+
+
+
+ MainSource
+
+
+
+
+
+
+ Cfg_2
+ Base
+
+
+ Base
+
+
+ Cfg_1
+ Base
+
+
+
+
+
+ Delphi.Personality.12
+ Package
+
+
+
+
+ True
+ False
+ 1
+ 0
+ 0
+ 0
+ False
+ False
+ False
+ False
+ False
+ 1049
+ 1251
+
+
+
+
+ 1.0.0.0
+
+
+
+
+
+ 1.0.0.0
+
+
+
+ File G:\notepad gnu\SynEdit\Source\SynEdit_D5.bpl not found
+ 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/GConsts.pas b/source/GConsts.pas
index dff36c5..ebae4c0 100644
--- a/source/GConsts.pas
+++ b/source/GConsts.pas
@@ -1,394 +1,394 @@
-unit GConsts;
-
-interface
-
-uses uLanguage, SysUtils, Windows;
-
-const
- CpProtocolVer = '3.0'; //версия протокола для Google Contacts
- CpNodeAlias = 'gContact:';//префикс XML-узлов, относящихся к Contacts
- CpGroupLink='http://www.google.com/m8/feeds/groups/%s/full';//URL на получение сведения о группах
- CpContactsLink='http://www.google.com/m8/feeds/contacts/default/full';//URL на получение сведений о контактах для пользователя по умолчанию
- CpPhotoLink = 'http://schemas.google.com/contacts/2008/rel#photo';
- CpDefaultCName = 'NoName Contact';
-
- gttNodeAlias ='gtt:';
- gdNodeAlias = 'gd:';//префикс узлов, относящихся к GData API
- sDefoultMimeType = 'application/atom+xml';
- sEventRelSuffix = 'event.';
- sImgRel = 'image/*'; //атрибут rel узла, содержащего изображения
- sAtomAlias = 'atom:'; //префикс узлов для формирования документа в формате Атом
- sXMLHeader = '';//заголовок XML документа по умолчанию
- sDefoultEncoding = 'utf-8';//кодировка документов по умолчанию
- sRootNodeName= 'feed';//корневой элемент фида
- sNodeValueAttr = 'value';//аттрибут узлов для хранения какого-либо значения
- sNodePrimaryAttr = 'primary';
- sNodeDeletedAttr = 'deleted';
- sNodeCodeAttr = 'code';
- sNodeKeyAttr = 'key';
- sEntryNodeName = 'entry';//имя узла, который необходимо разобрать
- sNodeRelAttr = 'rel';//аттрибут rel узла
- sNodeLabelAttr ='label';//аттрибут label узла
- sNodeHrefAttr = 'href';//атрибут наличия ссылки в узле.
- sSchemaHref ='http://schemas.google.com/g/2005#';
-
- {цвета в HEX поддерживаемые Google API}
- sGoogleColors: array [1..21]of string = ('A32929','B1365F','7A367A','5229A3',
- '29527A','2952A3','1B887A','28754E',
- '0D7813','528800','88880E','AB8B00',
- 'BE6D00','B1440E','865A5A','705770',
- '4E5D6C','5A6986','4A716C','6E6E41',
- '8D6F47');
-
- {часовые пояса}
- sGoogleTimeZones: array [0..308,0..3]of string =
- (('Pacific/Apia','(GMT-11:00) Апия','-11,00',''),
- ('Pacific/Midway','(GMT-11:00) Мидуэй','-11,00',''),
- ('Pacific/Niue','(GMT-11:00) Ниуэ','-11,00',''),
- ('Pacific/Pago_Pago','(GMT-11:00) Паго-Паго','-11,00',''),
- ('Pacific/Fakaofo','(GMT-10:00) Факаофо','-10,00',''),
- ('Pacific/Honolulu','(GMT-10:00) Гавайское время','-10,00',''),
- ('Pacific/Johnston','(GMT-10:00) атолл Джонстон','-10,00',''),
- ('Pacific/Rarotonga','(GMT-10:00) Раротонга','-10,00',''),
- ('Pacific/Tahiti','(GMT-10:00) Таити','-10,00',''),
- ('Pacific/Marquesas','(GMT-09:30) Маркизские острова','-09,30',''),
- ('America/Anchorage','(GMT-09:00) Время Аляски','-09,00',''),
- ('Pacific/Gambier','(GMT-09:00) Гамбир','-09,00',''),
- ('America/Los_Angeles','(GMT-08:00) Тихоокеанское время','-08,00',''),
- ('America/Tijuana','(GMT-08:00) Тихоокеанское время – Тихуана','-08,00',''),
- ('America/Vancouver','(GMT-08:00) Тихоокеанское время – Ванкувер','-08,00',''),
- ('America/Whitehorse','(GMT-08:00) Тихоокеанское время – Уайтхорс','-08,00',''),
- ('Pacific/Pitcairn','(GMT-08:00) Питкэрн','-08,00',''),
- ('America/Dawson_Creek','(GMT-07:00) Горное время – Доусон Крик','-07,00',''),
- ('America/Denver','(GMT-07:00) Горное время (America/Denver)','-07,00',''),
- ('America/Edmonton','(GMT-07:00) Горное время – Эдмонтон','-07,00',''),
- ('America/Hermosillo','(GMT-07:00) Горное время – Эрмосильо','-07,00',''),
- ('America/Mazatlan','(GMT-07:00) Горное время – Чиуауа, Мазатлан','-07,00',''),
- ('America/Phoenix','(GMT-07:00) Горное время – Аризона','-07,00',''),
- ('America/Yellowknife','(GMT-07:00) Горное время – Йеллоунайф','-07,00',''),
- ('America/Belize','(GMT-06:00) Белиз','-06,00',''),
- ('America/Chicago','(GMT-06:00) Центральное время','-06,00',''),
- ('America/Costa_Rica','(GMT-06:00) Коста-Рика','-06,00',''),
- ('America/El_Salvador','(GMT-06:00) Сальвадор','-06,00',''),
- ('America/Guatemala','(GMT-06:00) Гватемала','-06,00',''),
- ('America/Managua','(GMT-06:00) Манагуа','-06,00',''),
- ('America/Mexico_City','(GMT-06:00) Центральное время – Мехико','-06,00',''),
- ('America/Regina','(GMT-06:00) Центральное время – Реджайна','-06,00',''),
- ('America/Tegucigalpa','(GMT-06:00) Центральное время (America/Tegucigalpa)','-06,00',''),
- ('America/Winnipeg','(GMT-06:00) Центральное время – Виннипег','-06,00',''),
- ('Pacific/Easter','(GMT-06:00) остров Пасхи','-06,00',''),
- ('Pacific/Galapagos','(GMT-06:00) Галапагос','-06,00',''),
- ('America/Bogota','(GMT-05:00) Богота','-05,00',''),
- ('America/Cayman','(GMT-05:00) Каймановы острова','-05,00',''),
- ('America/Grand_Turk','(GMT-05:00) Гранд Турк','-05,00',''),
- ('America/Guayaquil','(GMT-05:00) Гуаякиль','-05,00',''),
- ('America/Havana','(GMT-05:00) Гавана','-05,00',''),
- ('America/Iqaluit','(GMT-05:00) Восточное время – Икалуит','-05,00',''),
- ('America/Jamaica','(GMT-05:00) Ямайка','-05,00',''),
- ('America/Lima','(GMT-05:00) Лима','-05,00',''),
- ('America/Montreal','(GMT-05:00) Восточное время – Монреаль','-05,00',''),
- ('America/Nassau','(GMT-05:00) Нассау','-05,00',''),
- ('America/New_York','(GMT-05:00) Восточное время','-05,00',''),
- ('America/Panama','(GMT-05:00) Панама','-05,00',''),
- ('America/Port-au-Prince','(GMT-05:00) Порт-о-Пренс','-05,00',''),
- ('America/Toronto','(GMT-05:00) Восточное время – Торонто','-05,00',''),
- ('America/Caracas','(GMT-04:30) Каракас','-04,30',''),
- ('America/Anguilla','(GMT-04:00) Ангилья','-04,00',''),
- ('America/Antigua','(GMT-04:00) Антигуа','-04,00',''),
- ('America/Aruba','(GMT-04:00) Аруба','-04,00',''),
- ('America/Asuncion','(GMT-04:00) Асунсьон','-04,00',''),
- ('America/Barbados','(GMT-04:00) Барбадос','-04,00',''),
- ('America/Boa_Vista','(GMT-04:00) Боа-Виста','-04,00',''),
- ('America/Campo_Grande','(GMT-04:00) Кампу-Гранди','-04,00',''),
- ('America/Cuiaba','(GMT-04:00) Куяба','-04,00',''),
- ('America/Curacao','(GMT-04:00) Кюрасао','-04,00',''),
- ('America/Dominica','(GMT-04:00) Доминика','-04,00',''),
- ('America/Grenada','(GMT-04:00) Гренада','-04,00',''),
- ('America/Guadeloupe','(GMT-04:00) Гваделупа','-04,00',''),
- ('America/Guyana','(GMT-04:00) Гайана','-04,00',''),
- ('America/Halifax','(GMT-04:00) Атлантическое время – Галифакс','-04,00',''),
- ('America/La_Paz','(GMT-04:00) Ла-Пас','-04,00',''),
- ('America/Manaus','(GMT-04:00) Манаус','-04,00',''),
- ('America/Martinique','(GMT-04:00) Мартиника','-04,00',''),
- ('America/Montserrat','(GMT-04:00) Монсеррат','-04,00',''),
- ('America/Port_of_Spain','(GMT-04:00) Порт-оф-Спейн','-04,00',''),
- ('America/Porto_Velho','(GMT-04:00) Порто-Велью','-04,00',''),
- ('America/Puerto_Rico','(GMT-04:00) Пуэрто-Рико','-04,00',''),
- ('America/Rio_Branco','(GMT-04:00) Риу-Бранку','-04,00',''),
- ('America/Santiago','(GMT-04:00) Сантьяго','-04,00',''),
- ('America/Santo_Domingo','(GMT-04:00) Санто-Доминго','-04,00',''),
- ('America/St_Kitts','(GMT-04:00) Сент-Китс','-04,00',''),
- ('America/St_Lucia','(GMT-04:00) Сент-Люсия','-04,00',''),
- ('America/St_Thomas','(GMT-04:00) Сент-Томас','-04,00',''),
- ('America/St_Vincent','(GMT-04:00) Сент-Винсент','-04,00',''),
- ('America/Thule','(GMT-04:00) Тули','-04,00',''),
- ('America/Tortola','(GMT-04:00) Тортола','-04,00',''),
- ('Antarctica/Palmer','(GMT-04:00) Палмер','-04,00',''),
- ('Atlantic/Bermuda','(GMT-04:00) Бермуды','-04,00',''),
- ('Atlantic/Stanley','(GMT-04:00) Стэнли','-04,00',''),
- ('America/St_Johns','(GMT-03:30) Ньюфаундлендское время – Сент-Джонс','-03,30',''),
- ('America/Araguaina','(GMT-03:00) Арагуайна','-03,00',''),
- ('America/Argentina/Buenos_Aires','(GMT-03:00) Буэнос-Айрес','-03,00',''),
- ('America/Bahia','(GMT-03:00) Сальвадор','-03,00',''),
- ('America/Belem','(GMT-03:00) Белен','-03,00',''),
- ('America/Cayenne','(GMT-03:00) Кайенна','-03,00',''),
- ('America/Fortaleza','(GMT-03:00) Форталеза','-03,00',''),
- ('America/Godthab','(GMT-03:00) Годхоб','-03,00',''),
- ('America/Maceio','(GMT-03:00) Масейо','-03,00',''),
- ('America/Miquelon','(GMT-03:00) Микелон','-03,00',''),
- ('America/Montevideo','(GMT-03:00) Монтевидео','-03,00',''),
- ('America/Paramaribo','(GMT-03:00) Парамарибо','-03,00',''),
- ('America/Recife','(GMT-03:00) Ресифи','-03,00',''),
- ('America/Sao_Paulo','(GMT-03:00) Сан-Пауло','-03,00',''),
- ('Antarctica/Rothera','(GMT-03:00) Ротера','-03,00',''),
- ('America/Noronha','(GMT-02:00) Норонха','-02,00',''),
- ('Atlantic/South_Georgia','(GMT-02:00) Южная Георгия','-02,00',''),
- ('America/Scoresbysund','(GMT-01:00) Скорсби','-01,00',''),
- ('Atlantic/Azores','(GMT-01:00) Азорские острова','-01,00',''),
- ('Atlantic/Cape_Verde','(GMT-01:00) острова Зеленого мыса','-01,00',''),
- ('Africa/Abidjan','(GMT+00:00) Абиджан','+00,00',''),
- ('Africa/Accra','(GMT+00:00) Аккра','+00,00',''),
- ('Africa/Bamako','(GMT+00:00) Бамако (Africa/Bamako)','+00,00',''),
- ('Africa/Banjul','(GMT+00:00) Банжул','+00,00',''),
- ('Africa/Bissau','(GMT+00:00) Бисау','+00,00',''),
- ('Africa/Casablanca','(GMT+00:00) Касабланка','+00,00',''),
- ('Africa/Conakry','(GMT+00:00) Конакри','+00,00',''),
- ('Africa/Dakar','(GMT+00:00) Дакар','+00,00',''),
- ('Africa/El_Aaiun','(GMT+00:00) Эль-Аюн','+00,00',''),
- ('Africa/Freetown','(GMT+00:00) Фритаун','+00,00',''),
- ('Africa/Lome','(GMT+00:00) Ломе','+00,00',''),
- ('Africa/Monrovia','(GMT+00:00) Монровия','+00,00',''),
- ('Africa/Nouakchott','(GMT+00:00) Нуакшот','+00,00',''),
- ('Africa/Ouagadougou','(GMT+00:00) Уагадугу','+00,00',''),
- ('Africa/Sao_Tome','(GMT+00:00) Сан-Томе','+00,00',''),
- ('America/Danmarkshavn','(GMT+00:00) Данмаркшавн','+00,00',''),
- ('Atlantic/Canary','(GMT+00:00) Канарские острова','+00,00',''),
- ('Atlantic/Faroe','(GMT+00:00) Фарерские острова','+00,00',''),
- ('Atlantic/Reykjavik','(GMT+00:00) Рейкьявик','+00,00',''),
- ('Atlantic/St_Helena','(GMT+00:00) остров Святой Елены','+00,00',''),
- ('Etc/GMT','(GMT+00:00) Время по Гринвичу (без перехода на летнее время)','+00,00',''),
- ('Europe/Dublin','(GMT+00:00) Дублин','+00,00',''),
- ('Europe/Lisbon','(GMT+00:00) Лиссабон','+00,00',''),
- ('Europe/London','(GMT+00:00) Лондон (Europe/London)','+00,00',''),
- ('Africa/Algiers','(GMT+01:00) Алжир','+01,00',''),
- ('Africa/Bangui','(GMT+01:00) Банги','+01,00',''),
- ('Africa/Brazzaville','(GMT+01:00) Браззавиль','+01,00',''),
- ('Africa/Ceuta','(GMT+01:00) Сеута','+01,00',''),
- ('Africa/Douala','(GMT+01:00) Дуала','+01,00',''),
- ('Africa/Kinshasa','(GMT+01:00) Киншаса','+01,00',''),
- ('Africa/Lagos','(GMT+01:00) Лагос','+01,00',''),
- ('Africa/Libreville','(GMT+01:00) Либревиль','+01,00',''),
- ('Africa/Luanda','(GMT+01:00) Луанда','+01,00',''),
- ('Africa/Malabo','(GMT+01:00) Малабо','+01,00',''),
- ('Africa/Ndjamena','(GMT+01:00) Нджамена','+01,00',''),
- ('Africa/Niamey','(GMT+01:00) Ниамей','+01,00',''),
- ('Africa/Porto-Novo','(GMT+01:00) Порто-Ново','+01,00',''),
- ('Africa/Tunis','(GMT+01:00) Тунис','+01,00',''),
- ('Africa/Windhoek','(GMT+01:00) Виндхук','+01,00',''),
- ('Europe/Amsterdam','(GMT+01:00) Амстердам','+01,00',''),
- ('Europe/Andorra','(GMT+01:00) Андорра','+01,00',''),
- ('Europe/Belgrade','(GMT+01:00) Центральноевропейское время (Europe/Belgrade)','+01,00',''),
- ('Europe/Berlin','(GMT+01:00) Берлин','+01,00',''),
- ('Europe/Brussels','(GMT+01:00) Брюссель','+01,00',''),
- ('Europe/Budapest','(GMT+01:00) Будапешт','+01,00',''),
- ('Europe/Copenhagen','(GMT+01:00) Копенгаген','+01,00',''),
- ('Europe/Gibraltar','(GMT+01:00) Гибралтар','+01,00',''),
- ('Europe/Luxembourg','(GMT+01:00) Люксембург','+01,00',''),
- ('Europe/Madrid','(GMT+01:00) Мадрид','+01,00',''),
- ('Europe/Malta','(GMT+01:00) Мальта','+01,00',''),
- ('Europe/Monaco','(GMT+01:00) Монако','+01,00',''),
- ('Europe/Oslo','(GMT+01:00) Осло (Europe/Oslo)','+01,00',''),
- ('Europe/Paris','(GMT+01:00) Париж','+01,00',''),
- ('Europe/Prague','(GMT+01:00) Центральноевропейское время (Europe/Prague)','+01,00',''),
- ('Europe/Rome','(GMT+01:00) Рим (Europe/Rome)','+01,00',''),
- ('Europe/Stockholm','(GMT+01:00) Стокгольм','+01,00',''),
- ('Europe/Tirane','(GMT+01:00) Тирана','+01,00',''),
- ('Europe/Vaduz','(GMT+01:00) Вадуц','+01,00',''),
- ('Europe/Vienna','(GMT+01:00) Вена','+01,00',''),
- ('Europe/Warsaw','(GMT+01:00) Варшава','+01,00',''),
- ('Europe/Zurich','(GMT+01:00) Цюрих','+01,00',''),
- ('Africa/Blantyre','(GMT+02:00) Блантайр','+02,00',''),
- ('Africa/Bujumbura','(GMT+02:00) Бужумбура','+02,00',''),
- ('Africa/Cairo','(GMT+02:00) Каир','+02,00',''),
- ('Africa/Gaborone','(GMT+02:00) Габороне','+02,00',''),
- ('Africa/Harare','(GMT+02:00) Хараре','+02,00',''),
- ('Africa/Johannesburg','(GMT+02:00) Йоханнесбург','+02,00',''),
- ('Africa/Kigali','(GMT+02:00) Кигали','+02,00',''),
- ('Africa/Lubumbashi','(GMT+02:00) Лубумбаши','+02,00',''),
- ('Africa/Lusaka','(GMT+02:00) Лусака','+02,00',''),
- ('Africa/Maputo','(GMT+02:00) Мапуту','+02,00',''),
- ('Africa/Maseru','(GMT+02:00) Масеру','+02,00',''),
- ('Africa/Mbabane','(GMT+02:00) Мбабане','+02,00',''),
- ('Africa/Tripoli','(GMT+02:00) Триполи','+02,00',''),
- ('Asia/Amman','(GMT+02:00) Амман','+02,00',''),
- ('Asia/Beirut','(GMT+02:00) Бейрут','+02,00',''),
- ('Asia/Damascus','(GMT+02:00) Дамаск','+02,00',''),
- ('Asia/Gaza','(GMT+02:00) Газа','+02,00',''),
- ('Asia/Jerusalem','(GMT+02:00) Jerusalem','+02,00',''),
- ('Asia/Nicosia','(GMT+02:00) Никосия (Asia/Nicosia)','+02,00',''),
- ('Europe/Athens','(GMT+02:00) Афины','+02,00',''),
- ('Europe/Bucharest','(GMT+02:00) Бухарест','+02,00',''),
- ('Europe/Chisinau','(GMT+02:00) Кишинев','+02,00',''),
- ('Europe/Helsinki','(GMT+02:00) Хельсинки (Europe/Helsinki)','+02,00',''),
- ('Europe/Istanbul','(GMT+02:00) Стамбул (Europe/Istanbul)','+02,00',''),
- ('Europe/Kaliningrad','(GMT+02:00) Москва-01 – Калининград','+02,00','rus'),
- ('Europe/Kiev','(GMT+02:00) Киев','+02,00',''),
- ('Europe/Minsk','(GMT+02:00) Минск','+02,00',''),
- ('Europe/Riga','(GMT+02:00) Рига','+02,00',''),
- ('Europe/Sofia','(GMT+02:00) София','+02,00',''),
- ('Europe/Tallinn','(GMT+02:00) Таллинн','+02,00',''),
- ('Europe/Vilnius','(GMT+02:00) Вильнюс','+02,00',''),
- ('Africa/Addis_Ababa','(GMT+03:00) Аддис-Абеба','+03,00',''),
- ('Africa/Asmara','(GMT+03:00) Асмера','+03,00',''),
- ('Africa/Dar_es_Salaam','(GMT+03:00) Дар-эс-Салам','+03,00',''),
- ('Africa/Djibouti','(GMT+03:00) Джибути','+03,00',''),
- ('Africa/Kampala','(GMT+03:00) Кампала','+03,00',''),
- ('Africa/Khartoum','(GMT+03:00) Хартум','+03,00',''),
- ('Africa/Mogadishu','(GMT+03:00) Могадишо','+03,00',''),
- ('Africa/Nairobi','(GMT+03:00) Найроби','+03,00',''),
- ('Antarctica/Syowa','(GMT+03:00) Сиова','+03,00',''),
- ('Asia/Aden','(GMT+03:00) Аден','+03,00',''),
- ('Asia/Baghdad','(GMT+03:00) Багдад','+03,00',''),
- ('Asia/Bahrain','(GMT+03:00) Бахрейн','+03,00',''),
- ('Asia/Kuwait','(GMT+03:00) Кувейт','+03,00',''),
- ('Asia/Qatar','(GMT+03:00) Катар','+03,00',''),
- ('Asia/Riyadh','(GMT+03:00) Эр-Рияд','+03,00',''),
- ('Europe/Moscow','(GMT+03:00) Москва +00','+03,00','rus'),
- ('Indian/Antananarivo','(GMT+03:00) Антананариву','+03,00',''),
- ('Indian/Comoro','(GMT+03:00) Коморские острова','+03,00',''),
- ('Indian/Mayotte','(GMT+03:00) Майорка','+03,00',''),
- ('Asia/Tehran','(GMT+03:30) Тегеран','+03,30',''),
- ('Asia/Baku','(GMT+04:00) Баку','+04,00',''),
- ('Asia/Dubai','(GMT+04:00) Дубай','+04,00',''),
- ('Asia/Muscat','(GMT+04:00) Мускат','+04,00',''),
- ('Asia/Tbilisi','(GMT+04:00) Тбилиси','+04,00',''),
- ('Asia/Yerevan','(GMT+04:00) Ереван','+04,00',''),
- ('Europe/Samara','(GMT+04:00) Москва +01 – Самара','+04,00','rus'),
- ('Indian/Mahe','(GMT+04:00) Маэ','+04,00',''),
- ('Indian/Mauritius','(GMT+04:00) Маврикий','+04,00',''),
- ('Indian/Reunion','(GMT+04:00) Реюньон','+04,00',''),
- ('Asia/Kabul','(GMT+04:30) Кабул','+04,30',''),
- ('Asia/Aqtau','(GMT+05:00) Актау','+05,00',''),
- ('Asia/Aqtobe','(GMT+05:00) Актобе','+05,00',''),
- ('Asia/Ashgabat','(GMT+05:00) Ашгабат','+05,00',''),
- ('Asia/Dushanbe','(GMT+05:00) Душанбе','+05,00',''),
- ('Asia/Karachi','(GMT+05:00) Карачи','+05,00',''),
- ('Asia/Tashkent','(GMT+05:00) Ташкент','+05,00',''),
- ('Asia/Yekaterinburg','(GMT+05:00) Москва +02 – Екатеринбург','+05,00','rus'),
- ('Indian/Kerguelen','(GMT+05:00) Кергелен','+05,00',''),
- ('Indian/Maldives','(GMT+05:00) Мальдивы','+05,00',''),
- ('Asia/Calcutta','(GMT+05:30) Индийское время','+05,30',''),
- ('Asia/Colombo','(GMT+05:30) Коломбо','+05,30',''),
- ('Asia/Katmandu','(GMT+05:45) Катманду','+05,45',''),
- ('Antarctica/Mawson','(GMT+06:00) Моусон','+06,00',''),
- ('Antarctica/Vostok','(GMT+06:00) Восток','+06,00',''),
- ('Asia/Almaty','(GMT+06:00) Алматы','+06,00',''),
- ('Asia/Bishkek','(GMT+06:00) Бишкек','+06,00',''),
- ('Asia/Dhaka','(GMT+06:00) Дхака','+06,00',''),
- ('Asia/Omsk','(GMT+06:00) Москва +03 – Омск, Новосибирск','+06,00','rus'),
- ('Asia/Thimphu','(GMT+06:00) Тхимпху','+06,00',''),
- ('Indian/Chagos','(GMT+06:00) Чагос','+06,00',''),
- ('Asia/Rangoon','(GMT+06:30) Рангун','+06,30',''),
- ('Indian/Cocos','(GMT+06:30) Кокосовые острова','+06,30',''),
- ('Antarctica/Davis','(GMT+07:00) Davis','+07,00',''),
- ('Asia/Bangkok','(GMT+07:00) Бангкок','+07,00',''),
- ('Asia/Hovd','(GMT+07:00) Ховд','+07,00',''),
- ('Asia/Jakarta','(GMT+07:00) Джакарта','+07,00',''),
- ('Asia/Krasnoyarsk','(GMT+07:00) Москва +04 – Красноярск','+07,00','rus'),
- ('Asia/Phnom_Penh','(GMT+07:00) Пномпень','+07,00',''),
- ('Asia/Saigon','(GMT+07:00) Ханой','+07,00',''),
- ('Asia/Vientiane','(GMT+07:00) Вьентьян','+07,00',''),
- ('Indian/Christmas','(GMT+07:00) Рождественские острова','+07,00',''),
- ('Antarctica/Casey','(GMT+08:00) Кейси','+08,00',''),
- ('Asia/Brunei','(GMT+08:00) Бруней','+08,00',''),
- ('Asia/Choibalsan','(GMT+08:00) Чойбалсан','+08,00',''),
- ('Asia/Hong_Kong','(GMT+08:00) Гонконг','+08,00',''),
- ('Asia/Irkutsk','(GMT+08:00) Москва +05 – Иркутск','+08,00','rus'),
- ('Asia/Kuala_Lumpur','(GMT+08:00) Куала-Лумпур','+08,00',''),
- ('Asia/Macau','(GMT+08:00) Макау','+08,00',''),
- ('Asia/Makassar','(GMT+08:00) Макасар','+08,00',''),
- ('Asia/Manila','(GMT+08:00) Манила','+08,00',''),
- ('Asia/Shanghai','(GMT+08:00) Китайское время – Пекин','+08,00',''),
- ('Asia/Singapore','(GMT+08:00) Сингапур','+08,00',''),
- ('Asia/Taipei','(GMT+08:00) Тайбэй','+08,00',''),
- ('Asia/Ulaanbaatar','(GMT+08:00) Улан-Батор','+08,00',''),
- ('Australia/Perth','(GMT+08:00) Западное время – Перт','+08,00',''),
- ('Asia/Dili','(GMT+09:00) Дили','+09,00',''),
- ('Asia/Jayapura','(GMT+09:00) Джапура','+09,00',''),
- ('Asia/Pyongyang','(GMT+09:00) Пхеньян','+09,00',''),
- ('Asia/Seoul','(GMT+09:00) Сеул','+09,00',''),
- ('Asia/Tokyo','(GMT+09:00) Токио','+09,00',''),
- ('Asia/Yakutsk','(GMT+09:00) Москва +06 – Якутск','+09,00','rus'),
- ('Pacific/Palau','(GMT+09:00) Палау','+09,00',''),
- ('Australia/Adelaide','(GMT+09:30) Центральное время – Аделаида','+09,30',''),
- ('Australia/Darwin','(GMT+09:30) Центральное время – Дарвин','+09,30',''),
- ('Antarctica/DumontDUrville','(GMT+10:00) Дюмон-Дюрвиль','+10,00',''),
- ('Asia/Vladivostok','(GMT+10:00) Москва +07 – Южно-Сахалинск','+10,00','rus'),
- ('Australia/Brisbane','(GMT+10:00) Восточное время – Брисбен','+10,00',''),
- ('Australia/Hobart','(GMT+10:00) Восточное время – Хобарт','+10,00',''),
- ('Australia/Sydney','(GMT+10:00) Восточное время – Мельбурн, Сидней','+10,00',''),
- ('Pacific/Guam','(GMT+10:00) Гуам','+10,00',''),
- ('Pacific/Port_Moresby','(GMT+10:00) Порт-Морсби','+10,00',''),
- ('Pacific/Saipan','(GMT+10:00) Сайпан','+10,00',''),
- ('Pacific/Truk','(GMT+10:00) Трук (Pacific/Truk)','+10,00',''),
- ('Asia/Magadan','(GMT+11:00) Москва +08 – Магадан','+11,00','rus'),
- ('Pacific/Efate','(GMT+11:00) Эфате','+11,00',''),
- ('Pacific/Guadalcanal','(GMT+11:00) Гвадалканал','+11,00',''),
- ('Pacific/Kosrae','(GMT+11:00) Kosrae','+11,00',''),
- ('Pacific/Noumea','(GMT+11:00) Нумеа','+11,00',''),
- ('Pacific/Ponape','(GMT+11:00) Понапе','+11,00',''),
- ('Pacific/Norfolk','(GMT+11:30) Норфолк','+11,30',''),
- ('Asia/Kamchatka','(GMT+12:00) Москва +09 – Петропавловск-Камчатский','+12,00','rus'),
- ('Pacific/Auckland','(GMT+12:00) Оклэнд','+12,00',''),
- ('Pacific/Fiji','(GMT+12:00) Фиджи','+12,00',''),
- ('Pacific/Funafuti','(GMT+12:00) Фунафути','+12,00',''),
- ('Pacific/Kwajalein','(GMT+12:00) Кваджелейн','+12,00',''),
- ('Pacific/Majuro','(GMT+12:00) Маджуро','+12,00',''),
- ('Pacific/Nauru','(GMT+12:00) Науру','+12,00',''),
- ('Pacific/Tarawa','(GMT+12:00) Тарава','+12,00',''),
- ('Pacific/Wake','(GMT+12:00) остров Вэйк','+12,00',''),
- ('Pacific/Wallis','(GMT+12:00) Уоллис','+12,00',''),
- ('Pacific/Enderbury','(GMT+13:00) острова Эндербери','+13,00',''),
- ('Pacific/Tongatapu','(GMT+13:00) Тонгатапу','+13,00',''),
- ('Pacific/Kiritimati','(GMT+14:00) Киритимати','+14,00',''));
-
-var
-{Диалоги}
- sc_ErrPrepareNode :string;
- sc_ErrCompNodes :string;
- sc_ErrWriteNode :string;
- sc_ErrReadNode :string;
- sc_ErrMissValue :string;
- sc_ErrMissAgrument :string;
- sc_UnUsedTag :string;
- sc_DuplicateLink :string;
- sc_WrongAttr :string;
- sc_RightAttrValues :string;
- sc_ErrCGroupCreate :string;
- sc_ErrNullAuth :string;
- sc_ErrFileName :string;
- sc_ErrFileNull :string;
- sc_ErrSysGroup :string;
- sc_ErrGroupLink :string;
-
-implementation
-
-initialization
-//загружаем строки из RES-файла, относящиеся к диалогам с пользователем
- sc_ErrPrepareNode :=LoadStr(c_ErrPrepareNode);
- sc_ErrCompNodes :=LoadStr(c_ErrCompNodes);
- sc_ErrWriteNode :=LoadStr(c_ErrWriteNode);
- sc_ErrReadNode :=LoadStr(c_ErrReadNode);
- sc_ErrMissValue :=LoadStr(c_ErrMissValue);
- sc_ErrMissAgrument :=LoadStr(c_ErrMissAgrument);
- sc_UnUsedTag :=LoadStr(c_UnUsedTag);
- sc_DuplicateLink :=LoadStr(c_DuplicateLink);
- sc_WrongAttr :=LoadStr(c_WrongAttr);
- sc_RightAttrValues :=LoadStr(c_RightAttrValues);
- sc_ErrCGroupCreate :=LoadStr(c_ErrCGroupCreate);
- sc_ErrNullAuth :=LoadStr(c_ErrNullAuth);
- sc_ErrFileName :=LoadStr(c_ErrFileName);
- sc_ErrFileNull :=LoadStr(c_ErrFileNull);
- sc_ErrSysGroup :=LoadStr(c_ErrSysGroup);
- sc_ErrGroupLink :=LoadStr(c_ErrGroupLink);
-end.
+unit GConsts;
+
+interface
+
+uses uLanguage, SysUtils, Windows;
+
+const
+ CpProtocolVer = '3.0'; //версия протокола для Google Contacts
+ CpNodeAlias = 'gContact:';//префикс XML-узлов, относящихся к Contacts
+ CpGroupLink='http://www.google.com/m8/feeds/groups/%s/full';//URL на получение сведения о группах
+ CpContactsLink='http://www.google.com/m8/feeds/contacts/default/full';//URL на получение сведений о контактах для пользователя по умолчанию
+ CpPhotoLink = 'http://schemas.google.com/contacts/2008/rel#photo';
+ CpDefaultCName = 'NoName Contact';
+
+ gttNodeAlias ='gtt:';
+ gdNodeAlias = 'gd:';//префикс узлов, относящихся к GData API
+ sDefoultMimeType = 'application/atom+xml';
+ sEventRelSuffix = 'event.';
+ sImgRel = 'image/*'; //атрибут rel узла, содержащего изображения
+ sAtomAlias = 'atom:'; //префикс узлов для формирования документа в формате Атом
+ sXMLHeader = '';//заголовок XML документа по умолчанию
+ sDefoultEncoding = 'utf-8';//кодировка документов по умолчанию
+ sRootNodeName= 'feed';//корневой элемент фида
+ sNodeValueAttr = 'value';//аттрибут узлов для хранения какого-либо значения
+ sNodePrimaryAttr = 'primary';
+ sNodeDeletedAttr = 'deleted';
+ sNodeCodeAttr = 'code';
+ sNodeKeyAttr = 'key';
+ sEntryNodeName = 'entry';//имя узла, который необходимо разобрать
+ sNodeRelAttr = 'rel';//аттрибут rel узла
+ sNodeLabelAttr ='label';//аттрибут label узла
+ sNodeHrefAttr = 'href';//атрибут наличия ссылки в узле.
+ sSchemaHref ='http://schemas.google.com/g/2005#';
+
+ {цвета в HEX поддерживаемые Google API}
+ sGoogleColors: array [1..21]of string = ('A32929','B1365F','7A367A','5229A3',
+ '29527A','2952A3','1B887A','28754E',
+ '0D7813','528800','88880E','AB8B00',
+ 'BE6D00','B1440E','865A5A','705770',
+ '4E5D6C','5A6986','4A716C','6E6E41',
+ '8D6F47');
+
+ {часовые пояса}
+ sGoogleTimeZones: array [0..308,0..3]of string =
+ (('Pacific/Apia','(GMT-11:00) Апия','-11,00',''),
+ ('Pacific/Midway','(GMT-11:00) Мидуэй','-11,00',''),
+ ('Pacific/Niue','(GMT-11:00) Ниуэ','-11,00',''),
+ ('Pacific/Pago_Pago','(GMT-11:00) Паго-Паго','-11,00',''),
+ ('Pacific/Fakaofo','(GMT-10:00) Факаофо','-10,00',''),
+ ('Pacific/Honolulu','(GMT-10:00) Гавайское время','-10,00',''),
+ ('Pacific/Johnston','(GMT-10:00) атолл Джонстон','-10,00',''),
+ ('Pacific/Rarotonga','(GMT-10:00) Раротонга','-10,00',''),
+ ('Pacific/Tahiti','(GMT-10:00) Таити','-10,00',''),
+ ('Pacific/Marquesas','(GMT-09:30) Маркизские острова','-09,30',''),
+ ('America/Anchorage','(GMT-09:00) Время Аляски','-09,00',''),
+ ('Pacific/Gambier','(GMT-09:00) Гамбир','-09,00',''),
+ ('America/Los_Angeles','(GMT-08:00) Тихоокеанское время','-08,00',''),
+ ('America/Tijuana','(GMT-08:00) Тихоокеанское время – Тихуана','-08,00',''),
+ ('America/Vancouver','(GMT-08:00) Тихоокеанское время – Ванкувер','-08,00',''),
+ ('America/Whitehorse','(GMT-08:00) Тихоокеанское время – Уайтхорс','-08,00',''),
+ ('Pacific/Pitcairn','(GMT-08:00) Питкэрн','-08,00',''),
+ ('America/Dawson_Creek','(GMT-07:00) Горное время – Доусон Крик','-07,00',''),
+ ('America/Denver','(GMT-07:00) Горное время (America/Denver)','-07,00',''),
+ ('America/Edmonton','(GMT-07:00) Горное время – Эдмонтон','-07,00',''),
+ ('America/Hermosillo','(GMT-07:00) Горное время – Эрмосильо','-07,00',''),
+ ('America/Mazatlan','(GMT-07:00) Горное время – Чиуауа, Мазатлан','-07,00',''),
+ ('America/Phoenix','(GMT-07:00) Горное время – Аризона','-07,00',''),
+ ('America/Yellowknife','(GMT-07:00) Горное время – Йеллоунайф','-07,00',''),
+ ('America/Belize','(GMT-06:00) Белиз','-06,00',''),
+ ('America/Chicago','(GMT-06:00) Центральное время','-06,00',''),
+ ('America/Costa_Rica','(GMT-06:00) Коста-Рика','-06,00',''),
+ ('America/El_Salvador','(GMT-06:00) Сальвадор','-06,00',''),
+ ('America/Guatemala','(GMT-06:00) Гватемала','-06,00',''),
+ ('America/Managua','(GMT-06:00) Манагуа','-06,00',''),
+ ('America/Mexico_City','(GMT-06:00) Центральное время – Мехико','-06,00',''),
+ ('America/Regina','(GMT-06:00) Центральное время – Реджайна','-06,00',''),
+ ('America/Tegucigalpa','(GMT-06:00) Центральное время (America/Tegucigalpa)','-06,00',''),
+ ('America/Winnipeg','(GMT-06:00) Центральное время – Виннипег','-06,00',''),
+ ('Pacific/Easter','(GMT-06:00) остров Пасхи','-06,00',''),
+ ('Pacific/Galapagos','(GMT-06:00) Галапагос','-06,00',''),
+ ('America/Bogota','(GMT-05:00) Богота','-05,00',''),
+ ('America/Cayman','(GMT-05:00) Каймановы острова','-05,00',''),
+ ('America/Grand_Turk','(GMT-05:00) Гранд Турк','-05,00',''),
+ ('America/Guayaquil','(GMT-05:00) Гуаякиль','-05,00',''),
+ ('America/Havana','(GMT-05:00) Гавана','-05,00',''),
+ ('America/Iqaluit','(GMT-05:00) Восточное время – Икалуит','-05,00',''),
+ ('America/Jamaica','(GMT-05:00) Ямайка','-05,00',''),
+ ('America/Lima','(GMT-05:00) Лима','-05,00',''),
+ ('America/Montreal','(GMT-05:00) Восточное время – Монреаль','-05,00',''),
+ ('America/Nassau','(GMT-05:00) Нассау','-05,00',''),
+ ('America/New_York','(GMT-05:00) Восточное время','-05,00',''),
+ ('America/Panama','(GMT-05:00) Панама','-05,00',''),
+ ('America/Port-au-Prince','(GMT-05:00) Порт-о-Пренс','-05,00',''),
+ ('America/Toronto','(GMT-05:00) Восточное время – Торонто','-05,00',''),
+ ('America/Caracas','(GMT-04:30) Каракас','-04,30',''),
+ ('America/Anguilla','(GMT-04:00) Ангилья','-04,00',''),
+ ('America/Antigua','(GMT-04:00) Антигуа','-04,00',''),
+ ('America/Aruba','(GMT-04:00) Аруба','-04,00',''),
+ ('America/Asuncion','(GMT-04:00) Асунсьон','-04,00',''),
+ ('America/Barbados','(GMT-04:00) Барбадос','-04,00',''),
+ ('America/Boa_Vista','(GMT-04:00) Боа-Виста','-04,00',''),
+ ('America/Campo_Grande','(GMT-04:00) Кампу-Гранди','-04,00',''),
+ ('America/Cuiaba','(GMT-04:00) Куяба','-04,00',''),
+ ('America/Curacao','(GMT-04:00) Кюрасао','-04,00',''),
+ ('America/Dominica','(GMT-04:00) Доминика','-04,00',''),
+ ('America/Grenada','(GMT-04:00) Гренада','-04,00',''),
+ ('America/Guadeloupe','(GMT-04:00) Гваделупа','-04,00',''),
+ ('America/Guyana','(GMT-04:00) Гайана','-04,00',''),
+ ('America/Halifax','(GMT-04:00) Атлантическое время – Галифакс','-04,00',''),
+ ('America/La_Paz','(GMT-04:00) Ла-Пас','-04,00',''),
+ ('America/Manaus','(GMT-04:00) Манаус','-04,00',''),
+ ('America/Martinique','(GMT-04:00) Мартиника','-04,00',''),
+ ('America/Montserrat','(GMT-04:00) Монсеррат','-04,00',''),
+ ('America/Port_of_Spain','(GMT-04:00) Порт-оф-Спейн','-04,00',''),
+ ('America/Porto_Velho','(GMT-04:00) Порто-Велью','-04,00',''),
+ ('America/Puerto_Rico','(GMT-04:00) Пуэрто-Рико','-04,00',''),
+ ('America/Rio_Branco','(GMT-04:00) Риу-Бранку','-04,00',''),
+ ('America/Santiago','(GMT-04:00) Сантьяго','-04,00',''),
+ ('America/Santo_Domingo','(GMT-04:00) Санто-Доминго','-04,00',''),
+ ('America/St_Kitts','(GMT-04:00) Сент-Китс','-04,00',''),
+ ('America/St_Lucia','(GMT-04:00) Сент-Люсия','-04,00',''),
+ ('America/St_Thomas','(GMT-04:00) Сент-Томас','-04,00',''),
+ ('America/St_Vincent','(GMT-04:00) Сент-Винсент','-04,00',''),
+ ('America/Thule','(GMT-04:00) Тули','-04,00',''),
+ ('America/Tortola','(GMT-04:00) Тортола','-04,00',''),
+ ('Antarctica/Palmer','(GMT-04:00) Палмер','-04,00',''),
+ ('Atlantic/Bermuda','(GMT-04:00) Бермуды','-04,00',''),
+ ('Atlantic/Stanley','(GMT-04:00) Стэнли','-04,00',''),
+ ('America/St_Johns','(GMT-03:30) Ньюфаундлендское время – Сент-Джонс','-03,30',''),
+ ('America/Araguaina','(GMT-03:00) Арагуайна','-03,00',''),
+ ('America/Argentina/Buenos_Aires','(GMT-03:00) Буэнос-Айрес','-03,00',''),
+ ('America/Bahia','(GMT-03:00) Сальвадор','-03,00',''),
+ ('America/Belem','(GMT-03:00) Белен','-03,00',''),
+ ('America/Cayenne','(GMT-03:00) Кайенна','-03,00',''),
+ ('America/Fortaleza','(GMT-03:00) Форталеза','-03,00',''),
+ ('America/Godthab','(GMT-03:00) Годхоб','-03,00',''),
+ ('America/Maceio','(GMT-03:00) Масейо','-03,00',''),
+ ('America/Miquelon','(GMT-03:00) Микелон','-03,00',''),
+ ('America/Montevideo','(GMT-03:00) Монтевидео','-03,00',''),
+ ('America/Paramaribo','(GMT-03:00) Парамарибо','-03,00',''),
+ ('America/Recife','(GMT-03:00) Ресифи','-03,00',''),
+ ('America/Sao_Paulo','(GMT-03:00) Сан-Пауло','-03,00',''),
+ ('Antarctica/Rothera','(GMT-03:00) Ротера','-03,00',''),
+ ('America/Noronha','(GMT-02:00) Норонха','-02,00',''),
+ ('Atlantic/South_Georgia','(GMT-02:00) Южная Георгия','-02,00',''),
+ ('America/Scoresbysund','(GMT-01:00) Скорсби','-01,00',''),
+ ('Atlantic/Azores','(GMT-01:00) Азорские острова','-01,00',''),
+ ('Atlantic/Cape_Verde','(GMT-01:00) острова Зеленого мыса','-01,00',''),
+ ('Africa/Abidjan','(GMT+00:00) Абиджан','+00,00',''),
+ ('Africa/Accra','(GMT+00:00) Аккра','+00,00',''),
+ ('Africa/Bamako','(GMT+00:00) Бамако (Africa/Bamako)','+00,00',''),
+ ('Africa/Banjul','(GMT+00:00) Банжул','+00,00',''),
+ ('Africa/Bissau','(GMT+00:00) Бисау','+00,00',''),
+ ('Africa/Casablanca','(GMT+00:00) Касабланка','+00,00',''),
+ ('Africa/Conakry','(GMT+00:00) Конакри','+00,00',''),
+ ('Africa/Dakar','(GMT+00:00) Дакар','+00,00',''),
+ ('Africa/El_Aaiun','(GMT+00:00) Эль-Аюн','+00,00',''),
+ ('Africa/Freetown','(GMT+00:00) Фритаун','+00,00',''),
+ ('Africa/Lome','(GMT+00:00) Ломе','+00,00',''),
+ ('Africa/Monrovia','(GMT+00:00) Монровия','+00,00',''),
+ ('Africa/Nouakchott','(GMT+00:00) Нуакшот','+00,00',''),
+ ('Africa/Ouagadougou','(GMT+00:00) Уагадугу','+00,00',''),
+ ('Africa/Sao_Tome','(GMT+00:00) Сан-Томе','+00,00',''),
+ ('America/Danmarkshavn','(GMT+00:00) Данмаркшавн','+00,00',''),
+ ('Atlantic/Canary','(GMT+00:00) Канарские острова','+00,00',''),
+ ('Atlantic/Faroe','(GMT+00:00) Фарерские острова','+00,00',''),
+ ('Atlantic/Reykjavik','(GMT+00:00) Рейкьявик','+00,00',''),
+ ('Atlantic/St_Helena','(GMT+00:00) остров Святой Елены','+00,00',''),
+ ('Etc/GMT','(GMT+00:00) Время по Гринвичу (без перехода на летнее время)','+00,00',''),
+ ('Europe/Dublin','(GMT+00:00) Дублин','+00,00',''),
+ ('Europe/Lisbon','(GMT+00:00) Лиссабон','+00,00',''),
+ ('Europe/London','(GMT+00:00) Лондон (Europe/London)','+00,00',''),
+ ('Africa/Algiers','(GMT+01:00) Алжир','+01,00',''),
+ ('Africa/Bangui','(GMT+01:00) Банги','+01,00',''),
+ ('Africa/Brazzaville','(GMT+01:00) Браззавиль','+01,00',''),
+ ('Africa/Ceuta','(GMT+01:00) Сеута','+01,00',''),
+ ('Africa/Douala','(GMT+01:00) Дуала','+01,00',''),
+ ('Africa/Kinshasa','(GMT+01:00) Киншаса','+01,00',''),
+ ('Africa/Lagos','(GMT+01:00) Лагос','+01,00',''),
+ ('Africa/Libreville','(GMT+01:00) Либревиль','+01,00',''),
+ ('Africa/Luanda','(GMT+01:00) Луанда','+01,00',''),
+ ('Africa/Malabo','(GMT+01:00) Малабо','+01,00',''),
+ ('Africa/Ndjamena','(GMT+01:00) Нджамена','+01,00',''),
+ ('Africa/Niamey','(GMT+01:00) Ниамей','+01,00',''),
+ ('Africa/Porto-Novo','(GMT+01:00) Порто-Ново','+01,00',''),
+ ('Africa/Tunis','(GMT+01:00) Тунис','+01,00',''),
+ ('Africa/Windhoek','(GMT+01:00) Виндхук','+01,00',''),
+ ('Europe/Amsterdam','(GMT+01:00) Амстердам','+01,00',''),
+ ('Europe/Andorra','(GMT+01:00) Андорра','+01,00',''),
+ ('Europe/Belgrade','(GMT+01:00) Центральноевропейское время (Europe/Belgrade)','+01,00',''),
+ ('Europe/Berlin','(GMT+01:00) Берлин','+01,00',''),
+ ('Europe/Brussels','(GMT+01:00) Брюссель','+01,00',''),
+ ('Europe/Budapest','(GMT+01:00) Будапешт','+01,00',''),
+ ('Europe/Copenhagen','(GMT+01:00) Копенгаген','+01,00',''),
+ ('Europe/Gibraltar','(GMT+01:00) Гибралтар','+01,00',''),
+ ('Europe/Luxembourg','(GMT+01:00) Люксембург','+01,00',''),
+ ('Europe/Madrid','(GMT+01:00) Мадрид','+01,00',''),
+ ('Europe/Malta','(GMT+01:00) Мальта','+01,00',''),
+ ('Europe/Monaco','(GMT+01:00) Монако','+01,00',''),
+ ('Europe/Oslo','(GMT+01:00) Осло (Europe/Oslo)','+01,00',''),
+ ('Europe/Paris','(GMT+01:00) Париж','+01,00',''),
+ ('Europe/Prague','(GMT+01:00) Центральноевропейское время (Europe/Prague)','+01,00',''),
+ ('Europe/Rome','(GMT+01:00) Рим (Europe/Rome)','+01,00',''),
+ ('Europe/Stockholm','(GMT+01:00) Стокгольм','+01,00',''),
+ ('Europe/Tirane','(GMT+01:00) Тирана','+01,00',''),
+ ('Europe/Vaduz','(GMT+01:00) Вадуц','+01,00',''),
+ ('Europe/Vienna','(GMT+01:00) Вена','+01,00',''),
+ ('Europe/Warsaw','(GMT+01:00) Варшава','+01,00',''),
+ ('Europe/Zurich','(GMT+01:00) Цюрих','+01,00',''),
+ ('Africa/Blantyre','(GMT+02:00) Блантайр','+02,00',''),
+ ('Africa/Bujumbura','(GMT+02:00) Бужумбура','+02,00',''),
+ ('Africa/Cairo','(GMT+02:00) Каир','+02,00',''),
+ ('Africa/Gaborone','(GMT+02:00) Габороне','+02,00',''),
+ ('Africa/Harare','(GMT+02:00) Хараре','+02,00',''),
+ ('Africa/Johannesburg','(GMT+02:00) Йоханнесбург','+02,00',''),
+ ('Africa/Kigali','(GMT+02:00) Кигали','+02,00',''),
+ ('Africa/Lubumbashi','(GMT+02:00) Лубумбаши','+02,00',''),
+ ('Africa/Lusaka','(GMT+02:00) Лусака','+02,00',''),
+ ('Africa/Maputo','(GMT+02:00) Мапуту','+02,00',''),
+ ('Africa/Maseru','(GMT+02:00) Масеру','+02,00',''),
+ ('Africa/Mbabane','(GMT+02:00) Мбабане','+02,00',''),
+ ('Africa/Tripoli','(GMT+02:00) Триполи','+02,00',''),
+ ('Asia/Amman','(GMT+02:00) Амман','+02,00',''),
+ ('Asia/Beirut','(GMT+02:00) Бейрут','+02,00',''),
+ ('Asia/Damascus','(GMT+02:00) Дамаск','+02,00',''),
+ ('Asia/Gaza','(GMT+02:00) Газа','+02,00',''),
+ ('Asia/Jerusalem','(GMT+02:00) Jerusalem','+02,00',''),
+ ('Asia/Nicosia','(GMT+02:00) Никосия (Asia/Nicosia)','+02,00',''),
+ ('Europe/Athens','(GMT+02:00) Афины','+02,00',''),
+ ('Europe/Bucharest','(GMT+02:00) Бухарест','+02,00',''),
+ ('Europe/Chisinau','(GMT+02:00) Кишинев','+02,00',''),
+ ('Europe/Helsinki','(GMT+02:00) Хельсинки (Europe/Helsinki)','+02,00',''),
+ ('Europe/Istanbul','(GMT+02:00) Стамбул (Europe/Istanbul)','+02,00',''),
+ ('Europe/Kaliningrad','(GMT+02:00) Москва-01 – Калининград','+02,00','rus'),
+ ('Europe/Kiev','(GMT+02:00) Киев','+02,00',''),
+ ('Europe/Minsk','(GMT+02:00) Минск','+02,00',''),
+ ('Europe/Riga','(GMT+02:00) Рига','+02,00',''),
+ ('Europe/Sofia','(GMT+02:00) София','+02,00',''),
+ ('Europe/Tallinn','(GMT+02:00) Таллинн','+02,00',''),
+ ('Europe/Vilnius','(GMT+02:00) Вильнюс','+02,00',''),
+ ('Africa/Addis_Ababa','(GMT+03:00) Аддис-Абеба','+03,00',''),
+ ('Africa/Asmara','(GMT+03:00) Асмера','+03,00',''),
+ ('Africa/Dar_es_Salaam','(GMT+03:00) Дар-эс-Салам','+03,00',''),
+ ('Africa/Djibouti','(GMT+03:00) Джибути','+03,00',''),
+ ('Africa/Kampala','(GMT+03:00) Кампала','+03,00',''),
+ ('Africa/Khartoum','(GMT+03:00) Хартум','+03,00',''),
+ ('Africa/Mogadishu','(GMT+03:00) Могадишо','+03,00',''),
+ ('Africa/Nairobi','(GMT+03:00) Найроби','+03,00',''),
+ ('Antarctica/Syowa','(GMT+03:00) Сиова','+03,00',''),
+ ('Asia/Aden','(GMT+03:00) Аден','+03,00',''),
+ ('Asia/Baghdad','(GMT+03:00) Багдад','+03,00',''),
+ ('Asia/Bahrain','(GMT+03:00) Бахрейн','+03,00',''),
+ ('Asia/Kuwait','(GMT+03:00) Кувейт','+03,00',''),
+ ('Asia/Qatar','(GMT+03:00) Катар','+03,00',''),
+ ('Asia/Riyadh','(GMT+03:00) Эр-Рияд','+03,00',''),
+ ('Europe/Moscow','(GMT+03:00) Москва +00','+03,00','rus'),
+ ('Indian/Antananarivo','(GMT+03:00) Антананариву','+03,00',''),
+ ('Indian/Comoro','(GMT+03:00) Коморские острова','+03,00',''),
+ ('Indian/Mayotte','(GMT+03:00) Майорка','+03,00',''),
+ ('Asia/Tehran','(GMT+03:30) Тегеран','+03,30',''),
+ ('Asia/Baku','(GMT+04:00) Баку','+04,00',''),
+ ('Asia/Dubai','(GMT+04:00) Дубай','+04,00',''),
+ ('Asia/Muscat','(GMT+04:00) Мускат','+04,00',''),
+ ('Asia/Tbilisi','(GMT+04:00) Тбилиси','+04,00',''),
+ ('Asia/Yerevan','(GMT+04:00) Ереван','+04,00',''),
+ ('Europe/Samara','(GMT+04:00) Москва +01 – Самара','+04,00','rus'),
+ ('Indian/Mahe','(GMT+04:00) Маэ','+04,00',''),
+ ('Indian/Mauritius','(GMT+04:00) Маврикий','+04,00',''),
+ ('Indian/Reunion','(GMT+04:00) Реюньон','+04,00',''),
+ ('Asia/Kabul','(GMT+04:30) Кабул','+04,30',''),
+ ('Asia/Aqtau','(GMT+05:00) Актау','+05,00',''),
+ ('Asia/Aqtobe','(GMT+05:00) Актобе','+05,00',''),
+ ('Asia/Ashgabat','(GMT+05:00) Ашгабат','+05,00',''),
+ ('Asia/Dushanbe','(GMT+05:00) Душанбе','+05,00',''),
+ ('Asia/Karachi','(GMT+05:00) Карачи','+05,00',''),
+ ('Asia/Tashkent','(GMT+05:00) Ташкент','+05,00',''),
+ ('Asia/Yekaterinburg','(GMT+05:00) Москва +02 – Екатеринбург','+05,00','rus'),
+ ('Indian/Kerguelen','(GMT+05:00) Кергелен','+05,00',''),
+ ('Indian/Maldives','(GMT+05:00) Мальдивы','+05,00',''),
+ ('Asia/Calcutta','(GMT+05:30) Индийское время','+05,30',''),
+ ('Asia/Colombo','(GMT+05:30) Коломбо','+05,30',''),
+ ('Asia/Katmandu','(GMT+05:45) Катманду','+05,45',''),
+ ('Antarctica/Mawson','(GMT+06:00) Моусон','+06,00',''),
+ ('Antarctica/Vostok','(GMT+06:00) Восток','+06,00',''),
+ ('Asia/Almaty','(GMT+06:00) Алматы','+06,00',''),
+ ('Asia/Bishkek','(GMT+06:00) Бишкек','+06,00',''),
+ ('Asia/Dhaka','(GMT+06:00) Дхака','+06,00',''),
+ ('Asia/Omsk','(GMT+06:00) Москва +03 – Омск, Новосибирск','+06,00','rus'),
+ ('Asia/Thimphu','(GMT+06:00) Тхимпху','+06,00',''),
+ ('Indian/Chagos','(GMT+06:00) Чагос','+06,00',''),
+ ('Asia/Rangoon','(GMT+06:30) Рангун','+06,30',''),
+ ('Indian/Cocos','(GMT+06:30) Кокосовые острова','+06,30',''),
+ ('Antarctica/Davis','(GMT+07:00) Davis','+07,00',''),
+ ('Asia/Bangkok','(GMT+07:00) Бангкок','+07,00',''),
+ ('Asia/Hovd','(GMT+07:00) Ховд','+07,00',''),
+ ('Asia/Jakarta','(GMT+07:00) Джакарта','+07,00',''),
+ ('Asia/Krasnoyarsk','(GMT+07:00) Москва +04 – Красноярск','+07,00','rus'),
+ ('Asia/Phnom_Penh','(GMT+07:00) Пномпень','+07,00',''),
+ ('Asia/Saigon','(GMT+07:00) Ханой','+07,00',''),
+ ('Asia/Vientiane','(GMT+07:00) Вьентьян','+07,00',''),
+ ('Indian/Christmas','(GMT+07:00) Рождественские острова','+07,00',''),
+ ('Antarctica/Casey','(GMT+08:00) Кейси','+08,00',''),
+ ('Asia/Brunei','(GMT+08:00) Бруней','+08,00',''),
+ ('Asia/Choibalsan','(GMT+08:00) Чойбалсан','+08,00',''),
+ ('Asia/Hong_Kong','(GMT+08:00) Гонконг','+08,00',''),
+ ('Asia/Irkutsk','(GMT+08:00) Москва +05 – Иркутск','+08,00','rus'),
+ ('Asia/Kuala_Lumpur','(GMT+08:00) Куала-Лумпур','+08,00',''),
+ ('Asia/Macau','(GMT+08:00) Макау','+08,00',''),
+ ('Asia/Makassar','(GMT+08:00) Макасар','+08,00',''),
+ ('Asia/Manila','(GMT+08:00) Манила','+08,00',''),
+ ('Asia/Shanghai','(GMT+08:00) Китайское время – Пекин','+08,00',''),
+ ('Asia/Singapore','(GMT+08:00) Сингапур','+08,00',''),
+ ('Asia/Taipei','(GMT+08:00) Тайбэй','+08,00',''),
+ ('Asia/Ulaanbaatar','(GMT+08:00) Улан-Батор','+08,00',''),
+ ('Australia/Perth','(GMT+08:00) Западное время – Перт','+08,00',''),
+ ('Asia/Dili','(GMT+09:00) Дили','+09,00',''),
+ ('Asia/Jayapura','(GMT+09:00) Джапура','+09,00',''),
+ ('Asia/Pyongyang','(GMT+09:00) Пхеньян','+09,00',''),
+ ('Asia/Seoul','(GMT+09:00) Сеул','+09,00',''),
+ ('Asia/Tokyo','(GMT+09:00) Токио','+09,00',''),
+ ('Asia/Yakutsk','(GMT+09:00) Москва +06 – Якутск','+09,00','rus'),
+ ('Pacific/Palau','(GMT+09:00) Палау','+09,00',''),
+ ('Australia/Adelaide','(GMT+09:30) Центральное время – Аделаида','+09,30',''),
+ ('Australia/Darwin','(GMT+09:30) Центральное время – Дарвин','+09,30',''),
+ ('Antarctica/DumontDUrville','(GMT+10:00) Дюмон-Дюрвиль','+10,00',''),
+ ('Asia/Vladivostok','(GMT+10:00) Москва +07 – Южно-Сахалинск','+10,00','rus'),
+ ('Australia/Brisbane','(GMT+10:00) Восточное время – Брисбен','+10,00',''),
+ ('Australia/Hobart','(GMT+10:00) Восточное время – Хобарт','+10,00',''),
+ ('Australia/Sydney','(GMT+10:00) Восточное время – Мельбурн, Сидней','+10,00',''),
+ ('Pacific/Guam','(GMT+10:00) Гуам','+10,00',''),
+ ('Pacific/Port_Moresby','(GMT+10:00) Порт-Морсби','+10,00',''),
+ ('Pacific/Saipan','(GMT+10:00) Сайпан','+10,00',''),
+ ('Pacific/Truk','(GMT+10:00) Трук (Pacific/Truk)','+10,00',''),
+ ('Asia/Magadan','(GMT+11:00) Москва +08 – Магадан','+11,00','rus'),
+ ('Pacific/Efate','(GMT+11:00) Эфате','+11,00',''),
+ ('Pacific/Guadalcanal','(GMT+11:00) Гвадалканал','+11,00',''),
+ ('Pacific/Kosrae','(GMT+11:00) Kosrae','+11,00',''),
+ ('Pacific/Noumea','(GMT+11:00) Нумеа','+11,00',''),
+ ('Pacific/Ponape','(GMT+11:00) Понапе','+11,00',''),
+ ('Pacific/Norfolk','(GMT+11:30) Норфолк','+11,30',''),
+ ('Asia/Kamchatka','(GMT+12:00) Москва +09 – Петропавловск-Камчатский','+12,00','rus'),
+ ('Pacific/Auckland','(GMT+12:00) Оклэнд','+12,00',''),
+ ('Pacific/Fiji','(GMT+12:00) Фиджи','+12,00',''),
+ ('Pacific/Funafuti','(GMT+12:00) Фунафути','+12,00',''),
+ ('Pacific/Kwajalein','(GMT+12:00) Кваджелейн','+12,00',''),
+ ('Pacific/Majuro','(GMT+12:00) Маджуро','+12,00',''),
+ ('Pacific/Nauru','(GMT+12:00) Науру','+12,00',''),
+ ('Pacific/Tarawa','(GMT+12:00) Тарава','+12,00',''),
+ ('Pacific/Wake','(GMT+12:00) остров Вэйк','+12,00',''),
+ ('Pacific/Wallis','(GMT+12:00) Уоллис','+12,00',''),
+ ('Pacific/Enderbury','(GMT+13:00) острова Эндербери','+13,00',''),
+ ('Pacific/Tongatapu','(GMT+13:00) Тонгатапу','+13,00',''),
+ ('Pacific/Kiritimati','(GMT+14:00) Киритимати','+14,00',''));
+
+var
+{Диалоги}
+ sc_ErrPrepareNode :string;
+ sc_ErrCompNodes :string;
+ sc_ErrWriteNode :string;
+ sc_ErrReadNode :string;
+ sc_ErrMissValue :string;
+ sc_ErrMissAgrument :string;
+ sc_UnUsedTag :string;
+ sc_DuplicateLink :string;
+ sc_WrongAttr :string;
+ sc_RightAttrValues :string;
+ sc_ErrCGroupCreate :string;
+ sc_ErrNullAuth :string;
+ sc_ErrFileName :string;
+ sc_ErrFileNull :string;
+ sc_ErrSysGroup :string;
+ sc_ErrGroupLink :string;
+
+implementation
+
+initialization
+//загружаем строки из RES-файла, относящиеся к диалогам с пользователем
+ sc_ErrPrepareNode :=LoadStr(c_ErrPrepareNode);
+ sc_ErrCompNodes :=LoadStr(c_ErrCompNodes);
+ sc_ErrWriteNode :=LoadStr(c_ErrWriteNode);
+ sc_ErrReadNode :=LoadStr(c_ErrReadNode);
+ sc_ErrMissValue :=LoadStr(c_ErrMissValue);
+ sc_ErrMissAgrument :=LoadStr(c_ErrMissAgrument);
+ sc_UnUsedTag :=LoadStr(c_UnUsedTag);
+ sc_DuplicateLink :=LoadStr(c_DuplicateLink);
+ sc_WrongAttr :=LoadStr(c_WrongAttr);
+ sc_RightAttrValues :=LoadStr(c_RightAttrValues);
+ sc_ErrCGroupCreate :=LoadStr(c_ErrCGroupCreate);
+ sc_ErrNullAuth :=LoadStr(c_ErrNullAuth);
+ sc_ErrFileName :=LoadStr(c_ErrFileName);
+ sc_ErrFileNull :=LoadStr(c_ErrFileNull);
+ sc_ErrSysGroup :=LoadStr(c_ErrSysGroup);
+ sc_ErrGroupLink :=LoadStr(c_ErrGroupLink);
+end.
diff --git a/source/GContacts.pas b/source/GContacts.pas
index 109558e..7985dbf 100644
--- a/source/GContacts.pas
+++ b/source/GContacts.pas
@@ -1,3621 +1,3621 @@
-{ unit GContacts
-
- Модуль содержит классы и методы для работы с Google Contacts API.
-
- Вы можете использовать этот модуль для получения чтения и редактирования своих
- контактов в GMail.
-
- Основной компонент для работы с контаками - TGoogleContact.
-
- Автор: Vlad. (vlad383@gmail.com)
- Дата: 16 Июля 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.
-
- Последние обновления модуля можно найти в репозитории по адресу:
- http://github.com/googleapi
-}
-
-unit GContacts;
-
-interface
-
-uses
- NativeXML, strUtils, httpsend, Classes, SysUtils,
- GDataCommon, Generics.Collections, Dialogs, jpeg, Graphics, typinfo,
- IOUtils, uLanguage, blcksock, Windows, GConsts;
-
-const
- cpGContactsVersion = '0.1';
-
-
-type
- ECPException = class(Exception)
- public
- constructor CreateFromStream(const Document: TStream);
-end;
-
-type
- {Элемент парсинга}
- TParseElement = (T_Group {группа контактов},
- T_Contact {группа контактов});
- {Событие TOnRetriveXML возникает каждый раз, когда компонент или класс
- обращается на сервер для получения XML-документа.
- FromURL содержит URL на который отправляется GET-запрос}
- TOnRetriveXML = procedure(const FromURL: string {URL на который отправляется HTTP-запрос для получения документа}) of object;
- {Событие TOnBeginParse возникает каждый раз, когда компонент или класс
- готов начать парсинг элемента в XML-документе.
- Общее количество однотипных элементов определяется по значению узла
- openSearch:totalResults в первом возвращенном с сервера документе.}
- TOnBeginParse = procedure(const What: TParseElement{элемент парсинга (группа или контакт) см. TParseElement};
- Total:integer{общее количество элементов доступных для парсинга};
- Number: integer{текущий номер элементапарсинга})
- of object;
- {Событие TOnEndParse возникает каждый раз, когда компонент или класс
- заканчивает парсинг элемента в XML-документе.}
- TOnEndParse = procedure(const What: TParseElement;{элемент парсинга (группа или контакт) см. TParseElement}
- Element: TObject{элемент, полученный в результате парсинга.
- Если был проведен парсинг группы, то Element имеет тип TContactGroup,
- если контакта, то - TContact})
- of object;
- {Событие TOnReadData возникает каждый раз, когда компонент или класс
- считывает данные из Сети.
- TotalBytes содержит информацию по размеру получаемого документа, включая размер
- всех заголовков, возвращаемых сервером}
- TOnReadData = procedure(const TotalBytes:int64 {содержит значение объема данных, который должен быть получен, байт};
- ReadBytes: int64 {содержит количество байт информации полученных из Сети на текущий момент}) of object;
-
-
-{Перечислитель, содержащий все типы узлов, относящихся к Google Contacts API
- и обрабатываемых с помощью классов модуля}
-type
- TcpTagEnum = (cp_billingInformation {тип узла gContact:billingInformation},
- cp_birthday {тип узла gContact:birthday},
- cp_calendarLink {тип узла gContact:calendarLink},
- cp_directoryServer {тип узла gContact:directoryServer},
- cp_event {тип узла gContact:event},
- cp_externalId {тип узла gContact:externalId},
- cp_gender {тип узла gContact:gender},
- cp_groupMembershipInfo {тип узла gContact:groupMembershipInfo},
- cp_hobby {тип узла gContact:hobby},
- cp_initials {тип узла gContact:initials},
- cp_jot {тип узла gContact:jot},
- cp_language {тип узла gContact:language},
- cp_maidenName {тип узла gContact:maidenName},
- cp_mileage {тип узла gContact:mileage},
- cp_nickname {тип узла gContact:nickname},
- cp_occupation {тип узла gContact:occupation},
- cp_priority {тип узла gContact:priority},
- cp_relation {тип узла gContact:relation},
- cp_sensitivity {тип узла gContact:sensitivity},
- cp_shortName {тип узла gContact:shortName},
- cp_subject {тип узла gContact:subject},
- cp_userDefinedField {тип узла gContact:userDefinedField},
- cp_website {тип узла gContact:website},
- cp_systemGroup {тип узла gContact:systemGroup},
- cp_None {используется в случае, если тип узла не определен});
-
-type
- {Класс, описывающий узел gContact:billingInformation.
- Этот узел используется для описания платежной информации контакта.
- Элемент gContact:billingInformation не может быть повторен в рамках
- описания одного контакта.
- Вся информация содержится в текстовой части узла.
- Узел gContact:billingInformation может отсутствовать в XML-документе}
- TcpBillingInformation = class(TTextTag);
-
- {Класс, описывающий узел gContact:directoryServer.
- Этот узел используется для указания сервера катологов, связанного с контактом.
- Элемент gContact:directoryServer может быть повторен в рамках описания
- одного контакта.
- Вся информация содержится в текстовой части узла.
- Узел gContact:directoryServer может отсутствовать в XML-документе}
- TcpDirectoryServer = class(TTextTag);
-
- {Класс, описывающий узел gContact:hobby.
- Этот узел используется для указания хобби контакта.
- Элемент gContact:hobby может быть повторен в рамках описания
- одного контакта.
- Вся информация о хобби содержится в текстовой части узла.
- Узел gContact:hobby может отсутствовать в XML-документе}
- TcpHobby = class(TTextTag);
-
- {Класс, описывающий узел gContact:initials.
- Этот узел используется для указания инициалов контакта.
- Элемент gContact:initials не может быть повторен в рамках описания
- одного контакта.
- Вся информация об инициалах содержится в текстовой части узла.
- Узел gContact:initials может отсутствовать в XML-документе}
- TcpInitials = class(TTextTag);
-
- {Класс, описывающий узел gContact:shortName.
- Этот узел используется для указания сокращенного имени контакта (например,
- для имени Владислав коротким является - Влад).
- Элемент gContact:shortName не может быть повторен в рамках описания
- одного контакта.
- Вся информация о коротком имени содержится в текстовой части узла.
- Узел gContact:shortName может отсутствовать в XML-документе}
- TcpShortName = class(TTextTag);
-
- {Класс, описывающий узел gContact:subject.
- Этот узел используется для указания дополнительной информации о контакте,
- например, области деятельности в которой пользователь пересекается с контактом.
- Элемент gContact:subject не может быть повторен в рамках описания
- одного контакта.
- Вся дополнительная информация о контакте содержится в текстовой части узла.
- Узел gContact:subject может отсутствовать в XML-документе}
- TcpSubject = class(TTextTag);
-
- {Класс, описывающий узел gContact:maidenName.
- Этот узел используется для указания девичьей фамилии контакта (для контактов женского пола).
- Элемент gContact:maidenName не может быть повторен в рамках описания
- одного контакта.
- Вся информация о девичьей фамилии содержится в текстовой части узла.
- Узел gContact:maidenName может отсутствовать в XML-документе}
- TcpMaidenName = class(TTextTag);
-
- {Класс, описывающий узел gContact:mileage.
- Этот узел используется для указания расстояния, отделяющего пользователя от контакта.
- Элемент gContact:mileage не может быть повторен в рамках описания
- одного контакта.
- Вся информация о расстоянии содержится в текстовой части узла. Текст,
- содержащий информацию о расстоянии может содержать подстроки размерности,
- например "км.". Размерности никак не интерпретируются сервером Google.
- Узел gContact:mileage может отсутствовать в XML-документе}
- TcpMileage = class(TTextTag);
-
- {Класс, описывающий узел gContact:nickname.
- Этот узел используется для ника (клички) контакта.
- Элемент gContact:nickname не может быть повторен в рамках описания
- одного контакта.
- Вся информация о нике содержится в текстовой части узла.
- Узел gContact:nickname может отсутствовать в XML-документе}
- TcpNickname = class(TTextTag);
-
- {Класс, описывающий узел gContact:occupation.
- Этот узел используется для описания рода занятий/профессии контакта.
- Элемент gContact:occupation не может быть повторен в рамках описания
- одного контакта.
- Вся информация о профессии содержится в текстовой части узла.
- Узел gContact:occupation может отсутствовать в XML-документе}
- TcpOccupation = class(TTextTag);
-
-
-{Класс, описывающий узел gContact:birthday.
- Этот узел используется для указания даты рождения контакта.
- Элемент gContact:birthday не может быть повторен в рамках описания
- одного контакта.
- Вся информация о дате рождения содержится в аттрибуте "when" узла. Дата может
- быть представлена как в полном формате "YYYY-MM-DD", так и в укороченном "--MM-DD"
- Узел gContact:birthday может отсутствовать в XML-документе}
-type
- TcpBirthday = class
- private
- FDate: TDate; //дата рождения контакта
- FShortFormat: boolean; //если True, то в указании даты рождения используется укороченный формат даты
- procedure SetDate(aDate: TDate);
- function GetServerDate: string;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode{XML-узел на основании которого будет создан экземпляр класса} = nil);
- {Очищает поля класса от всех данных. Поле FShortFormat получает значение false}
- procedure Clear;
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- поле FDate<=0}
- function IsEmpty: boolean;
- { Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(const Node: TXmlNode{узел на основании которого будет проходить заполнение полей объекта});
- {На основании значений полей класса формирует новый XML-узел и помещает его как
- дочерний для узла Root. Если экземпляр класса не содержит данных (функция
- IsEmpty возвращает true) выполнение функции прерывается и результатом функции
- будет nil}
- function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
- {Указывает используется ли в описании даты рождения контакта укороченный формат датты (без года рождения)}
- property ShotrFormat: boolean read FShortFormat write FShortFormat;
- {Дата рождения контакта. Если используется укороченный формат даты, то в Date указывается текущий год}
- property Date: TDate read FDate write SetDate;
- {Строка используемая для указания даты рождения контакта в XML-документе.
- Фактически - это значение атрибута when узла gContact:birthday}
- property ServerDate: string read GetServerDate;
- end;
-
-{Перечислитель, используемый для определения параметра Rel узла
-gContact:calendarLink}
-type
- TCalendarRel = (tc_none {значение парамета не определено},
- tc_work {определяет ссылку на рабочий календарь контакта},
- tc_home {определяет ссылку на календарь контакта, используемого для домашних записей},
- tc_free_busy {определяет ссылку на календарь контака в котором указана информация о занятости});
-
-
-{Класс, описывающий узел gContact:calendarLink.
- Этот узел используется для указания ссылок на календари контакта.
- Тип календаря, указанного в ссылке, определяется атрибутом Rel XML-узла
- Элемент gContact:calendarLink может быть повторен в рамках описания
- одного контакта, но только один календарь пользователя может помечаться как основной
- (иметь аттрибут primary=true).
- Узел gContact:calendarLink может отсутствовать в XML-документе}
- TcpCalendarLink = class
- private
- FRel: TCalendarRel;
- FLabel: string;
- FPrimary: boolean;
- FHref: string;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- { Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
- {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
-
- * Пример использования *
-
- ...
- property Rel: TCalendarRel read FRel write FRel;
- ...
- S:string;
-
- Rel:=tc_work;
- S:=RelToString;
- ----------
- S='Рабочий календарь'
- }
- function RelToString: string;
- {Очищает поля класса от всех данных.}
- procedure Clear;
- {На основании значений полей класса формирует новый XML-узел и помещает его как
- дочерний для узла Root. Если экземпляр класса не содержит данных (функция
- IsEmpty возвращает true) выполнение функции прерывается и результатом функции
- будет nil}
- function AddToXML(Root: TXmlNode {родительский узел для вновь создаваемого узла}): TXmlNode;
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
- function IsEmpty: boolean;
- property Rel: TCalendarRel read FRel write FRel;//атрибут Rel узла. Определяет тип ссылки на календарь
- property Primary: boolean read FPrimary write FPrimary;//определяет является ли календарь основным для контакта
- property Href: string read FHref write FHref;//ссылка на календарь контакта
- end;
-
-
-{Перечислитель, используемый для определения параметра Rel узла
-gContact:event}
- TEventRel = (teNone {значение парамета не определено - при отправке информации на сервер,
- содержащей такой XML-узел закончится неудачей, если не будет определен атрибут label},
- teAnniversary {значение определяет какой-либо юбилей контакта},
- teOther {значение определяет другие важные события контакта});
-
-
-{Класс, описывающий узел gContact:event.
- Этот узел используется для указания каких-либо значимых дат для контакта.
- Тип события, указанного в XML-элементе, определяется атрибутом Rel.
- Элемент gContact:event может быть повторен в рамках описания
- одного контакта.
- Узел gContact:event может отсутствовать в XML-документе}
- TcpEvent = class
- private
- FEventType: TEventRel;
- FLabel: string;
- FWhen: TgdWhen;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- {Очищает поля класса от всех данных.}
- procedure Clear;
- { Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
- {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
-
- * Пример использования *
-
- ...
- property EventType: TEventRel read FEventType write FEventType;
- ...
- S:string;
-
- Rel:=teAnniversary;
- S:=RelToString;
- ----------
- S='Юбилей'
- }
- function RelToString: string;
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
- function IsEmpty: boolean;
- {На основании значений полей класса формирует новый XML-узел и помещает его как
- дочерний для узла Root. Если экземпляр класса не содержит данных (функция
- IsEmpty возвращает true) выполнение функции прерывается и результатом функции
- будет nil}
- function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
-
- property EventType: TEventRel read FEventType write FEventType;//тип события, указанного в элементе
- property Labl: string read FLabel write FLabel;//тектсовая метка, определяющая событие, если параметр Rel XML-узла имеет значение Other
- property When: TgdWhen read FWhen write FWhen; //определет дату наступления события
- end;
-
-
-{Перечислитель, используемый для определения параметра Rel узла
-gContact:externalId}
-type
- TExternalIdType = (tiNone {значение не определено},
- tiAccount {указан ID аккаунта},
- tiCustomer {указан ID клиента какой-либо внешней сети},
- tiNetwork {указан сетевой идентификатор в какой-либо сети},
- tiOrganization {указан ID организации в которой работает контакт});
-
-{Класс, описывающий узел gContact:externalId.
- Этот узел используется для указания каких-либо идентификаторов внешних систем в которых участвует контакт.
- Тип ID, указанного в XML-элементе, определяется атрибутом Rel.
- Элемент gContact:externalId может быть повторен в рамках описания
- одного контакта.
- Узел gContact:externalId может отсутствовать в XML-документе}
- TcpExternalId = class
- private
- FRel: TExternalIdType;
- FLabel: string;
- FValue: string;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- {Очищает поля класса от всех данных.}
- procedure Clear;
- { Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
- {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
-
- * Пример использования *
-
- ...
- property Rel: TExternalIdType read FRel write FRel;
- ...
- S:string;
-
- Rel:=tiAccount;
- S:=RelToString;
- ----------
- S='ID аккаунта'
- }
- function RelToString: string;
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
- function IsEmpty: boolean;
- {На основании значений полей класса формирует новый XML-узел и помещает его как
- дочерний для узла Root. Если экземпляр класса не содержит данных (функция
- IsEmpty возвращает true) выполнение функции прерывается и результатом функции
- будет nil}
- function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
-
- property Rel: TExternalIdType read FRel write FRel;//определяет тип ID
- property Labl: string read FLabel write FLabel;//текстовая метка, определяющая указанный ID
- property Value: string read FValue write FValue;//значение ID
- end;
-
-
-{Перечислитель, используемый для определения значения узла
-gContact:gender}
-type
- TGenderType = (none {пол контакта не указан},
- male {мужской},
- female{женский});
-
-{Класс, описывающий узел gContact:gender.
- Этот узел используется для указания пола контакта.
- Пол указывается в значении в XML-элемента.
- Элемент gContact:gender не может быть повторен в рамках описания
- одного контакта.
- Узел gContact:gender может отсутствовать в XML-документе}
- TcpGender = class
- private
- FValue: TGenderType;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- {Очищает поля класса от всех данных.}
- procedure Clear;
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
- function IsEmpty: boolean;
- {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
-
- * Пример использования *
-
- ...
- property Value: TGenderType read FValue write FValue;
- ...
- S:string;
-
- Rel:=male;
- S:=ValueToString;
- ----------
- S='мужской'
- }
- function ValueToString: string;
- {Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
- {На основании значений полей класса формирует новый XML-узел и помещает его как
- дочерний для узла Root. Если экземпляр класса не содержит данных (функция
- IsEmpty возвращает true) выполнение функции прерывается и результатом функции
- будет nil}
- function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
-
- property Value: TGenderType read FValue write FValue;//пол контакта
- end;
-
-
-{Класс, описывающий узел gContact:groupMembershipInfo.
- Этот узел используется для указания того в каких группах содержится контакт.
- Группа указывается в виде строки, содержащей URL группы в адресной книге.
- Элемент gContact:groupMembershipInfo может быть повторен в рамках описания
- одного контакта.
- Узел gContact:groupMembershipInfo обязательно присутствует в XML-документе}
-type
- TcpGroupMembershipInfo = class
- private
- FDeleted: boolean;
- FHref: string;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- {Очищает поля класса от всех данных.}
- procedure Clear;
- {Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
- function IsEmpty: boolean;
- {На основании значений полей класса формирует новый XML-узел и помещает его как
- дочерний для узла Root. Если экземпляр класса не содержит данных (функция
- IsEmpty возвращает true) выполнение функции прерывается и результатом функции
- будет nil}
- function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
-
- property Href: string read FHref write FHref;//URL группы контактов
- property Deleted: boolean read FDeleted write FDeleted;//значение true указывает на то, что контакт был удален не позднее, чем 30 дней назад
- end;
-
-{Перечислитель, используемый для определения значения атрибута rel узла
-gContact:jot}
-type
- TJotRel = (TjNone,
- Tjhome,
- Tjwork,
- Tjother,
- Tjkeywords,
- Tjuser );
-
-{Класс, описывающий узел gContact:jot.
- Этот узел используется для хранения произвольной информации о контакте.
- Каждый фрагмент информации обязательно должен иметь свой тип, описываемый в атрибуте rel
- (см. также значения перечислителя TJotRel)
- Фрагменты информации храняться в значении XML-узла.
- Элемент gContact:jot может быть повторен в рамках описания одного контакта.
- Узел gContact:jot может отсутствовать в XML-документе}
- TcpJot = class
- private
- FRel: TJotRel;
- FText: string;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- {Очищает поля класса от всех данных.}
- procedure Clear;
- {Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
- {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
-
- * Пример использования *
-
- ...
- property Rel: TJotRel read FRel write FRel;
- ...
- S:string;
-
- Rel:=Tjkeywords;
- S:=RelToString;
- ----------
- S='Ключевые слова'
- }
- function RelToString: string;
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
- function IsEmpty: boolean;
- {На основании значений полей класса формирует новый XML-узел и помещает его как
- дочерний для узла Root. Если экземпляр класса не содержит данных (функция
- IsEmpty возвращает true) выполнение функции прерывается и результатом функции
- будет nil}
- function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
- property Rel: TJotRel read FRel write FRel;//значение атрибута Rel
- property Text: string read FText write FText;//фрагмент информации о контакте, записанный в XML-узле
- end;
-
-
-{Класс, описывающий узел gContact:language.
- Этот узел используется для хранения информации о предпочитаемом языке контакта.
- В атрибуте code указывается код языка согласно спецификации IETF BCP 47. Если код определен не верно, то
- сервер вернет ошибку.
- Произвольное описание языка задается в атрибуте label узла. Если определено значение code, то label обязателен к заполнению.
- Элемент gContact:language может быть повторен в рамках описания одного контакта.
- Узел gContact:language может отсутствовать в XML-документе}
-type
- TcpLanguage = class
- private
- Fcode: string;
- FLabel: string;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- {Очищает поля класса от всех данных.}
- procedure Clear;
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
- function IsEmpty: boolean;
- {Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
- {На основании значений полей класса формирует новый XML-узел и помещает его как
- дочерний для узла Root. Если экземпляр класса не содержит данных (функция
- IsEmpty возвращает true) выполнение функции прерывается и результатом функции
- будет nil}
- function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
- property Code: string read Fcode write Fcode;//код языка согласно спецификации IETF BCP 47
- property Labl: string read FLabel write FLabel;//произвольная строка определяющая язык пользователя
- end;
-
-
-{Перечислитель, используемый для определения значения атрибута rel узла
-gContact:priority}
-type
- TPriotityRel = (TpNone {приоритет не определен},
- Tplow {низкий приоритет контакта},
- Tpnormal {нормальный приоритет контакта},
- Tphigh {высокий приоритет контакта});
-
- {Класс, описывающий узел gContact:priority.
- С помощью этого узла контакты можно разделить по трём категориям важности (см. описание перечислителя TPriotityRel).
- Важность контакта определяется в атрибуте rel XML-узла.
- Элемент gContact:priority не может повторяться в рамках описания одного контакта.
- Узел gContact:priority может отсутствовать в XML-документе}
- TcpPriority = class
- private
- FRel: TPriotityRel;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- {Очищает поля класса от всех данных.}
- procedure Clear;
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
- function IsEmpty: boolean;
- {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
-
- * Пример использования *
-
- ...
- property Rel: TPriotityRel read FRel write FRel;
- ...
- S:string;
-
- Rel:=Tplow;
- S:=RelToString;
- ----------
- S='Низкий приоритет'
- }
- function RelToString: string;
- {Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
- {На основании значений полей класса формирует новый XML-узел и помещает его как
- дочерний для узла Root. Если экземпляр класса не содержит данных (функция
- IsEmpty возвращает true) выполнение функции прерывается и результатом функции
- будет nil}
- function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
- property Rel: TPriotityRel read FRel write FRel;//приоритет пользователя (см. описание перечислителя TPriotityRel)
- end;
-
-
-{Перечислитель, используемый для определения значения атрибута rel узла
-gContact:relation}
-type
- TRelationType = (tr_None {отношение к контаку не указано},
- tr_assistant {указанное лицо является помощником},
- tr_brother {указанное лицо является братом},
- tr_child {указанное лицо является ребенком},
- tr_domestic_partner {указанное лицо является соседом},
- tr_father {указанное лицо является отцом},
- tr_friend {указанное лицо является другом},
- tr_manager {указанное лицо является управляющим (начальником)},
- tr_mother {указанное лицо является матерью},
- tr_parent {указанное лицо является родителем},
- tr_partner {указанное лицо является партнером},
- tr_referred_by {указанное лицо является знакомым},
- tr_relative {контакт находится с этим лицом в каких-либо других отношениях},
- tr_sister {указанное лицо является сестрой},
- tr_spouse {указанное лицо является супругой});
-
- {Класс, описывающий узел gContact:relation.
- Используется для указания других лиц, состоящих в каки-либо отношениях с контактом (см. описание перечислителя TRelationType).
- Отношение к контакту указывается в атрибуте rel XML-узла.
- Элемент gContact:relation может повторяться в рамках описания одного контакта.
- Узел gContact:relation может отсутствовать в XML-документе}
- TcpRelation = class
- private
- FValue: string;
- FLabel: string;
- FRealition: TRelationType;
- function GetRelStr(aRel: TRelationType): string;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- {Очищает поля класса от всех данных.}
- procedure Clear;
- {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
-
- * Пример использования *
-
- ...
- property Realition: TRelationType read FRealition write FRealition;
- ...
- S:string;
-
- Realition:=tr_brother;
- S:=RelToString;
- ----------
- S='Брат'
- }
- function RelToString: string;
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
- function IsEmpty: boolean;
- {Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
- {На основании значений полей класса формирует новый XML-узел и помещает его как
- дочерний для узла Root. Если экземпляр класса не содержит данных (функция
- IsEmpty возвращает true) выполнение функции прерывается и результатом функции
- будет nil}
- function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
- property Realition: TRelationType read FRealition write FRealition;//отношение к контакту (см. описание значений перечислителя TRelationType)
- property Value: string read FValue write FValue;//дения об указанном человеке (e-mail, имя, и т.д.)
- end;
-
-
-{Перечислитель, используемый для определения значения атрибута rel узла
-gContact:sensitivity}
-type
- TSensitivityRel = (TsNone {характер контакта не определен},
- Tsconfidential {конфеденциальный контакт},
- Tsnormal {обычный контакт},
- Tspersonal {персональный контакт},
- Tsprivate {приватный (скрытый) контакт});
-
-
-
-
- {Класс, описывающий узел gContact:sensitivity.
- Используется для классификации контактов по их степени открытости (см. описание значений перечислителя TSensitivityRel).
- Степень открытости контакта указывается в атрибуте rel XML-узла.
- Элемент gContact:sensitivity не может повторяться в рамках описания одного контакта.
- Узел gContact:sensitivity может отсутствовать в XML-документе}
- TcpSensitivity = class
- private
- FRel: TSensitivityRel;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- {Очищает поля класса от всех данных.}
- procedure Clear;
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
- function IsEmpty: boolean;
- {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
-
- * Пример использования *
-
- ...
- property Rel: TSensitivityRel read FRel write FRel;
- ...
- S:string;
-
- Rel:=Tsconfidential;
- S:=RelToString;
- ----------
- S='Конфеденциальный'
- }
- function RelToString: string;
- {Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
- {На основании значений полей класса формирует новый XML-узел и помещает его как
- дочерний для узла Root. Если экземпляр класса не содержит данных (функция
- IsEmpty возвращает true) выполнение функции прерывается и результатом функции
- будет nil}
- function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
- property Rel: TSensitivityRel read FRel write FRel;//характеристика "открытости" контакта (см. описание значений перечислителя TSensitivityRel)
- end;
-
-
-{Перечислитель, используемый для определения значения атрибута id узла
-gContact:systemGroup}
-type
- TcpSysGroupId = (tg_None {идентификатор группы не определен},
- tg_Contacts {идентификатор системной группы "Мои контакты"},
- tg_Friends {идентификатор системной группы "Друзья"},
- tg_Family {идентификатор системной группы "Семья"},
- tg_Coworkers {идентификатор системной группы "Коллеги"});
-
-{Класс, описывающий узел gContact:systemGroup.
- Используется для определения идентификатора групы, если группа является системной.
- Идентификатор сисемной группы указывается в атрибуте id XML-узла.
- Элемент gContact:systemGroup не может повторяться в рамках описания одной группы.
- Узел gContact:systemGroup может отсутствовать в XML-документе}
- TcpSystemGroup = class
- private
- FIdRel: TcpSysGroupId;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- {Очищает поля класса от всех данных.}
- procedure Clear;
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
- function IsEmpty: boolean;
- {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
-
- * Пример использования *
-
- ...
- property ID: TcpSysGroupId read FIdRel write FIdRel;
- ...
- S:string;
-
- Rel:=tg_Contacts;
- S:=RelToString;
- ----------
- S='Мои контакты'
- }
- function RelToString: string;
- {Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
- {На основании значений полей класса формирует новый XML-узел и помещает его как
- дочерний для узла Root. Если экземпляр класса не содержит данных (функция
- IsEmpty возвращает true) выполнение функции прерывается и результатом функции
- будет nil}
- function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
- property ID: TcpSysGroupId read FIdRel write FIdRel;//идентификатор системной группы (см. описание перечислителя TcpSysGroupId)
- end;
-
-
-{Класс, описывающий узел gContact:userDefinedField.
- Используется для указания произвольной информации о контакте.
- В XML-узле обязательно должен присутствовать атрибут key - имя поля и value - значение
- Элемент gContact:userDefinedField может повторяться в рамках описания одной группы.
- Узел gContact:userDefinedField может отсутствовать в XML-документе}
-type
- TcpUserDefinedField = class
- private
- FKey: string;
- FValue: string;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- {Очищает поля класса от всех данных.}
- procedure Clear;
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
- function IsEmpty: boolean;
- {Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
- {На основании значений полей класса формирует новый XML-узел и помещает его как
- дочерний для узла Root. Если экземпляр класса не содержит данных (функция
- IsEmpty возвращает true) выполнение функции прерывается и результатом функции
- будет nil}
- function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
-
- property Key: string read FKey write FKey;//Ключ (имя) поля определенного пользователем
- property Value: string read FValue write FValue;//значения поля, определенного пользователем
- end;
-
-
-{Перечислитель, используемый для определения значения атрибута rel узла
-gContact:website}
-type
- TWebSiteType = (tw_None {назначение ресурса не определено},
- tw_Home_Page {ресурс является домашней страничкой контакта},
- tw_Blog {ресурс яляется блогом контакта},
- tw_Profile {ресурс является профилем в Google контакта},
- tw_Home {ресурс является домашним сайтом контакта},
- tw_Work {ресурс является рабочим сайтом контакта},
- tw_Other {назначение ресурса не подходит ни под одно доступное описание},
- tw_Ftp {ресурс является FTP-сайтом контакта});
-
- {Класс, описывающий узел gContact:website.
- Используется для указания ресурсов в Сети с которыми связан контакт.
- Назначение ресурса описывается в атрибуте rel XML-узла (см. описание перечислителя TWebSiteType)
- Элемент gContact:website может повторяться в рамках описания одной группы.
- Узел gContact:website может отсутствовать в XML-документе}
- TcpWebsite = class
- private
- FHref: string;
- FPrimary: boolean;
- FLabel: string;
- FRel: TWebSiteType;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- {Очищает поля класса от всех данных.}
- procedure Clear;
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
- function IsEmpty: boolean;
- {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
-
- * Пример использования *
-
- ...
- property Rel: TWebSiteType read FRel write FRel;
- ...
- S:string;
-
- Rel:=tw_Blog;
- S:=RelToString;
- ----------
- S='Блог'
- }
- function RelToString: string;
- {Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
- {На основании значений полей класса формирует новый XML-узел и помещает его как
- дочерний для узла Root. Если экземпляр класса не содержит данных (функция
- IsEmpty возвращает true) выполнение функции прерывается и результатом функции
- будет nil}
- function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
-
- property Href: string read FHref write FHref;//URL ресурса
- property Primary: boolean read FPrimary write FPrimary;//true, если указанный ресурс является основным для контакта
- property Labl: string read FLabel write FLabel;//произвольное описание ресурса
- property Rel: TWebSiteType read FRel write FRel;//назначение ресурса (см. описание перечислителя TWebSiteType)
- end;
-
-type
- TGoogleContact = class;
- TContactGroup = class;
-
- {Перечислитель, пределяющий формат файла, который будет сформирован для
- передачи на сервер или для сохранения на жесткий диск}
- TFileType = (tfAtom {файл будет формироваться как документ Atom},
- tfXML {файл будет формироваться как обычный XML-документ});
- {Перечислитель, определяющий способ сортировки контактов пользователя}
- TSortOrder = (Ts_None {способ сортировки контактов не определен (определяется сервером)},
- Ts_ascending {сортировка контактов по возрастанию},
- Ts_descending {сортировка контактов по убыванию});
-
-
-{Класс предоставляющий доступ к информации об одном контакте пользователя. Поля класса могут заполняться на основании
-XML-узла entry XML-документа, содержащего сведения о контактах пользователя}
- TContact = class
- private
- FEtag: string;
- FId: string;
- FUpdated: TDateTime;
- FTitle: TTextTag;
- FContent: TTextTag;
- FLinks: TList;
- FName: TgdName;
- FNickName: TcpNickname;
- FBirthDay: TcpBirthday;
- FOrganization: TgdOrganization;
- FEmails: TList;
- FPhones: TList;
- FPostalAddreses: TList;
- FEvents: TList;
- FRelations: TList;
- FUserFields: TList;
- FWebSites: TList;
- FGroupMemberships: TList;
- FIMs: TList;
- function GetPrimaryEmail: string;
- procedure SetPrimaryEmail(aEmail: string);
- function GetOrganization: TgdOrganization;
- function GetContactName: string;
- function GenerateText(TypeFile: TFileType): string;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- {Деструктор. Корректно удаляет объект из памяти}
- destructor Destroy; override;
- {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
- ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
- function IsEmpty: boolean;
- {Очищает поля класса от всех данных.}
- procedure Clear;
- {Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта}); overload;
- {Разбирает узел XML, находящийся в потоке Stream и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(Stream: TStream{поток, содержащий информацию об XML-узле}); overload;
- {находит в списке всех email'ов контакта заданный адрес и возвращает полную информацию по нему в виде объекта TgdEmail}
- function FindEmail(const aEmail: string {адрес email информацию по которому необходимо найти};
- out Index: integer {индекс объекта в списке email'ов контакта}): TgdEmail;
- {сохраняет всю информацию о контакте в файл}
- procedure SaveToFile(const FileName: string {имя файла (включая путь к нему)};
- FileType: TFileType = tfAtom{тип файла (см. описание TFileType)});
- {загружает информацию о контакте из файла}
- procedure LoadFromFile(const FileName: string{имя файла (включая путь к нему});
- {Заголовок контакта. Представляет собой объект TTextTag}
- property TagTitle: TTextTag read FTitle write FTitle;
- {Краткое описание контакта. Представляет собой объект TTextTag}
- property TagContent: TTextTag read FContent write FContent;
- {Имя контакта. Представляет собой объект TgdName}
- property TagName: TgdName read FName write FName;
- {Псевдоним контакта. Представляет собой объект TcpNickname}
- property TagNickName: TcpNickname read FNickName write FNickName;
- {День рождения контакта. Представляет собой объект TcpBirthday}
- property TagBirthDay: TcpBirthday read FBirthDay write FBirthDay;
- {Организация в которой рабоает контакт. Представляет собой объект TgdOrganization}
- property TagOrganization
- : TgdOrganization read GetOrganization write FOrganization;
- {Уникальный идентификатор контакта}
- property Etag: string read FEtag;
- {Идентификатор контакта, представляющий собой URL по которому находится полная информация о контакте}
- property ID: string read FId write FId;
- {Дата последнего обновления контакта}
- property Updated: TDateTime read FUpdated write FUpdated;
- {Список ссылок, связанных с контактом. Каждая ссылка представлена в виде объекта TEntryLink
- Эти ссылки используются для редактирования информации о контакте на сервере, загрузки фотографий, удаления контакта и т.д.}
- property Links: TListread FLinks write FLinks;
- {Список всех email-адресов контакта. Каждый элемент списка представляет собой объект TgdEmail}
- property Emails: TListread FEmails write FEmails;
- {Список всех номеров телефонов контакта. Каждый элемент списка представляет собой объект TgdPhoneNumber}
- property Phones: TListread FPhones write FPhones;
- {Список всех почтовых адресов контакта. Каждый элемент списка представляет собой объект TgdStructuredPostalAddress}
- property PostalAddreses
- : TListread FPostalAddreses write
- FPostalAddreses;
- {Список всех значимых событий для контакта. Каждый элемент списка представляет собой объект TcpEvent}
- property Events: TListread FEvents write FEvents;
- {Список лиц, связанных каким-либо образом с контактом. Каждый элемент списка представляет собой объект TcpRelation}
- property Relations: TListread FRelations write FRelations;
- {Список полей, содержащих дополнительную информацию о контакте. Каждый элемент списка представляет собой объект TcpUserDefinedField}
- property UserFields
- : TListread FUserFields write FUserFields;
- {Список ресурсов в Сети, с которыми связан контакт. Каждый элемент списка представляет собой объект TcpWebsite}
- property WebSites: TListread FWebSites write FWebSites;
- {Список групп в которых находится контакт. Каждый элемент списка представляет собой объект TcpGroupMembershipInfo}
- property GroupMemberships
- : TListread FGroupMemberships write
- FGroupMemberships;
- {Список дополнительных средств связи с контактом. Каждый элемент списка представляет собой объект TgdIm}
- property IMs: TListread FIMs write FIMs;
- {Содержит адрес электронной почты, который является основным для контата.
- Может содержать пустую строку, если ни один из адресов в списке Emails не помечен как Primary}
- property PrimaryEmail: string read GetPrimaryEmail write SetPrimaryEmail;
- {Содержит строку которая представляет собой полное имя контакта.
- Полоное имя контакта формируется на основании данных, содержащихся в свойстве TagName}
- property ContactName: string Read GetContactName;
- {Содержит строку, представляющую собой XML-узел entry, в котором содержится вся информация о конакте}
- property ToXMLText[XMLType: TFileType{тип формируемого узла (см. описание TFileType)}]: string read GenerateText;
- end;
-
-
-{Класс предоставляющий доступ к информации о группе контактов пользователя.
-Поля класса могут заполняться на основании XML-узла entry XML-документа,
-содержащего сведения о группах контактов пользователя}
- TContactGroup = class
- private
- FEtag: string;
- FId: string;
- FLinks: TList;
- FUpdate: TDateTime;
- FTitle: TTextTag;
- FContent: TTextTag;
- FExtendedProps: TgdExtendedProperty;
- FSystemGroup: TcpSystemGroup;
- function GetTitle: string;
- function GetContent: string;
- function GetSysGroupId: TcpSysGroupId;
- procedure SetTitle(const aTitle: string);
- procedure SetContent(const aContent: string);
- procedure SetSysGroupId(aSysGroupId: TcpSysGroupId);
- function GenerateXML(const WintExtended: boolean): TNativeXml;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
- {Разбирает узел XML Node и заполняет на основании полученных данных
- поля класса }
- procedure ParseXML(Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
- {Уникальный идентификатор группы контактов}
- property Etag: string read FEtag write FEtag;
- {Идентификатор группы, представляющий собой URL документа, содержащего всю информацию по группе.
- Также этот идентификатор используется для использования в качестве аттрибута узла gContact:groupMembershipInfo
- (см. иформацию по классу TcpgroupMembershipInfo)}
- property ID: string read FId write FId;
- {Список служебных ссылок для группы контактов. Ссылки используются для редактирования и удаления группы.
- Каждый элемент списка представляет собой класс TEntryLink}
- property Links: TListread FLinks write FLinks;
- {Дата последнего обновления информации о группе}
- property Update: TDateTime read FUpdate write FUpdate;
- {Заголовок группы контактов}
- property Title: string read GetTitle write SetTitle;
- {Краткое описание группы контактов}
- property Content: string read GetContent write SetContent;
- {Если группа является системной, то это свойство содержит всю служебную информацию по группе}
- property SystemGroup: TcpSysGroupId read GetSysGroupId write SetSysGroupId;
- end;
-
- {Основной компонент для работы с Google Contacts. Содержит необходимые свойства
- и методы для работы с группами контактов и контактами}
- TGoogleContact = class(TComponent)
- private
- FAuth: string; // AUTH для доступа к API
- FEmail: string; // обязательно GMAIL!
- FTotalBytes: int64;
- FBytesCount: int64;
- FGroups: TList; // группы контактов
- FContacts: TList; // все контакты
- FOnRetriveXML: TOnRetriveXML;
- FOnBeginParse: TOnBeginParse;
- FOnEndParse: TOnEndParse;
- FOnReadData: TOnReadData;
- FMaximumResults: integer;
- FStartIndex: integer;
- FUpdatesMin: TDateTime;
- FSortOrder: TSortOrder;
- FShowDeleted: boolean;
- function GetNextLink(Stream: TStream): string; overload;
- function GetNextLink(aXMLDoc: TNativeXml): string; overload;
- function GetContactsByGroup(GroupName: string): TList;
- function GroupLink(const aGroupName: string): string;
- procedure ParseXMLContacts(const Data: TStream);
- function GetEditLink(aContact: TContact): string;
- function InsertPhotoEtag(aContact: TContact; const Response: TStream)
- : boolean;
- function GetTotalCount(aXMLDoc: TNativeXml): integer;
- procedure ReadData(Sender: TObject; Reason: THookSocketReason;
- const Value: String);
- function RetriveContactPhoto(index: integer): TJPEGImage; overload;
- function RetriveContactPhoto(aContact: TContact): TJPEGImage; overload;
- procedure SetMaximumResults(const Value: integer);
- procedure SetShowDeleted(const Value: boolean);
- procedure SetSortOrder(const Value: TSortOrder);
- procedure SetStartIndex(const Value: integer);
- procedure SetUpdatesMin(const Value: TDateTime);
- function ParamsToStr: TStringList;
- function GetContact(GroupName: string; Index: integer): TContact;
- procedure SetAuth(const aAuth: string);
- procedure SetGmail(const aGMail: string);
- function GetContactNames: TStrings;
- function GetGropsNames: TStrings;
- public
- {Конструктор. Создает объект с настройками по умолчанию}
- constructor Create(AOwner: TComponent); override;
- {Деструктор. Корректно удаляет объект из памяти}
- destructor Destroy; override;
- {Получение всех групп контактов пользователя. Результатом выполнения функции
- является число групп, полученных в результате выполнения запроса на сервер}
- function RetriveGroups: integer;
- {Получение всех контактов пользователя. Результатом выполнения функции
- является число контактов, полученных в результате выполнения запроса на сервер}
- function RetriveContacts: integer;
- {Удаление контакта с сервера по его индексу в списке Contacts.
- Функция возвращает true в случае, если контакт корректно удален с сервера.
- Удаленный с сервера контакт автоматически удаляется из списка контактов Contacts}
- function DeleteContact(index: integer): boolean; overload;
- {Удаление контакта с сервера. Контакт aContact должен находиться в списке Contacts
- Функция возвращает true в случае, если контакт корректно удален с сервера.
- Удаленный с сервера контакт автоматически удаляется из списка контактов Contacts}
- function DeleteContact(aContact: TContact): boolean; overload;
- {Добавление контакта aContact на сервер. успешного выполнения операции
- новый контакт автоматически добавляется в список Contacts}
- function AddContact(aContact: TContact): boolean;
- {Добавление новой группы контактов с названием aName и описанием aDescription на сервер.
- В случае, если операция выполнена успешно новая группа автоматически добавляется в список Groups}
- function AddContactGroup(const aName, aDescription: string): boolean;
- {Редактирование информации группы контактов aGroup. Редактируемая группа
- должна находится на сервере (содержать список ссылок Links)}
- function UpdateContactGroup(const aGroup:TContactGroup):boolean;overload;
- {Редактирование информации группы контактов с индексом Index в списке Groups.
- Редактируемая группа должна находится на сервере (содержать список ссылок Links)}
- function UpdateContactGroup(const Index:integer):boolean;overload;
- {Удаление групп контактов aGroup с сервера. В случае успешно выполненной
- операции группа также удляется из списка Groups}
- function DeleteContactGroup(const aGroup:TContactGroup):boolean;overload;
- {Удаление групп контактов с индексом Index в списке Groups с сервера.
- В случае успешно выполненной операции группа также удляется из списка Groups}
- function DeleteContactGroup(const Index:integer):boolean;overload;
- {Обновление информации о контакте aContact. Контакт должен находится в списке Contacts
- В случае успешно выполненной операции информация о контакте обновляется как в списке Contacts
- так и на сервере}
- function UpdateContact(aContact: TContact): boolean; overload;
- {Обновление информации о контакте с индексом Index в списке Contacts
- В случае успешно выполненной операции информация о контакте обновляется как в списке Contacts
- так и на сервере}
- function UpdateContact(index: integer): boolean; overload;
- {Получение с сервера фотографии контакта aContact. В случае, если контакт не содержит фотографии
- результатом выполнения функции будет изображение, загруженное из файла DefaultImage}
- function RetriveContactPhoto(aContact: TContact; DefaultImage: TFileName)
- : TJPEGImage; overload;
- {Получение с сервера фотографии контакта с индексом Index в списке Contacts.
- В случае, если контакт не содержит фотографии результатом выполнения функции
- будет изображение, загруженное из файла DefaultImage}
- function RetriveContactPhoto(index: integer; DefaultImage: TFileName)
- : TJPEGImage; overload;
-
- {Загружает на сервер файл PhotoFile в качестве изображения контакта,
- имеющего индекс Index в списке Contacts. Функция возращает
- True в случае успешной загрузки}
- function UpdatePhoto(index: integer; const PhotoFile: TFileName): boolean;
- overload;
- {Загружает на сервер файл PhotoFile в качестве изображения контакта
- aContact. Функция возращает True в случае успешной загрузки}
- function UpdatePhoto(aContact: TContact; const PhotoFile: TFileName)
- : boolean; overload;
- {Удаление изображения контакта aContact с сервера. Функция возвращает
- true в случае, если удаление прошло успешно}
- function DeletePhoto(aContact: TContact): boolean; overload;
- {Удаление изображения контакта с индексом Index в списке Contacts
- с сервера. Функция возвращает true в случае, если удаление прошло успешно}
- function DeletePhoto(index: integer): boolean; overload;
- {Сохранение всего списка контактов Contacts в файл FileName.
- Формат файла - XML}
- procedure SaveContactsToFile(const FileName: string);
- {Загружает локальную копию списка контактов из XML-файла FileName}
- procedure LoadContactsFromFile(const FileName: string);
-
-
- property Groups: TListread FGroups write FGroups;//список все групп контактов пользователя
- property Contacts: TListread FContacts write FContacts;//список всех контактов пользователя
- property ContactByGroupIndex[Group: string; I: integer]
- : TContact read GetContact;//контакт, находящийся в группе с именем
- //Group и имеющий в этой группе индекс i
- property ContactsByGroup[GroupName: string]
- : TListread GetContactsByGroup;//список всех контактов, находящихся в группе с именем GroupName
- property ContactsNames: TStrings read GetContactNames;// список имен контактов
- property GroupsNames: TStrings read GetGropsNames;// список имен групп контактов
-
- published
- property Auth: string read FAuth write SetAuth;//Ключ Auth для авторизации в сервисе. Может быть получен с использованием компонента TClientLogin
- property Gmail: string read FEmail write SetGmail;//адрес почтового ящика на GMail. Используется для работы с группами и контактами
-
- property MaximumResults: integer read FMaximumResults write SetMaximumResults;// максимальное количество записей контактов возвращаемое в одном фиде
- property StartIndex: integer read FStartIndex write SetStartIndex;// начальный номер контакта с которого начинать принятие данных
- property UpdatesMin: TDateTime read FUpdatesMin write SetUpdatesMin;// нижняя граница обновления контактов
- property ShowDeleted: boolean read FShowDeleted write SetShowDeleted;// определяет будут ли показываться в списке удаленные контакты
- property SortOrder: TSortOrder read FSortOrder write SetSortOrder;// сортировка контактов
-
-
- property OnRetriveXML: TOnRetriveXML read FOnRetriveXML write FOnRetriveXML;// начало загрузки XML-документа с сервера
- property OnBeginParse: TOnBeginParse read FOnBeginParse write FOnBeginParse;// старт парсинга XML
- property OnEndParse: TOnEndParse read FOnEndParse write FOnEndParse;// окончание парсинга XML
- property OnReadData: TOnReadData read FOnReadData write FOnReadData;// чтение данных из Сети
- end;
-
-// получение типа узла
-function GetContactNodeType(const NodeName: string): TcpTagEnum; inline;
-// получение имени узла по его типу
-function GetContactNodeName(const NodeType: TcpTagEnum): string; inline;
-
-procedure Register;
-
-implementation
-
-procedure Register;
-begin
- RegisterComponents('webdelphi.ru',[TGoogleContact]);
-end;
-
-function GetContactNodeName(const NodeType: TcpTagEnum): string; inline;
-begin
- Result := GetEnumName(TypeInfo(TcpTagEnum), ord(NodeType));
- Delete(Result, 1, 3);
- Result := CpNodeAlias + Result;
-end;
-
-function GetContactNodeType(const NodeName: string): TcpTagEnum; inline;
-var
- I: integer;
-begin
- if pos(CpNodeAlias, NodeName) > 0 then
- begin
- I := GetEnumValue(TypeInfo(TcpTagEnum), Trim
- (ReplaceStr(NodeName, CpNodeAlias, 'cp_')));
- if I > -1 then
- Result := TcpTagEnum(I)
- else
- Result := cp_None;
- end
- else
- Result := cp_None;
-end;
-
-{ TcpBirthday }
-
-function TcpBirthday.AddToXML(Root: TXmlNode): TXmlNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetContactNodeName(cp_birthday));
- Result.AttributeAdd('when', ServerDate);
-end;
-
-procedure TcpBirthday.Clear;
-begin
- FDate := 0;
- FShortFormat:=false;
-end;
-
-constructor TcpBirthday.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- Clear;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TcpBirthday.GetServerDate: string;
-begin
- Result := '';
- if not IsEmpty then
- begin
- if FShortFormat then // укороченный формат даты
- Result := FormatDateTime('--mm-dd', FDate)
- else
- Result := FormatDateTime('yyyy-mm-dd', FDate);
- end;
-end;
-
-function TcpBirthday.IsEmpty: boolean;
-begin
- Result := FDate <= 0;
-end;
-
-procedure TcpBirthday.ParseXML(const Node: TXmlNode);
-var
- DateStr: string;
- FormatSet: TFormatSettings;
-begin
- if GetContactNodeType(Node.NameUnicode) <> cp_birthday then
- raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_birthday)]);
- try
- { читаем локальные настройки форматов }
- GetLocaleFormatSettings(LOCALE_SYSTEM_DEFAULT, FormatSet);
- { чиаем дату }
- DateStr := Node.ReadAttributeString('when');
- if (Length(Trim(DateStr)) > 0) then // что-то есть - можно парсить дату
- begin
- // сокращенный формат - только месяц и число рождения
- if (pos('--', DateStr) > 0) then
- begin
- FormatSet.DateSeparator := '-'; // устанавливаем новый разделиель
- Delete(DateStr, 1, 2); // срезаем первые два символа
- FormatSet.ShortDateFormat := 'mm-dd';
- FDate := StrToDate(DateStr, FormatSet);
- FShortFormat := true;
- end
- // полный формат даты
- else
- begin
- FormatSet.DateSeparator := '-';
- FormatSet.ShortDateFormat := 'yyyy-mm-dd';
- FDate := StrToDate(DateStr, FormatSet);
- FShortFormat := false;
- end;
- end;
- except
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- end;
-end;
-
-procedure TcpBirthday.SetDate(aDate: TDate);
-begin
- FDate := aDate;
-end;
-
-{ TcpCalendarLink }
-
-function TcpCalendarLink.AddToXML(Root: TXmlNode): TXmlNode;
-var
- tmp: string;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetContactNodeName(cp_calendarLink));
- if FRel <> tc_none then
- begin
- tmp := ReplaceStr(GetEnumName(TypeInfo(TCalendarRel), ord(FRel)), '_', '-');
- Delete(tmp, 1, 3);
- Result.AttributeAdd(sNodeRelAttr, tmp)
- end
- else
- Result.AttributeAdd(sNodeLabelAttr, FLabel);
- Result.AttributeAdd(sNodeHrefAttr, FHref);
- if FPrimary then
- Result.WriteAttributeBool(sNodePrimaryAttr, FPrimary);
-end;
-
-procedure TcpCalendarLink.Clear;
-begin
- FLabel := '';
- FRel := tc_none;
- FHref := '';
-end;
-
-constructor TcpCalendarLink.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- Clear;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TcpCalendarLink.IsEmpty: boolean;
-begin
- Result := ((Length(Trim(FLabel)) = 0) or (FRel = tc_none)) and
- (Length(Trim(FHref)) = 0);
-end;
-
-procedure TcpCalendarLink.ParseXML(const Node: TXmlNode);
-begin
- if GetContactNodeType(Node.NameUnicode) <> cp_calendarLink then
- raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_calendarLink)]);
- try
- FPrimary := false;
- FRel := tc_none;
- if Length(Trim(Node.AttributeByUnicodeName[sNodeRelAttr])) > 0 then
- begin // считываем данные о rel
- FRel := TCalendarRel(GetEnumValue(TypeInfo(TCalendarRel),
- 'tc_' + ReplaceStr((Trim(Node.AttributeByUnicodeName[sNodeRelAttr])),
- '-', '_')))
- end
- else // rel отсутствует, следовательно читаем label
- FLabel := Trim(Node.AttributeByUnicodeName[sNodeLabelAttr]);
- if Node.HasAttribute(sNodePrimaryAttr) then
- FPrimary := Node.ReadAttributeBool(sNodePrimaryAttr);
- FHref := Node.ReadAttributeString(sNodeHrefAttr);
- except
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- end;
-end;
-
-function TcpCalendarLink.RelToString: string;
-begin
- case FRel of
- tc_none: Result := FLabel; // описание содержится в label - свободный текст
- tc_work: Result := LoadStr(c_Work);
- tc_home: Result := LoadStr(c_Home);
- tc_free_busy: Result := LoadStr(c_FreeBusy);
- end;
-end;
-
-{ TcpEvent }
-
-function TcpEvent.AddToXML(Root: TXmlNode): TXmlNode;
-var
- sRel: string;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetContactNodeName(cp_event));
- if ord(FEventType) > -1 then
- begin
- sRel := GetEnumName(TypeInfo(TEventRel), ord(FEventType));
- Delete(sRel, 1, 2);
- Result.WriteAttributeString(sNodeRelAttr, sRel);
- end
- else
- begin
- sRel := GetEnumName(TypeInfo(TEventRel), ord(teOther));
- Delete(sRel, 1, 2);
- Result.WriteAttributeString(sNodeRelAttr, sRel);
- end;
- if Length(FLabel) > 0 then
- Result.WriteAttributeString(sNodeLabelAttr, FLabel);
- FWhen.AddToXML(Result, tdDate);
-end;
-
-procedure TcpEvent.Clear;
-begin
- FEventType := teNone;
- FLabel := '';
-end;
-
-constructor TcpEvent.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- Clear;
- FWhen := TgdWhen.Create;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TcpEvent.IsEmpty: boolean;
-begin
- Result := (FEventType = teNone) and (Length(Trim(FLabel)) = 0) and
- (FWhen.IsEmpty)
-end;
-
-procedure TcpEvent.ParseXML(const Node: TXmlNode);
-var
- WhenNode: TXmlNode;
- S: String;
-begin
- if GetContactNodeType(Node.NameUnicode) <> cp_event then
- raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_event)]);
- try
- if Node.HasAttribute(sNodeLabelAttr) then
- FLabel := Trim(Node.ReadAttributeString(sNodeLabelAttr));
- if Node.HasAttribute(sNodeRelAttr) then
- begin
- S := Trim(Node.ReadAttributeString(sNodeRelAttr));
- S := StringReplace(S, sSchemaHref, '', [rfIgnoreCase]);
- FEventType := TEventRel(GetEnumValue(TypeInfo(TEventRel), S));
- end;
-
- WhenNode := Node.FindNode(GetGDNodeName(gd_When));
- if WhenNode <> nil then
- FWhen := TgdWhen.Create(WhenNode)
- else
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- except
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- end;
-end;
-
-function TcpEvent.RelToString: string;
-begin
- case FEventType of
- teNone: Result := FLabel;
- teAnniversary: Result := LoadStr(c_EvntAnniv);
- teOther: Result := LoadStr(c_EvntOther);
- end;
-end;
-
-{ TcpExternalId }
-
-function TcpExternalId.AddToXML(Root: TXmlNode): TXmlNode;
-var
- sRel: string;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- if ord(FRel) < 0 then
- raise ECPException.CreateFmt(sc_ErrWriteNode, [GetContactNodeName(cp_externalId)+ ' ' + Format(sc_WrongAttr, ['rel'])]);
- Result := Root.NodeNew(GetContactNodeName(cp_externalId));
- if Trim(FLabel) <> '' then
- Result.WriteAttributeString(sNodeLabelAttr, FLabel);
- sRel := GetEnumName(TypeInfo(TExternalIdType), ord(FRel));
- Delete(sRel, 1, 2);
- Result.WriteAttributeString(sNodeRelAttr, sRel);
- Result.WriteAttributeString(sNodeValueAttr, FValue);
-end;
-
-procedure TcpExternalId.Clear;
-begin
- FRel := tiNone;
- FLabel := '';
- FValue := '';
-end;
-
-constructor TcpExternalId.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- Clear;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TcpExternalId.IsEmpty: boolean;
-begin
- Result := (FRel = tiNone) and (Length(Trim(FLabel)) = 0) and
- (Length(Trim(FValue)) = 0);
-end;
-
-procedure TcpExternalId.ParseXML(const Node: TXmlNode);
-begin
- if Node = nil then Exit;
- if GetContactNodeType(Node.NameUnicode) <> cp_externalId then
- raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName
- (cp_externalId)]);
- try
- if Node.HasAttribute(sNodeLabelAttr) then
- FLabel := Node.ReadAttributeString(sNodeLabelAttr);
- FRel := TExternalIdType(GetEnumValue(TypeInfo(TExternalIdType),
- 'ti' + Node.ReadAttributeString(sNodeRelAttr)));
- FValue := Node.ReadAttributeString(sNodeValueAttr);
- except
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- end;
-end;
-
-function TcpExternalId.RelToString: string;
-begin
- // TExternalIdType = (tiNone,tiAccount,tiCustomer,tiNetwork,tiOrganization);
- case FRel of
- tiNone: Result := FLabel; // rel не определен - берем описание из label
- tiAccount: Result := LoadStr(c_AccId);
- tiCustomer: Result := LoadStr(c_AccCostumer);
- tiNetwork: Result := LoadStr(c_AccNetwork);
- tiOrganization: Result := LoadStr(c_AccOrg);
- end;
-end;
-
-{ TcpGender }
-
-function TcpGender.AddToXML(Root: TXmlNode): TXmlNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then Exit;
- if ord(FValue) < 0 then
- raise ECPException.CreateFmt(sc_ErrWriteNode, [GetContactNodeName(cp_gender)+' '+
- Format(sc_WrongAttr, [sNodeValueAttr])]);
- Result := Root.NodeNew(GetContactNodeName(cp_gender));
- Result.WriteAttributeString(sNodeValueAttr, GetEnumName
- (TypeInfo(TGenderType), ord(FValue)));
-end;
-
-procedure TcpGender.Clear;
-begin
- FValue := none;
-end;
-
-constructor TcpGender.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- Clear;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TcpGender.IsEmpty: boolean;
-begin
- Result := FValue = none;
-end;
-
-procedure TcpGender.ParseXML(const Node: TXmlNode);
-begin
- if Node = nil then
- Exit;
- if GetContactNodeType(Node.NameUnicode) <> cp_gender then
- raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_gender)]);
- try
- FValue := TGenderType(GetEnumValue(TypeInfo(TGenderType),
- Node.ReadAttributeString(sNodeValueAttr)));
- except
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- end;
-end;
-
-function TcpGender.ValueToString: string;
-begin
- case FValue of
- none:
- Result := '';
- male:
- Result := LoadStr(c_Male);
- female:
- Result := LoadStr(c_Female);
- end;
-end;
-
-{ TcpGroupMembershipInfo }
-
-function TcpGroupMembershipInfo.AddToXML(Root: TXmlNode): TXmlNode;
-begin
- Result := nil;
- if (Root = nil) or (IsEmpty) then
- Exit;
- Result := Root.NodeNew(GetContactNodeName(cp_groupMembershipInfo));
- Result.WriteAttributeString(sNodeHrefAttr, FHref);
- Result.WriteAttributeBool(sNodeDeletedAttr, FDeleted);
-end;
-
-procedure TcpGroupMembershipInfo.Clear;
-begin
- FHref := '';
-end;
-
-constructor TcpGroupMembershipInfo.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- Clear;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TcpGroupMembershipInfo.IsEmpty: boolean;
-begin
- Result := Length(Trim(FHref)) = 0
-end;
-
-procedure TcpGroupMembershipInfo.ParseXML(const Node: TXmlNode);
-begin
- if Node = nil then
- Exit;
- if GetContactNodeType(Node.NameUnicode) <> cp_groupMembershipInfo then
- raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName
- (cp_groupMembershipInfo)]);
- try
- FHref := Node.ReadAttributeString(sNodeHrefAttr);
- FDeleted := Node.ReadAttributeBool(sNodeDeletedAttr)
- except
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- end;
-end;
-
-{ TcpJot }
-
-function TcpJot.AddToXML(Root: TXmlNode): TXmlNode;
-var
- sRel: string;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetContactNodeName(cp_jot));
- if FRel <> TjNone then
- begin
- sRel := GetEnumName(TypeInfo(TJotRel), ord(FRel));
- Delete(sRel, 1, 2);
- Result.WriteAttributeString(sNodeRelAttr, sRel);
- end;
- Result.ValueAsUnicodeString := FText;
-end;
-
-procedure TcpJot.Clear;
-begin
- FRel := TjNone;
- FText := '';
-end;
-
-constructor TcpJot.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- Clear;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TcpJot.IsEmpty: boolean;
-begin
- Result := (FRel = TjNone) and (Length(Trim(FText)) = 0);
-end;
-
-procedure TcpJot.ParseXML(const Node: TXmlNode);
-begin
- if Node = nil then
- Exit;
- if GetContactNodeType(Node.NameUnicode) <> cp_jot then
- raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_jot)]);
- try
- FRel := TJotRel(GetEnumValue(TypeInfo(TJotRel),
- 'Tj' + Node.ReadAttributeString(sNodeRelAttr)));
- FText := Node.ValueAsUnicodeString;
- except
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- end;
-end;
-
-function TcpJot.RelToString: string;
-begin
- case FRel of
- TjNone:
- Result := ''; // не определенное значение
- Tjhome:
- Result := LoadStr(c_JotHome);
- Tjwork:
- Result := LoadStr(c_JotWork);
- Tjother:
- Result := LoadStr(c_JotOther);
- Tjkeywords:
- Result := LoadStr(c_JotKeywords);
- Tjuser:
- Result := LoadStr(c_JotUser);
- end;
-end;
-
-{ TcpLanguage }
-
-function TcpLanguage.AddToXML(Root: TXmlNode): TXmlNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetContactNodeName(cp_language));
- Result.WriteAttributeString(sNodeCodeAttr, Fcode);
- Result.WriteAttributeString(sNodeLabelAttr, FLabel);
-end;
-
-procedure TcpLanguage.Clear;
-begin
- Fcode := '';
- FLabel := '';
-end;
-
-constructor TcpLanguage.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- Clear;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TcpLanguage.IsEmpty: boolean;
-begin
- Result := (Length(Trim(Fcode)) = 0) and (Length(Trim(FLabel)) = 0);
-end;
-
-procedure TcpLanguage.ParseXML(const Node: TXmlNode);
-begin
- if Node = nil then
- Exit;
- if GetContactNodeType(Node.NameUnicode) <> cp_language then
- raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_language)]);
- try
- Fcode := Node.ReadAttributeString(sNodeCodeAttr);
- FLabel := Node.ReadAttributeString(sNodeLabelAttr);
- except
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- end;
-end;
-
-{ TcpPriority }
-
-function TcpPriority.AddToXML(Root: TXmlNode): TXmlNode;
-var
- sRel: string;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetContactNodeName(cp_priority));
- sRel := GetEnumName(TypeInfo(TPriotityRel), ord(FRel));
- Delete(sRel, 1, 2);
- Result.WriteAttributeString(sNodeRelAttr, sRel);
-end;
-
-procedure TcpPriority.Clear;
-begin
- FRel := TpNone;
-end;
-
-constructor TcpPriority.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- Clear;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TcpPriority.IsEmpty: boolean;
-begin
- Result := FRel = TpNone;
-end;
-
-procedure TcpPriority.ParseXML(const Node: TXmlNode);
-begin
- if Node = nil then
- Exit;
- if GetContactNodeType(Node.NameUnicode) <> cp_priority then
- raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_priority)]);
- try
- FRel := TPriotityRel(GetEnumValue(TypeInfo(TPriotityRel),
- 'Tp' + Node.ReadAttributeString(sNodeRelAttr)));
- except
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- end;
-end;
-
-function TcpPriority.RelToString: string;
-begin
- case FRel of
- TpNone:
- Result := ''; // значение не определено
- Tplow:
- Result := LoadStr(c_PriorityLow);
- Tpnormal:
- Result := LoadStr(c_PriorityNormal);
- Tphigh:
- Result := LoadStr(c_PriorityHigh);
- end;
-end;
-
-{ TcpRelation }
-
-function TcpRelation.AddToXML(Root: TXmlNode): TXmlNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetContactNodeName(cp_relation));
- if FRealition = tr_None then
- Result.WriteAttributeString(sNodeLabelAttr, FLabel)
- else
- Result.WriteAttributeString(sNodeRelAttr, GetRelStr(FRealition));
- Result.ValueAsUnicodeString := FValue;
-end;
-
-procedure TcpRelation.Clear;
-begin
- FValue := '';
- FLabel := '';
- FRealition := tr_None;
-end;
-
-constructor TcpRelation.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- Clear;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TcpRelation.GetRelStr(aRel: TRelationType): string;
-begin
- Result := GetEnumName(TypeInfo(TRelationType), ord(aRel));
- Delete(Result, 1, 3);
- Result := StringReplace(Result, '_', '-', [rfReplaceAll])
-end;
-
-function TcpRelation.IsEmpty: boolean;
-begin
- Result := (Length(Trim(FLabel)) = 0) and (Length(Trim(FValue)) = 0) and
- (FRealition = tr_None);
-end;
-
-procedure TcpRelation.ParseXML(const Node: TXmlNode);
-var
- tmp: string;
-begin
- if Node = nil then
- Exit;
- if GetContactNodeType(Node.NameUnicode) <> cp_relation then
- raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_relation)]);
- try
- if Node.HasAttribute(sNodeRelAttr) then
- begin
- tmp := 'tr_' + ReplaceStr(Node.ReadAttributeString(sNodeRelAttr), '-',
- '_');
- FRealition := TRelationType(GetEnumValue(TypeInfo(TRelationType), tmp))
- end
- else
- begin
- FLabel := Node.ReadAttributeString(sNodeLabelAttr);
- FRealition := tr_None;
- end;
- FValue := Node.ValueAsUnicodeString;
- except
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- end;
-end;
-
-function TcpRelation.RelToString: string;
-begin
- case FRealition of
- tr_None:
- Result := ''; // не определено
- tr_assistant:
- Result := LoadStr(c_RelationAssistant);
- tr_brother:
- Result := LoadStr(c_RelationBrother);
- tr_child:
- Result := LoadStr(c_RelationChild);
- tr_domestic_partner:
- Result := LoadStr(c_RelationDomestPart);
- tr_father:
- Result := LoadStr(c_RelationFather);
- tr_friend:
- Result := LoadStr(c_RelationFriend);
- tr_manager:
- Result := LoadStr(c_RelationManager);
- tr_mother:
- Result := LoadStr(c_RelationMother);
- tr_parent:
- Result := LoadStr(c_RelationPartner);
- tr_partner:
- Result := LoadStr(c_RelationPartner);
- tr_referred_by:
- Result := LoadStr(c_RelationReffered);
- tr_relative:
- Result := LoadStr(c_RelationRelative);
- tr_sister:
- Result := LoadStr(c_RelationSister);
- tr_spouse:
- Result := LoadStr(c_RelationSpouse);
- end;
-end;
-
-{ TcpSensitivity }
-
-function TcpSensitivity.AddToXML(Root: TXmlNode): TXmlNode;
-var
- sRel: string;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- if ord(FRel) < 0 then
- raise ECPException.CreateFmt(sc_ErrWriteNode, [GetContactNodeName(cp_sensitivity) + ' ' + Format(sc_WrongAttr, ['rel'])]);
- Result := Root.NodeNew(GetContactNodeName(cp_sensitivity));
- sRel := GetEnumName(TypeInfo(TSensitivityRel), ord(FRel));
- Delete(sRel, 1, 2);
- Result.WriteAttributeString(sNodeRelAttr, sRel);
-end;
-
-procedure TcpSensitivity.Clear;
-begin
- FRel := TsNone;
-end;
-
-constructor TcpSensitivity.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- Clear;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TcpSensitivity.IsEmpty: boolean;
-begin
- Result := FRel = TsNone;
-end;
-
-procedure TcpSensitivity.ParseXML(const Node: TXmlNode);
-begin
- if Node = nil then
- Exit;
- if GetContactNodeType(Node.NameUnicode) <> cp_sensitivity then
- raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName
- (cp_sensitivity)]);
- try
- FRel := TSensitivityRel(GetEnumValue(TypeInfo(TSensitivityRel),
- 'Ts' + Node.ReadAttributeString(sNodeRelAttr)));
- except
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- end;
-end;
-
-function TcpSensitivity.RelToString: string;
-begin
- case FRel of
- TsNone:
- Result := '';
- Tsconfidential:
- Result := LoadStr(c_SensitivConf);
- Tsnormal:
- Result := LoadStr(c_SensitivNormal);
- Tspersonal:
- Result := LoadStr(c_SensitivPersonal);
- Tsprivate:
- Result := LoadStr(c_SensitivPrivate);
- end;
-end;
-
-{ TsystemGroup }
-
-function TcpSystemGroup.AddToXML(Root: TXmlNode): TXmlNode;
-var
- tmp: string;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then Exit;
- if FIdRel = tg_None then
- raise ECPException.CreateFmt(sc_ErrWriteNode, [GetContactNodeName(cp_systemGroup)+ ' ' + Format(sc_WrongAttr, ['id'])]);
- Result := Root.NodeNew(GetContactNodeName(cp_systemGroup));
- tmp := GetEnumName(TypeInfo(TcpSysGroupId), ord(FIdRel));
- Delete(tmp, 1, 3);
- Result.WriteAttributeString('id', tmp);
-end;
-
-procedure TcpSystemGroup.Clear;
-begin
- FIdRel := tg_None;
-end;
-
-constructor TcpSystemGroup.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- Clear;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TcpSystemGroup.IsEmpty: boolean;
-begin
- Result := FIdRel = tg_None;
-end;
-
-procedure TcpSystemGroup.ParseXML(const Node: TXmlNode);
-begin
- if (Node = nil) then
- Exit;
- if GetContactNodeType(Node.NameUnicode) <> cp_systemGroup then
- raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName
- (cp_systemGroup)]);
- try
- FIdRel := TcpSysGroupId(GetEnumValue(TypeInfo(TcpSysGroupId),
- 'tg_' + Node.ReadAttributeString('id')));
- except
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- end;
-end;
-
-function TcpSystemGroup.RelToString: string;
-begin
- case FIdRel of
- tg_None:
- Result := ''; // значение не определено
- tg_Contacts:
- Result := LoadStr(c_SysGroupContacts);
- tg_Friends:
- Result := LoadStr(c_SysGroupFriends);
- tg_Family:
- Result := LoadStr(c_SysGroupFamily);
- tg_Coworkers:
- Result := LoadStr(c_SysGroupCoworkers);
- end;
-end;
-
-{ TcpUserDefinedField }
-
-function TcpUserDefinedField.AddToXML(Root: TXmlNode): TXmlNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetContactNodeName(cp_userDefinedField));
- Result.WriteAttributeString(sNodeKeyAttr, FKey);
- Result.WriteAttributeString(sNodeValueAttr, FValue);
-end;
-
-procedure TcpUserDefinedField.Clear;
-begin
- FKey := '';
- FValue := '';
-end;
-
-constructor TcpUserDefinedField.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- Clear;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TcpUserDefinedField.IsEmpty: boolean;
-begin
- Result := (Length(Trim(FKey)) = 0) and (Length(Trim(FValue)) = 0)
-end;
-
-procedure TcpUserDefinedField.ParseXML(const Node: TXmlNode);
-begin
- if Node = nil then
- Exit;
- if GetContactNodeType(Node.NameUnicode) <> cp_userDefinedField then
- raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName
- (cp_userDefinedField)]);
- try
- FKey := Node.ReadAttributeString(sNodeKeyAttr);
- FValue := Node.ReadAttributeString(sNodeValueAttr);
- except
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- end;
-end;
-
-{ TcpWebsite }
-
-function TcpWebsite.AddToXML(Root: TXmlNode): TXmlNode;
-var
- tmp: string;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- if FRel = tw_None then
- raise ECPException.CreateFmt(sc_ErrWriteNode, [GetContactNodeName(cp_website)+' '+Format(sc_WrongAttr, ['rel'])]);
- Result := Root.NodeNew(GetContactNodeName(cp_website));
- Result.WriteAttributeString(sNodeHrefAttr, FHref);
-
- tmp := GetEnumName(TypeInfo(TWebSiteType), ord(FRel));
- Delete(tmp, 1, 3);
- tmp := ReplaceStr(tmp, '_', '-');
- Result.WriteAttributeString(sNodeRelAttr, tmp);
-
- if FPrimary then
- Result.WriteAttributeBool(sNodePrimaryAttr, FPrimary);
- if Trim(FLabel) <> '' then
- Result.WriteAttributeString(sNodeLabelAttr, FLabel);
-end;
-
-procedure TcpWebsite.Clear;
-begin
- FHref := '';
- FLabel := '';
- FRel := tw_None;
-end;
-
-constructor TcpWebsite.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- Clear;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TcpWebsite.IsEmpty: boolean;
-begin
- Result := (Length(Trim(FHref)) = 0) and (Length(Trim(FLabel)) = 0) and
- (FRel = tw_None)
-end;
-
-procedure TcpWebsite.ParseXML(const Node: TXmlNode);
-var
- tmp: string;
-begin
- if (Node = nil) then
- Exit;
- if GetContactNodeType(Node.NameUnicode) <> cp_website then
- raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_website)]);
- try
- FRel := tw_None;
- FHref := Node.ReadAttributeString(sNodeHrefAttr);
- tmp := ReplaceStr(Node.ReadAttributeString(sNodeRelAttr), sSchemaHref, '');
- tmp := 'tw_' + ReplaceStr(tmp, '-', '_');
- FRel := TWebSiteType(GetEnumValue(TypeInfo(TWebSiteType), tmp));
- if Node.HasAttribute(sNodeLabelAttr) then
- FLabel := Node.ReadAttributeString(sNodeLabelAttr);
- if Node.HasAttribute(sNodePrimaryAttr) then
- FPrimary := Node.ReadAttributeBool(sNodePrimaryAttr);
- except
- ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
- end;
-end;
-
-function TcpWebsite.RelToString: string;
-begin
- case FRel of
- tw_None:
- Result := ''; // значение не определено
- tw_Home_Page:
- Result := LoadStr(c_WebsiteHomePage);
- tw_Blog:
- Result := LoadStr(c_WebsiteBlog);
- tw_Profile:
- Result := LoadStr(c_WebsiteProfile);
- tw_Home:
- Result := LoadStr(c_WebsiteHome);
- tw_Work:
- Result := LoadStr(c_WebsiteWork);
- tw_Other:
- Result := LoadStr(c_WebsiteOther);
- tw_Ftp:
- Result := LoadStr(c_WebsiteFtp);
- end;
-end;
-
-{ TContact }
-
-procedure TContact.Clear;
-begin
- FEtag := '';
- FId := '';
- FUpdated := 0;
- FTitle.Clear;
- FContent.Clear;
- FLinks.Clear;
- FName.Clear;
- FNickName.Clear;
- FBirthDay.Clear;
- FOrganization.Clear;
- FEmails.Clear;
- FPhones.Clear;
- FPostalAddreses.Clear;
- FEvents.Clear;
- FRelations.Clear;
- FUserFields.Clear;
- FWebSites.Clear;
- FGroupMemberships.Clear;
- FIMs.Clear;
-end;
-
-constructor TContact.Create(byNode: TXmlNode);
-begin
- inherited Create();
- FLinks := TList.Create;
- FEmails := TList.Create;
- FPhones := TList.Create;
- FPostalAddreses := TList.Create;
- FEvents := TList.Create;
- FRelations := TList.Create;
- FUserFields := TList.Create;
- FWebSites := TList.Create;
- FIMs := TList.Create;
- FGroupMemberships := TList.Create;
- FOrganization := TgdOrganization.Create();
- FTitle := TTextTag.Create();
- FContent := TTextTag.Create();
- FName := TgdName.Create();
- FNickName := TcpNickname.Create();
- FBirthDay := TcpBirthday.Create(nil);
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-destructor TContact.Destroy;
-begin
- FreeAndNil(FTitle);
- FreeAndNil(FContent);
- FreeAndNil(FLinks);
- FreeAndNil(FName);
- FreeAndNil(FNickName);
- FreeAndNil(FBirthDay);
- FreeAndNil(FOrganization);
- FreeAndNil(FEmails);
- FreeAndNil(FPhones);
- FreeAndNil(FPostalAddreses);
- FreeAndNil(FEvents);
- FreeAndNil(FRelations);
- FreeAndNil(FUserFields);
- FreeAndNil(FWebSites);
- FreeAndNil(FGroupMemberships);
- FreeAndNil(FIMs);
- inherited Destroy;
-end;
-
-function TContact.FindEmail(const aEmail: string; out Index: integer): TgdEmail;
-var
- I: integer;
-begin
- Result := nil;
- for I := 0 to FEmails.Count - 1 do
- begin
- if UpperCase(aEmail) = UpperCase(FEmails[I].Address) then
- begin
- Result := FEmails[I];
- Index := I;
- break;
- end;
- end;
-end;
-
-function TContact.GenerateText(TypeFile: TFileType): string;
-var
- Doc: TNativeXml;
- I: integer;
- Node: TXmlNode;
-begin
- try
- Node := nil;
- if IsEmpty then
- Exit;
- Doc := TNativeXml.Create;
- Doc.EncodingString := sDefoultEncoding;
- case TypeFile of
- tfAtom:
- begin
- Doc.CreateName(sAtomAlias + sEntryNodeName);
- Doc.Root.WriteAttributeString('xmlns:atom',
- 'http://www.w3.org/2005/Atom');
- Node := Doc.Root.NodeNew(sAtomAlias + 'category');
- end;
- tfXML:
- begin
- Doc.CreateName(sEntryNodeName);
- Doc.Root.WriteAttributeString('xmlns', 'http://www.w3.org/2005/Atom');
- Node := Doc.Root.NodeNew('category');
- end;
- end;
- Doc.Root.WriteAttributeString('xmlns:gd',
- 'http://schemas.google.com/g/2005');
- Doc.Root.WriteAttributeString('xmlns:gContact',
- 'http://schemas.google.com/contact/2008');
- Node.WriteAttributeString('scheme',
- 'http://schemas.google.com/g/2005#kind');
- Node.WriteAttributeString('term',
- 'http://schemas.google.com/contact/2008#contact');
-
- FTitle.AddToXML(Doc.Root);
-
- for I := 0 to FLinks.Count - 1 do
- FLinks[I].AddToXML(Doc.Root);
- for I := 0 to FEmails.Count - 1 do
- FEmails[I].AddToXML(Doc.Root);
- for I := 0 to FPhones.Count - 1 do
- FPhones[I].AddToXML(Doc.Root);
- for I := 0 to FPostalAddreses.Count - 1 do
- FPostalAddreses[I].AddToXML(Doc.Root);
- for I := 0 to FIMs.Count - 1 do
- FIMs[I].AddToXML(Doc.Root);
- // GContact
- for I := 0 to FEvents.Count - 1 do
- FEvents[I].AddToXML(Doc.Root);
- for I := 0 to FRelations.Count - 1 do
- FRelations[I].AddToXML(Doc.Root);
- for I := 0 to FUserFields.Count - 1 do
- FUserFields[I].AddToXML(Doc.Root);
- for I := 0 to FWebSites.Count - 1 do
- FWebSites[I].AddToXML(Doc.Root);
- for I := 0 to FGroupMemberships.Count - 1 do
- FGroupMemberships[I].AddToXML(Doc.Root);
-
- FContent.AddToXML(Doc.Root);
- FName.AddToXML(Doc.Root);
- FNickName.AddToXML(Doc.Root);
- FOrganization.AddToXML(Doc.Root);
- FBirthDay.AddToXML(Doc.Root);
- Result := string(Doc.Root.WriteToString);
- finally
- FreeAndNil(Doc)
- end;
-end;
-
-function TContact.GetContactName: string;
-begin
- Result := CpDefaultCName;
- if FTitle.IsEmpty then
- if PrimaryEmail <> '' then
- Result := PrimaryEmail
- else if not FNickName.IsEmpty then
- Result := FNickName.Value
- else
- Result := CpDefaultCName
- else
- Result := FTitle.Value
-end;
-
-function TContact.GetOrganization: TgdOrganization;
-begin
- Result := TgdOrganization.Create();
- if FOrganization <> nil then
- Result := FOrganization
- else
- begin
- Result.OrgName := TTextTag.Create();
- Result.OrgTitle := TTextTag.Create();
- end;
-end;
-
-function TContact.GetPrimaryEmail: string;
-var
- I: integer;
-begin
- Result := '';
- if FEmails = nil then
- Exit;
- if FEmails.Count = 0 then
- Exit;
- Result := FEmails[0].Address;
- for I := 0 to FEmails.Count - 1 do
- begin
- if FEmails[I].Primary then
- begin
- Result := FEmails[I].Address;
- break;
- end;
- end;
-end;
-
-function TContact.IsEmpty: boolean;
-begin
- Result := FTitle.IsEmpty and FContent.IsEmpty and FName.IsEmpty and FNickName.
- IsEmpty and FBirthDay.IsEmpty and FOrganization.IsEmpty and
- (FEmails.Count = 0) and (FPhones.Count = 0) and (FPostalAddreses.Count = 0)
- and (FEvents.Count = 0) and (FRelations.Count = 0) and
- (FUserFields.Count = 0) and (FWebSites.Count = 0) and
- (FGroupMemberships.Count = 0) and (FIMs.Count = 0);
-end;
-
-procedure TContact.LoadFromFile(const FileName: string);
-var
- XML: TNativeXml;
-begin
- try
- XML := TNativeXml.Create;
- XML.LoadFromFile(FileName);
- if (not XML.IsEmpty) and ((LowerCase(XML.Root.NameUnicode) = LowerCase
- (sAtomAlias + sEntryNodeName)) or (LowerCase(XML.Root.NameUnicode)
- = LowerCase(sEntryNodeName))) then
- ParseXML(XML.Root);
- finally
- FreeAndNil(XML)
- end;
-end;
-
-procedure TContact.ParseXML(Stream: TStream);
-var
- XMLDoc: TNativeXml;
-begin
- if Stream = nil then
- Exit;
- if Stream.Size = 0 then
- Exit;
- XMLDoc := TNativeXml.Create;
- try
- try
- XMLDoc.LoadFromStream(Stream);
- ParseXML(XMLDoc.Root);
- except
- Exit;
- end;
- finally
- FreeAndNil(XMLDoc)
- end;
-end;
-
-procedure TContact.ParseXML(Node: TXmlNode);
-var
- I: integer;
- List: TXmlNodeList;
-begin
- try
- if Node = nil then Exit;
- FEtag := Node.ReadAttributeString(gdNodeAlias + 'etag');
- List := TXmlNodeList.Create;
-// Node.NodesByName('id', List);
-// for I := 0 to List.Count - 1 do {!!!!!!!!!!}
-// FId :=List.Items[I].ValueAsUnicodeString;
-
- FId := Node.NodeByName('id').ValueAsUnicodeString;
-
- Node.NodesByName(GetGDNodeName(gd_Email), List);
- for I := 0 to List.Count - 1 do
- FEmails.Add(TgdEmail.Create(List.Items[I]));
-
- Node.NodesByName(GetGDNodeName(gd_PhoneNumber), List);
- for I := 0 to List.Count - 1 do
- FPhones.Add(TgdPhoneNumber.Create(List.Items[I]));
-
- Node.NodesByName(GetGDNodeName(gd_Im), List);
- for I := 0 to List.Count - 1 do
- FIMs.Add(TgdIm.Create(List.Items[I]));
-
- Node.NodesByName(GetGDNodeName(gd_StructuredPostalAddress), List);
- for I := 0 to List.Count - 1 do
- FPostalAddreses.Add(TgdStructuredPostalAddress.Create(List.Items[I]));
-
- Node.NodesByName(GetContactNodeName(cp_event), List);
- for I := 0 to List.Count - 1 do
- FEvents.Add(TcpEvent.Create(List.Items[I]));
-
- Node.NodesByName(GetContactNodeName(cp_relation), List);
- for I := 0 to List.Count - 1 do
- FRelations.Add(TcpRelation.Create(List.Items[I]));
-
- Node.NodesByName(GetContactNodeName(cp_userDefinedField), List);
- for I := 0 to List.Count - 1 do
- FUserFields.Add(TcpUserDefinedField.Create(List.Items[I]));
-
- Node.NodesByName(GetContactNodeName(cp_website), List);
- for I := 0 to List.Count - 1 do
- FWebSites.Add(TcpWebsite.Create(List.Items[I]));
-
- Node.NodesByName(GetContactNodeName(cp_groupMembershipInfo), List);
- for I := 0 to List.Count - 1 do
- FGroupMemberships.Add(TcpGroupMembershipInfo.Create(List.Items[I]));
-
- Node.NodesByName('link', List);
- for I := 0 to List.Count - 1 do
- FLinks.Add(TEntryLink.Create(List.Items[I]));
-
- for I := 0 to Node.NodeCount - 1 do
- begin
- // CpAtomAlias
- if (LowerCase(Node.Nodes[I].NameUnicode) = 'updated') or
- (LowerCase(Node.Nodes[I].NameUnicode) = LowerCase
- (sAtomAlias + 'updated')) then
- FUpdated := ServerDateToDateTime(Node.Nodes[I].ValueAsUnicodeString)
- else if (LowerCase(Node.Nodes[I].NameUnicode) = 'title') or
- (LowerCase(Node.Nodes[I].NameUnicode) = LowerCase(sAtomAlias + 'title')
- ) then
- FTitle := TTextTag.Create(Node.Nodes[I])
- else if (LowerCase(Node.Nodes[I].NameUnicode) = 'content') or
- (LowerCase(Node.Nodes[I].NameUnicode) = LowerCase
- (sAtomAlias + 'content')) then
- FContent := TTextTag.Create(Node.Nodes[I])
- else if LowerCase(Node.Nodes[I].NameUnicode) = LowerCase
- (GetGDNodeName(gd_Name)) then
- FName := TgdName.Create(Node.Nodes[I])
- else if LowerCase(Node.Nodes[I].NameUnicode) = LowerCase
- (GetGDNodeName(gd_Organization)) then
- FOrganization := TgdOrganization.Create(Node.Nodes[I])
- else if LowerCase(Node.Nodes[I].NameUnicode) = LowerCase
- (GetContactNodeName(cp_birthday)) then
- FBirthDay := TcpBirthday.Create(Node.Nodes[I])
- else if LowerCase(Node.Nodes[I].NameUnicode) = LowerCase
- (GetContactNodeName(cp_nickname)) then
- FNickName := TagNickName.Create(Node.Nodes[I]);
- end;
- finally
- FreeAndNil(List)
- end;
-end;
-
-procedure TContact.SaveToFile(const FileName: string; FileType: TFileType);
-begin
- TFile.WriteAllText(FileName, GenerateText(FileType));
-end;
-
-procedure TContact.SetPrimaryEmail(aEmail: string);
-var
- index, I: integer;
- NewEmail: TgdEmail;
-begin
- if FindEmail(aEmail, index) = nil then
- begin
- NewEmail := TgdEmail.Create();
- NewEmail.Address := aEmail;
- NewEmail.Primary := true;
- NewEmail.Rel := em_other;
- FEmails.Add(NewEmail);
- end;
- for I := 0 to FEmails.Count - 1 do
- FEmails[I].Primary := (I = index);
-end;
-
-{ TContactGroup }
-
-
-constructor TContactGroup.Create(const byNode: TXmlNode);
-begin
- inherited Create;
- FLinks := TList.Create;
- FExtendedProps:=TgdExtendedProperty.Create();
- FSystemGroup:=TcpSystemGroup.Create();
- FSystemGroup.ID:=tg_None;
- if byNode <> nil then
- ParseXML(byNode);
-end;
-
-function TContactGroup.GenerateXML(const WintExtended: boolean): TNativeXml;
-var Node,IdNode:TXmlNode;
-begin
- Result:=TNativeXml.Create;
- Result.CreateName(sEntryNodeName);
- Result.Root.WriteAttributeString('xmlns:gd','http://schemas.google.com/g/2005');
- Result.Root.WriteAttributeString('xmlns','http://www.w3.org/2005/Atom');
- Result.Root.WriteAttributeString(gdNodeAlias+'etag',FEtag);
- Node:=Result.Root.NodeNew('category');
- Node.WriteAttributeString('scheme','http://schemas.google.com/g/2005#kind');
- Node.WriteAttributeString('term','http://schemas.google.com/g/2005#group');
- IdNode:=Result.Root.NodeNew('id');
- idNode.ValueAsUnicodeString:=Fid;
- FTitle.AddToXML(Result.Root);
- FContent.AddToXML(Result.Root);
- if WintExtended then
- FExtendedProps.AddToXML(Result.Root);
-end;
-
-function TContactGroup.GetContent: string;
-begin
- Result := FContent.Value;
-end;
-
-function TContactGroup.GetSysGroupId: TcpSysGroupId;
-begin
- Result := FSystemGroup.ID;
-end;
-
-function TContactGroup.GetTitle: string;
-begin
- Result := FTitle.Value;
-end;
-
-procedure TContactGroup.ParseXML(Node: TXmlNode);
-var
- I: integer;
-begin
- if Node = nil then
- Exit;
- FEtag := Node.ReadAttributeString(gdNodeAlias + 'etag');
- for I := 0 to Node.NodeCount - 1 do
- begin
- if Node.Nodes[I].NameUnicode = 'id' then
- FId := Node.Nodes[I].ValueAsUnicodeString
- else if Node.Nodes[I].NameUnicode = 'updated' then
- FUpdate := ServerDateToDateTime(Node.Nodes[I].ValueAsUnicodeString)
- else if Node.Nodes[I].NameUnicode = 'title' then
- FTitle := TTextTag.Create(Node.Nodes[I])
- else if Node.Nodes[I].NameUnicode = 'content' then
- FContent := TTextTag.Create(Node.Nodes[I])
- else if Node.Nodes[I].NameUnicode = GetContactNodeName(cp_systemGroup) then
- FSystemGroup := TcpSystemGroup.Create(Node.Nodes[I])
- else if Node.Nodes[I].NameUnicode = 'link' then
- FLinks.Add(TEntryLink.Create(Node.Nodes[I]))
- else if Node.Nodes[i].NameUnicode=GetGDNodeName(gd_extendedProperty)then
- FExtendedProps:=TgdExtendedProperty.Create(Node.Nodes[i]);
- end;
-end;
-
-procedure TContactGroup.SetContent(const aContent: string);
-begin
- FContent.Value := aContent
-end;
-
-procedure TContactGroup.SetSysGroupId(aSysGroupId: TcpSysGroupId);
-begin
- FSystemGroup.ID := aSysGroupId;
-end;
-
-procedure TContactGroup.SetTitle(const aTitle: string);
-begin
- FTitle.Value := aTitle;
-end;
-
-{ TGoogleContact }
-
-function TGoogleContact.AddContact(aContact: TContact): boolean;
-var
- XML: TNativeXml;
-begin
- Result := false;
- if (aContact = nil) Or aContact.IsEmpty then
- Exit;
- try
- XML := TNativeXml.Create;
- XML.ReadFromString(UTF8String(aContact.ToXMLText[tfAtom]));
- with THTTPSender.Create('POST', FAuth, CpContactsLink, CpProtocolVer) do
- begin
- XML.SaveToStream(Document);
- if SendRequest then
- begin
- Result := (ResultCode = 201);
- if Result then
- begin
- XML.Clear;
- XML.LoadFromStream(Document);
- FContacts.Add(TContact.Create(XML.Root))
- end;
- end
- else
- begin
- { TODO -oVlad -cbugs : Корректно обработать исключение }
- ShowMessage(IntToStr(ResultCode) + ' ' + ResultString)
- end;
- end;
- finally
- FreeAndNil(XML)
- end;
-end;
-
-function TGoogleContact.DeleteContact(index: integer): boolean;
-begin
- try
- Result := false;
- if (Index < 0) or (Index >= FContacts.Count) then
- Exit;
- Result := DeleteContact(FContacts[index]);
- except
- Result := false;
- end;
-end;
-
-function TGoogleContact.AddContactGroup(const aName, aDescription: string)
- : boolean;
-var
- XMLDoc: TNativeXml;
- Node: TXmlNode;
- Ext: TgdExtendedProperty;
- List: TStringList;
-begin
-Result:=false;
-List:=TStringList.Create;
-try
- Ext:=TgdExtendedProperty.Create();
- Ext.Name:=aDescription;
- Ext.ChildNodes.Add(TTextTag.Create('info',aDescription));
- XMLDoc := TNativeXml.Create;
- XMLDoc.CreateName(sAtomAlias + sEntryNodeName);
- XMLDoc.Root.WriteAttributeString('xmlns:gd','http://schemas.google.com/g/2005');
- XMLDoc.Root.WriteAttributeString('xmlns:atom','http://www.w3.org/2005/Atom');
- Node := XMLDoc.Root.NodeNew(sAtomAlias + 'category');
- Node.WriteAttributeString('scheme', 'http://schemas.google.com/g/2005#kind');
- Node.WriteAttributeString('term', 'http://schemas.google.com/contact/2008#group');
- Node:=XMLDoc.Root.NodeNew(sAtomAlias + 'title');
- Node.ValueAsUnicodeString:=aName;
- Ext.AddToXML(XMLDoc.Root);
-
- with THTTPSender.Create('POST',FAuth,Format(CpGroupLink,[FEmail]),CpProtocolVer)do
- begin
- XMLDoc.SaveToStream(Document);
- if SendRequest then
- begin
- Result:=ResultCode=201;
- if Result then
- begin
- XMLDoc.Clear;
- XMLDoc.LoadFromStream(Document);
- // если событие определено - отправляем данные
- if Assigned(FOnBeginParse) then
- OnBeginParse(T_Group, FGroups.Count+1,FGroups.Count + 1);
- // парсим группу
- FGroups.Add(TContactGroup.Create(XMLDoc.Root));
- // если событие определено - отправляем данные
- if Assigned(FOnEndParse) then
- OnEndParse(T_Group, FGroups.Last);
- end
- else
- begin
- List.LoadFromStream(Document);
- ShowMessage(List.Text);
- end;
- end
- else
- ShowMessage(IntToStr(ResultCode)+' '+ResultString);
- end;
-finally
- FreeAndNil(Ext);
- FReeAndNil(XMLDoc);
- FreeAndNil(List);
-end;
-end;
-
-constructor TGoogleContact.Create(AOwner: TComponent);
-begin
- inherited Create(AOwner);
- FMaximumResults := -1;
- FStartIndex := 1;
- FUpdatesMin := 0;
- FShowDeleted := false;
- FSortOrder := Ts_None;
- FGroups := TList.Create;
- FContacts := TList.Create;
-end;
-
-function TGoogleContact.DeleteContact(aContact: TContact): boolean;
-var
- I, j: integer;
-begin
- try
- Result := false;
- if aContact = nil then
- Exit;
-
- if Length(aContact.Etag) > 0 then
- begin
- for I := 0 to aContact.FLinks.Count - 1 do
- begin
- if LowerCase(aContact.FLinks[I].Rel) = 'edit' then
- begin
- with THTTPSender.Create('DELETE', FAuth, aContact.FLinks[I].Href,
- CpProtocolVer) do
- begin
- MimeType := 'application/atom+xml';
- ExtendedHeaders.Add('If-Match: ' + aContact.Etag);
- if SendRequest then
- begin
- if ResultCode = 200 then
- begin
- for j := 0 to FContacts.Count - 1 do
- if FContacts[I] = aContact then
- begin
- FContacts.DeleteRange(I, 1);
- // удаляем свободный элемент из списка
- break;
- end;
- aContact.Destroy; // удалили из памяти
- Result := true;
- end;
- end
- else
- begin
- { TODO -oVlad -cbugs : Корректно обработать исключение }
- ShowMessage(IntToStr(ResultCode) + ' ' + ResultString)
- end;
- end;
- break;
- end;
- end;
- end;
- except
- Result := false;
- end;
-end;
-
-function TGoogleContact.DeleteContactGroup(const Index: integer): boolean;
-begin
- Result:=false;
- if (Index>=0)and(Index= FContacts.Count) or (index < 0) then
- Exit;
- Result := DeletePhoto(FContacts[index])
-end;
-
-function TGoogleContact.DeletePhoto(aContact: TContact): boolean;
-var
- I: integer;
-begin
- Result := false;
- if aContact = nil then
- Exit;
- for I := 0 to aContact.FLinks.Count - 1 do
- begin
- if (LowerCase(aContact.FLinks[I].Ltype) = sImgRel) and
- (Length(aContact.FLinks[I].Etag) > 0) then
- begin
- with THTTPSender.Create('DELETE', FAuth, aContact.FLinks[I].Href,
- CpProtocolVer) do
- begin
- MimeType := sImgRel;
- ExtendedHeaders.Add('If-Match: *');
- if SendRequest then
- begin
- Result := ResultCode = 200;
- if Result then
- aContact.FLinks[I].Etag := '';
- end
- else
- ShowMessage(IntToStr(ResultCode) + ' ' + ResultString)
- end;
- break;
- end;
- end;
-end;
-
-destructor TGoogleContact.Destroy;
-var
- c: TContact;
- g: TContactGroup;
-begin
- for g in FGroups do
- g.Destroy;
- for c in FContacts do
- c.Destroy;
- FContacts.Free;
- FGroups.Free;
- inherited Destroy;
-end;
-
-function TGoogleContact.GetContact(GroupName: string; Index: integer): TContact;
-var
- List: TList;
-begin
- Result := nil;
- try
- List := TList.Create;
- List := GetContactsByGroup(GroupName);
- if (Index > List.Count) or (Index < 0) then
- Exit;
- Result := TContact.Create();
- Result := List[index];
- finally
- FreeAndNil(List);
- end;
-end;
-
-function TGoogleContact.GetContactNames: TStrings;
-var
- I: integer;
-begin
- Result := TStringList.Create;
- for I := 0 to FContacts.Count - 1 do
- Result.Add(FContacts[I].GetContactName);
-end;
-
-function TGoogleContact.GetContactsByGroup(GroupName: string): TList;
-var
- I, j: integer;
- GrupLink: string;
-begin
- Result := TList.Create;
- GrupLink := GroupLink(GroupName);
- if GrupLink <> '' then
- begin
- for I := 0 to FContacts.Count - 1 do
- for j := 0 to FContacts[I].FGroupMemberships.Count - 1 do
- begin
- if FContacts[I].FGroupMemberships[j].FHref = GrupLink then
- Result.Add(FContacts[I])
- end;
- end;
-end;
-
-function TGoogleContact.GetEditLink(aContact: TContact): string;
-var
- I: integer;
-begin
- Result := '';
- for I := 0 to aContact.FLinks.Count - 1 do
- if aContact.FLinks[I].Rel = 'edit' then
- begin
- Result := aContact.FLinks[I].Href;
- break;
- end;
-end;
-
-function TGoogleContact.GetGropsNames: TStrings;
-var
- I: integer;
-begin
- Result := TStringList.Create;
- for I := 0 to FGroups.Count - 1 do
- Result.Add(FGroups[I].GetTitle);
-end;
-
-function TGoogleContact.GetNextLink(aXMLDoc: TNativeXml): string;
-var
- I: integer;
- List: TXmlNodeList;
-begin
- try
- if aXMLDoc = nil then
- Exit;
- Result := '';
- List := TXmlNodeList.Create;
- aXMLDoc.Root.NodesByName('link', List);
- for I := 0 to List.Count - 1 do
- begin
- if List.Items[I].ReadAttributeString(sNodeRelAttr) = 'next' then
- begin
- Result := String(List.Items[I].ReadAttributeString(sNodeHrefAttr));
- break;
- end;
- end;
- finally
- FreeAndNil(List);
- end;
-end;
-
-function TGoogleContact.GetTotalCount(aXMLDoc: TNativeXml): integer;
-var Node: TXmlNode;
-begin
-Result := -1;
- try
- if aXMLDoc = nil then Exit;
- // ищем вот такой узел ЧИСЛО
- Node:=aXMLDoc.Root.NodeByName('openSearch:totalResults');
- if Node<>nil then
- Result := Node.ValueAsInteger
- except
- {обработать исключение}
- end;
-end;
-
-function TGoogleContact.GetNextLink(Stream: TStream): string;
-var
- I: integer;
- List: TXmlNodeList;
- XML: TNativeXml;
-begin
- try
- if Stream = nil then
- Exit;
- XML := TNativeXml.Create;
- XML.LoadFromStream(Stream);
- Result := '';
- List := TXmlNodeList.Create;
- XML.Root.NodesByName('link', List);
- for I := 0 to List.Count - 1 do
- begin
- if List.Items[I].ReadAttributeString(sNodeRelAttr) = 'next' then
- begin
- Result := string(List.Items[I].ReadAttributeString(sNodeHrefAttr));
- break;
- end;
- end;
- finally
- FreeAndNil(List);
- FreeAndNil(XML);
- end;
-end;
-
-function TGoogleContact.GroupLink(const aGroupName: string): string;
-var
- I: integer;
-begin
- Result := '';
- for I := 0 to FGroups.Count - 1 do
- begin
- if UpperCase(aGroupName) = UpperCase(FGroups[I].Title) then
- begin
- Result := FGroups[I].FId;
- break
- end;
- end;
-end;
-
-function TGoogleContact.InsertPhotoEtag(aContact: TContact;
- const Response: TStream): boolean;
-var
- XML: TNativeXml;
- I: integer;
- Etag: string;
-begin
- Result := false;
- try
- if Response = nil then
- Exit;
- XML := TNativeXml.Create;
- try
- XML.LoadFromStream(Response);
- except
- Exit;
- end;
- Etag := XML.Root.ReadAttributeString(gdNodeAlias + 'etag');
- for I := 0 to aContact.FLinks.Count - 1 do
- begin
- if aContact.FLinks[I].Ltype = sImgRel then
- begin
- aContact.FLinks[I].Etag := Etag;
- Result := true;
- break;
- end;
- end;
- finally
- FreeAndNil(XML)
- end;
-end;
-
-procedure TGoogleContact.LoadContactsFromFile(const FileName: string);
-var
- XML: TStringStream;
-begin
- try
- XML := TStringStream.Create('', TEncoding.UTF8);
- XML.LoadFromFile(FileName);
- ParseXMLContacts(XML);
- finally
- FreeAndNil(XML)
- end;
-end;
-
-function TGoogleContact.ParamsToStr: TStringList;
-var
- S: string;
-begin
- Result := TStringList.Create;
- Result.Delimiter := '&';
- if FMaximumResults > 0 then
- Result.Add('max-results=' + IntToStr(FMaximumResults));
- if FStartIndex > 1 then
- Result.Add('start-index=' + IntToStr(FStartIndex));
- if ShowDeleted then
- Result.Add('showdeleted=true');
- if FUpdatesMin > 0 then
- Result.Add('updated-min=' + DateTimeToServerDate(FUpdatesMin));
- if FSortOrder <> Ts_None then
- begin
- S := GetEnumName(TypeInfo(TSortOrder), ord(FSortOrder));
- Delete(S, 1, 3);
- Result.Add('sortorder=' + S);
- end;
-
-end;
-
-procedure TGoogleContact.ParseXMLContacts(const Data: TStream);
-var
- XMLDoc: TNativeXml;
- List: TXmlNodeList;
- I: integer;
-begin
- try
- if (Data = nil) then
- Exit;
- XMLDoc := TNativeXml.Create;
- XMLDoc.LoadFromStream(Data);
- List := TXmlNodeList.Create;
- XMLDoc.Root.NodesByName(sEntryNodeName, List);
- for I := 0 to List.Count - 1 do
- begin
- // Если событие определено - отправляем данные
- if Assigned(FOnBeginParse) then
- OnBeginParse(T_Contact, GetTotalCount(XMLDoc), FContacts.Count + 1);
- // парсим элемент контакта
- FContacts.Add(TContact.Create(List.Items[I]));
- // Если событие определено - отправляем данные. В Element кладем TContact
- if Assigned(FOnEndParse) then
- OnEndParse(T_Contact, FContacts.Last)
- end;
- finally
- FreeAndNil(List);
- FreeAndNil(XMLDoc);
- end;
-end;
-
-function TGoogleContact.RetriveContactPhoto(index: integer): TJPEGImage;
-begin
- Result := nil;
- if (index >= FContacts.Count) or (index < 0) then
- Exit;
- Result := RetriveContactPhoto(FContacts[index])
-end;
-
-procedure TGoogleContact.ReadData(Sender: TObject; Reason: THookSocketReason;
- const Value: String);
-begin
- if Reason = HR_ReadCount then
- begin
- FBytesCount := FBytesCount + StrToInt(Value);
- if Assigned(FOnReadData) then
- FOnReadData(FTotalBytes, FBytesCount)
- end;
-end;
-
-function TGoogleContact.RetriveContactPhoto(aContact: TContact): TJPEGImage;
-var
- I: integer;
-begin
- Result := nil;
- if aContact = nil then
- Exit;
- for I := 0 to aContact.FLinks.Count - 1 do
- begin
- if (aContact.FLinks[I].Rel = CpPhotoLink) and
- (Length(aContact.FLinks[I].Etag) > 0) then
- begin
- FTotalBytes := 0;
- FBytesCount := 0;
- with THTTPSender.Create('GET', FAuth, aContact.FLinks[I].Href,
- CpProtocolVer) do
- begin
- Sock.OnStatus := ReadData; // ставим хук на соккет
- FTotalBytes := GetLength(aContact.FLinks[I].Href);
- // получаем размер документа
- if Assigned(FOnRetriveXML) then
- FOnRetriveXML(aContact.FLinks[I].Href);
- MimeType := sDefoultMimeType;
- if SendRequest and (FTotalBytes > 0) then
- begin
- Result := TJPEGImage.Create;
- Result.LoadFromStream(Document);
- end
- else
- begin
- { TODO -oVlad -cbugs : Корректно обработать исключение }
- end;
- break;
- end;
- end;
- end;
-end;
-
-function TGoogleContact.RetriveContactPhoto(aContact: TContact;
- DefaultImage: TFileName): TJPEGImage;
-var
- Img: TJPEGImage;
-begin
- try
- Result := nil;
- if aContact = nil then
- Exit;
- if Length(Trim(DefaultImage)) = 0 then
- raise ECPException.Create(sc_ErrFileNull);
- if not FileExists(DefaultImage) then
- raise ECPException.CreateFmt(sc_ErrFileName, [DefaultImage]);
- Img := TJPEGImage.Create;
- Result := TJPEGImage.Create;
- Img := RetriveContactPhoto(aContact);
- if Img = nil then
- Result.LoadFromFile(DefaultImage)
- else
- Result.Assign(Img);
- finally
- FreeAndNil(Img)
- end;
-end;
-
-function TGoogleContact.RetriveContacts: integer;
-var
- XMLDoc: TStringStream;
- NextLink: string;
- Params: TStringList;
-begin
- try
- NextLink := CpContactsLink;
- Params := TStringList.Create;
- Params.Assign(ParamsToStr);
- if Params.Count > 0 then
- NextLink := NextLink + '?' + Params.DelimitedText;
-
- XMLDoc := TStringStream.Create('', TEncoding.UTF8);
- repeat
- FTotalBytes := 0;
- FBytesCount := 0;
-
- with THTTPSender.Create('GET', FAuth, NextLink, CpProtocolVer) do
- begin
- Sock.OnStatus := ReadData; // ставим хук на соккет
- FTotalBytes := GetLength(NextLink); // получаем размер документа
- // сигналим о начале загрузки
- if Assigned(FOnRetriveXML) then
- OnRetriveXML(NextLink);
- if SendRequest then
- begin
- XMLDoc.LoadFromStream(Document);
- ParseXMLContacts(XMLDoc);
- NextLink := GetNextLink(XMLDoc);
- end
- else
- begin
- { TODO -oVlad -cbugs : Корректно обработать исключение }
- break;
- end;
- end;
- until NextLink = '';
- Result := FContacts.Count;
- finally
- FreeAndNil(XMLDoc);
- end;
-
-end;
-
-function TGoogleContact.RetriveGroups: integer;
-var
- XMLDoc: TNativeXml;
- List: TXmlNodeList;
- I, Count: integer;
- NextLink: string;
-begin
- try
- FGroups.Clear;
- NextLink := Format(CpGroupLink, [FEmail]);
- XMLDoc := TNativeXml.Create;
- repeat
- FTotalBytes := 0;
- FBytesCount := 0;
- with THTTPSender.Create('GET', FAuth, NextLink, CpProtocolVer) do
- begin
- Sock.OnStatus := ReadData; // ставим хук на соккет
- FTotalBytes := GetLength(NextLink); // получаем размер документа
- // отправляем сообщение о начале загрузки
- if Assigned(FOnRetriveXML) then
- FOnRetriveXML(NextLink);
- if SendRequest then
- begin
- XMLDoc.LoadFromStream(Document);
- List := TXmlNodeList.Create;
- XMLDoc.Root.NodesByName(sEntryNodeName, List);
- Count := GetTotalCount(XMLDoc);
- if Count=-1 then
- raise ECPException.CreateFromStream(Document);
- for I := 0 to List.Count - 1 do
- begin
- // если событие определено - отправляем данные
- if Assigned(FOnBeginParse) then
- FOnBeginParse(T_Group, Count, FGroups.Count + 1);
- // парсим группу
- FGroups.Add(TContactGroup.Create(List.Items[I]));
- // если событие определено - отправляем данные
- if Assigned(FOnEndParse) then
- FOnEndParse(T_Group, FGroups.Last);
- end;
- NextLink := GetNextLink(XMLDoc);
- end
- else
- break; { TODO -oVlad -cbugs : Корректно обработать исключение }
- end;
- until NextLink = '';
- Result := FGroups.Count;
- finally
- FreeAndNil(XMLDoc);
- end;
-
-end;
-
-procedure TGoogleContact.SaveContactsToFile(const FileName: string);
-var
- I: integer;
- Stream: TStringStream;
-begin
- try
- Stream := TStringStream.Create('', TEncoding.UTF8);
- Stream.WriteString('');
- Stream.WriteString('');
- for I := 0 to Contacts.Count - 1 do
- Stream.WriteString(Contacts[I].ToXMLText[tfXML]);
- Stream.WriteString('');
- Stream.SaveToFile(FileName);
- finally
- FreeAndNil(Stream)
- end;
-end;
-
-procedure TGoogleContact.SetAuth(const aAuth: string);
-begin
- FAuth := aAuth;
-end;
-
-procedure TGoogleContact.SetGmail(const aGMail: string);
-begin
- FEmail := aGMail;
-end;
-
-procedure TGoogleContact.SetMaximumResults(const Value: integer);
-begin
- FMaximumResults := Value;
-end;
-
-procedure TGoogleContact.SetShowDeleted(const Value: boolean);
-begin
- FShowDeleted := Value;
-end;
-
-procedure TGoogleContact.SetSortOrder(const Value: TSortOrder);
-begin
- FSortOrder := Value;
-end;
-
-procedure TGoogleContact.SetStartIndex(const Value: integer);
-begin
- FStartIndex := Value;
-end;
-
-procedure TGoogleContact.SetUpdatesMin(const Value: TDateTime);
-begin
- FUpdatesMin := Value;
-end;
-
-function TGoogleContact.UpdateContact(index: integer): boolean;
-begin
- Result := false;
- if (Index > FContacts.Count) Or (FContacts[index].IsEmpty) or (Index < 0) then
- Exit;
- UpdateContact(FContacts[index]);
- Result := true;
-end;
-
-function TGoogleContact.UpdateContactGroup(const Index: integer): boolean;
-begin
-Result:=false;
- if (Index>=0)and(Index= FContacts.Count) or (index < 0) then
- Exit;
- Result := UpdatePhoto(FContacts[index], PhotoFile);
-end;
-
-function TGoogleContact.UpdateContact(aContact: TContact): boolean;
-var
- Doc: TNativeXml;
-begin
- Result := false;
- if (aContact = nil) Or aContact.IsEmpty then
- Exit;
- if (Length(aContact.Etag) = 0) then
- Exit;
- try
- Doc := TNativeXml.Create;
- Doc.ReadFromString(UTF8String(aContact.ToXMLText[tfXML]));
- with THTTPSender.Create('PUT', FAuth, GetEditLink(aContact), CpProtocolVer)
- do
- begin
- ExtendedHeaders.Add('If-Match: *');
- Doc.SaveToStream(Document);
- if SendRequest then
- begin
- Result := ResultCode = 200;
- if Result then
- begin
- aContact.Clear;
- aContact.ParseXML(Document);
- end;
- end
- else
- ShowMessage(IntToStr(ResultCode) + ' ' + ResultString)
- end;
- finally
- FreeAndNil(Doc)
- end;
-end;
-
-function TGoogleContact.RetriveContactPhoto(index: integer;
- DefaultImage: TFileName): TJPEGImage;
-begin
- Result := nil;
- if (index >= FContacts.Count) or (index < 0) then
- Exit;
- Result := TJPEGImage.Create;
- Result.Assign(RetriveContactPhoto(index, DefaultImage));
-end;
-
-{ ECPECPException }
-
-constructor ECPException.CreateFromStream(const Document: TStream);
-var Lst: TStringList;
- Err: string;
-begin
- Document.Position:=0;
- Lst:=TStringList.Create;
- Lst.LoadFromStream(Document);
- if Pos('html',LowerCase(Lst.Text))>0 then
- begin
- Err:=Lst[2];
- Err:=StringReplace(Err,'','',[rfIgnoreCase]);
- Err:=StringReplace(Err,'','',[rfIgnoreCase]);
- end
- else
- Err:=Lst.Text;
- inherited Create(Err);
-end;
-
-end.
+{ unit GContacts
+
+ Модуль содержит классы и методы для работы с Google Contacts API.
+
+ Вы можете использовать этот модуль для получения чтения и редактирования своих
+ контактов в GMail.
+
+ Основной компонент для работы с контаками - TGoogleContact.
+
+ Автор: Vlad. (vlad383@gmail.com)
+ Дата: 16 Июля 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.
+
+ Последние обновления модуля можно найти в репозитории по адресу:
+ http://github.com/googleapi
+}
+
+unit GContacts;
+
+interface
+
+uses
+ NativeXML, strUtils, httpsend, Classes, SysUtils,
+ GDataCommon, Generics.Collections, Dialogs, jpeg, Graphics, typinfo,
+ IOUtils, uLanguage, blcksock, Windows, GConsts;
+
+const
+ cpGContactsVersion = '0.1';
+
+
+type
+ ECPException = class(Exception)
+ public
+ constructor CreateFromStream(const Document: TStream);
+end;
+
+type
+ {Элемент парсинга}
+ TParseElement = (T_Group {группа контактов},
+ T_Contact {группа контактов});
+ {Событие TOnRetriveXML возникает каждый раз, когда компонент или класс
+ обращается на сервер для получения XML-документа.
+ FromURL содержит URL на который отправляется GET-запрос}
+ TOnRetriveXML = procedure(const FromURL: string {URL на который отправляется HTTP-запрос для получения документа}) of object;
+ {Событие TOnBeginParse возникает каждый раз, когда компонент или класс
+ готов начать парсинг элемента в XML-документе.
+ Общее количество однотипных элементов определяется по значению узла
+ openSearch:totalResults в первом возвращенном с сервера документе.}
+ TOnBeginParse = procedure(const What: TParseElement{элемент парсинга (группа или контакт) см. TParseElement};
+ Total:integer{общее количество элементов доступных для парсинга};
+ Number: integer{текущий номер элементапарсинга})
+ of object;
+ {Событие TOnEndParse возникает каждый раз, когда компонент или класс
+ заканчивает парсинг элемента в XML-документе.}
+ TOnEndParse = procedure(const What: TParseElement;{элемент парсинга (группа или контакт) см. TParseElement}
+ Element: TObject{элемент, полученный в результате парсинга.
+ Если был проведен парсинг группы, то Element имеет тип TContactGroup,
+ если контакта, то - TContact})
+ of object;
+ {Событие TOnReadData возникает каждый раз, когда компонент или класс
+ считывает данные из Сети.
+ TotalBytes содержит информацию по размеру получаемого документа, включая размер
+ всех заголовков, возвращаемых сервером}
+ TOnReadData = procedure(const TotalBytes:int64 {содержит значение объема данных, который должен быть получен, байт};
+ ReadBytes: int64 {содержит количество байт информации полученных из Сети на текущий момент}) of object;
+
+
+{Перечислитель, содержащий все типы узлов, относящихся к Google Contacts API
+ и обрабатываемых с помощью классов модуля}
+type
+ TcpTagEnum = (cp_billingInformation {тип узла gContact:billingInformation},
+ cp_birthday {тип узла gContact:birthday},
+ cp_calendarLink {тип узла gContact:calendarLink},
+ cp_directoryServer {тип узла gContact:directoryServer},
+ cp_event {тип узла gContact:event},
+ cp_externalId {тип узла gContact:externalId},
+ cp_gender {тип узла gContact:gender},
+ cp_groupMembershipInfo {тип узла gContact:groupMembershipInfo},
+ cp_hobby {тип узла gContact:hobby},
+ cp_initials {тип узла gContact:initials},
+ cp_jot {тип узла gContact:jot},
+ cp_language {тип узла gContact:language},
+ cp_maidenName {тип узла gContact:maidenName},
+ cp_mileage {тип узла gContact:mileage},
+ cp_nickname {тип узла gContact:nickname},
+ cp_occupation {тип узла gContact:occupation},
+ cp_priority {тип узла gContact:priority},
+ cp_relation {тип узла gContact:relation},
+ cp_sensitivity {тип узла gContact:sensitivity},
+ cp_shortName {тип узла gContact:shortName},
+ cp_subject {тип узла gContact:subject},
+ cp_userDefinedField {тип узла gContact:userDefinedField},
+ cp_website {тип узла gContact:website},
+ cp_systemGroup {тип узла gContact:systemGroup},
+ cp_None {используется в случае, если тип узла не определен});
+
+type
+ {Класс, описывающий узел gContact:billingInformation.
+ Этот узел используется для описания платежной информации контакта.
+ Элемент gContact:billingInformation не может быть повторен в рамках
+ описания одного контакта.
+ Вся информация содержится в текстовой части узла.
+ Узел gContact:billingInformation может отсутствовать в XML-документе}
+ TcpBillingInformation = class(TTextTag);
+
+ {Класс, описывающий узел gContact:directoryServer.
+ Этот узел используется для указания сервера катологов, связанного с контактом.
+ Элемент gContact:directoryServer может быть повторен в рамках описания
+ одного контакта.
+ Вся информация содержится в текстовой части узла.
+ Узел gContact:directoryServer может отсутствовать в XML-документе}
+ TcpDirectoryServer = class(TTextTag);
+
+ {Класс, описывающий узел gContact:hobby.
+ Этот узел используется для указания хобби контакта.
+ Элемент gContact:hobby может быть повторен в рамках описания
+ одного контакта.
+ Вся информация о хобби содержится в текстовой части узла.
+ Узел gContact:hobby может отсутствовать в XML-документе}
+ TcpHobby = class(TTextTag);
+
+ {Класс, описывающий узел gContact:initials.
+ Этот узел используется для указания инициалов контакта.
+ Элемент gContact:initials не может быть повторен в рамках описания
+ одного контакта.
+ Вся информация об инициалах содержится в текстовой части узла.
+ Узел gContact:initials может отсутствовать в XML-документе}
+ TcpInitials = class(TTextTag);
+
+ {Класс, описывающий узел gContact:shortName.
+ Этот узел используется для указания сокращенного имени контакта (например,
+ для имени Владислав коротким является - Влад).
+ Элемент gContact:shortName не может быть повторен в рамках описания
+ одного контакта.
+ Вся информация о коротком имени содержится в текстовой части узла.
+ Узел gContact:shortName может отсутствовать в XML-документе}
+ TcpShortName = class(TTextTag);
+
+ {Класс, описывающий узел gContact:subject.
+ Этот узел используется для указания дополнительной информации о контакте,
+ например, области деятельности в которой пользователь пересекается с контактом.
+ Элемент gContact:subject не может быть повторен в рамках описания
+ одного контакта.
+ Вся дополнительная информация о контакте содержится в текстовой части узла.
+ Узел gContact:subject может отсутствовать в XML-документе}
+ TcpSubject = class(TTextTag);
+
+ {Класс, описывающий узел gContact:maidenName.
+ Этот узел используется для указания девичьей фамилии контакта (для контактов женского пола).
+ Элемент gContact:maidenName не может быть повторен в рамках описания
+ одного контакта.
+ Вся информация о девичьей фамилии содержится в текстовой части узла.
+ Узел gContact:maidenName может отсутствовать в XML-документе}
+ TcpMaidenName = class(TTextTag);
+
+ {Класс, описывающий узел gContact:mileage.
+ Этот узел используется для указания расстояния, отделяющего пользователя от контакта.
+ Элемент gContact:mileage не может быть повторен в рамках описания
+ одного контакта.
+ Вся информация о расстоянии содержится в текстовой части узла. Текст,
+ содержащий информацию о расстоянии может содержать подстроки размерности,
+ например "км.". Размерности никак не интерпретируются сервером Google.
+ Узел gContact:mileage может отсутствовать в XML-документе}
+ TcpMileage = class(TTextTag);
+
+ {Класс, описывающий узел gContact:nickname.
+ Этот узел используется для ника (клички) контакта.
+ Элемент gContact:nickname не может быть повторен в рамках описания
+ одного контакта.
+ Вся информация о нике содержится в текстовой части узла.
+ Узел gContact:nickname может отсутствовать в XML-документе}
+ TcpNickname = class(TTextTag);
+
+ {Класс, описывающий узел gContact:occupation.
+ Этот узел используется для описания рода занятий/профессии контакта.
+ Элемент gContact:occupation не может быть повторен в рамках описания
+ одного контакта.
+ Вся информация о профессии содержится в текстовой части узла.
+ Узел gContact:occupation может отсутствовать в XML-документе}
+ TcpOccupation = class(TTextTag);
+
+
+{Класс, описывающий узел gContact:birthday.
+ Этот узел используется для указания даты рождения контакта.
+ Элемент gContact:birthday не может быть повторен в рамках описания
+ одного контакта.
+ Вся информация о дате рождения содержится в аттрибуте "when" узла. Дата может
+ быть представлена как в полном формате "YYYY-MM-DD", так и в укороченном "--MM-DD"
+ Узел gContact:birthday может отсутствовать в XML-документе}
+type
+ TcpBirthday = class
+ private
+ FDate: TDate; //дата рождения контакта
+ FShortFormat: boolean; //если True, то в указании даты рождения используется укороченный формат даты
+ procedure SetDate(aDate: TDate);
+ function GetServerDate: string;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode{XML-узел на основании которого будет создан экземпляр класса} = nil);
+ {Очищает поля класса от всех данных. Поле FShortFormat получает значение false}
+ procedure Clear;
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ поле FDate<=0}
+ function IsEmpty: boolean;
+ { Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(const Node: TXmlNode{узел на основании которого будет проходить заполнение полей объекта});
+ {На основании значений полей класса формирует новый XML-узел и помещает его как
+ дочерний для узла Root. Если экземпляр класса не содержит данных (функция
+ IsEmpty возвращает true) выполнение функции прерывается и результатом функции
+ будет nil}
+ function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
+ {Указывает используется ли в описании даты рождения контакта укороченный формат датты (без года рождения)}
+ property ShotrFormat: boolean read FShortFormat write FShortFormat;
+ {Дата рождения контакта. Если используется укороченный формат даты, то в Date указывается текущий год}
+ property Date: TDate read FDate write SetDate;
+ {Строка используемая для указания даты рождения контакта в XML-документе.
+ Фактически - это значение атрибута when узла gContact:birthday}
+ property ServerDate: string read GetServerDate;
+ end;
+
+{Перечислитель, используемый для определения параметра Rel узла
+gContact:calendarLink}
+type
+ TCalendarRel = (tc_none {значение парамета не определено},
+ tc_work {определяет ссылку на рабочий календарь контакта},
+ tc_home {определяет ссылку на календарь контакта, используемого для домашних записей},
+ tc_free_busy {определяет ссылку на календарь контака в котором указана информация о занятости});
+
+
+{Класс, описывающий узел gContact:calendarLink.
+ Этот узел используется для указания ссылок на календари контакта.
+ Тип календаря, указанного в ссылке, определяется атрибутом Rel XML-узла
+ Элемент gContact:calendarLink может быть повторен в рамках описания
+ одного контакта, но только один календарь пользователя может помечаться как основной
+ (иметь аттрибут primary=true).
+ Узел gContact:calendarLink может отсутствовать в XML-документе}
+ TcpCalendarLink = class
+ private
+ FRel: TCalendarRel;
+ FLabel: string;
+ FPrimary: boolean;
+ FHref: string;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ { Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
+ {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
+
+ * Пример использования *
+
+ ...
+ property Rel: TCalendarRel read FRel write FRel;
+ ...
+ S:string;
+
+ Rel:=tc_work;
+ S:=RelToString;
+ ----------
+ S='Рабочий календарь'
+ }
+ function RelToString: string;
+ {Очищает поля класса от всех данных.}
+ procedure Clear;
+ {На основании значений полей класса формирует новый XML-узел и помещает его как
+ дочерний для узла Root. Если экземпляр класса не содержит данных (функция
+ IsEmpty возвращает true) выполнение функции прерывается и результатом функции
+ будет nil}
+ function AddToXML(Root: TXmlNode {родительский узел для вновь создаваемого узла}): TXmlNode;
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
+ function IsEmpty: boolean;
+ property Rel: TCalendarRel read FRel write FRel;//атрибут Rel узла. Определяет тип ссылки на календарь
+ property Primary: boolean read FPrimary write FPrimary;//определяет является ли календарь основным для контакта
+ property Href: string read FHref write FHref;//ссылка на календарь контакта
+ end;
+
+
+{Перечислитель, используемый для определения параметра Rel узла
+gContact:event}
+ TEventRel = (teNone {значение парамета не определено - при отправке информации на сервер,
+ содержащей такой XML-узел закончится неудачей, если не будет определен атрибут label},
+ teAnniversary {значение определяет какой-либо юбилей контакта},
+ teOther {значение определяет другие важные события контакта});
+
+
+{Класс, описывающий узел gContact:event.
+ Этот узел используется для указания каких-либо значимых дат для контакта.
+ Тип события, указанного в XML-элементе, определяется атрибутом Rel.
+ Элемент gContact:event может быть повторен в рамках описания
+ одного контакта.
+ Узел gContact:event может отсутствовать в XML-документе}
+ TcpEvent = class
+ private
+ FEventType: TEventRel;
+ FLabel: string;
+ FWhen: TgdWhen;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ {Очищает поля класса от всех данных.}
+ procedure Clear;
+ { Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
+ {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
+
+ * Пример использования *
+
+ ...
+ property EventType: TEventRel read FEventType write FEventType;
+ ...
+ S:string;
+
+ Rel:=teAnniversary;
+ S:=RelToString;
+ ----------
+ S='Юбилей'
+ }
+ function RelToString: string;
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
+ function IsEmpty: boolean;
+ {На основании значений полей класса формирует новый XML-узел и помещает его как
+ дочерний для узла Root. Если экземпляр класса не содержит данных (функция
+ IsEmpty возвращает true) выполнение функции прерывается и результатом функции
+ будет nil}
+ function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
+
+ property EventType: TEventRel read FEventType write FEventType;//тип события, указанного в элементе
+ property Labl: string read FLabel write FLabel;//тектсовая метка, определяющая событие, если параметр Rel XML-узла имеет значение Other
+ property When: TgdWhen read FWhen write FWhen; //определет дату наступления события
+ end;
+
+
+{Перечислитель, используемый для определения параметра Rel узла
+gContact:externalId}
+type
+ TExternalIdType = (tiNone {значение не определено},
+ tiAccount {указан ID аккаунта},
+ tiCustomer {указан ID клиента какой-либо внешней сети},
+ tiNetwork {указан сетевой идентификатор в какой-либо сети},
+ tiOrganization {указан ID организации в которой работает контакт});
+
+{Класс, описывающий узел gContact:externalId.
+ Этот узел используется для указания каких-либо идентификаторов внешних систем в которых участвует контакт.
+ Тип ID, указанного в XML-элементе, определяется атрибутом Rel.
+ Элемент gContact:externalId может быть повторен в рамках описания
+ одного контакта.
+ Узел gContact:externalId может отсутствовать в XML-документе}
+ TcpExternalId = class
+ private
+ FRel: TExternalIdType;
+ FLabel: string;
+ FValue: string;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ {Очищает поля класса от всех данных.}
+ procedure Clear;
+ { Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
+ {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
+
+ * Пример использования *
+
+ ...
+ property Rel: TExternalIdType read FRel write FRel;
+ ...
+ S:string;
+
+ Rel:=tiAccount;
+ S:=RelToString;
+ ----------
+ S='ID аккаунта'
+ }
+ function RelToString: string;
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
+ function IsEmpty: boolean;
+ {На основании значений полей класса формирует новый XML-узел и помещает его как
+ дочерний для узла Root. Если экземпляр класса не содержит данных (функция
+ IsEmpty возвращает true) выполнение функции прерывается и результатом функции
+ будет nil}
+ function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
+
+ property Rel: TExternalIdType read FRel write FRel;//определяет тип ID
+ property Labl: string read FLabel write FLabel;//текстовая метка, определяющая указанный ID
+ property Value: string read FValue write FValue;//значение ID
+ end;
+
+
+{Перечислитель, используемый для определения значения узла
+gContact:gender}
+type
+ TGenderType = (none {пол контакта не указан},
+ male {мужской},
+ female{женский});
+
+{Класс, описывающий узел gContact:gender.
+ Этот узел используется для указания пола контакта.
+ Пол указывается в значении в XML-элемента.
+ Элемент gContact:gender не может быть повторен в рамках описания
+ одного контакта.
+ Узел gContact:gender может отсутствовать в XML-документе}
+ TcpGender = class
+ private
+ FValue: TGenderType;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ {Очищает поля класса от всех данных.}
+ procedure Clear;
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
+ function IsEmpty: boolean;
+ {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
+
+ * Пример использования *
+
+ ...
+ property Value: TGenderType read FValue write FValue;
+ ...
+ S:string;
+
+ Rel:=male;
+ S:=ValueToString;
+ ----------
+ S='мужской'
+ }
+ function ValueToString: string;
+ {Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
+ {На основании значений полей класса формирует новый XML-узел и помещает его как
+ дочерний для узла Root. Если экземпляр класса не содержит данных (функция
+ IsEmpty возвращает true) выполнение функции прерывается и результатом функции
+ будет nil}
+ function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
+
+ property Value: TGenderType read FValue write FValue;//пол контакта
+ end;
+
+
+{Класс, описывающий узел gContact:groupMembershipInfo.
+ Этот узел используется для указания того в каких группах содержится контакт.
+ Группа указывается в виде строки, содержащей URL группы в адресной книге.
+ Элемент gContact:groupMembershipInfo может быть повторен в рамках описания
+ одного контакта.
+ Узел gContact:groupMembershipInfo обязательно присутствует в XML-документе}
+type
+ TcpGroupMembershipInfo = class
+ private
+ FDeleted: boolean;
+ FHref: string;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ {Очищает поля класса от всех данных.}
+ procedure Clear;
+ {Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
+ function IsEmpty: boolean;
+ {На основании значений полей класса формирует новый XML-узел и помещает его как
+ дочерний для узла Root. Если экземпляр класса не содержит данных (функция
+ IsEmpty возвращает true) выполнение функции прерывается и результатом функции
+ будет nil}
+ function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
+
+ property Href: string read FHref write FHref;//URL группы контактов
+ property Deleted: boolean read FDeleted write FDeleted;//значение true указывает на то, что контакт был удален не позднее, чем 30 дней назад
+ end;
+
+{Перечислитель, используемый для определения значения атрибута rel узла
+gContact:jot}
+type
+ TJotRel = (TjNone,
+ Tjhome,
+ Tjwork,
+ Tjother,
+ Tjkeywords,
+ Tjuser );
+
+{Класс, описывающий узел gContact:jot.
+ Этот узел используется для хранения произвольной информации о контакте.
+ Каждый фрагмент информации обязательно должен иметь свой тип, описываемый в атрибуте rel
+ (см. также значения перечислителя TJotRel)
+ Фрагменты информации храняться в значении XML-узла.
+ Элемент gContact:jot может быть повторен в рамках описания одного контакта.
+ Узел gContact:jot может отсутствовать в XML-документе}
+ TcpJot = class
+ private
+ FRel: TJotRel;
+ FText: string;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ {Очищает поля класса от всех данных.}
+ procedure Clear;
+ {Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
+ {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
+
+ * Пример использования *
+
+ ...
+ property Rel: TJotRel read FRel write FRel;
+ ...
+ S:string;
+
+ Rel:=Tjkeywords;
+ S:=RelToString;
+ ----------
+ S='Ключевые слова'
+ }
+ function RelToString: string;
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
+ function IsEmpty: boolean;
+ {На основании значений полей класса формирует новый XML-узел и помещает его как
+ дочерний для узла Root. Если экземпляр класса не содержит данных (функция
+ IsEmpty возвращает true) выполнение функции прерывается и результатом функции
+ будет nil}
+ function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
+ property Rel: TJotRel read FRel write FRel;//значение атрибута Rel
+ property Text: string read FText write FText;//фрагмент информации о контакте, записанный в XML-узле
+ end;
+
+
+{Класс, описывающий узел gContact:language.
+ Этот узел используется для хранения информации о предпочитаемом языке контакта.
+ В атрибуте code указывается код языка согласно спецификации IETF BCP 47. Если код определен не верно, то
+ сервер вернет ошибку.
+ Произвольное описание языка задается в атрибуте label узла. Если определено значение code, то label обязателен к заполнению.
+ Элемент gContact:language может быть повторен в рамках описания одного контакта.
+ Узел gContact:language может отсутствовать в XML-документе}
+type
+ TcpLanguage = class
+ private
+ Fcode: string;
+ FLabel: string;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ {Очищает поля класса от всех данных.}
+ procedure Clear;
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
+ function IsEmpty: boolean;
+ {Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
+ {На основании значений полей класса формирует новый XML-узел и помещает его как
+ дочерний для узла Root. Если экземпляр класса не содержит данных (функция
+ IsEmpty возвращает true) выполнение функции прерывается и результатом функции
+ будет nil}
+ function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
+ property Code: string read Fcode write Fcode;//код языка согласно спецификации IETF BCP 47
+ property Labl: string read FLabel write FLabel;//произвольная строка определяющая язык пользователя
+ end;
+
+
+{Перечислитель, используемый для определения значения атрибута rel узла
+gContact:priority}
+type
+ TPriotityRel = (TpNone {приоритет не определен},
+ Tplow {низкий приоритет контакта},
+ Tpnormal {нормальный приоритет контакта},
+ Tphigh {высокий приоритет контакта});
+
+ {Класс, описывающий узел gContact:priority.
+ С помощью этого узла контакты можно разделить по трём категориям важности (см. описание перечислителя TPriotityRel).
+ Важность контакта определяется в атрибуте rel XML-узла.
+ Элемент gContact:priority не может повторяться в рамках описания одного контакта.
+ Узел gContact:priority может отсутствовать в XML-документе}
+ TcpPriority = class
+ private
+ FRel: TPriotityRel;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ {Очищает поля класса от всех данных.}
+ procedure Clear;
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
+ function IsEmpty: boolean;
+ {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
+
+ * Пример использования *
+
+ ...
+ property Rel: TPriotityRel read FRel write FRel;
+ ...
+ S:string;
+
+ Rel:=Tplow;
+ S:=RelToString;
+ ----------
+ S='Низкий приоритет'
+ }
+ function RelToString: string;
+ {Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
+ {На основании значений полей класса формирует новый XML-узел и помещает его как
+ дочерний для узла Root. Если экземпляр класса не содержит данных (функция
+ IsEmpty возвращает true) выполнение функции прерывается и результатом функции
+ будет nil}
+ function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
+ property Rel: TPriotityRel read FRel write FRel;//приоритет пользователя (см. описание перечислителя TPriotityRel)
+ end;
+
+
+{Перечислитель, используемый для определения значения атрибута rel узла
+gContact:relation}
+type
+ TRelationType = (tr_None {отношение к контаку не указано},
+ tr_assistant {указанное лицо является помощником},
+ tr_brother {указанное лицо является братом},
+ tr_child {указанное лицо является ребенком},
+ tr_domestic_partner {указанное лицо является соседом},
+ tr_father {указанное лицо является отцом},
+ tr_friend {указанное лицо является другом},
+ tr_manager {указанное лицо является управляющим (начальником)},
+ tr_mother {указанное лицо является матерью},
+ tr_parent {указанное лицо является родителем},
+ tr_partner {указанное лицо является партнером},
+ tr_referred_by {указанное лицо является знакомым},
+ tr_relative {контакт находится с этим лицом в каких-либо других отношениях},
+ tr_sister {указанное лицо является сестрой},
+ tr_spouse {указанное лицо является супругой});
+
+ {Класс, описывающий узел gContact:relation.
+ Используется для указания других лиц, состоящих в каки-либо отношениях с контактом (см. описание перечислителя TRelationType).
+ Отношение к контакту указывается в атрибуте rel XML-узла.
+ Элемент gContact:relation может повторяться в рамках описания одного контакта.
+ Узел gContact:relation может отсутствовать в XML-документе}
+ TcpRelation = class
+ private
+ FValue: string;
+ FLabel: string;
+ FRealition: TRelationType;
+ function GetRelStr(aRel: TRelationType): string;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ {Очищает поля класса от всех данных.}
+ procedure Clear;
+ {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
+
+ * Пример использования *
+
+ ...
+ property Realition: TRelationType read FRealition write FRealition;
+ ...
+ S:string;
+
+ Realition:=tr_brother;
+ S:=RelToString;
+ ----------
+ S='Брат'
+ }
+ function RelToString: string;
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
+ function IsEmpty: boolean;
+ {Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
+ {На основании значений полей класса формирует новый XML-узел и помещает его как
+ дочерний для узла Root. Если экземпляр класса не содержит данных (функция
+ IsEmpty возвращает true) выполнение функции прерывается и результатом функции
+ будет nil}
+ function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
+ property Realition: TRelationType read FRealition write FRealition;//отношение к контакту (см. описание значений перечислителя TRelationType)
+ property Value: string read FValue write FValue;//дения об указанном человеке (e-mail, имя, и т.д.)
+ end;
+
+
+{Перечислитель, используемый для определения значения атрибута rel узла
+gContact:sensitivity}
+type
+ TSensitivityRel = (TsNone {характер контакта не определен},
+ Tsconfidential {конфеденциальный контакт},
+ Tsnormal {обычный контакт},
+ Tspersonal {персональный контакт},
+ Tsprivate {приватный (скрытый) контакт});
+
+
+
+
+ {Класс, описывающий узел gContact:sensitivity.
+ Используется для классификации контактов по их степени открытости (см. описание значений перечислителя TSensitivityRel).
+ Степень открытости контакта указывается в атрибуте rel XML-узла.
+ Элемент gContact:sensitivity не может повторяться в рамках описания одного контакта.
+ Узел gContact:sensitivity может отсутствовать в XML-документе}
+ TcpSensitivity = class
+ private
+ FRel: TSensitivityRel;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ {Очищает поля класса от всех данных.}
+ procedure Clear;
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
+ function IsEmpty: boolean;
+ {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
+
+ * Пример использования *
+
+ ...
+ property Rel: TSensitivityRel read FRel write FRel;
+ ...
+ S:string;
+
+ Rel:=Tsconfidential;
+ S:=RelToString;
+ ----------
+ S='Конфеденциальный'
+ }
+ function RelToString: string;
+ {Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
+ {На основании значений полей класса формирует новый XML-узел и помещает его как
+ дочерний для узла Root. Если экземпляр класса не содержит данных (функция
+ IsEmpty возвращает true) выполнение функции прерывается и результатом функции
+ будет nil}
+ function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
+ property Rel: TSensitivityRel read FRel write FRel;//характеристика "открытости" контакта (см. описание значений перечислителя TSensitivityRel)
+ end;
+
+
+{Перечислитель, используемый для определения значения атрибута id узла
+gContact:systemGroup}
+type
+ TcpSysGroupId = (tg_None {идентификатор группы не определен},
+ tg_Contacts {идентификатор системной группы "Мои контакты"},
+ tg_Friends {идентификатор системной группы "Друзья"},
+ tg_Family {идентификатор системной группы "Семья"},
+ tg_Coworkers {идентификатор системной группы "Коллеги"});
+
+{Класс, описывающий узел gContact:systemGroup.
+ Используется для определения идентификатора групы, если группа является системной.
+ Идентификатор сисемной группы указывается в атрибуте id XML-узла.
+ Элемент gContact:systemGroup не может повторяться в рамках описания одной группы.
+ Узел gContact:systemGroup может отсутствовать в XML-документе}
+ TcpSystemGroup = class
+ private
+ FIdRel: TcpSysGroupId;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ {Очищает поля класса от всех данных.}
+ procedure Clear;
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
+ function IsEmpty: boolean;
+ {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
+
+ * Пример использования *
+
+ ...
+ property ID: TcpSysGroupId read FIdRel write FIdRel;
+ ...
+ S:string;
+
+ Rel:=tg_Contacts;
+ S:=RelToString;
+ ----------
+ S='Мои контакты'
+ }
+ function RelToString: string;
+ {Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
+ {На основании значений полей класса формирует новый XML-узел и помещает его как
+ дочерний для узла Root. Если экземпляр класса не содержит данных (функция
+ IsEmpty возвращает true) выполнение функции прерывается и результатом функции
+ будет nil}
+ function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
+ property ID: TcpSysGroupId read FIdRel write FIdRel;//идентификатор системной группы (см. описание перечислителя TcpSysGroupId)
+ end;
+
+
+{Класс, описывающий узел gContact:userDefinedField.
+ Используется для указания произвольной информации о контакте.
+ В XML-узле обязательно должен присутствовать атрибут key - имя поля и value - значение
+ Элемент gContact:userDefinedField может повторяться в рамках описания одной группы.
+ Узел gContact:userDefinedField может отсутствовать в XML-документе}
+type
+ TcpUserDefinedField = class
+ private
+ FKey: string;
+ FValue: string;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ {Очищает поля класса от всех данных.}
+ procedure Clear;
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
+ function IsEmpty: boolean;
+ {Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
+ {На основании значений полей класса формирует новый XML-узел и помещает его как
+ дочерний для узла Root. Если экземпляр класса не содержит данных (функция
+ IsEmpty возвращает true) выполнение функции прерывается и результатом функции
+ будет nil}
+ function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
+
+ property Key: string read FKey write FKey;//Ключ (имя) поля определенного пользователем
+ property Value: string read FValue write FValue;//значения поля, определенного пользователем
+ end;
+
+
+{Перечислитель, используемый для определения значения атрибута rel узла
+gContact:website}
+type
+ TWebSiteType = (tw_None {назначение ресурса не определено},
+ tw_Home_Page {ресурс является домашней страничкой контакта},
+ tw_Blog {ресурс яляется блогом контакта},
+ tw_Profile {ресурс является профилем в Google контакта},
+ tw_Home {ресурс является домашним сайтом контакта},
+ tw_Work {ресурс является рабочим сайтом контакта},
+ tw_Other {назначение ресурса не подходит ни под одно доступное описание},
+ tw_Ftp {ресурс является FTP-сайтом контакта});
+
+ {Класс, описывающий узел gContact:website.
+ Используется для указания ресурсов в Сети с которыми связан контакт.
+ Назначение ресурса описывается в атрибуте rel XML-узла (см. описание перечислителя TWebSiteType)
+ Элемент gContact:website может повторяться в рамках описания одной группы.
+ Узел gContact:website может отсутствовать в XML-документе}
+ TcpWebsite = class
+ private
+ FHref: string;
+ FPrimary: boolean;
+ FLabel: string;
+ FRel: TWebSiteType;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ {Очищает поля класса от всех данных.}
+ procedure Clear;
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
+ function IsEmpty: boolean;
+ {Возвращает строку на языке пользователя, определяющую тип календаря в ссылке
+
+ * Пример использования *
+
+ ...
+ property Rel: TWebSiteType read FRel write FRel;
+ ...
+ S:string;
+
+ Rel:=tw_Blog;
+ S:=RelToString;
+ ----------
+ S='Блог'
+ }
+ function RelToString: string;
+ {Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(const Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
+ {На основании значений полей класса формирует новый XML-узел и помещает его как
+ дочерний для узла Root. Если экземпляр класса не содержит данных (функция
+ IsEmpty возвращает true) выполнение функции прерывается и результатом функции
+ будет nil}
+ function AddToXML(Root: TXmlNode{родительский узел для вновь создаваемого узла}): TXmlNode;
+
+ property Href: string read FHref write FHref;//URL ресурса
+ property Primary: boolean read FPrimary write FPrimary;//true, если указанный ресурс является основным для контакта
+ property Labl: string read FLabel write FLabel;//произвольное описание ресурса
+ property Rel: TWebSiteType read FRel write FRel;//назначение ресурса (см. описание перечислителя TWebSiteType)
+ end;
+
+type
+ TGoogleContact = class;
+ TContactGroup = class;
+
+ {Перечислитель, пределяющий формат файла, который будет сформирован для
+ передачи на сервер или для сохранения на жесткий диск}
+ TFileType = (tfAtom {файл будет формироваться как документ Atom},
+ tfXML {файл будет формироваться как обычный XML-документ});
+ {Перечислитель, определяющий способ сортировки контактов пользователя}
+ TSortOrder = (Ts_None {способ сортировки контактов не определен (определяется сервером)},
+ Ts_ascending {сортировка контактов по возрастанию},
+ Ts_descending {сортировка контактов по убыванию});
+
+
+{Класс предоставляющий доступ к информации об одном контакте пользователя. Поля класса могут заполняться на основании
+XML-узла entry XML-документа, содержащего сведения о контактах пользователя}
+ TContact = class
+ private
+ FEtag: string;
+ FId: string;
+ FUpdated: TDateTime;
+ FTitle: TTextTag;
+ FContent: TTextTag;
+ FLinks: TList;
+ FName: TgdName;
+ FNickName: TcpNickname;
+ FBirthDay: TcpBirthday;
+ FOrganization: TgdOrganization;
+ FEmails: TList;
+ FPhones: TList;
+ FPostalAddreses: TList;
+ FEvents: TList;
+ FRelations: TList;
+ FUserFields: TList;
+ FWebSites: TList;
+ FGroupMemberships: TList;
+ FIMs: TList;
+ function GetPrimaryEmail: string;
+ procedure SetPrimaryEmail(aEmail: string);
+ function GetOrganization: TgdOrganization;
+ function GetContactName: string;
+ function GenerateText(TypeFile: TFileType): string;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ {Деструктор. Корректно удаляет объект из памяти}
+ destructor Destroy; override;
+ {Проверка экземпляра класса на "пустоту". Возвращает true в случае, если
+ ни одно поле объекта не заполнено, либо отсутствует обязательные какие-либо значения}
+ function IsEmpty: boolean;
+ {Очищает поля класса от всех данных.}
+ procedure Clear;
+ {Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта}); overload;
+ {Разбирает узел XML, находящийся в потоке Stream и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(Stream: TStream{поток, содержащий информацию об XML-узле}); overload;
+ {находит в списке всех email'ов контакта заданный адрес и возвращает полную информацию по нему в виде объекта TgdEmail}
+ function FindEmail(const aEmail: string {адрес email информацию по которому необходимо найти};
+ out Index: integer {индекс объекта в списке email'ов контакта}): TgdEmail;
+ {сохраняет всю информацию о контакте в файл}
+ procedure SaveToFile(const FileName: string {имя файла (включая путь к нему)};
+ FileType: TFileType = tfAtom{тип файла (см. описание TFileType)});
+ {загружает информацию о контакте из файла}
+ procedure LoadFromFile(const FileName: string{имя файла (включая путь к нему});
+ {Заголовок контакта. Представляет собой объект TTextTag}
+ property TagTitle: TTextTag read FTitle write FTitle;
+ {Краткое описание контакта. Представляет собой объект TTextTag}
+ property TagContent: TTextTag read FContent write FContent;
+ {Имя контакта. Представляет собой объект TgdName}
+ property TagName: TgdName read FName write FName;
+ {Псевдоним контакта. Представляет собой объект TcpNickname}
+ property TagNickName: TcpNickname read FNickName write FNickName;
+ {День рождения контакта. Представляет собой объект TcpBirthday}
+ property TagBirthDay: TcpBirthday read FBirthDay write FBirthDay;
+ {Организация в которой рабоает контакт. Представляет собой объект TgdOrganization}
+ property TagOrganization
+ : TgdOrganization read GetOrganization write FOrganization;
+ {Уникальный идентификатор контакта}
+ property Etag: string read FEtag;
+ {Идентификатор контакта, представляющий собой URL по которому находится полная информация о контакте}
+ property ID: string read FId write FId;
+ {Дата последнего обновления контакта}
+ property Updated: TDateTime read FUpdated write FUpdated;
+ {Список ссылок, связанных с контактом. Каждая ссылка представлена в виде объекта TEntryLink
+ Эти ссылки используются для редактирования информации о контакте на сервере, загрузки фотографий, удаления контакта и т.д.}
+ property Links: TListread FLinks write FLinks;
+ {Список всех email-адресов контакта. Каждый элемент списка представляет собой объект TgdEmail}
+ property Emails: TListread FEmails write FEmails;
+ {Список всех номеров телефонов контакта. Каждый элемент списка представляет собой объект TgdPhoneNumber}
+ property Phones: TListread FPhones write FPhones;
+ {Список всех почтовых адресов контакта. Каждый элемент списка представляет собой объект TgdStructuredPostalAddress}
+ property PostalAddreses
+ : TListread FPostalAddreses write
+ FPostalAddreses;
+ {Список всех значимых событий для контакта. Каждый элемент списка представляет собой объект TcpEvent}
+ property Events: TListread FEvents write FEvents;
+ {Список лиц, связанных каким-либо образом с контактом. Каждый элемент списка представляет собой объект TcpRelation}
+ property Relations: TListread FRelations write FRelations;
+ {Список полей, содержащих дополнительную информацию о контакте. Каждый элемент списка представляет собой объект TcpUserDefinedField}
+ property UserFields
+ : TListread FUserFields write FUserFields;
+ {Список ресурсов в Сети, с которыми связан контакт. Каждый элемент списка представляет собой объект TcpWebsite}
+ property WebSites: TListread FWebSites write FWebSites;
+ {Список групп в которых находится контакт. Каждый элемент списка представляет собой объект TcpGroupMembershipInfo}
+ property GroupMemberships
+ : TListread FGroupMemberships write
+ FGroupMemberships;
+ {Список дополнительных средств связи с контактом. Каждый элемент списка представляет собой объект TgdIm}
+ property IMs: TListread FIMs write FIMs;
+ {Содержит адрес электронной почты, который является основным для контата.
+ Может содержать пустую строку, если ни один из адресов в списке Emails не помечен как Primary}
+ property PrimaryEmail: string read GetPrimaryEmail write SetPrimaryEmail;
+ {Содержит строку которая представляет собой полное имя контакта.
+ Полоное имя контакта формируется на основании данных, содержащихся в свойстве TagName}
+ property ContactName: string Read GetContactName;
+ {Содержит строку, представляющую собой XML-узел entry, в котором содержится вся информация о конакте}
+ property ToXMLText[XMLType: TFileType{тип формируемого узла (см. описание TFileType)}]: string read GenerateText;
+ end;
+
+
+{Класс предоставляющий доступ к информации о группе контактов пользователя.
+Поля класса могут заполняться на основании XML-узла entry XML-документа,
+содержащего сведения о группах контактов пользователя}
+ TContactGroup = class
+ private
+ FEtag: string;
+ FId: string;
+ FLinks: TList;
+ FUpdate: TDateTime;
+ FTitle: TTextTag;
+ FContent: TTextTag;
+ FExtendedProps: TgdExtendedProperty;
+ FSystemGroup: TcpSystemGroup;
+ function GetTitle: string;
+ function GetContent: string;
+ function GetSysGroupId: TcpSysGroupId;
+ procedure SetTitle(const aTitle: string);
+ procedure SetContent(const aContent: string);
+ procedure SetSysGroupId(aSysGroupId: TcpSysGroupId);
+ function GenerateXML(const WintExtended: boolean): TNativeXml;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ constructor Create(const byNode: TXmlNode = nil{XML-узел на основании которого будет создан экземпляр класса});
+ {Разбирает узел XML Node и заполняет на основании полученных данных
+ поля класса }
+ procedure ParseXML(Node: TXmlNode {узел на основании которого будет проходить заполнение полей объекта});
+ {Уникальный идентификатор группы контактов}
+ property Etag: string read FEtag write FEtag;
+ {Идентификатор группы, представляющий собой URL документа, содержащего всю информацию по группе.
+ Также этот идентификатор используется для использования в качестве аттрибута узла gContact:groupMembershipInfo
+ (см. иформацию по классу TcpgroupMembershipInfo)}
+ property ID: string read FId write FId;
+ {Список служебных ссылок для группы контактов. Ссылки используются для редактирования и удаления группы.
+ Каждый элемент списка представляет собой класс TEntryLink}
+ property Links: TListread FLinks write FLinks;
+ {Дата последнего обновления информации о группе}
+ property Update: TDateTime read FUpdate write FUpdate;
+ {Заголовок группы контактов}
+ property Title: string read GetTitle write SetTitle;
+ {Краткое описание группы контактов}
+ property Content: string read GetContent write SetContent;
+ {Если группа является системной, то это свойство содержит всю служебную информацию по группе}
+ property SystemGroup: TcpSysGroupId read GetSysGroupId write SetSysGroupId;
+ end;
+
+ {Основной компонент для работы с Google Contacts. Содержит необходимые свойства
+ и методы для работы с группами контактов и контактами}
+ TGoogleContact = class(TComponent)
+ private
+ FAuth: string; // AUTH для доступа к API
+ FEmail: string; // обязательно GMAIL!
+ FTotalBytes: int64;
+ FBytesCount: int64;
+ FGroups: TList; // группы контактов
+ FContacts: TList; // все контакты
+ FOnRetriveXML: TOnRetriveXML;
+ FOnBeginParse: TOnBeginParse;
+ FOnEndParse: TOnEndParse;
+ FOnReadData: TOnReadData;
+ FMaximumResults: integer;
+ FStartIndex: integer;
+ FUpdatesMin: TDateTime;
+ FSortOrder: TSortOrder;
+ FShowDeleted: boolean;
+ function GetNextLink(Stream: TStream): string; overload;
+ function GetNextLink(aXMLDoc: TNativeXml): string; overload;
+ function GetContactsByGroup(GroupName: string): TList;
+ function GroupLink(const aGroupName: string): string;
+ procedure ParseXMLContacts(const Data: TStream);
+ function GetEditLink(aContact: TContact): string;
+ function InsertPhotoEtag(aContact: TContact; const Response: TStream)
+ : boolean;
+ function GetTotalCount(aXMLDoc: TNativeXml): integer;
+ procedure ReadData(Sender: TObject; Reason: THookSocketReason;
+ const Value: String);
+ function RetriveContactPhoto(index: integer): TJPEGImage; overload;
+ function RetriveContactPhoto(aContact: TContact): TJPEGImage; overload;
+ procedure SetMaximumResults(const Value: integer);
+ procedure SetShowDeleted(const Value: boolean);
+ procedure SetSortOrder(const Value: TSortOrder);
+ procedure SetStartIndex(const Value: integer);
+ procedure SetUpdatesMin(const Value: TDateTime);
+ function ParamsToStr: TStringList;
+ function GetContact(GroupName: string; Index: integer): TContact;
+ procedure SetAuth(const aAuth: string);
+ procedure SetGmail(const aGMail: string);
+ function GetContactNames: TStrings;
+ function GetGropsNames: TStrings;
+ public
+ {Конструктор. Создает объект с настройками по умолчанию}
+ constructor Create(AOwner: TComponent); override;
+ {Деструктор. Корректно удаляет объект из памяти}
+ destructor Destroy; override;
+ {Получение всех групп контактов пользователя. Результатом выполнения функции
+ является число групп, полученных в результате выполнения запроса на сервер}
+ function RetriveGroups: integer;
+ {Получение всех контактов пользователя. Результатом выполнения функции
+ является число контактов, полученных в результате выполнения запроса на сервер}
+ function RetriveContacts: integer;
+ {Удаление контакта с сервера по его индексу в списке Contacts.
+ Функция возвращает true в случае, если контакт корректно удален с сервера.
+ Удаленный с сервера контакт автоматически удаляется из списка контактов Contacts}
+ function DeleteContact(index: integer): boolean; overload;
+ {Удаление контакта с сервера. Контакт aContact должен находиться в списке Contacts
+ Функция возвращает true в случае, если контакт корректно удален с сервера.
+ Удаленный с сервера контакт автоматически удаляется из списка контактов Contacts}
+ function DeleteContact(aContact: TContact): boolean; overload;
+ {Добавление контакта aContact на сервер. успешного выполнения операции
+ новый контакт автоматически добавляется в список Contacts}
+ function AddContact(aContact: TContact): boolean;
+ {Добавление новой группы контактов с названием aName и описанием aDescription на сервер.
+ В случае, если операция выполнена успешно новая группа автоматически добавляется в список Groups}
+ function AddContactGroup(const aName, aDescription: string): boolean;
+ {Редактирование информации группы контактов aGroup. Редактируемая группа
+ должна находится на сервере (содержать список ссылок Links)}
+ function UpdateContactGroup(const aGroup:TContactGroup):boolean;overload;
+ {Редактирование информации группы контактов с индексом Index в списке Groups.
+ Редактируемая группа должна находится на сервере (содержать список ссылок Links)}
+ function UpdateContactGroup(const Index:integer):boolean;overload;
+ {Удаление групп контактов aGroup с сервера. В случае успешно выполненной
+ операции группа также удляется из списка Groups}
+ function DeleteContactGroup(const aGroup:TContactGroup):boolean;overload;
+ {Удаление групп контактов с индексом Index в списке Groups с сервера.
+ В случае успешно выполненной операции группа также удляется из списка Groups}
+ function DeleteContactGroup(const Index:integer):boolean;overload;
+ {Обновление информации о контакте aContact. Контакт должен находится в списке Contacts
+ В случае успешно выполненной операции информация о контакте обновляется как в списке Contacts
+ так и на сервере}
+ function UpdateContact(aContact: TContact): boolean; overload;
+ {Обновление информации о контакте с индексом Index в списке Contacts
+ В случае успешно выполненной операции информация о контакте обновляется как в списке Contacts
+ так и на сервере}
+ function UpdateContact(index: integer): boolean; overload;
+ {Получение с сервера фотографии контакта aContact. В случае, если контакт не содержит фотографии
+ результатом выполнения функции будет изображение, загруженное из файла DefaultImage}
+ function RetriveContactPhoto(aContact: TContact; DefaultImage: TFileName)
+ : TJPEGImage; overload;
+ {Получение с сервера фотографии контакта с индексом Index в списке Contacts.
+ В случае, если контакт не содержит фотографии результатом выполнения функции
+ будет изображение, загруженное из файла DefaultImage}
+ function RetriveContactPhoto(index: integer; DefaultImage: TFileName)
+ : TJPEGImage; overload;
+
+ {Загружает на сервер файл PhotoFile в качестве изображения контакта,
+ имеющего индекс Index в списке Contacts. Функция возращает
+ True в случае успешной загрузки}
+ function UpdatePhoto(index: integer; const PhotoFile: TFileName): boolean;
+ overload;
+ {Загружает на сервер файл PhotoFile в качестве изображения контакта
+ aContact. Функция возращает True в случае успешной загрузки}
+ function UpdatePhoto(aContact: TContact; const PhotoFile: TFileName)
+ : boolean; overload;
+ {Удаление изображения контакта aContact с сервера. Функция возвращает
+ true в случае, если удаление прошло успешно}
+ function DeletePhoto(aContact: TContact): boolean; overload;
+ {Удаление изображения контакта с индексом Index в списке Contacts
+ с сервера. Функция возвращает true в случае, если удаление прошло успешно}
+ function DeletePhoto(index: integer): boolean; overload;
+ {Сохранение всего списка контактов Contacts в файл FileName.
+ Формат файла - XML}
+ procedure SaveContactsToFile(const FileName: string);
+ {Загружает локальную копию списка контактов из XML-файла FileName}
+ procedure LoadContactsFromFile(const FileName: string);
+
+
+ property Groups: TListread FGroups write FGroups;//список все групп контактов пользователя
+ property Contacts: TListread FContacts write FContacts;//список всех контактов пользователя
+ property ContactByGroupIndex[Group: string; I: integer]
+ : TContact read GetContact;//контакт, находящийся в группе с именем
+ //Group и имеющий в этой группе индекс i
+ property ContactsByGroup[GroupName: string]
+ : TListread GetContactsByGroup;//список всех контактов, находящихся в группе с именем GroupName
+ property ContactsNames: TStrings read GetContactNames;// список имен контактов
+ property GroupsNames: TStrings read GetGropsNames;// список имен групп контактов
+
+ published
+ property Auth: string read FAuth write SetAuth;//Ключ Auth для авторизации в сервисе. Может быть получен с использованием компонента TClientLogin
+ property Gmail: string read FEmail write SetGmail;//адрес почтового ящика на GMail. Используется для работы с группами и контактами
+
+ property MaximumResults: integer read FMaximumResults write SetMaximumResults;// максимальное количество записей контактов возвращаемое в одном фиде
+ property StartIndex: integer read FStartIndex write SetStartIndex;// начальный номер контакта с которого начинать принятие данных
+ property UpdatesMin: TDateTime read FUpdatesMin write SetUpdatesMin;// нижняя граница обновления контактов
+ property ShowDeleted: boolean read FShowDeleted write SetShowDeleted;// определяет будут ли показываться в списке удаленные контакты
+ property SortOrder: TSortOrder read FSortOrder write SetSortOrder;// сортировка контактов
+
+
+ property OnRetriveXML: TOnRetriveXML read FOnRetriveXML write FOnRetriveXML;// начало загрузки XML-документа с сервера
+ property OnBeginParse: TOnBeginParse read FOnBeginParse write FOnBeginParse;// старт парсинга XML
+ property OnEndParse: TOnEndParse read FOnEndParse write FOnEndParse;// окончание парсинга XML
+ property OnReadData: TOnReadData read FOnReadData write FOnReadData;// чтение данных из Сети
+ end;
+
+// получение типа узла
+function GetContactNodeType(const NodeName: string): TcpTagEnum; inline;
+// получение имени узла по его типу
+function GetContactNodeName(const NodeType: TcpTagEnum): string; inline;
+
+procedure Register;
+
+implementation
+
+procedure Register;
+begin
+ RegisterComponents('webdelphi.ru',[TGoogleContact]);
+end;
+
+function GetContactNodeName(const NodeType: TcpTagEnum): string; inline;
+begin
+ Result := GetEnumName(TypeInfo(TcpTagEnum), ord(NodeType));
+ Delete(Result, 1, 3);
+ Result := CpNodeAlias + Result;
+end;
+
+function GetContactNodeType(const NodeName: string): TcpTagEnum; inline;
+var
+ I: integer;
+begin
+ if pos(CpNodeAlias, NodeName) > 0 then
+ begin
+ I := GetEnumValue(TypeInfo(TcpTagEnum), Trim
+ (ReplaceStr(NodeName, CpNodeAlias, 'cp_')));
+ if I > -1 then
+ Result := TcpTagEnum(I)
+ else
+ Result := cp_None;
+ end
+ else
+ Result := cp_None;
+end;
+
+{ TcpBirthday }
+
+function TcpBirthday.AddToXML(Root: TXmlNode): TXmlNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetContactNodeName(cp_birthday));
+ Result.AttributeAdd('when', ServerDate);
+end;
+
+procedure TcpBirthday.Clear;
+begin
+ FDate := 0;
+ FShortFormat:=false;
+end;
+
+constructor TcpBirthday.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ Clear;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TcpBirthday.GetServerDate: string;
+begin
+ Result := '';
+ if not IsEmpty then
+ begin
+ if FShortFormat then // укороченный формат даты
+ Result := FormatDateTime('--mm-dd', FDate)
+ else
+ Result := FormatDateTime('yyyy-mm-dd', FDate);
+ end;
+end;
+
+function TcpBirthday.IsEmpty: boolean;
+begin
+ Result := FDate <= 0;
+end;
+
+procedure TcpBirthday.ParseXML(const Node: TXmlNode);
+var
+ DateStr: string;
+ FormatSet: TFormatSettings;
+begin
+ if GetContactNodeType(Node.NameUnicode) <> cp_birthday then
+ raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_birthday)]);
+ try
+ { читаем локальные настройки форматов }
+ GetLocaleFormatSettings(LOCALE_SYSTEM_DEFAULT, FormatSet);
+ { чиаем дату }
+ DateStr := Node.ReadAttributeString('when');
+ if (Length(Trim(DateStr)) > 0) then // что-то есть - можно парсить дату
+ begin
+ // сокращенный формат - только месяц и число рождения
+ if (pos('--', DateStr) > 0) then
+ begin
+ FormatSet.DateSeparator := '-'; // устанавливаем новый разделиель
+ Delete(DateStr, 1, 2); // срезаем первые два символа
+ FormatSet.ShortDateFormat := 'mm-dd';
+ FDate := StrToDate(DateStr, FormatSet);
+ FShortFormat := true;
+ end
+ // полный формат даты
+ else
+ begin
+ FormatSet.DateSeparator := '-';
+ FormatSet.ShortDateFormat := 'yyyy-mm-dd';
+ FDate := StrToDate(DateStr, FormatSet);
+ FShortFormat := false;
+ end;
+ end;
+ except
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ end;
+end;
+
+procedure TcpBirthday.SetDate(aDate: TDate);
+begin
+ FDate := aDate;
+end;
+
+{ TcpCalendarLink }
+
+function TcpCalendarLink.AddToXML(Root: TXmlNode): TXmlNode;
+var
+ tmp: string;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetContactNodeName(cp_calendarLink));
+ if FRel <> tc_none then
+ begin
+ tmp := ReplaceStr(GetEnumName(TypeInfo(TCalendarRel), ord(FRel)), '_', '-');
+ Delete(tmp, 1, 3);
+ Result.AttributeAdd(sNodeRelAttr, tmp)
+ end
+ else
+ Result.AttributeAdd(sNodeLabelAttr, FLabel);
+ Result.AttributeAdd(sNodeHrefAttr, FHref);
+ if FPrimary then
+ Result.WriteAttributeBool(sNodePrimaryAttr, FPrimary);
+end;
+
+procedure TcpCalendarLink.Clear;
+begin
+ FLabel := '';
+ FRel := tc_none;
+ FHref := '';
+end;
+
+constructor TcpCalendarLink.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ Clear;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TcpCalendarLink.IsEmpty: boolean;
+begin
+ Result := ((Length(Trim(FLabel)) = 0) or (FRel = tc_none)) and
+ (Length(Trim(FHref)) = 0);
+end;
+
+procedure TcpCalendarLink.ParseXML(const Node: TXmlNode);
+begin
+ if GetContactNodeType(Node.NameUnicode) <> cp_calendarLink then
+ raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_calendarLink)]);
+ try
+ FPrimary := false;
+ FRel := tc_none;
+ if Length(Trim(Node.AttributeByUnicodeName[sNodeRelAttr])) > 0 then
+ begin // считываем данные о rel
+ FRel := TCalendarRel(GetEnumValue(TypeInfo(TCalendarRel),
+ 'tc_' + ReplaceStr((Trim(Node.AttributeByUnicodeName[sNodeRelAttr])),
+ '-', '_')))
+ end
+ else // rel отсутствует, следовательно читаем label
+ FLabel := Trim(Node.AttributeByUnicodeName[sNodeLabelAttr]);
+ if Node.HasAttribute(sNodePrimaryAttr) then
+ FPrimary := Node.ReadAttributeBool(sNodePrimaryAttr);
+ FHref := Node.ReadAttributeString(sNodeHrefAttr);
+ except
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ end;
+end;
+
+function TcpCalendarLink.RelToString: string;
+begin
+ case FRel of
+ tc_none: Result := FLabel; // описание содержится в label - свободный текст
+ tc_work: Result := LoadStr(c_Work);
+ tc_home: Result := LoadStr(c_Home);
+ tc_free_busy: Result := LoadStr(c_FreeBusy);
+ end;
+end;
+
+{ TcpEvent }
+
+function TcpEvent.AddToXML(Root: TXmlNode): TXmlNode;
+var
+ sRel: string;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetContactNodeName(cp_event));
+ if ord(FEventType) > -1 then
+ begin
+ sRel := GetEnumName(TypeInfo(TEventRel), ord(FEventType));
+ Delete(sRel, 1, 2);
+ Result.WriteAttributeString(sNodeRelAttr, sRel);
+ end
+ else
+ begin
+ sRel := GetEnumName(TypeInfo(TEventRel), ord(teOther));
+ Delete(sRel, 1, 2);
+ Result.WriteAttributeString(sNodeRelAttr, sRel);
+ end;
+ if Length(FLabel) > 0 then
+ Result.WriteAttributeString(sNodeLabelAttr, FLabel);
+ FWhen.AddToXML(Result, tdDate);
+end;
+
+procedure TcpEvent.Clear;
+begin
+ FEventType := teNone;
+ FLabel := '';
+end;
+
+constructor TcpEvent.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ Clear;
+ FWhen := TgdWhen.Create;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TcpEvent.IsEmpty: boolean;
+begin
+ Result := (FEventType = teNone) and (Length(Trim(FLabel)) = 0) and
+ (FWhen.IsEmpty)
+end;
+
+procedure TcpEvent.ParseXML(const Node: TXmlNode);
+var
+ WhenNode: TXmlNode;
+ S: String;
+begin
+ if GetContactNodeType(Node.NameUnicode) <> cp_event then
+ raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_event)]);
+ try
+ if Node.HasAttribute(sNodeLabelAttr) then
+ FLabel := Trim(Node.ReadAttributeString(sNodeLabelAttr));
+ if Node.HasAttribute(sNodeRelAttr) then
+ begin
+ S := Trim(Node.ReadAttributeString(sNodeRelAttr));
+ S := StringReplace(S, sSchemaHref, '', [rfIgnoreCase]);
+ FEventType := TEventRel(GetEnumValue(TypeInfo(TEventRel), S));
+ end;
+
+ WhenNode := Node.FindNode(GetGDNodeName(gd_When));
+ if WhenNode <> nil then
+ FWhen := TgdWhen.Create(WhenNode)
+ else
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ except
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ end;
+end;
+
+function TcpEvent.RelToString: string;
+begin
+ case FEventType of
+ teNone: Result := FLabel;
+ teAnniversary: Result := LoadStr(c_EvntAnniv);
+ teOther: Result := LoadStr(c_EvntOther);
+ end;
+end;
+
+{ TcpExternalId }
+
+function TcpExternalId.AddToXML(Root: TXmlNode): TXmlNode;
+var
+ sRel: string;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ if ord(FRel) < 0 then
+ raise ECPException.CreateFmt(sc_ErrWriteNode, [GetContactNodeName(cp_externalId)+ ' ' + Format(sc_WrongAttr, ['rel'])]);
+ Result := Root.NodeNew(GetContactNodeName(cp_externalId));
+ if Trim(FLabel) <> '' then
+ Result.WriteAttributeString(sNodeLabelAttr, FLabel);
+ sRel := GetEnumName(TypeInfo(TExternalIdType), ord(FRel));
+ Delete(sRel, 1, 2);
+ Result.WriteAttributeString(sNodeRelAttr, sRel);
+ Result.WriteAttributeString(sNodeValueAttr, FValue);
+end;
+
+procedure TcpExternalId.Clear;
+begin
+ FRel := tiNone;
+ FLabel := '';
+ FValue := '';
+end;
+
+constructor TcpExternalId.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ Clear;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TcpExternalId.IsEmpty: boolean;
+begin
+ Result := (FRel = tiNone) and (Length(Trim(FLabel)) = 0) and
+ (Length(Trim(FValue)) = 0);
+end;
+
+procedure TcpExternalId.ParseXML(const Node: TXmlNode);
+begin
+ if Node = nil then Exit;
+ if GetContactNodeType(Node.NameUnicode) <> cp_externalId then
+ raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName
+ (cp_externalId)]);
+ try
+ if Node.HasAttribute(sNodeLabelAttr) then
+ FLabel := Node.ReadAttributeString(sNodeLabelAttr);
+ FRel := TExternalIdType(GetEnumValue(TypeInfo(TExternalIdType),
+ 'ti' + Node.ReadAttributeString(sNodeRelAttr)));
+ FValue := Node.ReadAttributeString(sNodeValueAttr);
+ except
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ end;
+end;
+
+function TcpExternalId.RelToString: string;
+begin
+ // TExternalIdType = (tiNone,tiAccount,tiCustomer,tiNetwork,tiOrganization);
+ case FRel of
+ tiNone: Result := FLabel; // rel не определен - берем описание из label
+ tiAccount: Result := LoadStr(c_AccId);
+ tiCustomer: Result := LoadStr(c_AccCostumer);
+ tiNetwork: Result := LoadStr(c_AccNetwork);
+ tiOrganization: Result := LoadStr(c_AccOrg);
+ end;
+end;
+
+{ TcpGender }
+
+function TcpGender.AddToXML(Root: TXmlNode): TXmlNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then Exit;
+ if ord(FValue) < 0 then
+ raise ECPException.CreateFmt(sc_ErrWriteNode, [GetContactNodeName(cp_gender)+' '+
+ Format(sc_WrongAttr, [sNodeValueAttr])]);
+ Result := Root.NodeNew(GetContactNodeName(cp_gender));
+ Result.WriteAttributeString(sNodeValueAttr, GetEnumName
+ (TypeInfo(TGenderType), ord(FValue)));
+end;
+
+procedure TcpGender.Clear;
+begin
+ FValue := none;
+end;
+
+constructor TcpGender.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ Clear;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TcpGender.IsEmpty: boolean;
+begin
+ Result := FValue = none;
+end;
+
+procedure TcpGender.ParseXML(const Node: TXmlNode);
+begin
+ if Node = nil then
+ Exit;
+ if GetContactNodeType(Node.NameUnicode) <> cp_gender then
+ raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_gender)]);
+ try
+ FValue := TGenderType(GetEnumValue(TypeInfo(TGenderType),
+ Node.ReadAttributeString(sNodeValueAttr)));
+ except
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ end;
+end;
+
+function TcpGender.ValueToString: string;
+begin
+ case FValue of
+ none:
+ Result := '';
+ male:
+ Result := LoadStr(c_Male);
+ female:
+ Result := LoadStr(c_Female);
+ end;
+end;
+
+{ TcpGroupMembershipInfo }
+
+function TcpGroupMembershipInfo.AddToXML(Root: TXmlNode): TXmlNode;
+begin
+ Result := nil;
+ if (Root = nil) or (IsEmpty) then
+ Exit;
+ Result := Root.NodeNew(GetContactNodeName(cp_groupMembershipInfo));
+ Result.WriteAttributeString(sNodeHrefAttr, FHref);
+ Result.WriteAttributeBool(sNodeDeletedAttr, FDeleted);
+end;
+
+procedure TcpGroupMembershipInfo.Clear;
+begin
+ FHref := '';
+end;
+
+constructor TcpGroupMembershipInfo.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ Clear;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TcpGroupMembershipInfo.IsEmpty: boolean;
+begin
+ Result := Length(Trim(FHref)) = 0
+end;
+
+procedure TcpGroupMembershipInfo.ParseXML(const Node: TXmlNode);
+begin
+ if Node = nil then
+ Exit;
+ if GetContactNodeType(Node.NameUnicode) <> cp_groupMembershipInfo then
+ raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName
+ (cp_groupMembershipInfo)]);
+ try
+ FHref := Node.ReadAttributeString(sNodeHrefAttr);
+ FDeleted := Node.ReadAttributeBool(sNodeDeletedAttr)
+ except
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ end;
+end;
+
+{ TcpJot }
+
+function TcpJot.AddToXML(Root: TXmlNode): TXmlNode;
+var
+ sRel: string;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetContactNodeName(cp_jot));
+ if FRel <> TjNone then
+ begin
+ sRel := GetEnumName(TypeInfo(TJotRel), ord(FRel));
+ Delete(sRel, 1, 2);
+ Result.WriteAttributeString(sNodeRelAttr, sRel);
+ end;
+ Result.ValueAsUnicodeString := FText;
+end;
+
+procedure TcpJot.Clear;
+begin
+ FRel := TjNone;
+ FText := '';
+end;
+
+constructor TcpJot.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ Clear;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TcpJot.IsEmpty: boolean;
+begin
+ Result := (FRel = TjNone) and (Length(Trim(FText)) = 0);
+end;
+
+procedure TcpJot.ParseXML(const Node: TXmlNode);
+begin
+ if Node = nil then
+ Exit;
+ if GetContactNodeType(Node.NameUnicode) <> cp_jot then
+ raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_jot)]);
+ try
+ FRel := TJotRel(GetEnumValue(TypeInfo(TJotRel),
+ 'Tj' + Node.ReadAttributeString(sNodeRelAttr)));
+ FText := Node.ValueAsUnicodeString;
+ except
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ end;
+end;
+
+function TcpJot.RelToString: string;
+begin
+ case FRel of
+ TjNone:
+ Result := ''; // не определенное значение
+ Tjhome:
+ Result := LoadStr(c_JotHome);
+ Tjwork:
+ Result := LoadStr(c_JotWork);
+ Tjother:
+ Result := LoadStr(c_JotOther);
+ Tjkeywords:
+ Result := LoadStr(c_JotKeywords);
+ Tjuser:
+ Result := LoadStr(c_JotUser);
+ end;
+end;
+
+{ TcpLanguage }
+
+function TcpLanguage.AddToXML(Root: TXmlNode): TXmlNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetContactNodeName(cp_language));
+ Result.WriteAttributeString(sNodeCodeAttr, Fcode);
+ Result.WriteAttributeString(sNodeLabelAttr, FLabel);
+end;
+
+procedure TcpLanguage.Clear;
+begin
+ Fcode := '';
+ FLabel := '';
+end;
+
+constructor TcpLanguage.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ Clear;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TcpLanguage.IsEmpty: boolean;
+begin
+ Result := (Length(Trim(Fcode)) = 0) and (Length(Trim(FLabel)) = 0);
+end;
+
+procedure TcpLanguage.ParseXML(const Node: TXmlNode);
+begin
+ if Node = nil then
+ Exit;
+ if GetContactNodeType(Node.NameUnicode) <> cp_language then
+ raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_language)]);
+ try
+ Fcode := Node.ReadAttributeString(sNodeCodeAttr);
+ FLabel := Node.ReadAttributeString(sNodeLabelAttr);
+ except
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ end;
+end;
+
+{ TcpPriority }
+
+function TcpPriority.AddToXML(Root: TXmlNode): TXmlNode;
+var
+ sRel: string;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetContactNodeName(cp_priority));
+ sRel := GetEnumName(TypeInfo(TPriotityRel), ord(FRel));
+ Delete(sRel, 1, 2);
+ Result.WriteAttributeString(sNodeRelAttr, sRel);
+end;
+
+procedure TcpPriority.Clear;
+begin
+ FRel := TpNone;
+end;
+
+constructor TcpPriority.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ Clear;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TcpPriority.IsEmpty: boolean;
+begin
+ Result := FRel = TpNone;
+end;
+
+procedure TcpPriority.ParseXML(const Node: TXmlNode);
+begin
+ if Node = nil then
+ Exit;
+ if GetContactNodeType(Node.NameUnicode) <> cp_priority then
+ raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_priority)]);
+ try
+ FRel := TPriotityRel(GetEnumValue(TypeInfo(TPriotityRel),
+ 'Tp' + Node.ReadAttributeString(sNodeRelAttr)));
+ except
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ end;
+end;
+
+function TcpPriority.RelToString: string;
+begin
+ case FRel of
+ TpNone:
+ Result := ''; // значение не определено
+ Tplow:
+ Result := LoadStr(c_PriorityLow);
+ Tpnormal:
+ Result := LoadStr(c_PriorityNormal);
+ Tphigh:
+ Result := LoadStr(c_PriorityHigh);
+ end;
+end;
+
+{ TcpRelation }
+
+function TcpRelation.AddToXML(Root: TXmlNode): TXmlNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetContactNodeName(cp_relation));
+ if FRealition = tr_None then
+ Result.WriteAttributeString(sNodeLabelAttr, FLabel)
+ else
+ Result.WriteAttributeString(sNodeRelAttr, GetRelStr(FRealition));
+ Result.ValueAsUnicodeString := FValue;
+end;
+
+procedure TcpRelation.Clear;
+begin
+ FValue := '';
+ FLabel := '';
+ FRealition := tr_None;
+end;
+
+constructor TcpRelation.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ Clear;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TcpRelation.GetRelStr(aRel: TRelationType): string;
+begin
+ Result := GetEnumName(TypeInfo(TRelationType), ord(aRel));
+ Delete(Result, 1, 3);
+ Result := StringReplace(Result, '_', '-', [rfReplaceAll])
+end;
+
+function TcpRelation.IsEmpty: boolean;
+begin
+ Result := (Length(Trim(FLabel)) = 0) and (Length(Trim(FValue)) = 0) and
+ (FRealition = tr_None);
+end;
+
+procedure TcpRelation.ParseXML(const Node: TXmlNode);
+var
+ tmp: string;
+begin
+ if Node = nil then
+ Exit;
+ if GetContactNodeType(Node.NameUnicode) <> cp_relation then
+ raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_relation)]);
+ try
+ if Node.HasAttribute(sNodeRelAttr) then
+ begin
+ tmp := 'tr_' + ReplaceStr(Node.ReadAttributeString(sNodeRelAttr), '-',
+ '_');
+ FRealition := TRelationType(GetEnumValue(TypeInfo(TRelationType), tmp))
+ end
+ else
+ begin
+ FLabel := Node.ReadAttributeString(sNodeLabelAttr);
+ FRealition := tr_None;
+ end;
+ FValue := Node.ValueAsUnicodeString;
+ except
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ end;
+end;
+
+function TcpRelation.RelToString: string;
+begin
+ case FRealition of
+ tr_None:
+ Result := ''; // не определено
+ tr_assistant:
+ Result := LoadStr(c_RelationAssistant);
+ tr_brother:
+ Result := LoadStr(c_RelationBrother);
+ tr_child:
+ Result := LoadStr(c_RelationChild);
+ tr_domestic_partner:
+ Result := LoadStr(c_RelationDomestPart);
+ tr_father:
+ Result := LoadStr(c_RelationFather);
+ tr_friend:
+ Result := LoadStr(c_RelationFriend);
+ tr_manager:
+ Result := LoadStr(c_RelationManager);
+ tr_mother:
+ Result := LoadStr(c_RelationMother);
+ tr_parent:
+ Result := LoadStr(c_RelationPartner);
+ tr_partner:
+ Result := LoadStr(c_RelationPartner);
+ tr_referred_by:
+ Result := LoadStr(c_RelationReffered);
+ tr_relative:
+ Result := LoadStr(c_RelationRelative);
+ tr_sister:
+ Result := LoadStr(c_RelationSister);
+ tr_spouse:
+ Result := LoadStr(c_RelationSpouse);
+ end;
+end;
+
+{ TcpSensitivity }
+
+function TcpSensitivity.AddToXML(Root: TXmlNode): TXmlNode;
+var
+ sRel: string;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ if ord(FRel) < 0 then
+ raise ECPException.CreateFmt(sc_ErrWriteNode, [GetContactNodeName(cp_sensitivity) + ' ' + Format(sc_WrongAttr, ['rel'])]);
+ Result := Root.NodeNew(GetContactNodeName(cp_sensitivity));
+ sRel := GetEnumName(TypeInfo(TSensitivityRel), ord(FRel));
+ Delete(sRel, 1, 2);
+ Result.WriteAttributeString(sNodeRelAttr, sRel);
+end;
+
+procedure TcpSensitivity.Clear;
+begin
+ FRel := TsNone;
+end;
+
+constructor TcpSensitivity.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ Clear;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TcpSensitivity.IsEmpty: boolean;
+begin
+ Result := FRel = TsNone;
+end;
+
+procedure TcpSensitivity.ParseXML(const Node: TXmlNode);
+begin
+ if Node = nil then
+ Exit;
+ if GetContactNodeType(Node.NameUnicode) <> cp_sensitivity then
+ raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName
+ (cp_sensitivity)]);
+ try
+ FRel := TSensitivityRel(GetEnumValue(TypeInfo(TSensitivityRel),
+ 'Ts' + Node.ReadAttributeString(sNodeRelAttr)));
+ except
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ end;
+end;
+
+function TcpSensitivity.RelToString: string;
+begin
+ case FRel of
+ TsNone:
+ Result := '';
+ Tsconfidential:
+ Result := LoadStr(c_SensitivConf);
+ Tsnormal:
+ Result := LoadStr(c_SensitivNormal);
+ Tspersonal:
+ Result := LoadStr(c_SensitivPersonal);
+ Tsprivate:
+ Result := LoadStr(c_SensitivPrivate);
+ end;
+end;
+
+{ TsystemGroup }
+
+function TcpSystemGroup.AddToXML(Root: TXmlNode): TXmlNode;
+var
+ tmp: string;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then Exit;
+ if FIdRel = tg_None then
+ raise ECPException.CreateFmt(sc_ErrWriteNode, [GetContactNodeName(cp_systemGroup)+ ' ' + Format(sc_WrongAttr, ['id'])]);
+ Result := Root.NodeNew(GetContactNodeName(cp_systemGroup));
+ tmp := GetEnumName(TypeInfo(TcpSysGroupId), ord(FIdRel));
+ Delete(tmp, 1, 3);
+ Result.WriteAttributeString('id', tmp);
+end;
+
+procedure TcpSystemGroup.Clear;
+begin
+ FIdRel := tg_None;
+end;
+
+constructor TcpSystemGroup.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ Clear;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TcpSystemGroup.IsEmpty: boolean;
+begin
+ Result := FIdRel = tg_None;
+end;
+
+procedure TcpSystemGroup.ParseXML(const Node: TXmlNode);
+begin
+ if (Node = nil) then
+ Exit;
+ if GetContactNodeType(Node.NameUnicode) <> cp_systemGroup then
+ raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName
+ (cp_systemGroup)]);
+ try
+ FIdRel := TcpSysGroupId(GetEnumValue(TypeInfo(TcpSysGroupId),
+ 'tg_' + Node.ReadAttributeString('id')));
+ except
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ end;
+end;
+
+function TcpSystemGroup.RelToString: string;
+begin
+ case FIdRel of
+ tg_None:
+ Result := ''; // значение не определено
+ tg_Contacts:
+ Result := LoadStr(c_SysGroupContacts);
+ tg_Friends:
+ Result := LoadStr(c_SysGroupFriends);
+ tg_Family:
+ Result := LoadStr(c_SysGroupFamily);
+ tg_Coworkers:
+ Result := LoadStr(c_SysGroupCoworkers);
+ end;
+end;
+
+{ TcpUserDefinedField }
+
+function TcpUserDefinedField.AddToXML(Root: TXmlNode): TXmlNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetContactNodeName(cp_userDefinedField));
+ Result.WriteAttributeString(sNodeKeyAttr, FKey);
+ Result.WriteAttributeString(sNodeValueAttr, FValue);
+end;
+
+procedure TcpUserDefinedField.Clear;
+begin
+ FKey := '';
+ FValue := '';
+end;
+
+constructor TcpUserDefinedField.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ Clear;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TcpUserDefinedField.IsEmpty: boolean;
+begin
+ Result := (Length(Trim(FKey)) = 0) and (Length(Trim(FValue)) = 0)
+end;
+
+procedure TcpUserDefinedField.ParseXML(const Node: TXmlNode);
+begin
+ if Node = nil then
+ Exit;
+ if GetContactNodeType(Node.NameUnicode) <> cp_userDefinedField then
+ raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName
+ (cp_userDefinedField)]);
+ try
+ FKey := Node.ReadAttributeString(sNodeKeyAttr);
+ FValue := Node.ReadAttributeString(sNodeValueAttr);
+ except
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ end;
+end;
+
+{ TcpWebsite }
+
+function TcpWebsite.AddToXML(Root: TXmlNode): TXmlNode;
+var
+ tmp: string;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ if FRel = tw_None then
+ raise ECPException.CreateFmt(sc_ErrWriteNode, [GetContactNodeName(cp_website)+' '+Format(sc_WrongAttr, ['rel'])]);
+ Result := Root.NodeNew(GetContactNodeName(cp_website));
+ Result.WriteAttributeString(sNodeHrefAttr, FHref);
+
+ tmp := GetEnumName(TypeInfo(TWebSiteType), ord(FRel));
+ Delete(tmp, 1, 3);
+ tmp := ReplaceStr(tmp, '_', '-');
+ Result.WriteAttributeString(sNodeRelAttr, tmp);
+
+ if FPrimary then
+ Result.WriteAttributeBool(sNodePrimaryAttr, FPrimary);
+ if Trim(FLabel) <> '' then
+ Result.WriteAttributeString(sNodeLabelAttr, FLabel);
+end;
+
+procedure TcpWebsite.Clear;
+begin
+ FHref := '';
+ FLabel := '';
+ FRel := tw_None;
+end;
+
+constructor TcpWebsite.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ Clear;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TcpWebsite.IsEmpty: boolean;
+begin
+ Result := (Length(Trim(FHref)) = 0) and (Length(Trim(FLabel)) = 0) and
+ (FRel = tw_None)
+end;
+
+procedure TcpWebsite.ParseXML(const Node: TXmlNode);
+var
+ tmp: string;
+begin
+ if (Node = nil) then
+ Exit;
+ if GetContactNodeType(Node.NameUnicode) <> cp_website then
+ raise ECPException.CreateFmt(sc_ErrCompNodes, [GetContactNodeName(cp_website)]);
+ try
+ FRel := tw_None;
+ FHref := Node.ReadAttributeString(sNodeHrefAttr);
+ tmp := ReplaceStr(Node.ReadAttributeString(sNodeRelAttr), sSchemaHref, '');
+ tmp := 'tw_' + ReplaceStr(tmp, '-', '_');
+ FRel := TWebSiteType(GetEnumValue(TypeInfo(TWebSiteType), tmp));
+ if Node.HasAttribute(sNodeLabelAttr) then
+ FLabel := Node.ReadAttributeString(sNodeLabelAttr);
+ if Node.HasAttribute(sNodePrimaryAttr) then
+ FPrimary := Node.ReadAttributeBool(sNodePrimaryAttr);
+ except
+ ECPException.CreateFmt(sc_ErrPrepareNode, [Node.Name]);
+ end;
+end;
+
+function TcpWebsite.RelToString: string;
+begin
+ case FRel of
+ tw_None:
+ Result := ''; // значение не определено
+ tw_Home_Page:
+ Result := LoadStr(c_WebsiteHomePage);
+ tw_Blog:
+ Result := LoadStr(c_WebsiteBlog);
+ tw_Profile:
+ Result := LoadStr(c_WebsiteProfile);
+ tw_Home:
+ Result := LoadStr(c_WebsiteHome);
+ tw_Work:
+ Result := LoadStr(c_WebsiteWork);
+ tw_Other:
+ Result := LoadStr(c_WebsiteOther);
+ tw_Ftp:
+ Result := LoadStr(c_WebsiteFtp);
+ end;
+end;
+
+{ TContact }
+
+procedure TContact.Clear;
+begin
+ FEtag := '';
+ FId := '';
+ FUpdated := 0;
+ FTitle.Clear;
+ FContent.Clear;
+ FLinks.Clear;
+ FName.Clear;
+ FNickName.Clear;
+ FBirthDay.Clear;
+ FOrganization.Clear;
+ FEmails.Clear;
+ FPhones.Clear;
+ FPostalAddreses.Clear;
+ FEvents.Clear;
+ FRelations.Clear;
+ FUserFields.Clear;
+ FWebSites.Clear;
+ FGroupMemberships.Clear;
+ FIMs.Clear;
+end;
+
+constructor TContact.Create(byNode: TXmlNode);
+begin
+ inherited Create();
+ FLinks := TList.Create;
+ FEmails := TList.Create;
+ FPhones := TList.Create;
+ FPostalAddreses := TList.Create;
+ FEvents := TList.Create;
+ FRelations := TList.Create;
+ FUserFields := TList.Create;
+ FWebSites := TList.Create;
+ FIMs := TList.Create;
+ FGroupMemberships := TList.Create;
+ FOrganization := TgdOrganization.Create();
+ FTitle := TTextTag.Create();
+ FContent := TTextTag.Create();
+ FName := TgdName.Create();
+ FNickName := TcpNickname.Create();
+ FBirthDay := TcpBirthday.Create(nil);
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+destructor TContact.Destroy;
+begin
+ FreeAndNil(FTitle);
+ FreeAndNil(FContent);
+ FreeAndNil(FLinks);
+ FreeAndNil(FName);
+ FreeAndNil(FNickName);
+ FreeAndNil(FBirthDay);
+ FreeAndNil(FOrganization);
+ FreeAndNil(FEmails);
+ FreeAndNil(FPhones);
+ FreeAndNil(FPostalAddreses);
+ FreeAndNil(FEvents);
+ FreeAndNil(FRelations);
+ FreeAndNil(FUserFields);
+ FreeAndNil(FWebSites);
+ FreeAndNil(FGroupMemberships);
+ FreeAndNil(FIMs);
+ inherited Destroy;
+end;
+
+function TContact.FindEmail(const aEmail: string; out Index: integer): TgdEmail;
+var
+ I: integer;
+begin
+ Result := nil;
+ for I := 0 to FEmails.Count - 1 do
+ begin
+ if UpperCase(aEmail) = UpperCase(FEmails[I].Address) then
+ begin
+ Result := FEmails[I];
+ Index := I;
+ break;
+ end;
+ end;
+end;
+
+function TContact.GenerateText(TypeFile: TFileType): string;
+var
+ Doc: TNativeXml;
+ I: integer;
+ Node: TXmlNode;
+begin
+ try
+ Node := nil;
+ if IsEmpty then
+ Exit;
+ Doc := TNativeXml.Create;
+ Doc.EncodingString := sDefoultEncoding;
+ case TypeFile of
+ tfAtom:
+ begin
+ Doc.CreateName(sAtomAlias + sEntryNodeName);
+ Doc.Root.WriteAttributeString('xmlns:atom',
+ 'http://www.w3.org/2005/Atom');
+ Node := Doc.Root.NodeNew(sAtomAlias + 'category');
+ end;
+ tfXML:
+ begin
+ Doc.CreateName(sEntryNodeName);
+ Doc.Root.WriteAttributeString('xmlns', 'http://www.w3.org/2005/Atom');
+ Node := Doc.Root.NodeNew('category');
+ end;
+ end;
+ Doc.Root.WriteAttributeString('xmlns:gd',
+ 'http://schemas.google.com/g/2005');
+ Doc.Root.WriteAttributeString('xmlns:gContact',
+ 'http://schemas.google.com/contact/2008');
+ Node.WriteAttributeString('scheme',
+ 'http://schemas.google.com/g/2005#kind');
+ Node.WriteAttributeString('term',
+ 'http://schemas.google.com/contact/2008#contact');
+
+ FTitle.AddToXML(Doc.Root);
+
+ for I := 0 to FLinks.Count - 1 do
+ FLinks[I].AddToXML(Doc.Root);
+ for I := 0 to FEmails.Count - 1 do
+ FEmails[I].AddToXML(Doc.Root);
+ for I := 0 to FPhones.Count - 1 do
+ FPhones[I].AddToXML(Doc.Root);
+ for I := 0 to FPostalAddreses.Count - 1 do
+ FPostalAddreses[I].AddToXML(Doc.Root);
+ for I := 0 to FIMs.Count - 1 do
+ FIMs[I].AddToXML(Doc.Root);
+ // GContact
+ for I := 0 to FEvents.Count - 1 do
+ FEvents[I].AddToXML(Doc.Root);
+ for I := 0 to FRelations.Count - 1 do
+ FRelations[I].AddToXML(Doc.Root);
+ for I := 0 to FUserFields.Count - 1 do
+ FUserFields[I].AddToXML(Doc.Root);
+ for I := 0 to FWebSites.Count - 1 do
+ FWebSites[I].AddToXML(Doc.Root);
+ for I := 0 to FGroupMemberships.Count - 1 do
+ FGroupMemberships[I].AddToXML(Doc.Root);
+
+ FContent.AddToXML(Doc.Root);
+ FName.AddToXML(Doc.Root);
+ FNickName.AddToXML(Doc.Root);
+ FOrganization.AddToXML(Doc.Root);
+ FBirthDay.AddToXML(Doc.Root);
+ Result := string(Doc.Root.WriteToString);
+ finally
+ FreeAndNil(Doc)
+ end;
+end;
+
+function TContact.GetContactName: string;
+begin
+ Result := CpDefaultCName;
+ if FTitle.IsEmpty then
+ if PrimaryEmail <> '' then
+ Result := PrimaryEmail
+ else if not FNickName.IsEmpty then
+ Result := FNickName.Value
+ else
+ Result := CpDefaultCName
+ else
+ Result := FTitle.Value
+end;
+
+function TContact.GetOrganization: TgdOrganization;
+begin
+ Result := TgdOrganization.Create();
+ if FOrganization <> nil then
+ Result := FOrganization
+ else
+ begin
+ Result.OrgName := TTextTag.Create();
+ Result.OrgTitle := TTextTag.Create();
+ end;
+end;
+
+function TContact.GetPrimaryEmail: string;
+var
+ I: integer;
+begin
+ Result := '';
+ if FEmails = nil then
+ Exit;
+ if FEmails.Count = 0 then
+ Exit;
+ Result := FEmails[0].Address;
+ for I := 0 to FEmails.Count - 1 do
+ begin
+ if FEmails[I].Primary then
+ begin
+ Result := FEmails[I].Address;
+ break;
+ end;
+ end;
+end;
+
+function TContact.IsEmpty: boolean;
+begin
+ Result := FTitle.IsEmpty and FContent.IsEmpty and FName.IsEmpty and FNickName.
+ IsEmpty and FBirthDay.IsEmpty and FOrganization.IsEmpty and
+ (FEmails.Count = 0) and (FPhones.Count = 0) and (FPostalAddreses.Count = 0)
+ and (FEvents.Count = 0) and (FRelations.Count = 0) and
+ (FUserFields.Count = 0) and (FWebSites.Count = 0) and
+ (FGroupMemberships.Count = 0) and (FIMs.Count = 0);
+end;
+
+procedure TContact.LoadFromFile(const FileName: string);
+var
+ XML: TNativeXml;
+begin
+ try
+ XML := TNativeXml.Create;
+ XML.LoadFromFile(FileName);
+ if (not XML.IsEmpty) and ((LowerCase(XML.Root.NameUnicode) = LowerCase
+ (sAtomAlias + sEntryNodeName)) or (LowerCase(XML.Root.NameUnicode)
+ = LowerCase(sEntryNodeName))) then
+ ParseXML(XML.Root);
+ finally
+ FreeAndNil(XML)
+ end;
+end;
+
+procedure TContact.ParseXML(Stream: TStream);
+var
+ XMLDoc: TNativeXml;
+begin
+ if Stream = nil then
+ Exit;
+ if Stream.Size = 0 then
+ Exit;
+ XMLDoc := TNativeXml.Create;
+ try
+ try
+ XMLDoc.LoadFromStream(Stream);
+ ParseXML(XMLDoc.Root);
+ except
+ Exit;
+ end;
+ finally
+ FreeAndNil(XMLDoc)
+ end;
+end;
+
+procedure TContact.ParseXML(Node: TXmlNode);
+var
+ I: integer;
+ List: TXmlNodeList;
+begin
+ try
+ if Node = nil then Exit;
+ FEtag := Node.ReadAttributeString(gdNodeAlias + 'etag');
+ List := TXmlNodeList.Create;
+// Node.NodesByName('id', List);
+// for I := 0 to List.Count - 1 do {!!!!!!!!!!}
+// FId :=List.Items[I].ValueAsUnicodeString;
+
+ FId := Node.NodeByName('id').ValueAsUnicodeString;
+
+ Node.NodesByName(GetGDNodeName(gd_Email), List);
+ for I := 0 to List.Count - 1 do
+ FEmails.Add(TgdEmail.Create(List.Items[I]));
+
+ Node.NodesByName(GetGDNodeName(gd_PhoneNumber), List);
+ for I := 0 to List.Count - 1 do
+ FPhones.Add(TgdPhoneNumber.Create(List.Items[I]));
+
+ Node.NodesByName(GetGDNodeName(gd_Im), List);
+ for I := 0 to List.Count - 1 do
+ FIMs.Add(TgdIm.Create(List.Items[I]));
+
+ Node.NodesByName(GetGDNodeName(gd_StructuredPostalAddress), List);
+ for I := 0 to List.Count - 1 do
+ FPostalAddreses.Add(TgdStructuredPostalAddress.Create(List.Items[I]));
+
+ Node.NodesByName(GetContactNodeName(cp_event), List);
+ for I := 0 to List.Count - 1 do
+ FEvents.Add(TcpEvent.Create(List.Items[I]));
+
+ Node.NodesByName(GetContactNodeName(cp_relation), List);
+ for I := 0 to List.Count - 1 do
+ FRelations.Add(TcpRelation.Create(List.Items[I]));
+
+ Node.NodesByName(GetContactNodeName(cp_userDefinedField), List);
+ for I := 0 to List.Count - 1 do
+ FUserFields.Add(TcpUserDefinedField.Create(List.Items[I]));
+
+ Node.NodesByName(GetContactNodeName(cp_website), List);
+ for I := 0 to List.Count - 1 do
+ FWebSites.Add(TcpWebsite.Create(List.Items[I]));
+
+ Node.NodesByName(GetContactNodeName(cp_groupMembershipInfo), List);
+ for I := 0 to List.Count - 1 do
+ FGroupMemberships.Add(TcpGroupMembershipInfo.Create(List.Items[I]));
+
+ Node.NodesByName('link', List);
+ for I := 0 to List.Count - 1 do
+ FLinks.Add(TEntryLink.Create(List.Items[I]));
+
+ for I := 0 to Node.NodeCount - 1 do
+ begin
+ // CpAtomAlias
+ if (LowerCase(Node.Nodes[I].NameUnicode) = 'updated') or
+ (LowerCase(Node.Nodes[I].NameUnicode) = LowerCase
+ (sAtomAlias + 'updated')) then
+ FUpdated := ServerDateToDateTime(Node.Nodes[I].ValueAsUnicodeString)
+ else if (LowerCase(Node.Nodes[I].NameUnicode) = 'title') or
+ (LowerCase(Node.Nodes[I].NameUnicode) = LowerCase(sAtomAlias + 'title')
+ ) then
+ FTitle := TTextTag.Create(Node.Nodes[I])
+ else if (LowerCase(Node.Nodes[I].NameUnicode) = 'content') or
+ (LowerCase(Node.Nodes[I].NameUnicode) = LowerCase
+ (sAtomAlias + 'content')) then
+ FContent := TTextTag.Create(Node.Nodes[I])
+ else if LowerCase(Node.Nodes[I].NameUnicode) = LowerCase
+ (GetGDNodeName(gd_Name)) then
+ FName := TgdName.Create(Node.Nodes[I])
+ else if LowerCase(Node.Nodes[I].NameUnicode) = LowerCase
+ (GetGDNodeName(gd_Organization)) then
+ FOrganization := TgdOrganization.Create(Node.Nodes[I])
+ else if LowerCase(Node.Nodes[I].NameUnicode) = LowerCase
+ (GetContactNodeName(cp_birthday)) then
+ FBirthDay := TcpBirthday.Create(Node.Nodes[I])
+ else if LowerCase(Node.Nodes[I].NameUnicode) = LowerCase
+ (GetContactNodeName(cp_nickname)) then
+ FNickName := TagNickName.Create(Node.Nodes[I]);
+ end;
+ finally
+ FreeAndNil(List)
+ end;
+end;
+
+procedure TContact.SaveToFile(const FileName: string; FileType: TFileType);
+begin
+ TFile.WriteAllText(FileName, GenerateText(FileType));
+end;
+
+procedure TContact.SetPrimaryEmail(aEmail: string);
+var
+ index, I: integer;
+ NewEmail: TgdEmail;
+begin
+ if FindEmail(aEmail, index) = nil then
+ begin
+ NewEmail := TgdEmail.Create();
+ NewEmail.Address := aEmail;
+ NewEmail.Primary := true;
+ NewEmail.Rel := em_other;
+ FEmails.Add(NewEmail);
+ end;
+ for I := 0 to FEmails.Count - 1 do
+ FEmails[I].Primary := (I = index);
+end;
+
+{ TContactGroup }
+
+
+constructor TContactGroup.Create(const byNode: TXmlNode);
+begin
+ inherited Create;
+ FLinks := TList.Create;
+ FExtendedProps:=TgdExtendedProperty.Create();
+ FSystemGroup:=TcpSystemGroup.Create();
+ FSystemGroup.ID:=tg_None;
+ if byNode <> nil then
+ ParseXML(byNode);
+end;
+
+function TContactGroup.GenerateXML(const WintExtended: boolean): TNativeXml;
+var Node,IdNode:TXmlNode;
+begin
+ Result:=TNativeXml.Create;
+ Result.CreateName(sEntryNodeName);
+ Result.Root.WriteAttributeString('xmlns:gd','http://schemas.google.com/g/2005');
+ Result.Root.WriteAttributeString('xmlns','http://www.w3.org/2005/Atom');
+ Result.Root.WriteAttributeString(gdNodeAlias+'etag',FEtag);
+ Node:=Result.Root.NodeNew('category');
+ Node.WriteAttributeString('scheme','http://schemas.google.com/g/2005#kind');
+ Node.WriteAttributeString('term','http://schemas.google.com/g/2005#group');
+ IdNode:=Result.Root.NodeNew('id');
+ idNode.ValueAsUnicodeString:=Fid;
+ FTitle.AddToXML(Result.Root);
+ FContent.AddToXML(Result.Root);
+ if WintExtended then
+ FExtendedProps.AddToXML(Result.Root);
+end;
+
+function TContactGroup.GetContent: string;
+begin
+ Result := FContent.Value;
+end;
+
+function TContactGroup.GetSysGroupId: TcpSysGroupId;
+begin
+ Result := FSystemGroup.ID;
+end;
+
+function TContactGroup.GetTitle: string;
+begin
+ Result := FTitle.Value;
+end;
+
+procedure TContactGroup.ParseXML(Node: TXmlNode);
+var
+ I: integer;
+begin
+ if Node = nil then
+ Exit;
+ FEtag := Node.ReadAttributeString(gdNodeAlias + 'etag');
+ for I := 0 to Node.NodeCount - 1 do
+ begin
+ if Node.Nodes[I].NameUnicode = 'id' then
+ FId := Node.Nodes[I].ValueAsUnicodeString
+ else if Node.Nodes[I].NameUnicode = 'updated' then
+ FUpdate := ServerDateToDateTime(Node.Nodes[I].ValueAsUnicodeString)
+ else if Node.Nodes[I].NameUnicode = 'title' then
+ FTitle := TTextTag.Create(Node.Nodes[I])
+ else if Node.Nodes[I].NameUnicode = 'content' then
+ FContent := TTextTag.Create(Node.Nodes[I])
+ else if Node.Nodes[I].NameUnicode = GetContactNodeName(cp_systemGroup) then
+ FSystemGroup := TcpSystemGroup.Create(Node.Nodes[I])
+ else if Node.Nodes[I].NameUnicode = 'link' then
+ FLinks.Add(TEntryLink.Create(Node.Nodes[I]))
+ else if Node.Nodes[i].NameUnicode=GetGDNodeName(gd_extendedProperty)then
+ FExtendedProps:=TgdExtendedProperty.Create(Node.Nodes[i]);
+ end;
+end;
+
+procedure TContactGroup.SetContent(const aContent: string);
+begin
+ FContent.Value := aContent
+end;
+
+procedure TContactGroup.SetSysGroupId(aSysGroupId: TcpSysGroupId);
+begin
+ FSystemGroup.ID := aSysGroupId;
+end;
+
+procedure TContactGroup.SetTitle(const aTitle: string);
+begin
+ FTitle.Value := aTitle;
+end;
+
+{ TGoogleContact }
+
+function TGoogleContact.AddContact(aContact: TContact): boolean;
+var
+ XML: TNativeXml;
+begin
+ Result := false;
+ if (aContact = nil) Or aContact.IsEmpty then
+ Exit;
+ try
+ XML := TNativeXml.Create;
+ XML.ReadFromString(UTF8String(aContact.ToXMLText[tfAtom]));
+ with THTTPSender.Create('POST', FAuth, CpContactsLink, CpProtocolVer) do
+ begin
+ XML.SaveToStream(Document);
+ if SendRequest then
+ begin
+ Result := (ResultCode = 201);
+ if Result then
+ begin
+ XML.Clear;
+ XML.LoadFromStream(Document);
+ FContacts.Add(TContact.Create(XML.Root))
+ end;
+ end
+ else
+ begin
+ { TODO -oVlad -cbugs : Корректно обработать исключение }
+ ShowMessage(IntToStr(ResultCode) + ' ' + ResultString)
+ end;
+ end;
+ finally
+ FreeAndNil(XML)
+ end;
+end;
+
+function TGoogleContact.DeleteContact(index: integer): boolean;
+begin
+ try
+ Result := false;
+ if (Index < 0) or (Index >= FContacts.Count) then
+ Exit;
+ Result := DeleteContact(FContacts[index]);
+ except
+ Result := false;
+ end;
+end;
+
+function TGoogleContact.AddContactGroup(const aName, aDescription: string)
+ : boolean;
+var
+ XMLDoc: TNativeXml;
+ Node: TXmlNode;
+ Ext: TgdExtendedProperty;
+ List: TStringList;
+begin
+Result:=false;
+List:=TStringList.Create;
+try
+ Ext:=TgdExtendedProperty.Create();
+ Ext.Name:=aDescription;
+ Ext.ChildNodes.Add(TTextTag.Create('info',aDescription));
+ XMLDoc := TNativeXml.Create;
+ XMLDoc.CreateName(sAtomAlias + sEntryNodeName);
+ XMLDoc.Root.WriteAttributeString('xmlns:gd','http://schemas.google.com/g/2005');
+ XMLDoc.Root.WriteAttributeString('xmlns:atom','http://www.w3.org/2005/Atom');
+ Node := XMLDoc.Root.NodeNew(sAtomAlias + 'category');
+ Node.WriteAttributeString('scheme', 'http://schemas.google.com/g/2005#kind');
+ Node.WriteAttributeString('term', 'http://schemas.google.com/contact/2008#group');
+ Node:=XMLDoc.Root.NodeNew(sAtomAlias + 'title');
+ Node.ValueAsUnicodeString:=aName;
+ Ext.AddToXML(XMLDoc.Root);
+
+ with THTTPSender.Create('POST',FAuth,Format(CpGroupLink,[FEmail]),CpProtocolVer)do
+ begin
+ XMLDoc.SaveToStream(Document);
+ if SendRequest then
+ begin
+ Result:=ResultCode=201;
+ if Result then
+ begin
+ XMLDoc.Clear;
+ XMLDoc.LoadFromStream(Document);
+ // если событие определено - отправляем данные
+ if Assigned(FOnBeginParse) then
+ OnBeginParse(T_Group, FGroups.Count+1,FGroups.Count + 1);
+ // парсим группу
+ FGroups.Add(TContactGroup.Create(XMLDoc.Root));
+ // если событие определено - отправляем данные
+ if Assigned(FOnEndParse) then
+ OnEndParse(T_Group, FGroups.Last);
+ end
+ else
+ begin
+ List.LoadFromStream(Document);
+ ShowMessage(List.Text);
+ end;
+ end
+ else
+ ShowMessage(IntToStr(ResultCode)+' '+ResultString);
+ end;
+finally
+ FreeAndNil(Ext);
+ FReeAndNil(XMLDoc);
+ FreeAndNil(List);
+end;
+end;
+
+constructor TGoogleContact.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FMaximumResults := -1;
+ FStartIndex := 1;
+ FUpdatesMin := 0;
+ FShowDeleted := false;
+ FSortOrder := Ts_None;
+ FGroups := TList.Create;
+ FContacts := TList.Create;
+end;
+
+function TGoogleContact.DeleteContact(aContact: TContact): boolean;
+var
+ I, j: integer;
+begin
+ try
+ Result := false;
+ if aContact = nil then
+ Exit;
+
+ if Length(aContact.Etag) > 0 then
+ begin
+ for I := 0 to aContact.FLinks.Count - 1 do
+ begin
+ if LowerCase(aContact.FLinks[I].Rel) = 'edit' then
+ begin
+ with THTTPSender.Create('DELETE', FAuth, aContact.FLinks[I].Href,
+ CpProtocolVer) do
+ begin
+ MimeType := 'application/atom+xml';
+ ExtendedHeaders.Add('If-Match: ' + aContact.Etag);
+ if SendRequest then
+ begin
+ if ResultCode = 200 then
+ begin
+ for j := 0 to FContacts.Count - 1 do
+ if FContacts[I] = aContact then
+ begin
+ FContacts.DeleteRange(I, 1);
+ // удаляем свободный элемент из списка
+ break;
+ end;
+ aContact.Destroy; // удалили из памяти
+ Result := true;
+ end;
+ end
+ else
+ begin
+ { TODO -oVlad -cbugs : Корректно обработать исключение }
+ ShowMessage(IntToStr(ResultCode) + ' ' + ResultString)
+ end;
+ end;
+ break;
+ end;
+ end;
+ end;
+ except
+ Result := false;
+ end;
+end;
+
+function TGoogleContact.DeleteContactGroup(const Index: integer): boolean;
+begin
+ Result:=false;
+ if (Index>=0)and(Index= FContacts.Count) or (index < 0) then
+ Exit;
+ Result := DeletePhoto(FContacts[index])
+end;
+
+function TGoogleContact.DeletePhoto(aContact: TContact): boolean;
+var
+ I: integer;
+begin
+ Result := false;
+ if aContact = nil then
+ Exit;
+ for I := 0 to aContact.FLinks.Count - 1 do
+ begin
+ if (LowerCase(aContact.FLinks[I].Ltype) = sImgRel) and
+ (Length(aContact.FLinks[I].Etag) > 0) then
+ begin
+ with THTTPSender.Create('DELETE', FAuth, aContact.FLinks[I].Href,
+ CpProtocolVer) do
+ begin
+ MimeType := sImgRel;
+ ExtendedHeaders.Add('If-Match: *');
+ if SendRequest then
+ begin
+ Result := ResultCode = 200;
+ if Result then
+ aContact.FLinks[I].Etag := '';
+ end
+ else
+ ShowMessage(IntToStr(ResultCode) + ' ' + ResultString)
+ end;
+ break;
+ end;
+ end;
+end;
+
+destructor TGoogleContact.Destroy;
+var
+ c: TContact;
+ g: TContactGroup;
+begin
+ for g in FGroups do
+ g.Destroy;
+ for c in FContacts do
+ c.Destroy;
+ FContacts.Free;
+ FGroups.Free;
+ inherited Destroy;
+end;
+
+function TGoogleContact.GetContact(GroupName: string; Index: integer): TContact;
+var
+ List: TList;
+begin
+ Result := nil;
+ try
+ List := TList.Create;
+ List := GetContactsByGroup(GroupName);
+ if (Index > List.Count) or (Index < 0) then
+ Exit;
+ Result := TContact.Create();
+ Result := List[index];
+ finally
+ FreeAndNil(List);
+ end;
+end;
+
+function TGoogleContact.GetContactNames: TStrings;
+var
+ I: integer;
+begin
+ Result := TStringList.Create;
+ for I := 0 to FContacts.Count - 1 do
+ Result.Add(FContacts[I].GetContactName);
+end;
+
+function TGoogleContact.GetContactsByGroup(GroupName: string): TList;
+var
+ I, j: integer;
+ GrupLink: string;
+begin
+ Result := TList.Create;
+ GrupLink := GroupLink(GroupName);
+ if GrupLink <> '' then
+ begin
+ for I := 0 to FContacts.Count - 1 do
+ for j := 0 to FContacts[I].FGroupMemberships.Count - 1 do
+ begin
+ if FContacts[I].FGroupMemberships[j].FHref = GrupLink then
+ Result.Add(FContacts[I])
+ end;
+ end;
+end;
+
+function TGoogleContact.GetEditLink(aContact: TContact): string;
+var
+ I: integer;
+begin
+ Result := '';
+ for I := 0 to aContact.FLinks.Count - 1 do
+ if aContact.FLinks[I].Rel = 'edit' then
+ begin
+ Result := aContact.FLinks[I].Href;
+ break;
+ end;
+end;
+
+function TGoogleContact.GetGropsNames: TStrings;
+var
+ I: integer;
+begin
+ Result := TStringList.Create;
+ for I := 0 to FGroups.Count - 1 do
+ Result.Add(FGroups[I].GetTitle);
+end;
+
+function TGoogleContact.GetNextLink(aXMLDoc: TNativeXml): string;
+var
+ I: integer;
+ List: TXmlNodeList;
+begin
+ try
+ if aXMLDoc = nil then
+ Exit;
+ Result := '';
+ List := TXmlNodeList.Create;
+ aXMLDoc.Root.NodesByName('link', List);
+ for I := 0 to List.Count - 1 do
+ begin
+ if List.Items[I].ReadAttributeString(sNodeRelAttr) = 'next' then
+ begin
+ Result := String(List.Items[I].ReadAttributeString(sNodeHrefAttr));
+ break;
+ end;
+ end;
+ finally
+ FreeAndNil(List);
+ end;
+end;
+
+function TGoogleContact.GetTotalCount(aXMLDoc: TNativeXml): integer;
+var Node: TXmlNode;
+begin
+Result := -1;
+ try
+ if aXMLDoc = nil then Exit;
+ // ищем вот такой узел ЧИСЛО
+ Node:=aXMLDoc.Root.NodeByName('openSearch:totalResults');
+ if Node<>nil then
+ Result := Node.ValueAsInteger
+ except
+ {обработать исключение}
+ end;
+end;
+
+function TGoogleContact.GetNextLink(Stream: TStream): string;
+var
+ I: integer;
+ List: TXmlNodeList;
+ XML: TNativeXml;
+begin
+ try
+ if Stream = nil then
+ Exit;
+ XML := TNativeXml.Create;
+ XML.LoadFromStream(Stream);
+ Result := '';
+ List := TXmlNodeList.Create;
+ XML.Root.NodesByName('link', List);
+ for I := 0 to List.Count - 1 do
+ begin
+ if List.Items[I].ReadAttributeString(sNodeRelAttr) = 'next' then
+ begin
+ Result := string(List.Items[I].ReadAttributeString(sNodeHrefAttr));
+ break;
+ end;
+ end;
+ finally
+ FreeAndNil(List);
+ FreeAndNil(XML);
+ end;
+end;
+
+function TGoogleContact.GroupLink(const aGroupName: string): string;
+var
+ I: integer;
+begin
+ Result := '';
+ for I := 0 to FGroups.Count - 1 do
+ begin
+ if UpperCase(aGroupName) = UpperCase(FGroups[I].Title) then
+ begin
+ Result := FGroups[I].FId;
+ break
+ end;
+ end;
+end;
+
+function TGoogleContact.InsertPhotoEtag(aContact: TContact;
+ const Response: TStream): boolean;
+var
+ XML: TNativeXml;
+ I: integer;
+ Etag: string;
+begin
+ Result := false;
+ try
+ if Response = nil then
+ Exit;
+ XML := TNativeXml.Create;
+ try
+ XML.LoadFromStream(Response);
+ except
+ Exit;
+ end;
+ Etag := XML.Root.ReadAttributeString(gdNodeAlias + 'etag');
+ for I := 0 to aContact.FLinks.Count - 1 do
+ begin
+ if aContact.FLinks[I].Ltype = sImgRel then
+ begin
+ aContact.FLinks[I].Etag := Etag;
+ Result := true;
+ break;
+ end;
+ end;
+ finally
+ FreeAndNil(XML)
+ end;
+end;
+
+procedure TGoogleContact.LoadContactsFromFile(const FileName: string);
+var
+ XML: TStringStream;
+begin
+ try
+ XML := TStringStream.Create('', TEncoding.UTF8);
+ XML.LoadFromFile(FileName);
+ ParseXMLContacts(XML);
+ finally
+ FreeAndNil(XML)
+ end;
+end;
+
+function TGoogleContact.ParamsToStr: TStringList;
+var
+ S: string;
+begin
+ Result := TStringList.Create;
+ Result.Delimiter := '&';
+ if FMaximumResults > 0 then
+ Result.Add('max-results=' + IntToStr(FMaximumResults));
+ if FStartIndex > 1 then
+ Result.Add('start-index=' + IntToStr(FStartIndex));
+ if ShowDeleted then
+ Result.Add('showdeleted=true');
+ if FUpdatesMin > 0 then
+ Result.Add('updated-min=' + DateTimeToServerDate(FUpdatesMin));
+ if FSortOrder <> Ts_None then
+ begin
+ S := GetEnumName(TypeInfo(TSortOrder), ord(FSortOrder));
+ Delete(S, 1, 3);
+ Result.Add('sortorder=' + S);
+ end;
+
+end;
+
+procedure TGoogleContact.ParseXMLContacts(const Data: TStream);
+var
+ XMLDoc: TNativeXml;
+ List: TXmlNodeList;
+ I: integer;
+begin
+ try
+ if (Data = nil) then
+ Exit;
+ XMLDoc := TNativeXml.Create;
+ XMLDoc.LoadFromStream(Data);
+ List := TXmlNodeList.Create;
+ XMLDoc.Root.NodesByName(sEntryNodeName, List);
+ for I := 0 to List.Count - 1 do
+ begin
+ // Если событие определено - отправляем данные
+ if Assigned(FOnBeginParse) then
+ OnBeginParse(T_Contact, GetTotalCount(XMLDoc), FContacts.Count + 1);
+ // парсим элемент контакта
+ FContacts.Add(TContact.Create(List.Items[I]));
+ // Если событие определено - отправляем данные. В Element кладем TContact
+ if Assigned(FOnEndParse) then
+ OnEndParse(T_Contact, FContacts.Last)
+ end;
+ finally
+ FreeAndNil(List);
+ FreeAndNil(XMLDoc);
+ end;
+end;
+
+function TGoogleContact.RetriveContactPhoto(index: integer): TJPEGImage;
+begin
+ Result := nil;
+ if (index >= FContacts.Count) or (index < 0) then
+ Exit;
+ Result := RetriveContactPhoto(FContacts[index])
+end;
+
+procedure TGoogleContact.ReadData(Sender: TObject; Reason: THookSocketReason;
+ const Value: String);
+begin
+ if Reason = HR_ReadCount then
+ begin
+ FBytesCount := FBytesCount + StrToInt(Value);
+ if Assigned(FOnReadData) then
+ FOnReadData(FTotalBytes, FBytesCount)
+ end;
+end;
+
+function TGoogleContact.RetriveContactPhoto(aContact: TContact): TJPEGImage;
+var
+ I: integer;
+begin
+ Result := nil;
+ if aContact = nil then
+ Exit;
+ for I := 0 to aContact.FLinks.Count - 1 do
+ begin
+ if (aContact.FLinks[I].Rel = CpPhotoLink) and
+ (Length(aContact.FLinks[I].Etag) > 0) then
+ begin
+ FTotalBytes := 0;
+ FBytesCount := 0;
+ with THTTPSender.Create('GET', FAuth, aContact.FLinks[I].Href,
+ CpProtocolVer) do
+ begin
+ Sock.OnStatus := ReadData; // ставим хук на соккет
+ FTotalBytes := GetLength(aContact.FLinks[I].Href);
+ // получаем размер документа
+ if Assigned(FOnRetriveXML) then
+ FOnRetriveXML(aContact.FLinks[I].Href);
+ MimeType := sDefoultMimeType;
+ if SendRequest and (FTotalBytes > 0) then
+ begin
+ Result := TJPEGImage.Create;
+ Result.LoadFromStream(Document);
+ end
+ else
+ begin
+ { TODO -oVlad -cbugs : Корректно обработать исключение }
+ end;
+ break;
+ end;
+ end;
+ end;
+end;
+
+function TGoogleContact.RetriveContactPhoto(aContact: TContact;
+ DefaultImage: TFileName): TJPEGImage;
+var
+ Img: TJPEGImage;
+begin
+ try
+ Result := nil;
+ if aContact = nil then
+ Exit;
+ if Length(Trim(DefaultImage)) = 0 then
+ raise ECPException.Create(sc_ErrFileNull);
+ if not FileExists(DefaultImage) then
+ raise ECPException.CreateFmt(sc_ErrFileName, [DefaultImage]);
+ Img := TJPEGImage.Create;
+ Result := TJPEGImage.Create;
+ Img := RetriveContactPhoto(aContact);
+ if Img = nil then
+ Result.LoadFromFile(DefaultImage)
+ else
+ Result.Assign(Img);
+ finally
+ FreeAndNil(Img)
+ end;
+end;
+
+function TGoogleContact.RetriveContacts: integer;
+var
+ XMLDoc: TStringStream;
+ NextLink: string;
+ Params: TStringList;
+begin
+ try
+ NextLink := CpContactsLink;
+ Params := TStringList.Create;
+ Params.Assign(ParamsToStr);
+ if Params.Count > 0 then
+ NextLink := NextLink + '?' + Params.DelimitedText;
+
+ XMLDoc := TStringStream.Create('', TEncoding.UTF8);
+ repeat
+ FTotalBytes := 0;
+ FBytesCount := 0;
+
+ with THTTPSender.Create('GET', FAuth, NextLink, CpProtocolVer) do
+ begin
+ Sock.OnStatus := ReadData; // ставим хук на соккет
+ FTotalBytes := GetLength(NextLink); // получаем размер документа
+ // сигналим о начале загрузки
+ if Assigned(FOnRetriveXML) then
+ OnRetriveXML(NextLink);
+ if SendRequest then
+ begin
+ XMLDoc.LoadFromStream(Document);
+ ParseXMLContacts(XMLDoc);
+ NextLink := GetNextLink(XMLDoc);
+ end
+ else
+ begin
+ { TODO -oVlad -cbugs : Корректно обработать исключение }
+ break;
+ end;
+ end;
+ until NextLink = '';
+ Result := FContacts.Count;
+ finally
+ FreeAndNil(XMLDoc);
+ end;
+
+end;
+
+function TGoogleContact.RetriveGroups: integer;
+var
+ XMLDoc: TNativeXml;
+ List: TXmlNodeList;
+ I, Count: integer;
+ NextLink: string;
+begin
+ try
+ FGroups.Clear;
+ NextLink := Format(CpGroupLink, [FEmail]);
+ XMLDoc := TNativeXml.Create;
+ repeat
+ FTotalBytes := 0;
+ FBytesCount := 0;
+ with THTTPSender.Create('GET', FAuth, NextLink, CpProtocolVer) do
+ begin
+ Sock.OnStatus := ReadData; // ставим хук на соккет
+ FTotalBytes := GetLength(NextLink); // получаем размер документа
+ // отправляем сообщение о начале загрузки
+ if Assigned(FOnRetriveXML) then
+ FOnRetriveXML(NextLink);
+ if SendRequest then
+ begin
+ XMLDoc.LoadFromStream(Document);
+ List := TXmlNodeList.Create;
+ XMLDoc.Root.NodesByName(sEntryNodeName, List);
+ Count := GetTotalCount(XMLDoc);
+ if Count=-1 then
+ raise ECPException.CreateFromStream(Document);
+ for I := 0 to List.Count - 1 do
+ begin
+ // если событие определено - отправляем данные
+ if Assigned(FOnBeginParse) then
+ FOnBeginParse(T_Group, Count, FGroups.Count + 1);
+ // парсим группу
+ FGroups.Add(TContactGroup.Create(List.Items[I]));
+ // если событие определено - отправляем данные
+ if Assigned(FOnEndParse) then
+ FOnEndParse(T_Group, FGroups.Last);
+ end;
+ NextLink := GetNextLink(XMLDoc);
+ end
+ else
+ break; { TODO -oVlad -cbugs : Корректно обработать исключение }
+ end;
+ until NextLink = '';
+ Result := FGroups.Count;
+ finally
+ FreeAndNil(XMLDoc);
+ end;
+
+end;
+
+procedure TGoogleContact.SaveContactsToFile(const FileName: string);
+var
+ I: integer;
+ Stream: TStringStream;
+begin
+ try
+ Stream := TStringStream.Create('', TEncoding.UTF8);
+ Stream.WriteString('');
+ Stream.WriteString('');
+ for I := 0 to Contacts.Count - 1 do
+ Stream.WriteString(Contacts[I].ToXMLText[tfXML]);
+ Stream.WriteString('');
+ Stream.SaveToFile(FileName);
+ finally
+ FreeAndNil(Stream)
+ end;
+end;
+
+procedure TGoogleContact.SetAuth(const aAuth: string);
+begin
+ FAuth := aAuth;
+end;
+
+procedure TGoogleContact.SetGmail(const aGMail: string);
+begin
+ FEmail := aGMail;
+end;
+
+procedure TGoogleContact.SetMaximumResults(const Value: integer);
+begin
+ FMaximumResults := Value;
+end;
+
+procedure TGoogleContact.SetShowDeleted(const Value: boolean);
+begin
+ FShowDeleted := Value;
+end;
+
+procedure TGoogleContact.SetSortOrder(const Value: TSortOrder);
+begin
+ FSortOrder := Value;
+end;
+
+procedure TGoogleContact.SetStartIndex(const Value: integer);
+begin
+ FStartIndex := Value;
+end;
+
+procedure TGoogleContact.SetUpdatesMin(const Value: TDateTime);
+begin
+ FUpdatesMin := Value;
+end;
+
+function TGoogleContact.UpdateContact(index: integer): boolean;
+begin
+ Result := false;
+ if (Index > FContacts.Count) Or (FContacts[index].IsEmpty) or (Index < 0) then
+ Exit;
+ UpdateContact(FContacts[index]);
+ Result := true;
+end;
+
+function TGoogleContact.UpdateContactGroup(const Index: integer): boolean;
+begin
+Result:=false;
+ if (Index>=0)and(Index= FContacts.Count) or (index < 0) then
+ Exit;
+ Result := UpdatePhoto(FContacts[index], PhotoFile);
+end;
+
+function TGoogleContact.UpdateContact(aContact: TContact): boolean;
+var
+ Doc: TNativeXml;
+begin
+ Result := false;
+ if (aContact = nil) Or aContact.IsEmpty then
+ Exit;
+ if (Length(aContact.Etag) = 0) then
+ Exit;
+ try
+ Doc := TNativeXml.Create;
+ Doc.ReadFromString(UTF8String(aContact.ToXMLText[tfXML]));
+ with THTTPSender.Create('PUT', FAuth, GetEditLink(aContact), CpProtocolVer)
+ do
+ begin
+ ExtendedHeaders.Add('If-Match: *');
+ Doc.SaveToStream(Document);
+ if SendRequest then
+ begin
+ Result := ResultCode = 200;
+ if Result then
+ begin
+ aContact.Clear;
+ aContact.ParseXML(Document);
+ end;
+ end
+ else
+ ShowMessage(IntToStr(ResultCode) + ' ' + ResultString)
+ end;
+ finally
+ FreeAndNil(Doc)
+ end;
+end;
+
+function TGoogleContact.RetriveContactPhoto(index: integer;
+ DefaultImage: TFileName): TJPEGImage;
+begin
+ Result := nil;
+ if (index >= FContacts.Count) or (index < 0) then
+ Exit;
+ Result := TJPEGImage.Create;
+ Result.Assign(RetriveContactPhoto(index, DefaultImage));
+end;
+
+{ ECPECPException }
+
+constructor ECPException.CreateFromStream(const Document: TStream);
+var Lst: TStringList;
+ Err: string;
+begin
+ Document.Position:=0;
+ Lst:=TStringList.Create;
+ Lst.LoadFromStream(Document);
+ if Pos('html',LowerCase(Lst.Text))>0 then
+ begin
+ Err:=Lst[2];
+ Err:=StringReplace(Err,'','',[rfIgnoreCase]);
+ Err:=StringReplace(Err,'','',[rfIgnoreCase]);
+ end
+ else
+ Err:=Lst.Text;
+ inherited Create(Err);
+end;
+
+end.
diff --git a/source/GData.pas b/source/GData.pas
index ca6ed76..9ab1598 100644
--- a/source/GData.pas
+++ b/source/GData.pas
@@ -1,519 +1,3 @@
-<<<<<<< HEAD
-<<<<<<< HEAD
-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/NMD
unit GData;
interface
@@ -521,7 +5,7 @@ interface
uses strutils, GHelper, XMLIntf,SysUtils, Variants, Classes,
StdCtrls, XMLDoc, xmldom, GDataCommon;
-//
+// элемены протокола
type
TAuthorElement = record
Email: string;
@@ -731,525 +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); //
- 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); //
+ ProcessNode(iNode); // Рекурсия
i := i + 1;
iNode := FCommonElements[i];
end;
@@ -1387,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;
@@ -1539,6 +508,4 @@ procedure TGDElemntList.SetRecord(index: Integer; Ptr: PGDElement);
end;
end;
-end.
->>>>>>> remotes/origin/Vlad55
->>>>>>> remotes/origin/NMD
+end.
\ No newline at end of file
diff --git a/source/GDataCommon.pas b/source/GDataCommon.pas
index 7a49e23..224b641 100644
--- a/source/GDataCommon.pas
+++ b/source/GDataCommon.pas
@@ -1,2479 +1,2479 @@
<<<<<<< HEAD
{ Модуль содержит наиболее общие классы для работы с Google API, а также
=======
-{ Модуль содержит наиболее общие классы для работы с Google API, а также
+{ Модуль содержит наиболее общие классы для работы с Google API, а также
>>>>>>> remotes/origin/master
- классы и методы для работы с основой всех API - GData API.
- Этот содуль должен подключаться в раздел uses всех прочих модулей, реализующих работу
- с различными Google API}
-unit GDataCommon;
-
-interface
-
-uses
- NativeXML, Classes, StrUtils, SysUtils, typinfo,
- uLanguage, GConsts, Generics.Collections, DateUtils, httpsend;
-
-type
-{Class helper для объекта TXMLNode (узел XML-документа)
- применяется для преобразования строк в кодировке UTF-8 (UTF8String) в UnicodeString (string) и наоборот}
- TXMLNode_ = class helper for TXMLNode
- private
- function GetNameUnicode: string;
- procedure SetNodeUnicode(const aName: string);
- function GetAttributeUnicodeValue(index:integer): string;
- procedure SetAttributeUnicodeValue(index:integer; const aValue:string);
- function GetAttributeUnicodeName(index:integer):string;
- procedure SetAttributeUnicodeName(index:integer; aValue:string);
- function GetAttributeByUnicodeName(const aName: string):string;
- procedure SetAttributeByUnicodeName(const aName,aValue: string);
- public
- function NodeNew(const AName: String): TXmlNode;overload;
- function FindNode(const NodeName: String): TXmlNode;overload;
- function ReadAttributeString(const AName: String; const ADefault: String = ''): String; overload;
- procedure AttributeAdd(const AName, AValue: String); overload;
- procedure WriteAttributeString(const AName: String; const AValue: String; const ADefault: String = ''); overload;
- procedure NodesByName(const AName: string; AList: TList);overload;
- property NameUnicode: string read GetNameUnicode write SetNodeUnicode;
- property AttributeUnicodeValue[Index: integer]: String read GetAttributeUnicodeValue write SetAttributeUnicodeValue;
- property AttributeUnicodeName[Index: integer]: String read GetAttributeUnicodeName write SetAttributeUnicodeName;
- property AttributeByUnicodeName[const AName: String]: String read GetAttributeByUnicodeName
- write SetAttributeByUnicodeName;
-end;
-
-
-type
- { Перечислитель, определяющий узлы которые могут содержаться в XML-документе,
- присланном Google и которые могут быть преобразованы классами модуля.
- Например,
- gd_email - определяет узел gd:email, который может быть преобразован с помощью
- класса TgdEmail }
- TgdEnum = (gd_country, gd_additionalName, gd_name, gd_email,
- gd_extendedProperty, gd_geoPt, gd_im, gd_orgName, gd_orgTitle,
- gd_organization, gd_originalEvent, gd_phoneNumber, gd_postalAddress,
- gd_rating, gd_recurrence, gd_reminder, gd_resourceId, gd_when, gd_agent,
- gd_housename, gd_street, gd_pobox, gd_neighborhood, gd_city, gd_subregion,
- gd_region, gd_postcode, gd_formattedAddress, gd_structuredPostalAddress,
- gd_entryLink, gd_where, gd_familyName, gd_givenName, gd_namePrefix,
- gd_nameSuffix, gd_fullName, gd_orgDepartment, gd_orgJobDescription,
- gd_orgSymbol, gd_famileName, gd_eventStatus, gd_visibility,
- gd_transparency, gd_attendeeType, gd_attendeeStatus, gd_comments,
- gd_deleted, gd_feedLink, gd_who, gd_recurrenceException);
-
-type
- {Перечислитель, определяющие все возможные варианты значений для атрибутов Rel
- XML-узла, определяющего событие}
- TEventRel = (ev_None, ev_attendee, ev_organizer, ev_performer, ev_speaker,
- ev_canceled, ev_confirmed, ev_tentative, ev_confidential, ev_default,
- ev_private, ev_public, ev_opaque, ev_transparent, ev_optional, ev_required,
- ev_accepted, ev_declined, ev_invited);
-
- { Классы и структуры общего назначения для парсинга XML-документов.
- Применяются в большинстве API Google и, как правило, узлы в XML-дереве не иеют
- каких-либо префиксов }
-
-type
- { Класс для отправки сообщений по HTTP-протоколу. Содержит необходимые поля и методы для работы с
- интерфейсом Google ClientLogin }
- THTTPSender = class(THTTPSend)
- private
- FMethod: string;
- FURL: string;
- FAuthKey: string;
- FApiVersion: string;
- FExtendedHeaders: TStringList;
- procedure SetApiVersion(const Value: string);
- procedure SetAuthKey(const Value: string);
- procedure SetExtendedHeaders(const Value: TStringList);
- procedure SetMethod(const Value: string);
- procedure SetURL(const Value: string);
- function HeadByName(const aHead: string; aHeaders: TStringList): string;
- procedure AddGoogleHeaders;
- public
- { создает новый экземрляр класса.
- * aMethod - метод, используемый в запросе (GET, POST, PUT и т.д.)
- * aAuthKey - ключ для авторизации, который должен быть предварительно получен,
- с использованием комопнента TGoogleLogin или другим способом
- * aURL - адрес на которые будет отправлен запрос
- * aAPIVersion - текущая версия API к которому будет осуществлен запрос }
- constructor Create(const aMethod, aAuthKey, aURL, aAPIVersion: string);
- {Очищает все поля класса, в т.ч. поля Headers и Cookies родителя}
- procedure Clear;
- {Получает точное значение размера документа, который должен быть скачан из Сети
- с адреса aURL. Результат содержит размер документа, включая заголовки}
- function GetLength(const aURL: string): integer;
- {Отправляет запрос на сервер. True - в случае успешной отправки}
- function SendRequest: boolean;
- property Method: string read FMethod write SetMethod;//метод запроса (GET, POST, PUT и т.д.)
- property URL: string read FURL write SetURL;//URL на который отправляется запрос
- property AuthKey: string read FAuthKey write SetAuthKey;//ключ для авторизации на сервере Google
- property ApiVersion: string read FApiVersion write SetApiVersion;//текущая версия API к которому планируется послать запрос
- property ExtendedHeaders: TStringList read FExtendedHeaders write
- SetExtendedHeaders;//дополнительные заголовки запроса. В этот список НЕ включаются заголовки, относящиеся к авторизации (они заполняются автоматически)
- end;
-
-type
- { Атрибут XML-узла }
- TAttribute = packed record
- Name: string;//имя атрибута
- Value: string;//значение арибута
- end;
-
-type
- { Класс общего назначения, определющий любой XML-узел, который
- содержит значение (текст). }
- TTextTag = class
- private
- FName: string; // название узла
- FValue: string; // значение узла
- FAtributes: TList; // список атрибутов узла
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- Constructor Create(const ByNode: TXMLNode = nil); overload;
- { Конструктор для создания эземпляра класса по известным значениям имени и текста }
- constructor Create(const NodeName: string; NodeValue: string = '');
- overload;
- { Функция возвращает True в случае, если не определено свойство Name или
- не определено значение узла или хотя бы один атрибут }
- function IsEmpty: boolean;
- { Очищает все поля класса }
- procedure Clear;
- { Разбирает узел Node:TXMLNode и заполняет на основании полученных данных поля класса }
- procedure ParseXML(Node: TXMLNode);
- { На основании значений свойств формирует новый XML-узел и помещает его как
- дочерний для узла Root }
- function AddToXML(Root: TXMLNode): TXMLNode;
- { Значение узла }
- property Value: string read FValue write FValue;
- { Название узла }
- property Name: string read FName write FName;
- { Атрибуты узла }
- property Attributes: TListread FAtributes write FAtributes;
- end;
-
-type
- TEntryLink = class
- private
- Frel: string;
- Ftype: string;
- Fhref: string;
- FEtag: string;
- public
- Constructor Create(const ByNode: TXMLNode = nil);
- procedure ParseXML(Node: TXMLNode);
- function AddToXML(Root: TXMLNode): TXMLNode;
- function IsEmpty:boolean;
- procedure Clear;
- property Rel: string read Frel write Frel;
- property Ltype: string read Ftype write Ftype;
- property Href: string read Fhref write Fhref;
- property Etag: string read FEtag write FEtag;
- end;
-
-type
- TAuthorTag = Class
- private
- FAuthor: string;
- FEmail: string;
- FUID: string;
- public
- constructor Create(ByNode: TXMLNode = nil);
- procedure ParseXML(Node: TXMLNode);
- property Author: string read FAuthor write FAuthor;
- property Email: string read FEmail write FEmail;
- end;
-
-type
- {Родительский класс для все классов, определющих значения событие (events)}
- TgdEvent = class
- private
- Frel: TEventRel;
- const
- EvSuffix = 'ev_';//префикс для перечислителя TEventRel
- { на входе имеется строка вида
- 'http://schemas.google.com/g/2005#event.SSSSSS'
- функция определяет тип события TEventRel }
- function StrToRel(const aRel: string): TEventRel;
- { на входе имеем тип события TEventRel
- на выходе строку вида
- 'http://schemas.google.com/g/2005#event.SSSSSS' }
- function RelToStr(aRel: TEventRel): string;
- public
- {Создает пустой экземпляр класса}
- Constructor Create;
- {Очищает поля класса}
- procedure Clear;
- {Проверяет экземпляр класса на "пустоту". Возвращает false, если
- поле FRel = ev_None}
- function IsEmpty: boolean;
- {перевод значения свойства Rel в тескт на языке разработчика}
- function RelToString: string;
- property Rel: TEventRel read Frel write Frel;//атрибут rel XML-узла
- end;
-
-type
- {Класс, определяющий статус события в календаре. Может принимать следующие значения:
- * ev_canceled - событие отменено
- * ev_confirmed - событие подтверждено и запланировано
- * ev_tentative - событие предварительно запланировано}
- TgdEventStatus = class(TgdEvent)
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- Constructor Create(const ByNode: TXMLNode = nil);
- {Разбирает узел Node:TXMLNode и заполняет на основании полученных данных поля класса}
- procedure ParseXML(Node: TXMLNode);
- { На основании значений свойств формирует новый XML-узел и помещает его как
- дочерний для узла Root }
- function AddToXML(Root: TXMLNode): TXMLNode;
- end;
-
- {Класс, определяющий видимость события в календаре для других пользователей. Может принимать следующие значения:
- * ev_confidential - видимо только для приглашенных пользователей.
- * ev_default - свойство видимости наследуется из настоек календаря
- * ev_private - видимо только для создателя
- * ev_public - видимо для всех}
- TgdVisibility = class(TgdEvent)
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- Constructor Create(const ByNode: TXMLNode = nil);
- { Разбирает узел XML и заполняет на основании полученных данных поля класса }
- procedure ParseXML(Node: TXMLNode);
- { На основании значений свойств формирует новый XML-узел и помещает его как
- дочерний для узла Root }
- function AddToXML(Root: TXMLNode): TXMLNode;
- end;
-
-type
- TgdTransparency = class(TgdEvent)
- public
- Constructor Create(const ByNode: TXMLNode = nil);
- procedure ParseXML(Node: TXMLNode);
- function AddToXML(Root: TXMLNode): TXMLNode;
- end;
-
-type
- TgdAttendeeType = class(TgdEvent)
- public
- Constructor Create(const ByNode: TXMLNode = nil);
- procedure ParseXML(Node: TXMLNode);
- function AddToXML(Root: TXMLNode): TXMLNode;
- end;
-
-type
- TgdAttendeeStatus = class(TgdEvent)
- public
- Constructor Create(const ByNode: TXMLNode = nil);
- procedure ParseXML(Node: TXMLNode);
- function AddToXML(Root: TXMLNode): TXMLNode;
- end;
-
-type
- TgdCountry = class
- private
- FCode: string;
- FValue: string;
- public
- Constructor Create(const ByNode: TXMLNode = nil);
- procedure Clear;
- function IsEmpty: boolean;
- procedure ParseXML(Node: TXMLNode);
- function AddToXML(Root: TXMLNode): TXMLNode;
- property Code: string read FCode write FCode;
- property Value: string read FValue write FValue;
- end;
-
-type
- TgdAdditionalName = TTextTag;
- TgdFamilyName = TTextTag;
- TgdGivenName = TTextTag;
- TgdNamePrefix = TTextTag;
- TgdNameSuffix = TTextTag;
- TgdFullName = TTextTag;
- TgdOrgDepartment = TTextTag;
- TgdOrgJobDescription = TTextTag;
- TgdOrgSymbol = TTextTag;
-
-type
- TgdName = class
- private
- FGivenName: TTextTag;
- FAdditionalName: TTextTag;
- FFamilyName: TTextTag;
- FNamePrefix: TTextTag;
- FNameSuffix: TTextTag;
- FFullName: TTextTag;
- function GetFullName: string;
- procedure SetFullName(aFullName: TTextTag);
- procedure SetGivenName(aGivenName: TTextTag);
- procedure SetAdditionalName(aAdditionalName: TTextTag);
- procedure SetFamilyName(aFamilyName: TTextTag);
- procedure SetNamePrefix(aNamePrefix: TTextTag);
- procedure SetNameSuffix(aNameSuffix: TTextTag);
- public
- constructor Create(ByNode: TXMLNode = nil);
- procedure ParseXML(const Node: TXMLNode);
- procedure Clear;
- function IsEmpty: boolean;
- function AddToXML(Root: TXMLNode): TXMLNode;
- property GivenName: TTextTag read FGivenName write SetGivenName;
- property AdditionalName
- : TTextTag read FAdditionalName write SetAdditionalName;
- property FamilyName: TTextTag read FFamilyName write SetFamilyName;
- property NamePrefix: TTextTag read FNamePrefix write SetNamePrefix;
- property NameSuffix: TTextTag read FNameSuffix write SetNameSuffix;
- property FullName: TTextTag read FFullName write SetFullName;
- property FullNameString: string read GetFullName;
- end;
-
-type
- TTypeElement = (em_None, em_home, em_other, em_work);
-
- TgdEmail = class
- private
- FAddress: string;
- Frel: TTypeElement;
- FLabel: string;
- FPrimary: boolean;
- FDisplayName: string;
- public
- constructor Create(ByNode: TXMLNode = nil);
- procedure Clear;
- function IsEmpty: boolean;
- procedure ParseXML(const Node: TXMLNode);
- function AddToXML(Root: TXMLNode): TXMLNode;
- function RelToString: string;
- property Address: string read FAddress write FAddress;
- property Labl: string read FLabel write FLabel;
- property Rel: TTypeElement read Frel write Frel;
- property DisplayName: string read FDisplayName write FDisplayName;
- property Primary: boolean read FPrimary write FPrimary;
- end;
-
-type
- {Класс, описывающие узел GData API gd:extendedProperty, который позволяет хранить ограниченный набор
- пользовательских данных в виде атрибутов узла и дочерних узлов XML-документа}
- TgdExtendedProperty = class
- private
- FName: string;
- FValue: string;
- FChildNodes: TList;
- public
- {Конструктор создает экземпляр класса. Если определен входной параметр
- ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
- Constructor Create(const ByNode: TXMLNode = nil);
- {Разбирает узел Node:TXMLNode и заполняет на основании полученных данных поля класса}
- procedure ParseXML(const Node: TXMLNode);
- { На основании значений свойств формирует новый XML-узел и помещает его как
- дочерний для узла Root }
- function AddToXML(Root: TXMLNode): TXMLNode;
- {Проверяет экземпляр класса на "пустоту". Возвращает false, если
- в классе не определены поля FName и FValue, а также отсутствуют дочерние узлы}
- function IsEmpty: boolean;
- {Очищает поля класса}
- procedure Clear;
- property Name: string read FName write FName; //атрибут name узла
- property Value: string read FValue write FValue;//атрибут value узла
- property ChildNodes: TList read FChildNodes write FChildNodes;//список дочерних текстовых узлов
- end;
-
-type
- TgdGeoPtStruct = record
- Elav: extended;
- Labels: string;
- Lat: extended;
- Lon: extended;
- Time: TDateTime;
- end;
-
-type
- TIMProtocol = (ti_None, ti_AIM, ti_MSN, ti_YAHOO, ti_SKYPE, ti_QQ,
- ti_GOOGLE_TALK, ti_ICQ, ti_JABBER);
- TIMtype = (im_None, im_home, im_netmeeting, im_other, im_work);
-
- TgdIm = class
- private
- FAddress: string;
- FLabel: string;
- FPrimary: boolean;
- FIMProtocol: TIMProtocol;
- FIMType: TIMtype;
- public
- constructor Create(ByNode: TXMLNode = nil);
- procedure ParseXML(const Node: TXMLNode);
- procedure Clear;
- function IsEmpty: boolean;
- function AddToXML(Root: TXMLNode): TXMLNode;
- function ImTypeToString: string;
- function ImProtocolToString: string;
- property Address: string read FAddress write FAddress;
- property iLabel: string read FLabel write FLabel;
- property ImType: TIMtype read FIMType write FIMType;
- property Protocol: TIMProtocol read FIMProtocol write FIMProtocol;
- property Primary: boolean read FPrimary write FPrimary;
- end;
-
- TgdOrgName = TTextTag;
- TgdOrgTitle = TTextTag;
-
-type
- TgdOrganization = class
- private
- FLabel: string;
- Frel: string;
- FPrimary: boolean;
- ForgName: TgdOrgName;
- ForgTitle: TgdOrgTitle;
- public
- constructor Create(ByNode: TXMLNode = nil);
- procedure ParseXML(const Node: TXMLNode);
- function AddToXML(Root: TXMLNode): TXMLNode;
- function IsEmpty: boolean;
- procedure Clear;
- property Labl: string read FLabel write FLabel;
- property Rel: string Read Frel write Frel;
- property Primary: boolean read FPrimary write FPrimary;
- property OrgName: TgdOrgName read ForgName write ForgName;
- property OrgTitle: TgdOrgTitle read ForgTitle write ForgTitle;
- end;
-
-type
- TgdOriginalEventStruct = record
- id: string;
- Href: string;
- end;
-
-type
- TPhonesRel = (tp_None, tp_Assistant, tp_Callback, tp_Car, Tp_Company_main,
- tp_Fax, tp_Home, tp_Home_fax, tp_Isdn, tp_Main, tp_Mobile, tp_Other,
- tp_Other_fax, tp_Pager, tp_Radio, tp_Telex, tp_Tty_tdd, Tp_Work,
- tp_Work_fax, tp_Work_mobile, tp_Work_pager);
-
- TgdPhoneNumber = class
- private
- FPrimary: boolean;
- FLabel: string;
- Frel: TPhonesRel;
- FUri: string;
- FValue: string;
- public
- constructor Create(ByNode: TXMLNode = nil);
- function IsEmpty: boolean;
- procedure Clear;
- procedure ParseXML(const Node: TXMLNode);
- function AddToXML(Root: TXMLNode): TXMLNode;
- function RelToString: string;
- property Primary: boolean read FPrimary write FPrimary;
- property Labl: string read FLabel write FLabel;
- property Rel: TPhonesRel read Frel write Frel;
- property Uri: string read FUri write FUri;
- property Text: string read FValue write FValue;
- end;
-
-type
- TgdPostalAddressStruct = record
- Labels: string;
- Rel: string;
- Primary: boolean;
- Text: string;
- end;
-
-type
- TgdRatingStruct = record
- Average: extended;
- Max: integer;
- Min: integer;
- numRaters: integer;
- Rel: string;
- Value: integer;
- end;
-
-type
- TgdRecurrence = class
- private
- FText: TStringList;
- public
- Constructor Create(const ByNode: TXMLNode = nil);
- procedure Clear;
- function IsEmpty: boolean;
- procedure ParseXML(Node: TXMLNode);
- function AddToXML(Root: TXMLNode): TXMLNode;
- property Text: TStringList read FText write FText;
- end;
-
- { TODO -oVlad -cBug : Переделать: добавить "неопределенное значение" в типы. Убрать константы }
-const
- cMethods: array [0 .. 2] of string = ('alert', 'email', 'sms');
-
-type
- TMethod = (tmAlert, tmEmail, tmSMS);
- TRemindPeriod = (tpDays, tpHours, tpMinutes);
-
-type
- TgdReminder = class(TPersistent)
- private
- FabsoluteTime: TDateTime;
- FMethod: TMethod;
- FPeriod: TRemindPeriod;
- FPeriodValue: integer;
- public
- Constructor Create(const ByNode: TXMLNode);
- procedure ParseXML(Node: TXMLNode);
- function AddToXML(Root: TXMLNode): TXMLNode;
- property AbsTime: TDateTime read FabsoluteTime write FabsoluteTime;
- property Method: TMethod read FMethod write FMethod;
- property Period: TRemindPeriod read FPeriod write FPeriod;
- property PeriodValue: integer read FPeriodValue write FPeriodValue;
- end;
-
-type
- TgdResourceIdStruct = string;
-
-type
- TDateFormat = (tdDate, tdServerDate);
-
- TgdWhen = class
- private
- FendTime: TDateTime;
- FstartTime: TDateTime;
- FvalueString: string;
- public
- Constructor Create(const ByNode: TXMLNode = nil);
- procedure Clear;
- function IsEmpty: boolean;
- procedure ParseXML(Node: TXMLNode);
- function AddToXML(Root: TXMLNode; DateFormat: TDateFormat): TXMLNode;
- property endTime: TDateTime read FendTime write FendTime;
- property startTime: TDateTime read FstartTime write FstartTime;
- property valueString: string read FvalueString write FvalueString;
- end;
-
-type
- TgdAgent = TTextTag;
- TgdHousename = TTextTag;
- TgdStreet = TTextTag;
- TgdPobox = TTextTag;
- TgdNeighborhood = TTextTag;
- TgdCity = TTextTag;
- TgdSubregion = TTextTag;
- TgdRegion = TTextTag;
- TgdPostcode = TTextTag;
- TgdFormattedAddress = TTextTag;
-
-type
- TgdStructuredPostalAddress = class
- private
- Frel: string;
- FMailClass: string;
- FUsage: string;
- FLabel: string;
- FPrimary: boolean;
- FAgent: TgdAgent;
- FHouseName: TgdHousename;
- FStreet: TgdStreet;
- FPobox: TgdPobox;
- FNeighborhood: TgdNeighborhood;
- FCity: TgdCity;
- FSubregion: TgdSubregion;
- FRegion: TgdRegion;
- FPostcode: TgdPostcode;
- FCountry: TgdCountry;
- FFormattedAddress: TgdFormattedAddress;
- public
- Constructor Create(const ByNode: TXMLNode = nil);
- procedure Clear;
- procedure ParseXML(Node: TXMLNode);
- function AddToXML(Root: TXMLNode): TXMLNode;
- function IsEmpty: boolean;
- property Rel: string read Frel write Frel;
- property MailClass: string read FMailClass write FMailClass;
- property Usage: string read FUsage write FUsage;
- property Labl: string read FLabel write FLabel;
- property Primary: boolean read FPrimary write FPrimary;
- property Agent: TgdAgent read FAgent write FAgent;
- property HouseName: TgdHousename read FHouseName write FHouseName;
- property Street: TgdStreet read FStreet write FStreet;
- property Pobox: TgdPobox read FPobox write FPobox;
- property Neighborhood
- : TgdNeighborhood read FNeighborhood write FNeighborhood;
- property City: TgdCity read FCity write FCity;
- property Subregion: TgdSubregion read FSubregion write FSubregion;
- property Region: TgdRegion read FRegion write FRegion;
- property Postcode: TgdPostcode read FPostcode write FPostcode;
- property Coutry: TgdCountry read FCountry write FCountry;
- property FormattedAddress: TgdFormattedAddress read FFormattedAddress write
- FFormattedAddress;
- end;
-
-type
- TgdEntryLink = class
- private
- Fhref: string;
- FReadOnly: boolean;
- Frel: string;
- FAtomEntry: TXMLNode;
- public
- Constructor Create(const ByNode: TXMLNode = nil);
- procedure ParseXML(Node: TXMLNode);
- procedure Clear;
- function IsEmpty: boolean;
- function AddToXML(Root: TXMLNode): TXMLNode;
- property Href: string read Fhref write Fhref;
- property OnlyRead: boolean read FReadOnly write FReadOnly;
- property Rel: string read Frel write Frel;
- end;
-
-type
- TgdWhere = class
- private
- FLabel: string;
- Frel: string;
- FvalueString: string;
- FEntryLink: TgdEntryLink;
- public
- Constructor Create(const ByNode: TXMLNode = nil);
- procedure Clear;
- function IsEmpty: boolean;
- procedure ParseXML(Node: TXMLNode);
- function AddToXML(Root: TXMLNode): TXMLNode;
- property Labl: string read FLabel write FLabel;
- property Rel: string read Frel write Frel;
- property valueString: string read FvalueString write FvalueString;
- property EntryLink: TgdEntryLink read FEntryLink write FEntryLink;
- end;
-
-type
- TWhoRel = (tw_None, tw_event_attendee, tw_event_organizer,
- tw_event_performer, tw_event_speaker, tw_message_bcc, tw_message_cc,
- tw_message_from, tw_message_reply_to, tw_message_to);
-
- TgdWho = class
- private
- FEmail: string;
- Frel: string;
- FRelValue: TWhoRel;
- FvalueString: string;
- FAttendeeStatus: TgdAttendeeStatus;
- FAttendeeType: TgdAttendeeType;
- FEntryLink: TgdEntryLink;
-
- const
- RelValues: array [0 .. 8] of string = ('event.attendee', 'event.organizer',
- 'event.performer', 'event.speaker', 'message.bcc', 'message.cc',
- 'message.from', 'message.reply-to', 'message.to');
- public
- Constructor Create(const ByNode: TXMLNode = nil);
- procedure Clear;
- function IsEmpty: boolean;
- procedure ParseXML(Node: TXMLNode);
- function AddToXML(Root: TXMLNode): TXMLNode;
- property Email: string read FEmail write FEmail;
- property RelValue: TWhoRel read FRelValue write FRelValue;
- property valueString: string read FvalueString write FvalueString;
- property AttendeeStatus
- : TgdAttendeeStatus read FAttendeeStatus write FAttendeeStatus;
- property AttendeeType
- : TgdAttendeeType read FAttendeeType write FAttendeeType;
- property EntryLink: TgdEntryLink read FEntryLink write FEntryLink;
- end;
-
-function GetGDNodeType(cName: string): TgdEnum; inline;
-function GetGDNodeName(NodeType: TgdEnum): string; inline;
-function ServerDateToDateTime(cServerDate: string): TDateTime;
-function DateTimeToServerDate(DateTime: TDateTime): string;
-
-implementation
-
-function DateTimeToServerDate(DateTime: TDateTime): string;
-var
- Year, Mounth, Day, hours, Mins, Seconds, MSec: Word;
- aYear, aMounth, aDay, ahours, aMins, aSeconds, aMSec: string;
-begin
- DecodeDateTime(DateTime, Year, Mounth, Day, hours, Mins, Seconds, MSec);
- aYear := IntToStr(Year);
- if Mounth < 10 then
- aMounth := '0' + IntToStr(Mounth)
- else
- aMounth := IntToStr(Mounth);
- if Day < 10 then
- aDay := '0' + IntToStr(Day)
- else
- aDay := IntToStr(Day);
- if hours < 10 then
- ahours := '0' + IntToStr(hours)
- else
- ahours := IntToStr(hours);
- if Mins < 10 then
- aMins := '0' + IntToStr(Mins)
- else
- aMins := IntToStr(Mins);
- if Seconds < 10 then
- aSeconds := '0' + IntToStr(Seconds)
- else
- aSeconds := IntToStr(Seconds);
-
- case MSec of
- 0 .. 9:
- aMSec := '00' + IntToStr(MSec);
- 10 .. 99:
- aMSec := '0' + IntToStr(MSec);
- else
- aMSec := IntToStr(MSec);
- end;
- Result := aYear + '-' + aMounth + '-' + aDay + 'T' + ahours + ':' + aMins +
- ':' + aSeconds + '.' + aMSec + 'Z';
-end;
-
-function ServerDateToDateTime(cServerDate: string): TDateTime;
-var
- Year, Mounth, Day, hours, Mins, Seconds: Word;
-begin
- Year := StrToInt(copy(cServerDate, 1, 4));
- Mounth := StrToInt(copy(cServerDate, 6, 2));
- Day := StrToInt(copy(cServerDate, 9, 2));
- if Length(cServerDate) > 10 then
- begin
- hours := StrToInt(copy(cServerDate, 12, 2));
- Mins := StrToInt(copy(cServerDate, 15, 2));
- Seconds := StrToInt(copy(cServerDate, 18, 2));
- end
- else
- begin
- hours := 0;
- Mins := 0;
- Seconds := 0;
- end;
- Result := EncodeDateTime(Year, Mounth, Day, hours, Mins, Seconds, 0)
-end;
-
-function GetGDNodeName(NodeType: TgdEnum): string; inline;
-begin
- Result := StringReplace(GetEnumName(TypeInfo(TgdEnum), ord(NodeType)), '_', ':',
- [rfReplaceAll]);
-end;
-
-function GetGDNodeType(cName: string): TgdEnum;
-begin
- Result := TgdEnum(GetEnumValue(TypeInfo(TgdEnum), ReplaceStr
- (cName, ':', '_')));
-end;
-
-{ TgdWhere }
-
-function TgdWhere.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
- // добавляем узел
- if Root = nil then
- Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_where));
- if Length(FLabel) > 0 then
- Result.WriteAttributeString(sNodeLabelAttr, FLabel);
- if Length(Frel) > 0 then
- Result.WriteAttributeString(sNodeRelAttr, Frel);
- if Length(FvalueString) > 0 then
- Result.WriteAttributeString('valueString', FvalueString);
- if FEntryLink <> nil then
- if (FEntryLink.FAtomEntry <> nil) or (Length(FEntryLink.Fhref) > 0) then
- FEntryLink.AddToXML(Result);
-end;
-
-procedure TgdWhere.Clear;
-begin
- FLabel := '';
- Frel := '';
- FvalueString := '';
-end;
-
-constructor TgdWhere.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- Clear;
- if ByNode = nil then
- Exit;
- FEntryLink := TgdEntryLink.Create(nil);
- ParseXML(ByNode);
-end;
-
-function TgdWhere.IsEmpty: boolean;
-begin
- Result := (Length(Trim(FLabel)) = 0) and (Length(Trim(Frel)) = 0) and
- (Length(Trim(FvalueString)) = 0)
-end;
-
-procedure TgdWhere.ParseXML(Node: TXMLNode);
-begin
- if GetGDNodeType(Node.NameUnicode) <> gd_where then
- raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_where)]));
- try
- FLabel := Node.ReadAttributeString(sNodeLabelAttr);
- if Length(FLabel) = 0 then
- FLabel := Node.ReadAttributeString(sNodeRelAttr);
- FvalueString := Node.ReadAttributeString('valueString');
- if Node.NodeCount > 0 then // есть дочерний узел с EntryLink
- begin
- FEntryLink.ParseXML(Node.FindNode(gdNodeAlias + sEntryNodeName));
- end;
- except
- Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TgdEntryLinkStruct }
-
-function TgdEntryLink.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_entryLink));
- if Length(Trim(Fhref)) > 0 then
- Result.WriteAttributeString(sNodeHrefAttr, Fhref);
- if Length(Trim(Frel)) > 0 then
- Result.WriteAttributeString(sNodeRelAttr, Frel);
- Result.WriteAttributeBool('readOnly', FReadOnly);
- if FAtomEntry <> nil then
- Result.NodeAdd(FAtomEntry);
-end;
-
-procedure TgdEntryLink.Clear;
-begin
- Fhref := '';
- Frel := '';
-end;
-
-constructor TgdEntryLink.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- Clear;
- if ByNode = nil then
- Exit;
- ParseXML(ByNode);
-end;
-
-function TgdEntryLink.IsEmpty: boolean;
-begin
- Result := (Length(Trim(Fhref)) = 0) and (Length(Trim(Frel)) = 0)
-end;
-
-procedure TgdEntryLink.ParseXML(Node: TXMLNode);
-begin
- if GetGDNodeType(Node.NameUnicode) <> gd_entryLink then
- raise Exception.Create
- (Format(sc_ErrCompNodes, [GetGDNodeName(gd_entryLink)]));
- try
- Fhref := Node.ReadAttributeString(sNodeHrefAttr);
- Frel := Node.ReadAttributeString(sNodeRelAttr);
- FReadOnly := Node.ReadAttributeBool('readOnly');
- if Node.NodeCount > 0 then // есть дочерний узел с EntryLink
- FAtomEntry := Node.FindNode(sEntryNodeName);
- except
- Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TgdEventStatus }
-
-function TgdEventStatus.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_eventStatus));
- Result.WriteAttributeString(sNodeValueAttr, sSchemaHref + RelToStr(Frel));
-end;
-
-constructor TgdEventStatus.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- Clear;
- if ByNode = nil then
- Exit;
- ParseXML(ByNode);
-end;
-
-procedure TgdEventStatus.ParseXML(Node: TXMLNode);
-begin
- Frel := ev_None;
- if Node = nil then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_eventStatus then
- raise Exception.Create
- (Format(sc_ErrCompNodes, [GetGDNodeName(gd_eventStatus)]));
- try
- Frel := StrToRel(Node.ReadAttributeString(sNodeValueAttr));
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TgdWhen }
-
-function TgdWhen.AddToXML(Root: TXMLNode; DateFormat: TDateFormat): TXMLNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_when));
- case DateFormat of
- tdDate:
- Result.WriteAttributeString('startTime', FormatDateTime('yyyy-mm-dd', FstartTime));
- tdServerDate:
- Result.WriteAttributeString('startTime', DateTimeToServerDate(FstartTime));
- end;
-
- if FendTime > 0 then
- Result.WriteAttributeString
- ('endTime', DateTimeToServerDate(FendTime));
- if Length(Trim(FvalueString)) > 0 then
- Result.WriteAttributeString('valueString', FvalueString);
-end;
-
-procedure TgdWhen.Clear;
-begin
- FendTime := 0;
- FstartTime := 0;
- FvalueString := '';
-end;
-
-constructor TgdWhen.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- Clear;
- if ByNode = nil then
- Exit;
- ParseXML(ByNode);
-end;
-
-function TgdWhen.IsEmpty: boolean;
-begin
- Result := FstartTime <= 0; // отсутствует обязательное поле
-end;
-
-procedure TgdWhen.ParseXML(Node: TXMLNode);
-begin
- if Node = nil then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_when then
- raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_when)]));
- try
- FendTime := 0;
- FstartTime := 0;
- FvalueString := '';
- if Node.HasAttribute('endTime') then
- FendTime := ServerDateToDateTime
- (Node.ReadAttributeString('endTime'));
- FstartTime := ServerDateToDateTime
- (Node.ReadAttributeString('startTime'));
- if Node.HasAttribute('valueString') then
- FvalueString := Node.ReadAttributeString('valueString');
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TgdAttendeeStatus }
-
-function TgdAttendeeStatus.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_attendeeStatus));
- Result.WriteAttributeString(sNodeValueAttr, sSchemaHref + RelToStr(Frel));
-end;
-
-constructor TgdAttendeeStatus.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- Clear;
- if ByNode = nil then
- Exit;
- ParseXML(ByNode);
-end;
-
-procedure TgdAttendeeStatus.ParseXML(Node: TXMLNode);
-begin
- Frel := ev_None;
- if (Node = nil) or IsEmpty then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_attendeeStatus then
- raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName
- (gd_attendeeStatus)]));
- try
- Frel := StrToRel(Node.ReadAttributeString(sNodeValueAttr));
- // TAttendeeStatus(GetEnumValue(TypeInfo(TAttendeeStatus),tmp));
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TgdAttendeeType }
-
-function TgdAttendeeType.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_attendeeType));
- Result.WriteAttributeString(sNodeValueAttr, sSchemaHref + RelToStr(Frel));
-end;
-
-constructor TgdAttendeeType.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- Clear;
- if ByNode = nil then
- Exit;
- ParseXML(ByNode);
-end;
-
-procedure TgdAttendeeType.ParseXML(Node: TXMLNode);
-begin
- Frel := ev_None;
- if Node = nil then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_attendeeType then
- raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName
- (gd_attendeeType)]));
- try
- Frel := StrToRel(Node.ReadAttributeString(sNodeValueAttr));
- // TAttendeeType(GetEnumValue(TypeInfo(TAttendeeType),tmp));
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TgdWho }
-
-function TgdWho.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_who));
- if Length(Trim(FEmail)) > 0 then
- Result.WriteAttributeString('email', FEmail);
- if Length(Trim(Frel)) > 0 then
- Result.WriteAttributeString(sNodeRelAttr, sSchemaHref + RelValues[ord(FRelValue)]);
- if Length(Trim(FvalueString)) > 0 then
- Result.WriteAttributeString('valueString', FvalueString);
- FAttendeeStatus.AddToXML(Result);
- FAttendeeType.AddToXML(Result);
- FEntryLink.AddToXML(Result);
-end;
-
-procedure TgdWho.Clear;
-begin
- FEmail := '';
- Frel := '';
- FvalueString := '';
- FAttendeeStatus.Clear;
- FAttendeeType.Clear;
- FEntryLink.Clear;
-end;
-
-constructor TgdWho.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- FAttendeeStatus := TgdAttendeeStatus.Create;
- FAttendeeType := TgdAttendeeType.Create;
- FEntryLink := TgdEntryLink.Create;
- Clear;
- if ByNode = nil then
- Exit;
- ParseXML(ByNode);
-end;
-
-function TgdWho.IsEmpty: boolean;
-begin
- Result := (Length(Trim(FEmail)) = 0) and (Length(Trim(Frel)) = 0) and
- (Length(Trim(FvalueString)) = 0) and (FAttendeeStatus.IsEmpty) and
- (FAttendeeType.IsEmpty) and (FEntryLink.IsEmpty)
-end;
-
-procedure TgdWho.ParseXML(Node: TXMLNode);
-var
- i: integer;
- s: string;
-begin
- if Node = nil then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_who then
- raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_who)]));
- try
- FEmail := Node.ReadAttributeString('email');
- if Length(Node.ReadAttributeString(sNodeRelAttr)) > 0 then
- begin
- s := Node.ReadAttributeString(sNodeRelAttr);
- s := StringReplace(s, sSchemaHref, '', [rfIgnoreCase]);
- FRelValue := TWhoRel(AnsiIndexStr(s, RelValues));
- end;
- FvalueString := Node.ReadAttributeString('valueString');
- if Node.NodeCount > 0 then
- begin
- for i := 0 to Node.NodeCount - 1 do
- case GetGDNodeType(Node.Nodes[i].NameUnicode) of
- gd_attendeeStatus:
- FAttendeeStatus := TgdAttendeeStatus.Create(Node.Nodes[i]);
- gd_attendeeType:
- FAttendeeType := TgdAttendeeType.Create(Node.Nodes[i]);
- gd_entryLink:
- FEntryLink := TgdEntryLink.Create(Node.Nodes[i]);
- end;
- end;
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TgdRecurrence }
-
-function TgdRecurrence.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_recurrence));
- Result.ValueAsUnicodeString:=FText.Text;
-end;
-
-procedure TgdRecurrence.Clear;
-begin
- FText.Clear;
-end;
-
-constructor TgdRecurrence.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- FText := TStringList.Create;
- if ByNode = nil then
- Exit;
- ParseXML(ByNode);
-end;
-
-function TgdRecurrence.IsEmpty: boolean;
-begin
- Result := FText.Count = 0
-end;
-
-procedure TgdRecurrence.ParseXML(Node: TXMLNode);
-begin
- if Node = nil then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_recurrence then
- raise Exception.Create
- (Format(sc_ErrCompNodes, [GetGDNodeName(gd_recurrence)]));
- try
- FText.Text := Node.ValueAsUnicodeString;
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TgdReminder }
-
-function TgdReminder.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
- if Root = nil then
- Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_reminder));
- Result.WriteAttributeString('method', cMethods[ord(FMethod)]);
- case FPeriod of
- tpDays:
- Result.WriteAttributeInteger('days', FPeriodValue);
- tpHours:
- Result.WriteAttributeInteger('hours', FPeriodValue);
- tpMinutes:
- Result.WriteAttributeInteger('minutes', FPeriodValue);
- end;
- if FabsoluteTime > 0 then
- Result.WriteAttributeString('absoluteTime', DateTimeToServerDate(FabsoluteTime))
-end;
-
-constructor TgdReminder.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- FabsoluteTime := 0;
- if ByNode = nil then
- Exit;
- ParseXML(ByNode);
-end;
-
-procedure TgdReminder.ParseXML(Node: TXMLNode);
-begin
- if Node = nil then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_reminder then
- raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_reminder)])
- );
- try
- if Length(Node.ReadAttributeString('absoluteTime')) > 0 then
- FabsoluteTime := ServerDateToDateTime
- (Node.ReadAttributeString('absoluteTime'));
- if Length(Node.ReadAttributeString('method')) > 0 then
- FMethod := TMethod(AnsiIndexStr(Node.ReadAttributeString('method')
- , cMethods));
- if Node.AttributeIndexByname('days') >= 0 then
- FPeriod := tpDays;
- if Node.AttributeIndexByname('hours') >= 0 then
- FPeriod := tpHours;
- if Node.AttributeIndexByname('minutes') >= 0 then
- FPeriod := tpMinutes;
- case FPeriod of
- tpDays:
- FPeriodValue := Node.ReadAttributeInteger('days');
- tpHours:
- FPeriodValue := Node.ReadAttributeInteger('hours');
- tpMinutes:
- FPeriodValue := Node.ReadAttributeInteger('minutes');
- end;
-
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TgdTransparency }
-
-function TgdTransparency.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result.WriteAttributeString(sNodeValueAttr, sSchemaHref + RelToStr(Frel));
-end;
-
-constructor TgdTransparency.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- Clear;
- if ByNode = nil then
- Exit;
- ParseXML(ByNode);
-end;
-
-procedure TgdTransparency.ParseXML(Node: TXMLNode);
-begin
- Frel := ev_None;
- if Node = nil then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_transparency then
- raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName
- (gd_transparency)]));
- try
- Frel := StrToRel(Node.ReadAttributeString(sNodeValueAttr));
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TgdVisibility }
-
-function TgdVisibility.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result.WriteAttributeString(sNodeValueAttr, sSchemaHref + RelToStr(Frel));
-end;
-
-constructor TgdVisibility.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- Clear;
- if ByNode = nil then
- Exit;
- ParseXML(ByNode);
-end;
-
-procedure TgdVisibility.ParseXML(Node: TXMLNode);
-begin
- Frel := ev_None;
- if Node = nil then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_visibility then
- raise Exception.Create
- (Format(sc_ErrCompNodes, [GetGDNodeName(gd_visibility)]));
- try
- Frel := StrToRel(Node.ReadAttributeString(sNodeValueAttr));
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TgdOrganization }
-
-function TgdOrganization.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
-
- Result := Root.NodeNew(GetGDNodeName(gd_organization));
- if Trim(Frel) <> '' then
- Result.WriteAttributeString(sNodeRelAttr, Frel);
- if Trim(FLabel) <> '' then
- Result.WriteAttributeString(sNodeLabelAttr, FLabel);
- if FPrimary then
- Result.WriteAttributeBool('primary', FPrimary);
- if Trim(ForgName.Value) <> '' then
- ForgName.AddToXML(Result);
- if Trim(ForgTitle.Value) <> '' then
- ForgTitle.AddToXML(Result);
-end;
-
-procedure TgdOrganization.Clear;
-begin
- FLabel := '';
- Frel := '';
-end;
-
-constructor TgdOrganization.Create(ByNode: TXMLNode);
-begin
- inherited Create;
- ForgName := TgdOrgName.Create;
- ForgTitle := TgdOrgTitle.Create;
- Clear;
- if ByNode <> nil then
- ParseXML(ByNode);
-
-end;
-
-function TgdOrganization.IsEmpty: boolean;
-begin
- Result := (Length(Trim(FLabel)) = 0) and (Length(Trim(Frel)) = 0) and
- (ForgName.IsEmpty) and (ForgTitle.IsEmpty)
-end;
-
-procedure TgdOrganization.ParseXML(const Node: TXMLNode);
-var
- i: integer;
-begin
- if (Node = nil) or IsEmpty then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_organization then
- raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName
- (gd_organization)]));
- try
- Frel := Node.ReadAttributeString(sNodeRelAttr);
- if Node.HasAttribute('primary') then
- FPrimary := Node.ReadAttributeBool('primary');
- if Node.HasAttribute(sNodeLabelAttr) then
- FLabel := Node.ReadAttributeString(sNodeLabelAttr);
- for i := 0 to Node.NodeCount - 1 do
- begin
- if LowerCase(Node.Nodes[i].NameUnicode) = LowerCase
- (GetGDNodeName(gd_orgName)) then
- ForgName := TgdOrgName.Create(Node.Nodes[i])
- else if LowerCase(Node.Nodes[i].NameUnicode) = LowerCase
- (GetGDNodeName(gd_orgTitle)) then
- ForgTitle := TgdOrgTitle.Create(Node.Nodes[i]);
- end;
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TgdEmailStruct }
-
-function TgdEmail.AddToXML(Root: TXMLNode): TXMLNode;
-var
- tmp: string;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_email));
- if Frel <> em_None then
- begin
- tmp := GetEnumName(TypeInfo(TTypeElement), ord(Frel));
- Delete(tmp, 1, 3);
- Result.WriteAttributeString(sNodeRelAttr, sSchemaHref + tmp);
- end;
- if Trim(FLabel) <> '' then
- Result.WriteAttributeString(sNodeLabelAttr, FLabel);
- if Trim(FLabel) <> '' then
- Result.WriteAttributeString('displayName', FDisplayName);
- if FPrimary then
- Result.WriteAttributeBool('primary', FPrimary);
- Result.WriteAttributeString('address', FAddress);
-end;
-
-procedure TgdEmail.Clear;
-begin
- FAddress := '';
- FLabel := '';
- Frel := em_None;
- FDisplayName := '';
-end;
-
-constructor TgdEmail.Create(ByNode: TXMLNode);
-begin
- inherited Create;
- Clear;
- if ByNode <> nil then
- ParseXML(ByNode);
-end;
-
-function TgdEmail.IsEmpty: boolean;
-begin
- Result := Length(Trim(FAddress)) = 0; // отсутствует обязательное поле
-end;
-
-procedure TgdEmail.ParseXML(const Node: TXMLNode);
-var
- tmp: string;
-begin
- Frel := em_None;
- if Node = nil then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_email then
- raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_email)]));
- try
- tmp := 'em_' + ReplaceStr(Node.ReadAttributeString(sNodeRelAttr),
- sSchemaHref, '');
- Frel := TTypeElement(GetEnumValue(TypeInfo(TTypeElement), tmp));
- if Node.HasAttribute('primary') then
- FPrimary := Node.ReadAttributeBool('primary');
- if Node.HasAttribute(sNodeLabelAttr) then
- FLabel := Node.ReadAttributeString(sNodeLabelAttr);
- if Node.HasAttribute('displayName') then
- FDisplayName := Node.ReadAttributeString('displayName');
- FAddress := Node.ReadAttributeString('address');
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-function TgdEmail.RelToString: string;
-begin
- case Frel of
- em_None:
- Result := ''; // значение не определено
- em_home:
- Result := LoadStr(c_EmailHome);
- em_other:
- Result := LoadStr(c_EmailOther);
- em_work:
- Result := LoadStr(c_EmailWork);
- end;
-end;
-
-{ TgdNameStruct }
-
-function TgdName.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
-
- Result := Root.NodeNew(GetGDNodeName(gd_name));
- if (AdditionalName <> nil) and (not AdditionalName.IsEmpty) then
- AdditionalName.AddToXML(Result);
-
- if (GivenName <> nil) and (not GivenName.IsEmpty) then
- GivenName.AddToXML(Result);
- if (FamilyName <> nil) and (not FamilyName.IsEmpty) then
- FamilyName.AddToXML(Result);
- if (not NamePrefix.IsEmpty) then
- NamePrefix.AddToXML(Result);
- if not NameSuffix.IsEmpty then
- NameSuffix.AddToXML(Result);
- if not FullName.IsEmpty then
- FullName.AddToXML(Result);
-end;
-
-procedure TgdName.Clear;
-begin
- FGivenName.Clear;
- FAdditionalName.Clear;
- FFamilyName.Clear;
- FNamePrefix.Clear;
- FNameSuffix.Clear;
- FFullName.Clear;
-end;
-
-constructor TgdName.Create(ByNode: TXMLNode);
-begin
- inherited Create;
- FGivenName := TgdGivenName.Create(GetGDNodeName(gd_givenName));
- FAdditionalName := TgdAdditionalName.Create
- (string(GetGDNodeName(gd_additionalName)));
- FFamilyName := TgdFamilyName.Create(GetGDNodeName(gd_familyName));
- FNamePrefix := TgdNamePrefix.Create(GetGDNodeName(gd_namePrefix));
- FNameSuffix := TgdNameSuffix.Create(GetGDNodeName(gd_nameSuffix));
- FFullName := TgdFullName.Create(GetGDNodeName(gd_fullName));
- if ByNode <> nil then
- ParseXML(ByNode);
-end;
-
-function TgdName.GetFullName: string;
-begin
- if FFullName <> nil then
- Result := FFullName.Value;
-end;
-
-function TgdName.IsEmpty: boolean;
-begin
- Result :=
- FGivenName.IsEmpty and FAdditionalName.IsEmpty and FFamilyName.IsEmpty and
- FNamePrefix.IsEmpty and FNameSuffix.IsEmpty and FFullName.IsEmpty;
-end;
-
-procedure TgdName.ParseXML(const Node: TXMLNode);
-var
- i: integer;
-begin
- if Node = nil then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_name then
- raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_name)]));
- try
- for i := 0 to Node.NodeCount - 1 do
- begin
- case GetGDNodeType(Node.Nodes[i].NameUnicode) of
- gd_givenName:
- FGivenName.ParseXML(Node.Nodes[i]);
- gd_additionalName:
- FAdditionalName.ParseXML(Node.Nodes[i]);
- gd_familyName:
- FFamilyName.ParseXML(Node.Nodes[i]);
- gd_namePrefix:
- FNamePrefix.ParseXML(Node.Nodes[i]);
- gd_nameSuffix:
- FNameSuffix.ParseXML(Node.Nodes[i]);
- gd_fullName:
- FFullName.ParseXML(Node.Nodes[i]);
- end;
- end;
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-procedure TgdName.SetAdditionalName(aAdditionalName: TTextTag);
-begin
- if aAdditionalName = nil then
- Exit;
- if Length(FAdditionalName.Name) = 0 then
- FAdditionalName.Name := GetGDNodeName(gd_additionalName);
- FAdditionalName.Value := aAdditionalName.Value;
-end;
-
-procedure TgdName.SetFamilyName(aFamilyName: TTextTag);
-begin
- if aFamilyName = nil then
- Exit;
- if Length(FFamilyName.Name) = 0 then
- FFamilyName.Name := GetGDNodeName(gd_familyName);
- FFamilyName.Value := aFamilyName.Value;
-end;
-
-procedure TgdName.SetFullName(aFullName: TTextTag);
-begin
- if aFullName = nil then
- Exit;
- if Length(FFullName.Name) = 0 then
- FFullName.Name := GetGDNodeName(gd_fullName);
- FFullName.Value := aFullName.Value;
-end;
-
-procedure TgdName.SetGivenName(aGivenName: TTextTag);
-begin
- if aGivenName = nil then
- Exit;
- if Length(FGivenName.Name) = 0 then
- FGivenName.Name := GetGDNodeName(gd_givenName);
- FFullName.Value := aGivenName.Value;
-end;
-
-procedure TgdName.SetNamePrefix(aNamePrefix: TTextTag);
-begin
- if aNamePrefix = nil then
- Exit;
- if Length(FNamePrefix.Name) = 0 then
- FNamePrefix.Name := GetGDNodeName(gd_namePrefix);
- FNamePrefix.Value := aNamePrefix.Value;
-end;
-
-procedure TgdName.SetNameSuffix(aNameSuffix: TTextTag);
-begin
- if aNameSuffix = nil then
- Exit;
- if Length(FNameSuffix.Name) = 0 then
- FNameSuffix.Name := GetGDNodeName(gd_nameSuffix);
- FNameSuffix.Value := aNameSuffix.Value;
-end;
-
-{ TgdPhoneNumber }
-
-function TgdPhoneNumber.AddToXML(Root: TXMLNode): TXMLNode;
-var
- tmp: string;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_phoneNumber));
-
- if Frel <> tp_None then
- begin
- tmp := GetEnumName(TypeInfo(TPhonesRel), ord(Frel));
- Delete(tmp, 1, 3);
- Result.WriteAttributeString(sNodeRelAttr, sSchemaHref + tmp);
- end;
-
- Result.ValueAsUnicodeString := FValue;
- if Trim(FLabel) <> '' then
- Result.WriteAttributeString(sNodeLabelAttr, FLabel);
- if Trim(FUri) <> '' then
- Result.WriteAttributeString('uri', FUri);
- if FPrimary then
- Result.WriteAttributeBool('primary', FPrimary);
-end;
-
-procedure TgdPhoneNumber.Clear;
-begin
- FLabel := '';
- FUri := '';
- FValue := '';
-end;
-
-constructor TgdPhoneNumber.Create(ByNode: TXMLNode);
-begin
- inherited Create;
- Clear;
- if ByNode <> nil then
- ParseXML(ByNode);
-end;
-
-function TgdPhoneNumber.IsEmpty: boolean;
-begin
- Result := (Length(Trim(FLabel)) = 0) and (Length(Trim(FUri)) = 0) and
- (Length(Trim(FValue)) = 0)
-end;
-
-procedure TgdPhoneNumber.ParseXML(const Node: TXMLNode);
-var
- tmp: string;
-begin
- Frel := tp_None;
- if Node = nil then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_phoneNumber then
- raise Exception.Create
- (Format(sc_ErrCompNodes, [GetGDNodeName(gd_phoneNumber)]));
- try
- tmp := 'tp_' + ReplaceStr(Node.ReadAttributeString(sNodeRelAttr),
- sSchemaHref, '');
- if Length(tmp) > 3 then
- Frel := TPhonesRel(GetEnumValue(TypeInfo(TPhonesRel), tmp));
- if Node.HasAttribute('primary') then
- FPrimary := Node.ReadAttributeBool('primary');
- if Node.HasAttribute(sNodeLabelAttr) then
- FLabel := Node.ReadAttributeString(sNodeLabelAttr);
- if Node.HasAttribute('uri') then
- FUri := Node.ReadAttributeString('uri');
- FValue := Node.ValueAsUnicodeString;
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-function TgdPhoneNumber.RelToString: string;
-begin
- case Frel of
- tp_None:
- Result := '';
- tp_Assistant:
- Result := LoadStr(c_PhoneAssistant);
- tp_Callback:
- Result := LoadStr(c_PhoneCallback);
- tp_Car:
- Result := LoadStr(c_PhoneCar);
- Tp_Company_main:
- Result := LoadStr(c_PhoneCompanymain);
- tp_Fax:
- Result := LoadStr(c_PhoneFax);
- tp_Home:
- Result := LoadStr(c_PhoneHome);
- tp_Home_fax:
- Result := LoadStr(c_PhoneHomefax);
- tp_Isdn:
- Result := LoadStr(c_PhoneIsdn);
- tp_Main:
- Result := LoadStr(c_PhoneMain);
- tp_Mobile:
- Result := LoadStr(c_PhoneMobile);
- tp_Other:
- Result := LoadStr(c_PhoneOther);
- tp_Other_fax:
- Result := LoadStr(c_PhoneOtherfax);
- tp_Pager:
- Result := LoadStr(c_PhonePager);
- tp_Radio:
- Result := LoadStr(c_PhoneRadio);
- tp_Telex:
- Result := LoadStr(c_PhoneTelex);
- tp_Tty_tdd:
- Result := LoadStr(c_PhoneTtytdd);
- Tp_Work:
- Result := LoadStr(c_PhoneWork);
- tp_Work_fax:
- Result := LoadStr(c_PhoneWorkfax);
- tp_Work_mobile:
- Result := LoadStr(c_PhoneWorkmobile);
- tp_Work_pager:
- Result := LoadStr(c_PhoneWorkpager);
- end;
-end;
-
-{ TgdCountry }
-
-function TgdCountry.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_country));
- if Trim(FCode) <> '' then
- Result.WriteAttributeString('code', FCode);
- Result.ValueAsUnicodeString := FValue;
-end;
-
-procedure TgdCountry.Clear;
-begin
- FCode := '';
- FValue := '';
-end;
-
-constructor TgdCountry.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- Clear;
- if ByNode <> nil then
- ParseXML(ByNode);
-end;
-
-function TgdCountry.IsEmpty: boolean;
-begin
- Result := (Length(Trim(FCode)) = 0) and (Length(Trim(FValue)) = 0);
-end;
-
-procedure TgdCountry.ParseXML(Node: TXMLNode);
-begin
- if Node = nil then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_country then
- raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_country)])
- );
- try
- FCode := Node.ReadAttributeString(sNodeRelAttr);
- FValue := Node.ValueAsUnicodeString;
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TgdStructuredPostalAddressStruct }
-
-function TgdStructuredPostalAddress.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_structuredPostalAddress));
- if Trim(Frel) <> '' then
- Result.WriteAttributeString(sNodeRelAttr, Frel);
- if Trim(FMailClass) <> '' then
- Result.WriteAttributeString('mailClass', FMailClass);
- if Trim(FLabel) <> '' then
- Result.WriteAttributeString(sNodeLabelAttr, FLabel);
- if Trim(FUsage) <> '' then
- Result.WriteAttributeString('Usage', FUsage);
- if FPrimary then
- Result.WriteAttributeBool('primary', FPrimary);
- if FAgent <> nil then
- FAgent.AddToXML(Result);
- if FHouseName <> nil then
- FHouseName.AddToXML(Result);
- if FStreet <> nil then
- FStreet.AddToXML(Result);
- if FPobox <> nil then
- FPobox.AddToXML(Result);
- if FNeighborhood <> nil then
- FNeighborhood.AddToXML(Result);
- if FCity <> nil then
- FCity.AddToXML(Result);
- if FSubregion <> nil then
- FSubregion.AddToXML(Result);
- if FRegion <> nil then
- FRegion.AddToXML(Result);
- if FPostcode <> nil then
- FPostcode.AddToXML(Result);
- if FCountry <> nil then
- FCountry.AddToXML(Result);
- if FFormattedAddress <> nil then
- FFormattedAddress.AddToXML(Result);
-end;
-
-procedure TgdStructuredPostalAddress.Clear;
-begin
- Frel := '';
- FMailClass := '';
- FUsage := '';
- FLabel := '';
- FAgent.Clear;
- FHouseName.Clear;
- FStreet.Clear;
- FPobox.Clear;
- FNeighborhood.Clear;
- FCity.Clear;
- FSubregion.Clear;
- FRegion.Clear;
- FPostcode.Clear;
- FCountry.Clear;
- FFormattedAddress.Clear;
-end;
-
-constructor TgdStructuredPostalAddress.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- FAgent := TgdAgent.Create;
- FHouseName := TgdHousename.Create;
- FStreet := TgdStreet.Create;
- FPobox := TgdPobox.Create;
- FNeighborhood := TgdNeighborhood.Create;
- FCity := TgdCity.Create;
- FSubregion := TgdSubregion.Create;
- FRegion := TgdRegion.Create;
- FPostcode := TgdPostcode.Create;
- FCountry := TgdCountry.Create;
- FFormattedAddress := TgdFormattedAddress.Create;
-
- Clear;
- if ByNode <> nil then
- ParseXML(ByNode);
-end;
-
-function TgdStructuredPostalAddress.IsEmpty: boolean;
-begin
- Result := (Length(Trim(Frel)) = 0) and (Length(Trim(FMailClass)) = 0) and
- (Length(Trim(FUsage)) = 0) and (Length(Trim(FLabel)) = 0)
- and FAgent.IsEmpty and FHouseName.IsEmpty and FStreet.IsEmpty and FPobox.
- IsEmpty and FNeighborhood.IsEmpty and FCity.IsEmpty and FSubregion.IsEmpty
- and FRegion.IsEmpty and FPostcode.IsEmpty and FCountry.IsEmpty and
- FFormattedAddress.IsEmpty;
-end;
-
-procedure TgdStructuredPostalAddress.ParseXML(Node: TXMLNode);
-var
- i: integer;
-begin
- if Node = nil then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_structuredPostalAddress then
- raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName
- (gd_structuredPostalAddress)]));
- try
- Frel := Node.ReadAttributeString(sNodeRelAttr);
- FMailClass := Node.ReadAttributeString('mailClass');
- FLabel := Node.ReadAttributeString(sNodeLabelAttr);
- if Node.HasAttribute('primaty') then
- FPrimary := Node.ReadAttributeBool('primary');
- FUsage := Node.ReadAttributeString('Usage');
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
- for i := 0 to Node.NodeCount - 1 do
- begin
- case GetGDNodeType(Node.Nodes[i].NameUnicode) of
- gd_agent:
- FAgent.ParseXML(Node.Nodes[i]);
- gd_housename:
- FHouseName.ParseXML(Node.Nodes[i]);
- gd_street:
- FStreet.ParseXML(Node.Nodes[i]);
- gd_pobox:
- FPobox.ParseXML(Node.Nodes[i]);
- gd_neighborhood:
- FNeighborhood.ParseXML(Node.Nodes[i]);
- gd_city:
- FCity.ParseXML(Node.Nodes[i]);
- gd_subregion:
- FSubregion.ParseXML(Node.Nodes[i]);
- gd_region:
- FRegion.ParseXML(Node.Nodes[i]);
- gd_postcode:
- FPostcode.ParseXML(Node.Nodes[i]);
- gd_country:
- FCountry.ParseXML(Node.Nodes[i]);
- gd_formattedAddress:
- FFormattedAddress.ParseXML(Node.Nodes[i]);
- end;
- end;
-end;
-
-{ TgdIm }
-
-function TgdIm.AddToXML(Root: TXMLNode): TXMLNode;
-var
- tmp: string;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_im));
- tmp := GetEnumName(TypeInfo(TIMtype), ord(FIMType));
- Delete(tmp, 1, 3);
- Result.WriteAttributeString(sNodeRelAttr, sSchemaHref + tmp);
- Result.WriteAttributeString('address', FAddress);
- Result.WriteAttributeString(sNodeLabelAttr, FLabel);
-
- tmp := GetEnumName(TypeInfo(TIMProtocol), ord(FIMProtocol));
- Delete(tmp, 1, 3);
- Result.WriteAttributeString('protocol', sSchemaHref + tmp);
-
- if FPrimary then
- Result.WriteAttributeBool('primary', FPrimary);
-end;
-
-procedure TgdIm.Clear;
-begin
- FAddress := '';
- FLabel := '';
-end;
-
-constructor TgdIm.Create(ByNode: TXMLNode);
-begin
- inherited Create;
- Clear;
- if ByNode <> nil then
- ParseXML(ByNode);
-end;
-
-function TgdIm.ImProtocolToString: string;
-begin
- Result := GetEnumName(TypeInfo(TIMProtocol), ord(FIMProtocol));
- Delete(Result, 1, 3);
-end;
-
-function TgdIm.ImTypeToString: string;
-begin
- case FIMType of
- im_None:
- Result := ''; // значение не определено
- im_home:
- Result := LoadStr(c_ImHome);
- im_netmeeting:
- Result := LoadStr(c_ImNetMeeting);
- im_other:
- Result := LoadStr(c_ImOther);
- im_work:
- Result := LoadStr(c_ImWork);
- end;
-end;
-
-function TgdIm.IsEmpty: boolean;
-begin
- Result := (Length(Trim(FAddress)) = 0); // отсутствует обязательное поле
-end;
-
-procedure TgdIm.ParseXML(const Node: TXMLNode);
-var
- tmp: string;
-begin
- FIMProtocol := ti_None;
- FIMType := im_None;
- if Node = nil then
- Exit;
- if GetGDNodeType(Node.NameUnicode) <> gd_im then
- raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_im)]));
- try
- tmp := 'im_' + ReplaceStr(Node.ReadAttributeString(sNodeRelAttr),
- sSchemaHref, '');
- FIMType := TIMtype(GetEnumValue(TypeInfo(TIMtype), tmp));
-
- FLabel := Node.ReadAttributeString(sNodeLabelAttr);
- FAddress := Node.ReadAttributeString('address');
-
- tmp := 'ti_' + ReplaceStr(Node.ReadAttributeString('protocol'),
- sSchemaHref, '');
- FIMProtocol := TIMProtocol(GetEnumValue(TypeInfo(TIMProtocol), tmp));
-
- if Node.HasAttribute('primary') then
- FPrimary := Node.ReadAttributeBool('primary');
- except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TgdEvent }
-
-procedure TgdEvent.Clear;
-begin
- Frel := ev_None;
-end;
-
-constructor TgdEvent.Create;
-begin
- inherited Create;
-end;
-
-function TgdEvent.IsEmpty: boolean;
-begin
- Result := Frel = ev_None;
-end;
-
-function TgdEvent.RelToStr(aRel: TEventRel): string;
-begin
- Result := sSchemaHref + sEventRelSuffix +
- ReplaceStr(GetEnumName(TypeInfo(TEventRel), ord(aRel)),
- EvSuffix, '');;
-end;
-
-function TgdEvent.RelToString: string;
-begin
- case Frel of
- ev_attendee:
- ;
- ev_organizer:
- ;
- ev_performer:
- ;
- ev_speaker:
- ;
- ev_canceled:
- Result := LoadStr(c_EventCancel);
- ev_confirmed:
- Result := LoadStr(c_EventConfirm);
- ev_tentative:
- Result := LoadStr(c_EventTentative);
- ev_confidential:
- Result := LoadStr(c_EventConfident);
- ev_default:
- Result := LoadStr(c_EventDefault);
- ev_private:
- Result := LoadStr(c_EventPrivate);
- ev_public:
- Result := LoadStr(c_EventPublic);
- ev_opaque:
- Result := LoadStr(c_EventOpaque);
- ev_transparent:
- Result := LoadStr(c_EventTransp);
- ev_optional:
- Result := LoadStr(c_EventOptional);
- ev_required:
- Result := LoadStr(c_EventRequired);
- ev_accepted:
- Result := LoadStr(c_EventAccepted);
- ev_declined:
- Result := LoadStr(c_EventDeclined);
- ev_invited:
- Result := LoadStr(c_EventInvited);
- else
- Result := '';
- end;
-end;
-
-function TgdEvent.StrToRel(const aRel: string): TEventRel;
-var
- tmp: string;
-begin
- tmp := EvSuffix + ReplaceStr(aRel, sSchemaHref + sEventRelSuffix, '');
- Result := TEventRel(GetEnumValue(TypeInfo(TEventRel), tmp));
-end;
-
-{ TTextTag }
-
-function TTextTag.AddToXML(Root: TXMLNode): TXMLNode;
-var
- i: integer;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then
- Exit;
- Result := Root.NodeNew(UTF8string(FName));
- Result.ValueAsUnicodeString := FValue;
- for i := 0 to FAtributes.Count - 1 do
- Result.AttributeAdd(UTF8string(FAtributes[i].Name), UTF8string
- (FAtributes[i].Value));
-end;
-
-constructor TTextTag.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- FAtributes := TList.Create;
- Clear;
- if ByNode <> nil then
- ParseXML(ByNode);
-end;
-
-procedure TTextTag.Clear;
-begin
- FName := '';
- FValue := '';
- FAtributes.Clear;
-end;
-
-constructor TTextTag.Create(const NodeName: string; NodeValue: string);
-begin
- inherited Create;
- FName := NodeName;
- FValue := NodeValue;
- FAtributes := TList.Create;
-end;
-
-function TTextTag.IsEmpty: boolean;
-begin
- Result := (Length(Trim(FName)) = 0) or ((Length(Trim(FValue)) = 0) and
- (FAtributes.Count = 0));
-end;
-
-procedure TTextTag.ParseXML(Node: TXMLNode);
-var
- i: integer;
- Attr: TAttribute;
-begin
- try
- FValue := Node.ValueAsUnicodeString;
- FName := Node.NameUnicode;
- for i := 0 to Node.AttributeCount - 1 do
- begin
- Attr.Name := Node.AttributeUnicodeName[i];
- Attr.Value := Node.AttributeUnicodeValue[i];
- FAtributes.Add(Attr)
- end;
- except
- Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TAuthorTag }
-constructor TAuthorTag.Create(ByNode: TXMLNode);
-begin
- inherited Create;
- if ByNode = nil then
- Exit;
- ParseXML(ByNode);
-end;
-
-procedure TAuthorTag.ParseXML(Node: TXMLNode);
-var
- i: integer;
-begin
- try
- for i := 0 to Node.NodeCount - 1 do
- begin
- if Node.Nodes[i].Name = 'name' then
- FAuthor := Node.Nodes[i].ValueAsUnicodeString
- else if Node.Nodes[i].Name = 'email' then
- FEmail := Node.Nodes[i].ValueAsUnicodeString
- else if Node.Nodes[i].Name = 'uid' then
- FUID := Node.Nodes[i].ValueAsUnicodeString;
- end;
- except
- Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
- end;
-end;
-
-{ TEntryLink }
-
-function TEntryLink.AddToXML(Root: TXMLNode): TXMLNode;
-begin
- Result := nil;
-end;
-
-procedure TEntryLink.Clear;
-begin
- Frel:='';
- Ftype:='';
- Fhref:='';
- FEtag:='';
-end;
-
-constructor TEntryLink.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- if ByNode <> nil then
- ParseXML(ByNode);
-end;
-
-function TEntryLink.IsEmpty: boolean;
-begin
- Result:=Length(Fhref)=0
-end;
-
-procedure TEntryLink.ParseXML(Node: TXMLNode);
-begin
- if Node = nil then
- Exit;
- try
- Frel := Node.ReadAttributeString(sNodeRelAttr);
- Ftype := Node.ReadAttributeString('type');
- Fhref := Node.ReadAttributeString(sNodeHrefAttr);
- FEtag := Node.ReadAttributeString(gdNodeAlias + 'etag')
- except Exception.Create(Format(sc_ErrPrepareNode, ['link']));
- end;
-end;
-
-{ THTTPSender }
-
-procedure THTTPSender.AddGoogleHeaders;
-begin
- Headers.Add('GData-Version: ' + FApiVersion);
- Headers.Add('Authorization: GoogleLogin auth=' + FAuthKey);
-end;
-
-procedure THTTPSender.Clear;
-begin
- inherited Clear;
- FMethod := '';
- FURL := '';
- FAuthKey := '';
- FApiVersion := '';
- FExtendedHeaders.Clear;
- Headers.Clear;
- Cookies.Clear;
-end;
-
-constructor THTTPSender.Create(const aMethod, aAuthKey, aURL,
- aAPIVersion: string);
-begin
- inherited Create;
- MimeType:='application/atom+xml';
- FAuthKey := aAuthKey;
- FURL := aURL;
- FApiVersion := aAPIVersion;
- FMethod := aMethod;
- FExtendedHeaders := TStringList.Create;
-end;
-
-function THTTPSender.GetLength(const aURL: string): integer;
-var
- size, content: Ansistring;
- ch: AnsiChar;
- h: TStringList;
-begin
- with THTTPSend.Create do
- begin
- Headers.Add('GData-Version: ' + FApiVersion);
- Headers.Add('Authorization: GoogleLogin auth=' + FAuthKey);
- if HTTPMethod('HEAD', aURL) and (ResultCode = 200) then
- begin
- h := TStringList.Create;
- h.Assign(Headers);
- content := Ansistring(HeadByName('content-length', h));
- h.Delete(h.IndexOf(HeadByName('Connection', h)));
- h.Delete(h.IndexOf(string(content)));
- for ch in content do
- if ch in ['0' .. '9'] then
- size := size + ch;
- Result := StrToIntDef(string(size), 0) + Length(BytesOf(h.Text));
- end
- else
- Result := -1;
- end
-end;
-
-function THTTPSender.HeadByName(const aHead: string; aHeaders: TStringList)
- : string;
-var
- str: string;
-begin
- Result := '';
- for str in aHeaders do
- begin
- if pos(LowerCase(aHead), LowerCase(str)) > 0 then
- begin
- Result := str;
- break;
- end;
- end;
-end;
-
-function THTTPSender.SendRequest: boolean;
-var
- str: string;
-begin
- Result := false;
- if (Length(Trim(FMethod)) = 0) or (Length(Trim(FURL)) = 0) or
- (Length(Trim(FAuthKey)) = 0) or (Length(Trim(FApiVersion)) = 0) then
- Exit;
- // добавляем необходимые заголовки
- AddGoogleHeaders;
- if FExtendedHeaders.Count > 0 then
- for str in FExtendedHeaders do
- Headers.Add(str);
- Result := HTTPMethod(FMethod, FURL);
-end;
-
-procedure THTTPSender.SetApiVersion(const Value: string);
-begin
- FApiVersion := Value;
-end;
-
-procedure THTTPSender.SetAuthKey(const Value: string);
-begin
- FAuthKey := Value;
-end;
-
-procedure THTTPSender.SetExtendedHeaders(const Value: TStringList);
-begin
- FExtendedHeaders := Value;
-end;
-
-procedure THTTPSender.SetMethod(const Value: string);
-begin
- FMethod := Value;
-end;
-
-procedure THTTPSender.SetURL(const Value: string);
-begin
- FURL := Value;
-end;
-
-{ TXMLNode_ }
-
-procedure TXMLNode_.AttributeAdd(const AName, AValue: String);
-begin
- AttributeAdd(UTF8String(AName),UTF8String(AValue));
-end;
-
-function TXMLNode_.FindNode(const NodeName: String): TXmlNode;
-begin
- Result:=FindNode(UTF8String(NodeName))
-end;
-
-function TXMLNode_.GetAttributeByUnicodeName(const aName: string): string;
-begin
- Result:=string(AttributeByName[UTF8String(aName)]);
-end;
-
-function TXMLNode_.GetAttributeUnicodeName(index: integer): string;
-begin
- Result:=string(AttributeName[index])
-end;
-
-function TXMLNode_.GetAttributeUnicodeValue(index:integer): string;
-begin
- Result:=string(AttributeValue[index])
-end;
-
-function TXMLNode_.GetNameUnicode: string;
-begin
- Result:=string(Name);
-end;
-
-function TXMLNode_.NodeNew(const AName: String): TXmlNode;
-begin
- Result:=NodeNew(UTF8String(AName));
-end;
-
-procedure TXMLNode_.NodesByName(const AName: string; AList: TList);
-begin
- if AList = nil then
- AList:=TXmlNodeList.Create;
- AList.Clear;
- NodesByName(UTF8String(AName),AList);
-end;
-
-
-function TXMLNode_.ReadAttributeString(const AName,
- ADefault: String): String;
-begin
- Result:=string(ReadAttributeString(UTF8String(AName),UTF8String(ADefault)))
-end;
-
-procedure TXMLNode_.SetAttributeByUnicodeName(const aName, aValue: string);
-begin
- AttributeByName[UTF8String(aName)]:=UTF8String(aValue);
-end;
-
-procedure TXMLNode_.SetAttributeUnicodeName(index: integer; aValue: string);
-begin
- AttributeName[index]:=UTF8String(aValue);
-end;
-
-procedure TXMLNode_.SetAttributeUnicodeValue(index:integer;const aValue: string);
-begin
- AttributeValue[index]:=UTF8String(aValue);
-end;
-
-procedure TXMLNode_.SetNodeUnicode(const aName: string);
-begin
- Name:=UTF8String(aName);
-end;
-
-procedure TXMLNode_.WriteAttributeString(const AName, AValue, ADefault: String);
-begin
- WriteAttributeString(UTF8String(AName),UTF8String(AValue),UTF8String(ADefault));
-end;
-
-{ TgdExtendedPropertyStruct }
-
-function TgdExtendedProperty.AddToXML(Root: TXMLNode): TXMLNode;
-var i: integer;
-begin
- Result := nil;
- if (Root = nil) or IsEmpty then Exit;
- Result := Root.NodeNew(GetGDNodeName(gd_extendedProperty));
- if Length(Trim(FName))>0 then
- Result.WriteAttributeString('name',FName);
- if Length(Trim(FValue))>0 then
- Result.WriteAttributeString('value',FValue);
- //добавляем все дочерние узлы
- for i := 0 to FChildNodes.Count - 1 do
- FChildNodes[i].AddToXML(Result)
-end;
-
-procedure TgdExtendedProperty.Clear;
-begin
- FName:='';
- FValue:='';
- FChildNodes.Clear;
-end;
-
-constructor TgdExtendedProperty.Create(const ByNode: TXMLNode);
-begin
- inherited Create;
- FChildNodes:=TList.Create;
- if ByNode<>nil then ParseXML(ByNode);
-end;
-
-function TgdExtendedProperty.IsEmpty: boolean;
-begin
- Result:=(Length(Trim(FName))=0)
- and(Length(Trim(FValue))=0)
- and(FChildNodes.Count=0)
-end;
-
-procedure TgdExtendedProperty.ParseXML(const Node: TXMLNode);
-var i:integer;
-begin
-if Node = nil then Exit; //если узел не определен, то выходим
- if GetGDNodeType(Node.NameUnicode) <> gd_extendedProperty then //указан не тот узел
- raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_extendedProperty)]));
-try
-//заполняем поля класса данными из атрибутов
-FValue:=Node.AttributeByUnicodeName['value'];
-FName:=Node.AttributeByUnicodeName['name'];
-{заполняем список дочерних узлов}
-if Node.NodeCount>0 then
- begin
- for I := 0 to Node.NodeCount - 1 do
- FChildNodes.Add(TTextTag.Create(Node.Nodes[i]));
- end;
-except
- raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
-end;
-end;
-
-end.
+ классы и методы для работы с основой всех API - GData API.
+ Этот содуль должен подключаться в раздел uses всех прочих модулей, реализующих работу
+ с различными Google API}
+unit GDataCommon;
+
+interface
+
+uses
+ NativeXML, Classes, StrUtils, SysUtils, typinfo,
+ uLanguage, GConsts, Generics.Collections, DateUtils, httpsend;
+
+type
+{Class helper для объекта TXMLNode (узел XML-документа)
+ применяется для преобразования строк в кодировке UTF-8 (UTF8String) в UnicodeString (string) и наоборот}
+ TXMLNode_ = class helper for TXMLNode
+ private
+ function GetNameUnicode: string;
+ procedure SetNodeUnicode(const aName: string);
+ function GetAttributeUnicodeValue(index:integer): string;
+ procedure SetAttributeUnicodeValue(index:integer; const aValue:string);
+ function GetAttributeUnicodeName(index:integer):string;
+ procedure SetAttributeUnicodeName(index:integer; aValue:string);
+ function GetAttributeByUnicodeName(const aName: string):string;
+ procedure SetAttributeByUnicodeName(const aName,aValue: string);
+ public
+ function NodeNew(const AName: String): TXmlNode;overload;
+ function FindNode(const NodeName: String): TXmlNode;overload;
+ function ReadAttributeString(const AName: String; const ADefault: String = ''): String; overload;
+ procedure AttributeAdd(const AName, AValue: String); overload;
+ procedure WriteAttributeString(const AName: String; const AValue: String; const ADefault: String = ''); overload;
+ procedure NodesByName(const AName: string; AList: TList);overload;
+ property NameUnicode: string read GetNameUnicode write SetNodeUnicode;
+ property AttributeUnicodeValue[Index: integer]: String read GetAttributeUnicodeValue write SetAttributeUnicodeValue;
+ property AttributeUnicodeName[Index: integer]: String read GetAttributeUnicodeName write SetAttributeUnicodeName;
+ property AttributeByUnicodeName[const AName: String]: String read GetAttributeByUnicodeName
+ write SetAttributeByUnicodeName;
+end;
+
+
+type
+ { Перечислитель, определяющий узлы которые могут содержаться в XML-документе,
+ присланном Google и которые могут быть преобразованы классами модуля.
+ Например,
+ gd_email - определяет узел gd:email, который может быть преобразован с помощью
+ класса TgdEmail }
+ TgdEnum = (gd_country, gd_additionalName, gd_name, gd_email,
+ gd_extendedProperty, gd_geoPt, gd_im, gd_orgName, gd_orgTitle,
+ gd_organization, gd_originalEvent, gd_phoneNumber, gd_postalAddress,
+ gd_rating, gd_recurrence, gd_reminder, gd_resourceId, gd_when, gd_agent,
+ gd_housename, gd_street, gd_pobox, gd_neighborhood, gd_city, gd_subregion,
+ gd_region, gd_postcode, gd_formattedAddress, gd_structuredPostalAddress,
+ gd_entryLink, gd_where, gd_familyName, gd_givenName, gd_namePrefix,
+ gd_nameSuffix, gd_fullName, gd_orgDepartment, gd_orgJobDescription,
+ gd_orgSymbol, gd_famileName, gd_eventStatus, gd_visibility,
+ gd_transparency, gd_attendeeType, gd_attendeeStatus, gd_comments,
+ gd_deleted, gd_feedLink, gd_who, gd_recurrenceException);
+
+type
+ {Перечислитель, определяющие все возможные варианты значений для атрибутов Rel
+ XML-узла, определяющего событие}
+ TEventRel = (ev_None, ev_attendee, ev_organizer, ev_performer, ev_speaker,
+ ev_canceled, ev_confirmed, ev_tentative, ev_confidential, ev_default,
+ ev_private, ev_public, ev_opaque, ev_transparent, ev_optional, ev_required,
+ ev_accepted, ev_declined, ev_invited);
+
+ { Классы и структуры общего назначения для парсинга XML-документов.
+ Применяются в большинстве API Google и, как правило, узлы в XML-дереве не иеют
+ каких-либо префиксов }
+
+type
+ { Класс для отправки сообщений по HTTP-протоколу. Содержит необходимые поля и методы для работы с
+ интерфейсом Google ClientLogin }
+ THTTPSender = class(THTTPSend)
+ private
+ FMethod: string;
+ FURL: string;
+ FAuthKey: string;
+ FApiVersion: string;
+ FExtendedHeaders: TStringList;
+ procedure SetApiVersion(const Value: string);
+ procedure SetAuthKey(const Value: string);
+ procedure SetExtendedHeaders(const Value: TStringList);
+ procedure SetMethod(const Value: string);
+ procedure SetURL(const Value: string);
+ function HeadByName(const aHead: string; aHeaders: TStringList): string;
+ procedure AddGoogleHeaders;
+ public
+ { создает новый экземрляр класса.
+ * aMethod - метод, используемый в запросе (GET, POST, PUT и т.д.)
+ * aAuthKey - ключ для авторизации, который должен быть предварительно получен,
+ с использованием комопнента TGoogleLogin или другим способом
+ * aURL - адрес на которые будет отправлен запрос
+ * aAPIVersion - текущая версия API к которому будет осуществлен запрос }
+ constructor Create(const aMethod, aAuthKey, aURL, aAPIVersion: string);
+ {Очищает все поля класса, в т.ч. поля Headers и Cookies родителя}
+ procedure Clear;
+ {Получает точное значение размера документа, который должен быть скачан из Сети
+ с адреса aURL. Результат содержит размер документа, включая заголовки}
+ function GetLength(const aURL: string): integer;
+ {Отправляет запрос на сервер. True - в случае успешной отправки}
+ function SendRequest: boolean;
+ property Method: string read FMethod write SetMethod;//метод запроса (GET, POST, PUT и т.д.)
+ property URL: string read FURL write SetURL;//URL на который отправляется запрос
+ property AuthKey: string read FAuthKey write SetAuthKey;//ключ для авторизации на сервере Google
+ property ApiVersion: string read FApiVersion write SetApiVersion;//текущая версия API к которому планируется послать запрос
+ property ExtendedHeaders: TStringList read FExtendedHeaders write
+ SetExtendedHeaders;//дополнительные заголовки запроса. В этот список НЕ включаются заголовки, относящиеся к авторизации (они заполняются автоматически)
+ end;
+
+type
+ { Атрибут XML-узла }
+ TAttribute = packed record
+ Name: string;//имя атрибута
+ Value: string;//значение арибута
+ end;
+
+type
+ { Класс общего назначения, определющий любой XML-узел, который
+ содержит значение (текст). }
+ TTextTag = class
+ private
+ FName: string; // название узла
+ FValue: string; // значение узла
+ FAtributes: TList; // список атрибутов узла
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ Constructor Create(const ByNode: TXMLNode = nil); overload;
+ { Конструктор для создания эземпляра класса по известным значениям имени и текста }
+ constructor Create(const NodeName: string; NodeValue: string = '');
+ overload;
+ { Функция возвращает True в случае, если не определено свойство Name или
+ не определено значение узла или хотя бы один атрибут }
+ function IsEmpty: boolean;
+ { Очищает все поля класса }
+ procedure Clear;
+ { Разбирает узел Node:TXMLNode и заполняет на основании полученных данных поля класса }
+ procedure ParseXML(Node: TXMLNode);
+ { На основании значений свойств формирует новый XML-узел и помещает его как
+ дочерний для узла Root }
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ { Значение узла }
+ property Value: string read FValue write FValue;
+ { Название узла }
+ property Name: string read FName write FName;
+ { Атрибуты узла }
+ property Attributes: TListread FAtributes write FAtributes;
+ end;
+
+type
+ TEntryLink = class
+ private
+ Frel: string;
+ Ftype: string;
+ Fhref: string;
+ FEtag: string;
+ public
+ Constructor Create(const ByNode: TXMLNode = nil);
+ procedure ParseXML(Node: TXMLNode);
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ function IsEmpty:boolean;
+ procedure Clear;
+ property Rel: string read Frel write Frel;
+ property Ltype: string read Ftype write Ftype;
+ property Href: string read Fhref write Fhref;
+ property Etag: string read FEtag write FEtag;
+ end;
+
+type
+ TAuthorTag = Class
+ private
+ FAuthor: string;
+ FEmail: string;
+ FUID: string;
+ public
+ constructor Create(ByNode: TXMLNode = nil);
+ procedure ParseXML(Node: TXMLNode);
+ property Author: string read FAuthor write FAuthor;
+ property Email: string read FEmail write FEmail;
+ end;
+
+type
+ {Родительский класс для все классов, определющих значения событие (events)}
+ TgdEvent = class
+ private
+ Frel: TEventRel;
+ const
+ EvSuffix = 'ev_';//префикс для перечислителя TEventRel
+ { на входе имеется строка вида
+ 'http://schemas.google.com/g/2005#event.SSSSSS'
+ функция определяет тип события TEventRel }
+ function StrToRel(const aRel: string): TEventRel;
+ { на входе имеем тип события TEventRel
+ на выходе строку вида
+ 'http://schemas.google.com/g/2005#event.SSSSSS' }
+ function RelToStr(aRel: TEventRel): string;
+ public
+ {Создает пустой экземпляр класса}
+ Constructor Create;
+ {Очищает поля класса}
+ procedure Clear;
+ {Проверяет экземпляр класса на "пустоту". Возвращает false, если
+ поле FRel = ev_None}
+ function IsEmpty: boolean;
+ {перевод значения свойства Rel в тескт на языке разработчика}
+ function RelToString: string;
+ property Rel: TEventRel read Frel write Frel;//атрибут rel XML-узла
+ end;
+
+type
+ {Класс, определяющий статус события в календаре. Может принимать следующие значения:
+ * ev_canceled - событие отменено
+ * ev_confirmed - событие подтверждено и запланировано
+ * ev_tentative - событие предварительно запланировано}
+ TgdEventStatus = class(TgdEvent)
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ Constructor Create(const ByNode: TXMLNode = nil);
+ {Разбирает узел Node:TXMLNode и заполняет на основании полученных данных поля класса}
+ procedure ParseXML(Node: TXMLNode);
+ { На основании значений свойств формирует новый XML-узел и помещает его как
+ дочерний для узла Root }
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ end;
+
+ {Класс, определяющий видимость события в календаре для других пользователей. Может принимать следующие значения:
+ * ev_confidential - видимо только для приглашенных пользователей.
+ * ev_default - свойство видимости наследуется из настоек календаря
+ * ev_private - видимо только для создателя
+ * ev_public - видимо для всех}
+ TgdVisibility = class(TgdEvent)
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ Constructor Create(const ByNode: TXMLNode = nil);
+ { Разбирает узел XML и заполняет на основании полученных данных поля класса }
+ procedure ParseXML(Node: TXMLNode);
+ { На основании значений свойств формирует новый XML-узел и помещает его как
+ дочерний для узла Root }
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ end;
+
+type
+ TgdTransparency = class(TgdEvent)
+ public
+ Constructor Create(const ByNode: TXMLNode = nil);
+ procedure ParseXML(Node: TXMLNode);
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ end;
+
+type
+ TgdAttendeeType = class(TgdEvent)
+ public
+ Constructor Create(const ByNode: TXMLNode = nil);
+ procedure ParseXML(Node: TXMLNode);
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ end;
+
+type
+ TgdAttendeeStatus = class(TgdEvent)
+ public
+ Constructor Create(const ByNode: TXMLNode = nil);
+ procedure ParseXML(Node: TXMLNode);
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ end;
+
+type
+ TgdCountry = class
+ private
+ FCode: string;
+ FValue: string;
+ public
+ Constructor Create(const ByNode: TXMLNode = nil);
+ procedure Clear;
+ function IsEmpty: boolean;
+ procedure ParseXML(Node: TXMLNode);
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ property Code: string read FCode write FCode;
+ property Value: string read FValue write FValue;
+ end;
+
+type
+ TgdAdditionalName = TTextTag;
+ TgdFamilyName = TTextTag;
+ TgdGivenName = TTextTag;
+ TgdNamePrefix = TTextTag;
+ TgdNameSuffix = TTextTag;
+ TgdFullName = TTextTag;
+ TgdOrgDepartment = TTextTag;
+ TgdOrgJobDescription = TTextTag;
+ TgdOrgSymbol = TTextTag;
+
+type
+ TgdName = class
+ private
+ FGivenName: TTextTag;
+ FAdditionalName: TTextTag;
+ FFamilyName: TTextTag;
+ FNamePrefix: TTextTag;
+ FNameSuffix: TTextTag;
+ FFullName: TTextTag;
+ function GetFullName: string;
+ procedure SetFullName(aFullName: TTextTag);
+ procedure SetGivenName(aGivenName: TTextTag);
+ procedure SetAdditionalName(aAdditionalName: TTextTag);
+ procedure SetFamilyName(aFamilyName: TTextTag);
+ procedure SetNamePrefix(aNamePrefix: TTextTag);
+ procedure SetNameSuffix(aNameSuffix: TTextTag);
+ public
+ constructor Create(ByNode: TXMLNode = nil);
+ procedure ParseXML(const Node: TXMLNode);
+ procedure Clear;
+ function IsEmpty: boolean;
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ property GivenName: TTextTag read FGivenName write SetGivenName;
+ property AdditionalName
+ : TTextTag read FAdditionalName write SetAdditionalName;
+ property FamilyName: TTextTag read FFamilyName write SetFamilyName;
+ property NamePrefix: TTextTag read FNamePrefix write SetNamePrefix;
+ property NameSuffix: TTextTag read FNameSuffix write SetNameSuffix;
+ property FullName: TTextTag read FFullName write SetFullName;
+ property FullNameString: string read GetFullName;
+ end;
+
+type
+ TTypeElement = (em_None, em_home, em_other, em_work);
+
+ TgdEmail = class
+ private
+ FAddress: string;
+ Frel: TTypeElement;
+ FLabel: string;
+ FPrimary: boolean;
+ FDisplayName: string;
+ public
+ constructor Create(ByNode: TXMLNode = nil);
+ procedure Clear;
+ function IsEmpty: boolean;
+ procedure ParseXML(const Node: TXMLNode);
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ function RelToString: string;
+ property Address: string read FAddress write FAddress;
+ property Labl: string read FLabel write FLabel;
+ property Rel: TTypeElement read Frel write Frel;
+ property DisplayName: string read FDisplayName write FDisplayName;
+ property Primary: boolean read FPrimary write FPrimary;
+ end;
+
+type
+ {Класс, описывающие узел GData API gd:extendedProperty, который позволяет хранить ограниченный набор
+ пользовательских данных в виде атрибутов узла и дочерних узлов XML-документа}
+ TgdExtendedProperty = class
+ private
+ FName: string;
+ FValue: string;
+ FChildNodes: TList;
+ public
+ {Конструктор создает экземпляр класса. Если определен входной параметр
+ ByNode: TXMLNode, то на основании этого узла заполняются поля класса}
+ Constructor Create(const ByNode: TXMLNode = nil);
+ {Разбирает узел Node:TXMLNode и заполняет на основании полученных данных поля класса}
+ procedure ParseXML(const Node: TXMLNode);
+ { На основании значений свойств формирует новый XML-узел и помещает его как
+ дочерний для узла Root }
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ {Проверяет экземпляр класса на "пустоту". Возвращает false, если
+ в классе не определены поля FName и FValue, а также отсутствуют дочерние узлы}
+ function IsEmpty: boolean;
+ {Очищает поля класса}
+ procedure Clear;
+ property Name: string read FName write FName; //атрибут name узла
+ property Value: string read FValue write FValue;//атрибут value узла
+ property ChildNodes: TList read FChildNodes write FChildNodes;//список дочерних текстовых узлов
+ end;
+
+type
+ TgdGeoPtStruct = record
+ Elav: extended;
+ Labels: string;
+ Lat: extended;
+ Lon: extended;
+ Time: TDateTime;
+ end;
+
+type
+ TIMProtocol = (ti_None, ti_AIM, ti_MSN, ti_YAHOO, ti_SKYPE, ti_QQ,
+ ti_GOOGLE_TALK, ti_ICQ, ti_JABBER);
+ TIMtype = (im_None, im_home, im_netmeeting, im_other, im_work);
+
+ TgdIm = class
+ private
+ FAddress: string;
+ FLabel: string;
+ FPrimary: boolean;
+ FIMProtocol: TIMProtocol;
+ FIMType: TIMtype;
+ public
+ constructor Create(ByNode: TXMLNode = nil);
+ procedure ParseXML(const Node: TXMLNode);
+ procedure Clear;
+ function IsEmpty: boolean;
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ function ImTypeToString: string;
+ function ImProtocolToString: string;
+ property Address: string read FAddress write FAddress;
+ property iLabel: string read FLabel write FLabel;
+ property ImType: TIMtype read FIMType write FIMType;
+ property Protocol: TIMProtocol read FIMProtocol write FIMProtocol;
+ property Primary: boolean read FPrimary write FPrimary;
+ end;
+
+ TgdOrgName = TTextTag;
+ TgdOrgTitle = TTextTag;
+
+type
+ TgdOrganization = class
+ private
+ FLabel: string;
+ Frel: string;
+ FPrimary: boolean;
+ ForgName: TgdOrgName;
+ ForgTitle: TgdOrgTitle;
+ public
+ constructor Create(ByNode: TXMLNode = nil);
+ procedure ParseXML(const Node: TXMLNode);
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ function IsEmpty: boolean;
+ procedure Clear;
+ property Labl: string read FLabel write FLabel;
+ property Rel: string Read Frel write Frel;
+ property Primary: boolean read FPrimary write FPrimary;
+ property OrgName: TgdOrgName read ForgName write ForgName;
+ property OrgTitle: TgdOrgTitle read ForgTitle write ForgTitle;
+ end;
+
+type
+ TgdOriginalEventStruct = record
+ id: string;
+ Href: string;
+ end;
+
+type
+ TPhonesRel = (tp_None, tp_Assistant, tp_Callback, tp_Car, Tp_Company_main,
+ tp_Fax, tp_Home, tp_Home_fax, tp_Isdn, tp_Main, tp_Mobile, tp_Other,
+ tp_Other_fax, tp_Pager, tp_Radio, tp_Telex, tp_Tty_tdd, Tp_Work,
+ tp_Work_fax, tp_Work_mobile, tp_Work_pager);
+
+ TgdPhoneNumber = class
+ private
+ FPrimary: boolean;
+ FLabel: string;
+ Frel: TPhonesRel;
+ FUri: string;
+ FValue: string;
+ public
+ constructor Create(ByNode: TXMLNode = nil);
+ function IsEmpty: boolean;
+ procedure Clear;
+ procedure ParseXML(const Node: TXMLNode);
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ function RelToString: string;
+ property Primary: boolean read FPrimary write FPrimary;
+ property Labl: string read FLabel write FLabel;
+ property Rel: TPhonesRel read Frel write Frel;
+ property Uri: string read FUri write FUri;
+ property Text: string read FValue write FValue;
+ end;
+
+type
+ TgdPostalAddressStruct = record
+ Labels: string;
+ Rel: string;
+ Primary: boolean;
+ Text: string;
+ end;
+
+type
+ TgdRatingStruct = record
+ Average: extended;
+ Max: integer;
+ Min: integer;
+ numRaters: integer;
+ Rel: string;
+ Value: integer;
+ end;
+
+type
+ TgdRecurrence = class
+ private
+ FText: TStringList;
+ public
+ Constructor Create(const ByNode: TXMLNode = nil);
+ procedure Clear;
+ function IsEmpty: boolean;
+ procedure ParseXML(Node: TXMLNode);
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ property Text: TStringList read FText write FText;
+ end;
+
+ { TODO -oVlad -cBug : Переделать: добавить "неопределенное значение" в типы. Убрать константы }
+const
+ cMethods: array [0 .. 2] of string = ('alert', 'email', 'sms');
+
+type
+ TMethod = (tmAlert, tmEmail, tmSMS);
+ TRemindPeriod = (tpDays, tpHours, tpMinutes);
+
+type
+ TgdReminder = class(TPersistent)
+ private
+ FabsoluteTime: TDateTime;
+ FMethod: TMethod;
+ FPeriod: TRemindPeriod;
+ FPeriodValue: integer;
+ public
+ Constructor Create(const ByNode: TXMLNode);
+ procedure ParseXML(Node: TXMLNode);
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ property AbsTime: TDateTime read FabsoluteTime write FabsoluteTime;
+ property Method: TMethod read FMethod write FMethod;
+ property Period: TRemindPeriod read FPeriod write FPeriod;
+ property PeriodValue: integer read FPeriodValue write FPeriodValue;
+ end;
+
+type
+ TgdResourceIdStruct = string;
+
+type
+ TDateFormat = (tdDate, tdServerDate);
+
+ TgdWhen = class
+ private
+ FendTime: TDateTime;
+ FstartTime: TDateTime;
+ FvalueString: string;
+ public
+ Constructor Create(const ByNode: TXMLNode = nil);
+ procedure Clear;
+ function IsEmpty: boolean;
+ procedure ParseXML(Node: TXMLNode);
+ function AddToXML(Root: TXMLNode; DateFormat: TDateFormat): TXMLNode;
+ property endTime: TDateTime read FendTime write FendTime;
+ property startTime: TDateTime read FstartTime write FstartTime;
+ property valueString: string read FvalueString write FvalueString;
+ end;
+
+type
+ TgdAgent = TTextTag;
+ TgdHousename = TTextTag;
+ TgdStreet = TTextTag;
+ TgdPobox = TTextTag;
+ TgdNeighborhood = TTextTag;
+ TgdCity = TTextTag;
+ TgdSubregion = TTextTag;
+ TgdRegion = TTextTag;
+ TgdPostcode = TTextTag;
+ TgdFormattedAddress = TTextTag;
+
+type
+ TgdStructuredPostalAddress = class
+ private
+ Frel: string;
+ FMailClass: string;
+ FUsage: string;
+ FLabel: string;
+ FPrimary: boolean;
+ FAgent: TgdAgent;
+ FHouseName: TgdHousename;
+ FStreet: TgdStreet;
+ FPobox: TgdPobox;
+ FNeighborhood: TgdNeighborhood;
+ FCity: TgdCity;
+ FSubregion: TgdSubregion;
+ FRegion: TgdRegion;
+ FPostcode: TgdPostcode;
+ FCountry: TgdCountry;
+ FFormattedAddress: TgdFormattedAddress;
+ public
+ Constructor Create(const ByNode: TXMLNode = nil);
+ procedure Clear;
+ procedure ParseXML(Node: TXMLNode);
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ function IsEmpty: boolean;
+ property Rel: string read Frel write Frel;
+ property MailClass: string read FMailClass write FMailClass;
+ property Usage: string read FUsage write FUsage;
+ property Labl: string read FLabel write FLabel;
+ property Primary: boolean read FPrimary write FPrimary;
+ property Agent: TgdAgent read FAgent write FAgent;
+ property HouseName: TgdHousename read FHouseName write FHouseName;
+ property Street: TgdStreet read FStreet write FStreet;
+ property Pobox: TgdPobox read FPobox write FPobox;
+ property Neighborhood
+ : TgdNeighborhood read FNeighborhood write FNeighborhood;
+ property City: TgdCity read FCity write FCity;
+ property Subregion: TgdSubregion read FSubregion write FSubregion;
+ property Region: TgdRegion read FRegion write FRegion;
+ property Postcode: TgdPostcode read FPostcode write FPostcode;
+ property Coutry: TgdCountry read FCountry write FCountry;
+ property FormattedAddress: TgdFormattedAddress read FFormattedAddress write
+ FFormattedAddress;
+ end;
+
+type
+ TgdEntryLink = class
+ private
+ Fhref: string;
+ FReadOnly: boolean;
+ Frel: string;
+ FAtomEntry: TXMLNode;
+ public
+ Constructor Create(const ByNode: TXMLNode = nil);
+ procedure ParseXML(Node: TXMLNode);
+ procedure Clear;
+ function IsEmpty: boolean;
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ property Href: string read Fhref write Fhref;
+ property OnlyRead: boolean read FReadOnly write FReadOnly;
+ property Rel: string read Frel write Frel;
+ end;
+
+type
+ TgdWhere = class
+ private
+ FLabel: string;
+ Frel: string;
+ FvalueString: string;
+ FEntryLink: TgdEntryLink;
+ public
+ Constructor Create(const ByNode: TXMLNode = nil);
+ procedure Clear;
+ function IsEmpty: boolean;
+ procedure ParseXML(Node: TXMLNode);
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ property Labl: string read FLabel write FLabel;
+ property Rel: string read Frel write Frel;
+ property valueString: string read FvalueString write FvalueString;
+ property EntryLink: TgdEntryLink read FEntryLink write FEntryLink;
+ end;
+
+type
+ TWhoRel = (tw_None, tw_event_attendee, tw_event_organizer,
+ tw_event_performer, tw_event_speaker, tw_message_bcc, tw_message_cc,
+ tw_message_from, tw_message_reply_to, tw_message_to);
+
+ TgdWho = class
+ private
+ FEmail: string;
+ Frel: string;
+ FRelValue: TWhoRel;
+ FvalueString: string;
+ FAttendeeStatus: TgdAttendeeStatus;
+ FAttendeeType: TgdAttendeeType;
+ FEntryLink: TgdEntryLink;
+
+ const
+ RelValues: array [0 .. 8] of string = ('event.attendee', 'event.organizer',
+ 'event.performer', 'event.speaker', 'message.bcc', 'message.cc',
+ 'message.from', 'message.reply-to', 'message.to');
+ public
+ Constructor Create(const ByNode: TXMLNode = nil);
+ procedure Clear;
+ function IsEmpty: boolean;
+ procedure ParseXML(Node: TXMLNode);
+ function AddToXML(Root: TXMLNode): TXMLNode;
+ property Email: string read FEmail write FEmail;
+ property RelValue: TWhoRel read FRelValue write FRelValue;
+ property valueString: string read FvalueString write FvalueString;
+ property AttendeeStatus
+ : TgdAttendeeStatus read FAttendeeStatus write FAttendeeStatus;
+ property AttendeeType
+ : TgdAttendeeType read FAttendeeType write FAttendeeType;
+ property EntryLink: TgdEntryLink read FEntryLink write FEntryLink;
+ end;
+
+function GetGDNodeType(cName: string): TgdEnum; inline;
+function GetGDNodeName(NodeType: TgdEnum): string; inline;
+function ServerDateToDateTime(cServerDate: string): TDateTime;
+function DateTimeToServerDate(DateTime: TDateTime): string;
+
+implementation
+
+function DateTimeToServerDate(DateTime: TDateTime): string;
+var
+ Year, Mounth, Day, hours, Mins, Seconds, MSec: Word;
+ aYear, aMounth, aDay, ahours, aMins, aSeconds, aMSec: string;
+begin
+ DecodeDateTime(DateTime, Year, Mounth, Day, hours, Mins, Seconds, MSec);
+ aYear := IntToStr(Year);
+ if Mounth < 10 then
+ aMounth := '0' + IntToStr(Mounth)
+ else
+ aMounth := IntToStr(Mounth);
+ if Day < 10 then
+ aDay := '0' + IntToStr(Day)
+ else
+ aDay := IntToStr(Day);
+ if hours < 10 then
+ ahours := '0' + IntToStr(hours)
+ else
+ ahours := IntToStr(hours);
+ if Mins < 10 then
+ aMins := '0' + IntToStr(Mins)
+ else
+ aMins := IntToStr(Mins);
+ if Seconds < 10 then
+ aSeconds := '0' + IntToStr(Seconds)
+ else
+ aSeconds := IntToStr(Seconds);
+
+ case MSec of
+ 0 .. 9:
+ aMSec := '00' + IntToStr(MSec);
+ 10 .. 99:
+ aMSec := '0' + IntToStr(MSec);
+ else
+ aMSec := IntToStr(MSec);
+ end;
+ Result := aYear + '-' + aMounth + '-' + aDay + 'T' + ahours + ':' + aMins +
+ ':' + aSeconds + '.' + aMSec + 'Z';
+end;
+
+function ServerDateToDateTime(cServerDate: string): TDateTime;
+var
+ Year, Mounth, Day, hours, Mins, Seconds: Word;
+begin
+ Year := StrToInt(copy(cServerDate, 1, 4));
+ Mounth := StrToInt(copy(cServerDate, 6, 2));
+ Day := StrToInt(copy(cServerDate, 9, 2));
+ if Length(cServerDate) > 10 then
+ begin
+ hours := StrToInt(copy(cServerDate, 12, 2));
+ Mins := StrToInt(copy(cServerDate, 15, 2));
+ Seconds := StrToInt(copy(cServerDate, 18, 2));
+ end
+ else
+ begin
+ hours := 0;
+ Mins := 0;
+ Seconds := 0;
+ end;
+ Result := EncodeDateTime(Year, Mounth, Day, hours, Mins, Seconds, 0)
+end;
+
+function GetGDNodeName(NodeType: TgdEnum): string; inline;
+begin
+ Result := StringReplace(GetEnumName(TypeInfo(TgdEnum), ord(NodeType)), '_', ':',
+ [rfReplaceAll]);
+end;
+
+function GetGDNodeType(cName: string): TgdEnum;
+begin
+ Result := TgdEnum(GetEnumValue(TypeInfo(TgdEnum), ReplaceStr
+ (cName, ':', '_')));
+end;
+
+{ TgdWhere }
+
+function TgdWhere.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+ // добавляем узел
+ if Root = nil then
+ Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_where));
+ if Length(FLabel) > 0 then
+ Result.WriteAttributeString(sNodeLabelAttr, FLabel);
+ if Length(Frel) > 0 then
+ Result.WriteAttributeString(sNodeRelAttr, Frel);
+ if Length(FvalueString) > 0 then
+ Result.WriteAttributeString('valueString', FvalueString);
+ if FEntryLink <> nil then
+ if (FEntryLink.FAtomEntry <> nil) or (Length(FEntryLink.Fhref) > 0) then
+ FEntryLink.AddToXML(Result);
+end;
+
+procedure TgdWhere.Clear;
+begin
+ FLabel := '';
+ Frel := '';
+ FvalueString := '';
+end;
+
+constructor TgdWhere.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ Clear;
+ if ByNode = nil then
+ Exit;
+ FEntryLink := TgdEntryLink.Create(nil);
+ ParseXML(ByNode);
+end;
+
+function TgdWhere.IsEmpty: boolean;
+begin
+ Result := (Length(Trim(FLabel)) = 0) and (Length(Trim(Frel)) = 0) and
+ (Length(Trim(FvalueString)) = 0)
+end;
+
+procedure TgdWhere.ParseXML(Node: TXMLNode);
+begin
+ if GetGDNodeType(Node.NameUnicode) <> gd_where then
+ raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_where)]));
+ try
+ FLabel := Node.ReadAttributeString(sNodeLabelAttr);
+ if Length(FLabel) = 0 then
+ FLabel := Node.ReadAttributeString(sNodeRelAttr);
+ FvalueString := Node.ReadAttributeString('valueString');
+ if Node.NodeCount > 0 then // есть дочерний узел с EntryLink
+ begin
+ FEntryLink.ParseXML(Node.FindNode(gdNodeAlias + sEntryNodeName));
+ end;
+ except
+ Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TgdEntryLinkStruct }
+
+function TgdEntryLink.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_entryLink));
+ if Length(Trim(Fhref)) > 0 then
+ Result.WriteAttributeString(sNodeHrefAttr, Fhref);
+ if Length(Trim(Frel)) > 0 then
+ Result.WriteAttributeString(sNodeRelAttr, Frel);
+ Result.WriteAttributeBool('readOnly', FReadOnly);
+ if FAtomEntry <> nil then
+ Result.NodeAdd(FAtomEntry);
+end;
+
+procedure TgdEntryLink.Clear;
+begin
+ Fhref := '';
+ Frel := '';
+end;
+
+constructor TgdEntryLink.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ Clear;
+ if ByNode = nil then
+ Exit;
+ ParseXML(ByNode);
+end;
+
+function TgdEntryLink.IsEmpty: boolean;
+begin
+ Result := (Length(Trim(Fhref)) = 0) and (Length(Trim(Frel)) = 0)
+end;
+
+procedure TgdEntryLink.ParseXML(Node: TXMLNode);
+begin
+ if GetGDNodeType(Node.NameUnicode) <> gd_entryLink then
+ raise Exception.Create
+ (Format(sc_ErrCompNodes, [GetGDNodeName(gd_entryLink)]));
+ try
+ Fhref := Node.ReadAttributeString(sNodeHrefAttr);
+ Frel := Node.ReadAttributeString(sNodeRelAttr);
+ FReadOnly := Node.ReadAttributeBool('readOnly');
+ if Node.NodeCount > 0 then // есть дочерний узел с EntryLink
+ FAtomEntry := Node.FindNode(sEntryNodeName);
+ except
+ Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TgdEventStatus }
+
+function TgdEventStatus.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_eventStatus));
+ Result.WriteAttributeString(sNodeValueAttr, sSchemaHref + RelToStr(Frel));
+end;
+
+constructor TgdEventStatus.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ Clear;
+ if ByNode = nil then
+ Exit;
+ ParseXML(ByNode);
+end;
+
+procedure TgdEventStatus.ParseXML(Node: TXMLNode);
+begin
+ Frel := ev_None;
+ if Node = nil then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_eventStatus then
+ raise Exception.Create
+ (Format(sc_ErrCompNodes, [GetGDNodeName(gd_eventStatus)]));
+ try
+ Frel := StrToRel(Node.ReadAttributeString(sNodeValueAttr));
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TgdWhen }
+
+function TgdWhen.AddToXML(Root: TXMLNode; DateFormat: TDateFormat): TXMLNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_when));
+ case DateFormat of
+ tdDate:
+ Result.WriteAttributeString('startTime', FormatDateTime('yyyy-mm-dd', FstartTime));
+ tdServerDate:
+ Result.WriteAttributeString('startTime', DateTimeToServerDate(FstartTime));
+ end;
+
+ if FendTime > 0 then
+ Result.WriteAttributeString
+ ('endTime', DateTimeToServerDate(FendTime));
+ if Length(Trim(FvalueString)) > 0 then
+ Result.WriteAttributeString('valueString', FvalueString);
+end;
+
+procedure TgdWhen.Clear;
+begin
+ FendTime := 0;
+ FstartTime := 0;
+ FvalueString := '';
+end;
+
+constructor TgdWhen.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ Clear;
+ if ByNode = nil then
+ Exit;
+ ParseXML(ByNode);
+end;
+
+function TgdWhen.IsEmpty: boolean;
+begin
+ Result := FstartTime <= 0; // отсутствует обязательное поле
+end;
+
+procedure TgdWhen.ParseXML(Node: TXMLNode);
+begin
+ if Node = nil then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_when then
+ raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_when)]));
+ try
+ FendTime := 0;
+ FstartTime := 0;
+ FvalueString := '';
+ if Node.HasAttribute('endTime') then
+ FendTime := ServerDateToDateTime
+ (Node.ReadAttributeString('endTime'));
+ FstartTime := ServerDateToDateTime
+ (Node.ReadAttributeString('startTime'));
+ if Node.HasAttribute('valueString') then
+ FvalueString := Node.ReadAttributeString('valueString');
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TgdAttendeeStatus }
+
+function TgdAttendeeStatus.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_attendeeStatus));
+ Result.WriteAttributeString(sNodeValueAttr, sSchemaHref + RelToStr(Frel));
+end;
+
+constructor TgdAttendeeStatus.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ Clear;
+ if ByNode = nil then
+ Exit;
+ ParseXML(ByNode);
+end;
+
+procedure TgdAttendeeStatus.ParseXML(Node: TXMLNode);
+begin
+ Frel := ev_None;
+ if (Node = nil) or IsEmpty then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_attendeeStatus then
+ raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName
+ (gd_attendeeStatus)]));
+ try
+ Frel := StrToRel(Node.ReadAttributeString(sNodeValueAttr));
+ // TAttendeeStatus(GetEnumValue(TypeInfo(TAttendeeStatus),tmp));
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TgdAttendeeType }
+
+function TgdAttendeeType.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_attendeeType));
+ Result.WriteAttributeString(sNodeValueAttr, sSchemaHref + RelToStr(Frel));
+end;
+
+constructor TgdAttendeeType.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ Clear;
+ if ByNode = nil then
+ Exit;
+ ParseXML(ByNode);
+end;
+
+procedure TgdAttendeeType.ParseXML(Node: TXMLNode);
+begin
+ Frel := ev_None;
+ if Node = nil then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_attendeeType then
+ raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName
+ (gd_attendeeType)]));
+ try
+ Frel := StrToRel(Node.ReadAttributeString(sNodeValueAttr));
+ // TAttendeeType(GetEnumValue(TypeInfo(TAttendeeType),tmp));
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TgdWho }
+
+function TgdWho.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_who));
+ if Length(Trim(FEmail)) > 0 then
+ Result.WriteAttributeString('email', FEmail);
+ if Length(Trim(Frel)) > 0 then
+ Result.WriteAttributeString(sNodeRelAttr, sSchemaHref + RelValues[ord(FRelValue)]);
+ if Length(Trim(FvalueString)) > 0 then
+ Result.WriteAttributeString('valueString', FvalueString);
+ FAttendeeStatus.AddToXML(Result);
+ FAttendeeType.AddToXML(Result);
+ FEntryLink.AddToXML(Result);
+end;
+
+procedure TgdWho.Clear;
+begin
+ FEmail := '';
+ Frel := '';
+ FvalueString := '';
+ FAttendeeStatus.Clear;
+ FAttendeeType.Clear;
+ FEntryLink.Clear;
+end;
+
+constructor TgdWho.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ FAttendeeStatus := TgdAttendeeStatus.Create;
+ FAttendeeType := TgdAttendeeType.Create;
+ FEntryLink := TgdEntryLink.Create;
+ Clear;
+ if ByNode = nil then
+ Exit;
+ ParseXML(ByNode);
+end;
+
+function TgdWho.IsEmpty: boolean;
+begin
+ Result := (Length(Trim(FEmail)) = 0) and (Length(Trim(Frel)) = 0) and
+ (Length(Trim(FvalueString)) = 0) and (FAttendeeStatus.IsEmpty) and
+ (FAttendeeType.IsEmpty) and (FEntryLink.IsEmpty)
+end;
+
+procedure TgdWho.ParseXML(Node: TXMLNode);
+var
+ i: integer;
+ s: string;
+begin
+ if Node = nil then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_who then
+ raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_who)]));
+ try
+ FEmail := Node.ReadAttributeString('email');
+ if Length(Node.ReadAttributeString(sNodeRelAttr)) > 0 then
+ begin
+ s := Node.ReadAttributeString(sNodeRelAttr);
+ s := StringReplace(s, sSchemaHref, '', [rfIgnoreCase]);
+ FRelValue := TWhoRel(AnsiIndexStr(s, RelValues));
+ end;
+ FvalueString := Node.ReadAttributeString('valueString');
+ if Node.NodeCount > 0 then
+ begin
+ for i := 0 to Node.NodeCount - 1 do
+ case GetGDNodeType(Node.Nodes[i].NameUnicode) of
+ gd_attendeeStatus:
+ FAttendeeStatus := TgdAttendeeStatus.Create(Node.Nodes[i]);
+ gd_attendeeType:
+ FAttendeeType := TgdAttendeeType.Create(Node.Nodes[i]);
+ gd_entryLink:
+ FEntryLink := TgdEntryLink.Create(Node.Nodes[i]);
+ end;
+ end;
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TgdRecurrence }
+
+function TgdRecurrence.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_recurrence));
+ Result.ValueAsUnicodeString:=FText.Text;
+end;
+
+procedure TgdRecurrence.Clear;
+begin
+ FText.Clear;
+end;
+
+constructor TgdRecurrence.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ FText := TStringList.Create;
+ if ByNode = nil then
+ Exit;
+ ParseXML(ByNode);
+end;
+
+function TgdRecurrence.IsEmpty: boolean;
+begin
+ Result := FText.Count = 0
+end;
+
+procedure TgdRecurrence.ParseXML(Node: TXMLNode);
+begin
+ if Node = nil then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_recurrence then
+ raise Exception.Create
+ (Format(sc_ErrCompNodes, [GetGDNodeName(gd_recurrence)]));
+ try
+ FText.Text := Node.ValueAsUnicodeString;
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TgdReminder }
+
+function TgdReminder.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+ if Root = nil then
+ Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_reminder));
+ Result.WriteAttributeString('method', cMethods[ord(FMethod)]);
+ case FPeriod of
+ tpDays:
+ Result.WriteAttributeInteger('days', FPeriodValue);
+ tpHours:
+ Result.WriteAttributeInteger('hours', FPeriodValue);
+ tpMinutes:
+ Result.WriteAttributeInteger('minutes', FPeriodValue);
+ end;
+ if FabsoluteTime > 0 then
+ Result.WriteAttributeString('absoluteTime', DateTimeToServerDate(FabsoluteTime))
+end;
+
+constructor TgdReminder.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ FabsoluteTime := 0;
+ if ByNode = nil then
+ Exit;
+ ParseXML(ByNode);
+end;
+
+procedure TgdReminder.ParseXML(Node: TXMLNode);
+begin
+ if Node = nil then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_reminder then
+ raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_reminder)])
+ );
+ try
+ if Length(Node.ReadAttributeString('absoluteTime')) > 0 then
+ FabsoluteTime := ServerDateToDateTime
+ (Node.ReadAttributeString('absoluteTime'));
+ if Length(Node.ReadAttributeString('method')) > 0 then
+ FMethod := TMethod(AnsiIndexStr(Node.ReadAttributeString('method')
+ , cMethods));
+ if Node.AttributeIndexByname('days') >= 0 then
+ FPeriod := tpDays;
+ if Node.AttributeIndexByname('hours') >= 0 then
+ FPeriod := tpHours;
+ if Node.AttributeIndexByname('minutes') >= 0 then
+ FPeriod := tpMinutes;
+ case FPeriod of
+ tpDays:
+ FPeriodValue := Node.ReadAttributeInteger('days');
+ tpHours:
+ FPeriodValue := Node.ReadAttributeInteger('hours');
+ tpMinutes:
+ FPeriodValue := Node.ReadAttributeInteger('minutes');
+ end;
+
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TgdTransparency }
+
+function TgdTransparency.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result.WriteAttributeString(sNodeValueAttr, sSchemaHref + RelToStr(Frel));
+end;
+
+constructor TgdTransparency.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ Clear;
+ if ByNode = nil then
+ Exit;
+ ParseXML(ByNode);
+end;
+
+procedure TgdTransparency.ParseXML(Node: TXMLNode);
+begin
+ Frel := ev_None;
+ if Node = nil then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_transparency then
+ raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName
+ (gd_transparency)]));
+ try
+ Frel := StrToRel(Node.ReadAttributeString(sNodeValueAttr));
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TgdVisibility }
+
+function TgdVisibility.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result.WriteAttributeString(sNodeValueAttr, sSchemaHref + RelToStr(Frel));
+end;
+
+constructor TgdVisibility.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ Clear;
+ if ByNode = nil then
+ Exit;
+ ParseXML(ByNode);
+end;
+
+procedure TgdVisibility.ParseXML(Node: TXMLNode);
+begin
+ Frel := ev_None;
+ if Node = nil then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_visibility then
+ raise Exception.Create
+ (Format(sc_ErrCompNodes, [GetGDNodeName(gd_visibility)]));
+ try
+ Frel := StrToRel(Node.ReadAttributeString(sNodeValueAttr));
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TgdOrganization }
+
+function TgdOrganization.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+
+ Result := Root.NodeNew(GetGDNodeName(gd_organization));
+ if Trim(Frel) <> '' then
+ Result.WriteAttributeString(sNodeRelAttr, Frel);
+ if Trim(FLabel) <> '' then
+ Result.WriteAttributeString(sNodeLabelAttr, FLabel);
+ if FPrimary then
+ Result.WriteAttributeBool('primary', FPrimary);
+ if Trim(ForgName.Value) <> '' then
+ ForgName.AddToXML(Result);
+ if Trim(ForgTitle.Value) <> '' then
+ ForgTitle.AddToXML(Result);
+end;
+
+procedure TgdOrganization.Clear;
+begin
+ FLabel := '';
+ Frel := '';
+end;
+
+constructor TgdOrganization.Create(ByNode: TXMLNode);
+begin
+ inherited Create;
+ ForgName := TgdOrgName.Create;
+ ForgTitle := TgdOrgTitle.Create;
+ Clear;
+ if ByNode <> nil then
+ ParseXML(ByNode);
+
+end;
+
+function TgdOrganization.IsEmpty: boolean;
+begin
+ Result := (Length(Trim(FLabel)) = 0) and (Length(Trim(Frel)) = 0) and
+ (ForgName.IsEmpty) and (ForgTitle.IsEmpty)
+end;
+
+procedure TgdOrganization.ParseXML(const Node: TXMLNode);
+var
+ i: integer;
+begin
+ if (Node = nil) or IsEmpty then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_organization then
+ raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName
+ (gd_organization)]));
+ try
+ Frel := Node.ReadAttributeString(sNodeRelAttr);
+ if Node.HasAttribute('primary') then
+ FPrimary := Node.ReadAttributeBool('primary');
+ if Node.HasAttribute(sNodeLabelAttr) then
+ FLabel := Node.ReadAttributeString(sNodeLabelAttr);
+ for i := 0 to Node.NodeCount - 1 do
+ begin
+ if LowerCase(Node.Nodes[i].NameUnicode) = LowerCase
+ (GetGDNodeName(gd_orgName)) then
+ ForgName := TgdOrgName.Create(Node.Nodes[i])
+ else if LowerCase(Node.Nodes[i].NameUnicode) = LowerCase
+ (GetGDNodeName(gd_orgTitle)) then
+ ForgTitle := TgdOrgTitle.Create(Node.Nodes[i]);
+ end;
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TgdEmailStruct }
+
+function TgdEmail.AddToXML(Root: TXMLNode): TXMLNode;
+var
+ tmp: string;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_email));
+ if Frel <> em_None then
+ begin
+ tmp := GetEnumName(TypeInfo(TTypeElement), ord(Frel));
+ Delete(tmp, 1, 3);
+ Result.WriteAttributeString(sNodeRelAttr, sSchemaHref + tmp);
+ end;
+ if Trim(FLabel) <> '' then
+ Result.WriteAttributeString(sNodeLabelAttr, FLabel);
+ if Trim(FLabel) <> '' then
+ Result.WriteAttributeString('displayName', FDisplayName);
+ if FPrimary then
+ Result.WriteAttributeBool('primary', FPrimary);
+ Result.WriteAttributeString('address', FAddress);
+end;
+
+procedure TgdEmail.Clear;
+begin
+ FAddress := '';
+ FLabel := '';
+ Frel := em_None;
+ FDisplayName := '';
+end;
+
+constructor TgdEmail.Create(ByNode: TXMLNode);
+begin
+ inherited Create;
+ Clear;
+ if ByNode <> nil then
+ ParseXML(ByNode);
+end;
+
+function TgdEmail.IsEmpty: boolean;
+begin
+ Result := Length(Trim(FAddress)) = 0; // отсутствует обязательное поле
+end;
+
+procedure TgdEmail.ParseXML(const Node: TXMLNode);
+var
+ tmp: string;
+begin
+ Frel := em_None;
+ if Node = nil then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_email then
+ raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_email)]));
+ try
+ tmp := 'em_' + ReplaceStr(Node.ReadAttributeString(sNodeRelAttr),
+ sSchemaHref, '');
+ Frel := TTypeElement(GetEnumValue(TypeInfo(TTypeElement), tmp));
+ if Node.HasAttribute('primary') then
+ FPrimary := Node.ReadAttributeBool('primary');
+ if Node.HasAttribute(sNodeLabelAttr) then
+ FLabel := Node.ReadAttributeString(sNodeLabelAttr);
+ if Node.HasAttribute('displayName') then
+ FDisplayName := Node.ReadAttributeString('displayName');
+ FAddress := Node.ReadAttributeString('address');
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+function TgdEmail.RelToString: string;
+begin
+ case Frel of
+ em_None:
+ Result := ''; // значение не определено
+ em_home:
+ Result := LoadStr(c_EmailHome);
+ em_other:
+ Result := LoadStr(c_EmailOther);
+ em_work:
+ Result := LoadStr(c_EmailWork);
+ end;
+end;
+
+{ TgdNameStruct }
+
+function TgdName.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+
+ Result := Root.NodeNew(GetGDNodeName(gd_name));
+ if (AdditionalName <> nil) and (not AdditionalName.IsEmpty) then
+ AdditionalName.AddToXML(Result);
+
+ if (GivenName <> nil) and (not GivenName.IsEmpty) then
+ GivenName.AddToXML(Result);
+ if (FamilyName <> nil) and (not FamilyName.IsEmpty) then
+ FamilyName.AddToXML(Result);
+ if (not NamePrefix.IsEmpty) then
+ NamePrefix.AddToXML(Result);
+ if not NameSuffix.IsEmpty then
+ NameSuffix.AddToXML(Result);
+ if not FullName.IsEmpty then
+ FullName.AddToXML(Result);
+end;
+
+procedure TgdName.Clear;
+begin
+ FGivenName.Clear;
+ FAdditionalName.Clear;
+ FFamilyName.Clear;
+ FNamePrefix.Clear;
+ FNameSuffix.Clear;
+ FFullName.Clear;
+end;
+
+constructor TgdName.Create(ByNode: TXMLNode);
+begin
+ inherited Create;
+ FGivenName := TgdGivenName.Create(GetGDNodeName(gd_givenName));
+ FAdditionalName := TgdAdditionalName.Create
+ (string(GetGDNodeName(gd_additionalName)));
+ FFamilyName := TgdFamilyName.Create(GetGDNodeName(gd_familyName));
+ FNamePrefix := TgdNamePrefix.Create(GetGDNodeName(gd_namePrefix));
+ FNameSuffix := TgdNameSuffix.Create(GetGDNodeName(gd_nameSuffix));
+ FFullName := TgdFullName.Create(GetGDNodeName(gd_fullName));
+ if ByNode <> nil then
+ ParseXML(ByNode);
+end;
+
+function TgdName.GetFullName: string;
+begin
+ if FFullName <> nil then
+ Result := FFullName.Value;
+end;
+
+function TgdName.IsEmpty: boolean;
+begin
+ Result :=
+ FGivenName.IsEmpty and FAdditionalName.IsEmpty and FFamilyName.IsEmpty and
+ FNamePrefix.IsEmpty and FNameSuffix.IsEmpty and FFullName.IsEmpty;
+end;
+
+procedure TgdName.ParseXML(const Node: TXMLNode);
+var
+ i: integer;
+begin
+ if Node = nil then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_name then
+ raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_name)]));
+ try
+ for i := 0 to Node.NodeCount - 1 do
+ begin
+ case GetGDNodeType(Node.Nodes[i].NameUnicode) of
+ gd_givenName:
+ FGivenName.ParseXML(Node.Nodes[i]);
+ gd_additionalName:
+ FAdditionalName.ParseXML(Node.Nodes[i]);
+ gd_familyName:
+ FFamilyName.ParseXML(Node.Nodes[i]);
+ gd_namePrefix:
+ FNamePrefix.ParseXML(Node.Nodes[i]);
+ gd_nameSuffix:
+ FNameSuffix.ParseXML(Node.Nodes[i]);
+ gd_fullName:
+ FFullName.ParseXML(Node.Nodes[i]);
+ end;
+ end;
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+procedure TgdName.SetAdditionalName(aAdditionalName: TTextTag);
+begin
+ if aAdditionalName = nil then
+ Exit;
+ if Length(FAdditionalName.Name) = 0 then
+ FAdditionalName.Name := GetGDNodeName(gd_additionalName);
+ FAdditionalName.Value := aAdditionalName.Value;
+end;
+
+procedure TgdName.SetFamilyName(aFamilyName: TTextTag);
+begin
+ if aFamilyName = nil then
+ Exit;
+ if Length(FFamilyName.Name) = 0 then
+ FFamilyName.Name := GetGDNodeName(gd_familyName);
+ FFamilyName.Value := aFamilyName.Value;
+end;
+
+procedure TgdName.SetFullName(aFullName: TTextTag);
+begin
+ if aFullName = nil then
+ Exit;
+ if Length(FFullName.Name) = 0 then
+ FFullName.Name := GetGDNodeName(gd_fullName);
+ FFullName.Value := aFullName.Value;
+end;
+
+procedure TgdName.SetGivenName(aGivenName: TTextTag);
+begin
+ if aGivenName = nil then
+ Exit;
+ if Length(FGivenName.Name) = 0 then
+ FGivenName.Name := GetGDNodeName(gd_givenName);
+ FFullName.Value := aGivenName.Value;
+end;
+
+procedure TgdName.SetNamePrefix(aNamePrefix: TTextTag);
+begin
+ if aNamePrefix = nil then
+ Exit;
+ if Length(FNamePrefix.Name) = 0 then
+ FNamePrefix.Name := GetGDNodeName(gd_namePrefix);
+ FNamePrefix.Value := aNamePrefix.Value;
+end;
+
+procedure TgdName.SetNameSuffix(aNameSuffix: TTextTag);
+begin
+ if aNameSuffix = nil then
+ Exit;
+ if Length(FNameSuffix.Name) = 0 then
+ FNameSuffix.Name := GetGDNodeName(gd_nameSuffix);
+ FNameSuffix.Value := aNameSuffix.Value;
+end;
+
+{ TgdPhoneNumber }
+
+function TgdPhoneNumber.AddToXML(Root: TXMLNode): TXMLNode;
+var
+ tmp: string;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_phoneNumber));
+
+ if Frel <> tp_None then
+ begin
+ tmp := GetEnumName(TypeInfo(TPhonesRel), ord(Frel));
+ Delete(tmp, 1, 3);
+ Result.WriteAttributeString(sNodeRelAttr, sSchemaHref + tmp);
+ end;
+
+ Result.ValueAsUnicodeString := FValue;
+ if Trim(FLabel) <> '' then
+ Result.WriteAttributeString(sNodeLabelAttr, FLabel);
+ if Trim(FUri) <> '' then
+ Result.WriteAttributeString('uri', FUri);
+ if FPrimary then
+ Result.WriteAttributeBool('primary', FPrimary);
+end;
+
+procedure TgdPhoneNumber.Clear;
+begin
+ FLabel := '';
+ FUri := '';
+ FValue := '';
+end;
+
+constructor TgdPhoneNumber.Create(ByNode: TXMLNode);
+begin
+ inherited Create;
+ Clear;
+ if ByNode <> nil then
+ ParseXML(ByNode);
+end;
+
+function TgdPhoneNumber.IsEmpty: boolean;
+begin
+ Result := (Length(Trim(FLabel)) = 0) and (Length(Trim(FUri)) = 0) and
+ (Length(Trim(FValue)) = 0)
+end;
+
+procedure TgdPhoneNumber.ParseXML(const Node: TXMLNode);
+var
+ tmp: string;
+begin
+ Frel := tp_None;
+ if Node = nil then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_phoneNumber then
+ raise Exception.Create
+ (Format(sc_ErrCompNodes, [GetGDNodeName(gd_phoneNumber)]));
+ try
+ tmp := 'tp_' + ReplaceStr(Node.ReadAttributeString(sNodeRelAttr),
+ sSchemaHref, '');
+ if Length(tmp) > 3 then
+ Frel := TPhonesRel(GetEnumValue(TypeInfo(TPhonesRel), tmp));
+ if Node.HasAttribute('primary') then
+ FPrimary := Node.ReadAttributeBool('primary');
+ if Node.HasAttribute(sNodeLabelAttr) then
+ FLabel := Node.ReadAttributeString(sNodeLabelAttr);
+ if Node.HasAttribute('uri') then
+ FUri := Node.ReadAttributeString('uri');
+ FValue := Node.ValueAsUnicodeString;
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+function TgdPhoneNumber.RelToString: string;
+begin
+ case Frel of
+ tp_None:
+ Result := '';
+ tp_Assistant:
+ Result := LoadStr(c_PhoneAssistant);
+ tp_Callback:
+ Result := LoadStr(c_PhoneCallback);
+ tp_Car:
+ Result := LoadStr(c_PhoneCar);
+ Tp_Company_main:
+ Result := LoadStr(c_PhoneCompanymain);
+ tp_Fax:
+ Result := LoadStr(c_PhoneFax);
+ tp_Home:
+ Result := LoadStr(c_PhoneHome);
+ tp_Home_fax:
+ Result := LoadStr(c_PhoneHomefax);
+ tp_Isdn:
+ Result := LoadStr(c_PhoneIsdn);
+ tp_Main:
+ Result := LoadStr(c_PhoneMain);
+ tp_Mobile:
+ Result := LoadStr(c_PhoneMobile);
+ tp_Other:
+ Result := LoadStr(c_PhoneOther);
+ tp_Other_fax:
+ Result := LoadStr(c_PhoneOtherfax);
+ tp_Pager:
+ Result := LoadStr(c_PhonePager);
+ tp_Radio:
+ Result := LoadStr(c_PhoneRadio);
+ tp_Telex:
+ Result := LoadStr(c_PhoneTelex);
+ tp_Tty_tdd:
+ Result := LoadStr(c_PhoneTtytdd);
+ Tp_Work:
+ Result := LoadStr(c_PhoneWork);
+ tp_Work_fax:
+ Result := LoadStr(c_PhoneWorkfax);
+ tp_Work_mobile:
+ Result := LoadStr(c_PhoneWorkmobile);
+ tp_Work_pager:
+ Result := LoadStr(c_PhoneWorkpager);
+ end;
+end;
+
+{ TgdCountry }
+
+function TgdCountry.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_country));
+ if Trim(FCode) <> '' then
+ Result.WriteAttributeString('code', FCode);
+ Result.ValueAsUnicodeString := FValue;
+end;
+
+procedure TgdCountry.Clear;
+begin
+ FCode := '';
+ FValue := '';
+end;
+
+constructor TgdCountry.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ Clear;
+ if ByNode <> nil then
+ ParseXML(ByNode);
+end;
+
+function TgdCountry.IsEmpty: boolean;
+begin
+ Result := (Length(Trim(FCode)) = 0) and (Length(Trim(FValue)) = 0);
+end;
+
+procedure TgdCountry.ParseXML(Node: TXMLNode);
+begin
+ if Node = nil then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_country then
+ raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_country)])
+ );
+ try
+ FCode := Node.ReadAttributeString(sNodeRelAttr);
+ FValue := Node.ValueAsUnicodeString;
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TgdStructuredPostalAddressStruct }
+
+function TgdStructuredPostalAddress.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_structuredPostalAddress));
+ if Trim(Frel) <> '' then
+ Result.WriteAttributeString(sNodeRelAttr, Frel);
+ if Trim(FMailClass) <> '' then
+ Result.WriteAttributeString('mailClass', FMailClass);
+ if Trim(FLabel) <> '' then
+ Result.WriteAttributeString(sNodeLabelAttr, FLabel);
+ if Trim(FUsage) <> '' then
+ Result.WriteAttributeString('Usage', FUsage);
+ if FPrimary then
+ Result.WriteAttributeBool('primary', FPrimary);
+ if FAgent <> nil then
+ FAgent.AddToXML(Result);
+ if FHouseName <> nil then
+ FHouseName.AddToXML(Result);
+ if FStreet <> nil then
+ FStreet.AddToXML(Result);
+ if FPobox <> nil then
+ FPobox.AddToXML(Result);
+ if FNeighborhood <> nil then
+ FNeighborhood.AddToXML(Result);
+ if FCity <> nil then
+ FCity.AddToXML(Result);
+ if FSubregion <> nil then
+ FSubregion.AddToXML(Result);
+ if FRegion <> nil then
+ FRegion.AddToXML(Result);
+ if FPostcode <> nil then
+ FPostcode.AddToXML(Result);
+ if FCountry <> nil then
+ FCountry.AddToXML(Result);
+ if FFormattedAddress <> nil then
+ FFormattedAddress.AddToXML(Result);
+end;
+
+procedure TgdStructuredPostalAddress.Clear;
+begin
+ Frel := '';
+ FMailClass := '';
+ FUsage := '';
+ FLabel := '';
+ FAgent.Clear;
+ FHouseName.Clear;
+ FStreet.Clear;
+ FPobox.Clear;
+ FNeighborhood.Clear;
+ FCity.Clear;
+ FSubregion.Clear;
+ FRegion.Clear;
+ FPostcode.Clear;
+ FCountry.Clear;
+ FFormattedAddress.Clear;
+end;
+
+constructor TgdStructuredPostalAddress.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ FAgent := TgdAgent.Create;
+ FHouseName := TgdHousename.Create;
+ FStreet := TgdStreet.Create;
+ FPobox := TgdPobox.Create;
+ FNeighborhood := TgdNeighborhood.Create;
+ FCity := TgdCity.Create;
+ FSubregion := TgdSubregion.Create;
+ FRegion := TgdRegion.Create;
+ FPostcode := TgdPostcode.Create;
+ FCountry := TgdCountry.Create;
+ FFormattedAddress := TgdFormattedAddress.Create;
+
+ Clear;
+ if ByNode <> nil then
+ ParseXML(ByNode);
+end;
+
+function TgdStructuredPostalAddress.IsEmpty: boolean;
+begin
+ Result := (Length(Trim(Frel)) = 0) and (Length(Trim(FMailClass)) = 0) and
+ (Length(Trim(FUsage)) = 0) and (Length(Trim(FLabel)) = 0)
+ and FAgent.IsEmpty and FHouseName.IsEmpty and FStreet.IsEmpty and FPobox.
+ IsEmpty and FNeighborhood.IsEmpty and FCity.IsEmpty and FSubregion.IsEmpty
+ and FRegion.IsEmpty and FPostcode.IsEmpty and FCountry.IsEmpty and
+ FFormattedAddress.IsEmpty;
+end;
+
+procedure TgdStructuredPostalAddress.ParseXML(Node: TXMLNode);
+var
+ i: integer;
+begin
+ if Node = nil then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_structuredPostalAddress then
+ raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName
+ (gd_structuredPostalAddress)]));
+ try
+ Frel := Node.ReadAttributeString(sNodeRelAttr);
+ FMailClass := Node.ReadAttributeString('mailClass');
+ FLabel := Node.ReadAttributeString(sNodeLabelAttr);
+ if Node.HasAttribute('primaty') then
+ FPrimary := Node.ReadAttributeBool('primary');
+ FUsage := Node.ReadAttributeString('Usage');
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+ for i := 0 to Node.NodeCount - 1 do
+ begin
+ case GetGDNodeType(Node.Nodes[i].NameUnicode) of
+ gd_agent:
+ FAgent.ParseXML(Node.Nodes[i]);
+ gd_housename:
+ FHouseName.ParseXML(Node.Nodes[i]);
+ gd_street:
+ FStreet.ParseXML(Node.Nodes[i]);
+ gd_pobox:
+ FPobox.ParseXML(Node.Nodes[i]);
+ gd_neighborhood:
+ FNeighborhood.ParseXML(Node.Nodes[i]);
+ gd_city:
+ FCity.ParseXML(Node.Nodes[i]);
+ gd_subregion:
+ FSubregion.ParseXML(Node.Nodes[i]);
+ gd_region:
+ FRegion.ParseXML(Node.Nodes[i]);
+ gd_postcode:
+ FPostcode.ParseXML(Node.Nodes[i]);
+ gd_country:
+ FCountry.ParseXML(Node.Nodes[i]);
+ gd_formattedAddress:
+ FFormattedAddress.ParseXML(Node.Nodes[i]);
+ end;
+ end;
+end;
+
+{ TgdIm }
+
+function TgdIm.AddToXML(Root: TXMLNode): TXMLNode;
+var
+ tmp: string;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_im));
+ tmp := GetEnumName(TypeInfo(TIMtype), ord(FIMType));
+ Delete(tmp, 1, 3);
+ Result.WriteAttributeString(sNodeRelAttr, sSchemaHref + tmp);
+ Result.WriteAttributeString('address', FAddress);
+ Result.WriteAttributeString(sNodeLabelAttr, FLabel);
+
+ tmp := GetEnumName(TypeInfo(TIMProtocol), ord(FIMProtocol));
+ Delete(tmp, 1, 3);
+ Result.WriteAttributeString('protocol', sSchemaHref + tmp);
+
+ if FPrimary then
+ Result.WriteAttributeBool('primary', FPrimary);
+end;
+
+procedure TgdIm.Clear;
+begin
+ FAddress := '';
+ FLabel := '';
+end;
+
+constructor TgdIm.Create(ByNode: TXMLNode);
+begin
+ inherited Create;
+ Clear;
+ if ByNode <> nil then
+ ParseXML(ByNode);
+end;
+
+function TgdIm.ImProtocolToString: string;
+begin
+ Result := GetEnumName(TypeInfo(TIMProtocol), ord(FIMProtocol));
+ Delete(Result, 1, 3);
+end;
+
+function TgdIm.ImTypeToString: string;
+begin
+ case FIMType of
+ im_None:
+ Result := ''; // значение не определено
+ im_home:
+ Result := LoadStr(c_ImHome);
+ im_netmeeting:
+ Result := LoadStr(c_ImNetMeeting);
+ im_other:
+ Result := LoadStr(c_ImOther);
+ im_work:
+ Result := LoadStr(c_ImWork);
+ end;
+end;
+
+function TgdIm.IsEmpty: boolean;
+begin
+ Result := (Length(Trim(FAddress)) = 0); // отсутствует обязательное поле
+end;
+
+procedure TgdIm.ParseXML(const Node: TXMLNode);
+var
+ tmp: string;
+begin
+ FIMProtocol := ti_None;
+ FIMType := im_None;
+ if Node = nil then
+ Exit;
+ if GetGDNodeType(Node.NameUnicode) <> gd_im then
+ raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_im)]));
+ try
+ tmp := 'im_' + ReplaceStr(Node.ReadAttributeString(sNodeRelAttr),
+ sSchemaHref, '');
+ FIMType := TIMtype(GetEnumValue(TypeInfo(TIMtype), tmp));
+
+ FLabel := Node.ReadAttributeString(sNodeLabelAttr);
+ FAddress := Node.ReadAttributeString('address');
+
+ tmp := 'ti_' + ReplaceStr(Node.ReadAttributeString('protocol'),
+ sSchemaHref, '');
+ FIMProtocol := TIMProtocol(GetEnumValue(TypeInfo(TIMProtocol), tmp));
+
+ if Node.HasAttribute('primary') then
+ FPrimary := Node.ReadAttributeBool('primary');
+ except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TgdEvent }
+
+procedure TgdEvent.Clear;
+begin
+ Frel := ev_None;
+end;
+
+constructor TgdEvent.Create;
+begin
+ inherited Create;
+end;
+
+function TgdEvent.IsEmpty: boolean;
+begin
+ Result := Frel = ev_None;
+end;
+
+function TgdEvent.RelToStr(aRel: TEventRel): string;
+begin
+ Result := sSchemaHref + sEventRelSuffix +
+ ReplaceStr(GetEnumName(TypeInfo(TEventRel), ord(aRel)),
+ EvSuffix, '');;
+end;
+
+function TgdEvent.RelToString: string;
+begin
+ case Frel of
+ ev_attendee:
+ ;
+ ev_organizer:
+ ;
+ ev_performer:
+ ;
+ ev_speaker:
+ ;
+ ev_canceled:
+ Result := LoadStr(c_EventCancel);
+ ev_confirmed:
+ Result := LoadStr(c_EventConfirm);
+ ev_tentative:
+ Result := LoadStr(c_EventTentative);
+ ev_confidential:
+ Result := LoadStr(c_EventConfident);
+ ev_default:
+ Result := LoadStr(c_EventDefault);
+ ev_private:
+ Result := LoadStr(c_EventPrivate);
+ ev_public:
+ Result := LoadStr(c_EventPublic);
+ ev_opaque:
+ Result := LoadStr(c_EventOpaque);
+ ev_transparent:
+ Result := LoadStr(c_EventTransp);
+ ev_optional:
+ Result := LoadStr(c_EventOptional);
+ ev_required:
+ Result := LoadStr(c_EventRequired);
+ ev_accepted:
+ Result := LoadStr(c_EventAccepted);
+ ev_declined:
+ Result := LoadStr(c_EventDeclined);
+ ev_invited:
+ Result := LoadStr(c_EventInvited);
+ else
+ Result := '';
+ end;
+end;
+
+function TgdEvent.StrToRel(const aRel: string): TEventRel;
+var
+ tmp: string;
+begin
+ tmp := EvSuffix + ReplaceStr(aRel, sSchemaHref + sEventRelSuffix, '');
+ Result := TEventRel(GetEnumValue(TypeInfo(TEventRel), tmp));
+end;
+
+{ TTextTag }
+
+function TTextTag.AddToXML(Root: TXMLNode): TXMLNode;
+var
+ i: integer;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then
+ Exit;
+ Result := Root.NodeNew(UTF8string(FName));
+ Result.ValueAsUnicodeString := FValue;
+ for i := 0 to FAtributes.Count - 1 do
+ Result.AttributeAdd(UTF8string(FAtributes[i].Name), UTF8string
+ (FAtributes[i].Value));
+end;
+
+constructor TTextTag.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ FAtributes := TList.Create;
+ Clear;
+ if ByNode <> nil then
+ ParseXML(ByNode);
+end;
+
+procedure TTextTag.Clear;
+begin
+ FName := '';
+ FValue := '';
+ FAtributes.Clear;
+end;
+
+constructor TTextTag.Create(const NodeName: string; NodeValue: string);
+begin
+ inherited Create;
+ FName := NodeName;
+ FValue := NodeValue;
+ FAtributes := TList.Create;
+end;
+
+function TTextTag.IsEmpty: boolean;
+begin
+ Result := (Length(Trim(FName)) = 0) or ((Length(Trim(FValue)) = 0) and
+ (FAtributes.Count = 0));
+end;
+
+procedure TTextTag.ParseXML(Node: TXMLNode);
+var
+ i: integer;
+ Attr: TAttribute;
+begin
+ try
+ FValue := Node.ValueAsUnicodeString;
+ FName := Node.NameUnicode;
+ for i := 0 to Node.AttributeCount - 1 do
+ begin
+ Attr.Name := Node.AttributeUnicodeName[i];
+ Attr.Value := Node.AttributeUnicodeValue[i];
+ FAtributes.Add(Attr)
+ end;
+ except
+ Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TAuthorTag }
+constructor TAuthorTag.Create(ByNode: TXMLNode);
+begin
+ inherited Create;
+ if ByNode = nil then
+ Exit;
+ ParseXML(ByNode);
+end;
+
+procedure TAuthorTag.ParseXML(Node: TXMLNode);
+var
+ i: integer;
+begin
+ try
+ for i := 0 to Node.NodeCount - 1 do
+ begin
+ if Node.Nodes[i].Name = 'name' then
+ FAuthor := Node.Nodes[i].ValueAsUnicodeString
+ else if Node.Nodes[i].Name = 'email' then
+ FEmail := Node.Nodes[i].ValueAsUnicodeString
+ else if Node.Nodes[i].Name = 'uid' then
+ FUID := Node.Nodes[i].ValueAsUnicodeString;
+ end;
+ except
+ Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+ end;
+end;
+
+{ TEntryLink }
+
+function TEntryLink.AddToXML(Root: TXMLNode): TXMLNode;
+begin
+ Result := nil;
+end;
+
+procedure TEntryLink.Clear;
+begin
+ Frel:='';
+ Ftype:='';
+ Fhref:='';
+ FEtag:='';
+end;
+
+constructor TEntryLink.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ if ByNode <> nil then
+ ParseXML(ByNode);
+end;
+
+function TEntryLink.IsEmpty: boolean;
+begin
+ Result:=Length(Fhref)=0
+end;
+
+procedure TEntryLink.ParseXML(Node: TXMLNode);
+begin
+ if Node = nil then
+ Exit;
+ try
+ Frel := Node.ReadAttributeString(sNodeRelAttr);
+ Ftype := Node.ReadAttributeString('type');
+ Fhref := Node.ReadAttributeString(sNodeHrefAttr);
+ FEtag := Node.ReadAttributeString(gdNodeAlias + 'etag')
+ except Exception.Create(Format(sc_ErrPrepareNode, ['link']));
+ end;
+end;
+
+{ THTTPSender }
+
+procedure THTTPSender.AddGoogleHeaders;
+begin
+ Headers.Add('GData-Version: ' + FApiVersion);
+ Headers.Add('Authorization: GoogleLogin auth=' + FAuthKey);
+end;
+
+procedure THTTPSender.Clear;
+begin
+ inherited Clear;
+ FMethod := '';
+ FURL := '';
+ FAuthKey := '';
+ FApiVersion := '';
+ FExtendedHeaders.Clear;
+ Headers.Clear;
+ Cookies.Clear;
+end;
+
+constructor THTTPSender.Create(const aMethod, aAuthKey, aURL,
+ aAPIVersion: string);
+begin
+ inherited Create;
+ MimeType:='application/atom+xml';
+ FAuthKey := aAuthKey;
+ FURL := aURL;
+ FApiVersion := aAPIVersion;
+ FMethod := aMethod;
+ FExtendedHeaders := TStringList.Create;
+end;
+
+function THTTPSender.GetLength(const aURL: string): integer;
+var
+ size, content: Ansistring;
+ ch: AnsiChar;
+ h: TStringList;
+begin
+ with THTTPSend.Create do
+ begin
+ Headers.Add('GData-Version: ' + FApiVersion);
+ Headers.Add('Authorization: GoogleLogin auth=' + FAuthKey);
+ if HTTPMethod('HEAD', aURL) and (ResultCode = 200) then
+ begin
+ h := TStringList.Create;
+ h.Assign(Headers);
+ content := Ansistring(HeadByName('content-length', h));
+ h.Delete(h.IndexOf(HeadByName('Connection', h)));
+ h.Delete(h.IndexOf(string(content)));
+ for ch in content do
+ if ch in ['0' .. '9'] then
+ size := size + ch;
+ Result := StrToIntDef(string(size), 0) + Length(BytesOf(h.Text));
+ end
+ else
+ Result := -1;
+ end
+end;
+
+function THTTPSender.HeadByName(const aHead: string; aHeaders: TStringList)
+ : string;
+var
+ str: string;
+begin
+ Result := '';
+ for str in aHeaders do
+ begin
+ if pos(LowerCase(aHead), LowerCase(str)) > 0 then
+ begin
+ Result := str;
+ break;
+ end;
+ end;
+end;
+
+function THTTPSender.SendRequest: boolean;
+var
+ str: string;
+begin
+ Result := false;
+ if (Length(Trim(FMethod)) = 0) or (Length(Trim(FURL)) = 0) or
+ (Length(Trim(FAuthKey)) = 0) or (Length(Trim(FApiVersion)) = 0) then
+ Exit;
+ // добавляем необходимые заголовки
+ AddGoogleHeaders;
+ if FExtendedHeaders.Count > 0 then
+ for str in FExtendedHeaders do
+ Headers.Add(str);
+ Result := HTTPMethod(FMethod, FURL);
+end;
+
+procedure THTTPSender.SetApiVersion(const Value: string);
+begin
+ FApiVersion := Value;
+end;
+
+procedure THTTPSender.SetAuthKey(const Value: string);
+begin
+ FAuthKey := Value;
+end;
+
+procedure THTTPSender.SetExtendedHeaders(const Value: TStringList);
+begin
+ FExtendedHeaders := Value;
+end;
+
+procedure THTTPSender.SetMethod(const Value: string);
+begin
+ FMethod := Value;
+end;
+
+procedure THTTPSender.SetURL(const Value: string);
+begin
+ FURL := Value;
+end;
+
+{ TXMLNode_ }
+
+procedure TXMLNode_.AttributeAdd(const AName, AValue: String);
+begin
+ AttributeAdd(UTF8String(AName),UTF8String(AValue));
+end;
+
+function TXMLNode_.FindNode(const NodeName: String): TXmlNode;
+begin
+ Result:=FindNode(UTF8String(NodeName))
+end;
+
+function TXMLNode_.GetAttributeByUnicodeName(const aName: string): string;
+begin
+ Result:=string(AttributeByName[UTF8String(aName)]);
+end;
+
+function TXMLNode_.GetAttributeUnicodeName(index: integer): string;
+begin
+ Result:=string(AttributeName[index])
+end;
+
+function TXMLNode_.GetAttributeUnicodeValue(index:integer): string;
+begin
+ Result:=string(AttributeValue[index])
+end;
+
+function TXMLNode_.GetNameUnicode: string;
+begin
+ Result:=string(Name);
+end;
+
+function TXMLNode_.NodeNew(const AName: String): TXmlNode;
+begin
+ Result:=NodeNew(UTF8String(AName));
+end;
+
+procedure TXMLNode_.NodesByName(const AName: string; AList: TList);
+begin
+ if AList = nil then
+ AList:=TXmlNodeList.Create;
+ AList.Clear;
+ NodesByName(UTF8String(AName),AList);
+end;
+
+
+function TXMLNode_.ReadAttributeString(const AName,
+ ADefault: String): String;
+begin
+ Result:=string(ReadAttributeString(UTF8String(AName),UTF8String(ADefault)))
+end;
+
+procedure TXMLNode_.SetAttributeByUnicodeName(const aName, aValue: string);
+begin
+ AttributeByName[UTF8String(aName)]:=UTF8String(aValue);
+end;
+
+procedure TXMLNode_.SetAttributeUnicodeName(index: integer; aValue: string);
+begin
+ AttributeName[index]:=UTF8String(aValue);
+end;
+
+procedure TXMLNode_.SetAttributeUnicodeValue(index:integer;const aValue: string);
+begin
+ AttributeValue[index]:=UTF8String(aValue);
+end;
+
+procedure TXMLNode_.SetNodeUnicode(const aName: string);
+begin
+ Name:=UTF8String(aName);
+end;
+
+procedure TXMLNode_.WriteAttributeString(const AName, AValue, ADefault: String);
+begin
+ WriteAttributeString(UTF8String(AName),UTF8String(AValue),UTF8String(ADefault));
+end;
+
+{ TgdExtendedPropertyStruct }
+
+function TgdExtendedProperty.AddToXML(Root: TXMLNode): TXMLNode;
+var i: integer;
+begin
+ Result := nil;
+ if (Root = nil) or IsEmpty then Exit;
+ Result := Root.NodeNew(GetGDNodeName(gd_extendedProperty));
+ if Length(Trim(FName))>0 then
+ Result.WriteAttributeString('name',FName);
+ if Length(Trim(FValue))>0 then
+ Result.WriteAttributeString('value',FValue);
+ //добавляем все дочерние узлы
+ for i := 0 to FChildNodes.Count - 1 do
+ FChildNodes[i].AddToXML(Result)
+end;
+
+procedure TgdExtendedProperty.Clear;
+begin
+ FName:='';
+ FValue:='';
+ FChildNodes.Clear;
+end;
+
+constructor TgdExtendedProperty.Create(const ByNode: TXMLNode);
+begin
+ inherited Create;
+ FChildNodes:=TList.Create;
+ if ByNode<>nil then ParseXML(ByNode);
+end;
+
+function TgdExtendedProperty.IsEmpty: boolean;
+begin
+ Result:=(Length(Trim(FName))=0)
+ and(Length(Trim(FValue))=0)
+ and(FChildNodes.Count=0)
+end;
+
+procedure TgdExtendedProperty.ParseXML(const Node: TXMLNode);
+var i:integer;
+begin
+if Node = nil then Exit; //если узел не определен, то выходим
+ if GetGDNodeType(Node.NameUnicode) <> gd_extendedProperty then //указан не тот узел
+ raise Exception.Create(Format(sc_ErrCompNodes, [GetGDNodeName(gd_extendedProperty)]));
+try
+//заполняем поля класса данными из атрибутов
+FValue:=Node.AttributeByUnicodeName['value'];
+FName:=Node.AttributeByUnicodeName['name'];
+{заполняем список дочерних узлов}
+if Node.NodeCount>0 then
+ begin
+ for I := 0 to Node.NodeCount - 1 do
+ FChildNodes.Add(TTextTag.Create(Node.Nodes[i]));
+ end;
+except
+ raise Exception.Create(Format(sc_ErrPrepareNode, [Node.Name]));
+end;
+end;
+
+end.
<<<<<<< HEAD
=======
=======
diff --git a/source/GFeedBurner.pas b/source/GFeedBurner.pas
index c26be50..5f0516f 100644
--- a/source/GFeedBurner.pas
+++ b/source/GFeedBurner.pas
@@ -1,265 +1,265 @@
-{==============================================================================|
-|Проект: Google API в Delphi |
-|==============================================================================|
-|unit: GFeedBurner |
-|==============================================================================|
-|Описание: Модуль для обработки данных каналов в FeedBurner. |
-|==============================================================================|
-|Зависимости: |
-|1. Для работы с HTTP-протоколом используется библиотека Synapse (httpsend.pas)|
-|2. Для парсинга XML-документов используется библиотека NativeXML |
-|==============================================================================|
-| Автор: Vlad. (vlad383@gmail.com) |
-| Дата: |
-| Версия: см. ниже |
-| 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 |
-|==============================================================================|
-| История версий |
-|==============================================================================|
-| |
-|==============================================================================}
-unit GFeedBurner;
-
-interface
-
-uses Windows,SysUtils, Classes, wininet, DateUtils, StrUtils, NativeXML,
- TypInfo;
-
-resourcestring
- rsErrDate = 'Дата %s не может использоваться, так как она позднее текущей.';
- rsErrDateRange = 'Начальная дата не может быть больше конечной.';
- rsErrEntry = 'Недопустимое имя XML-узла. Имя узла должно быть ';
- rsUnknownError = 'Неопознанная ошибка';
- rsFeedAPIError = 'Ошибка доступа к API. Код: %d; Описание: %s';
- rsRequestError = 'Ошибка выполнения HTTP-запроса';
- //API Errors
- rsAPIErr_1 = 'Канал не найден';
- rsAPIErr_2 = 'Этот канал не предоставляет доступ к Awareness API';
- rsAPIErr_3 = 'Элемент не найден в канале';
- rsAPIErr_4 = 'Данные ограничены; у этого канала не включена статистика FeedBurner Stats PRO';
- rsAPIErr_5 = 'Отсутствует необходимый параметр (URI)';
- rsAPIErr_6 = 'Неправильный параметр (DATES)';
-
-const
- {версия модуля}
- GFeedBurnerVersion = 0.1;
- {шаблон URL для доступа к функциям API}
- AwaAPIParamURL = 'api/awareness/%s/%s';
- DateFormat = 'YYYY-MM-DD';
- APIVersion='1.0';
- MaxThrds = 10;
-
-type
- TFeedBurner = class;
- TEntryCollection = class;
- TResyndicationData = class;
- TBasicEntry = class;
-
-
- TItemChangeEvent = procedure(Item: TCollectionItem) of object;
- TOnAPIRequestError = procedure (const Code:integer; Error: string) of object;
- TOnProgress = procedure(const Date: TDate; ThreadIdx:byte;
- ProgressCurrent,ProgressMax:int64) of object;
- TOnDownload = TNotifyEvent;
- TOnThreadEnd = procedure(ThreadIdx:integer; Actives:byte)of object;
- TOnThreadStart = procedure (ThreadIdx:integer; Actives:byte) of object;
- TOnParseElement = procedure (Item:TBasicEntry) of object;
-
-
- EFeedBurner = class(Exception)
- private
- class var FAPILatErrCode: integer;
- class var FAPILastErrText: string;
- public
- class procedure ParseError(XMLNode: TXMLNode);overload;
- class procedure ParseError(XMLDoc: TNativeXML);overload;
- constructor CreateByXML(XMLDoc: TNativeXML);
- end;
-
- PDouble = ^double;
- TDateList = class(TList)
- private
- function GetItem(index:integer): TDate;
- procedure SetItem(index:integer;Value: TDate);
- public
- procedure Add(Date: TDate);
- procedure AddRange(StartDate,EndDate: TDate);
- procedure DeleteDuplicates;
- procedure SortDates;
- property Items[Index: Integer]: TDate read GetItem write SetItem; default;
- end;
-
-
-{Содержимое узла Entry при запросе GetFeedData}
- TBasicEntry = class(TCollectionItem)
- private
- Fdate: TDate;
- Fcirculation: integer;
- Fhits: integer;
- Freach: integer;
- Fdownloads: integer;
- FNode: TXMLNode;
- FResyndicationData: TResyndicationData;
- procedure SetNode(const Value: TXMLNode);virtual;
- procedure ParseXML(Node:TXMLNode);virtual;
- public
- constructor Create(Collection: TCollection);override;
- property Date: TDate read FDate;//дата за которую получены данные
- property Circulation: integer read FCirculation;//приблизительно количество людей, подписаых на фид
- property Hits: integer read FHits;//количество запросов данных из фида
- property Reach: integer read FReach;//охват аудитории
- property Downloads: integer read FDownloads;//количество закачек файлов
- property Node: TXMLNode read FNode write SetNode;//узел XML для разбора
- property FeedItems: TResyndicationData read FResyndicationData;
- end;
-
- TEntryCollection = class(TCollection)
- private
- FFeedBurner: TFeedBurner;
- FOnItemChange: TItemChangeEvent;
- function GetItem(Index: Integer): TBasicEntry;
- procedure SetItem(Index: Integer; const Value: TBasicEntry);
- protected
- function GetOwner: TPersistent; override;
- procedure Update(Item: TCollectionItem); override;
- procedure DoItemChange(Item: TCollectionItem); dynamic;
- public
- constructor Create(FeedBurner: TFeedBurner);
- function Add: TBasicEntry;
- function IndexOf(Date: TDate):integer;
- property Items[Index: Integer]: TBasicEntry read GetItem write SetItem; default;
- published
- property OnItemChange: TItemChangeEvent read FOnItemChange write FOnItemChange;
- end;
-
- TItemData = class(TCollectionItem)
- private
- FTitle: string;
- FURL: string;
- FItemViews: integer;
- FClickThroughs: integer;
- FNode: TXMLNode;
- procedure ParseXML(Node: TXMLNode);virtual;
- procedure SetNode(aNode:TXmlNode);virtual;
- public
- constructor Create(Collection: TCollection);override;
- property Title: string read FTitle;
- property URL: string read FURL;
- property ItemViews: integer read FItemViews;
- property ClickThroughs: integer read FClickThroughs;
- property Node: TXMLNode read FNode write SetNode;
- end;
-
- TReferrer = class(TCollectionItem)
- private
- FItemViews: integer;
- FClickThroughs: integer;
- FURL : string;
- FNode: TXMLNode;
- procedure SetNode(aNode:TXMLNode);virtual;
- procedure ParseXML(Node: TXMLNode);virtual;
- public
- constructor Create(Collection: TCollection);override;
- property URL: string read FURL;
- property ItemViews: integer read FItemViews;
- property ClickThroughs: integer read FClickThroughs;
- property Node: TXMLNode read FNode write SetNode;
- end;
-
- TReferrerCollection = class(TCollection)
- private
- function GetItem(Index: Integer): TReferrer;
- procedure SetItem(Index: Integer; const Value: TReferrer);
- protected
- procedure Update(Item: TCollectionItem); override;
- public
- constructor Create;
- function Add: TReferrer;
- property Items[Index: Integer]: TReferrer read GetItem write SetItem; default;
- end;
-
- TResyndicationItem = class(TItemData)
- private
- FReferrers:TReferrerCollection;
- procedure ParseXML(Node: TXMLNode);override;
- procedure SetNode(aNode:TXmlNode);override;
- public
- constructor Create(Collection: TCollection);override;
- property Title;
- property URL;
- property ItemViews;
- property ClickThroughs;
- property Node;
- property Referrers: TReferrerCollection read FReferrers;
- end;
-
- TResyndicationData = class(TCollection)
- private
- function GetItem(Index: Integer): TResyndicationItem;
- procedure SetItem(Index: Integer; const Value: TResyndicationItem);
- protected
- procedure Update(Item: TCollectionItem); override;
- public
- constructor Create();
- function Add: TResyndicationItem;
- property Items[Index: Integer]: TResyndicationItem read GetItem write SetItem; default;
- end;
-
- TRangeType = (trSingle, trDescrete, trContinued);
-
- TDateItem = class(TCollectionItem)
- private
- FStartDate: TDate;
- FEndDate : TDate;
- FRangeType: TRangeType;
- procedure SetRangeType(Value:TRangeType);
- procedure SetEndDate(Value: TDate);
- procedure SetStartDate(Value: TDate);
- procedure Update;
- public
- constructor Create(Collection: TCollection);override;
- published
- property RangeType: TRangeType read FRangeType write SetRangeType;
- property StartDate: TDate read FStartDate write SetStartDate;
- property EndDate: TDate read FEndDate write SetEndDate;
- end;
-
- TTimeLine = class(TCollection)
- private
- FFeedBurner: TFeedBurner;
- function GetItem(Index: Integer): TDateItem;
- procedure SetItem(Index: Integer; const Value: TDateItem);
- protected
- procedure Update(Item: TCollectionItem); override;
- function GetOwner: TPersistent;
- public
- constructor Create(FeedBurner: TFeedBurner);
- function Add: TDateItem;
- property Items[Index: Integer]: TDateItem read GetItem write SetItem; default;
- end;
-
- TOperation = (toGetFeedData, toGetItemData, toGetResyndicationData);
-
- // поток используется только для получения XML-страницы
+{==============================================================================|
+|Проект: Google API в Delphi |
+|==============================================================================|
+|unit: GFeedBurner |
+|==============================================================================|
+|Описание: Модуль для обработки данных каналов в FeedBurner. |
+|==============================================================================|
+|Зависимости: |
+|1. Для работы с HTTP-протоколом используется библиотека Synapse (httpsend.pas)|
+|2. Для парсинга XML-документов используется библиотека NativeXML |
+|==============================================================================|
+| Автор: Vlad. (vlad383@gmail.com) |
+| Дата: |
+| Версия: см. ниже |
+| 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 |
+|==============================================================================|
+| История версий |
+|==============================================================================|
+| |
+|==============================================================================}
+unit GFeedBurner;
+
+interface
+
+uses Windows,SysUtils, Classes, wininet, DateUtils, StrUtils, NativeXML,
+ TypInfo;
+
+resourcestring
+ rsErrDate = 'Дата %s не может использоваться, так как она позднее текущей.';
+ rsErrDateRange = 'Начальная дата не может быть больше конечной.';
+ rsErrEntry = 'Недопустимое имя XML-узла. Имя узла должно быть ';
+ rsUnknownError = 'Неопознанная ошибка';
+ rsFeedAPIError = 'Ошибка доступа к API. Код: %d; Описание: %s';
+ rsRequestError = 'Ошибка выполнения HTTP-запроса';
+ //API Errors
+ rsAPIErr_1 = 'Канал не найден';
+ rsAPIErr_2 = 'Этот канал не предоставляет доступ к Awareness API';
+ rsAPIErr_3 = 'Элемент не найден в канале';
+ rsAPIErr_4 = 'Данные ограничены; у этого канала не включена статистика FeedBurner Stats PRO';
+ rsAPIErr_5 = 'Отсутствует необходимый параметр (URI)';
+ rsAPIErr_6 = 'Неправильный параметр (DATES)';
+
+const
+ {версия модуля}
+ GFeedBurnerVersion = 0.1;
+ {шаблон URL для доступа к функциям API}
+ AwaAPIParamURL = 'api/awareness/%s/%s';
+ DateFormat = 'YYYY-MM-DD';
+ APIVersion='1.0';
+ MaxThrds = 10;
+
+type
+ TFeedBurner = class;
+ TEntryCollection = class;
+ TResyndicationData = class;
+ TBasicEntry = class;
+
+
+ TItemChangeEvent = procedure(Item: TCollectionItem) of object;
+ TOnAPIRequestError = procedure (const Code:integer; Error: string) of object;
+ TOnProgress = procedure(const Date: TDate; ThreadIdx:byte;
+ ProgressCurrent,ProgressMax:int64) of object;
+ TOnDownload = TNotifyEvent;
+ TOnThreadEnd = procedure(ThreadIdx:integer; Actives:byte)of object;
+ TOnThreadStart = procedure (ThreadIdx:integer; Actives:byte) of object;
+ TOnParseElement = procedure (Item:TBasicEntry) of object;
+
+
+ EFeedBurner = class(Exception)
+ private
+ class var FAPILatErrCode: integer;
+ class var FAPILastErrText: string;
+ public
+ class procedure ParseError(XMLNode: TXMLNode);overload;
+ class procedure ParseError(XMLDoc: TNativeXML);overload;
+ constructor CreateByXML(XMLDoc: TNativeXML);
+ end;
+
+ PDouble = ^double;
+ TDateList = class(TList)
+ private
+ function GetItem(index:integer): TDate;
+ procedure SetItem(index:integer;Value: TDate);
+ public
+ procedure Add(Date: TDate);
+ procedure AddRange(StartDate,EndDate: TDate);
+ procedure DeleteDuplicates;
+ procedure SortDates;
+ property Items[Index: Integer]: TDate read GetItem write SetItem; default;
+ end;
+
+
+{Содержимое узла Entry при запросе GetFeedData}
+ TBasicEntry = class(TCollectionItem)
+ private
+ Fdate: TDate;
+ Fcirculation: integer;
+ Fhits: integer;
+ Freach: integer;
+ Fdownloads: integer;
+ FNode: TXMLNode;
+ FResyndicationData: TResyndicationData;
+ procedure SetNode(const Value: TXMLNode);virtual;
+ procedure ParseXML(Node:TXMLNode);virtual;
+ public
+ constructor Create(Collection: TCollection);override;
+ property Date: TDate read FDate;//дата за которую получены данные
+ property Circulation: integer read FCirculation;//приблизительно количество людей, подписаых на фид
+ property Hits: integer read FHits;//количество запросов данных из фида
+ property Reach: integer read FReach;//охват аудитории
+ property Downloads: integer read FDownloads;//количество закачек файлов
+ property Node: TXMLNode read FNode write SetNode;//узел XML для разбора
+ property FeedItems: TResyndicationData read FResyndicationData;
+ end;
+
+ TEntryCollection = class(TCollection)
+ private
+ FFeedBurner: TFeedBurner;
+ FOnItemChange: TItemChangeEvent;
+ function GetItem(Index: Integer): TBasicEntry;
+ procedure SetItem(Index: Integer; const Value: TBasicEntry);
+ protected
+ function GetOwner: TPersistent; override;
+ procedure Update(Item: TCollectionItem); override;
+ procedure DoItemChange(Item: TCollectionItem); dynamic;
+ public
+ constructor Create(FeedBurner: TFeedBurner);
+ function Add: TBasicEntry;
+ function IndexOf(Date: TDate):integer;
+ property Items[Index: Integer]: TBasicEntry read GetItem write SetItem; default;
+ published
+ property OnItemChange: TItemChangeEvent read FOnItemChange write FOnItemChange;
+ end;
+
+ TItemData = class(TCollectionItem)
+ private
+ FTitle: string;
+ FURL: string;
+ FItemViews: integer;
+ FClickThroughs: integer;
+ FNode: TXMLNode;
+ procedure ParseXML(Node: TXMLNode);virtual;
+ procedure SetNode(aNode:TXmlNode);virtual;
+ public
+ constructor Create(Collection: TCollection);override;
+ property Title: string read FTitle;
+ property URL: string read FURL;
+ property ItemViews: integer read FItemViews;
+ property ClickThroughs: integer read FClickThroughs;
+ property Node: TXMLNode read FNode write SetNode;
+ end;
+
+ TReferrer = class(TCollectionItem)
+ private
+ FItemViews: integer;
+ FClickThroughs: integer;
+ FURL : string;
+ FNode: TXMLNode;
+ procedure SetNode(aNode:TXMLNode);virtual;
+ procedure ParseXML(Node: TXMLNode);virtual;
+ public
+ constructor Create(Collection: TCollection);override;
+ property URL: string read FURL;
+ property ItemViews: integer read FItemViews;
+ property ClickThroughs: integer read FClickThroughs;
+ property Node: TXMLNode read FNode write SetNode;
+ end;
+
+ TReferrerCollection = class(TCollection)
+ private
+ function GetItem(Index: Integer): TReferrer;
+ procedure SetItem(Index: Integer; const Value: TReferrer);
+ protected
+ procedure Update(Item: TCollectionItem); override;
+ public
+ constructor Create;
+ function Add: TReferrer;
+ property Items[Index: Integer]: TReferrer read GetItem write SetItem; default;
+ end;
+
+ TResyndicationItem = class(TItemData)
+ private
+ FReferrers:TReferrerCollection;
+ procedure ParseXML(Node: TXMLNode);override;
+ procedure SetNode(aNode:TXmlNode);override;
+ public
+ constructor Create(Collection: TCollection);override;
+ property Title;
+ property URL;
+ property ItemViews;
+ property ClickThroughs;
+ property Node;
+ property Referrers: TReferrerCollection read FReferrers;
+ end;
+
+ TResyndicationData = class(TCollection)
+ private
+ function GetItem(Index: Integer): TResyndicationItem;
+ procedure SetItem(Index: Integer; const Value: TResyndicationItem);
+ protected
+ procedure Update(Item: TCollectionItem); override;
+ public
+ constructor Create();
+ function Add: TResyndicationItem;
+ property Items[Index: Integer]: TResyndicationItem read GetItem write SetItem; default;
+ end;
+
+ TRangeType = (trSingle, trDescrete, trContinued);
+
+ TDateItem = class(TCollectionItem)
+ private
+ FStartDate: TDate;
+ FEndDate : TDate;
+ FRangeType: TRangeType;
+ procedure SetRangeType(Value:TRangeType);
+ procedure SetEndDate(Value: TDate);
+ procedure SetStartDate(Value: TDate);
+ procedure Update;
+ public
+ constructor Create(Collection: TCollection);override;
+ published
+ property RangeType: TRangeType read FRangeType write SetRangeType;
+ property StartDate: TDate read FStartDate write SetStartDate;
+ property EndDate: TDate read FEndDate write SetEndDate;
+ end;
+
+ TTimeLine = class(TCollection)
+ private
+ FFeedBurner: TFeedBurner;
+ function GetItem(Index: Integer): TDateItem;
+ procedure SetItem(Index: Integer; const Value: TDateItem);
+ protected
+ procedure Update(Item: TCollectionItem); override;
+ function GetOwner: TPersistent;
+ public
+ constructor Create(FeedBurner: TFeedBurner);
+ function Add: TDateItem;
+ property Items[Index: Integer]: TDateItem read GetItem write SetItem; default;
+ end;
+
+ TOperation = (toGetFeedData, toGetItemData, toGetResyndicationData);
+
+ // поток используется только для получения XML-страницы
TRSSThread = class(TThread)
private
FDate: TDate; //дата за которую необходимо получить данные
@@ -290,500 +290,500 @@ TRSSThread = class(TThread)
property OnParseElement: TOnParseElement read FOnParseElement write FOnParseElement;
property OnThreadStart: TOnThreadStart read FOnThreadStart write FOnThreadStart;
end;
-
-
- TFeedBurner = class(TComponent)
- private
- FThread : array of TRSSThread;
- FFeedURL: string; //URL фида, например, http://feeds.feedburner.com/myDelphi
- Furi: string; //URI фида, например, myDelphi
- FDates: TDateList; //список дат за которые необходимо получить статистику
- FFeedData:TEntryCollection;//данные по фиду
- FSilent: boolean; //тихая обработка исключений API - все исключения API обрабатываются в событии
- FOnAPIRequestError:TOnAPIRequestError;//событие при возникновении исключения API
- FOnProgress: TOnProgress;
- FNextDateIdx: integer;
- FMaxThreads: byte;
- FAllThreads: byte;
- FAPIMethod: TOperation;
- FTimeLine : TTimeLine;
- FOnParseElement: TOnParseElement;
- FOnThreadStart: TOnThreadStart;
- FOnThreadEnd:TOnThreadEnd;
- FOnDone : TOnDownload;
- procedure SetRange(const Value: TDateList);
- procedure SetFeedURL(const Value: string);
- procedure DoSilentError(XMLDoc:TNativeXml);
- procedure EndThread(ThreadIdx:integer; All:byte=0);
- procedure CreateThread(idx:integer; aDate:TDate);
- procedure SetMaxThreads(Value:byte);
- procedure SetTimeLine(Value: TTimeLine);
- procedure SetTimeLIme(const Value: TTimeLine);
- procedure GetDates;
- public
- constructor Create(AOwner: TComponent);override;
- procedure Stop;
- procedure Start;
- destructor Destroy;override;
- property FeedData:TEntryCollection read FFeedData;
- property Dates: TDateList read FDates;
- published
- property APIMethod: TOperation read FAPIMethod write FAPIMethod;
- property FeedURL: string read FFeedURL write SetFeedURL;
- property SilentAPI: boolean read FSilent write FSilent;
- property MaxThreads: byte read FMaxThreads write SetMaxThreads;
- property TimeLine : TTimeLine read FTimeLine write SetTimeLIme;
- property OnAPIRequestError:TOnAPIRequestError read FOnAPIRequestError
- write FOnAPIRequestError;
- property OnProgress:TOnProgress read FOnProgress write FOnProgress;
- property OnParseElement: TOnParseElement read FOnParseElement write FOnParseElement;
- property OnThreadStart: TOnThreadStart read FOnThreadStart write FOnThreadStart;
- property OnThreadEnd:TOnThreadEnd read FOnThreadEnd write FOnThreadEnd;
- property OnDone : TOnDownload read FOnDone write FOnDone;
-
-end;
-
-function Comparator(Item1, Item2: pointer): integer;inline;
-procedure Register;
-
-implementation
-
-procedure Register;
-begin
- RegisterComponents('WebDelphi.ru',[TFeedBurner]);
-end;
-
-{ TFeedBurner }
-
-constructor TFeedBurner.Create(AOwner: TComponent);
-begin
- inherited Create(AOwner);
- FFeedData:=TEntryCollection.Create(self);
- FDates:=TDateList.Create;
- FTimeLine:=TTimeLine.Create(self);
-end;
-
-procedure TFeedBurner.CreateThread(idx: integer; aDate:TDate);
-begin
- if idx>(FDates.Count-1) then Exit;
- if (Length(FThread)-1)(FDates.Count-1) then Exit;
+ if (Length(FThread)-1)=FDates.Count) then
- if Assigned(FOnDone) then
- FOnDone(Self);
-end;
-
-procedure TFeedBurner.GetDates;
-var i: integer;
-begin
- FDates.Clear;
- for I := 0 to FTimeLine.Count - 1 do
- begin
- case FTimeLine[i].RangeType of
- trSingle:FDates.Add(FTimeLine[i].StartDate);
- trDescrete:begin
- FDates.Add(FTimeLine[i].StartDate);
- FDates.Add(FTimeLine[i].EndDate);
- end;
- trContinued:FDates.AddRange(FTimeLine[i].StartDate,FTimeLine[i].EndDate);
- end;
- end;
- FDates.DeleteDuplicates;
-end;
-
-procedure TFeedBurner.SetFeedURL(const Value: string);
-var s:string;
-begin
- FFeedURL:=Value;
- s:=ReverseString(FFeedURL);
- Furi:=ReverseString(Copy(s,1,pos('/',s)-1));
-end;
-
-procedure TFeedBurner.SetMaxThreads(Value: byte);
-begin
- if (Value>MaxThreads) or (Value=0) then
- FMaxThreads:=MaxThrds
- else
- if Value<0 then
- FMaxThreads:=1
- else
- FMaxThreads:=Value;
-end;
-
-procedure TFeedBurner.SetRange(const Value: TDateList);
-begin
- FDates.Assign(Value);
-end;
-
-
-procedure TFeedBurner.SetTimeLIme(const Value: TTimeLine);
-begin
- FTimeLine.Assign(Value);;
-end;
-
-procedure TFeedBurner.SetTimeLine(Value: TTimeLine);
-begin
-
-end;
-
-procedure TFeedBurner.Start;
-var i:integer;
-begin
-try
- GetDates;
- FFeedData.Clear;
- FThread:=nil;
- FNextDateIdx:=0;
- FAllThreads:=0;
- i:=0;
- repeat
- CreateThread(i,FDates[i]);
- inc(i);
- until (i=FDates.Count) or(i=FMaxThreads);
-finally
-end;
-end;
-
-procedure TFeedBurner.Stop;
-var i:integer;
-begin
-try
- for I:=0 to Length(FThread) - 1 do
- begin
- if TerminateThread(FThread[i].Handle,0) then
- if Assigned(FOnThreadEnd)then
- FOnThreadEnd(i,FAllThreads);
- end;
- FAllThreads:=0;
- if Assigned(FOnDone) then
- FOnDone(self);
-finally
- FThread:=nil
-end;
-end;
-
-{ TBasicEntry }
-
-constructor TBasicEntry.Create(Collection: TCollection);
-begin
- inherited Create(Collection);
- FResyndicationData:=TResyndicationData.Create();
-end;
-
-procedure TBasicEntry.ParseXML(Node: TXMLNode);
-var FormatSet: TFormatSettings;
- i:integer;
- List:TXMLNodeList;
-begin
- if Node=nil then Exit;
-
- if LowerCase(Node.Name)<>'entry' then
- raise EFeedBurner.Create(rsErrEntry);
-
- GetLocaleFormatSettings(LOCALE_SYSTEM_DEFAULT, FormatSet);
- FormatSet.DateSeparator := '-';
- FormatSet.ShortDateFormat := DateFormat;
- FDate := StrToDate(Node.ReadAttributeString('date'), FormatSet);
-
- Fcirculation:=Node.ReadAttributeInteger('circulation');
- Fhits:=Node.ReadAttributeInteger('hits');
- Freach:=Node.ReadAttributeInteger('reach');
- Fdownloads:=Node.ReadAttributeInteger('downloads');
-
- List:=TXmlNodeList.Create;
- Node.NodesByName('item',List);
- for I := 0 to List.Count - 1 do
- begin
- FResyndicationData.Add.Node:=List[i]
- end;
- Changed(false);
-end;
-
-procedure TBasicEntry.SetNode(const Value: TXMLNode);
-begin
- if FNode<>Value then
- begin
- FNode := Value;
- ParseXML(Node);
- end;
-end;
-
-{ TFeedData }
-
-function TEntryCollection.Add: TBasicEntry;
-begin
- Result := TBasicEntry(inherited Add)
-end;
-
-constructor TEntryCollection.Create(FeedBurner: TFeedBurner);
-begin
- inherited Create(TBasicEntry);
- FeedBurner := FeedBurner;
-end;
-
-procedure TEntryCollection.DoItemChange(Item: TCollectionItem);
-begin
- if Assigned(FOnItemChange) then
- FOnItemChange(Item)
-end;
-
-function TEntryCollection.GetItem(Index: Integer): TBasicEntry;
-begin
- Result := TBasicEntry(inherited GetItem(Index))
-end;
-
-function TEntryCollection.GetOwner: TPersistent;
-begin
- Result := FFeedBurner
-end;
-
-function TEntryCollection.IndexOf(Date: TDate): integer;
-var i:integer;
-begin
-Result:=-1;
- for I := 0 to Self.Count - 1 do
- begin
- if Trunc(GetItem(i).Fdate)=Trunc(Date) then
- begin
- Result:=i;
- break;
- end;
- end;
-end;
-
-procedure TEntryCollection.SetItem(Index: Integer; const Value: TBasicEntry);
-begin
- inherited SetItem(Index, Value)
-end;
-
-procedure TEntryCollection.Update(Item: TCollectionItem);
-begin
- inherited Update(Item);
- DoItemChange(Item)
-end;
-
-{ EFeedBurner }
-
-constructor EFeedBurner.CreateByXML(XMLDoc: TNativeXML);
-begin
- ParseError(XMLDoc);
- CreateFmt(rsFeedAPIError,[FAPILatErrCode,FAPILastErrText]);
-end;
-
-class procedure EFeedBurner.ParseError(XMLNode: TXMLNode);
-begin
- FAPILatErrCode:=XMLNode.ReadAttributeInteger('code');
- case FAPILatErrCode of
- 1:FAPILastErrText:=rsAPIErr_1;
- 2:FAPILastErrText:=rsAPIErr_2;
- 3:FAPILastErrText:=rsAPIErr_3;
- 4:FAPILastErrText:=rsAPIErr_4;
- 5:FAPILastErrText:=rsAPIErr_5;
- 6:FAPILastErrText:=rsAPIErr_6;
- else
- FAPILastErrText:=XMLNode.ReadAttributeString('msg')
- end;
-end;
-
-class procedure EFeedBurner.ParseError(XMLDoc: TNativeXML);
-var Node:TXMLNode;
-begin
- if XMLDoc=nil then
- raise Exception.Create(rsUnknownError);
- Node:=XMLDoc.Root.NodeByName('err');
- if Node=nil then
- raise Exception.Create(rsUnknownError);
- ParseError(Node);
-end;
-
-{ TItemData }
-
-constructor TItemData.Create(Collection: TCollection);
-begin
- inherited Create(Collection);
-end;
-
-procedure TItemData.ParseXML(Node: TXMLNode);
-begin
- if Node=nil then Exit;
- if LowerCase(Node.Name)<>'item' then
- raise EFeedBurner.Create(rsErrEntry);
- FTitle:=Node.ReadAttributeString('title');
- FURL:=Node.ReadAttributeString('url');
- FItemViews:=Node.ReadAttributeInteger('itemviews');
- FClickThroughs:=Node.ReadAttributeInteger('clickthroughs');
-end;
-
-procedure TItemData.SetNode(aNode: TXmlNode);
-begin
- if aNode=nil then Exit;
- if aNode<>FNode then
- begin
- FNode:=aNode;
- ParseXML(FNode);
- end;
-end;
-
-{ TReferrer }
-
-constructor TReferrer.Create(Collection: TCollection);
-begin
- inherited Create(Collection);
-end;
-
-procedure TReferrer.ParseXML(Node: TXMLNode);
-begin
-if Node=nil then Exit;
- if LowerCase(Node.Name)<>'referrer' then
- raise EFeedBurner.Create(rsErrEntry);
- FURL:=Node.ReadAttributeString('url');
- FItemViews:=Node.ReadAttributeInteger('itemviews');
- FClickThroughs:=Node.ReadAttributeInteger('clickthroughs');
-end;
-
-procedure TReferrer.SetNode(aNode: TXMLNode);
-begin
-if aNode=nil then Exit;
- if aNode<>FNode then
- begin
- FNode:=aNode;
- ParseXML(FNode);
- end;
-end;
-
-{ TReferrerCollection }
-
-function TReferrerCollection.Add: TReferrer;
-begin
-Result := TReferrer(inherited Add)
-end;
-
-constructor TReferrerCollection.Create();
-begin
- inherited Create(TReferrer);
-end;
-
-function TReferrerCollection.GetItem(Index: Integer): TReferrer;
-begin
- Result := TReferrer(inherited GetItem(Index))
-end;
-
-procedure TReferrerCollection.SetItem(Index: Integer; const Value: TReferrer);
-begin
-inherited SetItem(Index, Value)
-end;
-
-procedure TReferrerCollection.Update(Item: TCollectionItem);
-begin
- inherited Update(Item);
-end;
-
-{ TResyndicationItem }
-
-constructor TResyndicationItem.Create(Collection: TCollection);
-begin
- inherited Create(Collection);
- FReferrers:=TReferrerCollection.Create();
-end;
-
-procedure TResyndicationItem.ParseXML(Node: TXMLNode);
-var i: integer;
- List:TXMLNodeList;
-begin
- if Node=nil then Exit;
- inherited ParseXML(Node);
- List:=TXmlNodeList.Create;
- Node.NodesByName('referrer',List);
- for i:=0 to List.Count-1 do
- FReferrers.Add.Node:=List[i]
-
-end;
-
-procedure TResyndicationItem.SetNode(aNode: TXmlNode);
-begin
- if aNode=nil then Exit;
- if aNode<>FNode then
- begin
- FNode:=aNode;
- ParseXML(FNode);
- end;
-end;
-
-{ TResyndicationData }
-
-function TResyndicationData.Add: TResyndicationItem;
-begin
- Result := TResyndicationItem(inherited Add)
-end;
-
-constructor TResyndicationData.Create();
-begin
- inherited Create(TResyndicationItem);
-end;
-
-function TResyndicationData.GetItem(Index: Integer): TResyndicationItem;
-begin
- Result := TResyndicationItem(inherited GetItem(Index))
-end;
-
-
-procedure TResyndicationData.SetItem(Index: Integer;
- const Value: TResyndicationItem);
-begin
- inherited SetItem(Index, Value)
-end;
-
-procedure TResyndicationData.Update(Item: TCollectionItem);
-begin
- inherited Update(Item);
-end;
-
-{ TRSSThread }
-
-constructor TRSSThread.Create(CreateSuspennded: boolean;aParentComp: TFeedBurner;aIdx:integer;
- aDate:TDate;aOperation:TOperation;aURI:string);
-begin
- inherited Create(CreateSuspennded);
+ FThread[idx].Start;
+ inc(FNextDateIdx);
+ inc(FAllThreads);
+ if Assigned(FOnThreadStart) then
+ FOnThreadStart(Idx,FAllThreads);
+end;
+
+destructor TFeedBurner.Destroy;
+begin
+ FFeedData.Destroy;
+ inherited Destroy;
+end;
+
+procedure TFeedBurner.DoSilentError(XMLDoc: TNativeXml);
+begin
+EFeedBurner.ParseError(XMLDoc);
+if Assigned(FOnAPIRequestError) then
+ FOnAPIRequestError(EFeedBurner.FAPILatErrCode,EFeedBurner.FAPILastErrText);
+end;
+
+procedure TFeedBurner.EndThread(ThreadIdx: integer; All:byte);
+begin
+ Dec(FAllThreads);
+
+ if Assigned(FOnThreadEnd) then
+ FOnThreadEnd(ThreadIdx,FAllThreads);
+
+ FThread[ThreadIdx]:=nil;
+ if FNextDateIdx=FDates.Count) then
+ if Assigned(FOnDone) then
+ FOnDone(Self);
+end;
+
+procedure TFeedBurner.GetDates;
+var i: integer;
+begin
+ FDates.Clear;
+ for I := 0 to FTimeLine.Count - 1 do
+ begin
+ case FTimeLine[i].RangeType of
+ trSingle:FDates.Add(FTimeLine[i].StartDate);
+ trDescrete:begin
+ FDates.Add(FTimeLine[i].StartDate);
+ FDates.Add(FTimeLine[i].EndDate);
+ end;
+ trContinued:FDates.AddRange(FTimeLine[i].StartDate,FTimeLine[i].EndDate);
+ end;
+ end;
+ FDates.DeleteDuplicates;
+end;
+
+procedure TFeedBurner.SetFeedURL(const Value: string);
+var s:string;
+begin
+ FFeedURL:=Value;
+ s:=ReverseString(FFeedURL);
+ Furi:=ReverseString(Copy(s,1,pos('/',s)-1));
+end;
+
+procedure TFeedBurner.SetMaxThreads(Value: byte);
+begin
+ if (Value>MaxThreads) or (Value=0) then
+ FMaxThreads:=MaxThrds
+ else
+ if Value<0 then
+ FMaxThreads:=1
+ else
+ FMaxThreads:=Value;
+end;
+
+procedure TFeedBurner.SetRange(const Value: TDateList);
+begin
+ FDates.Assign(Value);
+end;
+
+
+procedure TFeedBurner.SetTimeLIme(const Value: TTimeLine);
+begin
+ FTimeLine.Assign(Value);;
+end;
+
+procedure TFeedBurner.SetTimeLine(Value: TTimeLine);
+begin
+
+end;
+
+procedure TFeedBurner.Start;
+var i:integer;
+begin
+try
+ GetDates;
+ FFeedData.Clear;
+ FThread:=nil;
+ FNextDateIdx:=0;
+ FAllThreads:=0;
+ i:=0;
+ repeat
+ CreateThread(i,FDates[i]);
+ inc(i);
+ until (i=FDates.Count) or(i=FMaxThreads);
+finally
+end;
+end;
+
+procedure TFeedBurner.Stop;
+var i:integer;
+begin
+try
+ for I:=0 to Length(FThread) - 1 do
+ begin
+ if TerminateThread(FThread[i].Handle,0) then
+ if Assigned(FOnThreadEnd)then
+ FOnThreadEnd(i,FAllThreads);
+ end;
+ FAllThreads:=0;
+ if Assigned(FOnDone) then
+ FOnDone(self);
+finally
+ FThread:=nil
+end;
+end;
+
+{ TBasicEntry }
+
+constructor TBasicEntry.Create(Collection: TCollection);
+begin
+ inherited Create(Collection);
+ FResyndicationData:=TResyndicationData.Create();
+end;
+
+procedure TBasicEntry.ParseXML(Node: TXMLNode);
+var FormatSet: TFormatSettings;
+ i:integer;
+ List:TXMLNodeList;
+begin
+ if Node=nil then Exit;
+
+ if LowerCase(Node.Name)<>'entry' then
+ raise EFeedBurner.Create(rsErrEntry);
+
+ GetLocaleFormatSettings(LOCALE_SYSTEM_DEFAULT, FormatSet);
+ FormatSet.DateSeparator := '-';
+ FormatSet.ShortDateFormat := DateFormat;
+ FDate := StrToDate(Node.ReadAttributeString('date'), FormatSet);
+
+ Fcirculation:=Node.ReadAttributeInteger('circulation');
+ Fhits:=Node.ReadAttributeInteger('hits');
+ Freach:=Node.ReadAttributeInteger('reach');
+ Fdownloads:=Node.ReadAttributeInteger('downloads');
+
+ List:=TXmlNodeList.Create;
+ Node.NodesByName('item',List);
+ for I := 0 to List.Count - 1 do
+ begin
+ FResyndicationData.Add.Node:=List[i]
+ end;
+ Changed(false);
+end;
+
+procedure TBasicEntry.SetNode(const Value: TXMLNode);
+begin
+ if FNode<>Value then
+ begin
+ FNode := Value;
+ ParseXML(Node);
+ end;
+end;
+
+{ TFeedData }
+
+function TEntryCollection.Add: TBasicEntry;
+begin
+ Result := TBasicEntry(inherited Add)
+end;
+
+constructor TEntryCollection.Create(FeedBurner: TFeedBurner);
+begin
+ inherited Create(TBasicEntry);
+ FeedBurner := FeedBurner;
+end;
+
+procedure TEntryCollection.DoItemChange(Item: TCollectionItem);
+begin
+ if Assigned(FOnItemChange) then
+ FOnItemChange(Item)
+end;
+
+function TEntryCollection.GetItem(Index: Integer): TBasicEntry;
+begin
+ Result := TBasicEntry(inherited GetItem(Index))
+end;
+
+function TEntryCollection.GetOwner: TPersistent;
+begin
+ Result := FFeedBurner
+end;
+
+function TEntryCollection.IndexOf(Date: TDate): integer;
+var i:integer;
+begin
+Result:=-1;
+ for I := 0 to Self.Count - 1 do
+ begin
+ if Trunc(GetItem(i).Fdate)=Trunc(Date) then
+ begin
+ Result:=i;
+ break;
+ end;
+ end;
+end;
+
+procedure TEntryCollection.SetItem(Index: Integer; const Value: TBasicEntry);
+begin
+ inherited SetItem(Index, Value)
+end;
+
+procedure TEntryCollection.Update(Item: TCollectionItem);
+begin
+ inherited Update(Item);
+ DoItemChange(Item)
+end;
+
+{ EFeedBurner }
+
+constructor EFeedBurner.CreateByXML(XMLDoc: TNativeXML);
+begin
+ ParseError(XMLDoc);
+ CreateFmt(rsFeedAPIError,[FAPILatErrCode,FAPILastErrText]);
+end;
+
+class procedure EFeedBurner.ParseError(XMLNode: TXMLNode);
+begin
+ FAPILatErrCode:=XMLNode.ReadAttributeInteger('code');
+ case FAPILatErrCode of
+ 1:FAPILastErrText:=rsAPIErr_1;
+ 2:FAPILastErrText:=rsAPIErr_2;
+ 3:FAPILastErrText:=rsAPIErr_3;
+ 4:FAPILastErrText:=rsAPIErr_4;
+ 5:FAPILastErrText:=rsAPIErr_5;
+ 6:FAPILastErrText:=rsAPIErr_6;
+ else
+ FAPILastErrText:=XMLNode.ReadAttributeString('msg')
+ end;
+end;
+
+class procedure EFeedBurner.ParseError(XMLDoc: TNativeXML);
+var Node:TXMLNode;
+begin
+ if XMLDoc=nil then
+ raise Exception.Create(rsUnknownError);
+ Node:=XMLDoc.Root.NodeByName('err');
+ if Node=nil then
+ raise Exception.Create(rsUnknownError);
+ ParseError(Node);
+end;
+
+{ TItemData }
+
+constructor TItemData.Create(Collection: TCollection);
+begin
+ inherited Create(Collection);
+end;
+
+procedure TItemData.ParseXML(Node: TXMLNode);
+begin
+ if Node=nil then Exit;
+ if LowerCase(Node.Name)<>'item' then
+ raise EFeedBurner.Create(rsErrEntry);
+ FTitle:=Node.ReadAttributeString('title');
+ FURL:=Node.ReadAttributeString('url');
+ FItemViews:=Node.ReadAttributeInteger('itemviews');
+ FClickThroughs:=Node.ReadAttributeInteger('clickthroughs');
+end;
+
+procedure TItemData.SetNode(aNode: TXmlNode);
+begin
+ if aNode=nil then Exit;
+ if aNode<>FNode then
+ begin
+ FNode:=aNode;
+ ParseXML(FNode);
+ end;
+end;
+
+{ TReferrer }
+
+constructor TReferrer.Create(Collection: TCollection);
+begin
+ inherited Create(Collection);
+end;
+
+procedure TReferrer.ParseXML(Node: TXMLNode);
+begin
+if Node=nil then Exit;
+ if LowerCase(Node.Name)<>'referrer' then
+ raise EFeedBurner.Create(rsErrEntry);
+ FURL:=Node.ReadAttributeString('url');
+ FItemViews:=Node.ReadAttributeInteger('itemviews');
+ FClickThroughs:=Node.ReadAttributeInteger('clickthroughs');
+end;
+
+procedure TReferrer.SetNode(aNode: TXMLNode);
+begin
+if aNode=nil then Exit;
+ if aNode<>FNode then
+ begin
+ FNode:=aNode;
+ ParseXML(FNode);
+ end;
+end;
+
+{ TReferrerCollection }
+
+function TReferrerCollection.Add: TReferrer;
+begin
+Result := TReferrer(inherited Add)
+end;
+
+constructor TReferrerCollection.Create();
+begin
+ inherited Create(TReferrer);
+end;
+
+function TReferrerCollection.GetItem(Index: Integer): TReferrer;
+begin
+ Result := TReferrer(inherited GetItem(Index))
+end;
+
+procedure TReferrerCollection.SetItem(Index: Integer; const Value: TReferrer);
+begin
+inherited SetItem(Index, Value)
+end;
+
+procedure TReferrerCollection.Update(Item: TCollectionItem);
+begin
+ inherited Update(Item);
+end;
+
+{ TResyndicationItem }
+
+constructor TResyndicationItem.Create(Collection: TCollection);
+begin
+ inherited Create(Collection);
+ FReferrers:=TReferrerCollection.Create();
+end;
+
+procedure TResyndicationItem.ParseXML(Node: TXMLNode);
+var i: integer;
+ List:TXMLNodeList;
+begin
+ if Node=nil then Exit;
+ inherited ParseXML(Node);
+ List:=TXmlNodeList.Create;
+ Node.NodesByName('referrer',List);
+ for i:=0 to List.Count-1 do
+ FReferrers.Add.Node:=List[i]
+
+end;
+
+procedure TResyndicationItem.SetNode(aNode: TXmlNode);
+begin
+ if aNode=nil then Exit;
+ if aNode<>FNode then
+ begin
+ FNode:=aNode;
+ ParseXML(FNode);
+ end;
+end;
+
+{ TResyndicationData }
+
+function TResyndicationData.Add: TResyndicationItem;
+begin
+ Result := TResyndicationItem(inherited Add)
+end;
+
+constructor TResyndicationData.Create();
+begin
+ inherited Create(TResyndicationItem);
+end;
+
+function TResyndicationData.GetItem(Index: Integer): TResyndicationItem;
+begin
+ Result := TResyndicationItem(inherited GetItem(Index))
+end;
+
+
+procedure TResyndicationData.SetItem(Index: Integer;
+ const Value: TResyndicationItem);
+begin
+ inherited SetItem(Index, Value)
+end;
+
+procedure TResyndicationData.Update(Item: TCollectionItem);
+begin
+ inherited Update(Item);
+end;
+
+{ TRSSThread }
+
+constructor TRSSThread.Create(CreateSuspennded: boolean;aParentComp: TFeedBurner;aIdx:integer;
+ aDate:TDate;aOperation:TOperation;aURI:string);
+begin
+ inherited Create(CreateSuspennded);
FParentComp:=aParentComp;
FDate := aDate;
FOperation:=aOperation;
@@ -796,30 +796,30 @@ constructor TRSSThread.Create(CreateSuspennded: boolean;aParentComp: TFeedBurner
FBasicEntry:=TBasicEntry.Create(FParentComp.FeedData);
GetParams;
end;
-
+
function GetUrlSize(const URL:string):integer;//результат в байтах
-var
- hSession,hFile:hInternet;
- dwBuffer:array[1..20] of char;
- dwBufferLen,dwIndex:cardinal;
-begin
-Result:=0;
-hSession:=InternetOpen('GetUrlSize',INTERNET_OPEN_TYPE_PRECONFIG,nil,nil,0);
-if Assigned(hSession) then
-begin
- hFile:=InternetOpenURL(hSession,PChar(URL),nil,0,INTERNET_FLAG_RELOAD,0);
- dwIndex:=0;
- dwBufferLen:=20;
- if HttpQueryInfo(hFile,HTTP_QUERY_CONTENT_LENGTH,@dwBuffer,dwBufferLen, dwIndex) then
- Result:=StrToInt(PChar(@dwBuffer));
-
- if Assigned(hFile) then InternetCloseHandle(hFile);
- InternetCloseHandle(hsession);
-end;
-end;
-
-procedure TRSSThread.Execute;
-var
+var
+ hSession,hFile:hInternet;
+ dwBuffer:array[1..20] of char;
+ dwBufferLen,dwIndex:cardinal;
+begin
+Result:=0;
+hSession:=InternetOpen('GetUrlSize',INTERNET_OPEN_TYPE_PRECONFIG,nil,nil,0);
+if Assigned(hSession) then
+begin
+ hFile:=InternetOpenURL(hSession,PChar(URL),nil,0,INTERNET_FLAG_RELOAD,0);
+ dwIndex:=0;
+ dwBufferLen:=20;
+ if HttpQueryInfo(hFile,HTTP_QUERY_CONTENT_LENGTH,@dwBuffer,dwBufferLen, dwIndex) then
+ Result:=StrToInt(PChar(@dwBuffer));
+
+ if Assigned(hFile) then InternetCloseHandle(hFile);
+ InternetCloseHandle(hsession);
+end;
+end;
+
+procedure TRSSThread.Execute;
+var
hInternet, hConnect, hRequest: pointer;
dwBytesRead,i: cardinal;
Buffer: array [0 .. 255] of Byte;
@@ -859,12 +859,12 @@ procedure TRSSThread.Execute;
Exit;
end;
FillChar(Buffer, SizeOf(Buffer), 0);
- if not InternetReadFile(hRequest, @Buffer, Length(Buffer), dwBytesRead) then
- Exit
- else
- Document.Write(Buffer, dwBytesRead);
- FProgress := Document.Size;
- Synchronize(SynProgress);
+ if not InternetReadFile(hRequest, @Buffer, Length(Buffer), dwBytesRead) then
+ Exit
+ else
+ Document.Write(Buffer, dwBytesRead);
+ FProgress := Document.Size;
+ Synchronize(SynProgress);
until dwBytesRead = 0;
Document.Position:=0;
end;
@@ -879,16 +879,16 @@ procedure TRSSThread.Execute;
end;
FXMLDoc.LoadFromStream(Document);
-
+
if XMLWithError(FXMLDoc) then
- begin
- if FParentComp.FSilent then
- FParentComp.DoSilentError(FXMLDoc)
- else
- raise
- EFeedBurner.CreateByXML(FXMLDoc);
- FBasicEntry.Destroy;
- end
+ begin
+ if FParentComp.FSilent then
+ FParentComp.DoSilentError(FXMLDoc)
+ else
+ raise
+ EFeedBurner.CreateByXML(FXMLDoc);
+ FBasicEntry.Destroy;
+ end
else
begin
FBasicEntry.Node:=FXMLDoc.Root.NodeByName('feed').NodeByName('entry');
@@ -900,189 +900,189 @@ procedure TRSSThread.Execute;
Synchronize(SynEndThread);
end;
-procedure TRSSThread.GetParams;
-var Oper, Date: string;
-begin
- //составление параметров запроса
- Oper:='';
- Date:='';
- Oper:=GetEnumName(TypeInfo(TOperation),ord(FOperation));
- Delete(Oper,1,2);
- if FDate>0 then
- Date:='&dates='+FormatDateTime(DateFormat,FDate);
- FParamStr:=Format(AwaAPIParamURL,[APIVersion,Oper+'?uri='+FURI+Date])
-end;
-
-procedure TRSSThread.SynEndThread;
-begin
- if Assigned(FOnThreadEnd) then
- FOnThreadEnd(FIdx,FParentComp.FAllThreads);
-end;
-
-procedure TRSSThread.SynProgress;
-begin
-if Assigned(FOnProgress) then
- OnProgress(FDate,FIdx,FProgress,FMaxProgress); // передаем прогресс авторизации
-end;
-
-function TRSSThread.XMLWithError(XMLDoc: TNativeXml): boolean;
-begin
-result:=true;
- if XMLDoc=nil then exit;
- if Document.Size=0 then Exit;
-
- if XMLDoc.Root.HasAttribute('stat') then
- Result:=XMLDoc.Root.ReadAttributeString('stat')='fail'
- else
- begin
- raise EFeedBurner.Create(rsRequestError);
- end;
-end;
-
-{ TDateList }
-
-procedure TDateList.Add(Date: TDate);
-var pD: PDouble;
-begin
- new(pD);
- pD^:=Date;
- Self.Insert(Self.Count,pD);
-end;
-
-procedure TDateList.AddRange(StartDate, EndDate: TDate);
-var i:integer;
-begin
- for i:=0 to DaysBetween(StartDate,EndDate) do
- Add(IncDay(StartDate,i));
-end;
-
-function Comparator(Item1, Item2: pointer): integer;inline;
-begin
- if PDouble(Item1)^PDouble(Item2)^ then
- Result:=1
- else
- Result:=0;
-end;
-
-procedure TDateList.DeleteDuplicates;
-var i:integer;
- b:boolean;
-begin
- b:=true;
- Self.Sort(Comparator);
- while b do
- begin
- i:=1;
- while i=Count then Exit;
- pD:=Get(index);
- Result:=pD^;
-end;
-
-procedure TDateList.SetItem(index:integer;Value: TDate);
-begin
- if Index<0 then Exit;
- Add(Value);
-end;
-
-procedure TDateList.SortDates;
-begin
- Self.Sort(Comparator);
-end;
-
-{ TDateItem }
-
-constructor TDateItem.Create(Collection: TCollection);
-begin
- inherited Create(Collection);
- FStartDate:=Now;
- FEndDate:=Now;
- FRangeType:=trSingle;
-end;
-
-procedure TDateItem.SetEndDate(Value: TDate);
-begin
- if ValueFEndDate then
- FStartDate:=FEndDate
- else
- FStartDate:=Value;
- Update;
-end;
-
-procedure TDateItem.Update;
-begin
- if FEndDate=FStartDate then
- FRangeType:=trSingle
- else
- if FRangeType=trSingle then
- FRangeType:=trContinued
-end;
-
-{ TTimeLine }
-
-function TTimeLine.Add: TDateItem;
-begin
- result:=TDateItem(inherited Add)
-end;
-
-constructor TTimeLine.Create(FeedBurner: TFeedBurner);
-begin
- inherited Create(TDateItem);
- FFeedBurner:=FeedBurner;
-end;
-
-function TTimeLine.GetItem(Index: Integer): TDateItem;
-begin
- Result := TDateItem(inherited GetItem(Index))
-end;
-
-function TTimeLine.GetOwner: TPersistent;
-begin
- Result:=FFeedBurner
-end;
-
-procedure TTimeLine.SetItem(Index: Integer; const Value: TDateItem);
-begin
- inherited SetItem(Index, Value)
-end;
-
-procedure TTimeLine.Update(Item: TCollectionItem);
-begin
- inherited Update(Item);
-end;
-
-end.
+procedure TRSSThread.GetParams;
+var Oper, Date: string;
+begin
+ //составление параметров запроса
+ Oper:='';
+ Date:='';
+ Oper:=GetEnumName(TypeInfo(TOperation),ord(FOperation));
+ Delete(Oper,1,2);
+ if FDate>0 then
+ Date:='&dates='+FormatDateTime(DateFormat,FDate);
+ FParamStr:=Format(AwaAPIParamURL,[APIVersion,Oper+'?uri='+FURI+Date])
+end;
+
+procedure TRSSThread.SynEndThread;
+begin
+ if Assigned(FOnThreadEnd) then
+ FOnThreadEnd(FIdx,FParentComp.FAllThreads);
+end;
+
+procedure TRSSThread.SynProgress;
+begin
+if Assigned(FOnProgress) then
+ OnProgress(FDate,FIdx,FProgress,FMaxProgress); // передаем прогресс авторизации
+end;
+
+function TRSSThread.XMLWithError(XMLDoc: TNativeXml): boolean;
+begin
+result:=true;
+ if XMLDoc=nil then exit;
+ if Document.Size=0 then Exit;
+
+ if XMLDoc.Root.HasAttribute('stat') then
+ Result:=XMLDoc.Root.ReadAttributeString('stat')='fail'
+ else
+ begin
+ raise EFeedBurner.Create(rsRequestError);
+ end;
+end;
+
+{ TDateList }
+
+procedure TDateList.Add(Date: TDate);
+var pD: PDouble;
+begin
+ new(pD);
+ pD^:=Date;
+ Self.Insert(Self.Count,pD);
+end;
+
+procedure TDateList.AddRange(StartDate, EndDate: TDate);
+var i:integer;
+begin
+ for i:=0 to DaysBetween(StartDate,EndDate) do
+ Add(IncDay(StartDate,i));
+end;
+
+function Comparator(Item1, Item2: pointer): integer;inline;
+begin
+ if PDouble(Item1)^PDouble(Item2)^ then
+ Result:=1
+ else
+ Result:=0;
+end;
+
+procedure TDateList.DeleteDuplicates;
+var i:integer;
+ b:boolean;
+begin
+ b:=true;
+ Self.Sort(Comparator);
+ while b do
+ begin
+ i:=1;
+ while i=Count then Exit;
+ pD:=Get(index);
+ Result:=pD^;
+end;
+
+procedure TDateList.SetItem(index:integer;Value: TDate);
+begin
+ if Index<0 then Exit;
+ Add(Value);
+end;
+
+procedure TDateList.SortDates;
+begin
+ Self.Sort(Comparator);
+end;
+
+{ TDateItem }
+
+constructor TDateItem.Create(Collection: TCollection);
+begin
+ inherited Create(Collection);
+ FStartDate:=Now;
+ FEndDate:=Now;
+ FRangeType:=trSingle;
+end;
+
+procedure TDateItem.SetEndDate(Value: TDate);
+begin
+ if ValueFEndDate then
+ FStartDate:=FEndDate
+ else
+ FStartDate:=Value;
+ Update;
+end;
+
+procedure TDateItem.Update;
+begin
+ if FEndDate=FStartDate then
+ FRangeType:=trSingle
+ else
+ if FRangeType=trSingle then
+ FRangeType:=trContinued
+end;
+
+{ TTimeLine }
+
+function TTimeLine.Add: TDateItem;
+begin
+ result:=TDateItem(inherited Add)
+end;
+
+constructor TTimeLine.Create(FeedBurner: TFeedBurner);
+begin
+ inherited Create(TDateItem);
+ FFeedBurner:=FeedBurner;
+end;
+
+function TTimeLine.GetItem(Index: Integer): TDateItem;
+begin
+ Result := TDateItem(inherited GetItem(Index))
+end;
+
+function TTimeLine.GetOwner: TPersistent;
+begin
+ Result:=FFeedBurner
+end;
+
+procedure TTimeLine.SetItem(Index: Integer; const Value: TDateItem);
+begin
+ inherited SetItem(Index, Value)
+end;
+
+procedure TTimeLine.Update(Item: TCollectionItem);
+begin
+ inherited Update(Item);
+end;
+
+end.
diff --git a/source/GHelper.pas b/source/GHelper.pas
index 3b42b1e..3e64422 100644
--- a/source/GHelper.pas
+++ b/source/GHelper.pas
@@ -2,246 +2,246 @@
unit GHelper;
=======
-unit GHelper;
-
+unit GHelper;
+
>>>>>>> remotes/origin/master
-interface
-
-uses Graphics,strutils,Windows,DateUtils,SysUtils, Variants,
-Classes,StdCtrls,httpsend,Generics.Collections,xmlintf,xmldom,NativeXML,
-GConsts;
-
-type
- TTimeZone = packed record
- gConst: string;
- Desc : string;
- GMT: extended;
- rus: boolean;
-end;
-
-type
- PTimeZone = ^TTimeZone;
-
-type
- TTimeZoneList = class(TList)
- private
- procedure SetRecord(index: Integer; Ptr: PTimeZone);
- function GetRecord(index: Integer): PTimeZone;
- public
- constructor Create;
- procedure Clear;override;
- destructor Destroy; override;
- property TimeZone[i: Integer]: PTimeZone read GetRecord write SetRecord;
- end;
-
-
-function HexToColor(Color: string): TColor;
-function ColorToHex(Color: TColor): string;
-// 2007-07-11T21:50:15.000Z TDateTime
-function ServerDateToDateTime(cServerDate:string):TDateTime;
-// TDateTime 2007-07-11T21:50:15.000Z
-function DateTimeToServerDate(DateTime:TDateTime):string;
-//
-function ArrayToStr(Values:array of string; Delimiter:char):string;
-// HTTP
-function GetNewLocationURL(Headers: TStringList):string;
-function SendRequest(const aMethod, aURL, aAuth, ApiVersion: string; aDocument:TStream=nil; aExtendedHeaders:TStringList=nil):TStream;
-
-
-implementation
-
-function ArrayToStr(Values:array of string; Delimiter:char):string;
-var i:integer;
-begin
- if length(Values)=0 then Exit;
- Result:=Values[0];
- for i:= 1 to Length(Values)-1 do
- Result:=Result+Delimiter+Values[i]
-end;
-
-function SendRequest(const aMethod, aURL, aAuth, ApiVersion: string; aDocument:TStream; aExtendedHeaders:TStringList):TStream;
-var tmpURL:string;
- i:integer;
-begin
- with THTTPSend.Create do
- begin
- Headers.Add('GData-Version: '+ApiVersion);
- Headers.Add('Authorization: GoogleLogin auth='+aAuth);
- MimeType := 'application/atom+xml';
- if aExtendedHeaders<>nil then
- begin
- for I:=0 to aExtendedHeaders.Count - 1 do
- Headers.Add(aExtendedHeaders[i])
- end;
- if aDocument<>nil then
- Document.LoadFromStream(aDocument);
-
- HTTPMethod(aMethod,aURL);
- if (ResultCode>200)and(ResultCode<400) then
- begin
- tmpURL:=GetNewLocationURL(Headers);
- Document.Clear;
- Headers.Clear;
- Headers.Add('GData-Version: 2');
- Headers.Add('Authorization: GoogleLogin auth='+aAuth);
- MimeType := 'application/atom+xml';
- if aExtendedHeaders<>nil then
- begin
- for I:=0 to aExtendedHeaders.Count - 1 do
- Headers.Add(aExtendedHeaders[i])
- end;
- if aDocument<>nil then
- Document.LoadFromStream(aDocument);
- HTTPMethod(aMethod,tmpURL);
- end;
- Result:=TStringStream.Create('');
- Headers.SaveToFile('headers.txt');
- Document.SaveToStream(Result);
- Result.Seek(0,soFromBeginning);
- end;
-end;
-
-function GetNewLocationURL(Headers: TStringList):string;
-var i:integer;
-begin
- if not Assigned(Headers) then Exit;
- for i:=0 to Headers.Count - 1 do
- begin
- if pos('location:',lowercase(Headers[i]))>0 then
- begin
- Result:=Trim(copy(Headers[i],10,length(Headers[i])-9));
- Exit;
- end;
- end;
-end;
-
-function DateTimeToServerDate(DateTime:TDateTime):string;
-var Year, Mounth, Day, hours, Mins, Seconds,MSec: Word;
- aYear, aMounth, aDay, ahours, aMins, aSeconds,aMSec: string;
-begin
- DecodeDateTime(DateTime,Year, Mounth, Day, hours, Mins, Seconds,MSec);
- aYear:=IntToStr(Year);
- if Mounth<10 then aMounth:='0'+IntToStr(Mounth)
- else aMounth:=IntToStr(Mounth);
- if Day<10 then aDay:='0'+IntToStr(Day)
- else aDay:=IntToStr(Day);
- if hours<10 then ahours:='0'+IntToStr(hours)
- else ahours:=IntToStr(hours);
- if Mins<10 then aMins:='0'+IntToStr(Mins)
- else aMins:=IntToStr(Mins);
- if Seconds<10 then aSeconds:='0'+IntToStr(Seconds)
- else aSeconds:=IntToStr(Seconds);
-
- case MSec of
- 0..9:aMSec:='00'+IntToStr(MSec);
- 10..99:aMSec:='0'+IntToStr(MSec);
- else
- aMSec:=IntToStr(MSec);
- end;
- Result:=aYear+'-'+aMounth+'-'+aDay+'T'+ahours+':'+aMins+':'+aSeconds+'.'+aMSec+'Z';
-end;
-
-function ServerDateToDateTime(cServerDate:string):TDateTime;
-var Year, Mounth, Day, hours, Mins, Seconds: Word;
-begin
- Year:=StrToInt(copy(cServerDate,1,4));
- Mounth:=StrToInt(copy(cServerDate,6,2));
- Day:=StrToInt(copy(cServerDate,9,2));
- if Length(cServerDate)>10 then
- begin
- hours:=StrToInt(copy(cServerDate,12,2));
- Mins:=StrToInt(copy(cServerDate,15,2));
- Seconds:=StrToInt(copy(cServerDate,18,2));
- end
- else
- begin
- hours:=0;
- Mins:=0;
- Seconds:=0;
- end;
- Result:=EncodeDateTime(Year, Mounth, Day, hours, Mins, Seconds,0)
-end;
-
-function ColorToHex(Color: TColor): string;
-begin
- Result :=
- IntToHex(GetRValue(Color), 2 ) +
- IntToHex(GetGValue(Color), 2 ) +
- IntToHex(GetBValue(Color), 2 );
-end;
-
-function HexToColor(Color: string): TColor;
-begin
-if pos('#',Color)>0 then
- Delete(Color,1,1);
- Result :=
- RGB(
- StrToInt('$' + Copy(Color, 1, 2)),
- StrToInt('$' + Copy(Color, 3, 2)),
- StrToInt('$' + Copy(Color, 5, 2))
- );
-end;
-
-{ TTimeZoneList }
-
-procedure TTimeZoneList.Clear;
-var
- i: Integer;
- p: PTimeZone;
-begin
- for i := 0 to Pred(Count) do
- begin
- p := TimeZone[i];
- if p <> nil then
- Dispose(p);
- end;
- inherited Clear;
-end;
-
-constructor TTimeZoneList.Create;
-var i:integer;
- Zone:PTimeZone;
-begin
- inherited Create;
- for i:=0 to High(sGoogleTimeZones) do
- begin
- New(Zone);
- with Zone^ do
- begin
- gConst:=sGoogleTimeZones[i,0];
- Desc:=sGoogleTimeZones[i,1];
- GMT:=StrToFloat(sGoogleTimeZones[i,2]);
- rus:=sGoogleTimeZones[i,2]='rus';
- end;
- Add(Zone);
- end;
-end;
-
-destructor TTimeZoneList.Destroy;
-begin
- Clear;
- inherited Destroy;
-end;
-
-function TTimeZoneList.GetRecord(index: Integer): PTimeZone;
-begin
- Result:= PTimeZone(Items[index]);
-end;
-
-procedure TTimeZoneList.SetRecord(index: Integer; Ptr: PTimeZone);
-var
- p: PTimeZone;
-begin
- p := TimeZone[index];
- if p <> Ptr then
- begin
- if p <> nil then
- Dispose(p);
- Items[index] := Ptr;
- end;
-end;
-
-end.
+interface
+
+uses Graphics,strutils,Windows,DateUtils,SysUtils, Variants,
+Classes,StdCtrls,httpsend,Generics.Collections,xmlintf,xmldom,NativeXML,
+GConsts;
+
+type
+ TTimeZone = packed record
+ gConst: string;
+ Desc : string;
+ GMT: extended;
+ rus: boolean;
+end;
+
+type
+ PTimeZone = ^TTimeZone;
+
+type
+ TTimeZoneList = class(TList)
+ private
+ procedure SetRecord(index: Integer; Ptr: PTimeZone);
+ function GetRecord(index: Integer): PTimeZone;
+ public
+ constructor Create;
+ procedure Clear;override;
+ destructor Destroy; override;
+ property TimeZone[i: Integer]: PTimeZone read GetRecord write SetRecord;
+ end;
+
+
+function HexToColor(Color: string): TColor;
+function ColorToHex(Color: TColor): string;
+// 2007-07-11T21:50:15.000Z TDateTime
+function ServerDateToDateTime(cServerDate:string):TDateTime;
+// TDateTime 2007-07-11T21:50:15.000Z
+function DateTimeToServerDate(DateTime:TDateTime):string;
+//
+function ArrayToStr(Values:array of string; Delimiter:char):string;
+// HTTP
+function GetNewLocationURL(Headers: TStringList):string;
+function SendRequest(const aMethod, aURL, aAuth, ApiVersion: string; aDocument:TStream=nil; aExtendedHeaders:TStringList=nil):TStream;
+
+
+implementation
+
+function ArrayToStr(Values:array of string; Delimiter:char):string;
+var i:integer;
+begin
+ if length(Values)=0 then Exit;
+ Result:=Values[0];
+ for i:= 1 to Length(Values)-1 do
+ Result:=Result+Delimiter+Values[i]
+end;
+
+function SendRequest(const aMethod, aURL, aAuth, ApiVersion: string; aDocument:TStream; aExtendedHeaders:TStringList):TStream;
+var tmpURL:string;
+ i:integer;
+begin
+ with THTTPSend.Create do
+ begin
+ Headers.Add('GData-Version: '+ApiVersion);
+ Headers.Add('Authorization: GoogleLogin auth='+aAuth);
+ MimeType := 'application/atom+xml';
+ if aExtendedHeaders<>nil then
+ begin
+ for I:=0 to aExtendedHeaders.Count - 1 do
+ Headers.Add(aExtendedHeaders[i])
+ end;
+ if aDocument<>nil then
+ Document.LoadFromStream(aDocument);
+
+ HTTPMethod(aMethod,aURL);
+ if (ResultCode>200)and(ResultCode<400) then
+ begin
+ tmpURL:=GetNewLocationURL(Headers);
+ Document.Clear;
+ Headers.Clear;
+ Headers.Add('GData-Version: 2');
+ Headers.Add('Authorization: GoogleLogin auth='+aAuth);
+ MimeType := 'application/atom+xml';
+ if aExtendedHeaders<>nil then
+ begin
+ for I:=0 to aExtendedHeaders.Count - 1 do
+ Headers.Add(aExtendedHeaders[i])
+ end;
+ if aDocument<>nil then
+ Document.LoadFromStream(aDocument);
+ HTTPMethod(aMethod,tmpURL);
+ end;
+ Result:=TStringStream.Create('');
+ Headers.SaveToFile('headers.txt');
+ Document.SaveToStream(Result);
+ Result.Seek(0,soFromBeginning);
+ end;
+end;
+
+function GetNewLocationURL(Headers: TStringList):string;
+var i:integer;
+begin
+ if not Assigned(Headers) then Exit;
+ for i:=0 to Headers.Count - 1 do
+ begin
+ if pos('location:',lowercase(Headers[i]))>0 then
+ begin
+ Result:=Trim(copy(Headers[i],10,length(Headers[i])-9));
+ Exit;
+ end;
+ end;
+end;
+
+function DateTimeToServerDate(DateTime:TDateTime):string;
+var Year, Mounth, Day, hours, Mins, Seconds,MSec: Word;
+ aYear, aMounth, aDay, ahours, aMins, aSeconds,aMSec: string;
+begin
+ DecodeDateTime(DateTime,Year, Mounth, Day, hours, Mins, Seconds,MSec);
+ aYear:=IntToStr(Year);
+ if Mounth<10 then aMounth:='0'+IntToStr(Mounth)
+ else aMounth:=IntToStr(Mounth);
+ if Day<10 then aDay:='0'+IntToStr(Day)
+ else aDay:=IntToStr(Day);
+ if hours<10 then ahours:='0'+IntToStr(hours)
+ else ahours:=IntToStr(hours);
+ if Mins<10 then aMins:='0'+IntToStr(Mins)
+ else aMins:=IntToStr(Mins);
+ if Seconds<10 then aSeconds:='0'+IntToStr(Seconds)
+ else aSeconds:=IntToStr(Seconds);
+
+ case MSec of
+ 0..9:aMSec:='00'+IntToStr(MSec);
+ 10..99:aMSec:='0'+IntToStr(MSec);
+ else
+ aMSec:=IntToStr(MSec);
+ end;
+ Result:=aYear+'-'+aMounth+'-'+aDay+'T'+ahours+':'+aMins+':'+aSeconds+'.'+aMSec+'Z';
+end;
+
+function ServerDateToDateTime(cServerDate:string):TDateTime;
+var Year, Mounth, Day, hours, Mins, Seconds: Word;
+begin
+ Year:=StrToInt(copy(cServerDate,1,4));
+ Mounth:=StrToInt(copy(cServerDate,6,2));
+ Day:=StrToInt(copy(cServerDate,9,2));
+ if Length(cServerDate)>10 then
+ begin
+ hours:=StrToInt(copy(cServerDate,12,2));
+ Mins:=StrToInt(copy(cServerDate,15,2));
+ Seconds:=StrToInt(copy(cServerDate,18,2));
+ end
+ else
+ begin
+ hours:=0;
+ Mins:=0;
+ Seconds:=0;
+ end;
+ Result:=EncodeDateTime(Year, Mounth, Day, hours, Mins, Seconds,0)
+end;
+
+function ColorToHex(Color: TColor): string;
+begin
+ Result :=
+ IntToHex(GetRValue(Color), 2 ) +
+ IntToHex(GetGValue(Color), 2 ) +
+ IntToHex(GetBValue(Color), 2 );
+end;
+
+function HexToColor(Color: string): TColor;
+begin
+if pos('#',Color)>0 then
+ Delete(Color,1,1);
+ Result :=
+ RGB(
+ StrToInt('$' + Copy(Color, 1, 2)),
+ StrToInt('$' + Copy(Color, 3, 2)),
+ StrToInt('$' + Copy(Color, 5, 2))
+ );
+end;
+
+{ TTimeZoneList }
+
+procedure TTimeZoneList.Clear;
+var
+ i: Integer;
+ p: PTimeZone;
+begin
+ for i := 0 to Pred(Count) do
+ begin
+ p := TimeZone[i];
+ if p <> nil then
+ Dispose(p);
+ end;
+ inherited Clear;
+end;
+
+constructor TTimeZoneList.Create;
+var i:integer;
+ Zone:PTimeZone;
+begin
+ inherited Create;
+ for i:=0 to High(sGoogleTimeZones) do
+ begin
+ New(Zone);
+ with Zone^ do
+ begin
+ gConst:=sGoogleTimeZones[i,0];
+ Desc:=sGoogleTimeZones[i,1];
+ GMT:=StrToFloat(sGoogleTimeZones[i,2]);
+ rus:=sGoogleTimeZones[i,2]='rus';
+ end;
+ Add(Zone);
+ end;
+end;
+
+destructor TTimeZoneList.Destroy;
+begin
+ Clear;
+ inherited Destroy;
+end;
+
+function TTimeZoneList.GetRecord(index: Integer): PTimeZone;
+begin
+ Result:= PTimeZone(Items[index]);
+end;
+
+procedure TTimeZoneList.SetRecord(index: Integer; Ptr: PTimeZone);
+var
+ p: PTimeZone;
+begin
+ p := TimeZone[index];
+ if p <> Ptr then
+ begin
+ if p <> nil then
+ Dispose(p);
+ Items[index] := Ptr;
+ end;
+end;
+
+end.
<<<<<<< HEAD
=======
=======
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 1f1f212..344ffec 100644
--- a/source/GTranslate.pas
+++ b/source/GTranslate.pas
@@ -1,347 +1,437 @@
-{ ==============================================================================|
-|: 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 |
-|==============================================================================|
-| |
-|==============================================================================|
-| |
-|==============================================================================}
-unit GTranslate;
-
-interface
-
-uses windows, msxml, superobject, classes, variants, sysutils, typinfo;
-
-resourcestring
- rsLangUnknown = ' ';
- rsLangAuto = '';
- rsLang_en = '';
- rsLang_ru = '';
- rsLang_it = '';
- rsLang_az = '';
- rsLang_sq = '';
- rsLang_ar = '';
- rsLang_hy = '';
- rsLang_af = '';
- rsLang_eu = '';
- rsLang_be = '';
- rsLang_bg = '';
- rsLang_cy = '';
- rsLang_hu = '';
- rsLang_vi = '';
- rsLang_gl = '';
- rsLang_nl = '';
- rsLang_el = '';
- rsLang_ka = '';
- rsLang_da = '';
- rsLang_iw = '';
- rsLang_yi = '';
- rsLang_id = '';
- rsLang_ga = '';
- rsLang_is = '';
- rsLang_es = '';
- rsLang_ca = '';
- rsLang_zh_CN = '';
- rsLang_ko = '';
- rsLang_ht = ' ()';
- rsLang_lv = '';
- rsLang_lt = '';
- rsLang_mk = '';
- rsLang_ms = '';
- rsLang_mt = '';
- rsLang_de = '';
- rsLang_no = '';
- rsLang_fa = '';
- rsLang_pl = '';
- rsLang_pt = '';
- rsLang_ro = '';
- rsLang_sr = '';
- rsLang_sk = '';
- rsLang_sl = '';
- rsLang_sw = '';
- rsLang_tl = '';
- rsLang_th = '';
- rsLang_tr = '';
- rsLang_uk = '';
- rsLang_ur = '';
- rsLang_fi = '';
- rsLang_fr = '';
- rsLang_hi = '';
- rsLang_hr = '';
- rsLang_cs = '';
- rsLang_sv = '';
- rsLang_et = '';
- rsLang_ja = '';
-
- rsErrorDestLng = ' .. ';
- rsErrorTrnsl = ' : %s';
-
-type
- TLanguageEnum = (unknown, lng_af, lng_sq, lng_ar, lng_hy, lng_az, lng_eu,
- lng_be, lng_bg, lng_my, lng_ca, lng_zh, lng_zh_CN, lng_zh_TW, lng_hr,
- lng_cs, lng_da, lng_nl, lng_en, lng_et, lng_tl, lng_fi, lng_fr, lng_gl,
- lng_ka, lng_de, lng_el, lng_gu, lng_ht, lng_iw, lng_hi, lng_hu, lng_is,
- lng_id, lng_iu, lng_ga, lng_it, lng_ja, lng_jw, lng_kn, lng_kk, lng_km,
- lng_ko, lng_ku, lng_ky, lng_lo, lng_la, lng_lv, lng_lt, lng_lb, lng_mk,
- lng_ms, lng_ml, lng_mt, lng_mi, lng_mr, lng_mn, lng_ne, lng_no, lng_oc,
- lng_or, lng_ps, lng_fa, lng_pl, lng_pt, lng_pt_PT, lng_pa, lng_qu, lng_ro,
- lng_ru, lng_sa, lng_gd, lng_sr, lng_sd, lng_si, lng_sk, lng_sl, lng_es,
- lng_su, lng_sw, lng_sv, lng_syr, lng_tg, lng_ta, lng_tt, lng_te, lng_th,
- lng_to, lng_tr, lng_uk, lng_ur, lng_uz, lng_ug, lng_vi, lng_cy, lng_yi,
- lng_yo);
-
- TLanguageRec = record
- Name: string;
- Ident: TLanguageEnum;
- end;
-
- TSpecials = set of AnsiChar;
-
-const
- Languages: array [0 .. 57] of TLanguageRec =
- ((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),
- (Name: rsLang_hy; Ident: lng_hy), (Name: rsLang_af; Ident: lng_af),
- (Name: rsLang_eu; Ident: lng_eu), (Name: rsLang_be; Ident: lng_be),
- (Name: rsLang_bg; Ident: lng_bg), (Name: rsLang_cy; Ident: lng_cy),
- (Name: rsLang_hu; Ident: lng_hu), (Name: rsLang_vi; Ident: lng_vi),
- (Name: rsLang_gl; Ident: lng_gl), (Name: rsLang_nl; Ident: lng_nl),
- (Name: rsLang_el; Ident: lng_el), (Name: rsLang_ka; Ident: lng_ka),
- (Name: rsLang_da; Ident: lng_da), (Name: rsLang_iw; Ident: lng_iw),
- (Name: rsLang_yi; Ident: lng_yi), (Name: rsLang_id; Ident: lng_id),
- (Name: rsLang_ga; Ident: lng_ga), (Name: rsLang_is; Ident: lng_is),
- (Name: rsLang_es; Ident: lng_es), (Name: rsLang_ca; Ident: lng_ca),
- (Name: rsLang_zh_CN; Ident: lng_zh_CN), (Name: rsLang_ko; Ident: lng_ko),
- (Name: rsLang_ht; Ident: lng_ht), (Name: rsLang_lv; Ident: lng_lv),
- (Name: rsLang_lt; Ident: lng_lt), (Name: rsLang_mk; Ident: lng_mk),
- (Name: rsLang_ms; Ident: lng_ms), (Name: rsLang_mt; Ident: lng_mt),
- (Name: rsLang_de; Ident: lng_de), (Name: rsLang_no; Ident: lng_no),
- (Name: rsLang_fa; Ident: lng_fa), (Name: rsLang_pl; Ident: lng_pl),
- (Name: rsLang_pt; Ident: lng_pt), (Name: rsLang_ro; Ident: lng_ro),
- (Name: rsLang_sr; Ident: lng_sr), (Name: rsLang_sk; Ident: lng_sk),
- (Name: rsLang_sl; Ident: lng_sl), (Name: rsLang_sw; Ident: lng_sw),
- (Name: rsLang_tl; Ident: lng_tl), (Name: rsLang_th; Ident: lng_th),
- (Name: rsLang_tr; Ident: lng_tr), (Name: rsLang_uk; Ident: lng_uk),
- (Name: rsLang_ur; Ident: lng_ur), (Name: rsLang_fi; Ident: lng_fi),
- (Name: rsLang_fr; Ident: lng_fr), (Name: rsLang_hi; Ident: lng_hi),
- (Name: rsLang_hr; Ident: lng_hr), (Name: rsLang_cs; Ident: lng_cs),
- (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];
-
-type
- TOnTranslate = procedure(const SourceStr, TranslateStr: string;
- LangDetected: TLanguageEnum) of object;
- TOnTranslateError = procedure(const Code: integer; Status: string) of object;
-
- TTranslator = class(TComponent)
- private
- FSourceLang: TLanguageEnum;
- FDestLang: TLanguageEnum;
- FOnTranslate: TOnTranslate;
- FOnTranslateError: TOnTranslateError;
- function GetDetectedLanguage(const DetectStr: string): TLanguageEnum;
- function GetRequestURL(SourceStr: string): string;
- public
- constructor Create(AOwner: TComponent); override;
- function Translate(const SourceStr: string): string;
- function GetLanguagesNames: TStringList;
- function GetLangByName(const aName: string): TLanguageEnum;
- published
- property SourceLang: TLanguageEnum read FSourceLang write FSourceLang;
- property DestLang: TLanguageEnum read FDestLang write FDestLang;
- property OnTranslate: TOnTranslate read FOnTranslate write FOnTranslate;
- property OnTranslateError: TOnTranslateError read FOnTranslateError write
- FOnTranslateError;
- end;
-
-procedure Register;
-function EncodeURL(const Value: AnsiString): AnsiString; inline;
-function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar;
- Specials: TSpecials): AnsiString; inline;
-
-implementation
-
-procedure Register;
-begin
- 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 EncodeURL(const Value: AnsiString): AnsiString; inline;
-begin
- Result := EncodeTriplet(Value, '%', URLSpecialChar);
-end;
-
-{ TTranslator }
-
-constructor TTranslator.Create(AOwner: TComponent);
-begin
- inherited Create(AOwner);
- FSourceLang := unknown;
- FDestLang := lng_ru;
-end;
-
-function TTranslator.GetDetectedLanguage(const DetectStr: string)
- : TLanguageEnum;
-var
- aName: string;
- idx: integer;
-begin
- aName := 'lng_' + StringReplace(DetectStr, '-', '_', [rfReplaceAll]);
- idx := GetEnumValue(TypeInfo(TLanguageEnum), aName);
- if idx > -1 then
- Result := TLanguageEnum(idx)
- else
- Result := unknown;
-end;
-
-function TTranslator.GetLangByName(const aName: string): TLanguageEnum;
-var
- i: integer;
-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
- end;
- end;
-end;
-
-function TTranslator.GetLanguagesNames: TStringList;
-var
- i: integer;
-begin
- Result := TStringList.Create;
- for i := 0 to High(Languages) - 1 do
- Result.Add(Languages[i].Name);
-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;
- dest := StringReplace(GetEnumName(TypeInfo(TLanguageEnum), Ord(FDestLang)),
- '_', '-', [rfReplaceAll]);
- Delete(dest, 1, 4);
- Result := EncodeURL(cTranslateURL + '?v=' + APIVersion + '&q=' + UTF8Encode
- (SourceStr) + '&langpair=' + source + '|' + dest);
-end;
-
-function TTranslator.Translate(const SourceStr: string): string;
-var
- obj: ISuperObject;
- req: IXMLHttpRequest;
- s: PSOChar;
-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
- 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;
-end;
-
-end.
+{ =============================================================================|
+ |: 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, superobject, classes, variants, sysutils, typinfo,synacode,
+ ssl_openssl,httpsend,Dialogs;
+
+resourcestring
+ rsLangUnknown = ' ';
+ rsLangAuto = '';
+ rsLang_en = '';
+ rsLang_ru = '';
+ rsLang_it = '';
+ rsLang_az = '';
+ rsLang_sq = '';
+ rsLang_ar = '';
+ rsLang_hy = '';
+ rsLang_af = '';
+ rsLang_eu = '';
+ rsLang_be = '';
+ rsLang_bg = '';
+ rsLang_cy = '';
+ rsLang_hu = '';
+ rsLang_vi = '';
+ rsLang_gl = '';
+ rsLang_nl = '';
+ rsLang_el = '';
+ rsLang_ka = '';
+ rsLang_da = '';
+ rsLang_iw = '';
+ rsLang_yi = '';
+ rsLang_id = '';
+ rsLang_ga = '';
+ rsLang_is = '';
+ rsLang_es = '';
+ rsLang_ca = '';
+ rsLang_zh_CN = '';
+ rsLang_ko = '';
+ rsLang_ht = ' ()';
+ rsLang_lv = '';
+ rsLang_lt = '';
+ rsLang_mk = '';
+ rsLang_ms = '';
+ rsLang_mt = '';
+ rsLang_de = '';
+ rsLang_no = '';
+ rsLang_fa = '';
+ rsLang_pl = '';
+ rsLang_pt = '';
+ rsLang_ro = '';
+ rsLang_sr = '';
+ rsLang_sk = '';
+ rsLang_sl = '';
+ rsLang_sw = '';
+ rsLang_tl = '';
+ rsLang_th = '';
+ rsLang_tr = '';
+ rsLang_uk = '';
+ rsLang_ur = '';
+ rsLang_fi = '';
+ rsLang_fr = '';
+ rsLang_hi = '';
+ rsLang_hr = '';
+ rsLang_cs = '';
+ rsLang_sv = '';
+ rsLang_et = '';
+ rsLang_ja = '';
+
+ rsErrorDestLng = ' .. ';
+ rsErrorTrnsl = ' ';
+ rsErrLagrgeReq =
+ ' 5000';
+
+type
+ TLanguageEnum = (unknown, lng_af, lng_sq, lng_ar, lng_hy, lng_az, lng_eu,
+ lng_be, lng_bg, lng_my, lng_ca, lng_zh, lng_zh_CN, lng_zh_TW, lng_hr,
+ lng_cs, lng_da, lng_nl, lng_en, lng_et, lng_tl, lng_fi, lng_fr, lng_gl,
+ lng_ka, lng_de, lng_el, lng_gu, lng_ht, lng_iw, lng_hi, lng_hu, lng_is,
+ lng_id, lng_iu, lng_ga, lng_it, lng_ja, lng_jw, lng_kn, lng_kk, lng_km,
+ lng_ko, lng_ku, lng_ky, lng_lo, lng_la, lng_lv, lng_lt, lng_lb, lng_mk,
+ lng_ms, lng_ml, lng_mt, lng_mi, lng_mr, lng_mn, lng_ne, lng_no, lng_oc,
+ lng_or, lng_ps, lng_fa, lng_pl, lng_pt, lng_pt_PT, lng_pa, lng_qu, lng_ro,
+ lng_ru, lng_sa, lng_gd, lng_sr, lng_sd, lng_si, lng_sk, lng_sl, lng_es,
+ lng_su, lng_sw, lng_sv, lng_syr, lng_tg, lng_ta, lng_tt, lng_te, lng_th,
+ lng_to, lng_tr, lng_uk, lng_ur, lng_uz, lng_ug, lng_vi, lng_cy, lng_yi,
+ lng_yo);
+
+ TLanguageRec = record
+ Name: string;
+ Ident: TLanguageEnum;
+ end;
+
+ TSpecials = set of AnsiChar;
+
+const
+ Languages: array [0 .. 57] of TLanguageRec =
+ ((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),
+ (Name: rsLang_hy; Ident: lng_hy), (Name: rsLang_af; Ident: lng_af),
+ (Name: rsLang_eu; Ident: lng_eu), (Name: rsLang_be; Ident: lng_be),
+ (Name: rsLang_bg; Ident: lng_bg), (Name: rsLang_cy; Ident: lng_cy),
+ (Name: rsLang_hu; Ident: lng_hu), (Name: rsLang_vi; Ident: lng_vi),
+ (Name: rsLang_gl; Ident: lng_gl), (Name: rsLang_nl; Ident: lng_nl),
+ (Name: rsLang_el; Ident: lng_el), (Name: rsLang_ka; Ident: lng_ka),
+ (Name: rsLang_da; Ident: lng_da), (Name: rsLang_iw; Ident: lng_iw),
+ (Name: rsLang_yi; Ident: lng_yi), (Name: rsLang_id; Ident: lng_id),
+ (Name: rsLang_ga; Ident: lng_ga), (Name: rsLang_is; Ident: lng_is),
+ (Name: rsLang_es; Ident: lng_es), (Name: rsLang_ca; Ident: lng_ca),
+ (Name: rsLang_zh_CN; Ident: lng_zh_CN), (Name: rsLang_ko; Ident: lng_ko),
+ (Name: rsLang_ht; Ident: lng_ht), (Name: rsLang_lv; Ident: lng_lv),
+ (Name: rsLang_lt; Ident: lng_lt), (Name: rsLang_mk; Ident: lng_mk),
+ (Name: rsLang_ms; Ident: lng_ms), (Name: rsLang_mt; Ident: lng_mt),
+ (Name: rsLang_de; Ident: lng_de), (Name: rsLang_no; Ident: lng_no),
+ (Name: rsLang_fa; Ident: lng_fa), (Name: rsLang_pl; Ident: lng_pl),
+ (Name: rsLang_pt; Ident: lng_pt), (Name: rsLang_ro; Ident: lng_ro),
+ (Name: rsLang_sr; Ident: lng_sr), (Name: rsLang_sk; Ident: lng_sk),
+ (Name: rsLang_sl; Ident: lng_sl), (Name: rsLang_sw; Ident: lng_sw),
+ (Name: rsLang_tl; Ident: lng_tl), (Name: rsLang_th; Ident: lng_th),
+ (Name: rsLang_tr; Ident: lng_tr), (Name: rsLang_uk; Ident: lng_uk),
+ (Name: rsLang_ur; Ident: lng_ur), (Name: rsLang_fi; Ident: lng_fi),
+ (Name: rsLang_fr; Ident: lng_fr), (Name: rsLang_hi; Ident: lng_hi),
+ (Name: rsLang_hr; Ident: lng_hr), (Name: rsLang_cs; Ident: lng_cs),
+ (Name: rsLang_sv; Ident: lng_sv), (Name: rsLang_et; Ident: lng_et),
+ (Name: rsLang_ja; Ident: lng_ja));
+
+ 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;
+ LangDetected: TLanguageEnum) of object;
+ TOnTranslateError = procedure(const Code: integer; Status: string) of object;
+
+ 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;
+ function GetLanguagesNames: TStringList;
+ function GetLangByName(const aName: string): TLanguageEnum;
+ 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;
+
+implementation
+
+procedure Register;
+begin
+ 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 EncodeURL(const Value: AnsiString): AnsiString; inline;
+//begin
+// Result := EncodeTriplet(Value, '%', URLSpecialChar);
+//end;
+
+{ TTranslator }
+
+constructor TTranslator.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FSourceLang := unknown;
+ FDestLang := lng_ru;
+end;
+
+function TTranslator.GetDetectedLanguage(const DetectStr: string)
+ : TLanguageEnum;
+var
+ aName: string;
+ idx: integer;
+begin
+ aName := 'lng_' + StringReplace(DetectStr, '-', '_', [rfReplaceAll]);
+ idx := GetEnumValue(TypeInfo(TLanguageEnum), aName);
+ if idx > -1 then
+ Result := TLanguageEnum(idx)
+ else
+ Result := unknown;
+end;
+
+function TTranslator.GetLangByName(const aName: string): TLanguageEnum;
+var
+ i: integer;
+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
+ end;
+ end;
+end;
+
+function TTranslator.GetLanguagesNames: TStringList;
+var
+ i: integer;
+begin
+ Result := TStringList.Create;
+ for i := 0 to High(Languages) - 1 do
+ 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;
+ dest := StringReplace(GetEnumName(TypeInfo(TLanguageEnum), Ord(FDestLang)),
+ '_', '-', [rfReplaceAll]);
+ Delete(dest, 1, 4);
+ 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;
+ s: PSOChar;
+ Text: TStringList;
+ Resp: string;
+begin
+ if FDestLang = unknown then
+ raise Exception.Create(rsErrorDestLng);
+ Text := TStringList.Create;
+ Text.Add(SourceStr);
+
+ if SendRequest(Text, Resp) then
+ begin
+ 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/GoogleLogin.pas b/source/GoogleLogin.pas
index 0cbb2c8..021447f 100644
--- a/source/GoogleLogin.pas
+++ b/source/GoogleLogin.pas
@@ -1,657 +1,657 @@
{ ******************************************************* }
-{ }
-{ Delphi & Google API }
-{ }
-{ File: uGoogleLogin }
-{ Copyright (c) WebDelphi.ru }
-{ All Rights Reserved. }
-{ }
-{ }
-{ }
-{ ******************************************************* }
-
-{ ******************************************************* }
-{ GoogleLogin Component }
-{ ******************************************************* }
-
-unit GoogleLogin;
-
-interface
-
-uses WinInet, StrUtils, SysUtils, Classes, Windows, TypInfo;
-
-resourcestring
- rcNone = 'Аутентификация не производилась или сброшена';
- rcOk = 'Аутентификация прошла успешно';
- rcBadAuthentication =
- 'Не удалось распознать имя пользователя или пароль, использованные в запросе на вход';
- rcNotVerified =
- 'Адрес электронной почты, связанный с аккаунтом, не был подтвержден';
- rcTermsNotAgreed = 'Пользователь не принял условия использования службы';
- rcCaptchaRequired = 'Требуется ответ на тест CAPTCHA';
- rcUnknown = 'Неизвестная ошибка';
- rcAccountDeleted = 'Аккаунт этого пользователя удален';
- rcAccountDisabled = 'Аккаунт этого пользователя отключен';
- rcServiceDisabled = 'Доступ пользователя к указанной службе запрещен';
- rcServiceUnavailable = 'Служба недоступна, повторите попытку позже';
- rcDisconnect = 'Соединение с сервером разорвано';
- // ошибки соединения
- rcErrServer = 'На сервере произошла ошибка #';
- rcErrDont = 'Не могу получить описание ошибки';
-
-const
- // дефолное название приложение через которое якобы происходит соединение с сервером гугла
- DefaultAppName =
- 'Mozilla/5.0 (Windows; U; Windows NT 5.1; ru; rv:1.9.2.6) Gecko/20100625 Firefox/3.6.6';
- // настройки wininet для работы с ssl
- Flags_Connection = INTERNET_DEFAULT_HTTPS_PORT;
- Flags_Request =
- INTERNET_FLAG_RELOAD or INTERNET_FLAG_IGNORE_CERT_CN_INVALID
- or INTERNET_FLAG_NO_CACHE_WRITE or 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);
-
-type
- TLoginResult = (lrNone, lrOk, lrBadAuthentication, lrNotVerified,
- lrTermsNotAgreed, lrCaptchaRequired, lrUnknown, lrAccountDeleted,
- 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);
-
-type
- TResultRec = packed record
- LoginStr: string; // текстовый результат авторизации
- SID: string; // в настоящее время не используется
- LSID: string; // в настоящее время не используется
- Auth: string;
- end;
-
-type
- TAutorization = procedure(const LoginResult: TLoginResult;
- Result: TResultRec) of object; // авторизировались
- TErrorAutorization = procedure(const ErrorStr: string) of object;
- // а это не авторизировались))
- TDisconnect = procedure(const ResultStr: string) of object;
-
-type
- // поток используется только для получения HTML страницы
- TGoogleLoginThread = class(TThread)
- private
- { private declarations }
- FParamStr: string; // параметры запроса
- FLogintoken: string;
- // данные ответа/запроса
- FResultRec: TResultRec; // структура для передачи результатов
-
- FCaptchaURL: string;
-
- FLastResult: TLoginResult; // результаты авторизации
-
- // События
- FAutorization: TAutorization; // авторизация
- 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;
- // получаем текст ошибки
-
- procedure SynAutoriz; // передача значения авторизации в главную форму как положено в потоке
- procedure SynErrAutoriz; // передача значения ошибки в главную форму как положено в потоке
- protected
- { protected declarations }
- public
- { public declarations }
- constructor Create(CreateSuspennded: BOOLEAN; aParamStr: string);
- // используем для передачи логина и пароля и подобного
- procedure Execute; override; // выполняем непосредственно авторизацию на сайте
- published
- { published declarations }
- // события
- property OnAutorization
- : TAutorization read FAutorization write FAutorization;
- // авторизировались
- property OnError: TErrorAutorization read FErrorAutorization write
- FErrorAutorization; // возникла ошибка ((
- end;
-
- // "шкурка" компонента
- TGoogleLogin = class(TComponent)
- private
- // Поток
- FThread: TGoogleLoginThread;
- // регистрационные данные
- FAppname: string; // строка символов, которая передается серверу и идентифицирует программное обеспечение, пославшее запрос.
- FAccountType: TAccountType;
- FLastResult: TLoginResult;
- FEmail: string;
- FPassword: string;
- // данные ответа/запроса
- FService: TServices; // сервис к которому необходимо получить доступ
- FLogintoken: string;
- FLogincaptcha: string;
- // параметры Captcha
- FCaptchaURL: string;
- FAfterLogin: TAutorization;
- 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;
- procedure Login(aLoginToken: string = ''; aLoginCaptcha: string = '');
- // формируем запрос
- procedure Disconnect; // удаляет все данные по авторизации
- property LastResult: TLoginResult read FLastResult;
- // property Auth: string read FAuth;
- // property SID: string read FSID;
- // property LSID: string read FLSID;
- // property CaptchaURL: string read FCaptchaURL;
- // property LoginToken: string read FLogintoken;
- // property LoginCaptcha: string read FLogincaptcha write FLogincaptcha;
- published
- property AppName: string read FAppname write SetAppName;
- property AccountType: TAccountType read FAccountType write FAccountType;
- property Email: string read FEmail write SetEmail;
- property Password: string read FPassword write SetPassword;
- property Service: TServices read FService write SetService default xapi;
- property OnAutorization: TAutorization read FAfterLogin write FAfterLogin;
- property OnError: TErrorAutorization read FErrorAutorization write
- FErrorAutorization; // возникла ошибка ((
- property OnDisconnect: TDisconnect read FDisconnect write FDisconnect;
- end;
-
-procedure Register;
-
-implementation
-
-procedure Register;
-begin
- RegisterComponents('WebDelphi.ru', [TGoogleLogin]);
-end;
-
-{ TGoogleLogin }
-
-function TGoogleLogin.DigitToHex(Digit: Integer): Char;
-begin
- case Digit of
- 0 .. 9:
- Result := Chr(Digit + Ord('0'));
- 10 .. 15:
- Result := Chr(Digit - 10 + Ord('A'));
- else
- Result := '0';
- end;
-end;
-
-procedure TGoogleLogin.Disconnect;
-begin
- FAccountType := atNone;
- FLastResult := lrNone;
- // FSID:='';
- // FLSID:='';
- // FAuth:='';
- FLogintoken := '';
- FLogincaptcha := '';
- FCaptchaURL := '';
- FLogintoken := '';
- if Assigned(FThread) then
- FThread.Terminate;
- if Assigned(FDisconnect) then
- OnDisconnect(rcDisconnect)
-end;
-
-constructor TGoogleLogin.Create(AOwner: TComponent);
-begin
- inherited Create(AOwner);
- FAppname := DefaultAppName; // дефолтное значение
-end;
-
-procedure TGoogleLogin.Login(aLoginToken, aLoginCaptcha: string);
-var
- cBody: TStringStream;
- ResponseText: string;
-begin
- cBody := TStringStream.Create('');
- case FAccountType of
- atNone, atHOSTED_OR_GOOGLE:
- cBody.WriteString('accountType=HOSTED_OR_GOOGLE&');
- atGOOGLE:
- cBody.WriteString('accountType=GOOGLE&');
- atHOSTED:
- cBody.WriteString('accountType=HOSTED&');
- end;
- cBody.WriteString('Email=' + FEmail + '&');
- cBody.WriteString('Passwd=' + URLEncode(FPassword) + '&');
- cBody.WriteString('service=' + GetEnumName(TypeInfo(TServices),
- Ord(FService)) + '&');
- //ResponseText := GetEnumName(TypeInfo(TServices), Integer(FService));
-
- if Length(Trim(FAppname)) > 0 then
- cBody.WriteString('source=' + FAppname)
- else
- cBody.WriteString('source=' + DefaultAppName);
- if Length(Trim(aLoginToken)) > 0 then
- begin
- cBody.WriteString('&logintoken=' + aLoginToken);
- cBody.WriteString('&logincaptcha=' + aLoginCaptcha);
- end;
- // отправляем запрос на сервер
- ResponseText := SendRequest(cBody.DataString);
-end;
-
-function TGoogleLogin.SendRequest(const ParamStr: string): AnsiString;
-begin
- // отправляем запрос на сервер в отдельном потоке
- FThread := TGoogleLoginThread.Create(true, ParamStr);
- FThread.OnAutorization := Self.OnAutorization;
- FThread.OnError := Self.OnError;
- FThread.FreeOnTerminate := true; // чтобы сам себя грухнул после окончания операции
- FThread.Resume; // запуск
- // тут делать смысла что то нет так как данные еще не получены(они ведь будут получены в другом потоке)
-end;
-
-// устанавливаем значение строки символов, которая передается серверу
-// идентифицирует программное обеспечение, пославшее запрос.
-procedure TGoogleLogin.SetAppName(value: string);
-begin
- if not(value = '') then
- FAppname := value
- else
- FAppname := DefaultAppName;
-end;
-
-procedure TGoogleLogin.SetCaptcha(cCaptcha: string);
-begin
- FLogincaptcha := cCaptcha;
- Login(FLogintoken, FLogincaptcha); // перелогиниваемся с каптчей
-end;
-
-procedure TGoogleLogin.SetEmail(cEmail: string);
-begin
- FEmail := cEmail;
- if FLastResult = lrOk then
- Disconnect; // обнуляем результаты
-end;
-
-procedure TGoogleLogin.SetPassword(cPassword: string);
-begin
- FPassword := cPassword;
- if FLastResult = lrOk then
- Disconnect; // обнуляем результаты
-end;
-
-procedure TGoogleLogin.SetService(cService: TServices);
-begin
- FService := cService;
- if FLastResult = lrOk then
- begin
- 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;
-begin
- len := 0;
- for i := 1 to Length(S) do
- if ((S[i] >= '0') and (S[i] <= '9')) or ((S[i] >= 'A') and (S[i] <= 'Z'))
- or ((S[i] >= 'a') and (S[i] <= 'z')) or (S[i] = ' ') or (S[i] = '_') or
- (S[i] = '*') or (S[i] = '-') or (S[i] = '.') then
- len := len + 1
- else
- len := len + 3;
- SetLength(Result, len);
- idx := 1;
- for i := 1 to Length(S) do
- if S[i] = ' ' then
- begin
- Result[idx] := '+';
- idx := idx + 1;
- end
- else if ((S[i] >= '0') and (S[i] <= '9')) or
- ((S[i] >= 'A') and (S[i] <= 'Z')) or ((S[i] >= 'a') and (S[i] <= 'z'))
- or (S[i] = '_') or (S[i] = '*') or (S[i] = '-') or (S[i] = '.') then
- begin
- Result[idx] := S[i];
- idx := idx + 1;
- end
- else
- begin
- Result[idx] := '%';
- Result[idx + 1] := DigitToHex(Ord(S[i]) div 16);
- Result[idx + 2] := DigitToHex(Ord(S[i]) mod 16);
- idx := idx + 3;
- end;
-end;
-
-{ TGoogleLoginThread }
-
-constructor TGoogleLoginThread.Create(CreateSuspennded: BOOLEAN;
- aParamStr: string);
-begin
- inherited Create(CreateSuspennded);
- FParamStr := aParamStr;
- FResultRec.LoginStr := '';
- FResultRec.SID := '';
- FResultRec.LSID := '';
- FResultRec.Auth := '';
-end;
-
-procedure TGoogleLoginThread.Execute;
- function DataAvailable(hRequest: pointer; out Size: cardinal): BOOLEAN;
- begin
- Result := WinInet.InternetQueryDataAvailable(hRequest, Size, 0, 0);
- end;
-
-var
- hInternet, hConnect, hRequest: pointer;
- dwBytesRead, i, L: cardinal;
- 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); // Получаем кол-во принимаемых данных
- if L = 0 then
- break;
- SetLength(sTemp, L + i);
- if not InternetReadFile(hRequest, @sTemp[i], sizeof(L),
- dwBytesRead) then
- break; // Получаем данные с сервера
- inc(i, dwBytesRead);
- if Terminated then // проверка для экстренного закрытия потока
- begin
- InternetCloseHandle(hRequest);
- InternetCloseHandle(hConnect);
- InternetCloseHandle(hInternet);
- Exit;
- end;
- until dwBytesRead = 0;
- sTemp[i] := #0;
- end;
- end;
- end;
- end;
- except
- Synchronize(SynErrAutoriz);
- Exit; // сваливаем отсюда
- end;
- InternetCloseHandle(hRequest);
- InternetCloseHandle(hConnect);
- InternetCloseHandle(hInternet);
- // получаем результаты авторизации
- FLastResult := ExpertLoginResult(sTemp);
- FResultRec.LoginStr := GetResultText;
- Synchronize(SynAutoriz);
-end;
-
-function TGoogleLoginThread.ExpertLoginResult(const LoginResult: string)
- : TLoginResult;
-var
- List: TStringList;
- i: Integer;
-begin
- // грузим ответ сервера в список
- List := TStringList.Create;
- List.Text := LoginResult;
- // анализируем построчно
- 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 // строка с ошибкой
- begin
- Result := GetLoginError(List[i]); // получили тип ошибки
- break;
- end;
- end;
- if Result = lrCaptchaRequired then // требуется ввод каптчи
- begin
- FCaptchaURL := GetCaptchaURL(List);
- FLogintoken := GetCaptchaToken(List);
- end;
- end
- else
- begin
- Result := lrOk;
- for i := 0 to List.Count - 1 do
- begin
- if pos('SID', uppercase(List[i])) > 0 then
- FResultRec.SID := Trim(copy(List[i], pos('=', List[i]) + 1,
- Length(List[i]) - pos('=', List[i])))
- else if pos('LSID', uppercase(List[i])) > 0 then
- FResultRec.LSID := Trim(copy(List[i], pos('=', List[i]) + 1,
- Length(List[i]) - pos('=', List[i])))
- else if pos('AUTH', uppercase(List[i])) > 0 then
- FResultRec.Auth := Trim(copy(List[i], pos('=', List[i]) + 1,
- Length(List[i]) - pos('=', List[i])));
- end;
- end;
- FreeAndNil(List);
-end;
-
-function TGoogleLoginThread.GetCaptchaToken(const cList: TStringList): String;
-var
- i: Integer;
-begin
- for i := 0 to cList.Count - 1 do
- begin
- if pos('captchatoken', LowerCase(cList[i])) > 0 then
- begin
- Result := Trim(copy(cList[i], pos('=', cList[i]) + 1,
- Length(cList[i]) - pos('=', cList[i])));
- break;
- end;
- end;
-end;
-
-function TGoogleLoginThread.GetCaptchaURL(const cList: TStringList): string;
-var
- i: Integer;
-begin
- for i := 0 to cList.Count - 1 do
- begin
- if pos('captchaurl', LowerCase(cList[i])) > 0 then
- begin
- Result := Trim(copy(cList[i], pos('=', cList[i]) + 1,
- Length(cList[i]) - pos('=', cList[i])));
- break;
- end;
- end;
-end;
-
-// Если параметр FromServer TRUE, то код ошибки и её текст берется с сервера, в противном случае берется текст локальной ошибки.
-function TGoogleLoginThread.GetErrorText(const FromServer: BOOLEAN): string;
-var
- Msg: array [0 .. 1023] of Char;
- ErCode, len: cardinal;
-begin
- len := sizeof(Msg);
- ZeroMemory(@Msg, sizeof(Msg));
- if FromServer then
- if InternetGetLastResponseInfo(ErCode, @Msg, len) then
- Result := rcErrServer + IntToStr(ErCode) + #13 + StrPas(Msg)
- else
- Result := rcErrDont
- else if FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, GetLastError,
- GetKeyboardLayout(0), @Msg, sizeof(Msg), nil) <> 0 then
- Result := StrPas(Msg)
- else
- Result := rcErrDont;
-end;
-
-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);
-end;
-
-function TGoogleLoginThread.GetResultText: string;
-begin
- case FLastResult of
- lrNone:
- Result := rcNone;
- lrOk:
- Result := rcOk;
- lrBadAuthentication:
- Result := rcBadAuthentication;
- lrNotVerified:
- Result := rcNotVerified;
- lrTermsNotAgreed:
- Result := rcTermsNotAgreed;
- lrCaptchaRequired:
- Result := rcCaptchaRequired;
- lrUnknown:
- Result := rcUnknown;
- lrAccountDeleted:
- Result := rcAccountDeleted;
- lrAccountDisabled:
- Result := rcAccountDisabled;
- lrServiceDisabled:
- Result := rcServiceDisabled;
- lrServiceUnavailable:
- Result := rcServiceUnavailable;
- end;
-end;
-
-procedure TGoogleLoginThread.SynAutoriz;
-begin
- if Assigned(FAutorization) then
- OnAutorization(FLastResult, FResultRec);
-end;
-
-procedure TGoogleLoginThread.SynErrAutoriz;
-begin
- if Assigned(FErrorAutorization) then
- OnError(GetErrorText(true)); // получаем текст ошибки
-end;
-
-end.
-
+{ }
+{ Delphi & Google API }
+{ }
+{ File: uGoogleLogin }
+{ Copyright (c) WebDelphi.ru }
+{ All Rights Reserved. }
+{ }
+{ }
+{ }
+{ ******************************************************* }
+
+{ ******************************************************* }
+{ GoogleLogin Component }
+{ ******************************************************* }
+
+unit GoogleLogin;
+
+interface
+
+uses WinInet, StrUtils, SysUtils, Classes, Windows, TypInfo;
+
+resourcestring
+ rcNone = 'Аутентификация не производилась или сброшена';
+ rcOk = 'Аутентификация прошла успешно';
+ rcBadAuthentication =
+ 'Не удалось распознать имя пользователя или пароль, использованные в запросе на вход';
+ rcNotVerified =
+ 'Адрес электронной почты, связанный с аккаунтом, не был подтвержден';
+ rcTermsNotAgreed = 'Пользователь не принял условия использования службы';
+ rcCaptchaRequired = 'Требуется ответ на тест CAPTCHA';
+ rcUnknown = 'Неизвестная ошибка';
+ rcAccountDeleted = 'Аккаунт этого пользователя удален';
+ rcAccountDisabled = 'Аккаунт этого пользователя отключен';
+ rcServiceDisabled = 'Доступ пользователя к указанной службе запрещен';
+ rcServiceUnavailable = 'Служба недоступна, повторите попытку позже';
+ rcDisconnect = 'Соединение с сервером разорвано';
+ // ошибки соединения
+ rcErrServer = 'На сервере произошла ошибка #';
+ rcErrDont = 'Не могу получить описание ошибки';
+
+const
+ // дефолное название приложение через которое якобы происходит соединение с сервером гугла
+ DefaultAppName =
+ 'Mozilla/5.0 (Windows; U; Windows NT 5.1; ru; rv:1.9.2.6) Gecko/20100625 Firefox/3.6.6';
+ // настройки wininet для работы с ssl
+ Flags_Connection = INTERNET_DEFAULT_HTTPS_PORT;
+ Flags_Request =
+ INTERNET_FLAG_RELOAD or INTERNET_FLAG_IGNORE_CERT_CN_INVALID
+ or INTERNET_FLAG_NO_CACHE_WRITE or 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);
+
+type
+ TLoginResult = (lrNone, lrOk, lrBadAuthentication, lrNotVerified,
+ lrTermsNotAgreed, lrCaptchaRequired, lrUnknown, lrAccountDeleted,
+ 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);
+
+type
+ TResultRec = packed record
+ LoginStr: string; // текстовый результат авторизации
+ SID: string; // в настоящее время не используется
+ LSID: string; // в настоящее время не используется
+ Auth: string;
+ end;
+
+type
+ TAutorization = procedure(const LoginResult: TLoginResult;
+ Result: TResultRec) of object; // авторизировались
+ TErrorAutorization = procedure(const ErrorStr: string) of object;
+ // а это не авторизировались))
+ TDisconnect = procedure(const ResultStr: string) of object;
+
+type
+ // поток используется только для получения HTML страницы
+ TGoogleLoginThread = class(TThread)
+ private
+ { private declarations }
+ FParamStr: string; // параметры запроса
+ FLogintoken: string;
+ // данные ответа/запроса
+ FResultRec: TResultRec; // структура для передачи результатов
+
+ FCaptchaURL: string;
+
+ FLastResult: TLoginResult; // результаты авторизации
+
+ // События
+ FAutorization: TAutorization; // авторизация
+ 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;
+ // получаем текст ошибки
+
+ procedure SynAutoriz; // передача значения авторизации в главную форму как положено в потоке
+ procedure SynErrAutoriz; // передача значения ошибки в главную форму как положено в потоке
+ protected
+ { protected declarations }
+ public
+ { public declarations }
+ constructor Create(CreateSuspennded: BOOLEAN; aParamStr: string);
+ // используем для передачи логина и пароля и подобного
+ procedure Execute; override; // выполняем непосредственно авторизацию на сайте
+ published
+ { published declarations }
+ // события
+ property OnAutorization
+ : TAutorization read FAutorization write FAutorization;
+ // авторизировались
+ property OnError: TErrorAutorization read FErrorAutorization write
+ FErrorAutorization; // возникла ошибка ((
+ end;
+
+ // "шкурка" компонента
+ TGoogleLogin = class(TComponent)
+ private
+ // Поток
+ FThread: TGoogleLoginThread;
+ // регистрационные данные
+ FAppname: string; // строка символов, которая передается серверу и идентифицирует программное обеспечение, пославшее запрос.
+ FAccountType: TAccountType;
+ FLastResult: TLoginResult;
+ FEmail: string;
+ FPassword: string;
+ // данные ответа/запроса
+ FService: TServices; // сервис к которому необходимо получить доступ
+ FLogintoken: string;
+ FLogincaptcha: string;
+ // параметры Captcha
+ FCaptchaURL: string;
+ FAfterLogin: TAutorization;
+ 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;
+ procedure Login(aLoginToken: string = ''; aLoginCaptcha: string = '');
+ // формируем запрос
+ procedure Disconnect; // удаляет все данные по авторизации
+ property LastResult: TLoginResult read FLastResult;
+ // property Auth: string read FAuth;
+ // property SID: string read FSID;
+ // property LSID: string read FLSID;
+ // property CaptchaURL: string read FCaptchaURL;
+ // property LoginToken: string read FLogintoken;
+ // property LoginCaptcha: string read FLogincaptcha write FLogincaptcha;
+ published
+ property AppName: string read FAppname write SetAppName;
+ property AccountType: TAccountType read FAccountType write FAccountType;
+ property Email: string read FEmail write SetEmail;
+ property Password: string read FPassword write SetPassword;
+ property Service: TServices read FService write SetService default xapi;
+ property OnAutorization: TAutorization read FAfterLogin write FAfterLogin;
+ property OnError: TErrorAutorization read FErrorAutorization write
+ FErrorAutorization; // возникла ошибка ((
+ property OnDisconnect: TDisconnect read FDisconnect write FDisconnect;
+ end;
+
+procedure Register;
+
+implementation
+
+procedure Register;
+begin
+ RegisterComponents('WebDelphi.ru', [TGoogleLogin]);
+end;
+
+{ TGoogleLogin }
+
+function TGoogleLogin.DigitToHex(Digit: Integer): Char;
+begin
+ case Digit of
+ 0 .. 9:
+ Result := Chr(Digit + Ord('0'));
+ 10 .. 15:
+ Result := Chr(Digit - 10 + Ord('A'));
+ else
+ Result := '0';
+ end;
+end;
+
+procedure TGoogleLogin.Disconnect;
+begin
+ FAccountType := atNone;
+ FLastResult := lrNone;
+ // FSID:='';
+ // FLSID:='';
+ // FAuth:='';
+ FLogintoken := '';
+ FLogincaptcha := '';
+ FCaptchaURL := '';
+ FLogintoken := '';
+ if Assigned(FThread) then
+ FThread.Terminate;
+ if Assigned(FDisconnect) then
+ OnDisconnect(rcDisconnect)
+end;
+
+constructor TGoogleLogin.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FAppname := DefaultAppName; // дефолтное значение
+end;
+
+procedure TGoogleLogin.Login(aLoginToken, aLoginCaptcha: string);
+var
+ cBody: TStringStream;
+ ResponseText: string;
+begin
+ cBody := TStringStream.Create('');
+ case FAccountType of
+ atNone, atHOSTED_OR_GOOGLE:
+ cBody.WriteString('accountType=HOSTED_OR_GOOGLE&');
+ atGOOGLE:
+ cBody.WriteString('accountType=GOOGLE&');
+ atHOSTED:
+ cBody.WriteString('accountType=HOSTED&');
+ end;
+ cBody.WriteString('Email=' + FEmail + '&');
+ cBody.WriteString('Passwd=' + URLEncode(FPassword) + '&');
+ cBody.WriteString('service=' + GetEnumName(TypeInfo(TServices),
+ Ord(FService)) + '&');
+ //ResponseText := GetEnumName(TypeInfo(TServices), Integer(FService));
+
+ if Length(Trim(FAppname)) > 0 then
+ cBody.WriteString('source=' + FAppname)
+ else
+ cBody.WriteString('source=' + DefaultAppName);
+ if Length(Trim(aLoginToken)) > 0 then
+ begin
+ cBody.WriteString('&logintoken=' + aLoginToken);
+ cBody.WriteString('&logincaptcha=' + aLoginCaptcha);
+ end;
+ // отправляем запрос на сервер
+ ResponseText := SendRequest(cBody.DataString);
+end;
+
+function TGoogleLogin.SendRequest(const ParamStr: string): AnsiString;
+begin
+ // отправляем запрос на сервер в отдельном потоке
+ FThread := TGoogleLoginThread.Create(true, ParamStr);
+ FThread.OnAutorization := Self.OnAutorization;
+ FThread.OnError := Self.OnError;
+ FThread.FreeOnTerminate := true; // чтобы сам себя грухнул после окончания операции
+ FThread.Resume; // запуск
+ // тут делать смысла что то нет так как данные еще не получены(они ведь будут получены в другом потоке)
+end;
+
+// устанавливаем значение строки символов, которая передается серверу
+// идентифицирует программное обеспечение, пославшее запрос.
+procedure TGoogleLogin.SetAppName(value: string);
+begin
+ if not(value = '') then
+ FAppname := value
+ else
+ FAppname := DefaultAppName;
+end;
+
+procedure TGoogleLogin.SetCaptcha(cCaptcha: string);
+begin
+ FLogincaptcha := cCaptcha;
+ Login(FLogintoken, FLogincaptcha); // перелогиниваемся с каптчей
+end;
+
+procedure TGoogleLogin.SetEmail(cEmail: string);
+begin
+ FEmail := cEmail;
+ if FLastResult = lrOk then
+ Disconnect; // обнуляем результаты
+end;
+
+procedure TGoogleLogin.SetPassword(cPassword: string);
+begin
+ FPassword := cPassword;
+ if FLastResult = lrOk then
+ Disconnect; // обнуляем результаты
+end;
+
+procedure TGoogleLogin.SetService(cService: TServices);
+begin
+ FService := cService;
+ if FLastResult = lrOk then
+ begin
+ 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;
+begin
+ len := 0;
+ for i := 1 to Length(S) do
+ if ((S[i] >= '0') and (S[i] <= '9')) or ((S[i] >= 'A') and (S[i] <= 'Z'))
+ or ((S[i] >= 'a') and (S[i] <= 'z')) or (S[i] = ' ') or (S[i] = '_') or
+ (S[i] = '*') or (S[i] = '-') or (S[i] = '.') then
+ len := len + 1
+ else
+ len := len + 3;
+ SetLength(Result, len);
+ idx := 1;
+ for i := 1 to Length(S) do
+ if S[i] = ' ' then
+ begin
+ Result[idx] := '+';
+ idx := idx + 1;
+ end
+ else if ((S[i] >= '0') and (S[i] <= '9')) or
+ ((S[i] >= 'A') and (S[i] <= 'Z')) or ((S[i] >= 'a') and (S[i] <= 'z'))
+ or (S[i] = '_') or (S[i] = '*') or (S[i] = '-') or (S[i] = '.') then
+ begin
+ Result[idx] := S[i];
+ idx := idx + 1;
+ end
+ else
+ begin
+ Result[idx] := '%';
+ Result[idx + 1] := DigitToHex(Ord(S[i]) div 16);
+ Result[idx + 2] := DigitToHex(Ord(S[i]) mod 16);
+ idx := idx + 3;
+ end;
+end;
+
+{ TGoogleLoginThread }
+
+constructor TGoogleLoginThread.Create(CreateSuspennded: BOOLEAN;
+ aParamStr: string);
+begin
+ inherited Create(CreateSuspennded);
+ FParamStr := aParamStr;
+ FResultRec.LoginStr := '';
+ FResultRec.SID := '';
+ FResultRec.LSID := '';
+ FResultRec.Auth := '';
+end;
+
+procedure TGoogleLoginThread.Execute;
+ function DataAvailable(hRequest: pointer; out Size: cardinal): BOOLEAN;
+ begin
+ Result := WinInet.InternetQueryDataAvailable(hRequest, Size, 0, 0);
+ end;
+
+var
+ hInternet, hConnect, hRequest: pointer;
+ dwBytesRead, i, L: cardinal;
+ 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); // Получаем кол-во принимаемых данных
+ if L = 0 then
+ break;
+ SetLength(sTemp, L + i);
+ if not InternetReadFile(hRequest, @sTemp[i], sizeof(L),
+ dwBytesRead) then
+ break; // Получаем данные с сервера
+ inc(i, dwBytesRead);
+ if Terminated then // проверка для экстренного закрытия потока
+ begin
+ InternetCloseHandle(hRequest);
+ InternetCloseHandle(hConnect);
+ InternetCloseHandle(hInternet);
+ Exit;
+ end;
+ until dwBytesRead = 0;
+ sTemp[i] := #0;
+ end;
+ end;
+ end;
+ end;
+ except
+ Synchronize(SynErrAutoriz);
+ Exit; // сваливаем отсюда
+ end;
+ InternetCloseHandle(hRequest);
+ InternetCloseHandle(hConnect);
+ InternetCloseHandle(hInternet);
+ // получаем результаты авторизации
+ FLastResult := ExpertLoginResult(sTemp);
+ FResultRec.LoginStr := GetResultText;
+ Synchronize(SynAutoriz);
+end;
+
+function TGoogleLoginThread.ExpertLoginResult(const LoginResult: string)
+ : TLoginResult;
+var
+ List: TStringList;
+ i: Integer;
+begin
+ // грузим ответ сервера в список
+ List := TStringList.Create;
+ List.Text := LoginResult;
+ // анализируем построчно
+ 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 // строка с ошибкой
+ begin
+ Result := GetLoginError(List[i]); // получили тип ошибки
+ break;
+ end;
+ end;
+ if Result = lrCaptchaRequired then // требуется ввод каптчи
+ begin
+ FCaptchaURL := GetCaptchaURL(List);
+ FLogintoken := GetCaptchaToken(List);
+ end;
+ end
+ else
+ begin
+ Result := lrOk;
+ for i := 0 to List.Count - 1 do
+ begin
+ if pos('SID', uppercase(List[i])) > 0 then
+ FResultRec.SID := Trim(copy(List[i], pos('=', List[i]) + 1,
+ Length(List[i]) - pos('=', List[i])))
+ else if pos('LSID', uppercase(List[i])) > 0 then
+ FResultRec.LSID := Trim(copy(List[i], pos('=', List[i]) + 1,
+ Length(List[i]) - pos('=', List[i])))
+ else if pos('AUTH', uppercase(List[i])) > 0 then
+ FResultRec.Auth := Trim(copy(List[i], pos('=', List[i]) + 1,
+ Length(List[i]) - pos('=', List[i])));
+ end;
+ end;
+ FreeAndNil(List);
+end;
+
+function TGoogleLoginThread.GetCaptchaToken(const cList: TStringList): String;
+var
+ i: Integer;
+begin
+ for i := 0 to cList.Count - 1 do
+ begin
+ if pos('captchatoken', LowerCase(cList[i])) > 0 then
+ begin
+ Result := Trim(copy(cList[i], pos('=', cList[i]) + 1,
+ Length(cList[i]) - pos('=', cList[i])));
+ break;
+ end;
+ end;
+end;
+
+function TGoogleLoginThread.GetCaptchaURL(const cList: TStringList): string;
+var
+ i: Integer;
+begin
+ for i := 0 to cList.Count - 1 do
+ begin
+ if pos('captchaurl', LowerCase(cList[i])) > 0 then
+ begin
+ Result := Trim(copy(cList[i], pos('=', cList[i]) + 1,
+ Length(cList[i]) - pos('=', cList[i])));
+ break;
+ end;
+ end;
+end;
+
+// Если параметр FromServer TRUE, то код ошибки и её текст берется с сервера, в противном случае берется текст локальной ошибки.
+function TGoogleLoginThread.GetErrorText(const FromServer: BOOLEAN): string;
+var
+ Msg: array [0 .. 1023] of Char;
+ ErCode, len: cardinal;
+begin
+ len := sizeof(Msg);
+ ZeroMemory(@Msg, sizeof(Msg));
+ if FromServer then
+ if InternetGetLastResponseInfo(ErCode, @Msg, len) then
+ Result := rcErrServer + IntToStr(ErCode) + #13 + StrPas(Msg)
+ else
+ Result := rcErrDont
+ else if FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, GetLastError,
+ GetKeyboardLayout(0), @Msg, sizeof(Msg), nil) <> 0 then
+ Result := StrPas(Msg)
+ else
+ Result := rcErrDont;
+end;
+
+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);
+end;
+
+function TGoogleLoginThread.GetResultText: string;
+begin
+ case FLastResult of
+ lrNone:
+ Result := rcNone;
+ lrOk:
+ Result := rcOk;
+ lrBadAuthentication:
+ Result := rcBadAuthentication;
+ lrNotVerified:
+ Result := rcNotVerified;
+ lrTermsNotAgreed:
+ Result := rcTermsNotAgreed;
+ lrCaptchaRequired:
+ Result := rcCaptchaRequired;
+ lrUnknown:
+ Result := rcUnknown;
+ lrAccountDeleted:
+ Result := rcAccountDeleted;
+ lrAccountDisabled:
+ Result := rcAccountDisabled;
+ lrServiceDisabled:
+ Result := rcServiceDisabled;
+ lrServiceUnavailable:
+ Result := rcServiceUnavailable;
+ end;
+end;
+
+procedure TGoogleLoginThread.SynAutoriz;
+begin
+ if Assigned(FAutorization) then
+ OnAutorization(FLastResult, FResultRec);
+end;
+
+procedure TGoogleLoginThread.SynErrAutoriz;
+begin
+ if Assigned(FErrorAutorization) then
+ OnError(GetErrorText(true)); // получаем текст ошибки
+end;
+
+end.
+
=======
unit GoogleLogin;
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/languages/English/GStrings.rc b/source/languages/English/GStrings.rc
index 88fbd22..ad16cc8 100644
--- a/source/languages/English/GStrings.rc
+++ b/source/languages/English/GStrings.rc
@@ -1,76 +1,76 @@
-#include "uLanguage.pas"
-LANGUAGE LANG_ENGLISH, 2
-STRINGTABLE
-{
- c_ErrPrepareNode, "Error in prepare node %s"
- c_ErrCompNodes, " %s"
- c_ErrWriteNode, " %s"
- c_ErrReadNode, " %s"
- c_ErrMissValue, " %s"
- c_ErrMissAgrument, " "
- c_UnUsedTag, " "
- c_DuplicateLink, " "
- c_WrongAttr, " %s"
- c_RightAttrValues, " : %s"
- c_ErrCGroupCreate," XML-. "
- c_ErrNullAuth, " Auth "
- c_ErrFileName, " %s "
-
- c_Work, ""
- c_Home, ""
- c_FreeBusy, "-"
-
- c_AccId, " "
- c_AccCostumer, " "
- c_AccNetwork, " "
- c_AccOrg, " "
-
- c_EvntAnniv, ""
- c_EvntOther, ""
-
- c_Male, ""
- c_Female, ""
-
- c_JotHome, ""
- c_JotWork, " "
- c_JotOther, ""
- c_JotKeywords, " "
- c_JotUser, ""
-
- c_PriorityLow, ""
- c_PriorityNormal, ""
- c_PriorityHigh, ""
-
- c_RelationAssistant, ""
- c_RelationBrother, ""
- c_RelationChild, ""
- c_RelationDomestPart, ""
- c_RelationFather, ""
- c_RelationFriend, ""
- c_RelationManager, ""
- c_RelationMother, ""
- c_RelationPartner, ""
- c_RelationParent, ""
- c_RelationReffered, ""
- c_RelationRelative, ""
- c_RelationSister, ""
- c_RelationSpouse, ""
-
- c_SensitivConf, ""
- c_SensitivNormal, ""
- c_SensitivPersonal, ""
- c_SensitivPrivate, ""
-
- c_SysGroupContacts, ""
- c_SysGroupFriends, ""
- c_SysGroupFamily, ""
- c_SysGroupCoworkers, ""
-
- c_WebsiteHomePage, " "
- c_WebsiteBlog, ""
- c_WebsiteProfile, ""
- c_WebsiteHome, " "
- c_WebsiteWork, " "
- c_WebsiteOther, ""
- c_WebsiteFtp, "FTP-"
+#include "uLanguage.pas"
+LANGUAGE LANG_ENGLISH, 2
+STRINGTABLE
+{
+ c_ErrPrepareNode, "Error in prepare node %s"
+ c_ErrCompNodes, " %s"
+ c_ErrWriteNode, " %s"
+ c_ErrReadNode, " %s"
+ c_ErrMissValue, " %s"
+ c_ErrMissAgrument, " "
+ c_UnUsedTag, " "
+ c_DuplicateLink, " "
+ c_WrongAttr, " %s"
+ c_RightAttrValues, " : %s"
+ c_ErrCGroupCreate," XML-. "
+ c_ErrNullAuth, " Auth "
+ c_ErrFileName, " %s "
+
+ c_Work, ""
+ c_Home, ""
+ c_FreeBusy, "-"
+
+ c_AccId, " "
+ c_AccCostumer, " "
+ c_AccNetwork, " "
+ c_AccOrg, " "
+
+ c_EvntAnniv, ""
+ c_EvntOther, ""
+
+ c_Male, ""
+ c_Female, ""
+
+ c_JotHome, ""
+ c_JotWork, " "
+ c_JotOther, ""
+ c_JotKeywords, " "
+ c_JotUser, ""
+
+ c_PriorityLow, ""
+ c_PriorityNormal, ""
+ c_PriorityHigh, ""
+
+ c_RelationAssistant, ""
+ c_RelationBrother, ""
+ c_RelationChild, ""
+ c_RelationDomestPart, ""
+ c_RelationFather, ""
+ c_RelationFriend, ""
+ c_RelationManager, ""
+ c_RelationMother, ""
+ c_RelationPartner, ""
+ c_RelationParent, ""
+ c_RelationReffered, ""
+ c_RelationRelative, ""
+ c_RelationSister, ""
+ c_RelationSpouse, ""
+
+ c_SensitivConf, ""
+ c_SensitivNormal, ""
+ c_SensitivPersonal, ""
+ c_SensitivPrivate, ""
+
+ c_SysGroupContacts, ""
+ c_SysGroupFriends, ""
+ c_SysGroupFamily, ""
+ c_SysGroupCoworkers, ""
+
+ c_WebsiteHomePage, " "
+ c_WebsiteBlog, ""
+ c_WebsiteProfile, ""
+ c_WebsiteHome, " "
+ c_WebsiteWork, " "
+ c_WebsiteOther, ""
+ c_WebsiteFtp, "FTP-"
}
\ No newline at end of file
diff --git a/source/languages/Russian/GStrings.rc b/source/languages/Russian/GStrings.rc
index bcd8e3d..8221fee 100644
--- a/source/languages/Russian/GStrings.rc
+++ b/source/languages/Russian/GStrings.rc
@@ -1,129 +1,129 @@
-#include "uLanguage.pas"
-LANGUAGE LANG_RUSSIAN,1
-STRINGTABLE
-{
- c_ErrPrepareNode, " %s"
- c_ErrCompNodes, " %s"
- c_ErrWriteNode, " %s"
- c_ErrReadNode, " %s"
- c_ErrMissValue, " %s"
- c_ErrMissAgrument, " "
- c_UnUsedTag, " "
- c_DuplicateLink, " "
- c_WrongAttr, " %s"
- c_RightAttrValues, " : %s"
- c_ErrCGroupCreate," XML-. "
- c_ErrNullAuth, " Auth "
- c_ErrFileName, " %s "
- c_ErrSysGroup, " "
- c_ErrGroupLink, " URL . ."
-
- c_Work, ""
- c_Home, ""
- c_FreeBusy, "-"
-
- c_AccId, " "
- c_AccCostumer, " "
- c_AccNetwork, " "
- c_AccOrg, " "
-
- c_EvntAnniv, ""
- c_EvntOther, ""
-
- c_Male, ""
- c_Female, ""
-
- c_JotHome, ""
- c_JotWork, " "
- c_JotOther, ""
- c_JotKeywords, " "
- c_JotUser, ""
-
- c_PriorityLow, ""
- c_PriorityNormal, ""
- c_PriorityHigh, ""
-
- c_RelationAssistant, ""
- c_RelationBrother, ""
- c_RelationChild, ""
- c_RelationDomestPart, ""
- c_RelationFather, ""
- c_RelationFriend, ""
- c_RelationManager, ""
- c_RelationMother, ""
- c_RelationPartner, ""
- c_RelationParent, ""
- c_RelationReffered, ""
- c_RelationRelative, ""
- c_RelationSister, ""
- c_RelationSpouse, ""
-
- c_SensitivConf, ""
- c_SensitivNormal, ""
- c_SensitivPersonal, ""
- c_SensitivPrivate, ""
-
- c_SysGroupContacts, ""
- c_SysGroupFriends, ""
- c_SysGroupFamily, ""
- c_SysGroupCoworkers, ""
-
- c_WebsiteHomePage, " "
- c_WebsiteBlog, ""
- c_WebsiteProfile, ""
- c_WebsiteHome, " "
- c_WebsiteWork, " "
- c_WebsiteOther, ""
- c_WebsiteFtp, "FTP-"
-
- c_EventCancel, ""
- c_EventConfirm, ""
- c_EventTentative, " "
-
- c_EventConfident, ""
- c_EventDefault, " "
- c_EventPrivate, ""
- c_EventPublic, ""
-
- c_EventOpaque, " "
- c_EventTransp, " "
-
- c_EventOptional, ""
- c_EventRequired, ""
-
- c_EventAccepted, ""
- c_EventDeclined, ""
- c_EventInvited, ""
- c_EventTentativ, " "
-
- c_EmailHome, ""
- c_EmailOther, ""
- c_EmailWork, ""
-
- c_ImHome, ""
- c_ImNetMeeting, "NetMeeting"
- c_ImOther, ""
- c_ImWork, ""
-
- c_PhoneAssistant,""
- c_PhoneCallback,""
- c_PhoneCar,""
- c_PhoneCompanymain," "
- c_PhoneFax,""
- c_PhoneHome,""
- c_PhoneHomefax," "
- c_PhoneIsdn,"ISDN"
- c_PhoneMain,""
- c_PhoneMobile,""
- c_PhoneOther,""
- c_PhoneOtherfax," ()"
- c_PhonePager,""
- c_PhoneRadio,""
- c_PhoneTelex,""
- c_PhoneTtytdd,"IP-"
- c_PhoneWork,""
- c_PhoneWorkfax," "
- c_PhoneWorkmobile," "
- c_PhoneWorkpager," "
-
+#include "uLanguage.pas"
+LANGUAGE LANG_RUSSIAN,1
+STRINGTABLE
+{
+ c_ErrPrepareNode, " %s"
+ c_ErrCompNodes, " %s"
+ c_ErrWriteNode, " %s"
+ c_ErrReadNode, " %s"
+ c_ErrMissValue, " %s"
+ c_ErrMissAgrument, " "
+ c_UnUsedTag, " "
+ c_DuplicateLink, " "
+ c_WrongAttr, " %s"
+ c_RightAttrValues, " : %s"
+ c_ErrCGroupCreate," XML-. "
+ c_ErrNullAuth, " Auth "
+ c_ErrFileName, " %s "
+ c_ErrSysGroup, " "
+ c_ErrGroupLink, " URL . ."
+
+ c_Work, ""
+ c_Home, ""
+ c_FreeBusy, "-"
+
+ c_AccId, " "
+ c_AccCostumer, " "
+ c_AccNetwork, " "
+ c_AccOrg, " "
+
+ c_EvntAnniv, ""
+ c_EvntOther, ""
+
+ c_Male, ""
+ c_Female, ""
+
+ c_JotHome, ""
+ c_JotWork, " "
+ c_JotOther, ""
+ c_JotKeywords, " "
+ c_JotUser, ""
+
+ c_PriorityLow, ""
+ c_PriorityNormal, ""
+ c_PriorityHigh, ""
+
+ c_RelationAssistant, ""
+ c_RelationBrother, ""
+ c_RelationChild, ""
+ c_RelationDomestPart, ""
+ c_RelationFather, ""
+ c_RelationFriend, ""
+ c_RelationManager, ""
+ c_RelationMother, ""
+ c_RelationPartner, ""
+ c_RelationParent, ""
+ c_RelationReffered, ""
+ c_RelationRelative, ""
+ c_RelationSister, ""
+ c_RelationSpouse, ""
+
+ c_SensitivConf, ""
+ c_SensitivNormal, ""
+ c_SensitivPersonal, ""
+ c_SensitivPrivate, ""
+
+ c_SysGroupContacts, ""
+ c_SysGroupFriends, ""
+ c_SysGroupFamily, ""
+ c_SysGroupCoworkers, ""
+
+ c_WebsiteHomePage, " "
+ c_WebsiteBlog, ""
+ c_WebsiteProfile, ""
+ c_WebsiteHome, " "
+ c_WebsiteWork, " "
+ c_WebsiteOther, ""
+ c_WebsiteFtp, "FTP-"
+
+ c_EventCancel, ""
+ c_EventConfirm, ""
+ c_EventTentative, " "
+
+ c_EventConfident, ""
+ c_EventDefault, " "
+ c_EventPrivate, ""
+ c_EventPublic, ""
+
+ c_EventOpaque, " "
+ c_EventTransp, " "
+
+ c_EventOptional, ""
+ c_EventRequired, ""
+
+ c_EventAccepted, ""
+ c_EventDeclined, ""
+ c_EventInvited, ""
+ c_EventTentativ, " "
+
+ c_EmailHome, ""
+ c_EmailOther, ""
+ c_EmailWork, ""
+
+ c_ImHome, ""
+ c_ImNetMeeting, "NetMeeting"
+ c_ImOther, ""
+ c_ImWork, ""
+
+ c_PhoneAssistant,""
+ c_PhoneCallback,""
+ c_PhoneCar,""
+ c_PhoneCompanymain," "
+ c_PhoneFax,""
+ c_PhoneHome,""
+ c_PhoneHomefax," "
+ c_PhoneIsdn,"ISDN"
+ c_PhoneMain,""
+ c_PhoneMobile,""
+ c_PhoneOther,""
+ c_PhoneOtherfax," ()"
+ c_PhonePager,""
+ c_PhoneRadio,""
+ c_PhoneTelex,""
+ c_PhoneTtytdd,"IP-"
+ c_PhoneWork,""
+ c_PhoneWorkfax," "
+ c_PhoneWorkmobile," "
+ c_PhoneWorkpager," "
+
}
\ No newline at end of file
diff --git a/source/uLanguage.pas b/source/uLanguage.pas
index 5ec9de0..c4ad5bd 100644
--- a/source/uLanguage.pas
+++ b/source/uLanguage.pas
@@ -1,183 +1,138 @@
-<<<<<<< HEAD
unit uLanguage;
-=======
-unit uLanguage;
-
->>>>>>> remotes/origin/master
-interface
-
-const
- GStringsMaxId = 58000;
- //Dialogs
- c_ErrPrepareNode = GStringsMaxId - 1;
- c_ErrCompNodes = GStringsMaxId - 2;
- c_ErrWriteNode = GStringsMaxId - 3;
- c_ErrReadNode = GStringsMaxId - 5;
- c_ErrMissValue = GStringsMaxId - 6;
- c_ErrMissAgrument = GStringsMaxId - 7;
- c_UnUsedTag = GStringsMaxId - 8;
- c_DuplicateLink = GStringsMaxId - 9;
- c_WrongAttr = GStringsMaxId - 10;
- c_RightAttrValues = GStringsMaxId - 11;
- c_ErrCGroupCreate = GStringsMaxId - 12;
- c_ErrNullAuth = GStringsMaxId - 13;
- c_ErrFileName = GStringsMaxId - 14;
- c_ErrFileNull = GStringsMaxId - 15;
- c_ErrSysGroup = GStringsMaxId - 106;
- c_ErrGroupLink = GStringsMaxId - 107;
-{Variables}
-//gContact:calendarLink rel values
- c_Work = GStringsMaxId - 16;
- c_Home = GStringsMaxId - 17;
- c_FreeBusy = GStringsMaxId - 18;
-//gContact:externalId rel values
- c_AccId = GStringsMaxId - 19;
- c_AccCostumer = GStringsMaxId - 20;
- c_AccNetwork = GStringsMaxId - 21;
- c_AccOrg = GStringsMaxId - 22;
-//gContact:event rel values
- c_EvntAnniv = GStringsMaxId - 23;
- c_EvntOther = GStringsMaxId - 24;
-//gContact:gender values
- c_Male = GStringsMaxId - 25;
- c_Female = GStringsMaxId - 26;
-//gContact:Jot rel values
- c_JotHome = GStringsMaxId - 27;
- c_JotWork = GStringsMaxId - 28;
- c_JotOther = GStringsMaxId - 29;
- c_JotKeywords = GStringsMaxId - 30;
- c_JotUser = GStringsMaxId - 31;
-//gContact:Priority rel values
- c_PriorityLow = GStringsMaxId - 32;
- c_PriorityNormal = GStringsMaxId - 33;
- c_PriorityHigh = GStringsMaxId - 34;
-//gContact:Relation rel values
- c_RelationAssistant = GStringsMaxId - 35;
- c_RelationBrother = GStringsMaxId - 36;
- c_RelationChild = GStringsMaxId - 37;
- c_RelationDomestPart = GStringsMaxId - 38;
- c_RelationFather = GStringsMaxId - 39;
- c_RelationFriend = GStringsMaxId - 40;
- c_RelationManager = GStringsMaxId - 41;
- c_RelationMother = GStringsMaxId - 42;
- c_RelationParent = GStringsMaxId - 43;
- c_RelationPartner = GStringsMaxId - 44;
- c_RelationReffered = GStringsMaxId - 45;
- c_RelationRelative = GStringsMaxId - 46;
- c_RelationSister = GStringsMaxId - 47;
- c_RelationSpouse = GStringsMaxId - 48;
-//gContact:sensitivity rel values
- c_SensitivConf = GStringsMaxId - 49;
- c_SensitivNormal = GStringsMaxId - 50;
- c_SensitivPersonal = GStringsMaxId - 51;
- c_SensitivPrivate = GStringsMaxId - 52;
-//gContact: SystemGroup rel values
- c_SysGroupContacts = GStringsMaxId - 53;
- c_SysGroupFriends= GStringsMaxId - 54;
- c_SysGroupFamily= GStringsMaxId - 55;
- c_SysGroupCoworkers = GStringsMaxId - 56;
-//gContact: WebSite rel values
- c_WebsiteHomePage = GStringsMaxId - 57;
- c_WebsiteBlog = GStringsMaxId - 58;
- c_WebsiteProfile = GStringsMaxId - 59;
- c_WebsiteHome = GStringsMaxId - 60;
- c_WebsiteWork = GStringsMaxId - 61;
- c_WebsiteOther = GStringsMaxId - 62;
- c_WebsiteFtp = GStringsMaxId - 63;
-//gd:eventStatus values
- c_EventCancel = GStringsMaxId - 64;
- c_EventConfirm = GStringsMaxId - 65;
- c_EventTentative = GStringsMaxId - 66;
-//gd:visibility values
- c_EventConfident = GStringsMaxId - 67;
- c_EventDefault = GStringsMaxId - 68;
- c_EventPrivate = GStringsMaxId - 69;
- c_EventPublic = GStringsMaxId - 70;
-//gd:transparency values
- c_EventOpaque = GStringsMaxId - 71;
- c_EventTransp = GStringsMaxId - 72;
-//gd:attendeeType Values
- c_EventOptional = GStringsMaxId - 73;
- c_EventRequired = GStringsMaxId - 74;
-//gd:attendeeStatus Values
- c_EventAccepted = GStringsMaxId - 75;
- c_EventDeclined = GStringsMaxId - 76;
- c_EventInvited = GStringsMaxId - 77;
- c_EventTentativ = GStringsMaxId - 78;
-//gd:email rel values
- c_EmailHome = GStringsMaxId - 79;
- c_EmailOther = GStringsMaxId - 80;
- c_EmailWork = GStringsMaxId - 81;
-//gd:im rel values
- c_ImHome = GStringsMaxId - 82;
- c_ImNetMeeting = GStringsMaxId - 83;
- c_ImOther = GStringsMaxId - 84;
- c_ImWork = GStringsMaxId - 85;
-//gd:phoneNumber rel values
- c_PhoneAssistant = GStringsMaxId - 86;
- c_PhoneCallback = GStringsMaxId - 87;
- c_PhoneCar = GStringsMaxId - 88;
- c_PhoneCompanymain = GStringsMaxId - 89;
- c_PhoneFax = GStringsMaxId - 90;
- c_PhoneHome = GStringsMaxId - 91;
- c_PhoneHomefax = GStringsMaxId - 92;
- c_PhoneIsdn = GStringsMaxId - 93;
- c_PhoneMain = GStringsMaxId - 94;
- c_PhoneMobile = GStringsMaxId - 95;
- c_PhoneOther = GStringsMaxId - 96;
- c_PhoneOtherfax = GStringsMaxId - 97;
- c_PhonePager = GStringsMaxId - 98;
- c_PhoneRadio = GStringsMaxId - 99;
- c_PhoneTelex = GStringsMaxId - 100;
- c_PhoneTtytdd = GStringsMaxId - 101;
- c_PhoneWork = GStringsMaxId - 102;
- c_PhoneWorkfax = GStringsMaxId - 103;
- c_PhoneWorkmobile = GStringsMaxId - 104;
- c_PhoneWorkpager = GStringsMaxId - 105;
-
-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}
+const
+ GStringsMaxId = 58000;
+ //Dialogs
+ c_ErrPrepareNode = GStringsMaxId - 1;
+ c_ErrCompNodes = GStringsMaxId - 2;
+ c_ErrWriteNode = GStringsMaxId - 3;
+ c_ErrReadNode = GStringsMaxId - 5;
+ c_ErrMissValue = GStringsMaxId - 6;
+ c_ErrMissAgrument = GStringsMaxId - 7;
+ c_UnUsedTag = GStringsMaxId - 8;
+ c_DuplicateLink = GStringsMaxId - 9;
+ c_WrongAttr = GStringsMaxId - 10;
+ c_RightAttrValues = GStringsMaxId - 11;
+ c_ErrCGroupCreate = GStringsMaxId - 12;
+ c_ErrNullAuth = GStringsMaxId - 13;
+ c_ErrFileName = GStringsMaxId - 14;
+ c_ErrFileNull = GStringsMaxId - 15;
+ c_ErrSysGroup = GStringsMaxId - 106;
+ c_ErrGroupLink = GStringsMaxId - 107;
+{Variables}
+//gContact:calendarLink rel values
+ c_Work = GStringsMaxId - 16;
+ c_Home = GStringsMaxId - 17;
+ c_FreeBusy = GStringsMaxId - 18;
+//gContact:externalId rel values
+ c_AccId = GStringsMaxId - 19;
+ c_AccCostumer = GStringsMaxId - 20;
+ c_AccNetwork = GStringsMaxId - 21;
+ c_AccOrg = GStringsMaxId - 22;
+//gContact:event rel values
+ c_EvntAnniv = GStringsMaxId - 23;
+ c_EvntOther = GStringsMaxId - 24;
+//gContact:gender values
+ c_Male = GStringsMaxId - 25;
+ c_Female = GStringsMaxId - 26;
+//gContact:Jot rel values
+ c_JotHome = GStringsMaxId - 27;
+ c_JotWork = GStringsMaxId - 28;
+ c_JotOther = GStringsMaxId - 29;
+ c_JotKeywords = GStringsMaxId - 30;
+ c_JotUser = GStringsMaxId - 31;
+//gContact:Priority rel values
+ c_PriorityLow = GStringsMaxId - 32;
+ c_PriorityNormal = GStringsMaxId - 33;
+ c_PriorityHigh = GStringsMaxId - 34;
+//gContact:Relation rel values
+ c_RelationAssistant = GStringsMaxId - 35;
+ c_RelationBrother = GStringsMaxId - 36;
+ c_RelationChild = GStringsMaxId - 37;
+ c_RelationDomestPart = GStringsMaxId - 38;
+ c_RelationFather = GStringsMaxId - 39;
+ c_RelationFriend = GStringsMaxId - 40;
+ c_RelationManager = GStringsMaxId - 41;
+ c_RelationMother = GStringsMaxId - 42;
+ c_RelationParent = GStringsMaxId - 43;
+ c_RelationPartner = GStringsMaxId - 44;
+ c_RelationReffered = GStringsMaxId - 45;
+ c_RelationRelative = GStringsMaxId - 46;
+ c_RelationSister = GStringsMaxId - 47;
+ c_RelationSpouse = GStringsMaxId - 48;
+//gContact:sensitivity rel values
+ c_SensitivConf = GStringsMaxId - 49;
+ c_SensitivNormal = GStringsMaxId - 50;
+ c_SensitivPersonal = GStringsMaxId - 51;
+ c_SensitivPrivate = GStringsMaxId - 52;
+//gContact: SystemGroup rel values
+ c_SysGroupContacts = GStringsMaxId - 53;
+ c_SysGroupFriends= GStringsMaxId - 54;
+ c_SysGroupFamily= GStringsMaxId - 55;
+ c_SysGroupCoworkers = GStringsMaxId - 56;
+//gContact: WebSite rel values
+ c_WebsiteHomePage = GStringsMaxId - 57;
+ c_WebsiteBlog = GStringsMaxId - 58;
+ c_WebsiteProfile = GStringsMaxId - 59;
+ c_WebsiteHome = GStringsMaxId - 60;
+ c_WebsiteWork = GStringsMaxId - 61;
+ c_WebsiteOther = GStringsMaxId - 62;
+ c_WebsiteFtp = GStringsMaxId - 63;
+//gd:eventStatus values
+ c_EventCancel = GStringsMaxId - 64;
+ c_EventConfirm = GStringsMaxId - 65;
+ c_EventTentative = GStringsMaxId - 66;
+//gd:visibility values
+ c_EventConfident = GStringsMaxId - 67;
+ c_EventDefault = GStringsMaxId - 68;
+ c_EventPrivate = GStringsMaxId - 69;
+ c_EventPublic = GStringsMaxId - 70;
+//gd:transparency values
+ c_EventOpaque = GStringsMaxId - 71;
+ c_EventTransp = GStringsMaxId - 72;
+//gd:attendeeType Values
+ c_EventOptional = GStringsMaxId - 73;
+ c_EventRequired = GStringsMaxId - 74;
+//gd:attendeeStatus Values
+ c_EventAccepted = GStringsMaxId - 75;
+ c_EventDeclined = GStringsMaxId - 76;
+ c_EventInvited = GStringsMaxId - 77;
+ c_EventTentativ = GStringsMaxId - 78;
+//gd:email rel values
+ c_EmailHome = GStringsMaxId - 79;
+ c_EmailOther = GStringsMaxId - 80;
+ c_EmailWork = GStringsMaxId - 81;
+//gd:im rel values
+ c_ImHome = GStringsMaxId - 82;
+ c_ImNetMeeting = GStringsMaxId - 83;
+ c_ImOther = GStringsMaxId - 84;
+ c_ImWork = GStringsMaxId - 85;
+//gd:phoneNumber rel values
+ c_PhoneAssistant = GStringsMaxId - 86;
+ c_PhoneCallback = GStringsMaxId - 87;
+ c_PhoneCar = GStringsMaxId - 88;
+ c_PhoneCompanymain = GStringsMaxId - 89;
+ c_PhoneFax = GStringsMaxId - 90;
+ c_PhoneHome = GStringsMaxId - 91;
+ c_PhoneHomefax = GStringsMaxId - 92;
+ c_PhoneIsdn = GStringsMaxId - 93;
+ c_PhoneMain = GStringsMaxId - 94;
+ c_PhoneMobile = GStringsMaxId - 95;
+ c_PhoneOther = GStringsMaxId - 96;
+ c_PhoneOtherfax = GStringsMaxId - 97;
+ c_PhonePager = GStringsMaxId - 98;
+ c_PhoneRadio = GStringsMaxId - 99;
+ c_PhoneTelex = GStringsMaxId - 100;
+ c_PhoneTtytdd = GStringsMaxId - 101;
+ c_PhoneWork = GStringsMaxId - 102;
+ c_PhoneWorkfax = GStringsMaxId - 103;
+ c_PhoneWorkmobile = GStringsMaxId - 104;
+ c_PhoneWorkpager = GStringsMaxId - 105;
implementation
-begin
->>>>>>> remotes/origin/Vlad55
-end.
->>>>>>> remotes/origin/NMD
-=======
->>>>>>> remotes/origin/master
+{$R GStrings.res}
+
+end.
\ No newline at end of file