diff --git a/.gitignore b/.gitignore deleted file mode 100644 index 30a9381..0000000 --- a/.gitignore +++ /dev/null @@ -1,7 +0,0 @@ -*.dcu -*.local -*.exe -*.identcache - -*.patch -*.diff \ No newline at end of file diff --git a/demos/gmail_demo/gmail.dpr b/Demo/blogger_api_demo/ExampleBlogApi.dpr similarity index 56% rename from demos/gmail_demo/gmail.dpr rename to Demo/blogger_api_demo/ExampleBlogApi.dpr index d2d71f1..3de5039 100644 --- a/demos/gmail_demo/gmail.dpr +++ b/Demo/blogger_api_demo/ExampleBlogApi.dpr @@ -1,14 +1,14 @@ -program gmail; +program ExampleBlogApi; uses Forms, - Unit2 in 'Unit2.pas' {Form2}; + Unit1 in 'Unit1.pas' {Form1}; {$R *.res} begin Application.Initialize; Application.MainFormOnTaskbar := True; - Application.CreateForm(TForm2, Form2); + Application.CreateForm(TForm1, Form1); Application.Run; end. diff --git a/demos/gmail_demo/gmail.res b/Demo/blogger_api_demo/ExampleBlogApi.res similarity index 99% rename from demos/gmail_demo/gmail.res rename to Demo/blogger_api_demo/ExampleBlogApi.res index fc1937e..4ade570 100644 Binary files a/demos/gmail_demo/gmail.res and b/Demo/blogger_api_demo/ExampleBlogApi.res differ diff --git a/Demo/blogger_api_demo/Unit1.dcu b/Demo/blogger_api_demo/Unit1.dcu new file mode 100644 index 0000000..3f3b30a Binary files /dev/null and b/Demo/blogger_api_demo/Unit1.dcu differ diff --git a/Demo/blogger_api_demo/Unit1.dfm b/Demo/blogger_api_demo/Unit1.dfm new file mode 100644 index 0000000..6ec46c4 --- /dev/null +++ b/Demo/blogger_api_demo/Unit1.dfm @@ -0,0 +1,166 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Form1' + ClientHeight = 455 + ClientWidth = 903 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Image1: TImage + Left = 278 + Top = 287 + Width = 227 + Height = 146 + Stretch = True + end + object Button1: TButton + Left = 8 + Top = 217 + Width = 201 + Height = 25 + Caption = #1055#1086#1083#1091#1095#1077#1085#1080#1077' '#1082#1083#1102#1095#1072 + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 8 + Top = 8 + Width = 825 + Height = 81 + Lines.Strings = ( + 'Memo1') + TabOrder = 1 + WantTabs = True + end + object ComboBox1: TComboBox + Left = 8 + Top = 190 + Width = 145 + Height = 21 + TabOrder = 2 + Text = 'ComboBox1' + OnChange = ComboBox1Change + end + object Button2: TButton + Left = 8 + Top = 244 + Width = 201 + Height = 25 + Caption = #1057#1086#1079#1076#1072#1085#1080#1077' '#1087#1086#1089#1090#1072 + TabOrder = 3 + OnClick = Button2Click + end + object Memo2: TMemo + Left = 8 + Top = 95 + Width = 185 + Height = 89 + Lines.Strings = ( + 'Memo2') + TabOrder = 4 + end + object Memo3: TMemo + Left = 230 + Top = 95 + Width = 618 + Height = 174 + Lines.Strings = ( + '

Memo2

') + TabOrder = 5 + end + object Button3: TButton + Left = 8 + Top = 271 + Width = 201 + Height = 25 + Caption = #1055#1086#1083#1091#1095#1077#1085#1080#1077' '#1087#1086#1089#1090#1072 + TabOrder = 6 + OnClick = Button3Click + end + object Button4: TButton + Left = 8 + Top = 298 + Width = 201 + Height = 25 + Caption = #1055#1086#1083#1091#1095#1077#1085#1080#1077' '#1087#1086#1089#1090#1072' '#1089' '#1087#1072#1088#1072#1084#1077#1090#1088#1072#1084#1080 + TabOrder = 7 + OnClick = Button4Click + end + object Button5: TButton + Left = 8 + Top = 325 + Width = 201 + Height = 25 + Caption = #1054#1073#1085#1086#1074#1083#1077#1085#1080#1077' '#1087#1086#1089#1090#1072 + TabOrder = 8 + OnClick = Button5Click + end + object Edit1: TEdit + Left = 390 + Top = 198 + Width = 185 + Height = 21 + TabOrder = 9 + end + object Button6: TButton + Left = 8 + Top = 353 + Width = 201 + Height = 25 + Caption = #1059#1076#1072#1083#1077#1085#1080#1077' '#1087#1086#1089#1090#1072 + TabOrder = 10 + OnClick = Button6Click + end + object ProgressBar1: TProgressBar + Left = 390 + Top = 108 + Width = 150 + Height = 17 + TabOrder = 11 + end + object Button7: TButton + Left = 8 + Top = 384 + Width = 201 + Height = 25 + Caption = #1055#1086#1083#1091#1095#1077#1085#1080#1077' '#1074#1089#1077#1093' '#1082#1086#1084#1084#1077#1085#1090#1072#1088#1080#1077#1074 + TabOrder = 12 + OnClick = Button7Click + end + object Edit2: TEdit + Left = 390 + Top = 171 + Width = 161 + Height = 21 + TabOrder = 13 + Text = 'Edit2' + end + object Blogger1: TBlogger + AppName = 'MyCompany' + Blogs = <> + OnProgress = Blogger1Progress + OnError = Blogger1Error + Left = 584 + Top = 8 + 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' + AccountType = atGOOGLE + Email = 'nmdsoft@gmail.com' + Service = blogger + OnAutorization = GoogleLogin1Autorization + OnAutorizCaptcha = GoogleLogin1AutorizCaptcha + OnError = GoogleLogin1Error + Left = 584 + Top = 56 + end +end diff --git a/Demo/blogger_api_demo/Unit1.pas b/Demo/blogger_api_demo/Unit1.pas new file mode 100644 index 0000000..e23a9ae --- /dev/null +++ b/Demo/blogger_api_demo/Unit1.pas @@ -0,0 +1,195 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, BloggerApi, uGoogleLogin, ComCtrls, ExtCtrls; + +type + TForm1 = class(TForm) + Blogger1: TBlogger; + Button1: TButton; + Memo1: TMemo; + GoogleLogin1: TGoogleLogin; + ComboBox1: TComboBox; + Button2: TButton; + Memo2: TMemo; + Memo3: TMemo; + Button3: TButton; + Button4: TButton; + Button5: TButton; + Edit1: TEdit; + Button6: TButton; + ProgressBar1: TProgressBar; + Button7: TButton; + Edit2: TEdit; + Image1: TImage; + procedure Button1Click(Sender: TObject); + procedure GoogleLogin1Autorization(const LoginResult: TLoginResult; Result: TResultRec); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + procedure Button5Click(Sender: TObject); + procedure Button6Click(Sender: TObject); + procedure Blogger1Error(E: string); + procedure ComboBox1Change(Sender: TObject); + procedure Blogger1Progress(aCurrentProgress, aMaxProgress: Integer); + procedure Button7Click(Sender: TObject); + procedure GoogleLogin1Error(const ErrorStr: string); + procedure GoogleLogin1AutorizCaptcha(PicCaptcha: TPicture); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Blogger1Error(E: string); +begin + ShowMessage(e); +end; + +procedure TForm1.Blogger1Progress(aCurrentProgress, aMaxProgress: Integer); +begin + ProgressBar1.Max:=aMaxProgress; + ProgressBar1.Position:=aCurrentProgress; +end; + +procedure TForm1.Button1Click(Sender: TObject); +begin + GoogleLogin1.Password:=Edit2.Text; + GoogleLogin1.Login; + if Edit1.Text<>'' then + GoogleLogin1.Captcha:=Edit1.Text; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + a:TStringList; +begin + a:=TStringList.Create; + a.Add('dd'); + Memo1.Lines.Text:= Blogger1.PostCreat(Memo2.Text,Memo3.Text ,a,False); + a.Free; +end; + +procedure TForm1.Button3Click(Sender: TObject); +var + aa:TPostCollection; +begin + aa:=TPostCollection.Create(nil); + aa:=Blogger1.RetrievAllPosts; + if aa.Count<1 then + Exit; + Memo1.Lines.Add( IntToStr( aa.Count)); + Memo1.Lines.Add(aa.Items[0].PostId); + Memo1.Lines.Add(DateToStr(aa.Items[0].PostPublished)); + Memo1.Lines.Add(DateToStr(aa.Items[0].PostUpdate)); + Memo1.Lines.Add(aa.Items[0].PostTitle); + Memo1.Lines.Add(aa.Items[0].PostSourse.Text); + Memo1.Lines.Add(aa.Items[0].СategoryPost.Text); + aa.Free; +end; + +procedure TForm1.Button4Click(Sender: TObject); +var + aa:TPostCollection; +begin + aa:=TPostCollection.Create(nil); + aa:=Blogger1.RetrievPostForParams('Wininet','','','','','',1,2); + if aa.Count<1 then + begin + aa.Free; + Exit; + end; + Memo1.Lines.Add( IntToStr( aa.Count)); + Memo1.Lines.Add(aa.Items[0].PostId); + Memo1.Lines.Add(DateToStr(aa.Items[0].PostPublished)); + Memo1.Lines.Add(DateToStr(aa.Items[0].PostUpdate)); + Memo1.Lines.Add(aa.Items[0].PostTitle); + Memo1.Lines.Add(aa.Items[0].PostSourse.Text); + Memo1.Lines.Add(aa.Items[0].СategoryPost.Text); + aa.Free; +end; + +procedure TForm1.Button5Click(Sender: TObject); +var + a:TStringList; +begin + a:=TStringList.Create; + a.Add('Привет'); + Blogger1.PostModify(Edit1.Text,Memo2.Text,Memo3.Text ,a,False); + a.Free; +end; + +procedure TForm1.Button6Click(Sender: TObject); +begin + Blogger1.PostDelete(Edit1.Text); +end; + +procedure TForm1.Button7Click(Sender: TObject); +var + a:TCommentCollection; + i:Integer; +begin + a:=TCommentCollection.Create(nil); + a:=Blogger1.RetrievAllComments; + if a.Count<=0 then + begin + a.Free; + Exit; + end; + for I := 0 to a.Count - 1 do + begin + Memo3.Lines.Add('Имя автора: '+a.Items[i].CommentAutorName); + Memo3.Lines.Add('URL: '+a.Items[i].CommentAutorURL); + Memo3.Lines.Add('Email: '+a.Items[i].CommentAutorEmail); + Memo3.Lines.Add('ID Комментария: '+a.Items[i].CommentId); + Memo3.Lines.Add('Заголовок комментария: '+a.Items[i].CommentTitle); + Memo3.Lines.Add('Текст комментария: '+a.Items[i].CommentSourse.Text); + Memo3.Lines.Add('Дата публикации: '+DateToStr( a.Items[i].CommentPublished )); + Memo3.Lines.Add('Дата обновления: '+DateToStr( a.Items[i].CommentPublished )); + + end; + a.Free; +end; + +procedure TForm1.ComboBox1Change(Sender: TObject); +begin + Blogger1.CurrentBlog:=ComboBox1.ItemIndex; +end; + +procedure TForm1.GoogleLogin1Autorization(const LoginResult: TLoginResult; Result: TResultRec); +var + i:Integer; +begin + if LoginResult=lrOk then + begin + Blogger1.Auth:=Result.Auth; + Blogger1.RetrievAllBlogs; + if Blogger1.Blogs.Count=0 then + Exit; + Memo1.Lines:=Blogger1.Blogs.Items[1].СategoryBlog; + for I := 0 to Blogger1.Blogs.Count - 1 do + ComboBox1.Items.Add(Blogger1.Blogs.Items[i].Title); + end; +end; + +procedure TForm1.GoogleLogin1AutorizCaptcha(PicCaptcha: TPicture); +begin + Image1.Picture:=PicCaptcha; +end; + +procedure TForm1.GoogleLogin1Error(const ErrorStr: string); +begin + ShowMessage(ErrorStr); +end; + +end. diff --git a/README b/README deleted file mode 100644 index bb124a5..0000000 --- a/README +++ /dev/null @@ -1,10 +0,0 @@ -{*******************************************************} -{ } -{ Delphi & Google API } -{ } -{ Copyright (c) WebDelphi.ru } -{ All Rights Reserved. } -{ } -{ } -{ } -{*******************************************************} \ No newline at end of file diff --git a/addons/nativexml/NativeXml.inc b/addons/nativexml/NativeXml.inc deleted file mode 100644 index 75e257f..0000000 --- a/addons/nativexml/NativeXml.inc +++ /dev/null @@ -1,101 +0,0 @@ -{ unit NativeXml.inc - - Nativexml a small-footprint implementation to read and write XML documents - natively from Delpi code. NativeXml has very fast parsing speeds. - - Author: Nils Haeck M.Sc. - Copyright (c) 2007 - 2010 Simdesign B.V. - - It is NOT allowed under ANY circumstances to publish, alter or copy this code - without accepting the license conditions in accompanying LICENSE.txt - first! - - This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF - ANY KIND, either express or implied. - - Please visit http://www.simdesign.nl/xml.html for more information. -} -// Delphi and BCB versions - -// Freepascal (MK) -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF FPC} -// Delphi 5 -{$IFDEF VER130} - {$DEFINE D5UP} -{$ENDIF} -//Delphi 6 -{$IFDEF VER140} - {$DEFINE D5UP} - {$DEFINE D6UP} -{$ENDIF} -//Delphi 7 -{$IFDEF VER150} - {$DEFINE D5UP} - {$DEFINE D6UP} - {$DEFINE D7UP} -{$ENDIF} -//Delphi 8 -{$IFDEF VER160} - {$DEFINE D5UP} - {$DEFINE D6UP} - {$DEFINE D7UP} - {$DEFINE D8UP} -{$ENDIF} -// Delphi 2005 -{$IFDEF VER170} - {$DEFINE D5UP} - {$DEFINE D6UP} - {$DEFINE D7UP} - {$DEFINE D8UP} - {$DEFINE D9UP} -{$ENDIF} -// Delphi 2006 -{$IFDEF VER180} - {$DEFINE D5UP} - {$DEFINE D6UP} - {$DEFINE D7UP} - {$DEFINE D8UP} - {$DEFINE D9UP} - {$DEFINE D10UP} -{$ENDIF} -// Delphi 2007 - NET -{$IFDEF VER190} - {$DEFINE D5UP} - {$DEFINE D6UP} - {$DEFINE D7UP} - {$DEFINE D8UP} - {$DEFINE D9UP} - {$DEFINE D10UP} -{$ENDIF} -// Delphi 2009 -{$IFDEF VER200} - {$DEFINE D5UP} - {$DEFINE D6UP} - {$DEFINE D7UP} - {$DEFINE D8UP} - {$DEFINE D9UP} - {$DEFINE D10UP} - {$DEFINE D11UP} - {$DEFINE D12UP} -{$ENDIF} -// Delphi 2010 -{$IFDEF VER210} - {$DEFINE D5UP} - {$DEFINE D6UP} - {$DEFINE D7UP} - {$DEFINE D8UP} - {$DEFINE D9UP} - {$DEFINE D10UP} - {$DEFINE D11UP} - {$DEFINE D12UP} - {$DEFINE D14UP} -{$ENDIF} - -// Uncomment to save memory space for large documents if you don't need tags. -// Tags are an additional integer field that can be used by the application. -{$DEFINE USETAGS} - -// uncomment if you do not want to include the Graphics unit. -{$DEFINE USEGRAPHICS} diff --git a/addons/nativexml/NativeXml.pas b/addons/nativexml/NativeXml.pas deleted file mode 100644 index a6077e2..0000000 --- a/addons/nativexml/NativeXml.pas +++ /dev/null @@ -1,6335 +0,0 @@ -{ unit NativeXml - - This is a small-footprint implementation to read and write XML documents - natively from Delpi code. - - You can use this code to read XML documents from files, streams or strings. - The load routine generates events that can be used to display load progress - on the fly. - - Note: any external encoding (ANSI, UTF16, etc) is converted to an internal - encoding that is ANSI or UTF8. When the loaded document is ANSI based, - the encoding will be ANSI, in other cases (UTF8, UTF16) the encoding - will be UTF8. - - Original Author: Nils Haeck M.Sc. (n.haeck@simdesign.nl) - Original Date: 01 Apr 2003 - Version: see below - Copyright (c) 2003-2010 Simdesign BV - - It is NOT allowed under ANY circumstances to publish or copy this code - without accepting the license conditions in accompanying LICENSE.txt - first! - - This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF - ANY KIND, either express or implied. - - Please visit http://www.simdesign.nl/xml.html for more information. -} -unit NativeXml; - -interface - -{$I NativeXml.inc} - -uses - {$IFDEF D9UP} - Windows, - {$ENDIF} - {$IFDEF CLR} - System.Text, - {$ENDIF} - {$IFDEF USEGRAPHICS} - {$IFDEF LINUX} - QGraphics, - {$ELSE} - Graphics, - {$ENDIF} - {$ENDIF} - Classes, - SysUtils; - -const - - // Current version of the NativeXml unit - cNativeXmlVersion = '3.07'; - -// cross-platform pointer type -type - {$IFDEF CLR} - TPointer = TObject; - {$ELSE} - TPointer = Pointer; - {$ENDIF} - -// Delphi 5 stubs -{$IFNDEF D6UP} -type - TSeekOrigin = Word; - UTF8String = AnsiString; -const - soBeginning = soFromBeginning; - soCurrent = soFromCurrent; - soEnd = soFromEnd; -{$ENDIF} - -{$IFNDEF D12UP} -// Delphi 2007 and below -type - UnicodeString = WideString; - UnicodeChar = WideChar; - PUnicodeChar = PWideChar; - RawByteString = AnsiString; -{$ELSE} -type - UnicodeChar = Char; - PUnicodeChar = PChar; -{$ENDIF} - -type - - // Note on TNativeXml.Format: - // - xfReadable (default) to be able to read the xml file with a standard editor. - // - xfCompact to save the xml fully compliant and at smallest size - TXmlFormatType = ( - xfReadable, // Save in readable format with CR-LF and indents - xfCompact // Save without any control chars except LF after declarations - ); - - // TXmlElementType enumerates the different kinds of elements that can be found - // in the XML document. - TXmlElementType = ( - xeNormal, // Normal element [value][sub-elements] - xeComment, // Comment - xeCData, // literal data - xeDeclaration, // XML declaration - xeStylesheet, // Stylesheet - xeDoctype, // DOCTYPE DTD declaration - xeElement, // - xeAttList, // - xeEntity, // - xeNotation, // - xeExclam, // Any - xeQuestion, // Any - xeCharData, // character data in a node - xeUnknown // Any - ); - - // Choose what kind of binary encoding will be used when calling - // TXmlNode BufferRead and BufferWrite. - TBinaryEncodingType = ( - xbeBinHex, { With this encoding, each byte is stored as a hexadecimal - number, e.g. 0 = 00 and 255 = FF. } - xbeBase64 { With this encoding, each group of 3 bytes are stored as 4 - characters, requiring 64 different AnsiCharacters.} - ); - - // Definition of different methods of String encoding. - TStringEncodingType = ( - seAnsi, // General 8 bit encoding, encoding must be determined from encoding declaration - seUCS4BE, // UCS-4 Big Endian - seUCS4LE, // UCS-4 Little Endian - seUCS4_2143, // UCS-4 unusual octet order (2143) - seUCS4_3412, // UCS-4 unusual octet order (3412) - se16BitBE, // General 16 bit Big Endian, encoding must be determined from encoding declaration - se16BitLE, // General 16 bit Little Endian, encoding must be determined from encoding declaration - seUTF8, // UTF-8 - seUTF16BE, // UTF-16 Big Endian - seUTF16LE, // UTF-16 Little Endian - seEBCDIC // EBCDIC flavour - ); - - TXmlCompareOption = ( - xcNodeName, - xcNodeType, - xcNodeValue, - xcAttribCount, - xcAttribNames, - xcAttribValues, - xcChildCount, - xcChildNames, - xcChildValues, - xcRecursive - ); - - TXmlCompareOptions = set of TXmlCompareOption; - -const - - xcAll: TXmlCompareOptions = [xcNodeName, xcNodeType, xcNodeValue, xcAttribCount, - xcAttribNames, xcAttribValues, xcChildCount, xcChildNames, xcChildValues, - xcRecursive]; - -var - - // XML Defaults - - cDefaultEncodingString: UTF8String = 'UTF-8'; - cDefaultExternalEncoding: TStringEncodingType = seUTF8; - cDefaultVersionString: UTF8String = '1.0'; - cDefaultXmlFormat: TXmlFormatType = xfCompact; - cDefaultWriteOnDefault: boolean = True; - cDefaultBinaryEncoding: TBinaryEncodingType = xbeBase64; - cDefaultIndentString: UTF8String = ' '; - cDefaultDropCommentsOnParse: boolean = False; - cDefaultUseFullNodes: boolean = False; - cDefaultFloatAllowScientific: boolean = True; - cDefaultFloatSignificantDigits: integer = 6; - -type - - TXmlNode = class; - TNativeXml = class; - TsdCodecStream = class; - - // An event that is based on the TXmlNode object Node. - TXmlNodeEvent = procedure(Sender: TObject; Node: TXmlNode) of object; - - // An event that is used to indicate load or save progress. - TXmlProgressEvent = procedure(Sender: TObject; Size: integer) of object; - - // This event is used in the TNativeXml.OnNodeCompare event, and should - // return -1 if Node1 < Node2, 0 if Node1 = Node2 and 1 if Node1 > Node2. - TXmlNodeCompareEvent = function(Sender: TObject; Node1, Node2: TXmlNode; Info: TPointer): integer of object; - - // Pass a function of this kind to TXmlNode.SortChildNodes. The function should - // return -1 if Node1 < Node2, 0 if Node1 = Node2 and 1 if Node1 > Node2. - TXMLNodeCompareFunction = function(Node1, Node2: TXmlNode; Info: TPointer): integer; - - // Very simple autonomous stringlist that holds the list of attributes in the node - TsdUTF8StringList = class(TPersistent) - private - FItems: array of UTF8String; - FCount: integer; - function GetItems(Index: integer): UTF8String; - procedure SetItems(Index: integer; const Value: UTF8String); - function GetValues(const Name: UTF8String): UTF8String; - function GetNames(Index: integer): UTF8String; - procedure SetValues(const Name, Value: UTF8String); - function GetText: UTF8String; - public - function Add(const S: UTF8String): integer; - procedure Assign(Source: TPersistent); override; - procedure Clear; - procedure Delete(Index: Integer); - function IndexOfName(const Name: UTF8String): integer; - property Count: integer read FCount; - property Items[Index: integer]: UTF8String read GetItems write SetItems; default; - property Names[Index: integer]: UTF8String read GetNames; - property Values[const Name: UTF8String]: UTF8String read GetValues write SetValues; - property Text: UTF8String read GetText; - end; - - // The TXmlNode represents an element in the XML file. Each TNativeXml holds - // one Root element. Under ths root element, sub-elements can be nested (there - // is no limit on how deep). Property ElementType defines what kind of element - // this node is. - TXmlNode = class(TPersistent) - private - FName: UTF8String; // The element name - FValue: UTF8String; // The *escaped* value - FAttributes: TsdUTF8StringList; // List with attributes - FNodes: TList; // These are the child elements - FParent: TXmlNode; // Pointer to parent element - FDocument: TNativeXml; // Pointer to parent XmlDocument - FElementType: TXmlElementType; // The type of element - FTag: integer; // A value the developer can use - function AbortParsing: boolean; - function GetValueAsString: UTF8String; - procedure SetAttributeName(Index: integer; const Value: UTF8String); - procedure SetAttributeValue(Index: integer; const Value: UTF8String); - procedure SetValueAsString(const AValue: UTF8String); - function GetIndent: UTF8String; - function GetLineFeed: UTF8String; - function GetTreeDepth: integer; - function GetAttributeCount: integer; - function GetAttributePair(Index: integer): UTF8String; - function GetAttributeName(Index: integer): UTF8String; - function GetAttributeValue(Index: integer): UTF8String; - function GetWriteOnDefault: boolean; - function GetBinaryEncoding: TBinaryEncodingType; - function GetCascadedName: UTF8String; - function QualifyAsDirectNode: boolean; - procedure SetName(const Value: UTF8String); - function GetFullPath: UTF8String; - procedure SetBinaryEncoding(const Value: TBinaryEncodingType); - function GetBinaryString: RawByteString; - procedure SetBinaryString(const Value: RawByteString); - function UseFullNodes: boolean; - function GetValueAsUnicodeString: UnicodeString; - procedure SetValueAsUnicodeString(const Value: UnicodeString); - function GetAttributeByName(const AName: UTF8String): UTF8String; - procedure SetAttributeByName(const AName, Value: UTF8String); - function GetValueAsInteger: integer; - procedure SetValueAsInteger(const Value: integer); - function GetValueAsFloat: double; - procedure SetValueAsFloat(const Value: double); - function GetValueAsDateTime: TDateTime; - procedure SetValueAsDateTime(const Value: TDateTime); - function GetValueAsBool: boolean; - procedure SetValueAsBool(const Value: boolean); - function GetValueAsInt64: int64; - procedure SetValueAsInt64(const Value: int64); - procedure CheckCreateAttributesList; - function GetAttributeValueAsUnicodeString(Index: integer): UnicodeString; - procedure SetAttributeValueAsUnicodeString(Index: integer; - const Value: UnicodeString); - function GetAttributeValueAsInteger(Index: integer): integer; - procedure SetAttributeValueAsInteger(Index: integer; - const Value: integer); - function GetAttributeByNameWide(const AName: UTF8String): UnicodeString; - procedure SetAttributeByNameWide(const AName: UTF8String; - const Value: UnicodeString); - function GetTotalNodeCount: integer; - function FloatSignificantDigits: integer; - function FloatAllowScientific: boolean; - function GetAttributeValueDirect(Index: integer): UTF8String; - procedure SetAttributeValueDirect(Index: integer; const Value: UTF8String); - protected - function CompareNodeName(const NodeName: UTF8String): integer; - procedure DeleteEmptyAttributes; - function GetNodes(Index: integer): TXmlNode; virtual; - function GetNodeCount: integer; virtual; - procedure ParseTag(const AValue: UTF8String; TagStart, TagClose: integer); - procedure ReadFromStream(S: TStream); virtual; - procedure ReadFromString(const AValue: UTF8String); virtual; - procedure ResolveEntityReferences; - function UnescapeString(const AValue: UTF8String): UTF8String; virtual; - function WriteInnerTag: UTF8String; virtual; - procedure WriteToStream(S: TStream); virtual; - procedure ChangeDocument(ADocument: TNativeXml); - public - // Create a new TXmlNode object. ADocument must be the TNativeXml that is - // going to hold this new node. - constructor Create(ADocument: TNativeXml); virtual; - // \Create a new TXmlNode with name AName. ADocument must be the TNativeXml - // that is going to hold this new node. - constructor CreateName(ADocument: TNativeXml; const AName: UTF8String); virtual; - // \Create a new TXmlNode with name AName and UTF8String value AValue. ADocument - // must be the TNativeXml that is going to hold this new node. - constructor CreateNameValue(ADocument: TNativeXml; const AName, AValue: UTF8String); virtual; - // \Create a new TXmlNode with XML element type AType. ADocument must be the - // TNativeXml that is going to hold this new node. - constructor CreateType(ADocument: TNativeXml; AType: TXmlElementType); virtual; - // Use Assign to assign another TXmlNode to this node. This means that all - // properties and subnodes from the Source TXmlNode are copied to the current - // node. You can also Assign a TNativeXml document to the node, in that case - // the RootNodeList property of the TNativeXml object will be copied. - procedure Assign(Source: TPersistent); override; - // Call Delete to delete this node completely from the parent node list. This - // call only succeeds if the node has a parent. It has no effect when called for - // the root node. - procedure Delete; virtual; - // \Delete all nodes that are empty (this means, which have no subnodes, no - // attributes, and no value assigned). This procedure works recursively. - procedure DeleteEmptyNodes; - // Destroy a TXmlNode object. This will free the child node list automatically. - // Never call this method directly. All TXmlNodes in the document will be - // recursively freed when TNativeXml.Free is called. - destructor Destroy; override; - // Use this method to add an integer attribute to the node. - procedure AttributeAdd(const AName: UTF8String; AValue: integer); overload; - // Use this method to add a string attribute with value AValue to the node. - procedure AttributeAdd(const AName, AValue: UTF8String); overload; - // Use this method to delete the attribute at Index in the list. Index must be - // equal or greater than 0, and smaller than AttributeCount. Using an index - // outside of that range has no effect. - procedure AttributeDelete(Index: integer); - // Switch position of the attributes at Index1 and Index2. - procedure AttributeExchange(Index1, Index2: integer); - // Use this method to find the index of an attribute with name AName. - function AttributeIndexByname(const AName: UTF8String): integer; - // \Clear all attributes from the current node. - procedure AttributesClear; virtual; - // Use this method to read binary data from the node into Buffer with a length of Count. - procedure BufferRead(var Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer); virtual; - // Use this method to write binary data in Buffer with a length of Count to the - // current node. The data will appear as text using either BinHex or Base64 - // method) in the final XML document. - // Notice that NativeXml does only support up to 2Gb bytes of data per file, - // so do not use this option for huge files. The binary encoding method (converting - // binary data into text) can be selected using property BinaryEncoding. - // xbeBase64 is most efficient, but slightly slower. Always use identical methods - // for reading and writing. - procedure BufferWrite(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer); virtual; - // Returns the length of the data in the buffer, once it would be decoded by - // method xbeBinHex or xbeBase64. If BinaryEncoding is xbeSixBits, this function - // cannot be used. The length of the unencoded data is determined from the - // length of the encoded data. For xbeBinHex this is trivial (just half the - // length), for xbeBase64 this is more difficult (must use the padding characters) - function BufferLength: integer; virtual; - // Clear all child nodes and attributes, and the name and value of the current - // XML node. However, the node is not deleted. Call Delete instead for that. - procedure Clear; virtual; - // Find the first node which has name NodeName. Contrary to the NodeByName - // function, this function will search the whole subnode tree, using the - // DepthFirst method. It is possible to search for a full path too, e.g. - // FoundNode := MyNode.FindNode('/Root/SubNode1/SubNode2/ThisNode'); - function FindNode(const NodeName: UTF8String): TXmlNode; - // Find all nodes which have name NodeName. Contrary to the NodesByName - // function, this function will search the whole subnode tree. If you use - // a TXmlNodeList for the AList parameter, you don't need to cast the list - // items to TXmlNode. - procedure FindNodes(const NodeName: UTF8String; const AList: TList); - // Use FromAnsiString to convert a normal ANSI String to a UTF8String for the node - // (name, value, attributes). In TNativeXml the ANSI Characters are encoded - // into UTF8. - function FromAnsiString(const s: AnsiString): UTF8String; - // Use FromUnicodeString to convert UnicodeString to a UTF8String for the node (name, value, - // attributes). - function FromUnicodeString(const W: UnicodeString): UTF8String; - // Use HasAttribute to determine if the node has an attribute with name AName. - function HasAttribute(const AName: UTF8String): boolean; virtual; - // This function returns the index of this node in the parent's node list. - // If Parent is not assigned, this function returns -1. - function IndexInParent: integer; - // This function returns True if the node has no subnodes and no attributes, - // and if the node Name and value are empty. - function IsClear: boolean; virtual; - // This function returns True if the node has no subnodes and no attributes, - // and if the node value is empty. - function IsEmpty: boolean; virtual; - function IsEqualTo(ANode: TXmlNode; Options: TXmlCompareOptions; MismatchNodes: TList = nil): boolean; - // Add the node ANode as a new subelement in the nodelist. The node will be - // added in position NodeCount (which will be returned). - function NodeAdd(ANode: TXmlNode): integer; virtual; - // This function returns a pointer to the first subnode that has an attribute with - // name AttribName and value AttribValue. If ShouldRecurse = True (default), the - // function works recursively, using the depthfirst method. - function NodeByAttributeValue(const NodeName, AttribName, AttribValue: UTF8String; - ShouldRecurse: boolean = True): TXmlNode; - // Return a pointer to the first subnode with this Elementype, or return nil - // if no subnode with that type is found. - function NodeByElementType(ElementType: TXmlElementType): TXmlNode; - // Return a pointer to the first subnode in the nodelist that has name AName. - // If no subnodes with AName are found, the function returns nil. - function NodeByName(const AName: UTF8String): TXmlNode; virtual; - // \Delete the subnode at Index. The node will also be freed, so do not free the - // node in the application. - procedure NodeDelete(Index: integer); virtual; - // Switch position of the nodes at Index1 and Index2. - procedure NodeExchange(Index1, Index2: integer); - // Extract the node ANode from the subnode list. The node will no longer appear - // in the subnodes list, so the application is responsible for freeing ANode later. - function NodeExtract(ANode: TXmlNode): TXmlNode; virtual; - // This function returns a pointer to the first node with AName. If this node - // is not found, then it creates a new node with AName and returns its pointer. - function NodeFindOrCreate(const AName: UTF8String): TXmlNode; virtual; - // Find the index of the first subnode with name AName. - function NodeIndexByName(const AName: UTF8String): integer; virtual; - // Find the index of the first subnode with name AName that appears after or on - // the index AFrom. This function can be used in a loop to retrieve all nodes - // with a certain name, without using a helper list. See also NodesByName. - function NodeIndexByNameFrom(const AName: UTF8String; AFrom: integer): integer; virtual; - // Call NodeIndexOf to get the index for ANode in the Nodes array. The first - // node in the array has index 0, the second item has index 1, and so on. If - // a node is not in the list, NodeIndexOf returns -1. - function NodeIndexOf(ANode: TXmlNode): integer; - // Insert the node ANode at location Index in the list. - procedure NodeInsert(Index: integer; ANode: TXmlNode); virtual; - // \Create a new node with AName, add it to the subnode list, and return a - // pointer to it. - function NodeNew(const AName: UTF8String): TXmlNode; virtual; - // \Create a new node with AName, and insert it into the subnode list at location - // Index, and return a pointer to it. - function NodeNewAtIndex(Index: integer; const AName: UTF8String): TXmlNode; virtual; - // Call NodeRemove to remove a specific node from the Nodes array when its index - // is unknown. The value returned is the index of the item in the Nodes array - // before it was removed. After an item is removed, all the items that follow - // it are moved up in index position and the NodeCount is reduced by one. - function NodeRemove(ANode: TxmlNode): integer; - // \Clear (and free) the complete list of subnodes. - procedure NodesClear; virtual; - // Use this procedure to retrieve all nodes that have name AName. Pointers to - // these nodes are added to the list in AList. AList must be initialized - // before calling this procedure. If you use a TXmlNodeList you don't need - // to cast the list items to TXmlNode. - procedure NodesByName(const AName: UTF8String; const AList: TList); - // Find the attribute with AName, and convert its value to a boolean. If the - // attribute is not found, or cannot be converted, the default ADefault will - // be returned. - function ReadAttributeBool(const AName: UTF8String; ADefault: boolean = False): boolean; virtual; - function ReadAttributeDateTime(const AName: UTF8String; ADefault: TDateTime = 0): TDateTime; virtual; - // Find the attribute with AName, and convert its value to an integer. If the - // attribute is not found, or cannot be converted, the default ADefault will - // be returned. - function ReadAttributeInteger(const AName: UTF8String; ADefault: integer = 0): integer; virtual; - // Find the attribute with AName, and convert its value to an int64. If the - // attribute is not found, or cannot be converted, the default ADefault will - // be returned. - function ReadAttributeInt64(const AName: UTF8String; ADefault: int64 = 0): int64; virtual; - // Find the attribute with AName, and convert its value to a float. If the - // attribute is not found, or cannot be converted, the default ADefault will - // be returned. - function ReadAttributeFloat(const AName: UTF8String; ADefault: double = 0): double; - function ReadAttributeString(const AName: UTF8String; const ADefault: UTF8String = ''): UTF8String; virtual; - // Read the subnode with AName and convert it to a boolean value. If the - // subnode is not found, or cannot be converted, the boolean ADefault will - // be returned. - function ReadBool(const AName: UTF8String; ADefault: boolean = False): boolean; virtual; - {$IFDEF USEGRAPHICS} - // Read the properties Color and Style for the TBrush object ABrush from the - // subnode with AName. - procedure ReadBrush(const AName: UTF8String; ABrush: TBrush); virtual; - // Read the subnode with AName and convert its value to TColor. If the - // subnode is not found, or cannot be converted, ADefault will be returned. - function ReadColor(const AName: UTF8String; ADefault: TColor = clBlack): TColor; virtual; - // Read the properties \Name, Color, Size and Style for the TFont object AFont - // from the subnode with AName. - procedure ReadFont(const AName: UTF8String; AFont: TFont); virtual; - // Read the properties Color, Mode, Style and Width for the TPen object APen - // from the subnode with AName. - procedure ReadPen(const AName: UTF8String; APen: TPen); virtual; - {$ENDIF} - // Read the subnode with AName and convert its value to TDateTime. If the - // subnode is not found, or cannot be converted, ADefault will be returned. - function ReadDateTime(const AName: UTF8String; ADefault: TDateTime = 0): TDateTime; virtual; - // Read the subnode with AName and convert its value to a double. If the - // subnode is not found, or cannot be converted, ADefault will be returned. - function ReadFloat(const AName: UTF8String; ADefault: double = 0.0): double; virtual; - // Read the subnode with AName and convert its value to an int64. If the - // subnode is not found, or cannot be converted, ADefault will be returned. - function ReadInt64(const AName: UTF8String; ADefault: int64 = 0): int64; virtual; - // Read the subnode with AName and convert its value to an integer. If the - // subnode is not found, or cannot be converted, ADefault will be returned. - function ReadInteger(const AName: UTF8String; ADefault: integer = 0): integer; virtual; - // Read the subnode with AName and return its UTF8String value. If the subnode is - // not found, ADefault will be returned. - function ReadString(const AName: UTF8String; const ADefault: UTF8String = ''): UTF8String; virtual; - // Read the subnode with AName and return its UnicodeString value. If the subnode is - // not found, ADefault will be returned. - function ReadUnicodeString(const AName: UTF8String; const ADefault: UnicodeString = ''): UnicodeString; virtual; - // Sort the child nodes of this node. Provide a custom node compare function in Compare, - // or attach an event handler to the parent documents' OnNodeCompare in order to - // provide custom sorting. If no compare function is given (nil) and OnNodeCompare - // is not implemented, SortChildNodes will simply sort the nodes by name (ascending, - // case insensitive). The Info pointer parameter can be used to pass any custom - // information to the compare function. Default value for Info is nil. - procedure SortChildNodes(Compare: TXMLNodeCompareFunction = nil; Info: TPointer = nil); - // Use ToUnicodeString to convert any UTF8 String from the node (name, value, attributes) - // to a UnicodeString. - function ToUnicodeString(const s: UTF8String): UnicodeString; - // Convert the node's value to boolean and return the result. If this conversion - // fails, or no value is found, then the function returns ADefault. - function ValueAsBoolDef(ADefault: boolean): boolean; virtual; - // Convert the node's value to a TDateTime and return the result. If this conversion - // fails, or no value is found, then the function returns ADefault. - function ValueAsDateTimeDef(ADefault: TDateTime): TDateTime; virtual; - // Convert the node's value to a double and return the result. If this conversion - // fails, or no value is found, then the function returns ADefault. - function ValueAsFloatDef(ADefault: double): double; virtual; - // Convert the node's value to int64 and return the result. If this conversion - // fails, or no value is found, then the function returns ADefault. - function ValueAsInt64Def(ADefault: int64): int64; virtual; - // Convert the node's value to integer and return the result. If this conversion - // fails, or no value is found, then the function returns ADefault. - function ValueAsIntegerDef(ADefault: integer): integer; virtual; - // If the attribute with name AName exists, then set its value to the boolean - // AValue. If it does not exist, then create a new attribute AName with the - // boolean value converted to either "True" or "False". If ADefault = AValue, and - // WriteOnDefault = False, no attribute will be added. - procedure WriteAttributeBool(const AName: UTF8String; AValue: boolean; ADefault: boolean = False); virtual; - procedure WriteAttributeDateTime(const AName: UTF8string; AValue: TDateTime; ADefault: TDateTime = 0); virtual; - // If the attribute with name AName exists, then set its value to the integer - // AValue. If it does not exist, then create a new attribute AName with the - // integer value converted to a quoted string. If ADefault = AValue, and - // WriteOnDefault = False, no attribute will be added. - procedure WriteAttributeInteger(const AName: UTF8String; AValue: integer; ADefault: integer = 0); virtual; - procedure WriteAttributeInt64(const AName: UTF8String; const AValue: int64; ADefault: int64 = 0); virtual; - procedure WriteAttributeFloat(const AName: UTF8String; AValue: double; ADefault: double = 0); virtual; - // If the attribute with name AName exists, then set its value to the UTF8String - // AValue. If it does not exist, then create a new attribute AName with the - // value AValue. If ADefault = AValue, and WriteOnDefault = False, no attribute - // will be added. - procedure WriteAttributeString(const AName: UTF8String; const AValue: UTF8String; const ADefault: UTF8String = ''); virtual; - // Add or replace the subnode with AName and set its value to represent the boolean - // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added. - procedure WriteBool(const AName: UTF8String; AValue: boolean; ADefault: boolean = False); virtual; - {$IFDEF USEGRAPHICS} - // Write properties Color and Style of the TBrush object ABrush to the subnode - // with AName. If AName does not exist, it will be created. - procedure WriteBrush(const AName: UTF8String; ABrush: TBrush); virtual; - // Add or replace the subnode with AName and set its value to represent the TColor - // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added. - procedure WriteColor(const AName: UTF8String; AValue: TColor; ADefault: TColor = clBlack); virtual; - // Write properties \Name, Color, Size and Style of the TFont object AFont to - // the subnode with AName. If AName does not exist, it will be created. - procedure WriteFont(const AName: UTF8String; AFont: TFont); virtual; - // Write properties Color, Mode, Style and Width of the TPen object APen to - // the subnode with AName. If AName does not exist, it will be created. - procedure WritePen(const AName: UTF8String; APen: TPen); virtual; - {$ENDIF} - // Add or replace the subnode with AName and set its value to represent the TDateTime - // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added. - // The XML format used is compliant with W3C's specification of date and time. - procedure WriteDateTime(const AName: UTF8String; AValue: TDateTime; ADefault: TDateTime = 0); virtual; - // Add or replace the subnode with AName and set its value to represent the double - // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added. - procedure WriteFloat(const AName: UTF8String; AValue: double; ADefault: double = 0.0); virtual; - // Add or replace the subnode with AName and set its value to represent the hexadecimal representation of - // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added. - procedure WriteHex(const AName: UTF8String; AValue: integer; Digits: integer; ADefault: integer = 0); virtual; - // Add or replace the subnode with AName and set its value to represent the int64 - // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added. - procedure WriteInt64(const AName: UTF8String; AValue: int64; ADefault: int64 = 0); virtual; - // Add or replace the subnode with AName and set its value to represent the integer - // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added. - procedure WriteInteger(const AName: UTF8String; AValue: integer; ADefault: integer = 0); virtual; - // Add or replace the subnode with AName and set its value to represent the UTF8String - // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added. - procedure WriteString(const AName, AValue: UTF8String; const ADefault: UTF8String = ''); virtual; - // Call WriteToString to save the XML node to a UTF8String. This method can be used to store - // individual nodes instead of the complete XML document. - function WriteToString: UTF8String; virtual; - // Add or replace the subnode with AName and set its value to represent the UnicodeString - // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added. - procedure WriteUnicodeString(const AName: UTF8String; const AValue: UnicodeString; const ADefault: UnicodeString = ''); virtual; - // AttributeByName returns the attribute value for the attribute that has name AName. - // Set AttributeByName to add an attribute to the attribute list, or replace an - // existing one. - property AttributeByName[const AName: UTF8String]: UTF8String read GetAttributeByName write - SetAttributeByName; - // AttributeByNameWide returns the attribute value for the attribute that has name AName - // as UnicodeString. Set AttributeByNameWide to add an attribute to the attribute list, or replace an - // existing one. - property AttributeByNameWide[const AName: UTF8String]: UnicodeString read GetAttributeByNameWide write - SetAttributeByNameWide; - // Returns the number of attributes in the current node. - property AttributeCount: integer read GetAttributeCount; - // Read this property to get the name of the attribute at Index. Note that Index - // is zero-based: Index goes from 0 to AttributeCount - 1 - property AttributeName[Index: integer]: UTF8String read GetAttributeName write SetAttributeName; - // Read this property to get the Attribute \Name and Value pair at index Index. - // This is a UTF8String with \Name and Value separated by a TAB character (#9). - property AttributePair[Index: integer]: UTF8String read GetAttributePair; - // Read this property to get the UTF8String value of the attribute at index Index. - // Write to it to set the UTF8String value. - property AttributeValue[Index: integer]: UTF8String read GetAttributeValue write SetAttributeValue; - // Read this property to get the UnicodeString value of the attribute at index Index. - // Write to it to set the UnicodeString value. - property AttributeValueAsUnicodeString[Index: integer]: UnicodeString read GetAttributeValueAsUnicodeString write SetAttributeValueAsUnicodeString; - // Read this property to get the integer value of the attribute at index Index. - // If the value cannot be converted, 0 will be returned. Write to it to set the integer value. - property AttributeValueAsInteger[Index: integer]: integer read GetAttributeValueAsInteger write SetAttributeValueAsInteger; - // Set or get the raw attribute value, thus circumventing the escape function. Make sure that - // the value you set does not contain the & and quote AnsiCharacters, or the produced - // XML will be invalid. - property AttributeValueDirect[Index: integer]: UTF8String read GetAttributeValueDirect write SetAttributeValueDirect; - // BinaryEncoding reflects the same value as the BinaryEncoding setting of the parent - // Document. - property BinaryEncoding: TBinaryEncodingType read GetBinaryEncoding write SetBinaryEncoding; - // Use BinaryString to add/extract binary data in an easy way to/from the node. Internally the - // data gets stored as Base64-encoded data. Do not use this method for normal textual - // information, it is better to use ValueAsString in that case (adds less overhead). - property BinaryString: RawByteString read GetBinaryString write SetBinaryString; - // This property returns the name and index and all predecessors with underscores - // to separate, in order to get a unique reference that can be used in filenames. - property CascadedName: UTF8String read GetCascadedName; - // Pointer to parent NativeXml document, or Nil if none. - property Document: TNativeXml read FDocument write FDocument; - // ElementType contains the type of element that this node holds. - property ElementType: TXmlElementType read FElementType write FElementType; - // Fullpath will return the complete path of the node from the root, e.g. - // /Root/SubNode1/SubNode2/ThisNode - property FullPath: UTF8String read GetFullPath; - // Read Name to get the name of the element, and write Name to set the name. - // This is the full name and may include a namespace. (Namespace:Name) - property Name: UTF8String read FName write SetName; - // Parent points to the parent node of the current XML node. - property Parent: TXmlNode read FParent write FParent; - // NodeCount is the number of child nodes that this node holds. In order to - // loop through all child nodes, use a construct like this: - // - // with MyNode do - // for i := 0 to NodeCount - 1 do - // with Nodes[i] do - // ..processing here - // - property NodeCount: integer read GetNodeCount; - // Use Nodes to access the child nodes of the current XML node by index. Note - // that the list is zero-based, so Index is valid from 0 to NodeCount - 1. - property Nodes[Index: integer]: TXmlNode read GetNodes; default; - // Tag is an integer value the developer can use in any way. Tag does not get - // saved to the XML. Tag is often used to point to a GUI element (and is then - // cast to a pointer). - property Tag: integer read FTag write FTag; - // TotalNodeCount represents the total number of child nodes, and child nodes - // of child nodes etcetera of this particular node. Use the following to get - // the total number of nodes in the XML document: - // - // Total := MyDoc.RootNodes.TotalNodeCount; - // - property TotalNodeCount: integer read GetTotalNodeCount; - // Read TreeDepth to find out many nested levels there are for the current XML - // node. Root has a TreeDepth of zero. - property TreeDepth: integer read GetTreeDepth; - // ValueAsBool returns the node's value as boolean, or raises an - // exception if the value cannot be converted to boolean. Set ValueAsBool - // to convert a boolean to a UTF8String in the node's value field. See also - // function ValueAsBoolDef. - property ValueAsBool: boolean read GetValueAsBool write SetValueAsBool; - // ValueAsDateTime returns the node's value as TDateTime, or raises an - // exception if the value cannot be converted to TDateTime. Set ValueAsDateTime - // to convert a TDateTime to a UTF8String in the node's value field. See also - // function ValueAsDateTimeDef. - property ValueAsDateTime: TDateTime read GetValueAsDateTime write SetValueAsDateTime; - // ValueAsIn64 returns the node's value as int64, or raises an - // exception if the value cannot be converted to int64. Set ValueAsInt64 - // to convert an int64 to a UTF8String in the node's value field. See also - // function ValueAsInt64Def. - property ValueAsInt64: int64 read GetValueAsInt64 write SetValueAsInt64; - // ValueAsInteger returns the node's value as integer, or raises an - // exception if the value cannot be converted to integer. Set ValueAsInteger - // to convert an integer to a UTF8String in the node's value field. See also - // function ValueAsIntegerDef. - property ValueAsInteger: integer read GetValueAsInteger write SetValueAsInteger; - // ValueAsFloat returns the node's value as float, or raises an - // exception if the value cannot be converted to float. Set ValueAsFloat - // to convert a float to a UTF8String in the node's value field. See also - // function ValueAsFloatDef. - property ValueAsFloat: double read GetValueAsFloat write SetValueAsFloat; - // ValueAsString returns the unescaped version of ValueDirect. All neccesary - // characters in ValueDirect must be escaped (e.g. "&" becomes "&") but - // ValueAsString returns them in original format. Always use ValueAsString to - // set the text value of a node, to make sure all neccesary charaters are - // escaped. - property ValueAsString: UTF8String read GetValueAsString write SetValueAsString; - // ValueAsUnicodeString returns the unescaped version of ValueDirect as a UnicodeString. - // Always use ValueAsUnicodeString to set the text value of a node, to make sure all - // neccesary charaters are escaped. - property ValueAsUnicodeString: UnicodeString read GetValueAsUnicodeString write SetValueAsUnicodeString; - // ValueDirect is the exact text value as was parsed from the stream. If multiple - // text elements are encountered, they are added to ValueDirect with a CR to - // separate them. - property ValueDirect: UTF8String read FValue write FValue; - // WriteOnDefault reflects the same value as the WriteOnDefault setting of the parent - // Document. - property WriteOnDefault: boolean read GetWriteOnDefault; - end; - - // TXmlNodeList is a utility TList descendant that can be used to work with selection - // lists. An example: - // - // procedure FindAllZips(ANode: TXmlNode); - // var - // i: integer; - // AList: TXmlNodeList; - // begin - // AList := TXmlNodeList.Create; - // try - // // Get a list of all nodes named 'ZIP' - // ANode.NodesByName('ZIP', AList); - // for i := 0 to AList.Count - 1 do - // // Write the value of the node to output. Since AList[i] will be - // // of type TXmlNode, we can directly access the Value property. - // WriteLn(AList[i].Value); - // finally - // AList.Free; - // end; - // end; - // - TXmlNodeList = class(TList) - private - function GetItems(Index: Integer): TXmlNode; - procedure SetItems(Index: Integer; const Value: TXmlNode); - public - // Return the first node in the list that has an attribute with AName, AValue - function ByAttribute(const AName, AValue: UTF8String): TXmlNode; - property Items[Index: Integer]: TXmlNode read GetItems write SetItems; default; - end; - - // TNativeXml is the XML document holder. Create a TNativeXml and then use - // methods LoadFromFile, LoadFromStream or ReadFromString to load an XML document - // into memory. Or start from scratch and use Root.NodeNew to add nodes and - // eventually SaveToFile and SaveToStream to save the results as an XML document. - // Use property Xmlformat = xfReadable to ensure that indented (readable) output - // is produced. - TNativeXml = class(TPersistent) - private - FAbortParsing: boolean; // Signal to abort the parsing process - FBinaryEncoding: TBinaryEncodingType; // xbeBinHex or xbeBase64 - FCodecStream: TsdCodecStream; // Temporary stream used to read encoded files - FDropCommentsOnParse: boolean; // If true, comments are dropped (deleted) when parsing - FExternalEncoding: TStringEncodingType; - FFloatAllowScientific: boolean; - FFloatSignificantDigits: integer; - FParserWarnings: boolean; // Show parser warnings for non-critical errors - FRootNodes: TXmlNode; // Root nodes in the document (which contains one normal element that is the root) - FIndentString: UTF8String; // The indent string used to indent content (default is two spaces) - FUseFullNodes: boolean; // If true, nodes are never written in short notation. - FWriteOnDefault: boolean; // Set this option to "False" to only write values <> default value (default = true) - FXmlFormat: TXmlFormatType; // xfReadable, xfCompact - FOnNodeCompare: TXmlNodeCompareEvent; // Compare two nodes - FOnNodeNew: TXmlNodeEvent; // Called after a node is added - FOnNodeLoaded: TXmlNodeEvent; // Called after a node is loaded completely - FOnProgress: TXmlProgressEvent; // Called after a node is loaded/saved, with the current position in the file - FOnUnicodeLoss: TNotifyEvent; // This event is called when there is a warning for unicode conversion loss when reading unicode - procedure DoNodeNew(Node: TXmlNode); - procedure DoNodeLoaded(Node: TXmlNode); - procedure DoUnicodeLoss(Sender: TObject); - function GetCommentString: UTF8String; - procedure SetCommentString(const Value: UTF8String); - function GetEntityByName(AName: UTF8String): UTF8String; - function GetRoot: TXmlNode; - function GetEncodingString: UTF8String; - procedure SetEncodingString(const Value: UTF8String); - function GetVersionString: UTF8String; - procedure SetVersionString(const Value: UTF8String); - function GetStyleSheetNode: TXmlNode; - function GetUtf8Encoded: boolean; - protected - procedure CopyFrom(Source: TNativeXml); virtual; - procedure DoProgress(Size: integer); - function LineFeed: UTF8String; virtual; - procedure ParseDTD(ANode: TXmlNode; S: TStream); virtual; - procedure ReadFromStream(S: TStream); virtual; - procedure WriteToStream(S: TStream); virtual; - procedure SetDefaults; virtual; - public - // Create a new NativeXml document which can then be used to read or write XML files. - // A document that is created with Create must later be freed using Free. - // Example: - // - // var - // ADoc: TNativeXml; - // begin - // ADoc := TNativeXml.Create; - // try - // ADoc.LoadFromFile('c:\\temp\\myxml.xml'); - // {do something with the document here} - // finally - // ADoc.Free; - // end; - // end; - // - constructor Create; virtual; - // Use CreateName to Create a new Xml document that will automatically - // contain a root element with name ARootName. - constructor CreateName(const ARootName: UTF8String); virtual; - // Destroy will free all data in the TNativeXml object. This includes the - // root node and all subnodes under it. Do not call Destroy directly, call - // Free instead. - destructor Destroy; override; - // When calling Assign with a Source object that is a TNativeXml, will cause - // it to copy all data from Source. - procedure Assign(Source: TPersistent); override; - // Call Clear to remove all data from the object, and restore all defaults. - procedure Clear; virtual; - // Function IsEmpty returns true if the root is clear, or in other words, the - // root contains no value, no name, no subnodes and no attributes. - function IsEmpty: boolean; virtual; - // Load an XML document from the TStream object in Stream. The LoadFromStream - // procedure will raise an exception of type EFilerError when it encounters - // non-wellformed XML. This method can be used with any TStream descendant. - // See also LoadFromFile and ReadFromString. - procedure LoadFromStream(Stream: TStream); virtual; - // Call procedure LoadFromFile to load an XML document from the filename - // specified. See Create for an example. The LoadFromFile procedure will raise - // an exception of type EFilerError when it encounters non-wellformed XML. - procedure LoadFromFile(const AFileName: string); virtual; - // Call procedure ReadFromString to load an XML document from the UTF8String AValue. - // The ReadFromString procedure will raise an exception of type EFilerError - // when it encounters non-wellformed XML. - procedure ReadFromString(const AValue: UTF8String); virtual; - // Call ResolveEntityReferences after the document has been loaded to resolve - // any present entity references (&Entity;). When an entity is found in the - // DTD, it will replace the entity reference. Whenever an entity contains - // XML markup, it will be parsed and become part of the document tree. Since - // calling ResolveEntityReferences is adding quite some extra overhead, it - // is not done automatically. If you want to do the entity replacement, a good - // moment to call ResolveEntityReferences is right after LoadFromFile. - procedure ResolveEntityReferences; - // Call SaveToStream to save the XML document to the Stream. Stream - // can be any TStream descendant. Set XmlFormat to xfReadable if you want - // the stream to contain indentations to make the XML more human-readable. This - // is not the default and also not compliant with the XML specification. See - // SaveToFile for information on how to save in special encoding. - procedure SaveToStream(Stream: TStream); virtual; - // Call SaveToFile to save the XML document to a file with FileName. If the - // filename exists, it will be overwritten without warning. If the file cannot - // be created, a standard I/O exception will be generated. Set XmlFormat to - // xfReadable if you want the file to contain indentations to make the XML - // more human-readable. This is not the default and also not compliant with - // the XML specification.

- // Saving to special encoding types can be achieved by setting two properties - // before saving: - // * ExternalEncoding - // * EncodingString - // ExternalEncoding can be se8bit (for plain ascii), seUtf8 (UTF-8), seUtf16LE - // (for unicode) or seUtf16BE (unicode big endian).

Do not forget to also - // set the EncodingString (e.g. "UTF-8" or "UTF-16") which matches with your - // ExternalEncoding. - procedure SaveToFile(const AFileName: string); virtual; - // Call WriteToString to save the XML document to a UTF8String. Set XmlFormat to - // xfReadable if you want the UTF8String to contain indentations to make the XML - // more human-readable. This is not the default and also not compliant with - // the XML specification. - function WriteToString: UTF8String; virtual; - // Set AbortParsing to True if you use the OnNodeNew and OnNodeLoaded events in - // a SAX-like manner, and you want to abort the parsing process halfway. Example: - // - // procedure MyForm.NativeXmlNodeLoaded(Sender: TObject; Node: TXmlNode); - // begin - // if (Node.Name = 'LastNode') and (Sender is TNativeXml) then - // TNativeXml(Sender).AbortParsing := True; - // end; - // - property AbortParsing: boolean read FAbortParsing write FAbortParsing; - // Choose what kind of binary encoding will be used when calling TXmlNode.BufferRead - // and TXmlNode.BufferWrite. Default value is xbeBase64. - property BinaryEncoding: TBinaryEncodingType read FBinaryEncoding write FBinaryEncoding; - // A comment string above the root element \'; Style: xeComment), - (Start: ''; Style: xeExclam), - (Start: ''; Style: xeQuestion), - (Start: '<'; Close: '>'; Style: xeNormal) ); - // direct tags are derived from Normal tags by checking for the /> - - // These constant are used when generating hexchars from buffer data - cHexChar: array[0..15] of AnsiChar = '0123456789ABCDEF'; - cHexCharLoCase: array[0..15] of AnsiChar = '0123456789abcdef'; - - // These AnsiCharacters are used when generating BASE64 AnsiChars from buffer data - cBase64Char: array[0..63] of AnsiChar = - 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; - cBase64PadChar: AnsiChar = '='; - - // The amount of bytes to allocate with each increase of the value buffer - cNodeValueBuf = 2048; - - // byte order marks for strings - // Unicode text files should contain $FFFE as first character to identify such a file clearly. Depending on the system - // where the file was created on this appears either in big endian or little endian style. - - const cBomInfoCount = 15; - const cBomInfo: array[0..cBomInfoCount - 1] of TBomInfo = - ( (BOM: ($00,$00,$FE,$FF); Len: 4; Encoding: seUCS4BE; HasBOM: true), - (BOM: ($FF,$FE,$00,$00); Len: 4; Encoding: seUCS4LE; HasBOM: true), - (BOM: ($00,$00,$FF,$FE); Len: 4; Encoding: seUCS4_2143; HasBOM: true), - (BOM: ($FE,$FF,$00,$00); Len: 4; Encoding: seUCS4_3412; HasBOM: true), - (BOM: ($FE,$FF,$00,$00); Len: 2; Encoding: seUTF16BE; HasBOM: true), - (BOM: ($FF,$FE,$00,$00); Len: 2; Encoding: seUTF16LE; HasBOM: true), - (BOM: ($EF,$BB,$BF,$00); Len: 3; Encoding: seUTF8; HasBOM: true), - (BOM: ($00,$00,$00,$3C); Len: 4; Encoding: seUCS4BE; HasBOM: false), - (BOM: ($3C,$00,$00,$00); Len: 4; Encoding: seUCS4LE; HasBOM: false), - (BOM: ($00,$00,$3C,$00); Len: 4; Encoding: seUCS4_2143; HasBOM: false), - (BOM: ($00,$3C,$00,$00); Len: 4; Encoding: seUCS4_3412; HasBOM: false), - (BOM: ($00,$3C,$00,$3F); Len: 4; Encoding: seUTF16BE; HasBOM: false), - (BOM: ($3C,$00,$3F,$00); Len: 4; Encoding: seUTF16LE; HasBOM: false), - (BOM: ($3C,$3F,$78,$6D); Len: 4; Encoding: seAnsi; HasBOM: false), - (BOM: ($4C,$6F,$A7,$94); Len: 4; Encoding: seEBCDIC; HasBOM: false) - ); - -// .NET compatible stub for TBytes (array of byte) type -{$IFNDEF CLR} -type - TBytes = TBigByteArray; -{$ENDIF} - -function StrScan(const Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; -begin - Result := Str; - while Result^ <> Chr do - begin - if Result^ = #0 then - begin - Result := nil; - Exit; - end; - Inc(Result); - end; -end; - -function UTF8QuotedStr(const S: UTF8String; Quote: AnsiChar): UTF8String; -var - P, Src, Dest: PAnsiChar; - AddCount: Integer; -begin - AddCount := 0; - P := StrScan(PAnsiChar(S), Quote); - while P <> nil do - begin - Inc(P); - Inc(AddCount); - P := StrScan(P, Quote); - end; - if AddCount = 0 then - begin - Result := UTF8String(Quote) + S + UTF8String(Quote); - Exit; - end; - SetLength(Result, Length(S) + AddCount + 2); - Dest := Pointer(Result); - Dest^ := Quote; - Inc(Dest); - Src := Pointer(S); - P := StrScan(Src, Quote); - repeat - Inc(P); - Move(Src^, Dest^, P - Src); - Inc(Dest, P - Src); - Dest^ := Quote; - Inc(Dest); - Src := P; - P := StrScan(Src, Quote); - until P = nil; - P := StrEnd(Src); - Move(Src^, Dest^, P - Src); - Inc(Dest, P - Src); - Dest^ := Quote; -end; - -function UTF8ExtractQuotedStr(const S: UTF8String; Quote: AnsiChar): UTF8String; -var - P, Src, Dest: PAnsiChar; - DropCount: Integer; -begin - Result := ''; - Src := PAnsiChar(S); - if (Src = nil) or (Src^ <> Quote) then - Exit; - Inc(Src); - DropCount := 1; - P := Src; - Src := StrScan(Src, Quote); - while Src <> nil do - begin - Inc(Src); - if Src^ <> Quote then - Break; - Inc(Src); - Inc(DropCount); - Src := StrScan(Src, Quote); - end; - if Src = nil then - Src := StrEnd(P); - if ((Src - P) <= 1) then - Exit; - if DropCount = 1 then - SetString(Result, P, Src - P - 1) - else - begin - SetLength(Result, Src - P - DropCount); - Dest := PAnsiChar(Result); - Src := StrScan(P, Quote); - while Src <> nil do - begin - Inc(Src); - if Src^ <> Quote then - Break; - Move(P^, Dest^, Src - P); - Inc(Dest, Src - P); - Inc(Src); - P := Src; - Src := StrScan(Src, Quote); - end; - if Src = nil then - Src := StrEnd(P); - Move(P^, Dest^, Src - P - 1); - end; -end; - -function Utf8Pos(const Substr, S: UTF8String): Integer; -var - i, x: Integer; - Len, LenSubStr: Integer; -begin - i := 1; - LenSubStr := Length(SubStr); - Len := Length(S) - LenSubStr + 1; - while i <= Len do - begin - if S[i] = SubStr[1] then - begin - x := 1; - while (x < LenSubStr) and (S[i + x] = SubStr[x + 1]) do - Inc(x); - if (x = LenSubStr) then - begin - Result := i; - exit; - end; - end; - Inc(i); - end; - Result := 0; -end; - -// .NET-compatible TStream.Write - -function StreamWrite(Stream: TStream; const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Offset, Count: Longint): Longint; -begin -{$IFDEF CLR} - Result := Stream.Write(Buffer, Offset, Count); -{$ELSE} - Result := Stream.Write(TBytes(Buffer)[Offset], Count); -{$ENDIF} -end; - -{$IFNDEF CLR} -// Delphi's implementation of TStringStream is severely flawed, it does a SetLength -// on each write, which slows down everything to a crawl. This implementation over- -// comes this issue. -type - TsdUTF8StringStream = class(TMemoryStream) - public - constructor Create(const S: UTF8String); - function DataString: UTF8String; - end; - -constructor TsdUTF8StringStream.Create(const S: UTF8String); -begin - inherited Create; - SetSize(length(S)); - if Size > 0 then - begin - Write(S[1], Size); - Position := 0; - end; -end; - -function TsdUTF8StringStream.DataString: UTF8String; -begin - SetLength(Result, Size); - if Size > 0 then - begin - Position := 0; - Read(Result[1], length(Result)); - end; -end; -{$ELSE} -// In .NET we use the standard TStringStream -type - TsdUTF8StringStream = TStringStream; -{$ENDIF} - -// Utility functions - -function Min(A, B: integer): integer; -begin - if A < B then - Result := A - else - Result := B; -end; - -function Max(A, B: integer): integer; -begin - if A > B then - Result := A - else - Result := B; -end; - -function sdUTF8StringReplace(const S, OldPattern, NewPattern: UTF8String): UTF8String; -var - SearchStr, NewStr: UTF8String; - Offset: Integer; -begin - // Case Sensitive, Replace All - SearchStr := S; - NewStr := S; - Result := ''; - while SearchStr <> '' do - begin - Offset := UTF8Pos(OldPattern, SearchStr); - if Offset = 0 then - begin - Result := Result + NewStr; - Break; - end; - Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern; - NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); - SearchStr := Copy(SearchStr, Offset + Length(OldPattern), MaxInt); - end; -end; - -function sdUTF8EscapeString(const AValue: UTF8String): UTF8String; -var - i: integer; -begin - Result := AValue; - for i := 0 to cEscapeCount - 1 do - Result := sdUTF8StringReplace(Result, cEscapes[i], cReplaces[i]); -end; - -function sdUTF8UnEscapeString(const AValue: UTF8String): UTF8String; -var - SearchStr, Reference, Replace: UTF8String; - i, Offset, Code: Integer; - W: word; -begin - SearchStr := AValue; - Result := ''; - while SearchStr <> '' do - begin - // find '&' - Offset := Utf8Pos('&', SearchStr); - if Offset = 0 then - begin - // Nothing found - Result := Result + SearchStr; - Break; - end; - Result := Result + Copy(SearchStr, 1, Offset - 1); - SearchStr := Copy(SearchStr, Offset, MaxInt); - // find next ';' - Offset := Utf8Pos(';', SearchStr); - if Offset = 0 then - begin - // Error: encountered a '&' but not a ';'.. we will ignore, just return - // the unmodified value - Result := Result + SearchStr; - Break; - end; - // Reference - Reference := copy(SearchStr, 1, Offset); - SearchStr := Copy(SearchStr, Offset + 1, MaxInt); - Replace := Reference; - // See if it is a Character reference - if copy(Reference, 1, 2) = '&#' then - begin - Reference := copy(Reference, 3, length(Reference) - 3); - if length(Reference) > 0 then - begin - if sdUpCase(Reference[1]) = 'X' then - // Hex notation - Reference[1] := '$'; - Code := StrToIntDef(string(Reference), -1); - if (Code >= 0) and (Code < $FFFF) then - begin - W := Code; - {$IFDEF D5UP} - Replace := sdUnicodeToUtf8(UnicodeChar(W)); - {$ELSE} - Replace := AnsiChar(W and $FF); - {$ENDIF} - end; - end; - end else - begin - // Look up default escapes - for i := 0 to cEscapeCount - 1 do - if Reference = cReplaces[i] then - begin - // Replace - Replace := cEscapes[i]; - Break; - end; - end; - // New result - Result := Result + Replace; - end; -end; - -function sdUTF8QuotedString(const AValue: UTF8String): UTF8String; -var - Quote: AnsiChar; -begin - Quote := '"'; - if UTF8Pos('"', AValue) > 0 then - Quote := ''''; -{$IFDEF CLR} - Result := QuotedStr(AValue, AQuoteChar); -{$ELSE} - Result := UTF8QuotedStr(AValue, Quote); -{$ENDIF} -end; - -function sdUTF8UnQuotedString(const AValue: UTF8String): UTF8String; -var - Quote: AnsiChar; -begin - if Length(AValue) < 2 then - begin - Result := AValue; - exit; - end; - Quote := AValue[1]; - if Quote in cQuoteChars then - begin - {$IFDEF CLR} - Result := DequotedStr(AValue, Quote); - {$ELSE} - Result := UTF8ExtractQuotedStr(AValue, Quote); - {$ENDIF} - end else - Result := AValue; -end; - -function sdAddControlChars(const AValue: UTF8String; const Chars: UTF8String; Interval: integer): UTF8String; -// Insert AnsiChars in AValue at each Interval AnsiChars -var - i, j, ALength: integer; - // local - procedure InsertControlChars; - var - k: integer; - begin - for k := 1 to Length(Chars) do - begin - Result[j] := Chars[k]; - inc(j); - end; - end; -// main -begin - if (Length(Chars) = 0) or (Interval <= 0) then - begin - Result := AValue; - exit; - end; - - // Calculate length based on original length and total extra length for control AnsiChars - ALength := Length(AValue) + ((Length(AValue) - 1) div Interval + 3) * Length(Chars); - SetLength(Result, ALength); - - // Copy and insert - j := 1; - for i := 1 to Length(AValue) do - begin - if (i mod Interval) = 1 then - // Insert control AnsiChars - InsertControlChars; - Result[j] := AValue[i]; - inc(j); - end; - InsertControlChars; - - // Adjust length - dec(j); - if ALength > j then - SetLength(Result, j); -end; - -function sdRemoveControlChars(const AValue: UTF8String): UTF8String; -// Remove control characters from UTF8String in AValue -var - i, j: integer; -begin - Setlength(Result, Length(AValue)); - i := 1; - j := 1; - while i <= Length(AValue) do - if AValue[i] in cControlChars then - inc(i) - else - begin - Result[j] := AValue[i]; - inc(i); - inc(j); - end; - // Adjust length - if i <> j then - SetLength(Result, j - 1); -end; - -function sdUTF8FindString(const SubString, S: UTF8String; Start, Close: integer; var APos: integer): boolean; -// Check if the Substring matches the UTF8String S in any position in interval Start to Close - 1 -// and returns found positon in APos. Result = True if anything is found. -// Note: this funtion is case-insensitive -var - CharIndex: integer; -begin - Result := False; - APos := 0; - for CharIndex := Start to Close - Length(SubString) do - if sdUTF8MatchString(SubString, S, CharIndex) then - begin - APos := CharIndex; - Result := True; - exit; - end; -end; - -function UTF8CompareText(const S1, S2: UTF8String): integer; -begin - Result := AnsiCompareText(string(S1), string(S2)); -end; - -function IntToUTF8Str(Value: integer): UTF8String; -begin - Result := UTF8String(IntToStr(Value)); -end; - -function Int64ToUTF8Str(Value: int64): UTF8String; -begin - Result := UTF8String(IntToStr(Value)); -end; - -function sdUTF8MatchString(const SubString: UTF8String; const S: UTF8String; Start: integer): boolean; -// Check if the Substring matches the string S at position Start. -// Note: this funtion is case-insensitive -var - CharIndex: integer; -begin - Result := False; - // Check range just in case - if (Length(S) - Start + 1) < Length(Substring) then - exit; - - CharIndex := 0; - while CharIndex < Length(SubString) do - if sdUpCase(SubString[CharIndex + 1]) = sdUpCase(S[Start + CharIndex]) then - inc(CharIndex) - else - exit; - // All AnsiChars were the same, so we succeeded - Result := True; -end; - -procedure sdUTF8ParseAttributes(const AValue: UTF8String; Start, Close: integer; Attributes: TsdUTF8StringList); -// Convert the attributes string AValue in [Start, Close - 1] to the attributes Stringlist -var - i: integer; - InQuotes: boolean; - Quote: AnsiChar; -begin - InQuotes := False; - Quote := '"'; - if not assigned(Attributes) then - exit; - if not sdUTF8TrimPos(AValue, Start, Close) then - exit; - - // Clear first - Attributes.Clear; - - // Loop through characters - for i := Start to Close - 1 do - begin - - // In quotes? - if InQuotes then - begin - if AValue[i] = Quote then - InQuotes := False; - end else - begin - if AValue[i] in cQuoteChars then - begin - InQuotes := True; - Quote := AValue[i]; - end; - end; - - // Add attribute strings on each controlchar break - if not InQuotes then - if AValue[i] in cControlChars then - begin - if i > Start then - Attributes.Add(copy(AValue, Start, i - Start)); - Start := i + 1; - end; - end; - - // Add last attribute string - if Start < Close then - Attributes.Add(copy(AValue, Start, Close - Start)); - - // First-char "=" signs should append to previous - for i := Attributes.Count - 1 downto 1 do - if Attributes[i][1] = '=' then - begin - Attributes[i - 1] := Attributes[i - 1] + Attributes[i]; - Attributes.Delete(i); - end; - - // First-char quotes should append to previous - for i := Attributes.Count - 1 downto 1 do - if (Attributes[i][1] in cQuoteChars) and (UTF8Pos('=', Attributes[i - 1]) > 0) then - begin - Attributes[i - 1] := Attributes[i - 1] + Attributes[i]; - Attributes.Delete(i); - end; -end; - -function sdUTF8TrimPos(const AValue: UTF8String; var Start, Close: integer): boolean; -// Trim the string in AValue in [Start, Close - 1] by adjusting Start and Close variables -begin - // Checks - Start := Max(1, Start); - Close := Min(Length(AValue) + 1, Close); - if Close <= Start then - begin - Result := False; - exit; - end; - - // Trim left - while - (Start < Close) and - (AValue[Start] in cControlChars) do - inc(Start); - - // Trim right - while - (Start < Close) and - (AValue[Close - 1] in cControlChars) do - dec(Close); - - // Do we have a string left? - Result := Close > Start; -end; - -function sdUTF8Trim(const AValue: UTF8String): UTF8String; -var - Start, Close: integer; - Res: boolean; -begin - Start := 1; - Close := length(AValue) + 1; - Res := sdUTF8TrimPos(AValue, Start, Close); - if Res then - Result := Copy(AValue, Start, Close - Start) - else - Result := ''; -end; - -procedure sdUTF8WriteStringToStream(S: TStream; const AString: UTF8String); -begin - if Length(AString) > 0 then - begin - {$IFDEF CLR} - S.Write(BytesOf(AString), Length(AString)); - {$ELSE} - S.Write(AString[1], Length(AString)); - {$ENDIF} - end; -end; - -function sdUpCase(Ch: AnsiChar): AnsiChar; -begin - Result := Ch; - case Result of - 'a'..'z': Dec(Result, Ord('a') - Ord('A')); - end; -end; - -function ReadOpenTag(AReader: TsdSurplusReader): integer; -// Try to read the type of open tag from S -var - AIndex, i: integer; - Found: boolean; - Ch: AnsiChar; - Candidates: array[0..cTagCount - 1] of boolean; - Surplus: UTF8String; -begin - Surplus := ''; - Result := cTagCount - 1; - for i := 0 to cTagCount - 1 do Candidates[i] := True; - AIndex := 1; - repeat - Found := False; - inc(AIndex); - if AReader.ReadChar(Ch) = 0 then - exit; - Surplus := Surplus + UTF8String(Ch); - for i := cTagCount - 1 downto 0 do - if Candidates[i] and (length(cTags[i].Start) >= AIndex) then - begin - if cTags[i].Start[AIndex] = Ch then - begin - Found := True; - if length(cTags[i].Start) = AIndex then - Result := i; - end else - Candidates[i] := False; - end; - until Found = False; - // The surplus string that we already read (everything after the tag) - AReader.Surplus := copy(Surplus, length(cTags[Result].Start), length(Surplus)); -end; - -function ReadStringFromStreamUntil(AReader: TsdSurplusReader; const ASearch: UTF8String; - var AValue: UTF8String; SkipQuotes: boolean): boolean; -var - AIndex, ValueIndex, SearchIndex: integer; - LastSearchChar, Ch: AnsiChar; - InQuotes: boolean; - QuoteChar: AnsiChar; - SB: TsdStringBuilder; -begin - Result := False; - InQuotes := False; - - // Get last searchstring character - AIndex := length(ASearch); - if AIndex = 0 then exit; - LastSearchChar := ASearch[AIndex]; - - SB := TsdStringBuilder.Create; - try - QuoteChar := #0; - - repeat - // Add characters to the value to be returned - if AReader.ReadChar(Ch) = 0 then - exit; - SB.AddChar(Ch); - - // Do we skip quotes? - if SkipQuotes then - begin - if InQuotes then - begin - if (Ch = QuoteChar) then - InQuotes := false; - end else - begin - if Ch in cQuoteChars then - begin - InQuotes := true; - QuoteChar := Ch; - end; - end; - end; - - // In quotes? If so, we don't check the end condition - if not InQuotes then - begin - // Is the last char the same as the last char of the search string? - if Ch = LastSearchChar then - begin - - // Check to see if the whole search string is present - ValueIndex := SB.Length - 1; - SearchIndex := length(ASearch) - 1; - if ValueIndex < SearchIndex then continue; - - Result := True; - while (SearchIndex > 0)and Result do - begin - Result := SB[ValueIndex] = ASearch[SearchIndex]; - dec(ValueIndex); - dec(SearchIndex); - end; - end; - end; - until Result; - - // Use only the part before the search string - AValue := SB.StringCopy(1, SB.Length - length(ASearch)); - finally - SB.Free; - end; -end; - -function ReadStringFromStreamWithQuotes(S: TStream; const Terminator: UTF8String; - var AValue: UTF8String): boolean; -var - Ch, QuoteChar: AnsiChar; - InQuotes: boolean; - SB: TsdStringBuilder; -begin - SB := TsdStringBuilder.Create; - try - QuoteChar := #0; - Result := False; - InQuotes := False; - repeat - if S.Read(Ch, 1) = 0 then exit; - if not InQuotes then - begin - if (Ch = '"') or (Ch = '''') then - begin - InQuotes := True; - QuoteChar := Ch; - end; - end else - begin - if Ch = QuoteChar then - InQuotes := False; - end; - if not InQuotes and (UTF8String(Ch) = Terminator) then - break; - SB.AddChar(Ch); - until False; - AValue := SB.Value; - Result := True; - finally - SB.Free; - end; -end; - -function sdDateTimeFromString(const ADate: UTF8String): TDateTime; -// Convert the string ADate to a TDateTime according to the W3C date/time specification -// as found here: http://www.w3.org/TR/NOTE-datetime -var - AYear, AMonth, ADay, AHour, AMin, ASec, AMSec: word; -begin - AYear := StrToInt(string(copy(ADate, 1, 4))); - AMonth := StrToInt(string(copy(ADate, 6, 2))); - ADay := StrToInt(string(copy(ADate, 9, 2))); - if Length(ADate) > 16 then - begin - AHour := StrToInt(string(copy(ADate, 12, 2))); - AMin := StrToInt(string(copy(ADate, 15, 2))); - ASec := StrToIntDef(string(copy(ADate, 18, 2)), 0); // They might be omitted, so default to 0 - AMSec := StrToIntDef(string(copy(ADate, 21, 3)), 0); // They might be omitted, so default to 0 - end else - begin - AHour := 0; - AMin := 0; - ASec := 0; - AMSec := 0; - end; - Result := - EncodeDate(AYear, AMonth, ADay) + - EncodeTime(AHour, AMin, ASec, AMSec); -end; - -function sdDateTimeFromStringDefault(const ADate: UTF8String; ADefault: TDateTime): TDateTime; -// Convert the string ADate to a TDateTime according to the W3C date/time specification -// as found here: http://www.w3.org/TR/NOTE-datetime -// If there is a conversion error, the default value ADefault is returned. -begin - try - Result := sdDateTimeFromString(ADate); - except - Result := ADefault; - end; -end; - -function sdDateTimeToString(ADate: TDateTime): UTF8String; -// Convert the TDateTime ADate to a string according to the W3C date/time specification -// as found here: http://www.w3.org/TR/NOTE-datetime -var - AYear, AMonth, ADay, AHour, AMin, ASec, AMSec: word; -begin - DecodeDate(ADate, AYear, AMonth, ADay); - DecodeTime(ADate, AHour, AMin, ASec, AMSec); - if frac(ADate) = 0 then - Result := UTF8String(Format('%.4d-%.2d-%.2d', [AYear, AMonth, ADay])) - else - Result := UTF8String(Format('%.4d-%.2d-%.2dT%.2d:%.2d:%.2d.%.3dZ', - [AYear, AMonth, ADay, AHour, AMin, ASec, AMSec])); -end; - -function sdWriteNumber(Value: double; SignificantDigits: integer; AllowScientific: boolean): UTF8String; -const - Limits: array[1..9] of integer = - (10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000); -var - Limit, Limitd, PointPos, IntVal, ScPower: integer; - Body: UTF8String; -begin - if (SignificantDigits < 1) or (SignificantDigits > 9) then - raise Exception.Create(sxeSignificantDigitsOutOfRange); - - // Zero - if Value = 0 then - begin - Result := '0'; - exit; - end; - - // Sign - if Value < 0 then - begin - Result := '-'; - Value := -Value; - end else - Result := ''; - - // Determine point position - Limit := Limits[SignificantDigits]; - Limitd := Limit div 10; - PointPos := SignificantDigits; - while Value < Limitd do - begin - Value := Value * 10; - dec(PointPos); - end; - while Value >= Limit do - begin - Value := Value * 0.1; - inc(PointPos); - end; - - // Round - IntVal := round(Value); - - // Exceptional case which happens when the value rounds up to the limit - if Intval = Limit then - begin - IntVal := IntVal div 10; - inc(PointPos); - end; - - // Strip off any zeros, these reduce significance count - while (IntVal mod 10 = 0) and (PointPos < SignificantDigits) do - begin - dec(SignificantDigits); - IntVal := IntVal div 10; - end; - - // Check for scientific notation - ScPower := 0; - if AllowScientific and ((PointPos < -1) or (PointPos > SignificantDigits + 2)) then - begin - ScPower := PointPos - 1; - dec(PointPos, ScPower); - end; - - // Body - Body := IntToUTF8Str(IntVal); - while PointPos > SignificantDigits do - begin - Body := Body + '0'; - inc(SignificantDigits); - end; - while PointPos < 0 do - begin - Body := '0' + Body; - inc(PointPos); - end; - if PointPos = 0 then - Body := '.' + Body - else - if PointPos < SignificantDigits then - Body := copy(Body, 1, PointPos) + '.' + copy(Body, PointPos + 1, SignificantDigits); - - // Final result - if ScPower = 0 then - Result := Result + Body - else - Result := Result + Body + 'E' + IntToUTF8Str(ScPower); -end; - -{$IFDEF CLR} - -function sdUnicodeToUtf8(const W: UnicodeString): UTF8String; -begin - Result := Encoding.UTF8.GetBytes(W); -end; - -function sdUtf8ToUnicode(const S: UTF8String): UnicodeString; -begin - Result := Encoding.UTF8.GetString(BytesOf(S)); -end; - -function EncodeBase64Buf(const Buffer: TBytes; Count: Integer): UTF8String; -begin - Result := Convert.ToBase64String(Buffer, 0, Count); -end; - -function EncodeBase64(const Source: UTF8String): UTF8String; -begin - Result := Convert.ToBase64String(BytesOf(Source)); -end; - -procedure DecodeBase64Buf(const Source: UTF8String; var Buffer: TBytes; Count: Integer); -var - ADecoded: TBytes; -begin - ADecoded := Convert.FromBase64String(Source); - if Count > Length(ADecoded) then - raise EFilerError.Create(sxeMissingDataInBinaryStream); - SetLength(ADecoded, Count); - Buffer := ADecoded; -end; - -function DecodeBase64(const Source: UTF8String): UTF8String; -begin - Result := UTF8String(Convert.FromBase64String(Source)); -end; - -{$ELSE} - -function PtrUnicodeToUtf8(Dest: PAnsiChar; MaxDestBytes: Cardinal; Source: PUnicodeChar; SourceChars: Cardinal): Cardinal; -var - i, count: Cardinal; - c: Cardinal; -begin - Result := 0; - if not assigned(Source) or not assigned(Dest) then - exit; - - count := 0; - i := 0; - - while (i < SourceChars) and (count < MaxDestBytes) do - begin - c := Cardinal(Source[i]); - Inc(i); - if c <= $7F then - begin - Dest[count] := AnsiChar(c); - Inc(count); - end else - if c > $7FF then - begin - if count + 3 > MaxDestBytes then - break; - Dest[count] := AnsiChar($E0 or (c shr 12)); - Dest[count+1] := AnsiChar($80 or ((c shr 6) and $3F)); - Dest[count+2] := AnsiChar($80 or (c and $3F)); - Inc(count,3); - end else - begin // $7F < Source[i] <= $7FF - if count + 2 > MaxDestBytes then - break; - Dest[count] := AnsiChar($C0 or (c shr 6)); - Dest[count+1] := AnsiChar($80 or (c and $3F)); - Inc(count,2); - end; - end; - if count >= MaxDestBytes then - count := MaxDestBytes-1; - Dest[count] := #0; - Result := count + 1; // convert zero based index to byte count -end; - -function PtrUtf8ToUnicode(Dest: PUnicodeChar; MaxDestChars: Cardinal; Source: PAnsiChar; - SourceBytes: Cardinal): Cardinal; -var - i, count: Cardinal; - c: Byte; - wc: Cardinal; -begin - if not assigned(Dest) or not assigned(Source) then - begin - Result := 0; - Exit; - end; - Result := Cardinal(-1); - count := 0; - i := 0; - while (i < SourceBytes) and (count < MaxDestChars) do - begin - wc := Cardinal(Source[i]); - Inc(i); - if (wc and $80) <> 0 then - begin - if i >= SourceBytes then - // incomplete multibyte char - Exit; - wc := wc and $3F; - if (wc and $20) <> 0 then - begin - c := Byte(Source[i]); - Inc(i); - if (c and $C0) <> $80 then - // malformed trail byte or out of range char - Exit; - if i >= SourceBytes then - // incomplete multibyte char - Exit; - wc := (wc shl 6) or (c and $3F); - end; - c := Byte(Source[i]); - Inc(i); - if (c and $C0) <> $80 then - // malformed trail byte - Exit; - Dest[count] := UnicodeChar((wc shl 6) or (c and $3F)); - end else - Dest[count] := UnicodeChar(wc); - Inc(count); - end; - - if count >= MaxDestChars then - count := MaxDestChars-1; - - Dest[count] := #0; - Result := count + 1; -end; - -function sdUnicodeToUtf8(const W: UnicodeString): UTF8String; -var - L: integer; - Temp: UTF8String; -begin - Result := ''; - if W = '' then - Exit; - SetLength(Temp, Length(W) * 3); // SetLength includes space for null terminator - - L := PtrUnicodeToUtf8(PAnsiChar(Temp), Length(Temp) + 1, PUnicodeChar(W), Length(W)); - if L > 0 then - SetLength(Temp, L - 1) - else - Temp := ''; - Result := Temp; -end; - -function sdUtf8ToUnicode(const S: UTF8String): UnicodeString; -var - L: Integer; - Temp: UnicodeString; -begin - Result := ''; - if S = '' then - Exit; - SetLength(Temp, Length(S)); - - L := PtrUtf8ToUnicode(PUnicodeChar(Temp), Length(Temp)+1, PAnsiChar(S), Length(S)); - if L > 0 then - SetLength(Temp, L-1) - else - Temp := ''; - Result := Temp; -end; - -function EncodeBase64Buf(const Buffer; Count: Integer): UTF8String; -var - i, j: integer; - ACore: integer; - ALong: cardinal; - S: PByte; -begin - // Make sure ASize is always a multiple of 3, and this multiple - // gets saved as 4 characters - ACore := (Count + 2) div 3; - - // Set the length of the string that stores encoded characters - SetLength(Result, ACore * 4); - S := @Buffer; - // Do the loop ACore times - for i := 0 to ACore - 1 do - begin - ALong := 0; - for j := 0 to 2 do - begin - ALong := ALong shl 8 + S^; - inc(S); - end; - for j := 0 to 3 do - begin - Result[i * 4 + 4 - j] := cBase64Char[ALong and $3F]; - ALong := ALong shr 6; - end; - end; - // For comformity to Base64, we must pad the data instead of zero out - // if the size is not an exact multiple of 3 - case ACore * 3 - Count of - 0:;// nothing to do - 1: // pad one byte - Result[ACore * 4] := cBase64PadChar; - 2: // pad two bytes - begin - Result[ACore * 4 ] := cBase64PadChar; - Result[ACore * 4 - 1] := cBase64PadChar; - end; - end;//case -end; - -function EncodeBase64(const Source: RawByteString): UTF8String; -// Encode binary data in Source as BASE64. The function returns the BASE64 encoded -// data as string, without any linebreaks. -begin - if length(Source) > 0 then - Result := EncodeBase64Buf(Source[1], length(Source)) - else - Result := ''; -end; - -procedure DecodeBase64Buf(var Source: UTF8String; var Buffer; Count: Integer); -var - i, j: integer; - BufPos, Core: integer; - LongVal: cardinal; - D: PByte; - Map: array[AnsiChar] of byte; -begin - // Core * 4 is the number of chars to read - check length - Core := Length(Source) div 4; - if Count > Core * 3 then - raise EFilerError.Create(sxeMissingDataInBinaryStream); - - // Prepare map - for i := 0 to 63 do - Map[cBase64Char[i]] := i; - D := @Buffer; - - // Check for final padding, and replace with "zeros". There can be - // at max two pad chars ('=') - BufPos := length(Source); - if (BufPos > 0) and (Source[BufPos] = cBase64PadChar) then - begin - Source[BufPos] := cBase64Char[0]; - dec(BufPos); - if (BufPos > 0) and (Source[BufPos] = cBase64PadChar) then - Source[BufPos] := cBase64Char[0]; - end; - - // Do this Core times - for i := 0 to Core - 1 do - begin - LongVal := 0; - // Unroll the characters - for j := 0 to 3 do - LongVal := LongVal shl 6 + Map[Source[i * 4 + j + 1]]; - // and unroll the bytes - for j := 2 downto 0 do - begin - // Check overshoot - if integer(D) - integer(@Buffer) >= Count then - exit; - D^ := LongVal shr (j * 8) and $FF; - inc(D); - end; - end; -end; - -function DecodeBase64(const Source: UTF8String): RawByteString; -// Decode BASE64 data in Source into binary data. The function returns the binary -// data as UTF8String. Use a TStringStream to convert this data to a stream. -var - BufData: UTF8String; - BufSize, BufPos: integer; -begin - BufData := sdRemoveControlChars(Source); - - // Determine length of data - BufSize := length(BufData) div 4; - if BufSize * 4 <> length(BufData) then - raise EFilerError.Create(sxeErrorCalcStreamLength); - BufSize := BufSize * 3; - // Check padding AnsiChars - BufPos := length(BufData); - if (BufPos > 0) and (BufData[BufPos] = cBase64PadChar) then - begin - dec(BufPos); - dec(BufSize); - if (BufPos > 0) and (BufData[BufPos] = cBase64PadChar) then - dec(BufSize); - end; - Setlength(Result, BufSize); - - // Decode - if BufSize > 0 then - DecodeBase64Buf(BufData, Result[1], BufSize); -end; - -{$ENDIF} - -function sdAnsiToUtf8(const S: AnsiString): UTF8String; -begin - // We let the OS figure out Ansi<->Unicode - Result := sdUnicodeToUtf8(UnicodeString(S)); -end; - -function sdUtf8ToAnsi(const S: UTF8String): AnsiString; -begin - // We let the OS figure out Ansi<->Unicode. There might be dataloss! - Result := Ansistring(sdUtf8ToUnicode(S)); -end; - -function EncodeBinHexBuf(const Source; Count: Integer): UTF8String; -// Encode binary data in Source as BINHEX. The function returns the BINHEX encoded -// data as UTF8String, without any linebreaks. -var -{$IFDEF CLR} - Text: TBytes; -{$ELSE} - Text: UTF8String; -{$ENDIF} -begin - SetLength(Text, Count * 2); -{$IFDEF CLR} - BinToHex(TBytes(Source), 0, Text, 0, Count); -{$ELSE} - BinToHex(PAnsiChar(@Source), PAnsiChar(Text), Count); -{$ENDIF} - Result := Text; -end; - -function EncodeBinHex(const Source: RawByteString): UTF8String; -// Encode binary data in Source as BINHEX. The function returns the BINHEX encoded -// data as UTF8String, without any linebreaks. -var -{$IFDEF CLR} - Text: TBytes; -{$ELSE} - Text: UTF8String; -{$ENDIF} -begin - SetLength(Text, Length(Source) * 2); -{$IFDEF CLR} - BinToHex(BytesOf(Source), 0, Text, 0, Length(Source)); -{$ELSE} - BinToHex(PAnsiChar(Source), PAnsiChar(Text), Length(Source)); -{$ENDIF} - Result := Text; -end; - -procedure DecodeBinHexBuf(const Source: UTF8String; var Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer); -// Decode BINHEX data in Source into binary data. -begin - if Length(Source) div 2 < Count then - raise EFilerError.Create(sxeMissingDataInBinaryStream); - -{$IFDEF CLR} - HexToBin(BytesOf(Source), 0, Buffer, 0, Count); -{$ELSE} - HexToBin(PAnsiChar(Source), PAnsiChar(@Buffer), Count); -{$ENDIF} -end; - -function DecodeBinHex(const Source: UTF8String): RawByteString; -// Decode BINHEX data in Source into binary data. The function returns the binary -// data as RawByteString. Use a TStringStream to convert this data to a stream. -var - Data: Utf8String; - Size: integer; -{$IFDEF CLR} - Buffer: TBytes; -{$ELSE} - Buffer: RawByteString; -{$ENDIF} -begin - Data := sdRemoveControlChars(Source); - - // Determine length of data - Size := length(Data) div 2; - if Size * 2 <> length(Data) then - raise EFilerError.Create(sxeErrorCalcStreamLength); - - SetLength(Buffer, Size); -{$IFDEF CLR} - HexToBin(BytesOf(Data), 0, Buffer, 0, Size); -{$ELSE} - HexToBin(PAnsiChar(Data), PAnsiChar(Buffer), Size); -{$ENDIF} - Result := Buffer; -end; - -function sdStringToBool(const AValue: UTF8String): boolean; -var - Ch: AnsiChar; -begin - if Length(AValue) > 0 then - begin - Ch := sdUpCase(AValue[1]); - if Ch in ['T', 'Y', '1'] then - begin - Result := True; - exit; - end; - if Ch in ['F', 'N', '0'] then - begin - Result := False; - exit; - end; - end; - raise Exception.Create(sxeCannotConverToBool); -end; - -function sdStringFromBool(ABool: boolean): UTF8String; -const - cBoolValues: array[boolean] of UTF8String = ('false', 'true'); -begin - Result := cBoolValues[ABool]; -end; - -{ TsdUTF8StringList } - -function TsdUTF8StringList.Add(const S: UTF8String): integer; -var - L: integer; -begin - L := Length(FItems); - if L = FCount then - begin - // Increase capacity - SetLength(FItems, FCount + 4); - end; - FItems[FCount] := S; - Result := FCount; - inc(FCount); -end; - -procedure TsdUTF8StringList.Assign(Source: TPersistent); -var - i: integer; - SL: TsdUTF8StringList; -begin - if Source is TsdUTF8StringList then - begin - SL := TsdUTF8StringList(Source); - SetLength(FItems, SL.FCount); - for i := 0 to SL.FCount - 1 do - FItems[i] := SL.FItems[i]; - FCount := SL.FCount; - end else - inherited; -end; - -procedure TsdUTF8StringList.Clear; -begin - FCount := 0; -end; - -procedure TsdUTF8StringList.Delete(Index: Integer); -var - i: integer; -begin - if (Index < 0) or (Index >= Count) then - exit; - for i := Index + 1 to Count - 1 do - FItems[i - 1] := FItems[i]; - dec(FCount); -end; - -function TsdUTF8StringList.GetItems(Index: integer): UTF8String; -begin - if (Index >= 0) and (Index < Count) then - Result := FItems[Index] - else - Result := ''; -end; - -function TsdUTF8StringList.GetNames(Index: integer): UTF8String; -var - P: integer; -begin - Result := Items[Index]; - P := UTF8Pos('=', Result); - if P <> 0 then - SetLength(Result, P - 1) - else - SetLength(Result, 0); -end; - -function TsdUTF8StringList.GetText: UTF8String; -const - cLB: UTF8String = #13#10; -var - i, L, LItem: integer; - P: PAnsiChar; -begin - L := 0; - for i := 0 to Count - 1 do - begin - inc(L, length(FItems[i])); - inc(L, 2); - end; - SetLength(Result, L); - if L = 0 then - exit; - P := @Result[1]; - for i := 0 to Count - 1 do - begin - LItem := length(FItems[i]); - if LItem > 0 then - begin - System.Move(FItems[i][1], P^, LItem); - inc(P, LItem); - end; - System.Move(cLB[1], P^, 2); - inc(P, 2); - end; -end; - -function TsdUTF8StringList.GetValues(const Name: UTF8String): UTF8String; -var - Idx: integer; -begin - Idx := IndexOfName(Name); - if Idx >= 0 then - Result := Copy(FItems[Idx], Length(Name) + 2, MaxInt) - else - Result := ''; -end; - -function TsdUTF8StringList.IndexOfName(const Name: UTF8String): integer; -begin - for Result := 0 to Count - 1 do - begin - if sdUTF8MatchString(Name + '=', FItems[Result], 1) then - exit; - end; - Result := -1; -end; - -procedure TsdUTF8StringList.SetItems(Index: integer; const Value: UTF8String); -begin - if (Index >= 0) and (Index < Count) then - FItems[Index] := Value; -end; - -procedure TsdUTF8StringList.SetValues(const Name, Value: UTF8String); -var - Idx: integer; -begin - Idx := IndexOfName(Name); - if Value <> '' then - begin - if Idx < 0 then - Idx := Add(''); - FItems[Idx] := Name + '=' + Value; - end else - Delete(Idx); -end; - -{ TXmlNode } - -function TXmlNode.AbortParsing: boolean; -begin - Result := assigned(Document) and Document.AbortParsing; -end; - -procedure TXmlNode.Assign(Source: TPersistent); -var - i: integer; - Node: TXmlNode; -begin - if Source is TXmlNode then - begin - // Clear first - Clear; - - // Properties - FElementType := TXmlNode(Source).FElementType; - FName := TXmlNode(Source).FName; - FTag := TXmlNode(Source).FTag; - FValue := TXmlNode(Source).FValue; - - // Attributes - if assigned(TXmlNode(Source).FAttributes) then - begin - CheckCreateAttributesList; - FAttributes.Assign(TXmlNode(Source).FAttributes); - end; - - // Nodes - for i := 0 to TXmlNode(Source).NodeCount - 1 do - begin - Node := NodeNew(''); - Node.Assign(TXmlNode(Source).Nodes[i]); - end; - end else - if Source is TNativeXml then - begin - Assign(TNativeXml(Source).FRootNodes); - end else - inherited; -end; - -procedure TXmlNode.AttributeAdd(const AName, AValue: UTF8String); -var - Attr: UTF8String; -begin - Attr := UTF8String(Format('%s=%s', [AName, sdUTF8QuotedString(sdUTF8EscapeString(AValue))])); - CheckCreateAttributesList; - FAttributes.Add(Attr); -end; - -procedure TXmlNode.AttributeAdd(const AName: UTF8String; AValue: integer); -begin - AttributeAdd(AName, IntToUTF8Str(AValue)); -end; - -procedure TXmlNode.AttributeDelete(Index: integer); -begin - if (Index >= 0) and (Index < AttributeCount) then - FAttributes.Delete(Index); -end; - -procedure TXmlNode.AttributeExchange(Index1, Index2: integer); -var - Temp: UTF8String; -begin - if (Index1 <> Index2) and - (Index1 >= 0) and (Index1 < FAttributes.Count) and - (Index2 >= 0) and (Index2 < FAttributes.Count) then - begin - Temp := FAttributes[Index1]; - FAttributes[Index1] := FAttributes[Index2]; - FAttributes[Index2] := Temp; - end; -end; - -function TXmlNode.AttributeIndexByname(const AName: UTF8String): integer; -// Return the index of the attribute with name AName, or -1 if not found -begin - if assigned(FAttributes) then - Result := FAttributes.IndexOfName(AName) - else - Result := -1; -end; - -procedure TXmlNode.AttributesClear; -begin - FreeAndNil(FAttributes); -end; - -function TXmlNode.BufferLength: integer; -var - BufData: UTF8String; - BufPos: integer; -begin - BufData := sdRemoveControlChars(FValue); - case BinaryEncoding of - xbeBinHex: - begin - Result := length(BufData) div 2; - if Result * 2 <> length(BufData) then - raise EFilerError.Create(sxeErrorCalcStreamLength); - end; - xbeBase64: - begin - Result := length(BufData) div 4; - if Result * 4 <> length(BufData) then - raise EFilerError.Create(sxeErrorCalcStreamLength); - Result := Result * 3; - // Check padding AnsiChars - BufPos := length(BufData); - if (BufPos > 0) and (BufData[BufPos] = cBase64PadChar) then - begin - dec(BufPos); - dec(Result); - if (BufPos > 0) and (BufData[BufPos] = cBase64PadChar) then - dec(Result); - end; - end; - else - Result := 0; // avoid compiler warning - end; -end; - -procedure TXmlNode.BufferRead(var Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer); -// Read data from XML binhex to the buffer -var - BufData: UTF8String; -begin - BufData := sdRemoveControlChars(FValue); - case BinaryEncoding of - xbeBinHex: - DecodeBinHexBuf(BufData, Buffer, Count); - xbeBase64: - DecodeBase64Buf(BufData, Buffer, Count); - end; -end; - -procedure TXmlNode.BufferWrite(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer); -// Write data from the buffer to XML in binhex or base64 format -var - BufData: UTF8String; -begin - if Count > 0 then - case BinaryEncoding of - xbeBinHex: - BufData := EncodeBinHexBuf(Buffer, Count); - xbeBase64: - BufData := EncodeBase64Buf(Buffer, Count); - end; - - // For comformity with Base64, we must add linebreaks each 76 AnsiCharacters - FValue := sdAddControlChars(BufData, GetLineFeed + GetIndent, 76); -end; - -procedure TXmlNode.ChangeDocument(ADocument: TNativeXml); -var - i: integer; -begin - FDocument := ADocument; - for i := 0 to NodeCount - 1 do - Nodes[i].ChangeDocument(ADocument); -end; - -procedure TXmlNode.CheckCreateAttributesList; -begin - if not assigned(FAttributes) then - FAttributes := TsdUTF8StringList.Create; -end; - -procedure TXmlNode.Clear; -begin - // Name + value - FName := ''; - FValue := ''; - // Clear attributes and nodes - AttributesClear; - NodesClear; -end; - -function TXmlNode.CompareNodeName(const NodeName: UTF8String): integer; -begin - // Compare with FullPath or local name based on NodeName's first AnsiCharacter - if length(NodeName) > 0 then - if NodeName[1] = '/' then - begin - // FullPath - Result := UTF8CompareText(FullPath, NodeName); - exit; - end; - // local name - Result := UTF8CompareText(Name, NodeName); -end; - -constructor TXmlNode.Create(ADocument: TNativeXml); -begin - inherited Create; - FDocument := ADocument; -end; - -constructor TXmlNode.CreateName(ADocument: TNativeXml; const AName: UTF8String); -begin - Create(ADocument); - Name := AName; -end; - -constructor TXmlNode.CreateNameValue(ADocument: TNativeXml; const AName, AValue: UTF8String); -begin - Create(ADocument); - Name := AName; - ValueAsString := AValue; -end; - -constructor TXmlNode.CreateType(ADocument: TNativeXml; - AType: TXmlElementType); -begin - Create(ADocument); - FElementType := AType; -end; - -procedure TXmlNode.Delete; -begin - if assigned(Parent) then - Parent.NodeRemove(Self); -end; - -procedure TXmlNode.DeleteEmptyAttributes; -var - i: integer; - V: UTF8String; -begin - for i := AttributeCount - 1 downto 0 do - begin - V := AttributeValue[i]; - if length(V) = 0 then - FAttributes.Delete(i); - end; -end; - -procedure TXmlNode.DeleteEmptyNodes; -var - i: integer; - Node: TXmlNode; -begin - for i := NodeCount - 1 downto 0 do - begin - Node := Nodes[i]; - // Recursive call - Node.DeleteEmptyNodes; - // Check if we should delete child node - if Node.IsEmpty then - NodeDelete(i); - end; -end; - -destructor TXmlNode.Destroy; -begin - NodesClear; - AttributesClear; - inherited; -end; - -function TXmlNode.FindNode(const NodeName: UTF8String): TXmlNode; -// Find the first node which has name NodeName. Contrary to the NodeByName -// function, this function will search the whole subnode tree, using the -// DepthFirst method. -var - i: integer; -begin - Result := nil; - // Loop through all subnodes - for i := 0 to NodeCount - 1 do - begin - Result := Nodes[i]; - // If the subnode has name NodeName then we have a result, exit - if Result.CompareNodeName(NodeName) = 0 then - exit; - // If not, we will search the subtree of this node - Result := Result.FindNode(NodeName); - if assigned(Result) then - exit; - end; -end; - -procedure TXmlNode.FindNodes(const NodeName: UTF8String; const AList: TList); - // local - procedure FindNodesRecursive(ANode: TXmlNode; AList: TList); - var - i: integer; - begin - with ANode do - for i := 0 to NodeCount - 1 do - begin - if Nodes[i].CompareNodeName(NodeName) = 0 then - AList.Add(Nodes[i]); - FindNodesRecursive(Nodes[i], AList); - end; - end; -// main -begin - AList.Clear; - FindNodesRecursive(Self, AList); -end; - -function TXmlNode.FloatAllowScientific: boolean; -begin - if assigned(Document) then - Result := Document.FloatAllowScientific - else - Result := cDefaultFloatAllowScientific; -end; - -function TXmlNode.FloatSignificantDigits: integer; -begin - if assigned(Document) then - Result := Document.FloatSignificantDigits - else - Result := cDefaultFloatSignificantDigits; -end; - -function TXmlNode.FromAnsiString(const s: AnsiString): UTF8String; -begin - Result := sdAnsiToUtf8(s) -end; - -function TXmlNode.FromUnicodeString(const W: UnicodeString): UTF8String; -begin - Result := sdUnicodeToUtf8(W) -end; - -function TXmlNode.GetAttributeByName(const AName: UTF8String): UTF8String; -begin - if assigned(FAttributes) then - Result := sdUTF8UnEscapeString(sdUTF8UnQuotedString(FAttributes.Values[AName])) - else - Result := ''; -end; - -function TXmlNode.GetAttributeByNameWide(const AName: UTF8String): UnicodeString; -begin - Result := ToUnicodeString(GetAttributeByName(AName)); -end; - -function TXmlNode.GetAttributeCount: integer; -begin - if assigned(FAttributes) then - Result := FAttributes.Count - else - Result := 0; -end; - -function TXmlNode.GetAttributeName(Index: integer): UTF8String; -begin - if (Index >= 0) and (Index < AttributeCount) then - Result := FAttributes.Names[Index]; -end; - -function TXmlNode.GetAttributePair(Index: integer): UTF8String; -begin - if (Index >= 0) and (Index < AttributeCount) then - Result := FAttributes[Index]; -end; - -function TXmlNode.GetAttributeValue(Index: integer): UTF8String; -var - P: integer; - S: UTF8String; -begin - Result := ''; - if (Index >= 0) and (Index < AttributeCount) then - begin - S := FAttributes[Index]; - P := Utf8Pos('=', S); - if P > 0 then - Result := sdUTF8UnEscapeString(sdUTF8UnQuotedString(Copy(S, P + 1, MaxInt))); - end; -end; - -function TXmlNode.GetAttributeValueAsInteger(Index: integer): integer; -begin - Result := StrToIntDef(string(GetAttributeValue(Index)), 0); -end; - -function TXmlNode.GetAttributeValueAsUnicodeString(Index: integer): UnicodeString; -begin - Result := ToUnicodeString(GetAttributeValue(Index)); -end; - -function TXmlNode.GetAttributeValueDirect(Index: integer): UTF8String; -var - P: integer; - S: UTF8String; -begin - Result := ''; - if (Index >= 0) and (Index < AttributeCount) then - begin - S := FAttributes[Index]; - P := Utf8Pos('=', S); - if P > 0 then - Result := sdUTF8UnQuotedString(Copy(S, P + 1, MaxInt)); - end; -end; - -function TXmlNode.GetBinaryEncoding: TBinaryEncodingType; -begin - Result := xbeBinHex; - if assigned(Document) then - Result := Document.BinaryEncoding; -end; - -function TXmlNode.GetBinaryString: RawByteString; -// Get the binary contents of this node as Base64 and return it as a RawByteString -var - OldEncoding: TBinaryEncodingType; -{$IFDEF CLR} - Buffer: TBytes; -{$ENDIF} -begin - // Set to base64 - OldEncoding := BinaryEncoding; - try - BinaryEncoding := xbeBase64; - {$IFDEF CLR} - SetLength(Buffer, BufferLength); - if length(Buffer) > 0 then - BufferRead(Buffer, length(Buffer)); - Result := Buffer; - {$ELSE} - SetLength(Result, BufferLength); - if length(Result) > 0 then - BufferRead(Result[1], length(Result)); - {$ENDIF} - finally - BinaryEncoding := OldEncoding; - end; -end; - -function TXmlNode.GetCascadedName: UTF8String; -// Return the name+index and all predecessors with underscores to separate, in -// order to get a unique reference that can be used in filenames -var - LName: UTF8String; -begin - LName := UTF8String(Format('%s%.4d', [Name, StrToIntDef(string(AttributeByName['Index']), 0)])); - if assigned(Parent) then - Result := UTF8String(Format('%s_%s', [Parent.CascadedName, LName])) - else - Result := LName; -end; - -function TXmlNode.GetFullPath: UTF8String; -// GetFullpath will return the complete path of the node from the root, e.g. -// /Root/SubNode1/SubNode2/ThisNode -begin - Result := '/' + Name; - if Treedepth > 0 then - // Recursive call - Result := Parent.GetFullPath + Result; -end; - -function TXmlNode.GetIndent: UTF8String; -var - i: integer; -begin - if assigned(Document) then - begin - case Document.XmlFormat of - xfCompact: Result := ''; - xfReadable: - for i := 0 to TreeDepth - 1 do - Result := Result + Document.IndentString; - end; //case - end else - Result := '' -end; - -function TXmlNode.GetLineFeed: UTF8String; -begin - if assigned(Document) then - begin - case Document.XmlFormat of - xfCompact: Result := ''; - xfReadable: Result := #13#10; - else - Result := #10; - end; //case - end else - Result := ''; -end; - -function TXmlNode.GetNodeCount: integer; -begin - if Assigned(FNodes) then - Result := FNodes.Count - else - Result := 0; -end; - -function TXmlNode.GetNodes(Index: integer): TXmlNode; -begin - if (Index >= 0) and (Index < NodeCount) then - Result := TXmlNode(FNodes[Index]) - else - Result := nil; -end; - -function TXmlNode.GetTotalNodeCount: integer; -var - i: integer; -begin - Result := NodeCount; - for i := 0 to NodeCount - 1 do - inc(Result, Nodes[i].TotalNodeCount); -end; - -function TXmlNode.GetTreeDepth: integer; -begin - Result := -1; - if assigned(Parent) then - Result := Parent.TreeDepth + 1; -end; - -function TXmlNode.GetValueAsBool: boolean; -begin - Result := sdStringToBool(FValue); -end; - -function TXmlNode.GetValueAsDateTime: TDateTime; -begin - Result := sdDateTimeFromString(ValueAsString); -end; - -function TXmlNode.GetValueAsFloat: double; -var - Code: integer; -begin - val(string(sdUTF8StringReplace(FValue, ',', '.')), Result, Code); - if Code > 0 then - raise Exception.Create(sxeCannotConvertToFloat); -end; - -function TXmlNode.GetValueAsInt64: int64; -begin - Result := StrToInt64(string(FValue)); -end; - -function TXmlNode.GetValueAsInteger: integer; -begin - Result := StrToInt(string(FValue)); -end; - -function TXmlNode.GetValueAsString: UTF8String; -begin - Result := UnEscapeString(FValue); -end; - -function TXmlNode.GetValueAsUnicodeString: UnicodeString; -begin - Result := ToUnicodeString(ValueAsString); -end; - -function TXmlNode.GetWriteOnDefault: boolean; -begin - Result := True; - if assigned(Document) then - Result := Document.WriteOnDefault; -end; - -function TXmlNode.HasAttribute(const AName: UTF8String): boolean; -begin - if assigned(FAttributes) then - Result := FAttributes.IndexOfName(AName) >= 0 - else - Result := False; -end; - -function TXmlNode.IndexInParent: integer; -// Retrieve our index in the parent's nodelist -begin - Result := -1; - if assigned(Parent) then - Result := Parent.FNodes.IndexOf(Self); -end; - -function TXmlNode.IsClear: boolean; -begin - Result := (Length(FName) = 0) and IsEmpty; -end; - -function TXmlNode.IsEmpty: boolean; -begin - Result := (Length(FValue) = 0) and (NodeCount = 0) and (AttributeCount = 0); -end; - -function TXmlNode.IsEqualTo(ANode: TXmlNode; Options: TXmlCompareOptions; - MismatchNodes: TList): boolean; -var - i, Index: integer; - NodeResult, ChildResult: boolean; -begin - // Start with a negative result - Result := False; - NodeResult := False; - if not assigned(ANode) then - exit; - - // Assume childs equals other node's childs - ChildResult := True; - - // child node names and values - this comes first to assure the lists are filled - if (xcChildNames in Options) or (xcChildValues in Options) or (xcRecursive in Options) then - for i := 0 to NodeCount - 1 do - begin - // Do child name check - Index := ANode.NodeIndexByName(Nodes[i].Name); - // Do we have the childnode in the other? - if Index < 0 then - begin - // No we dont have it - if xcChildNames in Options then - begin - if assigned(MismatchNodes) then MismatchNodes.Add(Nodes[i]); - ChildResult := False; - end; - end else - begin - // Do child value check - if xcChildValues in Options then - if UTF8CompareText(Nodes[i].ValueAsString, ANode.Nodes[Index].ValueAsString) <> 0 then - begin - if assigned(MismatchNodes) then - MismatchNodes.Add(Nodes[i]); - ChildResult := False; - end; - // Do recursive check - if xcRecursive in Options then - if not Nodes[i].IsEqualTo(ANode.Nodes[Index], Options, MismatchNodes) then - ChildResult := False; - end; - end; - - try - // We assume there are differences - NodeResult := False; - - // Node name, type and value - if xcNodeName in Options then - if UTF8CompareText(Name, ANode.Name) <> 0 then - exit; - - if xcNodeType in Options then - if ElementType <> ANode.ElementType then - exit; - - if xcNodeValue in Options then - if UTF8CompareText(ValueAsString, ANode.ValueAsString) <> 0 then - exit; - - // attribute count - if xcAttribCount in Options then - if AttributeCount <> ANode.AttributeCount then - exit; - - // attribute names and values - if (xcAttribNames in Options) or (xcAttribValues in Options) then - for i := 0 to AttributeCount - 1 do - begin - Index := ANode.AttributeIndexByName(AttributeName[i]); - if Index < 0 then - if xcAttribNames in Options then - exit - else - continue; - if xcAttribValues in Options then - if UTF8CompareText(AttributeValue[i], ANode.AttributeValue[Index]) <> 0 then - exit; - end; - - // child node count - if xcChildCount in Options then - if NodeCount <> ANode.NodeCount then - exit; - - // If we arrive here, it means no differences were found, return True - NodeResult := True; - - finally - - Result := ChildResult and NodeResult; - if (not NodeResult) and assigned(MismatchNodes) then - MismatchNodes.Insert(0, Self); - - end; -end; - -function TXmlNode.NodeAdd(ANode: TXmlNode): integer; -begin - if assigned(ANode) then - begin - ANode.Parent := Self; - ANode.ChangeDocument(Document); - if not assigned(FNodes) then - FNodes := TList.Create; - Result := FNodes.Add(ANode); - end else - Result := -1; -end; - -function TXmlNode.NodeByAttributeValue(const NodeName, AttribName, AttribValue: UTF8String; - ShouldRecurse: boolean): TXmlNode; -// This function returns a pointer to the first subnode that has an attribute with -// name AttribName and value AttribValue. -var - i: integer; - Node: TXmlNode; -begin - Result := nil; - // Find all nodes that are potential results - for i := 0 to NodeCount - 1 do - begin - Node := Nodes[i]; - if (UTF8CompareText(Node.Name, NodeName) = 0) and - Node.HasAttribute(AttribName) and - (UTF8CompareText(Node.AttributeByName[AttribName], AttribValue) = 0) then - begin - Result := Node; - exit; - end; - // Recursive call - if ShouldRecurse then - Result := Node.NodeByAttributeValue(NodeName, AttribName, AttribValue, True); - if assigned(Result) then - exit; - end; -end; - -function TXmlNode.NodeByElementType(ElementType: TXmlElementType): TXmlNode; -var - i: integer; -begin - Result := nil; - for i := 0 to NodeCount - 1 do - if Nodes[i].ElementType = ElementType then - begin - Result := Nodes[i]; - exit; - end; -end; - -function TXmlNode.NodeByName(const AName: UTF8String): TXmlNode; -var - i: integer; -begin - Result := nil; - for i := 0 to NodeCount - 1 do - if UTF8CompareText(Nodes[i].Name, AName) = 0 then - begin - Result := Nodes[i]; - exit; - end; -end; - -procedure TXmlNode.NodeDelete(Index: integer); -begin - if (Index >= 0) and (Index < NodeCount) then - begin - TXmlNode(FNodes[Index]).Free; - FNodes.Delete(Index); - end; -end; - -procedure TXmlNode.NodeExchange(Index1, Index2: integer); -begin - if (Index1 >= 0) and (Index1 < Nodecount) and - (Index2 >= 0) and (Index2 < Nodecount) then - FNodes.Exchange(Index1, Index2); -end; - -function TXmlNode.NodeExtract(ANode: TXmlNode): TXmlNode; -var - Index: integer; -begin - // Compatibility with Delphi4 - Result := nil; - if assigned(FNodes) then - begin - Index := FNodes.IndexOf(ANode); - if Index >= 0 then begin - Result := ANode; - FNodes.Delete(Index); - end; - end; -end; - -function TXmlNode.NodeFindOrCreate(const AName: UTF8String): TXmlNode; -// Find the node with AName, and if not found, add new one -begin - Result := NodeByName(AName); - if not assigned(Result) then - Result := NodeNew(AName); -end; - -function TXmlNode.NodeIndexByName(const AName: UTF8String): integer; -begin - Result := 0; - while Result < NodeCount do - begin - if UTF8CompareText(Nodes[Result].Name, AName) = 0 then - exit; - inc(Result); - end; - if Result = NodeCount then - Result := -1; -end; - -function TXmlNode.NodeIndexByNameFrom(const AName: UTF8String; AFrom: integer): integer; -begin - Result := AFrom; - while Result < NodeCount do - begin - if UTF8CompareText(Nodes[Result].Name, AName) = 0 then - exit; - inc(Result); - end; - if Result = NodeCount then - Result := -1; -end; - -function TXmlNode.NodeIndexOf(ANode: TXmlNode): integer; -begin - if assigned(ANode) and assigned(FNodes) then - Result := FNodes.IndexOf(ANode) - else - Result := -1; -end; - -procedure TXmlNode.NodeInsert(Index: integer; ANode: TXmlNode); -// Insert the node ANode at location Index in the list. -begin - if not assigned(ANode) then - exit; - if (Index >=0) and (Index <= NodeCount) then - begin - if not assigned(FNodes) then - FNodes := TList.Create; - ANode.Parent := Self; - FNodes.Insert(Index, ANode); - end; -end; - -function TXmlNode.NodeNew(const AName: UTF8String): TXmlNode; -// Add a new child node and return its pointer -begin - Result := Nodes[NodeAdd(TXmlNode.CreateName(Document, AName))]; -end; - -function TXmlNode.NodeNewAtIndex(Index: integer; const AName: UTF8String): TXmlNode; -// Create a new node with AName, and insert it into the subnode list at location -// Index, and return a pointer to it. -begin - if (Index >= 0) and (Index <= NodeCount) then - begin - Result := TXmlNode.CreateName(Document, AName); - NodeInsert(Index, Result); - end else - Result := nil; -end; - -function TXmlNode.NodeRemove(ANode: TxmlNode): integer; -begin - Result := NodeIndexOf(ANode); - if Result >= 0 then - NodeDelete(Result); -end; - -procedure TXmlNode.NodesByName(const AName: UTF8String; const AList: TList); -// Fill AList with nodes that have name AName -var - i: integer; -begin - if not assigned(AList) then - exit; - AList.Clear; - for i := 0 to NodeCount - 1 do - if UTF8CompareText(Nodes[i].Name, AName) = 0 then - AList.Add(Nodes[i]); -end; - -procedure TXmlNode.NodesClear; -var - i: integer; -begin - for i := 0 to NodeCount - 1 do - TXmlNode(FNodes[i]).Free; - FreeAndNil(FNodes); -end; - -procedure TXmlNode.ParseTag(const AValue: UTF8String; TagStart, TagClose: integer); -var - LItems: TsdUTF8StringList; -begin - // Create a list to hold string items - LItems := TsdUTF8StringList.Create; - try - sdUTF8ParseAttributes(AValue, TagStart, TagClose, LItems); - - // Determine name, attributes or value for each element type - case ElementType of - xeDeclaration: - FName := 'xml'; - xeStyleSheet: - begin - FName := 'xml-stylesheet'; - // We also set this as the value for use in "StyleSheetString" - ValueDirect := sdUTF8Trim(copy(AValue, TagStart, TagClose - TagStart)); - end; - else - // First item is the name - is it there? - if LItems.Count = 0 then - raise EFilerError.Create(sxeMissingElementName); - - // Set the name - using the element instead of property for speed - FName := LItems[0]; - LItems.Delete(0); - end;//case - - // Any attributes? - if LItems.Count > 0 then - begin - CheckCreateAttributesList; - FAttributes.Assign(LItems); - end; - - finally - LItems.Free; - end; -end; - -function TXmlNode.QualifyAsDirectNode: boolean; -// If this node qualifies as a direct node when writing, we return True. -// A direct node may have attributes, but no value or subnodes. Furhtermore, -// the root node will never be displayed as a direct node. -begin - Result := - (Length(FValue) = 0) and - (NodeCount = 0) and - (ElementType = xeNormal) and - not UseFullNodes and - (TreeDepth > 0); -end; - -function TXmlNode.ReadAttributeBool(const AName: UTF8String; ADefault: boolean): boolean; -var - V: UTF8String; -begin - V := AttributeByName[AName]; - try - Result := sdStringToBool(V); - except - Result := ADefault; - end; -end; - -function TXmlNode.ReadAttributeDateTime(const AName: UTF8String; ADefault: TDateTime): TDateTime; -var - V: UTF8String; -begin - V := AttributeByName[AName]; - try - Result := sdDateTimeFromStringDefault(V, ADefault); - except - Result := ADefault; - end; -end; - -function TXmlNode.ReadAttributeFloat(const AName: UTF8String; ADefault: double): double; -var - V: UTF8String; - Code: integer; -begin - V := AttributeByName[AName]; - val(string(sdUTF8StringReplace(V, ',', '.')), Result, Code); - if Code > 0 then - Result := ADefault; -end; - -function TXmlNode.ReadAttributeInteger(const AName: UTF8String; ADefault: integer): integer; -begin - Result := StrToIntDef(string(AttributeByName[AName]), ADefault); -end; - -function TXmlNode.ReadAttributeInt64(const AName: UTF8String; ADefault: int64): int64; -begin - Result := StrToInt64Def(string(AttributeByName[AName]), ADefault); -end; - -function TXmlNode.ReadAttributeString(const AName: UTF8String; const ADefault: UTF8String): UTF8String; -begin - Result := AttributeByName[AName]; - if length(Result) = 0 then - Result := ADefault; -end; - -function TXmlNode.ReadBool(const AName: UTF8String; ADefault: boolean): boolean; -var - Index: integer; -begin - Result := ADefault; - Index := NodeIndexByName(AName); - if Index >= 0 then - Result := Nodes[Index].ValueAsBoolDef(ADefault); -end; - -{$IFDEF USEGRAPHICS} -procedure TXmlNode.ReadBrush(const AName: UTF8String; ABrush: TBrush); -var - Child: TXmlNode; -begin - Child := NodeByName(AName); - if assigned(Child) then with Child do - begin - // Read values - ABrush.Color := ReadColor('Color', clWhite); - ABrush.Style := TBrushStyle(ReadInteger('Style', integer(bsSolid))); - end else - begin - // Defaults - ABrush.Bitmap := nil; - ABrush.Color := clWhite; - ABrush.Style := bsSolid; - end; -end; - -function TXmlNode.ReadColor(const AName: UTF8String; ADefault: TColor): TColor; -var - Index: integer; -begin - Result := ADefault; - Index := NodeIndexByName(AName); - if Index >= 0 then - Result := StrToInt(string(Nodes[Index].ValueAsString)); -end; -{$ENDIF} - -function TXmlNode.ReadDateTime(const AName: UTF8String; ADefault: TDateTime): TDateTime; -// Date MUST always be written in this format: -// YYYY-MM-DD (if just date) or -// YYYY-MM-DDThh:mm:ss.sssZ (if date and time. The Z stands for universal time -// zone. Since Delphi's TDateTime does not give us a clue about the timezone, -// this is the easiest solution) -// This format SHOULD NOT be changed, to avoid all kinds of -// conversion errors in future. -// This format is compatible with the W3C date/time specification as found here: -// http://www.w3.org/TR/NOTE-datetime -begin - Result := sdDateTimeFromStringDefault(ReadString(AName, ''), ADefault); -end; - -function TXmlNode.ReadFloat(const AName: UTF8String; ADefault: double): double; -var - Index: integer; -begin - Result := ADefault; - Index := NodeIndexByName(AName); - if Index >= 0 then - Result := Nodes[Index].ValueAsFloatDef(ADefault); -end; - -{$IFDEF USEGRAPHICS} -procedure TXmlNode.ReadFont(const AName: UTF8String; AFont: TFont); -var - Child: TXmlNode; -begin - Child := NodeByName(AName); - AFont.Style := []; - if assigned(Child) then with Child do - begin - // Read values - AFont.Name := string(ReadString('Name', 'Arial')); - AFont.Color := ReadColor('Color', clBlack); - AFont.Size := ReadInteger('Size', 14); - if ReadBool('Bold', False) then AFont.Style := AFont.Style + [fsBold]; - if ReadBool('Italic', False) then AFont.Style := AFont.Style + [fsItalic]; - if ReadBool('Underline', False) then AFont.Style := AFont.Style + [fsUnderline]; - if ReadBool('Strikeout', False) then AFont.Style := AFont.Style + [fsStrikeout]; - end else - begin - // Defaults - AFont.Name := 'Arial'; - AFont.Color := clBlack; - AFont.Size := 14; - end; -end; -{$ENDIF} - -procedure TXmlNode.ReadFromStream(S: TStream); -// Read the node from the starting "<" until the closing ">" from the stream in S. -// This procedure also calls OnNodeNew and OnNodeLoaded events -var - Ch: AnsiChar; - i: integer; - TagIndex: integer; - V: UTF8String; - Len: integer; - Node: TXmlNode; - NodeValue: UTF8String; - ValuePos, ValueLen: integer; - ClosePos: integer; - HasCR: boolean; - HasSubtags: boolean; - Words: TsdUTF8StringList; - IsDirect: boolean; - Reader: TsdSurplusReader; - // local - procedure AddCharDataNode(PreserveWhiteSpace: boolean); - var - V: UTF8String; - Node: TXmlNode; - L: integer; - begin - // Add all text up till now as xeCharData - if ValuePos > 0 then - begin - V := copy(NodeValue, 1, ValuePos); - - if PreserveWhiteSpace then - L := length(V) - else - L := length(sdUTF8Trim(V)); - - if L > 0 then - begin - Node := TXmlNode.CreateType(Document, xeCharData); - Node.ValueDirect := V; - NodeAdd(Node); - end; - ValuePos := 0; - end; - end; -// Main -begin - // Check if we aborted parsing - if AbortParsing then - exit; - // Clear this node first - Clear; - // Initial reserve textual value: just 80 AnsiCharacters which is OK for most short values - ValuePos := 0; - ValueLen := 80; - SetLength(NodeValue, ValueLen); - HasCR := False; - HasSubTags := False; - Reader := TsdSurplusReader.Create(S); - try - // Trailing blanks/controls AnsiChars? - if not Reader.ReadCharSkipBlanks(Ch) then - exit; - - // What is it? - if Ch = '<' then - begin - // A tag - which one? - TagIndex := ReadOpenTag(Reader); - if TagIndex >= 0 then - begin - try - ElementType := cTags[TagIndex].Style; - case ElementType of - xeNormal, xeDeclaration, xeStyleSheet: - begin - // These tags we will process - ReadStringFromStreamUntil(Reader, cTags[TagIndex].Close, V, True); - Len := length(V); - - // Is it a direct tag? - IsDirect := False; - if (ElementType = xeNormal) and (Len > 0) then - if V[Len] = '/' then - begin - dec(Len); - IsDirect := True; - end; - ParseTag(V, 1, Len + 1); - - // Here we know our name so good place to call OnNodeNew event - if assigned(Document) then - begin - Document.DoNodeNew(Self); - if AbortParsing then - exit; - end; - - // Now the tag can be a direct close - in that case we're finished - if IsDirect or (ElementType in [xeDeclaration, xeStyleSheet]) then - exit; - - // Process rest of tag - repeat - - // Read AnsiCharacter from stream - if S.Read(Ch, 1) <> 1 then - raise EFilerError.CreateFmt(sxeMissingCloseTag, [Name]); - - // Is there a subtag? - if Ch = '<' then - begin - if not Reader.ReadCharSkipBlanks(Ch) then - raise EFilerError.CreateFmt(sxeMissingDataAfterGreaterThan, [Name]); - if Ch = '/' then - begin - - // This seems our closing tag - if not ReadStringFromStreamUntil(Reader, '>', V, True) then - raise EFilerError.CreateFmt(sxeMissingLessThanInCloseTag, [Name]); - if UTF8CompareText(sdUTF8Trim(V), Name) <> 0 then - raise EFilerError.CreateFmt(sxeIncorrectCloseTag, [Name]); - V := ''; - break; - - end else - begin - - // Add all text up till now as xeCharData - AddCharDataNode(False); - - // Reset the HasCR flag if we add node, we only want to detect - // the CR after last subnode - HasCR := False; - - // This is a subtag... so create it and let it process - HasSubTags := True; - S.Seek(-2, soCurrent); - Node := TXmlNode.Create(Document); - NodeAdd(Node); - Node.ReadFromStream(S); - - // Check for dropping comments - if assigned(Document) and Document.DropCommentsOnParse and - (Node.ElementType = xeComment) then - NodeDelete(NodeIndexOf(Node)); - - end; - end else - begin - - // If we detect a CR we will set the flag. This will signal the fact - // that this XML file was saved with xfReadable - if Ch = #13 then - HasCR := True; - - // Add the AnsiCharacter to the node value buffer. - inc(ValuePos); - if ValuePos > ValueLen then - begin - inc(ValueLen, cNodeValueBuf); - SetLength(NodeValue, ValueLen); - end; - NodeValue[ValuePos] := Ch; - - end; - until False or AbortParsing; - - // Add all text up till now as xeText - AddCharDataNode(not HasSubtags); - - // Check AnsiCharData nodes, remove trailing CRLF + indentation if we - // were in xfReadable mode - if HasSubtags and HasCR then - begin - for i := 0 to NodeCount - 1 do - if Nodes[i].ElementType = xeCharData then - begin - ClosePos := length(Nodes[i].FValue); - while (ClosePos > 0) and (Nodes[i].FValue[ClosePos] in [#10, #13, ' ']) do - dec(ClosePos); - Nodes[i].FValue := copy(Nodes[i].FValue, 1, ClosePos); - end; - end; - - // If the first node is xeCharData we use it as ValueDirect - if NodeCount > 0 then - if Nodes[0].ElementType = xeCharData then - begin - ValueDirect := Nodes[0].ValueDirect; - NodeDelete(0); - end; - - end; - xeDocType: - begin - Name := 'DTD'; - if assigned(Document) then - begin - Document.DoNodeNew(Self); - if AbortParsing then - exit; - end; - // Parse DTD - if assigned(Document) then - Document.ParseDTD(Self, S); - end; - xeElement, xeAttList, xeEntity, xeNotation: - begin - // DTD elements - ReadStringFromStreamWithQuotes(S, cTags[TagIndex].Close, V); - Len := length(V); - Words := TsdUTF8StringList.Create; - try - sdUTF8ParseAttributes(V, 1, Len + 1, Words); - if Words.Count > 0 then - begin - Name := Words[0]; - Words.Delete(0); - end; - ValueDirect := sdUTF8Trim(Words.Text); - finally - Words.Free; - end; - if assigned(Document) then - begin - Document.DoNodeNew(Self); - if AbortParsing then - exit; - end; - end; - else - case ElementType of - xeComment: Name := 'Comment'; - xeCData: Name := 'CData'; - xeExclam: Name := 'Special'; - xeQuestion: Name := 'Special'; - else - Name := 'Unknown'; - end; //case - - // Here we know our name so good place to call OnNodeNew - if assigned(Document) then - begin - Document.DoNodeNew(Self); - if AbortParsing then - exit; - end; - - // In these cases just get all data up till the closing tag - ReadStringFromStreamUntil(Reader, cTags[TagIndex].Close, V, False); - ValueDirect := V; - end;//case - finally - // Call the OnNodeLoaded and OnProgress events - if assigned(Document) and not AbortParsing then - begin - Document.DoProgress(S.Position); - Document.DoNodeLoaded(Self); - end; - end; - end; - end; - finally - Reader.Free; - end; -end; - -procedure TXmlNode.ReadFromString(const AValue: UTF8String); -var - S: TStream; -begin - S := TsdUTF8StringStream.Create(AValue); - try - ReadFromStream(S); - finally - S.Free; - end; -end; - -function TXmlNode.ReadInt64(const AName: UTF8String; ADefault: int64): int64; -var - Index: integer; -begin - Result := ADefault; - Index := NodeIndexByName(AName); - if Index >= 0 then - Result := Nodes[Index].ValueAsInt64Def(ADefault); -end; - -function TXmlNode.ReadInteger(const AName: UTF8String; ADefault: integer): integer; -var - Index: integer; -begin - Result := ADefault; - Index := NodeIndexByName(AName); - if Index >= 0 then - Result := Nodes[Index].ValueAsIntegerDef(ADefault); -end; - -{$IFDEF USEGRAPHICS} -procedure TXmlNode.ReadPen(const AName: UTF8String; APen: TPen); -var - Child: TXmlNode; -begin - Child := NodeByName(AName); - if assigned(Child) then with Child do - begin - // Read values - APen.Color := ReadColor('Color', clBlack); - APen.Mode := TPenMode(ReadInteger('Mode', integer(pmCopy))); - APen.Style := TPenStyle(ReadInteger('Style', integer(psSolid))); - APen.Width := ReadInteger('Width', 1); - end else - begin - // Defaults - APen.Color := clBlack; - APen.Mode := pmCopy; - APen.Style := psSolid; - APen.Width := 1; - end; -end; -{$ENDIF} - -function TXmlNode.ReadString(const AName: UTF8String; const ADefault: UTF8String): UTF8String; -var - Index: integer; -begin - Result := ADefault; - Index := NodeIndexByName(AName); - if Index >= 0 then - Result := Nodes[Index].ValueAsString; -end; - -function TXmlNode.ReadUnicodeString(const AName: UTF8String; const ADefault: UnicodeString): UnicodeString; -begin - Result := ToUnicodeString(ReadString(AName, FromUnicodeString(ADefault))); -end; - -procedure TXmlNode.ResolveEntityReferences; -// Replace any entity references by the entities, and parse the new content if any - // local - function SplitReference(const AValue: UTF8String; var Text1, Text2: UTF8String): UTF8String; - var - P: integer; - begin - Result := ''; - P := UTF8Pos('&', AValue); - Text1 := ''; - Text2 := AValue; - if P = 0 then - exit; - Text1 := copy(AValue, 1, P - 1); - Text2 := copy(AValue, P + 1, length(AValue)); - P := UTF8Pos(';', Text2); - if P = 0 then - exit; - Result := copy(Text2, 1, P - 1); - Text2 := copy(Text2, P + 1, length(Text2)); - end; - // local - function ReplaceEntityReferenceByNodes(ARoot: TXmlNode; const AValue: UTF8String; var InsertPos: integer; var Text1, Text2: UTF8String): boolean; - var - Reference: UTF8String; - Entity: UTF8String; - Node: TXmlNode; - S: TStream; - begin - Result := False; - Reference := SplitReference(AValue, Text1, Text2); - if (length(Reference) = 0) or not assigned(Document) then - exit; - - // Lookup entity references - Entity := Document.EntityByName[Reference]; - - // Does the entity contain markup? - if (length(Entity) > 0) and (UTF8Pos('<', Entity) > 0) then - begin - S := TsdUTF8StringStream.Create(Entity); - try - while S.Position < S.Size do - begin - Node := TXmlNode.Create(Document); - Node.ReadFromStream(S); - if Node.IsEmpty then - Node.Free - else - begin - ARoot.NodeInsert(InsertPos, Node); - inc(InsertPos); - Result := True; - end; - end; - finally - S.Free; - end; - end; - end; -// main -var - i: integer; - InsertPos: integer; - Text1, Text2: UTF8String; - Node: TXmlNode; - V, Reference, Replace, Entity, First, Last: UTF8String; -begin - if length(FValue) > 0 then - begin - // Different behaviour for xeNormal and xeCharData - if ElementType = xeNormal then - begin - InsertPos := 0; - if ReplaceEntityReferenceByNodes(Self, FValue, InsertPos, Text1, Text2) then - begin - FValue := Text1; - if length(sdUTF8Trim(Text2)) > 0 then - begin - Node := TXmlNode.CreateType(Document, xeCharData); - Node.ValueDirect := Text2; - NodeInsert(InsertPos, Node); - end; - end; - end else if (ElementType = xeCharData) and assigned(Parent) then - begin - InsertPos := Parent.NodeIndexOf(Self); - if ReplaceEntityReferenceByNodes(Parent, FValue, InsertPos, Text1, Text2) then - begin - FValue := Text1; - if length(sdUTF8Trim(FValue)) = 0 then - FValue := ''; - if length(sdUTF8Trim(Text2)) > 0 then - begin - Node := TXmlNode.CreateType(Document, xeCharData); - Node.ValueDirect := Text2; - Parent.NodeInsert(InsertPos, Node); - end; - end; - end; - end; - - // Do attributes - for i := 0 to AttributeCount - 1 do - begin - Last := AttributeValue[i]; - V := ''; - repeat - Reference := SplitReference(Last, First, Last); - Replace := ''; - if length(Reference) > 0 then - begin - Entity := Document.EntityByName[Reference]; - if length(Entity) > 0 then - Replace := Entity - else - Replace := '&' + Reference + ';'; - end; - V := V + First + Replace; - until length(Reference) = 0; - V := V + Last; - AttributeValue[i] := V; - end; - - // Do childnodes too - i := 0; - while i < NodeCount do - begin - Nodes[i].ResolveEntityReferences; - inc(i); - end; - - // Check for empty AnsiCharData nodes - for i := NodeCount - 1 downto 0 do - if (Nodes[i].ElementType = xeCharData) and (length(Nodes[i].ValueDirect) = 0) then - NodeDelete(i); -end; - -procedure TXmlNode.SetAttributeByName(const AName, Value: UTF8String); -begin - CheckCreateAttributesList; - FAttributes.Values[AName] := sdUTF8QuotedString(sdUTF8EscapeString(Value)); -end; - -procedure TXmlNode.SetAttributeByNameWide(const AName: UTF8String; const Value: UnicodeString); -begin - SetAttributeByName(AName, FromUnicodeString(Value)); -end; - -procedure TXmlNode.SetAttributeName(Index: integer; const Value: UTF8String); -var - S: UTF8String; - P: integer; -begin - if (Index >= 0) and (Index < AttributeCount) then - begin - S := FAttributes[Index]; - P := Utf8Pos('=', S); - if P > 0 then - FAttributes[Index] := Value + '=' + Copy(S, P + 1, MaxInt); - end; -end; - -procedure TXmlNode.SetAttributeValue(Index: integer; const Value: UTF8String); -begin - if (Index >= 0) and (Index < AttributeCount) then - FAttributes[Index] := AttributeName[Index] + '=' + - sdUTF8QuotedString(sdUTF8EscapeString(Value)); -end; - -procedure TXmlNode.SetAttributeValueAsInteger(Index: integer; const Value: integer); -begin - SetAttributeValue(Index, IntToUTF8Str(Value)); -end; - -procedure TXmlNode.SetAttributeValueAsUnicodeString(Index: integer; - const Value: UnicodeString); -begin - SetAttributeValue(Index, FromUnicodeString(Value)); -end; - -procedure TXmlNode.SetAttributeValueDirect(Index: integer; const Value: UTF8String); -begin - if (Index >= 0) and (Index < AttributeCount) then - FAttributes[Index] := AttributeName[Index] + '=' + - sdUTF8QuotedString(Value); -end; - -procedure TXmlNode.SetBinaryEncoding(const Value: TBinaryEncodingType); -begin - if assigned(Document) then - Document.BinaryEncoding := Value; -end; - -procedure TXmlNode.SetBinaryString(const Value: RawByteString); -var - OldEncoding: TBinaryEncodingType; -begin - // Set to base64 - OldEncoding := BinaryEncoding; - try - BinaryEncoding := xbeBase64; - if length(Value) = 0 then - begin - ValueAsString := ''; - exit; - end; - // fill the buffer - {$IFDEF CLR} - BufferWrite(BytesOf(Value), length(Value)); - {$ELSE} - BufferWrite(Value[1], length(Value)); - {$ENDIF} - finally - BinaryEncoding := OldEncoding; - end; -end; - -procedure TXmlNode.SetName(const Value: UTF8String); -var - i: integer; -begin - if FName <> Value then - begin - // Check if the name abides the rules. We will be very forgiving here and - // just accept any name that at least does not contain control AnsiCharacters - for i := 1 to length(Value) do - if Value[i] in cControlChars then - raise Exception.Create(Format(sxeIllegalCharInNodeName, [Value])); - FName := Value; - end; -end; - -procedure TXmlNode.SetValueAsBool(const Value: boolean); -begin - FValue := sdStringFromBool(Value); -end; - -procedure TXmlNode.SetValueAsDateTime(const Value: TDateTime); -begin - ValueAsString := sdDateTimeToString(Value); -end; - -procedure TXmlNode.SetValueAsFloat(const Value: double); -begin - FValue := sdWriteNumber(Value, FloatSignificantDigits, FloatAllowScientific); -end; - -procedure TXmlNode.SetValueAsInt64(const Value: int64); -begin - FValue := Int64ToUTF8Str(Value); -end; - -procedure TXmlNode.SetValueAsInteger(const Value: integer); -begin - FValue := IntToUTF8Str(Value); -end; - -procedure TXmlNode.SetValueAsString(const AValue: UTF8String); -begin - FValue := sdUTF8EscapeString(AValue); -end; - -procedure TXmlNode.SetValueAsUnicodeString(const Value: UnicodeString); -begin - ValueAsString := FromUnicodeString(Value); -end; - -procedure TXmlNode.SortChildNodes(Compare: TXMLNodeCompareFunction; Info: TPointer); -// Sort the child nodes using the quicksort algorithm - //local - function DoNodeCompare(Node1, Node2: TXmlNode): integer; - begin - if assigned(Compare) then - Result := Compare(Node1, Node2, Info) - else - if assigned(Document) and assigned(Document.OnNodeCompare) then - Result := Document.OnNodeCompare(Document, Node1, Node2, Info) - else - Result := UTF8CompareText(Node1.Name, Node2.Name); - end; - // local - procedure QuickSort(iLo, iHi: Integer); - var - Lo, Hi, Mid: longint; - begin - Lo := iLo; - Hi := iHi; - Mid:= (Lo + Hi) div 2; - repeat - while DoNodeCompare(Nodes[Lo], Nodes[Mid]) < 0 do - Inc(Lo); - while DoNodeCompare(Nodes[Hi], Nodes[Mid]) > 0 do - Dec(Hi); - if Lo <= Hi then - begin - // Swap pointers; - NodeExchange(Lo, Hi); - if Mid = Lo then - Mid := Hi - else - if Mid = Hi then - Mid := Lo; - Inc(Lo); - Dec(Hi); - end; - until Lo > Hi; - if Hi > iLo then - QuickSort(iLo, Hi); - if Lo < iHi then - QuickSort(Lo, iHi); - end; -// main -begin - if NodeCount > 1 then - QuickSort(0, NodeCount - 1); -end; - -function TXmlNode.ToUnicodeString(const s: UTF8String): UnicodeString; -begin - Result := sdUtf8ToUnicode(s) -end; - -function TXmlNode.UnescapeString(const AValue: UTF8String): UTF8String; -begin - Result := sdUTF8UnEscapeString(AValue) -end; - -function TXmlNode.UseFullNodes: boolean; -begin - Result := False; - if assigned(Document) then - Result := Document.UseFullNodes; -end; - -function TXmlNode.ValueAsBoolDef(ADefault: boolean): boolean; -var - Ch: AnsiChar; -begin - Result := ADefault; - if Length(FValue) = 0 then - exit; - Ch := sdUpCase(FValue[1]); - if Ch in ['T', 'Y'] then - begin - Result := True; - exit; - end; - if Ch in ['F', 'N'] then - begin - Result := False; - exit; - end; -end; - -function TXmlNode.ValueAsDateTimeDef(ADefault: TDateTime): TDateTime; -begin - Result := sdDateTimeFromStringDefault(ValueAsString, ADefault); -end; - -function TXmlNode.ValueAsFloatDef(ADefault: double): double; -var - Code: integer; -begin - try - val(string(sdUTF8StringReplace(FValue, ',', '.')), Result, Code); - if Code > 0 then - Result := ADefault; - except - Result := ADefault; - end; -end; - -function TXmlNode.ValueAsInt64Def(ADefault: int64): int64; -begin - Result := StrToInt64Def(string(FValue), ADefault); -end; - -function TXmlNode.ValueAsIntegerDef(ADefault: integer): integer; -begin - Result := StrToIntDef(string(FValue), ADefault); -end; - -procedure TXmlNode.WriteAttributeBool(const AName: UTF8String; AValue: boolean; ADefault: boolean); -var - Index: integer; -begin - if WriteOnDefault or (AValue <> ADefault) then - begin - Index := AttributeIndexByName(AName); - if Index >= 0 then - AttributeValue[Index] := sdStringFromBool(AValue) - else - AttributeAdd(AName, sdStringFromBool(AValue)); - end; -end; - -procedure TXmlNode.WriteAttributeDateTime(const AName: UTF8String; AValue, ADefault: TDateTime); -var - Index: integer; -begin - if WriteOnDefault or (AValue <> ADefault) then - begin - Index := AttributeIndexByName(AName); - if Index >= 0 then - AttributeValue[Index] := sdDateTimeToString(AValue) - else - AttributeAdd(AName, sdDateTimeToString(AValue)); - end; -end; - -procedure TXmlNode.WriteAttributeFloat(const AName: UTF8String; AValue, ADefault: double); -var - Index: integer; - S: UTF8String; -begin - if WriteOnDefault or (AValue <> ADefault) then - begin - Index := AttributeIndexByName(AName); - S := sdWriteNumber(AValue, FloatSignificantDigits, FloatAllowScientific); - if Index >= 0 then - AttributeValue[Index] := S - else - AttributeAdd(AName, S); - end; -end; - -procedure TXmlNode.WriteAttributeInteger(const AName: UTF8String; AValue: integer; ADefault: integer); -var - Index: integer; -begin - if WriteOnDefault or (AValue <> ADefault) then - begin - Index := AttributeIndexByName(AName); - if Index >= 0 then - AttributeValue[Index] := IntToUTF8Str(AValue) - else - AttributeAdd(AName, IntToUTF8Str(AValue)); - end; -end; - -procedure TXmlNode.WriteAttributeInt64(const AName: UTF8String; const AValue: int64; ADefault: int64); -var - Index: integer; -begin - if WriteOnDefault or (AValue <> ADefault) then - begin - Index := AttributeIndexByName(AName); - if Index >= 0 then - AttributeValue[Index] := IntToUTF8Str(AValue) - else - AttributeAdd(AName, IntToUTF8Str(AValue)); - end; -end; - -procedure TXmlNode.WriteAttributeString(const AName, AValue, ADefault: UTF8String); -var - Index: integer; -begin - if WriteOnDefault or (AValue <> ADefault) then - begin - Index := AttributeIndexByName(AName); - if Index >= 0 then - AttributeValue[Index] := AValue - else - AttributeAdd(AName, AValue); - end; -end; - -procedure TXmlNode.WriteBool(const AName: UTF8String; AValue: boolean; ADefault: boolean); -const - cBoolValues: array[boolean] of UTF8String = ('False', 'True'); -begin - if WriteOnDefault or (AValue <> ADefault) then - with NodeFindOrCreate(AName) do - ValueAsString := cBoolValues[AValue]; -end; - -{$IFDEF USEGRAPHICS} -procedure TXmlNode.WriteBrush(const AName: UTF8String; ABrush: TBrush); -begin - with NodeFindOrCreate(AName) do - begin - WriteColor('Color', ABrush.Color, clBlack); - WriteInteger('Style', integer(ABrush.Style), 0); - end; -end; - -procedure TXmlNode.WriteColor(const AName: UTF8String; AValue, ADefault: TColor); -begin - if WriteOnDefault or (AValue <> ADefault) then - WriteHex(AName, ColorToRGB(AValue), 8, 0); -end; -{$ENDIF} - -procedure TXmlNode.WriteDateTime(const AName: UTF8String; AValue, ADefault: TDateTime); -// Date MUST always be written in this format: -// YYYY-MM-DD (if just date) or -// YYYY-MM-DDThh:mm:ss.sssZ (if date and time. The Z stands for universal time -// zone. Since Delphi's TDateTime does not give us a clue about the timezone, -// this is the easiest solution) -// This format SHOULD NOT be changed, to avoid all kinds of -// conversion errors in future. -// This format is compatible with the W3C date/time specification as found here: -// http://www.w3.org/TR/NOTE-datetime -begin - if WriteOnDefault or (AValue <> ADefault) then - WriteString(AName, sdDateTimeToString(AValue), ''); -end; - -procedure TXmlNode.WriteFloat(const AName: UTF8String; AValue: double; ADefault: double); -begin - if WriteOnDefault or (AValue <> ADefault) then - with NodeFindOrCreate(AName) do - ValueAsString := sdWriteNumber(AValue, FloatSignificantDigits, FloatAllowScientific); -end; - -{$IFDEF USEGRAPHICS} -procedure TXmlNode.WriteFont(const AName: UTF8String; AFont: TFont); -begin - with NodeFindOrCreate(AName) do - begin - WriteString('Name', UTF8String(AFont.Name), 'Arial'); - WriteColor('Color', AFont.Color, clBlack); - WriteInteger('Size', AFont.Size, 14); - WriteBool('Bold', fsBold in AFont.Style, False); - WriteBool('Italic', fsItalic in AFont.Style, False); - WriteBool('Underline', fsUnderline in AFont.Style, False); - WriteBool('Strikeout', fsStrikeout in AFont.Style, False); - end; -end; -{$ENDIF} - -procedure TXmlNode.WriteHex(const AName: UTF8String; AValue, Digits: integer; ADefault: integer); -begin - if WriteOnDefault or (AValue <> ADefault) then - with NodeFindOrCreate(AName) do - ValueAsString := '$' + UTF8String(IntToHex(AValue, Digits)); -end; - -function TXmlNode.WriteInnerTag: UTF8String; -// Write the inner part of the tag, the one that contains the attributes -var - i: integer; -begin - Result := ''; - // Attributes - for i := 0 to AttributeCount - 1 do - // Here we used to prevent empty attributes, but in fact, empty attributes - // should be allowed because sometimes they're required - Result := Result + ' ' + AttributePair[i]; - // End of tag - direct nodes get an extra "/" - if QualifyAsDirectNode then - Result := Result + '/'; -end; - -procedure TXmlNode.WriteInt64(const AName: UTF8String; AValue, ADefault: int64); -begin - if WriteOnDefault or (AValue <> ADefault) then - with NodeFindOrCreate(AName) do - ValueAsString := IntToUTF8Str(AValue); -end; - -procedure TXmlNode.WriteInteger(const AName: UTF8String; AValue: integer; ADefault: integer); -begin - if WriteOnDefault or (AValue <> ADefault) then - with NodeFindOrCreate(AName) do - ValueAsString := IntToUTF8Str(AValue); -end; - -{$IFDEF USEGRAPHICS} -procedure TXmlNode.WritePen(const AName: UTF8String; APen: TPen); -begin - with NodeFindOrCreate(AName) do - begin - WriteColor('Color', APen.Color, clBlack); - WriteInteger('Mode', integer(APen.Mode), 0); - WriteInteger('Style', integer(APen.Style), 0); - WriteInteger('Width', APen.Width, 0); - end; -end; -{$ENDIF} - -procedure TXmlNode.WriteString(const AName, AValue: UTF8String; const ADefault: UTF8String); -begin - if WriteOnDefault or (AValue <> ADefault) then - with NodeFindOrCreate(AName) do - ValueAsString := AValue; -end; - -procedure TXmlNode.WriteToStream(S: TStream); -var - i: integer; - Indent: UTF8String; - LFeed: UTF8String; - Line: UTF8String; - ThisNode, NextNode: TXmlNode; - AddLineFeed: boolean; -begin - Indent := GetIndent; - LFeed := GetLineFeed; - - // Write indent - Line := Indent; - - // Write the node - distinguish node type - case ElementType of - xeDeclaration: // XML declaration - begin - // Explicitly delete empty attributes in the declaration, - // this is usually the encoding and we do not want encoding="" - // to show up - DeleteEmptyAttributes; - Line := Indent + ''; - end; - xeStylesheet: // Stylesheet - Line := Indent + ''; - xeDoctype: - begin - if NodeCount = 0 then - Line := Indent + '' - else - begin - Line := Indent + ''; - end; - end; - xeElement: - Line := Indent + ''; - xeAttList: - Line := Indent + ''; - xeEntity: - Line := Indent + ''; - xeNotation: - Line := Indent + ''; - xeComment: // Comment - Line := Indent + ''; - xeCData: // literal data - Line := Indent + ''; - xeExclam: // Any - Line := Indent + ''; - xeQuestion: // Any - Line := Indent + ''; - xeCharData: - Line := FValue; - xeUnknown: // Any - Line := Indent + '<' + ValueDirect + '>'; - xeNormal: // normal nodes (xeNormal) - begin - // Write tag - Line := Line + '<' + FName + WriteInnerTag + '>'; - - // Write value (if any) - Line := Line + FValue; - if (NodeCount > 0) then - // ..and a linefeed - Line := Line + LFeed; - - sdUTF8WriteStringToStream(S, Line); - - // Write child elements - for i := 0 to NodeCount - 1 do - begin - ThisNode := Nodes[i]; - NextNode := Nodes[i + 1]; - ThisNode.WriteToStream(S); - AddLineFeed := True; - if ThisNode.ElementType = xeCharData then - AddLineFeed := False; - if assigned(NextNode) then - if NextNode.ElementType = xeCharData then - AddLineFeed := False; - if AddLineFeed then - sdUTF8WriteStringToStream(S, LFeed); - end; - - // Write end tag - Line := ''; - if not QualifyAsDirectNode then - begin - if NodeCount > 0 then - Line := Indent; - Line := Line + ''; - end; - end; - else - raise EFilerError.Create(sxeIllegalElementType); - end;//case - sdUTF8WriteStringToStream(S, Line); - - // Call the onprogress - if assigned(Document) then - Document.DoProgress(S.Position); -end; - -function TXmlNode.WriteToString: UTF8String; -var - S: TsdUTF8StringStream; -begin - // We will simply call WriteToStream and collect the result as UTF8String using - // a string stream - S := TsdUTF8StringStream.Create(''); - try - WriteToStream(S); - Result := S.DataString; - finally - S.Free; - end; -end; - -procedure TXmlNode.WriteUnicodeString(const AName: UTF8String; - const AValue: UnicodeString; const ADefault: UnicodeString); -begin - WriteString(AName, FromUnicodeString(AValue), FromUnicodeString(ADefault)); -end; - -{ TXmlNodeList } - -function TXmlNodeList.ByAttribute(const AName, AValue: UTF8String): TXmlNode; -var - i: integer; -begin - for i := 0 to Count - 1 do - if UTF8CompareText(Items[i].AttributeByName[AName], AValue) = 0 then - begin - Result := Items[i]; - exit; - end; - Result := nil; -end; - -function TXmlNodeList.GetItems(Index: Integer): TXmlNode; -begin - Result := TXmlNode(Get(Index)); -end; - -procedure TXmlNodeList.SetItems(Index: Integer; const Value: TXmlNode); -begin - Put(Index, TPointer(Value)); -end; - -{ TNativeXml } - -procedure TNativeXml.Assign(Source: TPersistent); - // local - procedure SetDocumentRecursively(ANode: TXmlNode; ADocument: TNativeXml); - var - i: integer; - begin - ANode.Document := ADocument; - for i := 0 to ANode.NodeCount - 1 do - SetDocumentRecursively(ANode.Nodes[i], ADocument); - end; -// main -begin - if Source is TNativeXml then - begin - // Copy private members - FBinaryEncoding := TNativeXml(Source).FBinaryEncoding; - FDropCommentsOnParse := TNativeXml(Source).FDropCommentsOnParse; - FExternalEncoding := TNativeXml(Source).FExternalEncoding; - FParserWarnings := TNativeXml(Source).FParserWarnings; - FIndentString := TNativeXml(Source).FIndentString; - FUseFullNodes := TNativeXml(Source).FUseFullNodes; - FWriteOnDefault := TNativeXml(Source).FWriteOnDefault; - FXmlFormat := TNativeXml(Source).FXmlFormat; - // Assign root - FRootNodes.Assign(TNativeXml(Source).FRootNodes); - // Set Document property recursively - SetDocumentRecursively(FRootNodes, Self); - end else - if Source is TXmlNode then - begin - // Assign this node to the FRootNodes property - FRootNodes.Assign(Source); - // Set Document property recursively - SetDocumentRecursively(FRootNodes, Self); - end else - inherited; -end; - -procedure TNativeXml.Clear; -var - Node: TXmlNode; -begin - // Reset defaults - SetDefaults; - // Clear root - FRootNodes.Clear; - // Build default items in RootNodes - // - first the declaration - Node := TXmlNode.CreateType(Self, xeDeclaration); - Node.Name := 'xml'; - Node.AttributeAdd('version', cDefaultVersionString); - Node.AttributeAdd('encoding', cDefaultEncodingString); - FRootNodes.NodeAdd(Node); - // - then the root node - FRootNodes.NodeNew(''); -end; - -procedure TNativeXml.CopyFrom(Source: TNativeXml); -begin - if not assigned(Source) then - exit; - Assign(Source); -end; - -constructor TNativeXml.Create; -begin - inherited Create; - FRootNodes := TXmlNode.Create(Self); - Clear; -end; - -constructor TNativeXml.CreateName(const ARootName: UTF8String); -begin - Create; - Root.Name := ARootName; -end; - -destructor TNativeXml.Destroy; -begin - FreeAndNil(FRootNodes); - inherited; -end; - -procedure TNativeXml.DoNodeLoaded(Node: TXmlNode); -begin - if assigned(FOnNodeLoaded) then - FOnNodeLoaded(Self, Node); -end; - -procedure TNativeXml.DoNodeNew(Node: TXmlNode); -begin - if assigned(FOnNodeNew) then - FOnNodeNew(Self, Node); -end; - -procedure TNativeXml.DoProgress(Size: integer); -begin - if assigned(FOnProgress) then - FOnProgress(Self, Size); -end; - -procedure TNativeXml.DoUnicodeLoss(Sender: TObject); -begin - if assigned(FOnUnicodeLoss) then - FOnUnicodeLoss(Self); -end; - -function TNativeXml.GetCommentString: UTF8String; -// Get the first comment node, and return its value -var - Node: TXmlNode; -begin - Result := ''; - Node := FRootNodes.NodeByElementType(xeComment); - if assigned(Node) then - Result := Node.ValueAsString; -end; - -function TNativeXml.GetEncodingString: UTF8String; -begin - Result := ''; - if FRootNodes.NodeCount > 0 then - if FRootNodes[0].ElementType = xeDeclaration then - Result := FRootNodes[0].AttributeByName['encoding']; -end; - -function TNativeXml.GetEntityByName(AName: UTF8String): UTF8String; -var - i, j: integer; -begin - Result := ''; - for i := 0 to FRootNodes.NodeCount - 1 do - if FRootNodes[i].ElementType = xeDoctype then with FRootNodes[i] do - begin - for j := 0 to NodeCount - 1 do - if (Nodes[j].ElementType = xeEntity) and (Nodes[j].Name = AName) then - begin - Result := sdUTF8UnQuotedString(sdUTF8Trim(Nodes[j].ValueDirect)); - exit; - end; - end; -end; - -function TNativeXml.GetRoot: TXmlNode; -begin - Result := FRootNodes.NodeByElementType(xeNormal); -end; - -function TNativeXml.GetStyleSheetNode: TXmlNode; -begin - Result := FRootNodes.NodeByElementType(xeStylesheet); - if not assigned(Result) then - begin - // Add a stylesheet node as second one if none present - Result := TXmlNode.CreateType(Self, xeStyleSheet); - FRootNodes.NodeInsert(1, Result); - end; -end; - -function TNativeXml.GetUtf8Encoded: boolean; -begin - Result := True; -end; - -function TNativeXml.GetVersionString: UTF8String; -begin - Result := ''; - if FRootNodes.NodeCount > 0 then - if FRootNodes[0].ElementType = xeDeclaration then - Result := FRootNodes[0].AttributeByName['version']; -end; - -function TNativeXml.IsEmpty: boolean; -var - R: TXmlNode; -begin - Result := True; - R := GetRoot; - if assigned(R) then - Result := R.IsClear; -end; - -function TNativeXml.LineFeed: UTF8String; -begin - case XmlFormat of - xfReadable: - Result := #13#10; - xfCompact: - Result := #10; - else - Result := #10; - end;//case -end; - -procedure TNativeXml.LoadFromFile(const AFileName: string); -var - S: TStream; -begin - S := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStream(S); - finally - S.Free; - end; -end; - -procedure TNativeXml.LoadFromStream(Stream: TStream); -var - B: TsdBufferedReadStream; -begin - // Create buffer filter. Since we read from the original stream a buffer at a - // time, this speeds up the reading process for disk-based files. - B := TsdBufferedReadStream.Create(Stream, False); - try - // We will create a conversion stream as intermediate - FCodecStream := TsdUtf8Stream.Create(B); - try - // Connect events - FCodecStream.OnUnicodeLoss := DoUnicodeLoss; - // Read from stream - ReadFromStream(FCodecStream); - // Set our external encoding - FExternalEncoding := FCodecStream.Encoding; - finally - FreeAndNil(FCodecStream); - end; - finally - B.Free; - end; -end; - -procedure TNativeXml.ParseDTD(ANode: TXmlNode; S: TStream); -// DTD parsing is quite different from normal node parsing so it is brought -// under in the main NativeXml object - // local - procedure ParseMarkupDeclarations; - var - Ch: AnsiChar; - begin - repeat - ANode.NodeNew('').ReadFromStream(S); - // Read AnsiCharacter, exit if none available - repeat - if S.Read(Ch, 1) = 0 then - exit; - // Read until end markup declaration or end - until not (Ch in cControlChars); - if Ch = ']' then - break; - S.Seek(-1, soCurrent); - until False; - end; -// main -var - Prework: UTF8String; - Ch: AnsiChar; - Words: TsdUTF8StringList; -begin - // Get the name and external ID - Prework := ''; - repeat - // Read AnsiCharacter, exit if none available - if S.Read(Ch, 1) = 0 then - exit; - // Read until markup declaration or end - if Ch in ['[', '>'] then - break; - Prework := Prework + UTF8String(Ch); - until False; - Words := TsdUTF8StringList.Create; - try - sdUTF8ParseAttributes(Prework, 1, length(Prework) + 1, Words); - // First word is name - if Words.Count > 0 then - begin - ANode.Name := Words[0]; - Words.Delete(0); - // Put the rest in the valuedirect - ANode.ValueDirect := sdUTF8Trim(sdUTF8StringReplace(Words.Text, #13#10, ' ')); - end; - finally - Words.Free; - end; - - if Ch = '[' then - begin - - // Parse any !ENTITY nodes and such - ParseMarkupDeclarations; - - // read final tag - repeat - if S.Read(Ch, 1) = 0 then - exit; - if Ch = '>' then - break; - until False; - - end; -end; - -procedure TNativeXml.ReadFromStream(S: TStream); -var - i: integer; - Node: TXmlNode; - Enc: UTF8String; - NormalCount, DeclarationCount, - DoctypeCount, CDataCount: integer; - NormalPos, DoctypePos: integer; -begin - FAbortParsing := False; - with FRootNodes do - begin - // Clear the old root nodes - we do not reset the defaults - Clear; - DoProgress(0); - repeat - Node := NodeNew(''); - Node.ReadFromStream(S); - if AbortParsing then - exit; - - // XML declaration - if Node.ElementType = xeDeclaration then - begin - if Node.HasAttribute('encoding') then - Enc := Node.AttributeByName['encoding']; - // Check encoding - if assigned(FCodecStream) and (Enc = 'UTF-8') then - FCodecStream.Encoding := seUTF8; - end; - // Skip clear nodes - if Node.IsClear then - NodeDelete(NodeCount - 1); - until S.Position >= S.Size; - DoProgress(S.Size); - - // Do some checks - NormalCount := 0; - DeclarationCount := 0; - DoctypeCount := 0; - CDataCount := 0; - NormalPos := -1; - DoctypePos := -1; - for i := 0 to NodeCount - 1 do - begin - // Count normal elements - there may be only one - case Nodes[i].ElementType of - xeNormal: - begin - inc(NormalCount); - NormalPos := i; - end; - xeDeclaration: inc(DeclarationCount); - xeDoctype: - begin - inc(DoctypeCount); - DoctypePos := i; - end; - xeCData: inc(CDataCount); - end;//case - end; - - // We *must* have a root node - if NormalCount = 0 then - raise EFilerError.Create(sxeNoRootElement); - - // Do some validation if we allow parser warnings - if FParserWarnings then - begin - - // Check for more than one root node - if NormalCount > 1 then - raise EFilerError.Create(sxeMoreThanOneRootElement); - - // Check for more than one xml declaration - if DeclarationCount > 1 then - raise EFilerError.Create(sxeMoreThanOneDeclaration); - - // Declaration must be first element if present - if DeclarationCount = 1 then - if Nodes[0].ElementType <> xeDeclaration then - raise EFilerError.Create(sxeDeclarationMustBeFirstElem); - - // Check for more than one DTD - if DoctypeCount > 1 then - raise EFilerError.Create(sxeMoreThanOneDoctype); - - // Check if DTD is after root, this is not allowed - if (DoctypeCount = 1) and (DoctypePos > NormalPos) then - raise EFilerError.Create(sxeDoctypeAfterRootElement); - - // No CDATA in root allowed - if CDataCount > 0 then - raise EFilerError.Create(sxeCDataInRoot); - end; - end;//with -end; - -procedure TNativeXml.ReadFromString(const AValue: UTF8String); -var - S: TStream; -begin - S := TsdUTF8StringStream.Create(AValue); - try - ReadFromStream(S); - finally - S.Free; - end; -end; - -procedure TNativeXml.ResolveEntityReferences; -begin - if assigned(Root) then - Root.ResolveEntityReferences; -end; - -procedure TNativeXml.SaveToFile(const AFileName: string); -var - S: TStream; -begin - S := TFileStream.Create(AFileName, fmCreate); - try - SaveToStream(S); - finally - S.Free; - end; -end; - -procedure TNativeXml.SaveToStream(Stream: TStream); -var - B: TsdBufferedWriteStream; -begin - // Create buffer filter. Since we write a buffer at a time to the destination - // stream, this speeds up the writing process for disk-based files. - B := TsdBufferedWriteStream.Create(Stream, False); - try - // Create conversion stream - FCodecStream := TsdUtf8Stream.Create(B); - try - // Set External encoding - FCodecStream.Encoding := FExternalEncoding; - WriteToStream(FCodecStream); - finally - FreeAndNil(FCodecStream); - end; - finally - B.Free; - end; -end; - -procedure TNativeXml.SetCommentString(const Value: UTF8String); -// Find first comment node and set it's value, otherwise add new comment node -// right below the xml declaration -var - Node: TXmlNode; -begin - Node := FRootNodes.NodeByElementType(xeComment); - if not assigned(Node) and (length(Value) > 0) then - begin - Node := TXmlNode.CreateType(Self, xeComment); - FRootNodes.NodeInsert(1, Node); - end; - if assigned(Node) then - Node.ValueAsString := Value; -end; - -procedure TNativeXml.SetDefaults; -begin - // Defaults - FExternalEncoding := cDefaultExternalEncoding; - FXmlFormat := cDefaultXmlFormat; - FWriteOnDefault := cDefaultWriteOnDefault; - FBinaryEncoding := cDefaultBinaryEncoding; - FIndentString := cDefaultIndentString; - FDropCommentsOnParse := cDefaultDropCommentsOnParse; - FUseFullNodes := cDefaultUseFullNodes; - FFloatAllowScientific := cDefaultFloatAllowScientific; - FFloatSignificantDigits := cDefaultFloatSignificantDigits; - FOnNodeNew := nil; - FOnNodeLoaded := nil; -end; - -procedure TNativeXml.SetEncodingString(const Value: UTF8String); -var - Node: TXmlNode; -begin - if Value = GetEncodingString then - exit; - Node := FRootNodes[0]; - if not assigned(Node) or (Node.ElementType <> xeDeclaration) then - begin - Node := TXmlNode.CreateType(Self, xeDeclaration); - FRootNodes.NodeInsert(0, Node); - end; - if assigned(Node) then - Node.AttributeByName['encoding'] := Value; -end; - -procedure TNativeXml.SetVersionString(const Value: UTF8String); -var - Node: TXmlNode; -begin - if Value = GetVersionString then - exit; - Node := FRootNodes[0]; - if not assigned(Node) or (Node.ElementType <> xeDeclaration) then - begin - if length(Value) > 0 then - begin - Node := TXmlNode.CreateType(Self, xeDeclaration); - FRootNodes.NodeInsert(0, Node); - end; - end; - if assigned(Node) then - Node.AttributeByName['version'] := Value; -end; - -procedure TNativeXml.WriteToStream(S: TStream); -var - i: integer; -begin - if not assigned(Root) and FParserWarnings then - raise EFilerError.Create(sxeRootElementNotDefined); - - DoProgress(0); - - // write the root nodes - for i := 0 to FRootNodes.NodeCount - 1 do - begin - FRootNodes[i].WriteToStream(S); - sdUTF8WriteStringToStream(S, LineFeed); - end; - - DoProgress(S.Size); -end; - -function TNativeXml.WriteToString: UTF8String; -var - S: TsdUTF8StringStream; -begin - S := TsdUTF8StringStream.Create(''); - try - WriteToStream(S); - Result := S.DataString; - finally - S.Free; - end; -end; - -{ TsdCodecStream } - -constructor TsdCodecStream.Create(AStream: TStream); -begin - inherited Create; - FStream := AStream; -end; - -function TsdCodecStream.InternalRead(var Buffer{$IFDEF CLR}: array of Byte{$ENDIF}; Offset, Count: Longint): Longint; -// Read from FStream and pass back data -var - i, j: integer; - BOM: array[0..3] of byte; - BytesRead: integer; - Found: boolean; -begin - Result := 0; - if FMode = umUnknown then - begin - FMode := umRead; - // Check FStream - if not assigned(FStream) then - raise EStreamError.Create(sxeCodecStreamNotAssigned); - - // Determine encoding - FEncoding := seAnsi; - BytesRead := FStream.Read(BOM, 4); - for i := 0 to cBomInfoCount - 1 do - begin - Found := True; - for j := 0 to Min(BytesRead, cBomInfo[i].Len) - 1 do - begin - if BOM[j] <> cBomInfo[i].BOM[j] then - begin - Found := False; - break; - end; - end; - if Found then - break; - end; - if Found then - begin - FEncoding := cBomInfo[i].Encoding; - FWriteBom := cBomInfo[i].HasBOM; - end else - begin - // Unknown.. default to this - FEncoding := seAnsi; - FWriteBom := False; - end; - - // Some encodings are not supported (yet) - if FEncoding in [seUCS4BE, seUCS4_2143, seUCS4_3412, seEBCDIC] then - raise EStreamError.Create(sxeUnsupportedEncoding); - - // Correct stream to start position - if FWriteBom then - FStream.Seek(cBomInfo[i].Len - BytesRead, soCurrent) - else - FStream.Seek(-BytesRead, soCurrent); - - // Check if we must swap byte order - if FEncoding in [se16BitBE, seUTF16BE] then - FSwapByteOrder := True; - - end; - - // Check mode - if FMode <> umRead then - raise EStreamError.Create(sxeCannotReadCodecForWriting); - - // Check count - if Count <> 1 then - raise EStreamError.Create(sxeCannotReadMultipeChar); - - // Now finally read - TBytes(Buffer)[Offset] := ReadByte; - if TBytes(Buffer)[Offset] <> 0 then Result := 1; -end; - -{$IFDEF CLR} - -function TsdCodecStream.Read(var Buffer: array of Byte; Offset, Count: Longint): Longint; -begin - Result := InternalRead(Buffer, Offset, Count); -end; - -{$ELSE} - -function TsdCodecStream.Read(var Buffer; Count: Longint): Longint; -begin - Result := InternalRead(Buffer, 0, Count); -end; - -{$ENDIF} - -function TsdCodecStream.ReadByte: byte; -begin - // default does nothing - Result := 0; -end; - -function TsdCodecStream.InternalSeek(Offset: Longint; Origin: TSeekOrigin): Longint; -begin - Result := 0; - if FMode = umUnknown then - raise EStreamError.Create(sxeCannotSeekBeforeReadWrite); - - if Origin = soCurrent then - begin - if Offset = 0 then - begin - // Position - Result := FStream.Position; - exit; - end; - if (FMode = umRead) and ((Offset = -1) or (Offset = -2)) then - begin - FBuffer := ''; - case Offset of - -1: FStream.Seek(FPosMin1, soBeginning); - -2: FStream.Seek(FPosMin2, soBeginning); - end;//case - exit; - end; - end; - if (Origin = soEnd) and (Offset = 0) then - begin - // Size - Result := FStream.Size; - exit; - end; - // Ignore set position from beginning (used in Size command) - if Origin = soBeginning then - exit; - // Arriving here means we cannot do it - raise EStreamError.Create(sxeCannotPerformSeek); -end; - -{$IFDEF CLR} - -function TsdCodecStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; -begin - Result := InternalSeek(Offset, Origin); -end; - -{$ELSE} - -function TsdCodecStream.Seek(Offset: Longint; Origin: Word): Longint; -begin - Result := InternalSeek(Offset, TSeekOrigin(Origin)); -end; - -{$ENDIF} - -procedure TsdCodecStream.StorePrevPositions; -begin - FPosMin2 := FPosMin1; - FPosMin1 := FStream.Position; -end; - -function TsdCodecStream.InternalWrite(const Buffer{$IFDEF CLR}: array of Byte{$ENDIF}; Offset, Count: Longint): Longint; -var - i: integer; -begin - if FMode = umUnknown then - begin - FMode := umWrite; - - // Some encodings are not supported (yet) - if FEncoding in [seUCS4BE, seUCS4_2143, seUCS4_3412, seEBCDIC] then - raise EStreamError.Create(sxeUnsupportedEncoding); - - // Find correct encoding info - for i := 0 to cBomInfoCount - 1 do - if cBomInfo[i].Encoding = FEncoding then - begin - // we do not write BOM if UTF8 since UTF8 is default - FWriteBom := cBomInfo[i].HasBOM and (FEncoding <> seUTF8); - break; - end; - - // Write BOM - if FWriteBom then - FStream.WriteBuffer(cBomInfo[i].BOM, cBomInfo[i].Len); - - // Check if we must swap byte order - if FEncoding in [se16BitBE, seUTF16BE] then - FSwapByteOrder := True; - end; - - if FMode <> umWrite then - raise EStreamError.Create(sxeCannotWriteCodecForReading); - WriteBuf(Buffer, Offset, Count); - Result := Count; -end; - -{$IFDEF CLR} - -function TsdCodecStream.Write(const Buffer: array of Byte; Offset, Count: Longint): Longint; -begin - Result := InternalWrite(Buffer, Offset, Count); -end; - -{$ELSE} - -function TsdCodecStream.Write(const Buffer; Count: Longint): Longint; -begin - Result := InternalWrite(Byte(Buffer), 0, Count); -end; - -{$ENDIF} - -procedure TsdCodecStream.WriteBuf(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Offset, Count: longint); -var - i: integer; -begin - // Default just writes out bytes one by one. We override this in descendants - // to provide faster writes for some modes - for i := 0 to Count - 1 do - {$IFDEF CLR} - WriteByte(Buffer[Offset + i]); - {$ELSE} - WriteByte(TBytes(Buffer)[Offset + i]); - {$ENDIF} -end; - -procedure TsdCodecStream.WriteByte(const B: byte); -begin -// default does nothing -end; - -{$IFDEF CLR} - -procedure TsdCodecStream.SetSize(NewSize: Int64); -begin -// default does nothing -end; - -{$ENDIF} - -{ TsdUtf8Stream } - -function TsdUtf8Stream.ReadByte: byte; -var - B, B1, B2, B3: byte; - W: word; - SA: AnsiString; -begin - Result := 0; - - // New AnsiCharacter? - if (Length(FBuffer) = 0) or (FBufferPos > length(FBuffer)) then - begin - StorePrevPositions; - FBufferPos := 1; - // Read another AnsiChar and put in buffer - case FEncoding of - seAnsi: - begin - // read one byte - B := 0; - FStream.Read(B, 1); - SA := AnsiChar(B); - // Convert to UTF8 - FBuffer := sdAnsiToUtf8(SA); - end; - seUTF8: - begin - // Read one, two or three bytes in the buffer - B1 := 0; - FStream.Read(B1, 1); - FBuffer := AnsiChar(B1); - if (B1 and $80) > 0 then - begin - if (B1 and $20) <> 0 then - begin - B2 := 0; - FStream.Read(B2, 1); - FBuffer := FBuffer + UTF8String(AnsiChar(B2)); - end; - B3 := 0; - FStream.Read(B3, 1); - FBuffer := FBuffer + UTF8String(AnsiChar(B3)); - end; - end; - se16BitBE, se16BitLE, seUTF16BE, seUTF16LE: - begin - // Read two bytes - W := 0; - FStream.Read(W, 2); - // Swap byte order - if FSwapByteOrder then - W := swap(W); - // Convert to UTF8 in buffer - {$IFDEF D5UP} - FBuffer := sdUnicodeToUtf8(UnicodeChar(W)); - {$ELSE} - FBuffer := sdUnicodeToUtf8(char(W and $FF)); - {$ENDIF} - end; - else - raise EStreamError.Create(sxeUnsupportedEncoding); - end;//case - end; - - // Now we have the buffer, so read - if (FBufferPos > 0) and (FBufferPos <= length(FBuffer)) then - Result := byte(FBuffer[FBufferPos]); - inc(FBufferPos); -end; - -procedure TsdUtf8Stream.WriteBuf(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Offset, Count: longint); -begin - case FEncoding of - seUtf8: - begin - // one on one - if StreamWrite(FStream, Buffer, Offset, Count) <> Count then - raise EStreamError.Create(sxeCannotWriteToOutputStream); - end - else - inherited; - end;//case -end; - -procedure TsdUtf8Stream.WriteByte(const B: byte); -var - SA: AnsiString; - SW: UnicodeString; - MustWrite: boolean; -begin - case FEncoding of - seAnsi, se16BitBE, se16BitLE, seUTF16BE, seUTF16LE: - begin - MustWrite := True; - case Length(FBuffer) of - 0: - begin - FBuffer := AnsiChar(B); - if (B and $80) <> 0 then - MustWrite := False; - end; - 1: - begin - FBuffer := FBuffer + UTF8String(AnsiChar(B)); - if (byte(FBuffer[1]) and $20) <> 0 then - MustWrite := False; - end; - 2: FBuffer := FBuffer + UTF8String(AnsiChar(B)); - end; - if MustWrite then - begin - if FEncoding = seAnsi then - begin - // Convert to ansi - SA := sdUtf8ToAnsi(FBuffer); - // write out - if length(SA) = 1 then - if FStream.Write(SA[1], 1) <> 1 then - raise EStreamError.Create(sxeCannotWriteToOutputStream); - end else - begin - // Convert to unicode - SW := sdUtf8ToUnicode(FBuffer); - // write out - if length(SW) = 1 then - if FStream.Write(SW[1], 2) <> 2 then - raise EStreamError.Create(sxeCannotWriteToOutputStream); - end; - FBuffer := ''; - end; - end; - seUTF8: - begin - // Just a flat write of one byte - if FStream.Write(B, 1) <> 1 then - raise EStreamError.Create(sxeCannotWriteToOutputStream); - end; - else - raise EStreamError.Create(sxeUnsupportedEncoding); - end;//case -end; - -{$IFDEF CLR} -{ TsdBufferedStream } - -constructor TsdBufferedStream.Create(AStream: TStream; Owned: Boolean = False); -begin - inherited Create; - FStream := AStream; - FOwned := Owned; -end; - -destructor TsdBufferedStream.Destroy; -begin - if FOwned then FreeAndNil(FStream); - inherited Destroy; -end; - -function TsdBufferedStream.Read(var Buffer: array of Byte; Offset, Count: Longint): Longint; -begin - Result := FStream.Read(Buffer, Offset, Count); -end; - -function TsdBufferedStream.Write(const Buffer: array of Byte; Offset, Count: Longint): Longint; -begin - Result := FStream.Write(Buffer, Offset, Count); -end; - -function TsdBufferedStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; -begin - Result := FStream.Seek(Offset, Origin); -end; - -procedure TsdBufferedStream.SetSize(NewSize: Int64); -begin - FStream.Size := NewSize; -end; - -{$ELSE} - -{ TsdBufferedReadStream } - -const - cMaxBufferSize = $10000; // 65536 bytes in the buffer - -procedure TsdBufferedReadStream.CheckPosition; -var - NewPage: integer; - FStartPos: longint; -begin - // Page and buffer position - NewPage := FPosition div cMaxBufferSize; - FBufPos := FPosition mod cMaxBufferSize; - - // Read new page if required - if (NewPage <> FPage) then - begin - // New page and buffer - FPage := NewPage; - - // Start position in stream - FStartPos := FPage * cMaxBufferSize; - FBufSize := Min(cMaxBufferSize, FStream.Size - FStartPos); - - FStream.Seek(FStartPos, soBeginning); - if FBufSize > 0 then - FStream.Read(FBuffer^, FBufSize); - end; - FMustCheck := False; -end; - -constructor TsdBufferedReadStream.Create(AStream: TStream; Owned: boolean); -begin - inherited Create; - FStream := AStream; - FOwned := Owned; - FMustCheck := True; - FPage := -1; // Set to invalid number to force an update on first read - ReallocMem(FBuffer, cMaxBufferSize); -end; - -destructor TsdBufferedReadStream.Destroy; -begin - if FOwned then FreeAndNil(FStream); - ReallocMem(FBuffer, 0); - inherited; -end; - -function TsdBufferedReadStream.Read(var Buffer; Count: longint): Longint; -var - Packet: PByte; - PacketCount: integer; -begin - // Set the right page - if FMustCheck then - CheckPosition; - - // Special case - read one byte, most often - if (Count = 1) and (FBufPos < FBufSize - 1) then - begin - byte(Buffer) := FBuffer^[FBufPos]; - inc(FBufPos); - inc(FPosition); - Result := 1; - exit; - end; - - // general case - Packet := @Buffer; - Result := 0; - while Count > 0 do - begin - PacketCount := min(FBufSize - FBufPos, Count); - if PacketCount <= 0 then - exit; - Move(FBuffer^[FBufPos], Packet^, PacketCount); - dec(Count, PacketCount); - inc(Packet, PacketCount); - inc(Result, PacketCount); - inc(FPosition, PacketCount); - inc(FBufPos, PacketCount); - if FBufPos >= FBufSize then - CheckPosition; - end; -end; - -function TsdBufferedReadStream.Seek(Offset: longint; Origin: Word): Longint; -begin - case Origin of - soFromBeginning: - FPosition := Offset; - soFromCurrent: - begin - // no need to check in this case - it is the GetPosition command - if Offset = 0 then - begin - Result := FPosition; - exit; - end; - FPosition := FPosition + Offset; - end; - soFromEnd: - FPosition := FStream.Size + Offset; - end;//case - Result := FPosition; - FMustCheck := True; -end; - -function TsdBufferedReadStream.Write(const Buffer; Count: longint): Longint; -begin - raise EStreamError.Create(sxeCannotWriteCodecForReading); -end; - -{ TsdBufferedWriteStream } - -constructor TsdBufferedWriteStream.Create(AStream: TStream; Owned: boolean); -begin - inherited Create; - FStream := AStream; - FOwned := Owned; - ReallocMem(FBuffer, cMaxBufferSize); -end; - -destructor TsdBufferedWriteStream.Destroy; -begin - Flush; - if FOwned then - FreeAndNil(FStream); - ReallocMem(FBuffer, 0); - inherited; -end; - -procedure TsdBufferedWriteStream.Flush; -begin - // Write the buffer to the stream - if FBufPos > 0 then - begin - FStream.Write(FBuffer^, FBufPos); - FBufPos := 0; - end; -end; - -function TsdBufferedWriteStream.Read(var Buffer; Count: longint): Longint; -begin - raise EStreamError.Create(sxeCannotReadCodecForWriting); -end; - -function TsdBufferedWriteStream.Seek(Offset: longint; Origin: Word): Longint; -begin - case Origin of - soFromBeginning: - if Offset = FPosition then - begin - Result := FPosition; - exit; - end; - soFromCurrent: - begin - // GetPosition command - if Offset = 0 then - begin - Result := FPosition; - exit; - end; - end; - soFromEnd: - if Offset = 0 then - begin - Result := FPosition; - exit; - end; - end;//case - raise EStreamError.Create(sxeCannotPerformSeek); -end; - -function TsdBufferedWriteStream.Write(const Buffer; Count: longint): Longint; -var - Packet: PByte; - PacketCount: integer; -begin - // Special case - read less bytes than would fill buffersize - if (FBufPos + Count < cMaxBufferSize) then - begin - Move(Buffer, FBuffer^[FBufPos], Count); - inc(FBufPos, Count); - inc(FPosition, Count); - Result := Count; - exit; - end; - - // general case that wraps buffer - Packet := @Buffer; - Result := 0; - while Count > 0 do - begin - PacketCount := min(cMaxBufferSize - FBufPos, Count); - if PacketCount <= 0 then - exit; - Move(Packet^, FBuffer^[FBufPos], PacketCount); - dec(Count, PacketCount); - inc(Result, PacketCount); - inc(FPosition, PacketCount); - inc(Packet, PacketCount); - inc(FBufPos, PacketCount); - if FBufPos = cMaxBufferSize then - Flush; - end; -end; -{$ENDIF} - -{ TsdSurplusReader } - -constructor TsdSurplusReader.Create(AStream: TStream); -begin - inherited Create; - FStream := AStream; -end; - -function TsdSurplusReader.ReadChar(var Ch: AnsiChar): integer; -begin - if length(FSurplus) > 0 then - begin - Ch := FSurplus[1]; - FSurplus := copy(FSurplus, 2, length(FSurplus) - 1); - Result := 1; - end else - Result := FStream.Read(Ch, 1); -end; - -function TsdSurplusReader.ReadCharSkipBlanks(var Ch: AnsiChar): boolean; -begin - Result := False; - repeat - // Read AnsiCharacter, exit if none available - if ReadChar(Ch) = 0 then - exit; - // Skip if in controlchars - if not (Ch in cControlchars) then - break; - until False; - Result := True; -end; - -{ TsdStringBuilder } - -procedure TsdStringBuilder.AddChar(Ch: AnsiChar); -begin - inc(FCurrentIdx); - Reallocate(FCurrentIdx); - FData[FCurrentIdx] := Ch; -end; - -procedure TsdStringBuilder.AddString(var S: UTF8String); -var - {$IFDEF CLR} - i: integer; - {$ENDIF} - Count: integer; -begin - {$IFDEF CLR} - Count := S.Length; - {$ELSE} - Count := System.length(S); - {$ENDIF} - if Count = 0 then - exit; - Reallocate(FCurrentIdx + Count); - {$IFDEF CLR} - for i := 1 to S.Length do - FData[FCurrentIdx + i] := S[i]; - {$ELSE} - Move(S[1], FData[FCurrentIdx + 1], Count); - {$ENDIF} - inc(FCurrentIdx, Count); -end; - -procedure TsdStringBuilder.Clear; -begin - FCurrentIdx := 0; -end; - -function TsdStringBuilder.StringCopy(AFirst, ALength: integer): UTF8String; -begin - if ALength > FCurrentIdx - AFirst + 1 then - ALength := FCurrentIdx - AFirst + 1; - Result := Copy(FData, AFirst, ALength); -end; - -constructor TsdStringBuilder.Create; -begin - inherited Create; - SetLength(FData, 64); -end; - -function TsdStringBuilder.GetData(Index: integer): AnsiChar; -begin - Result := FData[Index]; -end; - -procedure TsdStringBuilder.Reallocate(RequiredLength: integer); -begin - {$IFDEF CLR} - while FData.Length < RequiredLength do - SetLength(FData, FData.Length * 2); - {$ELSE} - while System.Length(FData) < RequiredLength do - SetLength(FData, System.Length(FData) * 2); - {$ENDIF} -end; - -function TsdStringBuilder.Value: UTF8String; -begin - Result := Copy(FData, 1, FCurrentIdx); -end; - -initialization - - {$IFDEF TRIALXML} - ShowMessage( - 'This is the unregistered version of NativeXml.pas'#13#13 + - 'Please visit http://www.simdesign.nl/xml.html to buy the'#13 + - 'registered version for Eur 29.95 (source included).'); - {$ENDIF} - -end. diff --git a/addons/nativexml/NativeXmlAppend.pas b/addons/nativexml/NativeXmlAppend.pas deleted file mode 100644 index da87926..0000000 --- a/addons/nativexml/NativeXmlAppend.pas +++ /dev/null @@ -1,243 +0,0 @@ -{ - Unit NativeXmlAppend - - This unit implements a method to add XML fragments to the end of an existing - XML file that resides on disk. The file is never loaded completely into memory, - the new data will be appended at the end. - - This unit requires NativeXml. - - Possible exceptions (apart from the regular ones for file access): - - 'Reverse read past beginning of stream': - The file provided in S is not an XML file or it is an XML file with not enough - levels. The XML file should have in its last tag at least ALevel levels of - elements. Literally this exception means that the algorithm went backwards - through the complete file and arrived at the beginning, without finding a - suitable position to insert the node data. - - 'Level cannot be found' - This exception will be raised when the last element does not contain enough - levels, so the algorithm encounters an opening tag where it would expect a - closing tag. - Example: - We try to add a node at level 3 in this XML file - - - - - - <-- This last node does not have a level2, so the algorithm - does not know where to add the data of level 3 under level2 - - - See Example4 for an implementation - - Original Author: Nils Haeck M.Sc. - Copyright (c) 2003-2009 Simdesign B.V. - - It is NOT allowed under ANY circumstances to publish or copy this code - without accepting the license conditions in accompanying LICENSE.txt - first! - - This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF - ANY KIND, either express or implied. - - Please visit http://www.simdesign.nl/xml.html for more information. -} -unit NativeXmlAppend; - -interface - -{$I NativeXml.inc} - -uses - Classes, SysUtils, Dialogs, NativeXml; - -type - ustring = UTF8String; - -// With this routine we can add a single node (TXmlNode) to an existing XML file. -// The file will NOT be read in completely, the data will simply be appended at the -// end. In order to do this, the file is scanned from the end until the last node -// at ALevel levels deep is located. -// ALevel = 0 would add the new node at the very end. This is not wise, since XML -// does not allow more than one root node. Choose ALevel = 1 to add the new node -// at the first level under the root (default). -//

-// TIP: If you want to start with an empty (template) XmlDocument, make sure to -// set TsdXmlDocument.UseFullNodes to True before saving it. This ensures that -// the append function will work correctly on the root node. -//

-// NOTE 1: This method does not work for unicode files. -procedure XmlAppendToExistingFile(const AFilename: string; ANode: TXmlNode; - ALevel: integer {$IFDEF D4UP}= 1{$ENDIF}); - -implementation - -type - // We need this class to get access to protected method WriteToString - THackNode = class(TXmlNode); - - TTagType = record - FClose: string; - FStart: string; - end; - -const - - // Reversed tags, note: the record fields are also in reversed order. This - // is because we read backwards - cTagCount = 4; - cTags: array[0..cTagCount - 1] of TTagType = ( - // The order is important here; the items are searched for in appearing order - (FClose: '>]]'; FStart: '[ATADC[!<'), // CDATA - (FClose: '>--'; FStart: '--!<'), // Comment - (FClose: '>?'; FStart: '?<'), // - (FClose: '>'; FStart: '<') // Any other - ); - -function ScanBackwards(S: TStream): char; -begin - if S.Position = 0 then - raise Exception.Create('Reverse read past beginning of stream'); - S.Seek(-1, soFromCurrent); - S.Read(Result, 1); - S.Seek(-1, soFromCurrent); -end; - -function ReverseReadCloseTag(S: TStream): integer; -// Try to read the type of close tag from S, in reversed order -var - AIndex, i: integer; - Found: boolean; - Ch: char; -begin - Result := cTagCount - 1; - AIndex := 1; - repeat - Found := False; - inc(AIndex); - Ch := ScanBackwards(S); - for i := cTagCount - 1 downto 0 do begin - if length(cTags[i].FClose) >= AIndex then - if cTags[i].FClose[AIndex] = Ch then begin - Found := True; - Result := i; - break; - end; - end; - until Found = False; - // Increase position again because we read too far - S.Seek(1, soFromCurrent); -end; - -procedure ReverseReadFromStreamUntil(S: TStream; const ASearch: string; - var AValue: string); -// Read the tag in reversed order. We are looking for the string in ASearch -// (in reversed order). AValue will contain the tag when done (in correct order). -var - AIndex: integer; - Ch: char; -begin - AIndex := 1; - AValue := ''; - while AIndex <= length(ASearch) do begin - Ch := ScanBackwards(S); - AValue := Ch + AValue; - if ASearch[AIndex] = Ch then - inc(AIndex) - else - AIndex := 1; - end; - AValue := copy(AValue, Length(ASearch) + 1, length(AValue)); -end; - -function XmlScanNodeFromEnd(S: TStream; ALevel: integer): integer; -// Scan the stream S from the end and find the end of node at level ALevel -var - Ch: char; - ATagIndex: integer; - AValue: string; -begin - S.Seek(0, soFromEnd); - while ALevel > 0 do begin - Ch := ScanBackwards(S); - if Ch = '>' then begin - // Determine tag type from closing tag - ATagIndex := ReverseReadCloseTag(S); - // Try to find the start - ReverseReadFromStreamUntil(S, cTags[ATagIndex].FStart, AValue); - // We found the start, now decide what to do. We only decrease - // level if this is a closing tag. If it is an opening tag, we - // should raise an exception - if (ATagIndex = 3) then begin - if (Length(AValue) > 0) and (AValue[1] = '/') then - dec(ALevel) - else - raise Exception.Create('Level cannot be found'); - end; - end; - end; - Result := S.Position; -end; - -procedure StreamInsertString(S: TStream; APos: integer; Value: string); -// Insert Value into stream S at position APos. The stream S (if it is a disk -// file) should have write access! -var - ASize: integer; - M: TMemoryStream; -begin - // Nothing to do if no value - if Length(Value) = 0 then exit; - - S.Position := APos; - ASize := S.Size - S.Position; - // Create intermediate memory stream that holds the new ending - M := TMemoryStream.Create; - try - // Create a copy into a memory stream that contains new insert + old last part - M.SetSize(ASize + Length(Value)); - M.Write(Value[1], Length(Value)); - M.CopyFrom(S, ASize); - // Now add this copy at the current position - M.Position := 0; - S.Position := APos; - S.CopyFrom(M, M.Size); - finally - M.Free; - end; -end; - -procedure XmlAppendToExistingFile(const AFilename: string; ANode: TXmlNode; - ALevel: integer); -// With this routine we can add a single node (TXmlNode) to an existing XML file. -// The file will NOT be read in completely, the data will simply be appended at the -// end. In order to do this, the file is scanned from the end until the last node -// at ALevel levels deep is located. -// ALevel = 0 would add the new node at the very end. This is not wise, since XML -// does not allow more than one root node. Choose ALevel = 1 to add the new node -// at the first level under the root (default). -var - S: TStream; - APos: integer; - AInsert: ustring; -begin - // Open the file with Read/Write access - S := TFileStream.Create(AFilename, fmOpenReadWrite or fmShareDenyWrite); - try - // After a successful open, we can locate the correct end of node - APos := XmlScanNodeFromEnd(S, ALevel); - // Still no exceptions, this means we found a valid position.. now insert the - // new node in here. - AInsert := THackNode(ANode).WriteToString; - // Now we happily insert the string into the opened stream at the right position - StreamInsertString(S, APos, string(AInsert)); - finally - // We're done, close the stream, this will save the modified filestream - S.Free; - end; -end; - -end. diff --git a/addons/nativexml/NativeXmlObjectStorage.pas b/addons/nativexml/NativeXmlObjectStorage.pas deleted file mode 100644 index 7cf85ab..0000000 --- a/addons/nativexml/NativeXmlObjectStorage.pas +++ /dev/null @@ -1,1276 +0,0 @@ -{ unit NativeXmlObjectStorage - - This unit provides functionality to store any TObject descendant to an XML file - or stream. Internally it makes full use of RTTI (runtime type information) in - order to store all published properties and events. - - It can even be used to copy forms, but form inheritance is not exploited, so - child forms descending from parent forms store everything that the parent already - stored. - - All published properties and events of objects are stored. This includes - the "DefineProperties". These are stored in binary form in the XML, encoded - as BASE64. - - Known limitations: - - The method and event lookup will not work correctly across forms. - - Please see the "ObjectToXML" demo for example usage of this unit. - - Original Author: Nils Haeck M.Sc. - Copyright (c) 2003-2009 Simdesign B.V. - - It is NOT allowed under ANY circumstances to publish or copy this code - without accepting the license conditions in accompanying LICENSE.txt - first! - - This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF - ANY KIND, either express or implied. - - Please visit http://www.simdesign.nl/xml.html for more information. -} - -// Delphi and BCB versions - -// Delphi 5 -{$IFDEF VER130} - {$DEFINE D5UP} -{$ENDIF} -//Delphi 6 -{$IFDEF VER140} - {$DEFINE D5UP} - {$DEFINE D6UP} -{$ENDIF} -//Delphi 7 -{$IFDEF VER150} - {$DEFINE D5UP} - {$DEFINE D6UP} - {$DEFINE D7UP} -{$ENDIF} -//Delphi 8 -{$IFDEF VER160} - {$DEFINE D5UP} - {$DEFINE D6UP} - {$DEFINE D7UP} - {$DEFINE D8UP} -{$ENDIF} -// Delphi 2005 -{$IFDEF VER170} - {$DEFINE D5UP} - {$DEFINE D6UP} - {$DEFINE D7UP} - {$DEFINE D8UP} - {$DEFINE D9UP} -{$ENDIF} -// Delphi 2006 -{$IFDEF VER180} - {$DEFINE D5UP} - {$DEFINE D6UP} - {$DEFINE D7UP} - {$DEFINE D8UP} - {$DEFINE D9UP} - {$DEFINE D10UP} -{$ENDIF} -// Delphi 2007 - NET -{$IFDEF VER190} - {$DEFINE D5UP} - {$DEFINE D6UP} - {$DEFINE D7UP} - {$DEFINE D8UP} - {$DEFINE D9UP} - {$DEFINE D10UP} -{$ENDIF} -// Delphi 2009 -{$IFDEF VER200} - {$DEFINE D5UP} - {$DEFINE D6UP} - {$DEFINE D7UP} - {$DEFINE D8UP} - {$DEFINE D9UP} - {$DEFINE D10UP} - {$DEFINE D11UP} - {$DEFINE D12UP} -{$ENDIF} -// Delphi 2010 -{$IFDEF VER210} - {$DEFINE D5UP} - {$DEFINE D6UP} - {$DEFINE D7UP} - {$DEFINE D8UP} - {$DEFINE D9UP} - {$DEFINE D10UP} - {$DEFINE D11UP} - {$DEFINE D12UP} - {$DEFINE D14UP} -{$ENDIF} - - -unit NativeXmlObjectStorage; - -interface - -uses - Classes, Forms, SysUtils, Controls, NativeXml, TypInfo - {$IFDEF D6UP} - , Variants - {$ENDIF}; - -type - - // Use TsdXmlObjectWriter to write any TPersistent descendant's published properties - // to an XML node. - TsdXmlObjectWriter = class(TPersistent) - protected - procedure WriteProperty(ANode: TXmlNode; AObject: TObject; AParent: TComponent; PropInfo: PPropInfo); - public - // Call WriteObject to write the published properties of AObject to the TXmlNode - // ANode. Specify AParent in order to store references to parent methods and - // events correctly. - procedure WriteObject(ANode: TXmlNode; AObject: TObject; AParent: TComponent = nil); - // Call WriteComponent to write the published properties of AComponent to the TXmlNode - // ANode. Specify AParent in order to store references to parent methods and - // events correctly. - procedure WriteComponent(ANode: TXmlNode; AComponent: TComponent; AParent: TComponent = nil); - end; - - // Use TsdXmlObjectReader to read any TPersistent descendant's published properties - // from an XML node. - TsdXmlObjectReader = class(TPersistent) - protected - procedure ReadProperty(ANode: TXmlNode; AObject: TObject; AParent: TComponent; PropInfo: PPropInfo); - public - // Call CreateComponent to first create AComponent and then read its published - // properties from the TXmlNode ANode. Specify AParent in order to resolve - // references to parent methods and events correctly. In order to successfully - // create the component from scratch, the component's class must be registered - // beforehand with a call to RegisterClass. Specify Owner to add the component - // as a child to Owner's component list. This is usually a form. Specify Name - // as the new component name for the created component. - function CreateComponent(ANode: TXmlNode; AOwner, AParent: TComponent; AName: string = ''): TComponent; - // Call ReadObject to read the published properties of AObject from the TXmlNode - // ANode. Specify AParent in order to resolve references to parent methods and - // events correctly. - procedure ReadObject(ANode: TXmlNode; AObject: TObject; AParent: TComponent = nil); - // Call ReadComponent to read the published properties of AComponent from the TXmlNode - // ANode. Specify AParent in order to resolve references to parent methods and - // events correctly. - procedure ReadComponent(ANode: TXmlNode; AComponent: TComponent; AParent: TComponent); - end; - -// High-level create methods - -// Create and read a component from the XML file with FileName. In order to successfully -// create the component from scratch, the component's class must be registered -// beforehand with a call to RegisterClass. Specify Owner to add the component -// as a child to Owner's component list. This is usually a form. Specify Name -// as the new component name for the created component. -function ComponentCreateFromXmlFile(const FileName: string; Owner: TComponent; - const Name: string): TComponent; - -// Create and read a component from the TXmlNode ANode. In order to successfully -// create the component from scratch, the component's class must be registered -// beforehand with a call to RegisterClass. Specify Owner to add the component -// as a child to Owner's component list. This is usually a form. Specify Name -// as the new component name for the created component. -function ComponentCreateFromXmlNode(ANode: TXmlNode; Owner: TComponent; - const Name: string): TComponent; - -// Create and read a component from the XML stream S. In order to successfully -// create the component from scratch, the component's class must be registered -// beforehand with a call to RegisterClass. Specify Owner to add the component -// as a child to Owner's component list. This is usually a form. Specify Name -// as the new component name for the created component. -function ComponentCreateFromXmlStream(S: TStream; Owner: TComponent; - const Name: string): TComponent; - -// Create and read a component from the XML in string in Value. In order to successfully -// create the component from scratch, the component's class must be registered -// beforehand with a call to RegisterClass. Specify Owner to add the component -// as a child to Owner's component list. This is usually a form. Specify Name -// as the new component name for the created component. -function ComponentCreateFromXmlString(const Value: string; Owner: TComponent; - const Name: string): TComponent; - -// Create and read a form from the XML file with FileName. In order to successfully -// create the form from scratch, the form's class must be registered -// beforehand with a call to RegisterClass. Specify Owner to add the form -// as a child to Owner's component list. For forms this is usually Application. -// Specify Name as the new form name for the created form. -function FormCreateFromXmlFile(const FileName: string; Owner: TComponent; - const Name: string): TForm; - -// Create and read a form from the XML stream in S. In order to successfully -// create the form from scratch, the form's class must be registered -// beforehand with a call to RegisterClass. Specify Owner to add the form -// as a child to Owner's component list. For forms this is usually Application. -// Specify Name as the new form name for the created form. -function FormCreateFromXmlStream(S: TStream; Owner: TComponent; - const Name: string): TForm; - -// Create and read a form from the XML string in Value. In order to successfully -// create the form from scratch, the form's class must be registered -// beforehand with a call to RegisterClass. Specify Owner to add the form -// as a child to Owner's component list. For forms this is usually Application. -// Specify Name as the new form name for the created form. -function FormCreateFromXmlString(const Value: string; Owner: TComponent; - const Name: string): TForm; - -// High-level load methods - -// Load all the published properties of AObject from the XML file in Filename. -// Specify AParent in order to resolve references to parent methods and -// events correctly. -procedure ObjectLoadFromXmlFile(AObject: TObject; const FileName: string; - AParent: TComponent = nil); - -// Load all the published properties of AObject from the TXmlNode ANode. -// Specify AParent in order to resolve references to parent methods and -// events correctly. -procedure ObjectLoadFromXmlNode(AObject: TObject; ANode: TXmlNode; AParent: TComponent = nil); - -// Load all the published properties of AObject from the XML stream in S. -// Specify AParent in order to resolve references to parent methods and -// events correctly. -procedure ObjectLoadFromXmlStream(AObject: TObject; S: TStream; AParent: TComponent = nil); - -// Load all the published properties of AObject from the XML string in Value. -// Specify AParent in order to resolve references to parent methods and -// events correctly. -procedure ObjectLoadFromXmlString(AObject: TObject; const Value: string; AParent: TComponent = nil); - -// High-level save methods - -// Save all the published properties of AObject as XML to the file in Filename. -// Specify AParent in order to store references to parent methods and -// events correctly. -procedure ObjectSaveToXmlFile(AObject: TObject; const FileName: string; - AParent: TComponent = nil); - -// Save all the published properties of AObject to the TXmlNode ANode. -// Specify AParent in order to store references to parent methods and -// events correctly. -procedure ObjectSaveToXmlNode(AObject: TObject; ANode: TXmlNode; AParent: TComponent = nil); - -// Save all the published properties of AObject as XML in stream S. -// Specify AParent in order to store references to parent methods and -// events correctly. -procedure ObjectSaveToXmlStream(AObject: TObject; S: TStream; AParent: TComponent = nil); - -// Save all the published properties of AObject as XML in string Value. -// Specify AParent in order to store references to parent methods and -// events correctly. -function ObjectSaveToXmlString(AObject: TObject; AParent: TComponent = nil): string; - -// Save all the published properties of AComponent as XML in the file in Filename. -// Specify AParent in order to store references to parent methods and -// events correctly. -procedure ComponentSaveToXmlFile(AComponent: TComponent; const FileName: string; - AParent: TComponent = nil); - -// Save all the published properties of AComponent to the TXmlNode ANode. -// Specify AParent in order to store references to parent methods and -// events correctly. -procedure ComponentSaveToXmlNode(AComponent: TComponent; ANode: TXmlNode; - AParent: TComponent = nil); - -// Save all the published properties of AComponent as XML in the stream in S. -// Specify AParent in order to store references to parent methods and -// events correctly. -procedure ComponentSaveToXmlStream(AComponent: TComponent; S: TStream; - AParent: TComponent = nil); - -// Save all the published properties of AComponent as XML in the string Value. -// Specify AParent in order to store references to parent methods and -// events correctly. -function ComponentSaveToXmlString(AComponent: TComponent; AParent: TComponent = nil): string; - -// Save the form AForm as XML to the file in Filename. This method also stores -// properties of all child components on the form, and can therefore be used -// as a form-storage method. -procedure FormSaveToXmlFile(AForm: TForm; const FileName: string); - -// Save the form AForm as XML to the stream in S. This method also stores -// properties of all child components on the form, and can therefore be used -// as a form-storage method. -procedure FormSaveToXmlStream(AForm: TForm; S: TStream); - -// Save the form AForm as XML to a string. This method also stores -// properties of all child components on the form, and can therefore be used -// as a form-storage method. -function FormSaveToXmlString(AForm: TForm): string; - -resourcestring - - sxwIllegalVarType = 'Illegal variant type'; - sxrUnregisteredClassType = 'Unregistered classtype encountered'; - sxrInvalidPropertyValue = 'Invalid property value'; - sxwInvalidMethodName = 'Invalid method name'; - -implementation - -{$IFDEF TRIALXML} -uses - Dialogs; -{$ENDIF} - -type - - THackPersistent = class(TPersistent); - THackComponent = class(TComponent) - public - procedure SetComponentState(const AState: TComponentState); - published - property ComponentState; - end; - - THackReader = class(TReader); - -function ComponentCreateFromXmlFile(const FileName: string; Owner: TComponent; - const Name: string): TComponent; -var - S: TStream; -begin - S := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone); - try - Result := ComponentCreateFromXmlStream(S, Owner, Name); - finally - S.Free; - end; -end; - -function ComponentCreateFromXmlNode(ANode: TXmlNode; Owner: TComponent; - const Name: string): TComponent; -var - AReader: TsdXmlObjectReader; -begin - Result := nil; - if not assigned(ANode) then exit; - // Create reader - AReader := TsdXmlObjectReader.Create; - try - // Read the component from the node - Result := AReader.CreateComponent(ANode, Owner, nil, Name); - finally - AReader.Free; - end; -end; - -function ComponentCreateFromXmlStream(S: TStream; Owner: TComponent; - const Name: string): TComponent; -var - ADoc: TNativeXml; -begin - Result := nil; - if not assigned(S) then exit; - // Create XML document - ADoc := TNativeXml.Create; - try - // Load XML - ADoc.LoadFromStream(S); - // Load from XML node - Result := ComponentCreateFromXmlNode(ADoc.Root, Owner, Name); - finally - ADoc.Free; - end; -end; - -function ComponentCreateFromXmlString(const Value: string; Owner: TComponent; - const Name: string): TComponent; -var - S: TStream; -begin - S := TStringStream.Create(Value); - try - Result := ComponentCreateFromXmlStream(S, Owner, Name); - finally - S.Free; - end; -end; - -function FormCreateFromXmlFile(const FileName: string; Owner: TComponent; - const Name: string): TForm; -var - S: TStream; -begin - S := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone); - try - Result := FormCreateFromXmlStream(S, Owner, Name); - finally - S.Free; - end; -end; - -function FormCreateFromXmlStream(S: TStream; Owner: TComponent; - const Name: string): TForm; -var - ADoc: TNativeXml; -begin - Result := nil; - if not assigned(S) then exit; - // Create XML document - ADoc := TNativeXml.Create; - try - // Load XML - ADoc.LoadFromStream(S); - - // Load from XML node - Result := TForm(ComponentCreateFromXmlNode(ADoc.Root, Owner, Name)); - finally - ADoc.Free; - end; -end; - -function FormCreateFromXmlString(const Value: string; Owner: TComponent; - const Name: string): TForm; -var - S: TStream; -begin - S := TStringStream.Create(Value); - try - Result := FormCreateFromXmlStream(S, Owner, Name); - finally - S.Free; - end; -end; - -procedure ObjectLoadFromXmlFile(AObject: TObject; const FileName: string; - AParent: TComponent = nil); -var - S: TStream; -begin - S := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone); - try - ObjectLoadFromXmlStream(AObject, S, AParent); - finally - S.Free; - end; -end; - -procedure ObjectLoadFromXmlNode(AObject: TObject; ANode: TXmlNode; AParent: TComponent = nil); -var - AReader: TsdXmlObjectReader; -begin - if not assigned(AObject) or not assigned(ANode) then exit; - // Create writer - AReader := TsdXmlObjectReader.Create; - try - // Write the object to the document - if AObject is TComponent then - AReader.ReadComponent(ANode, TComponent(AObject), AParent) - else - AReader.ReadObject(ANode, AObject, AParent); - finally - AReader.Free; - end; -end; - -procedure ObjectLoadFromXmlStream(AObject: TObject; S: TStream; AParent: TComponent = nil); -var - ADoc: TNativeXml; -begin - if not assigned(S) then exit; - // Create XML document - ADoc := TNativeXml.Create; - try - // Load XML - ADoc.LoadFromStream(S); - // Load from XML node - ObjectLoadFromXmlNode(AObject, ADoc.Root, AParent); - finally - ADoc.Free; - end; -end; - -procedure ObjectLoadFromXmlString(AObject: TObject; const Value: string; AParent: TComponent = nil); -var - S: TStringStream; -begin - S := TStringStream.Create(Value); - try - ObjectLoadFromXmlStream(AObject, S, AParent); - finally - S.Free; - end; -end; - -procedure ObjectSaveToXmlFile(AObject: TObject; const FileName: string; - AParent: TComponent = nil); -var - S: TStream; -begin - S := TFileStream.Create(FileName, fmCreate); - try - ObjectSaveToXmlStream(AObject, S, AParent); - finally - S.Free; - end; -end; - -procedure ObjectSaveToXmlNode(AObject: TObject; ANode: TXmlNode; AParent: TComponent = nil); -var - AWriter: TsdXmlObjectWriter; -begin - if not assigned(AObject) or not assigned(ANode) then exit; - // Create writer - AWriter := TsdXmlObjectWriter.Create; - try - // Write the object to the document - if AObject is TComponent then - AWriter.WriteComponent(ANode, TComponent(AObject), AParent) - else begin - ANode.Name := UTF8String(AObject.ClassName); - AWriter.WriteObject(ANode, AObject, AParent); - end; - finally - AWriter.Free; - end; -end; - -procedure ObjectSaveToXmlStream(AObject: TObject; S: TStream; AParent: TComponent = nil); -var - ADoc: TNativeXml; -begin - if not assigned(S) then exit; - // Create XML document - ADoc := TNativeXml.Create; - try - ADoc.XmlFormat := xfReadable; - // Save to XML node - ObjectSaveToXmlNode(AObject, ADoc.Root, AParent); - // Save to stream - ADoc.SaveToStream(S); - finally - ADoc.Free; - end; -end; - -function ObjectSaveToXmlString(AObject: TObject; AParent: TComponent = nil): string; -var - S: TStringStream; -begin - S := TStringStream.Create(''); - try - ObjectSaveToXmlStream(AObject, S, AParent); - Result := S.DataString; - finally - S.Free; - end; -end; - -procedure ComponentSaveToXmlFile(AComponent: TComponent; const FileName: string; - AParent: TComponent = nil); -begin - ObjectSaveToXmlFile(AComponent, FileName, AParent); -end; - -procedure ComponentSaveToXmlNode(AComponent: TComponent; ANode: TXmlNode; - AParent: TComponent = nil); -begin - ObjectSaveToXmlNode(AComponent, ANode, AParent); -end; - -procedure ComponentSaveToXmlStream(AComponent: TComponent; S: TStream; - AParent: TComponent = nil); -begin - ObjectSaveToXmlStream(AComponent, S, AParent); -end; - -function ComponentSaveToXmlString(AComponent: TComponent; AParent: TComponent = nil): string; -begin - Result := ObjectSaveToXmlString(AComponent, AParent); -end; - -procedure FormSaveToXmlFile(AForm: TForm; const FileName: string); -begin - ComponentSaveToXmlFile(AForm, FileName, AForm); -end; - -procedure FormSaveToXmlStream(AForm: TForm; S: TStream); -begin - ComponentSaveToXmlStream(AForm, S, AForm); -end; - -function FormSaveToXmlString(AForm: TForm): string; -begin - Result := ComponentSaveToXmlString(AForm, AForm); -end; - - -{ TsdXmlObjectWriter } - -procedure TsdXmlObjectWriter.WriteComponent(ANode: TXmlNode; AComponent, - AParent: TComponent); -begin - if not assigned(ANode) or not assigned(AComponent) then exit; - ANode.Name := UTF8String(AComponent.ClassName); - if length(AComponent.Name) > 0 then - ANode.AttributeAdd('Name', UTF8String(AComponent.Name)); - WriteObject(ANode, AComponent, AParent); -end; - -procedure TsdXmlObjectWriter.WriteObject(ANode: TXmlNode; AObject: TObject; - AParent: TComponent); -var - i, Count: Integer; - PropInfo: PPropInfo; - PropList: PPropList; - S: TStringStream; - AWriter: TWriter; - AChildNode: TXmlNode; - AComponentNode: TXmlNode; -begin - if not assigned(ANode) or not assigned(AObject) then exit; - - // If this is a component, store child components - if AObject is TComponent then with TComponent(AObject) do begin - if ComponentCount > 0 then begin - AChildNode := ANode.NodeNew('Components'); - for i := 0 to ComponentCount - 1 do begin - AComponentNode := AChildNode.NodeNew(UTF8String(Components[i].ClassName)); - if length(Components[i].Name) > 0 then - AComponentNode.AttributeAdd('Name', UTF8String(Components[i].Name)); - WriteObject(AComponentNode, Components[i], TComponent(AObject)); - end; - end; - end; - - // Save all regular properties that need storing - Count := GetTypeData(AObject.ClassInfo)^.PropCount; - if Count > 0 then begin - GetMem(PropList, Count * SizeOf(Pointer)); - try - GetPropInfos(AObject.ClassInfo, PropList); - for i := 0 to Count - 1 do begin - PropInfo := PropList^[i]; - if PropInfo = nil then continue; - if IsStoredProp(AObject, PropInfo) then - WriteProperty(ANode, AObject, AParent, PropInfo); - end; - finally - FreeMem(PropList, Count * SizeOf(Pointer)); - end; - end; - - // Save defined properties - if AObject is TPersistent then begin - S := TStringStream.Create(''); - try - AWriter := TWriter.Create(S, 4096); - try - THackPersistent(AObject).DefineProperties(AWriter); - finally - AWriter.Free; - end; - // Do we have data from DefineProperties? - if S.Size > 0 then begin - // Yes, add a node with binary data - ANode.NodeNew('DefinedProperties').BinaryString := UTF8String(S.DataString); - end; - finally - S.Free; - end; - end; -end; - -procedure TsdXmlObjectWriter.WriteProperty(ANode: TXmlNode; AObject: TObject; - AParent: TComponent; PropInfo: PPropInfo); -var - PropType: PTypeInfo; - AChildNode: TXmlNode; - ACollectionNode: TXmlNode; - - procedure WritePropName; - begin - AChildNode := ANode.NodeNew(PPropInfo(PropInfo)^.Name); - end; - - procedure WriteInteger(Value: Int64); - begin - AChildNode.ValueAsString := UTF8String(IntToStr(Value)); - end; - - procedure WriteString(Value: string); - begin - AChildNode.ValueAsUnicodeString := Value; - end; - - procedure WriteSet(Value: Longint); - var - I: Integer; - BaseType: PTypeInfo; - S, Enum: string; - begin - BaseType := GetTypeData(PropType)^.CompType^; - for i := 0 to SizeOf(TIntegerSet) * 8 - 1 do begin - if i in TIntegerSet(Value) then begin - Enum := GetEnumName(BaseType, i); - if i > 0 then - S := S + ',' + Enum - else - S := Enum; - end; - end; - AChildNode.ValueAsString := UTF8String(Format('[%s]', [S])); - end; - - procedure WriteIntProp(IntType: PTypeInfo; Value: Longint); - var - Ident: string; - IntToIdent: TIntToIdent; - begin - IntToIdent := FindIntToIdent(IntType); - if Assigned(IntToIdent) and IntToIdent(Value, Ident) then - WriteString(Ident) - else - WriteInteger(Value); - end; - - procedure WriteCollectionProp(Collection: TCollection); - var - i: integer; - begin - if assigned(Collection) then begin - for i := 0 to Collection.Count - 1 do - begin - ACollectionNode := AChildNode.NodeNew(UTF8String(Collection.Items[i].ClassName)); - WriteObject(ACollectionNode, Collection.Items[I], AParent); - end; - end; - end; - - procedure WriteOrdProp; - var - Value: Longint; - begin - Value := GetOrdProp(AObject, PropInfo); - if not (Value = PPropInfo(PropInfo)^.Default) then begin - WritePropName; - case PropType^.Kind of - tkInteger: WriteIntProp(PPropInfo(PropInfo)^.PropType^, Value); - tkChar: WriteString(Chr(Value)); - tkSet: WriteSet(Value); - tkEnumeration: WriteString(GetEnumName(PropType, Value)); - end; - end; - end; - - procedure WriteFloatProp; - var - Value: Extended; - begin - Value := GetFloatProp(AObject, PropInfo); - if not (Value = 0) then - ANode.WriteFloat(PPropInfo(PropInfo)^.Name, Value); - end; - - procedure WriteInt64Prop; - var - Value: Int64; - begin - Value := GetInt64Prop(AObject, PropInfo); - if not (Value = 0) then - ANode.WriteInt64(PPropInfo(PropInfo)^.Name, Value); - end; - - procedure WriteStrProp; - var - Value: string; - begin - Value := GetStrProp(AObject, PropInfo); - if not (length(Value) = 0) then - ANode.WriteUnicodeString(PPropInfo(PropInfo)^.Name, Value); - end; - - {$IFDEF D6UP} - procedure WriteWideStrProp; - var - Value: WideString; - begin - Value := GetWideStrProp(AObject, PropInfo); - if not (length(Value) = 0) then - ANode.WriteUnicodeString(PPropInfo(PropInfo)^.Name, Value); - end; - {$ENDIF} - - procedure WriteObjectProp; - var - Value: TObject; - ComponentName: string; - function GetComponentName(Component: TComponent): string; - begin - if Component.Owner = AParent then - Result := Component.Name - else if Component = AParent then - Result := 'Owner' - else if assigned(Component.Owner) and (length(Component.Owner.Name) > 0) - and (length(Component.Name) > 0) then - Result := Component.Owner.Name + '.' + Component.Name - else if length(Component.Name) > 0 then - Result := Component.Name + '.Owner' - else Result := ''; - end; - - begin - Value := TObject(GetOrdProp(AObject, PropInfo)); - if not assigned(Value) then exit; - WritePropName; - if Value is TComponent then begin - ComponentName := GetComponentName(TComponent(Value)); - if length(ComponentName) > 0 then - WriteString(ComponentName); - end else begin - WriteString(Format('(%s)', [Value.ClassName])); - if Value is TCollection then - WriteCollectionProp(TCollection(Value)) - else begin - if AObject is TComponent then - WriteObject(AChildNode, Value, TComponent(AObject)) - else - WriteObject(AChildNode, Value, AParent) - end; - // No need to store an empty child.. so check and remove - if AChildNode.NodeCount = 0 then - ANode.NodeRemove(AChildNode); - end; - end; - - procedure WriteMethodProp; - var - Value: TMethod; - function IsDefaultValue: Boolean; - begin - Result := (Value.Code = nil) or - ((Value.Code <> nil) and assigned(AParent) and (AParent.MethodName(Value.Code) = '')); - end; - begin - Value := GetMethodProp(AObject, PropInfo); - if not IsDefaultValue then begin - if assigned(Value.Code) then begin - WritePropName; - if assigned(AParent) then - WriteString(AParent.MethodName(Value.Code)) - else - AChildNode.ValueAsString := '???'; - end; - end; - end; - - procedure WriteVariantProp; - var - AValue: Variant; - ACurrency: Currency; - var - VType: Integer; - begin - AValue := GetVariantProp(AObject, PropInfo); - if not VarIsEmpty(AValue) then begin - if VarIsArray(AValue) then - raise Exception.Create(sxwIllegalVarType); - WritePropName; - VType := VarType(AValue); - AChildNode.AttributeAdd('VarType', UTF8String(IntToHex(VType, 4))); - case VType and varTypeMask of - varOleStr: AChildNode.ValueAsUnicodeString := AValue; - varString: AChildNode.ValueAsUnicodeString := AValue; - varByte, - varSmallInt, - varInteger: AChildNode.ValueAsInteger := AValue; - varSingle, - varDouble: AChildNode.ValueAsFloat := AValue; - varCurrency: - begin - ACurrency := AValue; - AChildNode.BufferWrite(ACurrency, SizeOf(ACurrency)); - end; - varDate: AChildNode.ValueAsDateTime := AValue; - varBoolean: AChildNode.ValueAsBool := AValue; - else - try - ANode.ValueAsUnicodeString := AValue; - except - raise Exception.Create(sxwIllegalVarType); - end; - end;//case - end; - end; - -begin - if (PPropInfo(PropInfo)^.SetProc <> nil) and - (PPropInfo(PropInfo)^.GetProc <> nil) then - begin - PropType := PPropInfo(PropInfo)^.PropType^; - case PropType^.Kind of - tkInteger, tkChar, tkEnumeration, tkSet: WriteOrdProp; - tkFloat: WriteFloatProp; - tkString, tkLString: WriteStrProp; - {$IFDEF D6UP} - tkWString: WriteWideStrProp; - {$ENDIF} - tkClass: WriteObjectProp; - tkMethod: WriteMethodProp; - tkVariant: WriteVariantProp; - tkInt64: WriteInt64Prop; - end; - end; -end; - -{ TsdXmlObjectReader } - -function TsdXmlObjectReader.CreateComponent(ANode: TXmlNode; - AOwner, AParent: TComponent; AName: string): TComponent; -var - AClass: TComponentClass; -begin - AClass := TComponentClass(GetClass(string(ANode.Name))); - if not assigned(AClass) then - raise Exception.Create(sxrUnregisteredClassType); - Result := AClass.Create(AOwner); - if length(AName) = 0 then - Result.Name := string(ANode.AttributeByName['Name']) - else - Result.Name := AName; - if not assigned(AParent) then - AParent := Result; - ReadComponent(ANode, Result, AParent); -end; - -procedure TsdXmlObjectReader.ReadComponent(ANode: TXmlNode; AComponent, - AParent: TComponent); -begin - ReadObject(ANode, AComponent, AParent); -end; - -procedure TsdXmlObjectReader.ReadObject(ANode: TXmlNode; AObject: TObject; AParent: TComponent); -var - i, Count: Integer; - PropInfo: PPropInfo; - PropList: PPropList; - S: TStringStream; - AReader: TReader; - AChildNode: TXmlNode; - AComponentNode: TXmlNode; - AClass: TComponentClass; - AComponent: TComponent; -begin - if not assigned(ANode) or not assigned(AObject) then exit; - - // Start loading - if AObject is TComponent then with THackComponent(AObject) do begin - THackComponent(AObject).Updating; - SetComponentState(ComponentState + [csLoading, csReading]); - end; - try - - // If this is a component, load child components - if AObject is TComponent then with TComponent(AObject) do begin - AChildNode := ANode.NodeByName('Components'); - if assigned(AChildNode) then begin - for i := 0 to AChildNode.NodeCount - 1 do begin - AComponentNode := AChildNode.Nodes[i]; - AComponent := FindComponent(string(AComponentNode.AttributeByName['Name'])); - if not assigned(AComponent) then begin - AClass := TComponentClass(GetClass(string(AComponentNode.Name))); - if not assigned(AClass) then - raise Exception.Create(sxrUnregisteredClassType); - AComponent := AClass.Create(TComponent(AObject)); - AComponent.Name := AComponentNode.AttributeByName['Name']; - // In case of new (visual) controls we set the parent - if (AComponent is TControl) and (AObject is TWinControl) then - TControl(AComponent).Parent := TWinControl(AObject); - end; - ReadComponent(AComponentNode, AComponent, TComponent(AObject)); - end; - end; - end; - - // Load all loadable regular properties - Count := GetTypeData(AObject.ClassInfo)^.PropCount; - if Count > 0 then begin - GetMem(PropList, Count * SizeOf(Pointer)); - try - GetPropInfos(AObject.ClassInfo, PropList); - for i := 0 to Count - 1 do begin - PropInfo := PropList^[i]; - if PropInfo = nil then continue; - if IsStoredProp(AObject, PropInfo) then - ReadProperty(ANode, AObject, AParent, PropInfo); - end; - finally - FreeMem(PropList, Count * SizeOf(Pointer)); - end; - end; - - // Load defined properties - if AObject is TPersistent then begin - AChildNode := ANode.NodeByName('DefinedProperties'); - if assigned(AChildNode) then begin - S := TStringStream.Create(AChildNode.BinaryString); - try - AReader := TReader.Create(S, 4096); - try - THackReader(AReader).ReadProperty(TPersistent(AObject)); - finally - AReader.Free; - end; - finally - S.Free; - end; - end; - end; - - finally - // End loading - if AObject is TComponent then with THackComponent(AObject) do begin - SetComponentState(ComponentState - [csReading]); - THackComponent(AObject).Loaded; - THackComponent(AObject).Updated; - end; - end; -end; - -procedure TsdXmlObjectReader.ReadProperty(ANode: TXmlNode; - AObject: TObject; AParent: TComponent; PropInfo: PPropInfo); -var - PropType: PTypeInfo; - AChildNode: TXmlNode; - Method: TMethod; - PropObject: TObject; - - procedure SetSetProp(const AValue: string); - var - S: string; - P: integer; - ASet: integer; - EnumType: PTypeInfo; - - procedure AddToEnum(const EnumName: string); - var - V: integer; - begin - if length(EnumName) = 0 then exit; - V := GetEnumValue(EnumType, EnumName); - if V = -1 then - raise Exception.Create(sxrInvalidPropertyValue); - Include(TIntegerSet(ASet), V); - end; - begin - ASet := 0; - EnumType := GetTypeData(PropType)^.CompType^; - S := copy(AValue, 2, length(AValue) - 2); - repeat - P := Pos(',', S); - if P > 0 then begin - AddToEnum(copy(S, 1, P - 1)); - S := copy(S, P + 1, length(S)); - end else begin - AddToEnum(S); - break; - end; - until False; - SetOrdProp(AObject, PropInfo, ASet); - end; - - procedure SetIntProp(const AValue: string); - var - V: Longint; - IdentToInt: TIdentToInt; - begin - IdentToInt := FindIdentToInt(PropType); - if Assigned(IdentToInt) and IdentToInt(AValue, V) then - SetOrdProp(AObject, PropInfo, V) - else - SetOrdProp(AObject, PropInfo, StrToInt(AValue)); - end; - - procedure SetCharProp(const AValue: string); - begin - if length(AValue) <> 1 then - raise Exception.Create(sxrInvalidPropertyValue); - SetOrdProp(AObject, PropInfo, Ord(AValue[1])); - end; - - procedure SetEnumProp(const AValue: string); - var - V: integer; - begin - V := GetEnumValue(PropType, AValue); - if V = -1 then - raise Exception.Create(sxrInvalidPropertyValue); - SetOrdProp(AObject, PropInfo, V) - end; - - procedure ReadCollectionProp(ACollection: TCollection); - var - i: integer; - Item: TPersistent; - begin - ACollection.BeginUpdate; - try - ACollection.Clear; - for i := 0 to AChildNode.NodeCount - 1 do begin - Item := ACollection.Add; - ReadObject(AChildNode.Nodes[i], Item, AParent); - end; - finally - ACollection.EndUpdate; - end; - end; - - procedure SetObjectProp(const AValue: string); - var - AClassName: string; - PropObject: TObject; - Reference: TComponent; - begin - if length(AValue) = 0 then exit; - if AValue[1] = '(' then begin - // Persistent class - AClassName := Copy(AValue, 2, length(AValue) - 2); - PropObject := TObject(GetOrdProp(AObject, PropInfo)); - if assigned(PropObject) and (PropObject.ClassName = AClassName) then begin - if PropObject is TCollection then - ReadCollectionProp(TCollection(PropObject)) - else begin - if AObject is TComponent then - ReadObject(AChildNode, PropObject, TComponent(AObject)) - else - ReadObject(AChildNode, PropObject, AParent); - end; - end else - raise Exception.Create(sxrUnregisteredClassType); - end else begin - // Component reference - if assigned(AParent) then begin - Reference := FindNestedComponent(AParent, AValue); - SetOrdProp(AObject, PropInfo, Longint(Reference)); - end; - end; - end; - - procedure SetMethodProp(const AValue: string); - var - Method: TMethod; - begin - // to do: add OnFindMethod - if not assigned(AParent) then exit; - Method.Code := AParent.MethodAddress(AValue); - if not assigned(Method.Code) then - raise Exception.Create(sxwInvalidMethodName); - Method.Data := AParent; - TypInfo.SetMethodProp(AObject, PropInfo, Method); - end; - - procedure SetVariantProp(const AValue: string); - var - VType: integer; - Value: Variant; - ACurrency: Currency; - begin - VType := StrToInt(AChildNode.AttributeByName['VarType']); - - case VType and varTypeMask of - varOleStr: Value := AChildNode.ValueAsUnicodeString; - varString: Value := AChildNode.ValueAsString; - varByte, - varSmallInt, - varInteger: Value := AChildNode.ValueAsInteger; - varSingle, - varDouble: Value := AChildNode.ValueAsFloat; - varCurrency: - begin - AChildNode.BufferWrite(ACurrency, SizeOf(ACurrency)); - Value := ACurrency; - end; - varDate: Value := AChildNode.ValueAsDateTime; - varBoolean: Value := AChildNode.ValueAsBool; - else - try - Value := ANode.ValueAsString; - except - raise Exception.Create(sxwIllegalVarType); - end; - end;//case - - TVarData(Value).VType := VType; - TypInfo.SetVariantProp(AObject, PropInfo, Value); - end; - -begin - if (PPropInfo(PropInfo)^.SetProc <> nil) and - (PPropInfo(PropInfo)^.GetProc <> nil) then - begin - PropType := PPropInfo(PropInfo)^.PropType^; - AChildNode := ANode.NodeByName(PPropInfo(PropInfo)^.Name); - if assigned(AChildNode) then begin - // Non-default values from XML - case PropType^.Kind of - tkInteger: SetIntProp(AChildNode.ValueAsString); - tkChar: SetCharProp(AChildNode.ValueAsString); - tkSet: SetSetProp(AChildNode.ValueAsString); - tkEnumeration: SetEnumProp(AChildNode.ValueAsString); - tkFloat: SetFloatProp(AObject, PropInfo, AChildNode.ValueAsFloat); - tkString, - tkLString: SetStrProp(AObject, PropInfo, AChildNode.ValueAsString); - {$IFDEF D6UP} - tkWString: SetWideStrProp(AObject, PropInfo, AChildNode.ValueAsUnicodeString); - {$ENDIF} - tkClass: SetObjectProp(AChildNode.ValueAsString); - tkMethod: SetMethodProp(AChildNode.ValueAsString); - tkVariant: SetVariantProp(AChildNode.ValueAsString); - tkInt64: SetInt64Prop(AObject, PropInfo, AChildNode.ValueAsInt64); - end;//case - end else begin - // Set Default value - case PropType^.Kind of - tkInteger: SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default); - tkChar: SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default); - tkSet: SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default); - tkEnumeration: SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default); - tkFloat: SetFloatProp(AObject, PropInfo, 0); - tkString, - tkLString, - tkWString: SetStrProp(AObject, PropInfo, ''); - tkClass: - begin - PropObject := TObject(GetOrdProp(AObject, PropInfo)); - if PropObject is TComponent then - SetOrdProp(AObject, PropInfo, 0); - end; - tkMethod: - begin - Method := TypInfo.GetMethodProp(AObject, PropInfo); - Method.Code := nil; - TypInfo.SetMethodProp(AObject, PropInfo, Method); - end; - tkInt64: SetInt64Prop(AObject, PropInfo, 0); - end;//case - end; - end; -end; - -{ THackComponent } - -procedure THackComponent.SetComponentState(const AState: TComponentState); -type - PInteger = ^integer; -var - PSet: PInteger; - AInfo: PPropInfo; -begin - // This is a "severe" hack in order to set a non-writable property value, - // also using RTTI - PSet := PInteger(@AState); - AInfo := GetPropInfo(THackComponent, 'ComponentState'); - if assigned(AInfo.GetProc) then - PInteger(Integer(Self) + Integer(AInfo.GetProc) and $00FFFFFF)^ := PSet^; -end; - -initialization - - {$IFDEF TRIALXML} - ShowMessage('ObjectToXml demo.'#13#10'For more information please visit:'#13#10 + - 'http://www.simdesign.nl/xml.html'); - {$ENDIF} - -end. - diff --git a/addons/superobject/superobject.pas b/addons/superobject/superobject.pas deleted file mode 100644 index b69f49f..0000000 --- a/addons/superobject/superobject.pas +++ /dev/null @@ -1,6555 +0,0 @@ -(* - * Super Object Toolkit - * - * Usage allowed under the restrictions of the Lesser GNU General Public License - * or alternatively the restrictions of the Mozilla Public License 1.1 - * - * Software distributed under the License is distributed on an "AS IS" basis, - * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - * the specific language governing rights and limitations under the License. - * - * Unit owner : Henri Gourvest - * Web site : http://www.progdigy.com - * - * This unit is inspired from the json c lib: - * Michael Clark - * http://oss.metaparadigm.com/json-c/ - * - * CHANGES: - * v1.2 - * + support of currency data type - * + right trim unquoted string - * + read Unicode Files and streams (Litle Endian with BOM) - * + Fix bug on javadate functions + windows nt compatibility - * + Now you can force to parse only the canonical syntax of JSON using the stric parameter - * + Delphi 2010 RTTI marshalling - * v1.1 - * + Double licence MPL or LGPL. - * + Delphi 2009 compatibility & Unicode support. - * + AsString return a string instead of PChar. - * + Escaped and Unascaped JSON serialiser. - * + Missed FormFeed added \f - * - Removed @ trick, uses forcepath() method instead. - * + Fixed parse error with uppercase E symbol in numbers. - * + Fixed possible buffer overflow when enlarging array. - * + Added "delete", "pack", "insert" methods for arrays and/or objects - * + Multi parametters when calling methods - * + Delphi Enumerator (for obj1 in obj2 do ...) - * + Format method ex: obj.format('<%name%>%tab[1]%') - * + ParseFile and ParseStream methods - * + Parser now understand hexdecimal c syntax ex: \xFF - * + Null Object Design Patern (ex: for obj in values.N['path'] do ...) - * v1.0 - * + renamed class - * + interfaced object - * + added a new data type: the method - * + parser can now evaluate properties and call methods - * - removed obselet rpc class - * - removed "find" method, now you can use "parse" method instead - * v0.6 - * + refactoring - * v0.5 - * + new find method to get or set value using a path syntax - * ex: obj.s['obj.prop[1]'] := 'string value'; - * obj.a['@obj.array'].b[n] := true; // @ -> create property if necessary - * v0.4 - * + bug corrected: AVL tree badly balanced. - * v0.3 - * + New validator partially based on the Kwalify syntax. - * + extended syntax to parse unquoted fields. - * + Freepascal compatibility win32/64 Linux32/64. - * + JavaToDelphiDateTime and DelphiToJavaDateTime improved for UTC. - * + new TJsonObject.Compare function. - * v0.2 - * + Hashed string list replaced with a faster AVL tree - * + JsonInt data type can be changed to int64 - * + JavaToDelphiDateTime and DelphiToJavaDateTime helper fonctions - * + from json-c v0.7 - * + Add escaping of backslash to json output - * + Add escaping of foward slash on tokenizing and output - * + Changes to internal tokenizer from using recursion to - * using a depth state structure to allow incremental parsing - * v0.1 - * + first release - *) - -{$IFDEF FPC} - {$MODE OBJFPC}{$H+} -{$ENDIF} - -{$DEFINE SUPER_METHOD} -{$DEFINE WINDOWSNT_COMPATIBILITY} -{.$DEFINE DEBUG} // track memory leack - -unit superobject; - -interface -uses - Classes -{$IFDEF VER210} - ,Generics.Collections, RTTI, TypInfo -{$ENDIF} - ; - -type -{$IFNDEF FPC} - PtrInt = longint; - PtrUInt = Longword; -{$ENDIF} - SuperInt = Int64; - -{$if (sizeof(Char) = 1)} - SOChar = WideChar; - SOIChar = Word; - PSOChar = PWideChar; - SOString = WideString; -{$else} - SOChar = Char; - SOIChar = Word; - PSOChar = PChar; - SOString = string; -{$ifend} - -const - SUPER_ARRAY_LIST_DEFAULT_SIZE = 32; - SUPER_TOKENER_MAX_DEPTH = 32; - - SUPER_AVL_MAX_DEPTH = sizeof(longint) * 8; - SUPER_AVL_MASK_HIGH_BIT = not ((not longword(0)) shr 1); - -type - // forward declarations - TSuperObject = class; - ISuperObject = interface; - TSuperArray = class; - -(* AVL Tree - * This is a "special" autobalanced AVL tree - * It use a hash value for fast compare - *) - -{$IFDEF SUPER_METHOD} - TSuperMethod = procedure(const This, Params: ISuperObject; var Result: ISuperObject); -{$ENDIF} - - - TSuperAvlBitArray = set of 0..SUPER_AVL_MAX_DEPTH - 1; - - TSuperAvlSearchType = (stEQual, stLess, stGreater); - TSuperAvlSearchTypes = set of TSuperAvlSearchType; - TSuperAvlIterator = class; - - TSuperAvlEntry = class - private - FGt, FLt: TSuperAvlEntry; - FBf: integer; - FHash: Cardinal; - FName: SOString; - FPtr: Pointer; - function GetValue: ISuperObject; - procedure SetValue(const val: ISuperObject); - public - class function Hash(const k: SOString): Cardinal; virtual; - constructor Create(const AName: SOString; Obj: Pointer); virtual; - property Name: SOString read FName; - property Ptr: Pointer read FPtr; - property Value: ISuperObject read GetValue write SetValue; - end; - - TSuperAvlTree = class - private - FRoot: TSuperAvlEntry; - FCount: Integer; - function balance(bal: TSuperAvlEntry): TSuperAvlEntry; - protected - procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); virtual; - function CompareNodeNode(node1, node2: TSuperAvlEntry): integer; virtual; - function CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; virtual; - function Insert(h: TSuperAvlEntry): TSuperAvlEntry; virtual; - function Search(const k: SOString; st: TSuperAvlSearchTypes = [stEqual]): TSuperAvlEntry; virtual; - public - constructor Create; virtual; - destructor Destroy; override; - function IsEmpty: boolean; - procedure Clear(all: boolean = false); virtual; - procedure Pack(all: boolean); - function Delete(const k: SOString): ISuperObject; - function GetEnumerator: TSuperAvlIterator; - property count: Integer read FCount; - end; - - TSuperTableString = class(TSuperAvlTree) - protected - procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); override; - procedure PutO(const k: SOString; const value: ISuperObject); - function GetO(const k: SOString): ISuperObject; - procedure PutS(const k: SOString; const value: SOString); - function GetS(const k: SOString): SOString; - procedure PutI(const k: SOString; value: SuperInt); - function GetI(const k: SOString): SuperInt; - procedure PutD(const k: SOString; value: Double); - function GetD(const k: SOString): Double; - procedure PutB(const k: SOString; value: Boolean); - function GetB(const k: SOString): Boolean; -{$IFDEF SUPER_METHOD} - procedure PutM(const k: SOString; value: TSuperMethod); - function GetM(const k: SOString): TSuperMethod; -{$ENDIF} - procedure PutN(const k: SOString; const value: ISuperObject); - function GetN(const k: SOString): ISuperObject; - procedure PutC(const k: SOString; value: Currency); - function GetC(const k: SOString): Currency; - public - property O[const k: SOString]: ISuperObject read GetO write PutO; default; - property S[const k: SOString]: SOString read GetS write PutS; - property I[const k: SOString]: SuperInt read GetI write PutI; - property D[const k: SOString]: Double read GetD write PutD; - property B[const k: SOString]: Boolean read GetB write PutB; -{$IFDEF SUPER_METHOD} - property M[const k: SOString]: TSuperMethod read GetM write PutM; -{$ENDIF} - property N[const k: SOString]: ISuperObject read GetN write PutN; - property C[const k: SOString]: Currency read GetC write PutC; - - function GetValues: ISuperObject; - function GetNames: ISuperObject; - end; - - TSuperAvlIterator = class - private - FTree: TSuperAvlTree; - FBranch: TSuperAvlBitArray; - FDepth: LongInt; - FPath: array[0..SUPER_AVL_MAX_DEPTH - 2] of TSuperAvlEntry; - public - constructor Create(tree: TSuperAvlTree); virtual; - procedure Search(const k: SOString; st: TSuperAvlSearchTypes = [stEQual]); - procedure First; - procedure Last; - function GetIter: TSuperAvlEntry; - procedure Next; - procedure Prior; - // delphi enumerator - function MoveNext: Boolean; - property Current: TSuperAvlEntry read GetIter; - end; - - TSuperObjectArray = array[0..(high(PtrInt) div sizeof(TSuperObject))-1] of ISuperObject; - PSuperObjectArray = ^TSuperObjectArray; - - TSuperArray = class - private - FArray: PSuperObjectArray; - FLength: Integer; - FSize: Integer; - procedure Expand(max: Integer); - protected - function GetO(const index: integer): ISuperObject; - procedure PutO(const index: integer; const Value: ISuperObject); - function GetB(const index: integer): Boolean; - procedure PutB(const index: integer; Value: Boolean); - function GetI(const index: integer): SuperInt; - procedure PutI(const index: integer; Value: SuperInt); - function GetD(const index: integer): Double; - procedure PutD(const index: integer; Value: Double); - function GetC(const index: integer): Currency; - procedure PutC(const index: integer; Value: Currency); - function GetS(const index: integer): SOString; - procedure PutS(const index: integer; const Value: SOString); -{$IFDEF SUPER_METHOD} - function GetM(const index: integer): TSuperMethod; - procedure PutM(const index: integer; Value: TSuperMethod); -{$ENDIF} - function GetN(const index: integer): ISuperObject; - procedure PutN(const index: integer; const Value: ISuperObject); - public - constructor Create; virtual; - destructor Destroy; override; - function Add(const Data: ISuperObject): Integer; - function Delete(index: Integer): ISuperObject; - procedure Insert(index: Integer; const value: ISuperObject); - procedure Clear(all: boolean = false); - procedure Pack(all: boolean); - property Length: Integer read FLength; - - property N[const index: integer]: ISuperObject read GetN write PutN; - property O[const index: integer]: ISuperObject read GetO write PutO; default; - property B[const index: integer]: boolean read GetB write PutB; - property I[const index: integer]: SuperInt read GetI write PutI; - property D[const index: integer]: Double read GetD write PutD; - property C[const index: integer]: Currency read GetC write PutC; - property S[const index: integer]: SOString read GetS write PutS; -{$IFDEF SUPER_METHOD} - property M[const index: integer]: TSuperMethod read GetM write PutM; -{$ENDIF} -// property A[const index: integer]: TSuperArray read GetA; - end; - - TSuperWriter = class - public - // abstact methods to overide - function Append(buf: PSOChar; Size: Integer): Integer; overload; virtual; abstract; - function Append(buf: PSOChar): Integer; overload; virtual; abstract; - procedure Reset; virtual; abstract; - end; - - TSuperWriterString = class(TSuperWriter) - private - FBuf: PSOChar; - FBPos: integer; - FSize: integer; - public - function Append(buf: PSOChar; Size: Integer): Integer; overload; override; - function Append(buf: PSOChar): Integer; overload; override; - procedure Reset; override; - procedure TrimRight; - constructor Create; virtual; - destructor Destroy; override; - function GetString: SOString; - property Data: PSOChar read FBuf; - property Size: Integer read FSize; - property Position: integer read FBPos; - end; - - TSuperWriterStream = class(TSuperWriter) - private - FStream: TStream; - public - function Append(buf: PSOChar): Integer; override; - procedure Reset; override; - constructor Create(AStream: TStream); reintroduce; virtual; - end; - - TSuperAnsiWriterStream = class(TSuperWriterStream) - public - function Append(buf: PSOChar; Size: Integer): Integer; override; - end; - - TSuperUnicodeWriterStream = class(TSuperWriterStream) - public - function Append(buf: PSOChar; Size: Integer): Integer; override; - end; - - TSuperWriterFake = class(TSuperWriter) - private - FSize: Integer; - public - function Append(buf: PSOChar; Size: Integer): Integer; override; - function Append(buf: PSOChar): Integer; override; - procedure Reset; override; - constructor Create; reintroduce; virtual; - property size: integer read FSize; - end; - - TSuperWriterSock = class(TSuperWriter) - private - FSocket: longint; - FSize: Integer; - public - function Append(buf: PSOChar; Size: Integer): Integer; override; - function Append(buf: PSOChar): Integer; override; - procedure Reset; override; - constructor Create(ASocket: longint); reintroduce; virtual; - property Socket: longint read FSocket; - property Size: Integer read FSize; - end; - - TSuperTokenizerError = ( - teSuccess, - teContinue, - teDepth, - teParseEof, - teParseUnexpected, - teParseNull, - teParseBoolean, - teParseNumber, - teParseArray, - teParseObjectKeyName, - teParseObjectKeySep, - teParseObjectValueSep, - teParseString, - teParseComment, - teEvalObject, - teEvalArray, - teEvalMethod, - teEvalInt - ); - - TSuperTokenerState = ( - tsEatws, - tsStart, - tsFinish, - tsNull, - tsCommentStart, - tsComment, - tsCommentEol, - tsCommentEnd, - tsString, - tsStringEscape, - tsIdentifier, - tsEscapeUnicode, - tsEscapeHexadecimal, - tsBoolean, - tsNumber, - tsArray, - tsArrayAdd, - tsArraySep, - tsObjectFieldStart, - tsObjectField, - tsObjectUnquotedField, - tsObjectFieldEnd, - tsObjectValue, - tsObjectValueAdd, - tsObjectSep, - tsEvalProperty, - tsEvalArray, - tsEvalMethod, - tsParamValue, - tsParamPut, - tsMethodValue, - tsMethodPut - ); - - PSuperTokenerSrec = ^TSuperTokenerSrec; - TSuperTokenerSrec = record - state, saved_state: TSuperTokenerState; - obj: ISuperObject; - current: ISuperObject; - field_name: SOString; - parent: ISuperObject; - gparent: ISuperObject; - end; - - TSuperTokenizer = class - public - str: PSOChar; - pb: TSuperWriterString; - depth, is_double, floatcount, st_pos, char_offset: Integer; - err: TSuperTokenizerError; - ucs_char: Word; - quote_char: SOChar; - stack: array[0..SUPER_TOKENER_MAX_DEPTH-1] of TSuperTokenerSrec; - line, col: Integer; - public - constructor Create; virtual; - destructor Destroy; override; - procedure ResetLevel(adepth: integer); - procedure Reset; - end; - - // supported object types - TSuperType = ( - stNull, - stBoolean, - stDouble, - stCurrency, - stInt, - stObject, - stArray, - stString -{$IFDEF SUPER_METHOD} - ,stMethod -{$ENDIF} - ); - - TSuperValidateError = ( - veRuleMalformated, - veFieldIsRequired, - veInvalidDataType, - veFieldNotFound, - veUnexpectedField, - veDuplicateEntry, - veValueNotInEnum, - veInvalidLength, - veInvalidRange - ); - - TSuperFindOption = ( - foCreatePath, - foPutValue, - foDelete -{$IFDEF SUPER_METHOD} - ,foCallMethod -{$ENDIF} - ); - - TSuperFindOptions = set of TSuperFindOption; - TSuperCompareResult = (cpLess, cpEqu, cpGreat, cpError); - TSuperOnValidateError = procedure(sender: Pointer; error: TSuperValidateError; const objpath: SOString); - - TSuperEnumerator = class - private - FObj: ISuperObject; - FObjEnum: TSuperAvlIterator; - FCount: Integer; - public - constructor Create(const obj: ISuperObject); virtual; - destructor Destroy; override; - function MoveNext: Boolean; - function GetCurrent: ISuperObject; - property Current: ISuperObject read GetCurrent; - end; - - ISuperObject = interface - ['{4B86A9E3-E094-4E5A-954A-69048B7B6327}'] - function GetEnumerator: TSuperEnumerator; - function GetDataType: TSuperType; - function GetProcessing: boolean; - procedure SetProcessing(value: boolean); - function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject; - function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString; - - function GetO(const path: SOString): ISuperObject; - procedure PutO(const path: SOString; const Value: ISuperObject); - function GetB(const path: SOString): Boolean; - procedure PutB(const path: SOString; Value: Boolean); - function GetI(const path: SOString): SuperInt; - procedure PutI(const path: SOString; Value: SuperInt); - function GetD(const path: SOString): Double; - procedure PutC(const path: SOString; Value: Currency); - function GetC(const path: SOString): Currency; - procedure PutD(const path: SOString; Value: Double); - function GetS(const path: SOString): SOString; - procedure PutS(const path: SOString; const Value: SOString); -{$IFDEF SUPER_METHOD} - function GetM(const path: SOString): TSuperMethod; - procedure PutM(const path: SOString; Value: TSuperMethod); -{$ENDIF} - function GetA(const path: SOString): TSuperArray; - - // Null Object Design patern - function GetN(const path: SOString): ISuperObject; - procedure PutN(const path: SOString; const Value: ISuperObject); - - // Writers - function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; - function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload; - function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload; - function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload; - function CalcSize(indent: boolean = false; escape: boolean = true): integer; - - // convert - function AsBoolean: Boolean; - function AsInteger: SuperInt; - function AsDouble: Double; - function AsCurrency: Currency; - function AsString: SOString; - function AsArray: TSuperArray; - function AsObject: TSuperTableString; -{$IFDEF SUPER_METHOD} - function AsMethod: TSuperMethod; -{$ENDIF} - function AsJSon(indent: boolean = false; escape: boolean = true): SOString; - - procedure Clear(all: boolean = false); - procedure Pack(all: boolean = false); - - property N[const path: SOString]: ISuperObject read GetN write PutN; - property O[const path: SOString]: ISuperObject read GetO write PutO; default; - property B[const path: SOString]: boolean read GetB write PutB; - property I[const path: SOString]: SuperInt read GetI write PutI; - property D[const path: SOString]: Double read GetD write PutD; - property C[const path: SOString]: Currency read GetC write PutC; - property S[const path: SOString]: SOString read GetS write PutS; -{$IFDEF SUPER_METHOD} - property M[const path: SOString]: TSuperMethod read GetM write PutM; -{$ENDIF} - property A[const path: SOString]: TSuperArray read GetA; - -{$IFDEF SUPER_METHOD} - function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; - function call(const path, param: SOString): ISuperObject; overload; -{$ENDIF} - // clone a node - function Clone: ISuperObject; - function Delete(const path: SOString): ISuperObject; - // merges tow objects of same type, if reference is true then nodes are not cloned - procedure Merge(const obj: ISuperObject; reference: boolean = false); overload; - procedure Merge(const str: SOString); overload; - - // validate methods - function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; - function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; - - // compare - function Compare(const obj: ISuperObject): TSuperCompareResult; overload; - function Compare(const str: SOString): TSuperCompareResult; overload; - - // the data type - function IsType(AType: TSuperType): boolean; - property DataType: TSuperType read GetDataType; - property Processing: boolean read GetProcessing write SetProcessing; - - function GetDataPtr: Pointer; - procedure SetDataPtr(const Value: Pointer); - property DataPtr: Pointer read GetDataPtr write SetDataPtr; - end; - - TSuperObject = class(TObject, ISuperObject) - private - FRefCount: Integer; - FProcessing: boolean; - FDataType: TSuperType; - FDataPtr: Pointer; -{.$if true} - FO: record - case TSuperType of - stBoolean: (c_boolean: boolean); - stDouble: (c_double: double); - stCurrency: (c_currency: Currency); - stInt: (c_int: SuperInt); - stObject: (c_object: TSuperTableString); - stArray: (c_array: TSuperArray); -{$IFDEF SUPER_METHOD} - stMethod: (c_method: TSuperMethod); -{$ENDIF} - end; -{.$ifend} - FOString: SOString; - function GetDataType: TSuperType; - function GetDataPtr: Pointer; - procedure SetDataPtr(const Value: Pointer); - protected - function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; - function _AddRef: Integer; virtual; stdcall; - function _Release: Integer; virtual; stdcall; - - function GetO(const path: SOString): ISuperObject; - procedure PutO(const path: SOString; const Value: ISuperObject); - function GetB(const path: SOString): Boolean; - procedure PutB(const path: SOString; Value: Boolean); - function GetI(const path: SOString): SuperInt; - procedure PutI(const path: SOString; Value: SuperInt); - function GetD(const path: SOString): Double; - procedure PutD(const path: SOString; Value: Double); - procedure PutC(const path: SOString; Value: Currency); - function GetC(const path: SOString): Currency; - function GetS(const path: SOString): SOString; - procedure PutS(const path: SOString; const Value: SOString); -{$IFDEF SUPER_METHOD} - function GetM(const path: SOString): TSuperMethod; - procedure PutM(const path: SOString; Value: TSuperMethod); -{$ENDIF} - function GetA(const path: SOString): TSuperArray; - function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; virtual; - public - function GetEnumerator: TSuperEnumerator; - procedure AfterConstruction; override; - procedure BeforeDestruction; override; - class function NewInstance: TObject; override; - property RefCount: Integer read FRefCount; - - function GetProcessing: boolean; - procedure SetProcessing(value: boolean); - - // Writers - function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload; - function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload; - function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload; - function CalcSize(indent: boolean = false; escape: boolean = true): integer; - function AsJSon(indent: boolean = false; escape: boolean = true): SOString; - - // parser ... owned! - class function ParseString(s: PSOChar; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; - const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; - class function ParseStream(stream: TStream; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; - const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; - class function ParseFile(const FileName: string; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; - const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; - class function ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; strict: Boolean; const this: ISuperObject = nil; - options: TSuperFindOptions = []; const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; - - // constructors / destructor - constructor Create(jt: TSuperType = stObject); overload; virtual; - constructor Create(b: boolean); overload; virtual; - constructor Create(i: SuperInt); overload; virtual; - constructor Create(d: double); overload; virtual; - constructor CreateCurrency(c: Currency); overload; virtual; - constructor Create(const s: SOString); overload; virtual; -{$IFDEF SUPER_METHOD} - constructor Create(m: TSuperMethod); overload; virtual; -{$ENDIF} - destructor Destroy; override; - - // convert - function AsBoolean: Boolean; virtual; - function AsInteger: SuperInt; virtual; - function AsDouble: Double; virtual; - function AsCurrency: Currency; virtual; - function AsString: SOString; virtual; - function AsArray: TSuperArray; virtual; - function AsObject: TSuperTableString; virtual; -{$IFDEF SUPER_METHOD} - function AsMethod: TSuperMethod; virtual; -{$ENDIF} - procedure Clear(all: boolean = false); virtual; - procedure Pack(all: boolean = false); virtual; - function GetN(const path: SOString): ISuperObject; - procedure PutN(const path: SOString; const Value: ISuperObject); - function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject; - function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString; - - property N[const path: SOString]: ISuperObject read GetN write PutN; - property O[const path: SOString]: ISuperObject read GetO write PutO; default; - property B[const path: SOString]: boolean read GetB write PutB; - property I[const path: SOString]: SuperInt read GetI write PutI; - property D[const path: SOString]: Double read GetD write PutD; - property C[const path: SOString]: Currency read GetC write PutC; - property S[const path: SOString]: SOString read GetS write PutS; -{$IFDEF SUPER_METHOD} - property M[const path: SOString]: TSuperMethod read GetM write PutM; -{$ENDIF} - property A[const path: SOString]: TSuperArray read GetA; - -{$IFDEF SUPER_METHOD} - function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; virtual; - function call(const path, param: SOString): ISuperObject; overload; virtual; -{$ENDIF} - // clone a node - function Clone: ISuperObject; virtual; - function Delete(const path: SOString): ISuperObject; - // merges tow objects of same type, if reference is true then nodes are not cloned - procedure Merge(const obj: ISuperObject; reference: boolean = false); overload; - procedure Merge(const str: SOString); overload; - - // validate methods - function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; - function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; - - // compare - function Compare(const obj: ISuperObject): TSuperCompareResult; overload; - function Compare(const str: SOString): TSuperCompareResult; overload; - - // the data type - function IsType(AType: TSuperType): boolean; - property DataType: TSuperType read GetDataType; - // a data pointer to link to something ele, a treeview for example - property DataPtr: Pointer read GetDataPtr write SetDataPtr; - property Processing: boolean read GetProcessing; - end; - -{$IFDEF VER210} - TSuperRttiContext = class; - - TSerialFromJson = function(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; - TSerialToJson = function(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; - - TSuperAttribute = class(TCustomAttribute) - private - FName: string; - public - constructor Create(const AName: string); - property Name: string read FName; - end; - - SOName = class(TSuperAttribute); - SODefault = class(TSuperAttribute); - - - TSuperRttiContext = class - private - class function GetFieldName(r: TRttiField): string; - class function GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject; - public - Context: TRttiContext; - SerialFromJson: TDictionary; - SerialToJson: TDictionary; - constructor Create; virtual; - destructor Destroy; override; - function FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; var Value: TValue): Boolean; virtual; - function ToJson(var value: TValue; const index: ISuperObject): ISuperObject; virtual; - function AsType(const obj: ISuperObject): T; - function AsJson(const obj: T; const index: ISuperObject = nil): ISuperObject; - end; - - TSuperObjectHelper = class helper for TObject - public - function ToJson(ctx: TSuperRttiContext = nil): ISuperObject; - constructor FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); overload; - constructor FromJson(const str: string; ctx: TSuperRttiContext = nil); overload; - end; -{$ENDIF} - - TSuperObjectIter = record - key: SOString; - val: ISuperObject; - Ite: TSuperAvlIterator; - end; - -function ObjectIsError(obj: TSuperObject): boolean; -function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean; -function ObjectGetType(const obj: ISuperObject): TSuperType; - -function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean; -function ObjectFindNext(var F: TSuperObjectIter): boolean; -procedure ObjectFindClose(var F: TSuperObjectIter); - -function SO(const s: SOString = '{}'): ISuperObject; overload; -function SO(const value: Variant): ISuperObject; overload; -function SO(const Args: array of const): ISuperObject; overload; - -function SA(const Args: array of const): ISuperObject; overload; - -function JavaToDelphiDateTime(const dt: int64): TDateTime; -function DelphiToJavaDateTime(const dt: TDateTime): int64; - -{$IFDEF VER210} - -type - TSuperInvokeResult = ( - irSuccess, - irMethothodError, // method don't exist - irParamError, // invalid parametters - irError // other error - ); - -function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; const method: string; const params: ISuperObject; var Return: ISuperObject): TSuperInvokeResult; overload; -function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext = nil): ISuperObject; overload; -function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext = nil): ISuperObject; overload; -{$ENDIF} - -implementation -uses sysutils, -{$IFDEF UNIX} - baseunix, unix, DateUtils -{$ELSE} - Windows -{$ENDIF} -{$IFDEF FPC} - ,sockets -{$ELSE} - ,WinSock -{$ENDIF}; - -{$IFDEF DEBUG} -var - debugcount: integer = 0; -{$ENDIF} - -const - super_number_chars_set = ['0'..'9','.','+','-','e','E']; - super_hex_chars: PSOChar = '0123456789abcdef'; - super_hex_chars_set = ['0'..'9','a'..'f','A'..'F']; - - ESC_BS: PSOChar = '\b'; - ESC_LF: PSOChar = '\n'; - ESC_CR: PSOChar = '\r'; - ESC_TAB: PSOChar = '\t'; - ESC_FF: PSOChar = '\f'; - ESC_QUOT: PSOChar = '\"'; - ESC_SL: PSOChar = '\\'; - ESC_SR: PSOChar = '\/'; - ESC_ZERO: PSOChar = '\u0000'; - - TOK_CRLF: PSOChar = #13#10; - TOK_SP: PSOChar = #32; - TOK_BS: PSOChar = #8; - TOK_TAB: PSOChar = #9; - TOK_LF: PSOChar = #10; - TOK_FF: PSOChar = #12; - TOK_CR: PSOChar = #13; -// TOK_SL: PSOChar = '\'; -// TOK_SR: PSOChar = '/'; - TOK_NULL: PSOChar = 'null'; - TOK_CBL: PSOChar = '{'; // curly bracket left - TOK_CBR: PSOChar = '}'; // curly bracket right - TOK_ARL: PSOChar = '['; - TOK_ARR: PSOChar = ']'; - TOK_ARRAY: PSOChar = '[]'; - TOK_OBJ: PSOChar = '{}'; // empty object - TOK_COM: PSOChar = ','; // Comma - TOK_DQT: PSOChar = '"'; // Double Quote - TOK_TRUE: PSOChar = 'true'; - TOK_FALSE: PSOChar = 'false'; - -{$if (sizeof(Char) = 1)} -function StrLComp(const Str1, Str2: PSOChar; MaxLen: Cardinal): Integer; -var - P1, P2: PWideChar; - I: Cardinal; - C1, C2: WideChar; -begin - P1 := Str1; - P2 := Str2; - I := 0; - while I < MaxLen do - begin - C1 := P1^; - C2 := P2^; - - if (C1 <> C2) or (C1 = #0) then - begin - Result := Ord(C1) - Ord(C2); - Exit; - end; - - Inc(P1); - Inc(P2); - Inc(I); - end; - Result := 0; -end; - -function StrComp(const Str1, Str2: PSOChar): Integer; -var - P1, P2: PWideChar; - C1, C2: WideChar; -begin - P1 := Str1; - P2 := Str2; - while True do - begin - C1 := P1^; - C2 := P2^; - - if (C1 <> C2) or (C1 = #0) then - begin - Result := Ord(C1) - Ord(C2); - Exit; - end; - - Inc(P1); - Inc(P2); - end; -end; - -function StrLen(const Str: PSOChar): Cardinal; -var - p: PSOChar; -begin - Result := 0; - if Str <> nil then - begin - p := Str; - while p^ <> #0 do inc(p); - Result := (p - Str); - end; -end; -{$ifend} - -function CurrToStr(c: Currency): SOString; -var - p: PSOChar; - i, len: Integer; -begin - Result := IntToStr(Abs(PInt64(@c)^)); - len := Length(Result); - SetLength(Result, len+1); - if c <> 0 then - begin - while len <= 4 do - begin - Result := '0' + Result; - inc(len); - end; - - p := PSOChar(Result); - inc(p, len-1); - i := 0; - repeat - if p^ <> '0' then - begin - len := len - i + 1; - repeat - p[1] := p^; - dec(p); - inc(i); - until i > 3; - Break; - end; - dec(p); - inc(i); - if i > 3 then - begin - len := len - i + 1; - Break; - end; - until false; - p[1] := '.'; - SetLength(Result, len); - if c < 0 then - Result := '-' + Result; - end; -end; - -{$IFDEF UNIX} - {$linklib c} -{$ENDIF} -function gcvt(value: Double; ndigit: longint; buf: PAnsiChar): PAnsiChar; cdecl; - external {$IFDEF MSWINDOWS} 'msvcrt.dll' name '_gcvt'{$ENDIF}; - -{$IFDEF UNIX} -type - ptm = ^tm; - tm = record - tm_sec: Integer; (* Seconds: 0-59 (K&R says 0-61?) *) - tm_min: Integer; (* Minutes: 0-59 *) - tm_hour: Integer; (* Hours since midnight: 0-23 *) - tm_mday: Integer; (* Day of the month: 1-31 *) - tm_mon: Integer; (* Months *since* january: 0-11 *) - tm_year: Integer; (* Years since 1900 *) - tm_wday: Integer; (* Days since Sunday (0-6) *) - tm_yday: Integer; (* Days since Jan. 1: 0-365 *) - tm_isdst: Integer; (* +1 Daylight Savings Time, 0 No DST, -1 don't know *) - end; - -function mktime(p: ptm): LongInt; cdecl; external; -function gmtime(const t: PLongint): ptm; cdecl; external; -function localtime (const t: PLongint): ptm; cdecl; external; - -function DelphiToJavaDateTime(const dt: TDateTime): Int64; -var - p: ptm; - l, ms: Integer; - v: Int64; -begin - v := Round((dt - 25569) * 86400000); - ms := v mod 1000; - l := v div 1000; - p := localtime(@l); - Result := Int64(mktime(p)) * 1000 + ms; -end; - -function JavaToDelphiDateTime(const dt: int64): TDateTime; -var - p: ptm; - l, ms: Integer; -begin - l := dt div 1000; - ms := dt mod 1000; - p := gmtime(@l); - Result := EncodeDateTime(p^.tm_year+1900, p^.tm_mon+1, p^.tm_mday, p^.tm_hour, p^.tm_min, p^.tm_sec, ms); -end; -{$ELSE} - -{$IFDEF WINDOWSNT_COMPATIBILITY} -function DayLightCompareDate(const date: PSystemTime; - const compareDate: PSystemTime): Integer; -var - limit_day, dayinsecs, weekofmonth: Integer; - First: Word; -begin - if (date^.wMonth < compareDate^.wMonth) then - begin - Result := -1; (* We are in a month before the date limit. *) - Exit; - end; - - if (date^.wMonth > compareDate^.wMonth) then - begin - Result := 1; (* We are in a month after the date limit. *) - Exit; - end; - - (* if year is 0 then date is in day-of-week format, otherwise - * it's absolute date. - *) - if (compareDate^.wYear = 0) then - begin - (* compareDate.wDay is interpreted as number of the week in the month - * 5 means: the last week in the month *) - weekofmonth := compareDate^.wDay; - (* calculate the day of the first DayOfWeek in the month *) - First := (6 + compareDate^.wDayOfWeek - date^.wDayOfWeek + date^.wDay) mod 7 + 1; - limit_day := First + 7 * (weekofmonth - 1); - (* check needed for the 5th weekday of the month *) - if (limit_day > MonthDays[(date^.wMonth=2) and IsLeapYear(date^.wYear)][date^.wMonth - 1]) then - dec(limit_day, 7); - end - else - limit_day := compareDate^.wDay; - - (* convert to seconds *) - limit_day := ((limit_day * 24 + compareDate^.wHour) * 60 + compareDate^.wMinute ) * 60; - dayinsecs := ((date^.wDay * 24 + date^.wHour) * 60 + date^.wMinute ) * 60 + date^.wSecond; - (* and compare *) - - if dayinsecs < limit_day then - Result := -1 else - if dayinsecs > limit_day then - Result := 1 else - Result := 0; (* date is equal to the date limit. *) -end; - -function CompTimeZoneID(const pTZinfo: PTimeZoneInformation; - lpFileTime: PFileTime; islocal: Boolean): LongWord; -var - ret: Integer; - beforeStandardDate, afterDaylightDate: Boolean; - llTime: Int64; - SysTime: TSystemTime; - ftTemp: TFileTime; -begin - llTime := 0; - - if (pTZinfo^.DaylightDate.wMonth <> 0) then - begin - (* if year is 0 then date is in day-of-week format, otherwise - * it's absolute date. - *) - if ((pTZinfo^.StandardDate.wMonth = 0) or - ((pTZinfo^.StandardDate.wYear = 0) and - ((pTZinfo^.StandardDate.wDay < 1) or - (pTZinfo^.StandardDate.wDay > 5) or - (pTZinfo^.DaylightDate.wDay < 1) or - (pTZinfo^.DaylightDate.wDay > 5)))) then - begin - SetLastError(ERROR_INVALID_PARAMETER); - Result := TIME_ZONE_ID_INVALID; - Exit; - end; - - if (not islocal) then - begin - llTime := PInt64(lpFileTime)^; - dec(llTime, Int64(pTZinfo^.Bias + pTZinfo^.DaylightBias) * 600000000); - PInt64(@ftTemp)^ := llTime; - lpFileTime := @ftTemp; - end; - - FileTimeToSystemTime(lpFileTime^, SysTime); - - (* check for daylight savings *) - ret := DayLightCompareDate(@SysTime, @pTZinfo^.StandardDate); - if (ret = -2) then - begin - Result := TIME_ZONE_ID_INVALID; - Exit; - end; - - beforeStandardDate := ret < 0; - - if (not islocal) then - begin - dec(llTime, Int64(pTZinfo^.StandardBias - pTZinfo^.DaylightBias) * 600000000); - PInt64(@ftTemp)^ := llTime; - FileTimeToSystemTime(lpFileTime^, SysTime); - end; - - ret := DayLightCompareDate(@SysTime, @pTZinfo^.DaylightDate); - if (ret = -2) then - begin - Result := TIME_ZONE_ID_INVALID; - Exit; - end; - - afterDaylightDate := ret >= 0; - - Result := TIME_ZONE_ID_STANDARD; - if( pTZinfo^.DaylightDate.wMonth < pTZinfo^.StandardDate.wMonth ) then - begin - (* Northern hemisphere *) - if( beforeStandardDate and afterDaylightDate) then - Result := TIME_ZONE_ID_DAYLIGHT; - end else (* Down south *) - if( beforeStandardDate or afterDaylightDate) then - Result := TIME_ZONE_ID_DAYLIGHT; - end else - (* No transition date *) - Result := TIME_ZONE_ID_UNKNOWN; -end; - -function GetTimezoneBias(const pTZinfo: PTimeZoneInformation; - lpFileTime: PFileTime; islocal: Boolean; pBias: PLongint): Boolean; -var - bias: LongInt; - tzid: LongWord; -begin - bias := pTZinfo^.Bias; - tzid := CompTimeZoneID(pTZinfo, lpFileTime, islocal); - - if( tzid = TIME_ZONE_ID_INVALID) then - begin - Result := False; - Exit; - end; - if (tzid = TIME_ZONE_ID_DAYLIGHT) then - inc(bias, pTZinfo^.DaylightBias) - else if (tzid = TIME_ZONE_ID_STANDARD) then - inc(bias, pTZinfo^.StandardBias); - pBias^ := bias; - Result := True; -end; - -function SystemTimeToTzSpecificLocalTime( - lpTimeZoneInformation: PTimeZoneInformation; - lpUniversalTime, lpLocalTime: PSystemTime): BOOL; -var - ft: TFileTime; - lBias: LongInt; - llTime: Int64; - tzinfo: TTimeZoneInformation; -begin - if (lpTimeZoneInformation <> nil) then - tzinfo := lpTimeZoneInformation^ else - if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then - begin - Result := False; - Exit; - end; - - if (not SystemTimeToFileTime(lpUniversalTime^, ft)) then - begin - Result := False; - Exit; - end; - llTime := PInt64(@ft)^; - if (not GetTimezoneBias(@tzinfo, @ft, False, @lBias)) then - begin - Result := False; - Exit; - end; - (* convert minutes to 100-nanoseconds-ticks *) - dec(llTime, Int64(lBias) * 600000000); - PInt64(@ft)^ := llTime; - Result := FileTimeToSystemTime(ft, lpLocalTime^); -end; - -function TzSpecificLocalTimeToSystemTime( - const lpTimeZoneInformation: PTimeZoneInformation; - const lpLocalTime: PSystemTime; lpUniversalTime: PSystemTime): BOOL; -var - ft: TFileTime; - lBias: LongInt; - t: Int64; - tzinfo: TTimeZoneInformation; -begin - if (lpTimeZoneInformation <> nil) then - tzinfo := lpTimeZoneInformation^ - else - if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then - begin - Result := False; - Exit; - end; - - if (not SystemTimeToFileTime(lpLocalTime^, ft)) then - begin - Result := False; - Exit; - end; - t := PInt64(@ft)^; - if (not GetTimezoneBias(@tzinfo, @ft, True, @lBias)) then - begin - Result := False; - Exit; - end; - (* convert minutes to 100-nanoseconds-ticks *) - inc(t, Int64(lBias) * 600000000); - PInt64(@ft)^ := t; - Result := FileTimeToSystemTime(ft, lpUniversalTime^); -end; -{$ELSE} -function TzSpecificLocalTimeToSystemTime( - lpTimeZoneInformation: PTimeZoneInformation; - lpLocalTime, lpUniversalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll'; - -function SystemTimeToTzSpecificLocalTime( - lpTimeZoneInformation: PTimeZoneInformation; - lpUniversalTime, lpLocalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll'; -{$ENDIF} - -function JavaToDelphiDateTime(const dt: int64): TDateTime; -var - t: TSystemTime; -begin - DateTimeToSystemTime(25569 + (dt / 86400000), t); - SystemTimeToTzSpecificLocalTime(nil, @t, @t); - Result := SystemTimeToDateTime(t); -end; - -function DelphiToJavaDateTime(const dt: TDateTime): int64; -var - t: TSystemTime; -begin - DateTimeToSystemTime(dt, t); - TzSpecificLocalTimeToSystemTime(nil, @t, @t); - Result := Round((SystemTimeToDateTime(t) - 25569) * 86400000) -end; -{$ENDIF} - - -function SO(const s: SOString): ISuperObject; overload; -begin - Result := TSuperObject.ParseString(PSOChar(s), False); -end; - -function SA(const Args: array of const): ISuperObject; overload; -type - TByteArray = array[0..sizeof(integer) - 1] of byte; - PByteArray = ^TByteArray; -var - j: Integer; - intf: IInterface; -begin - Result := TSuperObject.Create(stArray); - for j := 0 to length(Args) - 1 do - with Result.AsArray do - case TVarRec(Args[j]).VType of - vtInteger : Add(TSuperObject.Create(TVarRec(Args[j]).VInteger)); - vtInt64 : Add(TSuperObject.Create(TVarRec(Args[j]).VInt64^)); - vtBoolean : Add(TSuperObject.Create(TVarRec(Args[j]).VBoolean)); - vtChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VChar))); - vtWideChar: Add(TSuperObject.Create(SOChar(TVarRec(Args[j]).VWideChar))); - vtExtended: Add(TSuperObject.Create(TVarRec(Args[j]).VExtended^)); - vtCurrency: Add(TSuperObject.CreateCurrency(TVarRec(Args[j]).VCurrency^)); - vtString : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VString^))); - vtPChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VPChar^))); - vtAnsiString: Add(TSuperObject.Create(SOString(AnsiString(TVarRec(Args[j]).VAnsiString)))); - vtWideString: Add(TSuperObject.Create(SOString(PWideChar(TVarRec(Args[j]).VWideString)))); - vtInterface: - if TVarRec(Args[j]).VInterface = nil then - Add(nil) else - if IInterface(TVarRec(Args[j]).VInterface).QueryInterface(ISuperObject, intf) = 0 then - Add(ISuperObject(intf)) else - Add(nil); - vtPointer : - if TVarRec(Args[j]).VPointer = nil then - Add(nil) else - Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer))); - vtVariant: - Add(SO(TVarRec(Args[j]).VVariant^)); - vtObject: - if TVarRec(Args[j]).VPointer = nil then - Add(nil) else - Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer))); - vtClass: - if TVarRec(Args[j]).VPointer = nil then - Add(nil) else - Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer))); -{$if declared(vtUnicodeString)} - vtUnicodeString: - Add(TSuperObject.Create(SOString(string(TVarRec(Args[j]).VUnicodeString)))); -{$ifend} - else - assert(false); - end; -end; - -function SO(const Args: array of const): ISuperObject; overload; -var - j: Integer; - arr: ISuperObject; -begin - Result := TSuperObject.Create(stObject); - arr := SA(Args); - with arr.AsArray do - for j := 0 to (Length div 2) - 1 do - Result.AsObject.PutO(O[j*2].AsString, O[(j*2) + 1]); -end; - -function SO(const value: Variant): ISuperObject; overload; -begin - with TVarData(value) do - case VType of - varNull: Result := nil; - varEmpty: Result := nil; - varSmallInt: Result := TSuperObject.Create(VSmallInt); - varInteger: Result := TSuperObject.Create(VInteger); - varSingle: Result := TSuperObject.Create(VSingle); - varDouble: Result := TSuperObject.Create(VDouble); - varCurrency: Result := TSuperObject.CreateCurrency(VCurrency); - varDate: Result := TSuperObject.Create(DelphiToJavaDateTime(vDate)); - varOleStr: Result := TSuperObject.Create(SOString(VOleStr)); - varBoolean: Result := TSuperObject.Create(VBoolean); - varShortInt: Result := TSuperObject.Create(VShortInt); - varByte: Result := TSuperObject.Create(VByte); - varWord: Result := TSuperObject.Create(VWord); - varLongWord: Result := TSuperObject.Create(VLongWord); - varInt64: Result := TSuperObject.Create(VInt64); - varString: Result := TSuperObject.Create(SOString(AnsiString(VString))); -{$if declared(varUString)} - varUString: Result := TSuperObject.Create(SOString(string(VUString))); -{$ifend} - else - raise Exception.CreateFmt('Unsuported variant data type: %d', [VType]); - end; -end; - -function ObjectIsError(obj: TSuperObject): boolean; -begin - Result := PtrUInt(obj) > PtrUInt(-4000); -end; - -function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean; -begin - if obj <> nil then - Result := typ = obj.DataType else - Result := typ = stNull; -end; - -function ObjectGetType(const obj: ISuperObject): TSuperType; -begin - if obj <> nil then - Result := obj.DataType else - Result := stNull; -end; - -function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean; -var - i: TSuperAvlEntry; -begin - if ObjectIsType(obj, stObject) then - begin - F.Ite := TSuperAvlIterator.Create(obj.AsObject); - F.Ite.First; - i := F.Ite.GetIter; - if i <> nil then - begin - f.key := i.Name; - f.val := i.Value; - Result := true; - end else - Result := False; - end else - Result := False; -end; - -function ObjectFindNext(var F: TSuperObjectIter): boolean; -var - i: TSuperAvlEntry; -begin - F.Ite.Next; - i := F.Ite.GetIter; - if i <> nil then - begin - f.key := i.FName; - f.val := i.Value; - Result := true; - end else - Result := False; -end; - -procedure ObjectFindClose(var F: TSuperObjectIter); -begin - F.Ite.Free; - F.val := nil; -end; - -{$IFDEF VER210} - -function serialtoboolean(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; -begin - Result := TSuperObject.Create(TValueData(value).FAsSLong <> 0); -end; - -function serialtodatetime(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; -begin - Result := TSuperObject.Create(DelphiToJavaDateTime(TValueData(value).FAsDouble)); -end; - -function serialtoguid(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; -var - g: TGUID; -begin - value.ExtractRawData(@g); - Result := TSuperObject.Create( - format('%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x', - [g.D1, g.D2, g.D3, - g.D4[0], g.D4[1], g.D4[2], - g.D4[3], g.D4[4], g.D4[5], - g.D4[6], g.D4[7]]) - ); -end; - -function serialfromboolean(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; -var - o: ISuperObject; -begin - case ObjectGetType(obj) of - stBoolean: - begin - TValueData(Value).FAsSLong := obj.AsInteger; - Result := True; - end; - stInt: - begin - TValueData(Value).FAsSLong := ord(obj.AsInteger <> 0); - Result := True; - end; - stString: - begin - o := SO(obj.AsString); - if not ObjectIsType(o, stString) then - Result := serialfromboolean(ctx, SO(obj.AsString), Value) else - Result := False; - end; - else - Result := False; - end; -end; - -function serialfromdatetime(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; -var - dt: TDateTime; -begin - case ObjectGetType(obj) of - stInt: - begin - TValueData(Value).FAsDouble := JavaToDelphiDateTime(obj.AsInteger); - Result := True; - end; - stString: - begin - if TryStrToDateTime(obj.AsString, dt) then - begin - TValueData(Value).FAsDouble := dt; - Result := True; - end else - Result := False; - end; - else - Result := False; - end; -end; - -function UuidFromString(const s: PSOChar; Uuid: PGUID): Boolean; -const - hex2bin: array[#0..#102] of short = ( - -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x00 *) - -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x10 *) - -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x20 *) - 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1, (* 0x30 *) - -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x40 *) - -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x50 *) - -1,10,11,12,13,14,15); (* 0x60 *) -var - i: Integer; -begin - if (strlen(s) <> 36) then Exit(False); - - if ((s[8] <> '-') or (s[13] <> '-') or (s[18] <> '-') or (s[23] <> '-')) then - Exit(False); - - for i := 0 to 35 do - begin - if not i in [8,13,18,23] then - if ((s[i] > 'f') or ((hex2bin[s[i]] = -1) and (s[i] <> ''))) then - Exit(False); - end; - - uuid.D1 := ((hex2bin[s[0]] shl 28) or (hex2bin[s[1]] shl 24) or (hex2bin[s[2]] shl 20) or (hex2bin[s[3]] shl 16) or - (hex2bin[s[4]] shl 12) or (hex2bin[s[5]] shl 8) or (hex2bin[s[6]] shl 4) or hex2bin[s[7]]); - uuid.D2 := (hex2bin[s[9]] shl 12) or (hex2bin[s[10]] shl 8) or (hex2bin[s[11]] shl 4) or hex2bin[s[12]]; - uuid.D3 := (hex2bin[s[14]] shl 12) or (hex2bin[s[15]] shl 8) or (hex2bin[s[16]] shl 4) or hex2bin[s[17]]; - - uuid.D4[0] := (hex2bin[s[19]] shl 4) or hex2bin[s[20]]; - uuid.D4[1] := (hex2bin[s[21]] shl 4) or hex2bin[s[22]]; - uuid.D4[2] := (hex2bin[s[24]] shl 4) or hex2bin[s[25]]; - uuid.D4[3] := (hex2bin[s[26]] shl 4) or hex2bin[s[27]]; - uuid.D4[4] := (hex2bin[s[28]] shl 4) or hex2bin[s[29]]; - uuid.D4[5] := (hex2bin[s[30]] shl 4) or hex2bin[s[31]]; - uuid.D4[6] := (hex2bin[s[32]] shl 4) or hex2bin[s[33]]; - uuid.D4[7] := (hex2bin[s[34]] shl 4) or hex2bin[s[35]]; - Result := True; -end; - -function serialfromguid(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; -begin - case ObjectGetType(obj) of - stNull: - begin - FillChar(Value.GetReferenceToRawData^, SizeOf(TGUID), 0); - Result := True; - end; - stString: Result := UuidFromString(PSOChar(obj.AsString), Value.GetReferenceToRawData); - else - Result := False; - end; -end; - -function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext): ISuperObject; overload; -var - owned: Boolean; -begin - if ctx = nil then - begin - ctx := TSuperRttiContext.Create; - owned := True; - end else - owned := False; - try - if TrySOInvoke(ctx, obj, method, params, Result) <> irSuccess then - raise Exception.Create('Invalid method call'); - finally - if owned then - ctx.Free; - end; -end; - -function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext): ISuperObject; overload; -begin - Result := SOInvoke(obj, method, so(params), ctx) -end; - -function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; - const method: string; const params: ISuperObject; - var Return: ISuperObject): TSuperInvokeResult; -var - t: TRttiInstanceType; - m: TRttiMethod; - a: TArray; - ps: TArray; - v: TValue; - index: ISuperObject; - - function GetParams: Boolean; - var - i: Integer; - begin - case ObjectGetType(params) of - stArray: - for i := 0 to Length(ps) - 1 do - if (pfOut in ps[i].Flags) then - TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else - if not ctx.FromJson(ps[i].ParamType.Handle, params.AsArray[i], a[i]) then - Exit(False); - stObject: - for i := 0 to Length(ps) - 1 do - if (pfOut in ps[i].Flags) then - TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else - if not ctx.FromJson(ps[i].ParamType.Handle, params.AsObject[ps[i].Name], a[i]) then - Exit(False); - stNull: ; - else - Exit(False); - end; - Result := True; - end; - - procedure SetParams; - var - i: Integer; - begin - case ObjectGetType(params) of - stArray: - for i := 0 to Length(ps) - 1 do - if (ps[i].Flags * [pfVar, pfOut]) <> [] then - params.AsArray[i] := ctx.ToJson(a[i], index); - stObject: - for i := 0 to Length(ps) - 1 do - if (ps[i].Flags * [pfVar, pfOut]) <> [] then - params.AsObject[ps[i].Name] := ctx.ToJson(a[i], index); - end; - end; - -begin - Result := irSuccess; - index := SO; - case obj.Kind of - tkClass: - begin - t := TRttiInstanceType(ctx.Context.GetType(obj.AsObject.ClassType)); - m := t.GetMethod(method); - if m = nil then Exit(irMethothodError); - ps := m.GetParameters; - SetLength(a, Length(ps)); - if not GetParams then Exit(irParamError); - if m.IsClassMethod then - begin - v := m.Invoke(obj.AsObject.ClassType, a); - Return := ctx.ToJson(v, index); - SetParams; - end else - begin - v := m.Invoke(obj, a); - Return := ctx.ToJson(v, index); - SetParams; - end; - end; - tkClassRef: - begin - t := TRttiInstanceType(ctx.Context.GetType(obj.AsClass)); - m := t.GetMethod(method); - if m = nil then Exit(irMethothodError); - ps := m.GetParameters; - SetLength(a, Length(ps)); - - if not GetParams then Exit(irParamError); - if m.IsClassMethod then - begin - v := m.Invoke(obj, a); - Return := ctx.ToJson(v, index); - SetParams; - end else - Exit(irError); - end; - else - Exit(irError); - end; -end; - -{$ENDIF} - -{ TSuperEnumerator } - -constructor TSuperEnumerator.Create(const obj: ISuperObject); -begin - FObj := obj; - FCount := -1; - if ObjectIsType(FObj, stObject) then - FObjEnum := FObj.AsObject.GetEnumerator else - FObjEnum := nil; -end; - -destructor TSuperEnumerator.Destroy; -begin - if FObjEnum <> nil then - FObjEnum.Free; -end; - -function TSuperEnumerator.MoveNext: Boolean; -begin - case ObjectGetType(FObj) of - stObject: Result := FObjEnum.MoveNext; - stArray: - begin - inc(FCount); - if FCount < FObj.AsArray.Length then - Result := True else - Result := False; - end; - else - Result := false; - end; -end; - -function TSuperEnumerator.GetCurrent: ISuperObject; -begin - case ObjectGetType(FObj) of - stObject: Result := FObjEnum.Current.Value; - stArray: Result := FObj.AsArray.GetO(FCount); - else - Result := FObj; - end; -end; - -{ TSuperObject } - -constructor TSuperObject.Create(jt: TSuperType); -begin - inherited Create; -{$IFDEF DEBUG} - InterlockedIncrement(debugcount); -{$ENDIF} - - FProcessing := false; - FDataPtr := nil; - FDataType := jt; - case FDataType of - stObject: FO.c_object := TSuperTableString.Create; - stArray: FO.c_array := TSuperArray.Create; - stString: FOString := ''; - else - FO.c_object := nil; - end; -end; - -constructor TSuperObject.Create(b: boolean); -begin - Create(stBoolean); - FO.c_boolean := b; -end; - -constructor TSuperObject.Create(i: SuperInt); -begin - Create(stInt); - FO.c_int := i; -end; - -constructor TSuperObject.Create(d: double); -begin - Create(stDouble); - FO.c_double := d; -end; - -constructor TSuperObject.CreateCurrency(c: Currency); -begin - Create(stCurrency); - FO.c_currency := c; -end; - -destructor TSuperObject.Destroy; -begin -{$IFDEF DEBUG} - InterlockedDecrement(debugcount); -{$ENDIF} - case FDataType of - stObject: FO.c_object.Free; - stArray: FO.c_array.Free; - end; - inherited; -end; - -function TSuperObject.Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; -function DoEscape(str: PSOChar; len: Integer): Integer; -var - pos, start_offset: Integer; - c: SOChar; - buf: array[0..5] of SOChar; -type - TByteChar = record - case integer of - 0: (a, b: Byte); - 1: (c: WideChar); - end; - begin - if str = nil then - begin - Result := 0; - exit; - end; - pos := 0; start_offset := 0; - with writer do - while pos < len do - begin - c := str[pos]; - case c of - #8,#9,#10,#12,#13,'"','\','/': - begin - if(pos - start_offset > 0) then - Append(str + start_offset, pos - start_offset); - - if(c = #8) then Append(ESC_BS, 2) - else if (c = #9) then Append(ESC_TAB, 2) - else if (c = #10) then Append(ESC_LF, 2) - else if (c = #12) then Append(ESC_FF, 2) - else if (c = #13) then Append(ESC_CR, 2) - else if (c = '"') then Append(ESC_QUOT, 2) - else if (c = '\') then Append(ESC_SL, 2) - else if (c = '/') then Append(ESC_SR, 2); - inc(pos); - start_offset := pos; - end; - else - if (SOIChar(c) > 255) then - begin - if(pos - start_offset > 0) then - Append(str + start_offset, pos - start_offset); - buf[0] := '\'; - buf[1] := 'u'; - buf[2] := super_hex_chars[TByteChar(c).b shr 4]; - buf[3] := super_hex_chars[TByteChar(c).b and $f]; - buf[4] := super_hex_chars[TByteChar(c).a shr 4]; - buf[5] := super_hex_chars[TByteChar(c).a and $f]; - Append(@buf, 6); - inc(pos); - start_offset := pos; - end else - if (c < #32) or (c > #127) then - begin - if(pos - start_offset > 0) then - Append(str + start_offset, pos - start_offset); - buf[0] := '\'; - buf[1] := 'u'; - buf[2] := '0'; - buf[3] := '0'; - buf[4] := super_hex_chars[ord(c) shr 4]; - buf[5] := super_hex_chars[ord(c) and $f]; - Append(buf, 6); - inc(pos); - start_offset := pos; - end else - inc(pos); - end; - end; - if(pos - start_offset > 0) then - writer.Append(str + start_offset, pos - start_offset); - Result := 0; - end; - -function DoMinimalEscape(str: PSOChar; len: Integer): Integer; -var - pos, start_offset: Integer; - c: SOChar; -type - TByteChar = record - case integer of - 0: (a, b: Byte); - 1: (c: WideChar); - end; - begin - if str = nil then - begin - Result := 0; - exit; - end; - pos := 0; start_offset := 0; - with writer do - while pos < len do - begin - c := str[pos]; - case c of - #0: - begin - if(pos - start_offset > 0) then - Append(str + start_offset, pos - start_offset); - Append(ESC_ZERO, 6); - inc(pos); - start_offset := pos; - end; - '"': - begin - if(pos - start_offset > 0) then - Append(str + start_offset, pos - start_offset); - Append(ESC_QUOT, 2); - inc(pos); - start_offset := pos; - end; - '\': - begin - if(pos - start_offset > 0) then - Append(str + start_offset, pos - start_offset); - Append(ESC_SL, 2); - inc(pos); - start_offset := pos; - end; - '/': - begin - if(pos - start_offset > 0) then - Append(str + start_offset, pos - start_offset); - Append(ESC_SR, 2); - inc(pos); - start_offset := pos; - end; - else - inc(pos); - end; - end; - if(pos - start_offset > 0) then - writer.Append(str + start_offset, pos - start_offset); - Result := 0; - end; - - - procedure _indent(i: shortint; r: boolean); - begin - inc(level, i); - if r then - with writer do - begin -{$IFDEF MSWINDOWS} - Append(TOK_CRLF, 2); -{$ELSE} - Append(TOK_LF, 1); -{$ENDIF} - for i := 0 to level - 1 do - Append(TOK_SP, 1); - end; - end; -var - k,j: Integer; - iter: TSuperObjectIter; - st: AnsiString; - val: ISuperObject; - fbuffer: array[0..31] of AnsiChar; -const - ENDSTR_A: PSOChar = '": '; - ENDSTR_B: PSOChar = '":'; -begin - - if FProcessing then - begin - Result := writer.Append(TOK_NULL, 4); - Exit; - end; - - FProcessing := true; - with writer do - try - case FDataType of - stObject: - if FO.c_object.FCount > 0 then - begin - k := 0; - Append(TOK_CBL, 1); - if indent then _indent(1, false); - if ObjectFindFirst(Self, iter) then - repeat - {$IFDEF SUPER_METHOD} - if (iter.val = nil) or not ObjectIsType(iter.val, stMethod) then - begin - {$ENDIF} - if (iter.val = nil) or (not iter.val.Processing) then - begin - if(k <> 0) then - Append(TOK_COM, 1); - if indent then _indent(0, true); - Append(TOK_DQT, 1); - if escape then - doEscape(PSOChar(iter.key), Length(iter.key)) else - DoMinimalEscape(PSOChar(iter.key), Length(iter.key)); - if indent then - Append(ENDSTR_A, 3) else - Append(ENDSTR_B, 2); - if(iter.val = nil) then - Append(TOK_NULL, 4) else - iter.val.write(writer, indent, escape, level); - inc(k); - end; - {$IFDEF SUPER_METHOD} - end; - {$ENDIF} - until not ObjectFindNext(iter); - ObjectFindClose(iter); - if indent then _indent(-1, true); - Result := Append(TOK_CBR, 1); - end else - Result := Append(TOK_OBJ, 2); - stBoolean: - begin - if (FO.c_boolean) then - Result := Append(TOK_TRUE, 4) else - Result := Append(TOK_FALSE, 5); - end; - stInt: - begin - str(FO.c_int, st); - Result := Append(PSOChar(SOString(st))); - end; - stDouble: - Result := Append(PSOChar(SOString(gcvt(FO.c_double, 15, fbuffer)))); - stCurrency: - begin - Result := Append(PSOChar(CurrToStr(FO.c_currency))); - end; - stString: - begin - Append(TOK_DQT, 1); - if escape then - doEscape(PSOChar(FOString), Length(FOString)) else - DoMinimalEscape(PSOChar(FOString), Length(FOString)); - Append(TOK_DQT, 1); - Result := 0; - end; - stArray: - if FO.c_array.FLength > 0 then - begin - Append(TOK_ARL, 1); - if indent then _indent(1, true); - k := 0; - j := 0; - while k < FO.c_array.FLength do - begin - - val := FO.c_array.GetO(k); - {$IFDEF SUPER_METHOD} - if not ObjectIsType(val, stMethod) then - begin - {$ENDIF} - if (val = nil) or (not val.Processing) then - begin - if (j <> 0) then - Append(TOK_COM, 1); - if(val = nil) then - Append(TOK_NULL, 4) else - val.write(writer, indent, escape, level); - inc(j); - end; - {$IFDEF SUPER_METHOD} - end; - {$ENDIF} - inc(k); - end; - if indent then _indent(-1, false); - Result := Append(TOK_ARR, 1); - end else - Result := Append(TOK_ARRAY, 2); - stNull: - Result := Append(TOK_NULL, 4); - else - Result := 0; - end; - finally - FProcessing := false; - end; -end; - -function TSuperObject.IsType(AType: TSuperType): boolean; -begin - Result := AType = FDataType; -end; - -function TSuperObject.AsBoolean: boolean; -begin - case FDataType of - stBoolean: Result := FO.c_boolean; - stInt: Result := (FO.c_int <> 0); - stDouble: Result := (FO.c_double <> 0); - stCurrency: Result := (FO.c_currency <> 0); - stString: Result := (Length(FOString) <> 0); - stNull: Result := False; - else - Result := True; - end; -end; - -function TSuperObject.AsInteger: SuperInt; -var - code: integer; - cint: SuperInt; -begin - case FDataType of - stInt: Result := FO.c_int; - stDouble: Result := round(FO.c_double); - stCurrency: Result := round(FO.c_currency); - stBoolean: Result := ord(FO.c_boolean); - stString: - begin - Val(FOString, cint, code); - if code = 0 then - Result := cint else - Result := 0; - end; - else - Result := 0; - end; -end; - -function TSuperObject.AsDouble: Double; -var - code: integer; - cdouble: double; -begin - case FDataType of - stDouble: Result := FO.c_double; - stCurrency: Result := FO.c_currency; - stInt: Result := FO.c_int; - stBoolean: Result := ord(FO.c_boolean); - stString: - begin - Val(FOString, cdouble, code); - if code = 0 then - Result := cdouble else - Result := 0.0; - end; - else - Result := 0.0; - end; -end; - -function TSuperObject.AsCurrency: Currency; -var - code: integer; - cdouble: double; -begin - case FDataType of - stDouble: Result := FO.c_double; - stCurrency: Result := FO.c_currency; - stInt: Result := FO.c_int; - stBoolean: Result := ord(FO.c_boolean); - stString: - begin - Val(FOString, cdouble, code); - if code = 0 then - Result := cdouble else - Result := 0.0; - end; - else - Result := 0.0; - end; -end; - -function TSuperObject.AsString: SOString; -begin - if FDataType = stString then - Result := FOString else - Result := AsJSon(false, false); -end; - -function TSuperObject.GetEnumerator: TSuperEnumerator; -begin - Result := TSuperEnumerator.Create(Self); -end; - -procedure TSuperObject.AfterConstruction; -begin - InterlockedDecrement(FRefCount); -end; - -procedure TSuperObject.BeforeDestruction; -begin - if RefCount <> 0 then - raise Exception.Create('Invalid pointer'); -end; - -function TSuperObject.AsArray: TSuperArray; -begin - if FDataType = stArray then - Result := FO.c_array else - Result := nil; -end; - -function TSuperObject.AsObject: TSuperTableString; -begin - if FDataType = stObject then - Result := FO.c_object else - Result := nil; -end; - -function TSuperObject.AsJSon(indent, escape: boolean): SOString; -var - pb: TSuperWriterString; -begin - pb := TSuperWriterString.Create; - try - if(Write(pb, indent, escape, 0) < 0) then - begin - Result := ''; - Exit; - end; - if pb.FBPos > 0 then - Result := pb.FBuf else - Result := ''; - finally - pb.Free; - end; -end; - -class function TSuperObject.ParseString(s: PSOChar; strict: Boolean; partial: boolean; const this: ISuperObject; - options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject; -var - tok: TSuperTokenizer; - obj: ISuperObject; -begin - tok := TSuperTokenizer.Create; - obj := ParseEx(tok, s, -1, strict, this, options, put, dt); - if(tok.err <> teSuccess) or (not partial and (s[tok.char_offset] <> #0)) then - Result := nil else - Result := obj; - tok.Free; -end; - -class function TSuperObject.ParseStream(stream: TStream; strict: Boolean; - partial: boolean; const this: ISuperObject; options: TSuperFindOptions; - const put: ISuperObject; dt: TSuperType): ISuperObject; -const - BUFFER_SIZE = 1024; -var - tok: TSuperTokenizer; - buffera: array[0..BUFFER_SIZE-1] of AnsiChar; - bufferw: array[0..BUFFER_SIZE-1] of SOChar; - bom: array[0..1] of byte; - unicode: boolean; - j, size: Integer; - st: string; -begin - st := ''; - tok := TSuperTokenizer.Create; - - if (stream.Read(bom, sizeof(bom)) = 2) and (bom[0] = $FF) and (bom[1] = $FE) then - begin - unicode := true; - size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar); - end else - begin - unicode := false; - stream.Seek(0, soFromBeginning); - size := stream.Read(buffera, BUFFER_SIZE); - end; - - while size > 0 do - begin - if not unicode then - for j := 0 to size - 1 do - bufferw[j] := SOChar(buffera[j]); - ParseEx(tok, bufferw, size, strict, this, options, put, dt); - - if tok.err = teContinue then - begin - if not unicode then - size := stream.Read(buffera, BUFFER_SIZE) else - size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar); - end else - Break; - end; - if(tok.err <> teSuccess) or (not partial and (st[tok.char_offset] <> #0)) then - Result := nil else - Result := tok.stack[tok.depth].current; - tok.Free; -end; - -class function TSuperObject.ParseFile(const FileName: string; strict: Boolean; - partial: boolean; const this: ISuperObject; options: TSuperFindOptions; - const put: ISuperObject; dt: TSuperType): ISuperObject; -var - stream: TFileStream; -begin - stream := TFileStream.Create(FileName, fmOpenRead, fmShareDenyWrite); - try - Result := ParseStream(stream, strict, partial, this, options, put, dt); - finally - stream.Free; - end; -end; - -class function TSuperObject.ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; - strict: Boolean; const this: ISuperObject; options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject; - -const - spaces = [#32,#8,#9,#10,#12,#13]; - delimiters = ['"', '.', '[', ']', '{', '}', '(', ')', ',', ':', #0]; - reserved = delimiters + spaces; - path = ['a'..'z', 'A'..'Z', '.', '_']; - - function hexdigit(x: SOChar): byte; - begin - if x <= '9' then - Result := byte(x) - byte('0') else - Result := (byte(x) and 7) + 9; - end; - function min(v1, v2: integer): integer; begin if v1 < v2 then result := v1 else result := v2 end; - -var - obj: ISuperObject; - v: SOChar; -{$IFDEF SUPER_METHOD} - sm: TSuperMethod; -{$ENDIF} - numi: SuperInt; - numd: Double; - code: integer; - TokRec: PSuperTokenerSrec; - evalstack: integer; - p: PSOChar; - - function IsEndDelimiter(v: AnsiChar): Boolean; - begin - if tok.depth > 0 then - case tok.stack[tok.depth - 1].state of - tsArrayAdd: Result := v in [',', ']', #0]; - tsObjectValueAdd: Result := v in [',', '}', #0]; - else - Result := v = #0; - end else - Result := v = #0; - end; - -label out, redo_char; -begin - evalstack := 0; - obj := nil; - Result := nil; - TokRec := @tok.stack[tok.depth]; - - tok.char_offset := 0; - tok.err := teSuccess; - - repeat - if (tok.char_offset = len) then - begin - if (tok.depth = 0) and (TokRec^.state = tsEatws) and - (TokRec^.saved_state = tsFinish) then - tok.err := teSuccess else - tok.err := teContinue; - goto out; - end; - - v := str^; - - case v of - #10: - begin - inc(tok.line); - tok.col := 0; - end; - #9: inc(tok.col, 4); - else - inc(tok.col); - end; - -redo_char: - case TokRec^.state of - tsEatws: - begin - if (SOIChar(v) < 256) and (AnsiChar(v) in spaces) then {nop} else - if (v = '/') then - begin - tok.pb.Reset; - tok.pb.Append(@v, 1); - TokRec^.state := tsCommentStart; - end else begin - TokRec^.state := TokRec^.saved_state; - goto redo_char; - end - end; - - tsStart: - case v of - '"', - '''': - begin - TokRec^.state := tsString; - tok.pb.Reset; - tok.quote_char := v; - end; - '-': - begin - TokRec^.state := tsNumber; - tok.pb.Reset; - tok.is_double := 0; - tok.floatcount := -1; - goto redo_char; - end; - - '0'..'9': - begin - if (tok.depth = 0) then - case ObjectGetType(this) of - stObject: - begin - TokRec^.state := tsIdentifier; - TokRec^.current := this; - goto redo_char; - end; - end; - TokRec^.state := tsNumber; - tok.pb.Reset; - tok.is_double := 0; - tok.floatcount := -1; - goto redo_char; - end; - '{': - begin - TokRec^.state := tsEatws; - TokRec^.saved_state := tsObjectFieldStart; - TokRec^.current := TSuperObject.Create(stObject); - end; - '[': - begin - TokRec^.state := tsEatws; - TokRec^.saved_state := tsArray; - TokRec^.current := TSuperObject.Create(stArray); - end; -{$IFDEF SUPER_METHOD} - '(': - begin - if (tok.depth = 0) and ObjectIsType(this, stMethod) then - begin - TokRec^.current := this; - TokRec^.state := tsParamValue; - end; - end; -{$ENDIF} - 'N', - 'n': - begin - TokRec^.state := tsNull; - tok.pb.Reset; - tok.st_pos := 0; - goto redo_char; - end; - 'T', - 't', - 'F', - 'f': - begin - TokRec^.state := tsBoolean; - tok.pb.Reset; - tok.st_pos := 0; - goto redo_char; - end; - else - TokRec^.state := tsIdentifier; - tok.pb.Reset; - goto redo_char; - end; - - tsFinish: - begin - if(tok.depth = 0) then goto out; - obj := TokRec^.current; - tok.ResetLevel(tok.depth); - dec(tok.depth); - TokRec := @tok.stack[tok.depth]; - goto redo_char; - end; - - tsNull: - begin - tok.pb.Append(@v, 1); - if (StrLComp(TOK_NULL, PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then - begin - if (tok.st_pos = 4) then - if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then - TokRec^.state := tsIdentifier else - begin - TokRec^.current := TSuperObject.Create(stNull); - TokRec^.saved_state := tsFinish; - TokRec^.state := tsEatws; - goto redo_char; - end; - end else - begin - TokRec^.state := tsIdentifier; - tok.pb.FBuf[tok.st_pos] := #0; - dec(tok.pb.FBPos); - goto redo_char; - end; - inc(tok.st_pos); - end; - - tsCommentStart: - begin - if(v = '*') then - begin - TokRec^.state := tsComment; - end else - if (v = '/') then - begin - TokRec^.state := tsCommentEol; - end else - begin - tok.err := teParseComment; - goto out; - end; - tok.pb.Append(@v, 1); - end; - - tsComment: - begin - if(v = '*') then - TokRec^.state := tsCommentEnd; - tok.pb.Append(@v, 1); - end; - - tsCommentEol: - begin - if (v = #10) then - TokRec^.state := tsEatws else - tok.pb.Append(@v, 1); - end; - - tsCommentEnd: - begin - tok.pb.Append(@v, 1); - if (v = '/') then - TokRec^.state := tsEatws else - TokRec^.state := tsComment; - end; - - tsString: - begin - if (v = tok.quote_char) then - begin - TokRec^.current := TSuperObject.Create(SOString(tok.pb.GetString)); - TokRec^.saved_state := tsFinish; - TokRec^.state := tsEatws; - end else - if (v = '\') then - begin - TokRec^.saved_state := tsString; - TokRec^.state := tsStringEscape; - end else - begin - tok.pb.Append(@v, 1); - end - end; - - tsEvalProperty: - begin - if (TokRec^.current = nil) and (foCreatePath in options) then - begin - TokRec^.current := TSuperObject.Create(stObject); - TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current) - end else - if not ObjectIsType(TokRec^.current, stObject) then - begin - tok.err := teEvalObject; - goto out; - end; - tok.pb.Reset; - TokRec^.state := tsIdentifier; - goto redo_char; - end; - - tsEvalArray: - begin - if (TokRec^.current = nil) and (foCreatePath in options) then - begin - TokRec^.current := TSuperObject.Create(stArray); - TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current) - end else - if not ObjectIsType(TokRec^.current, stArray) then - begin - tok.err := teEvalArray; - goto out; - end; - tok.pb.Reset; - TokRec^.state := tsParamValue; - goto redo_char; - end; -{$IFDEF SUPER_METHOD} - tsEvalMethod: - begin - if ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then - begin - tok.pb.Reset; - TokRec^.obj := TSuperObject.Create(stArray); - TokRec^.state := tsMethodValue; - goto redo_char; - end else - begin - tok.err := teEvalMethod; - goto out; - end; - end; - - tsMethodValue: - begin - case v of - ')': - TokRec^.state := tsIdentifier; - else - if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then - begin - tok.err := teDepth; - goto out; - end; - inc(evalstack); - TokRec^.state := tsMethodPut; - inc(tok.depth); - tok.ResetLevel(tok.depth); - TokRec := @tok.stack[tok.depth]; - goto redo_char; - end; - end; - - tsMethodPut: - begin - TokRec^.obj.AsArray.Add(obj); - case v of - ',': - begin - tok.pb.Reset; - TokRec^.saved_state := tsMethodValue; - TokRec^.state := tsEatws; - end; - ')': - begin - if TokRec^.obj.AsArray.Length = 1 then - TokRec^.obj := TokRec^.obj.AsArray.GetO(0); - dec(evalstack); - tok.pb.Reset; - TokRec^.saved_state := tsIdentifier; - TokRec^.state := tsEatws; - end; - else - tok.err := teEvalMethod; - goto out; - end; - end; -{$ENDIF} - tsParamValue: - begin - case v of - ']': - TokRec^.state := tsIdentifier; - else - if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then - begin - tok.err := teDepth; - goto out; - end; - inc(evalstack); - TokRec^.state := tsParamPut; - inc(tok.depth); - tok.ResetLevel(tok.depth); - TokRec := @tok.stack[tok.depth]; - goto redo_char; - end; - end; - - tsParamPut: - begin - dec(evalstack); - TokRec^.obj := obj; - tok.pb.Reset; - TokRec^.saved_state := tsIdentifier; - TokRec^.state := tsEatws; - if v <> ']' then - begin - tok.err := teEvalArray; - goto out; - end; - end; - - tsIdentifier: - begin - if (this = nil) then - begin - if (SOIChar(v) < 256) and IsEndDelimiter(AnsiChar(v)) then - begin - if not strict then - begin - tok.pb.TrimRight; - TokRec^.current := TSuperObject.Create(tok.pb.Fbuf); - TokRec^.saved_state := tsFinish; - TokRec^.state := tsEatws; - goto redo_char; - end else - begin - tok.err := teParseString; - goto out; - end; - end else - if (v = '\') then - begin - TokRec^.saved_state := tsIdentifier; - TokRec^.state := tsStringEscape; - end else - tok.pb.Append(@v, 1); - end else - begin - if (SOIChar(v) < 256) and (AnsiChar(v) in reserved) then - begin - TokRec^.gparent := TokRec^.parent; - if TokRec^.current = nil then - TokRec^.parent := this else - TokRec^.parent := TokRec^.current; - - case ObjectGetType(TokRec^.parent) of - stObject: - case v of - '.': - begin - TokRec^.state := tsEvalProperty; - if tok.pb.FBPos > 0 then - TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); - end; - '[': - begin - TokRec^.state := tsEvalArray; - if tok.pb.FBPos > 0 then - TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); - end; - '(': - begin - TokRec^.state := tsEvalMethod; - if tok.pb.FBPos > 0 then - TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); - end; - else - if tok.pb.FBPos > 0 then - TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); - if (foPutValue in options) and (evalstack = 0) then - begin - TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, put); - TokRec^.current := put - end else - if (foDelete in options) and (evalstack = 0) then - begin - TokRec^.current := TokRec^.parent.AsObject.Delete(tok.pb.Fbuf); - end else - if (TokRec^.current = nil) and (foCreatePath in options) then - begin - TokRec^.current := TSuperObject.Create(dt); - TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current); - end; - TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); - TokRec^.state := tsFinish; - goto redo_char; - end; - stArray: - begin - if TokRec^.obj <> nil then - begin - if not ObjectIsType(TokRec^.obj, stInt) or (TokRec^.obj.AsInteger < 0) then - begin - tok.err := teEvalInt; - TokRec^.obj := nil; - goto out; - end; - numi := TokRec^.obj.AsInteger; - TokRec^.obj := nil; - - TokRec^.current := TokRec^.parent.AsArray.GetO(numi); - case v of - '.': - if (TokRec^.current = nil) and (foCreatePath in options) then - begin - TokRec^.current := TSuperObject.Create(stObject); - TokRec^.parent.AsArray.PutO(numi, TokRec^.current); - end else - if (TokRec^.current = nil) then - begin - tok.err := teEvalObject; - goto out; - end; - '[': - begin - if (TokRec^.current = nil) and (foCreatePath in options) then - begin - TokRec^.current := TSuperObject.Create(stArray); - TokRec^.parent.AsArray.Add(TokRec^.current); - end else - if (TokRec^.current = nil) then - begin - tok.err := teEvalArray; - goto out; - end; - TokRec^.state := tsEvalArray; - end; - '(': TokRec^.state := tsEvalMethod; - else - if (foPutValue in options) and (evalstack = 0) then - begin - TokRec^.parent.AsArray.PutO(numi, put); - TokRec^.current := put; - end else - if (foDelete in options) and (evalstack = 0) then - begin - TokRec^.current := TokRec^.parent.AsArray.Delete(numi); - end else - TokRec^.current := TokRec^.parent.AsArray.GetO(numi); - TokRec^.state := tsFinish; - goto redo_char - end; - end else - begin - case v of - '.': - begin - if (foPutValue in options) then - begin - TokRec^.current := TSuperObject.Create(stObject); - TokRec^.parent.AsArray.Add(TokRec^.current); - end else - TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1); - end; - '[': - begin - if (foPutValue in options) then - begin - TokRec^.current := TSuperObject.Create(stArray); - TokRec^.parent.AsArray.Add(TokRec^.current); - end else - TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1); - TokRec^.state := tsEvalArray; - end; - '(': - begin - if not (foPutValue in options) then - TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1) else - TokRec^.current := nil; - - TokRec^.state := tsEvalMethod; - end; - else - if (foPutValue in options) and (evalstack = 0) then - begin - TokRec^.parent.AsArray.Add(put); - TokRec^.current := put; - end else - if tok.pb.FBPos = 0 then - TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1); - TokRec^.state := tsFinish; - goto redo_char - end; - end; - end; -{$IFDEF SUPER_METHOD} - stMethod: - case v of - '.': - begin - TokRec^.current := nil; - sm := TokRec^.parent.AsMethod; - sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); - TokRec^.obj := nil; - end; - '[': - begin - TokRec^.current := nil; - sm := TokRec^.parent.AsMethod; - sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); - TokRec^.state := tsEvalArray; - TokRec^.obj := nil; - end; - '(': - begin - TokRec^.current := nil; - sm := TokRec^.parent.AsMethod; - sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); - TokRec^.state := tsEvalMethod; - TokRec^.obj := nil; - end; - else - if not (foPutValue in options) or (evalstack > 0) then - begin - TokRec^.current := nil; - sm := TokRec^.parent.AsMethod; - sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); - TokRec^.obj := nil; - TokRec^.state := tsFinish; - goto redo_char - end else - begin - tok.err := teEvalMethod; - TokRec^.obj := nil; - goto out; - end; - end; -{$ENDIF} - end; - end else - tok.pb.Append(@v, 1); - end; - end; - - tsStringEscape: - case v of - 'b', - 'n', - 'r', - 't', - 'f': - begin - if(v = 'b') then tok.pb.Append(TOK_BS, 1) - else if(v = 'n') then tok.pb.Append(TOK_LF, 1) - else if(v = 'r') then tok.pb.Append(TOK_CR, 1) - else if(v = 't') then tok.pb.Append(TOK_TAB, 1) - else if(v = 'f') then tok.pb.Append(TOK_FF, 1); - TokRec^.state := TokRec^.saved_state; - end; - 'u': - begin - tok.ucs_char := 0; - tok.st_pos := 0; - TokRec^.state := tsEscapeUnicode; - end; - 'x': - begin - tok.ucs_char := 0; - tok.st_pos := 0; - TokRec^.state := tsEscapeHexadecimal; - end - else - tok.pb.Append(@v, 1); - TokRec^.state := TokRec^.saved_state; - end; - - tsEscapeUnicode: - begin - if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then - begin - inc(tok.ucs_char, (Word(hexdigit(v)) shl ((3-tok.st_pos)*4))); - inc(tok.st_pos); - if (tok.st_pos = 4) then - begin - tok.pb.Append(@tok.ucs_char, 1); - TokRec^.state := TokRec^.saved_state; - end - end else - begin - tok.err := teParseString; - goto out; - end - end; - tsEscapeHexadecimal: - begin - if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then - begin - inc(tok.ucs_char, (Word(hexdigit(v)) shl ((1-tok.st_pos)*4))); - inc(tok.st_pos); - if (tok.st_pos = 2) then - begin - tok.pb.Append(@tok.ucs_char, 1); - TokRec^.state := TokRec^.saved_state; - end - end else - begin - tok.err := teParseString; - goto out; - end - end; - tsBoolean: - begin - tok.pb.Append(@v, 1); - if (StrLComp('true', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then - begin - if (tok.st_pos = 4) then - if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then - TokRec^.state := tsIdentifier else - begin - TokRec^.current := TSuperObject.Create(true); - TokRec^.saved_state := tsFinish; - TokRec^.state := tsEatws; - goto redo_char; - end - end else - if (StrLComp('false', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 5)) = 0) then - begin - if (tok.st_pos = 5) then - if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then - TokRec^.state := tsIdentifier else - begin - TokRec^.current := TSuperObject.Create(false); - TokRec^.saved_state := tsFinish; - TokRec^.state := tsEatws; - goto redo_char; - end - end else - begin - TokRec^.state := tsIdentifier; - tok.pb.FBuf[tok.st_pos] := #0; - dec(tok.pb.FBPos); - goto redo_char; - end; - inc(tok.st_pos); - end; - - tsNumber: - begin - if (SOIChar(v) < 256) and (AnsiChar(v) in super_number_chars_set) then - begin - tok.pb.Append(@v, 1); - if (SOIChar(v) < 256) then - case v of - '.': begin - tok.is_double := 1; - tok.floatcount := 0; - end; - 'e','E': - begin - tok.is_double := 1; - tok.floatcount := -1; - end; - '0'..'9': - begin - - if (tok.is_double = 1) and (tok.floatcount >= 0) then - begin - inc(tok.floatcount); - if tok.floatcount > 4 then - tok.floatcount := -1; - end; - end; - end; - end else - begin - if (tok.is_double = 0) then - begin - val(tok.pb.FBuf, numi, code); - if ObjectIsType(this, stArray) then - begin - if (foPutValue in options) and (evalstack = 0) then - begin - this.AsArray.PutO(numi, put); - TokRec^.current := put; - end else - if (foDelete in options) and (evalstack = 0) then - TokRec^.current := this.AsArray.Delete(numi) else - TokRec^.current := this.AsArray.GetO(numi); - end else - TokRec^.current := TSuperObject.Create(numi); - - end else - if (tok.is_double <> 0) then - begin - if tok.floatcount >= 0 then - begin - p := tok.pb.FBuf; - while p^ <> '.' do inc(p); - for code := 0 to tok.floatcount - 1 do - begin - p^ := p[1]; - inc(p); - end; - p^ := #0; - val(tok.pb.FBuf, numi, code); - case tok.floatcount of - 0: numi := numi * 10000; - 1: numi := numi * 1000; - 2: numi := numi * 100; - 3: numi := numi * 10; - end; - TokRec^.current := TSuperObject.CreateCurrency(PCurrency(@numi)^); - end else - begin - val(tok.pb.FBuf, numd, code); - TokRec^.current := TSuperObject.Create(numd); - end; - end else - begin - tok.err := teParseNumber; - goto out; - end; - TokRec^.saved_state := tsFinish; - TokRec^.state := tsEatws; - goto redo_char; - end - end; - - tsArray: - begin - if (v = ']') then - begin - TokRec^.saved_state := tsFinish; - TokRec^.state := tsEatws; - end else - begin - if(tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then - begin - tok.err := teDepth; - goto out; - end; - TokRec^.state := tsArrayAdd; - inc(tok.depth); - tok.ResetLevel(tok.depth); - TokRec := @tok.stack[tok.depth]; - goto redo_char; - end - end; - - tsArrayAdd: - begin - TokRec^.current.AsArray.Add(obj); - TokRec^.saved_state := tsArraySep; - TokRec^.state := tsEatws; - goto redo_char; - end; - - tsArraySep: - begin - if (v = ']') then - begin - TokRec^.saved_state := tsFinish; - TokRec^.state := tsEatws; - end else - if (v = ',') then - begin - TokRec^.saved_state := tsArray; - TokRec^.state := tsEatws; - end else - begin - tok.err := teParseArray; - goto out; - end - end; - - tsObjectFieldStart: - begin - if (v = '}') then - begin - TokRec^.saved_state := tsFinish; - TokRec^.state := tsEatws; - end else - if (SOIChar(v) < 256) and (AnsiChar(v) in ['"', '''']) then - begin - tok.quote_char := v; - tok.pb.Reset; - TokRec^.state := tsObjectField; - end else - if not((SOIChar(v) < 256) and ((AnsiChar(v) in reserved) or strict)) then - begin - TokRec^.state := tsObjectUnquotedField; - tok.pb.Reset; - goto redo_char; - end else - begin - tok.err := teParseObjectKeyName; - goto out; - end - end; - - tsObjectField: - begin - if (v = tok.quote_char) then - begin - TokRec^.field_name := tok.pb.FBuf; - TokRec^.saved_state := tsObjectFieldEnd; - TokRec^.state := tsEatws; - end else - if (v = '\') then - begin - TokRec^.saved_state := tsObjectField; - TokRec^.state := tsStringEscape; - end else - begin - tok.pb.Append(@v, 1); - end - end; - - tsObjectUnquotedField: - begin - if (SOIChar(v) < 256) and (AnsiChar(v) in [':', #0]) then - begin - TokRec^.field_name := tok.pb.FBuf; - TokRec^.saved_state := tsObjectFieldEnd; - TokRec^.state := tsEatws; - goto redo_char; - end else - if (v = '\') then - begin - TokRec^.saved_state := tsObjectUnquotedField; - TokRec^.state := tsStringEscape; - end else - tok.pb.Append(@v, 1); - end; - - tsObjectFieldEnd: - begin - if (v = ':') then - begin - TokRec^.saved_state := tsObjectValue; - TokRec^.state := tsEatws; - end else - begin - tok.err := teParseObjectKeySep; - goto out; - end - end; - - tsObjectValue: - begin - if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then - begin - tok.err := teDepth; - goto out; - end; - TokRec^.state := tsObjectValueAdd; - inc(tok.depth); - tok.ResetLevel(tok.depth); - TokRec := @tok.stack[tok.depth]; - goto redo_char; - end; - - tsObjectValueAdd: - begin - TokRec^.current.AsObject.PutO(TokRec^.field_name, obj); - TokRec^.field_name := ''; - TokRec^.saved_state := tsObjectSep; - TokRec^.state := tsEatws; - goto redo_char; - end; - - tsObjectSep: - begin - if (v = '}') then - begin - TokRec^.saved_state := tsFinish; - TokRec^.state := tsEatws; - end else - if (v = ',') then - begin - TokRec^.saved_state := tsObjectFieldStart; - TokRec^.state := tsEatws; - end else - begin - tok.err := teParseObjectValueSep; - goto out; - end - end; - end; - inc(str); - inc(tok.char_offset); - until v = #0; - - if(TokRec^.state <> tsFinish) and - (TokRec^.saved_state <> tsFinish) then - tok.err := teParseEof; - - out: - if(tok.err in [teSuccess]) then - begin -{$IFDEF SUPER_METHOD} - if (foCallMethod in options) and ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then - begin - sm := TokRec^.current.AsMethod; - sm(TokRec^.parent, put, Result); - end else -{$ENDIF} - Result := TokRec^.current; - end else - Result := nil; -end; - -procedure TSuperObject.PutO(const path: SOString; const Value: ISuperObject); -begin - ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], Value); -end; - -procedure TSuperObject.PutB(const path: SOString; Value: Boolean); -begin - ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); -end; - -procedure TSuperObject.PutD(const path: SOString; Value: Double); -begin - ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); -end; - -procedure TSuperObject.PutC(const path: SOString; Value: Currency); -begin - ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.CreateCurrency(Value)); -end; - -procedure TSuperObject.PutI(const path: SOString; Value: SuperInt); -begin - ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); -end; - -procedure TSuperObject.PutS(const path: SOString; const Value: SOString); -begin - ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); -end; - -function TSuperObject.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; -begin - if GetInterface(IID, Obj) then - Result := 0 - else - Result := E_NOINTERFACE; -end; - -function TSuperObject.SaveTo(stream: TStream; indent, escape: boolean): integer; -var - pb: TSuperWriterStream; -begin - if escape then - pb := TSuperAnsiWriterStream.Create(stream) else - pb := TSuperUnicodeWriterStream.Create(stream); - - if(Write(pb, indent, escape, 0) < 0) then - begin - pb.Reset; - pb.Free; - Result := 0; - Exit; - end; - Result := stream.Size; - pb.Free; -end; - -function TSuperObject.CalcSize(indent, escape: boolean): integer; -var - pb: TSuperWriterFake; -begin - pb := TSuperWriterFake.Create; - if(Write(pb, indent, escape, 0) < 0) then - begin - pb.Free; - Result := 0; - Exit; - end; - Result := pb.FSize; - pb.Free; -end; - -function TSuperObject.SaveTo(socket: Integer; indent, escape: boolean): integer; -var - pb: TSuperWriterSock; -begin - pb := TSuperWriterSock.Create(socket); - if(Write(pb, indent, escape, 0) < 0) then - begin - pb.Free; - Result := 0; - Exit; - end; - Result := pb.FSize; - pb.Free; -end; - -constructor TSuperObject.Create(const s: SOString); -begin - Create(stString); - FOString := s; -end; - -procedure TSuperObject.Clear(all: boolean); -begin - if FProcessing then exit; - FProcessing := true; - try - case FDataType of - stBoolean: FO.c_boolean := false; - stDouble: FO.c_double := 0.0; - stCurrency: FO.c_currency := 0.0; - stInt: FO.c_int := 0; - stObject: FO.c_object.Clear(all); - stArray: FO.c_array.Clear(all); - stString: FOString := ''; -{$IFDEF SUPER_METHOD} - stMethod: FO.c_method := nil; -{$ENDIF} - end; - finally - FProcessing := false; - end; -end; - -procedure TSuperObject.Pack(all: boolean = false); -begin - if FProcessing then exit; - FProcessing := true; - try - case FDataType of - stObject: FO.c_object.Pack(all); - stArray: FO.c_array.Pack(all); - end; - finally - FProcessing := false; - end; -end; - -function TSuperObject.GetN(const path: SOString): ISuperObject; -begin - Result := ParseString(PSOChar(path), False, true, self); - if Result = nil then - Result := TSuperObject.Create(stNull); -end; - -procedure TSuperObject.PutN(const path: SOString; const Value: ISuperObject); -begin - if Value = nil then - ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], TSuperObject.Create(stNull)) else - ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], Value); -end; - -function TSuperObject.Delete(const path: SOString): ISuperObject; -begin - Result := ParseString(PSOChar(path), False, true, self, [foDelete]); -end; - -function TSuperObject.Clone: ISuperObject; -var - ite: TSuperObjectIter; - arr: TSuperArray; - j: integer; -begin - case FDataType of - stBoolean: Result := TSuperObject.Create(FO.c_boolean); - stDouble: Result := TSuperObject.Create(FO.c_double); - stCurrency: Result := TSuperObject.CreateCurrency(FO.c_currency); - stInt: Result := TSuperObject.Create(FO.c_int); - stString: Result := TSuperObject.Create(FOString); -{$IFDEF SUPER_METHOD} - stMethod: Result := TSuperObject.Create(FO.c_method); -{$ENDIF} - stObject: - begin - Result := TSuperObject.Create(stObject); - if ObjectFindFirst(self, ite) then - with Result.AsObject do - repeat - PutO(ite.key, ite.val.Clone); - until not ObjectFindNext(ite); - ObjectFindClose(ite); - end; - stArray: - begin - Result := TSuperObject.Create(stArray); - arr := AsArray; - with Result.AsArray do - for j := 0 to arr.Length - 1 do - Add(arr.GetO(j).Clone); - end; - else - Result := nil; - end; -end; - -procedure TSuperObject.Merge(const obj: ISuperObject; reference: boolean); -var - prop1, prop2: ISuperObject; - ite: TSuperObjectIter; - arr: TSuperArray; - j: integer; -begin - if ObjectIsType(obj, FDataType) then - case FDataType of - stBoolean: FO.c_boolean := obj.AsBoolean; - stDouble: FO.c_double := obj.AsDouble; - stCurrency: FO.c_currency := obj.AsCurrency; - stInt: FO.c_int := obj.AsInteger; - stString: FOString := obj.AsString; -{$IFDEF SUPER_METHOD} - stMethod: FO.c_method := obj.AsMethod; -{$ENDIF} - stObject: - begin - if ObjectFindFirst(obj, ite) then - with FO.c_object do - repeat - prop1 := FO.c_object.GetO(ite.key); - if (prop1 <> nil) and (ite.val <> nil) and (prop1.DataType = ite.val.DataType) then - prop1.Merge(ite.val) else - if reference then - PutO(ite.key, ite.val) else - PutO(ite.key, ite.val.Clone); - until not ObjectFindNext(ite); - ObjectFindClose(ite); - end; - stArray: - begin - arr := obj.AsArray; - with FO.c_array do - for j := 0 to arr.Length - 1 do - begin - prop1 := GetO(j); - prop2 := arr.GetO(j); - if (prop1 <> nil) and (prop2 <> nil) and (prop1.DataType = prop2.DataType) then - prop1.Merge(prop2) else - if reference then - PutO(j, prop2) else - PutO(j, prop2.Clone); - end; - end; - end; -end; - -procedure TSuperObject.Merge(const str: SOString); -begin - Merge(TSuperObject.ParseString(PSOChar(str), False), true); -end; - -class function TSuperObject.NewInstance: TObject; -begin - Result := inherited NewInstance; - TSuperObject(Result).FRefCount := 1; -end; - -function TSuperObject.ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject; -begin - Result := ParseString(PSOChar(path), False, True, Self, [foCreatePath], nil, dataType); -end; - -function TSuperObject.Format(const str: SOString; BeginSep: SOChar; EndSep: SOChar): SOString; -var - p1, p2: PSOChar; -begin - Result := ''; - p2 := PSOChar(str); - p1 := p2; - while true do - if p2^ = BeginSep then - begin - if p2 > p1 then - Result := Result + Copy(p1, 0, p2-p1); - inc(p2); - p1 := p2; - while true do - if p2^ = EndSep then Break else - if p2^ = #0 then Exit else - inc(p2); - Result := Result + GetS(copy(p1, 0, p2-p1)); - inc(p2); - p1 := p2; - end - else if p2^ = #0 then - begin - if p2 > p1 then - Result := Result + Copy(p1, 0, p2-p1); - Break; - end else - inc(p2); -end; - -function TSuperObject.GetO(const path: SOString): ISuperObject; -begin - Result := ParseString(PSOChar(path), False, True, Self); -end; - -function TSuperObject.GetA(const path: SOString): TSuperArray; -var - obj: ISuperObject; -begin - obj := ParseString(PSOChar(path), False, True, Self); - if obj <> nil then - Result := obj.AsArray else - Result := nil; -end; - -function TSuperObject.GetB(const path: SOString): Boolean; -var - obj: ISuperObject; -begin - obj := GetO(path); - if obj <> nil then - Result := obj.AsBoolean else - Result := false; -end; - -function TSuperObject.GetD(const path: SOString): Double; -var - obj: ISuperObject; -begin - obj := GetO(path); - if obj <> nil then - Result := obj.AsDouble else - Result := 0.0; -end; - -function TSuperObject.GetC(const path: SOString): Currency; -var - obj: ISuperObject; -begin - obj := GetO(path); - if obj <> nil then - Result := obj.AsCurrency else - Result := 0.0; -end; - -function TSuperObject.GetI(const path: SOString): SuperInt; -var - obj: ISuperObject; -begin - obj := GetO(path); - if obj <> nil then - Result := obj.AsInteger else - Result := 0; -end; - -function TSuperObject.GetDataPtr: Pointer; -begin - Result := FDataPtr; -end; - -function TSuperObject.GetDataType: TSuperType; -begin - Result := FDataType -end; - -function TSuperObject.GetS(const path: SOString): SOString; -var - obj: ISuperObject; -begin - obj := GetO(path); - if obj <> nil then - Result := obj.AsString else - Result := ''; -end; - -function TSuperObject.SaveTo(const FileName: string; indent, escape: boolean): integer; -var - stream: TFileStream; -begin - stream := TFileStream.Create(FileName, fmCreate); - try - Result := SaveTo(stream, indent, escape); - finally - stream.Free; - end; -end; - -function TSuperObject.Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; -begin - Result := Validate(TSuperObject.ParseString(PSOChar(rules), False), TSuperObject.ParseString(PSOChar(defs), False), callback, sender); -end; - -function TSuperObject.Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; -type - TDataType = (dtUnknown, dtStr, dtInt, dtFloat, dtNumber, dtText, dtBool, - dtMap, dtSeq, dtScalar, dtAny); -var - datatypes: ISuperObject; - names: ISuperObject; - - function FindInheritedProperty(const prop: PSOChar; p: ISuperObject): ISuperObject; - var - o: ISuperObject; - e: TSuperAvlEntry; - begin - o := p[prop]; - if o <> nil then - result := o else - begin - o := p['inherit']; - if (o <> nil) and ObjectIsType(o, stString) then - begin - e := names.AsObject.Search(o.AsString); - if (e <> nil) then - Result := FindInheritedProperty(prop, e.Value) else - Result := nil; - end else - Result := nil; - end; - end; - - function FindDataType(o: ISuperObject): TDataType; - var - e: TSuperAvlEntry; - obj: ISuperObject; - begin - obj := FindInheritedProperty('type', o); - if obj <> nil then - begin - e := datatypes.AsObject.Search(obj.AsString); - if e <> nil then - Result := TDataType(e.Value.AsInteger) else - Result := dtUnknown; - end else - Result := dtUnknown; - end; - - procedure GetNames(o: ISuperObject); - var - obj: ISuperObject; - f: TSuperObjectIter; - begin - obj := o['name']; - if ObjectIsType(obj, stString) then - names[obj.AsString] := o; - - case FindDataType(o) of - dtMap: - begin - obj := o['mapping']; - if ObjectIsType(obj, stObject) then - begin - if ObjectFindFirst(obj, f) then - repeat - if ObjectIsType(f.val, stObject) then - GetNames(f.val); - until not ObjectFindNext(f); - ObjectFindClose(f); - end; - end; - dtSeq: - begin - obj := o['sequence']; - if ObjectIsType(obj, stObject) then - GetNames(obj); - end; - end; - end; - - function FindInheritedField(const prop: SOString; p: ISuperObject): ISuperObject; - var - o: ISuperObject; - e: TSuperAvlEntry; - begin - o := p['mapping']; - if ObjectIsType(o, stObject) then - begin - o := o.AsObject.GetO(prop); - if o <> nil then - begin - Result := o; - Exit; - end; - end; - - o := p['inherit']; - if ObjectIsType(o, stString) then - begin - e := names.AsObject.Search(o.AsString); - if (e <> nil) then - Result := FindInheritedField(prop, e.Value) else - Result := nil; - end else - Result := nil; - end; - - function InheritedFieldExist(const obj: ISuperObject; p: ISuperObject; const name: SOString = ''): boolean; - var - o: ISuperObject; - e: TSuperAvlEntry; - j: TSuperAvlIterator; - begin - Result := true; - o := p['mapping']; - if ObjectIsType(o, stObject) then - begin - j := TSuperAvlIterator.Create(o.AsObject); - try - j.First; - e := j.GetIter; - while e <> nil do - begin - if obj.AsObject.Search(e.Name) = nil then - begin - Result := False; - if assigned(callback) then - callback(sender, veFieldNotFound, name + '.' + e.Name); - end; - j.Next; - e := j.GetIter; - end; - - finally - j.Free; - end; - end; - - o := p['inherit']; - if ObjectIsType(o, stString) then - begin - e := names.AsObject.Search(o.AsString); - if (e <> nil) then - Result := InheritedFieldExist(obj, e.Value, name) and Result; - end; - end; - - function getInheritedBool(f: PSOChar; p: ISuperObject; default: boolean = false): boolean; - var - o: ISuperObject; - begin - o := FindInheritedProperty(f, p); - case ObjectGetType(o) of - stBoolean: Result := o.AsBoolean; - stNull: Result := Default; - else - Result := default; - if assigned(callback) then - callback(sender, veRuleMalformated, f); - end; - end; - - procedure GetInheritedFieldList(list: ISuperObject; p: ISuperObject); - var - o: ISuperObject; - e: TSuperAvlEntry; - i: TSuperAvlIterator; - begin - Result := true; - o := p['mapping']; - if ObjectIsType(o, stObject) then - begin - i := TSuperAvlIterator.Create(o.AsObject); - try - i.First; - e := i.GetIter; - while e <> nil do - begin - if list.AsObject.Search(e.Name) = nil then - list[e.Name] := e.Value; - i.Next; - e := i.GetIter; - end; - - finally - i.Free; - end; - end; - - o := p['inherit']; - if ObjectIsType(o, stString) then - begin - e := names.AsObject.Search(o.AsString); - if (e <> nil) then - GetInheritedFieldList(list, e.Value); - end; - end; - - function CheckEnum(o: ISuperObject; p: ISuperObject; name: SOString = ''): boolean; - var - enum: ISuperObject; - i: integer; - begin - Result := false; - enum := FindInheritedProperty('enum', p); - case ObjectGetType(enum) of - stArray: - for i := 0 to enum.AsArray.Length - 1 do - if (o.AsString = enum.AsArray[i].AsString) then - begin - Result := true; - exit; - end; - stNull: Result := true; - else - Result := false; - if assigned(callback) then - callback(sender, veRuleMalformated, ''); - Exit; - end; - - if (not Result) and assigned(callback) then - callback(sender, veValueNotInEnum, name); - end; - - function CheckLength(len: integer; p: ISuperObject; const objpath: SOString): boolean; - var - length, o: ISuperObject; - begin - result := true; - length := FindInheritedProperty('length', p); - case ObjectGetType(length) of - stObject: - begin - o := length.AsObject.GetO('min'); - if (o <> nil) and (o.AsInteger > len) then - begin - Result := false; - if assigned(callback) then - callback(sender, veInvalidLength, objpath); - end; - o := length.AsObject.GetO('max'); - if (o <> nil) and (o.AsInteger < len) then - begin - Result := false; - if assigned(callback) then - callback(sender, veInvalidLength, objpath); - end; - o := length.AsObject.GetO('minex'); - if (o <> nil) and (o.AsInteger >= len) then - begin - Result := false; - if assigned(callback) then - callback(sender, veInvalidLength, objpath); - end; - o := length.AsObject.GetO('maxex'); - if (o <> nil) and (o.AsInteger <= len) then - begin - Result := false; - if assigned(callback) then - callback(sender, veInvalidLength, objpath); - end; - end; - stNull: ; - else - Result := false; - if assigned(callback) then - callback(sender, veRuleMalformated, ''); - end; - end; - - function CheckRange(obj: ISuperObject; p: ISuperObject; const objpath: SOString): boolean; - var - length, o: ISuperObject; - begin - result := true; - length := FindInheritedProperty('range', p); - case ObjectGetType(length) of - stObject: - begin - o := length.AsObject.GetO('min'); - if (o <> nil) and (o.Compare(obj) = cpGreat) then - begin - Result := false; - if assigned(callback) then - callback(sender, veInvalidRange, objpath); - end; - o := length.AsObject.GetO('max'); - if (o <> nil) and (o.Compare(obj) = cpLess) then - begin - Result := false; - if assigned(callback) then - callback(sender, veInvalidRange, objpath); - end; - o := length.AsObject.GetO('minex'); - if (o <> nil) and (o.Compare(obj) in [cpGreat, cpEqu]) then - begin - Result := false; - if assigned(callback) then - callback(sender, veInvalidRange, objpath); - end; - o := length.AsObject.GetO('maxex'); - if (o <> nil) and (o.Compare(obj) in [cpLess, cpEqu]) then - begin - Result := false; - if assigned(callback) then - callback(sender, veInvalidRange, objpath); - end; - end; - stNull: ; - else - Result := false; - if assigned(callback) then - callback(sender, veRuleMalformated, ''); - end; - end; - - - function process(o: ISuperObject; p: ISuperObject; objpath: SOString = ''): boolean; - var - ite: TSuperAvlIterator; - ent: TSuperAvlEntry; - p2, o2, sequence: ISuperObject; - s: SOString; - i: integer; - uniquelist, fieldlist: ISuperObject; - begin - Result := true; - if (o = nil) then - begin - if getInheritedBool('required', p) then - begin - if assigned(callback) then - callback(sender, veFieldIsRequired, objpath); - result := false; - end; - end else - case FindDataType(p) of - dtStr: - case ObjectGetType(o) of - stString: - begin - Result := Result and CheckLength(Length(o.AsString), p, objpath); - Result := Result and CheckRange(o, p, objpath); - end; - else - if assigned(callback) then - callback(sender, veInvalidDataType, objpath); - result := false; - end; - dtBool: - case ObjectGetType(o) of - stBoolean: - begin - Result := Result and CheckRange(o, p, objpath); - end; - else - if assigned(callback) then - callback(sender, veInvalidDataType, objpath); - result := false; - end; - dtInt: - case ObjectGetType(o) of - stInt: - begin - Result := Result and CheckRange(o, p, objpath); - end; - else - if assigned(callback) then - callback(sender, veInvalidDataType, objpath); - result := false; - end; - dtFloat: - case ObjectGetType(o) of - stDouble, stCurrency: - begin - Result := Result and CheckRange(o, p, objpath); - end; - else - if assigned(callback) then - callback(sender, veInvalidDataType, objpath); - result := false; - end; - dtMap: - case ObjectGetType(o) of - stObject: - begin - // all objects have and match a rule ? - ite := TSuperAvlIterator.Create(o.AsObject); - try - ite.First; - ent := ite.GetIter; - while ent <> nil do - begin - p2 := FindInheritedField(ent.Name, p); - if ObjectIsType(p2, stObject) then - result := process(ent.Value, p2, objpath + '.' + ent.Name) and result else - begin - if assigned(callback) then - callback(sender, veUnexpectedField, objpath + '.' + ent.Name); - result := false; // field have no rule - end; - ite.Next; - ent := ite.GetIter; - end; - finally - ite.Free; - end; - - // all expected field exists ? - Result := InheritedFieldExist(o, p, objpath) and Result; - end; - stNull: {nop}; - else - result := false; - if assigned(callback) then - callback(sender, veRuleMalformated, objpath); - end; - dtSeq: - case ObjectGetType(o) of - stArray: - begin - sequence := FindInheritedProperty('sequence', p); - if sequence <> nil then - case ObjectGetType(sequence) of - stObject: - begin - for i := 0 to o.AsArray.Length - 1 do - result := process(o.AsArray.GetO(i), sequence, objpath + '[' + IntToStr(i) + ']') and result; - if getInheritedBool('unique', sequence) then - begin - // type is unique ? - uniquelist := TSuperObject.Create(stObject); - try - for i := 0 to o.AsArray.Length - 1 do - begin - s := o.AsArray.GetO(i).AsString; - if (s <> '') then - begin - if uniquelist.AsObject.Search(s) = nil then - uniquelist[s] := nil else - begin - Result := False; - if Assigned(callback) then - callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + ']'); - end; - end; - end; - finally - uniquelist := nil; - end; - end; - - // field is unique ? - if (FindDataType(sequence) = dtMap) then - begin - fieldlist := TSuperObject.Create(stObject); - try - GetInheritedFieldList(fieldlist, sequence); - ite := TSuperAvlIterator.Create(fieldlist.AsObject); - try - ite.First; - ent := ite.GetIter; - while ent <> nil do - begin - if getInheritedBool('unique', ent.Value) then - begin - uniquelist := TSuperObject.Create(stObject); - try - for i := 0 to o.AsArray.Length - 1 do - begin - o2 := o.AsArray.GetO(i); - if o2 <> nil then - begin - s := o2.AsObject.GetO(ent.Name).AsString; - if (s <> '') then - if uniquelist.AsObject.Search(s) = nil then - uniquelist[s] := nil else - begin - Result := False; - if Assigned(callback) then - callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + '].' + ent.name); - end; - end; - end; - finally - uniquelist := nil; - end; - end; - ite.Next; - ent := ite.GetIter; - end; - finally - ite.Free; - end; - finally - fieldlist := nil; - end; - end; - - - end; - stNull: {nop}; - else - result := false; - if assigned(callback) then - callback(sender, veRuleMalformated, objpath); - end; - Result := Result and CheckLength(o.AsArray.Length, p, objpath); - - end; - else - result := false; - if assigned(callback) then - callback(sender, veRuleMalformated, objpath); - end; - dtNumber: - case ObjectGetType(o) of - stInt, - stDouble, stCurrency: - begin - Result := Result and CheckRange(o, p, objpath); - end; - else - if assigned(callback) then - callback(sender, veInvalidDataType, objpath); - result := false; - end; - dtText: - case ObjectGetType(o) of - stInt, - stDouble, - stCurrency, - stString: - begin - result := result and CheckLength(Length(o.AsString), p, objpath); - Result := Result and CheckRange(o, p, objpath); - end; - else - if assigned(callback) then - callback(sender, veInvalidDataType, objpath); - result := false; - end; - dtScalar: - case ObjectGetType(o) of - stBoolean, - stDouble, - stCurrency, - stInt, - stString: - begin - result := result and CheckLength(Length(o.AsString), p, objpath); - Result := Result and CheckRange(o, p, objpath); - end; - else - if assigned(callback) then - callback(sender, veInvalidDataType, objpath); - result := false; - end; - dtAny:; - else - if assigned(callback) then - callback(sender, veRuleMalformated, objpath); - result := false; - end; - Result := Result and CheckEnum(o, p, objpath) - - end; -var - j: integer; - -begin - Result := False; - datatypes := TSuperObject.Create(stObject); - names := TSuperObject.Create; - try - datatypes.I['str'] := ord(dtStr); - datatypes.I['int'] := ord(dtInt); - datatypes.I['float'] := ord(dtFloat); - datatypes.I['number'] := ord(dtNumber); - datatypes.I['text'] := ord(dtText); - datatypes.I['bool'] := ord(dtBool); - datatypes.I['map'] := ord(dtMap); - datatypes.I['seq'] := ord(dtSeq); - datatypes.I['scalar'] := ord(dtScalar); - datatypes.I['any'] := ord(dtAny); - - if ObjectIsType(defs, stArray) then - for j := 0 to defs.AsArray.Length - 1 do - if ObjectIsType(defs.AsArray[j], stObject) then - GetNames(defs.AsArray[j]) else - begin - if assigned(callback) then - callback(sender, veRuleMalformated, ''); - Exit; - end; - - - if ObjectIsType(rules, stObject) then - GetNames(rules) else - begin - if assigned(callback) then - callback(sender, veRuleMalformated, ''); - Exit; - end; - - Result := process(self, rules); - - finally - datatypes := nil; - names := nil; - end; -end; - -function TSuperObject._AddRef: Integer; stdcall; -begin - Result := InterlockedIncrement(FRefCount); -end; - -function TSuperObject._Release: Integer; stdcall; -begin - Result := InterlockedDecrement(FRefCount); - if Result = 0 then - Destroy; -end; - -function TSuperObject.Compare(const str: SOString): TSuperCompareResult; -begin - Result := Compare(TSuperObject.ParseString(PSOChar(str), False)); -end; - -function TSuperObject.Compare(const obj: ISuperObject): TSuperCompareResult; - function GetIntCompResult(const i: int64): TSuperCompareResult; - begin - if i < 0 then result := cpLess else - if i = 0 then result := cpEqu else - Result := cpGreat; - end; - - function GetDblCompResult(const d: double): TSuperCompareResult; - begin - if d < 0 then result := cpLess else - if d = 0 then result := cpEqu else - Result := cpGreat; - end; - -begin - case DataType of - stBoolean: - case ObjectGetType(obj) of - stBoolean: Result := GetIntCompResult(ord(FO.c_boolean) - ord(obj.AsBoolean)); - stDouble: Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsDouble); - stCurrency:Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsCurrency); - stInt: Result := GetIntCompResult(ord(FO.c_boolean) - obj.AsInteger); - stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); - else - Result := cpError; - end; - stDouble: - case ObjectGetType(obj) of - stBoolean: Result := GetDblCompResult(FO.c_double - ord(obj.AsBoolean)); - stDouble: Result := GetDblCompResult(FO.c_double - obj.AsDouble); - stCurrency:Result := GetDblCompResult(FO.c_double - obj.AsCurrency); - stInt: Result := GetDblCompResult(FO.c_double - obj.AsInteger); - stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); - else - Result := cpError; - end; - stCurrency: - case ObjectGetType(obj) of - stBoolean: Result := GetDblCompResult(FO.c_currency - ord(obj.AsBoolean)); - stDouble: Result := GetDblCompResult(FO.c_currency - obj.AsDouble); - stCurrency:Result := GetDblCompResult(FO.c_currency - obj.AsCurrency); - stInt: Result := GetDblCompResult(FO.c_currency - obj.AsInteger); - stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); - else - Result := cpError; - end; - stInt: - case ObjectGetType(obj) of - stBoolean: Result := GetIntCompResult(FO.c_int - ord(obj.AsBoolean)); - stDouble: Result := GetDblCompResult(FO.c_int - obj.AsDouble); - stCurrency:Result := GetDblCompResult(FO.c_int - obj.AsCurrency); - stInt: Result := GetIntCompResult(FO.c_int - obj.AsInteger); - stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); - else - Result := cpError; - end; - stString: - case ObjectGetType(obj) of - stBoolean, - stDouble, - stCurrency, - stInt, - stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); - else - Result := cpError; - end; - else - Result := cpError; - end; -end; - -{$IFDEF SUPER_METHOD} -function TSuperObject.AsMethod: TSuperMethod; -begin - if FDataType = stMethod then - Result := FO.c_method else - Result := nil; -end; -{$ENDIF} - -{$IFDEF SUPER_METHOD} -constructor TSuperObject.Create(m: TSuperMethod); -begin - Create(stMethod); - FO.c_method := m; -end; -{$ENDIF} - -{$IFDEF SUPER_METHOD} -function TSuperObject.GetM(const path: SOString): TSuperMethod; -var - v: ISuperObject; -begin - v := ParseString(PSOChar(path), False, True, Self); - if (v <> nil) and (ObjectGetType(v) = stMethod) then - Result := v.AsMethod else - Result := nil; -end; -{$ENDIF} - -{$IFDEF SUPER_METHOD} -procedure TSuperObject.PutM(const path: SOString; Value: TSuperMethod); -begin - ParseString(PSOChar(path), False, True, Self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); -end; -{$ENDIF} - -{$IFDEF SUPER_METHOD} -function TSuperObject.call(const path: SOString; const param: ISuperObject): ISuperObject; -begin - Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], param); -end; -{$ENDIF} - -{$IFDEF SUPER_METHOD} -function TSuperObject.call(const path, param: SOString): ISuperObject; -begin - Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], TSuperObject.ParseString(PSOChar(param), False)); -end; -{$ENDIF} - -function TSuperObject.GetProcessing: boolean; -begin - Result := FProcessing; -end; - -procedure TSuperObject.SetDataPtr(const Value: Pointer); -begin - FDataPtr := Value; -end; - -procedure TSuperObject.SetProcessing(value: boolean); -begin - FProcessing := value; -end; - -{ TSuperArray } - -function TSuperArray.Add(const Data: ISuperObject): Integer; -begin - Result := FLength; - PutO(Result, data); -end; - -function TSuperArray.Delete(index: Integer): ISuperObject; -begin - if (Index >= 0) and (Index < FLength) then - begin - Result := FArray^[index]; - FArray^[index] := nil; - Dec(FLength); - if Index < FLength then - begin - Move(FArray^[index + 1], FArray^[index], - (FLength - index) * SizeOf(Pointer)); - Pointer(FArray^[FLength]) := nil; - end; - end; -end; - -procedure TSuperArray.Insert(index: Integer; const value: ISuperObject); -begin - if (Index >= 0) then - if (index < FLength) then - begin - if FLength = FSize then - Expand(index); - if Index < FLength then - Move(FArray^[index], FArray^[index + 1], - (FLength - index) * SizeOf(Pointer)); - Pointer(FArray^[index]) := nil; - FArray^[index] := value; - Inc(FLength); - end else - PutO(index, value); -end; - -procedure TSuperArray.Clear(all: boolean); -var - j: Integer; -begin - for j := 0 to FLength - 1 do - if FArray^[j] <> nil then - begin - if all then - FArray^[j].Clear(all); - FArray^[j] := nil; - end; - FLength := 0; -end; - -procedure TSuperArray.Pack(all: boolean); -var - PackedCount, StartIndex, EndIndex, j: Integer; -begin - if FLength > 0 then - begin - PackedCount := 0; - StartIndex := 0; - repeat - while (StartIndex < FLength) and (FArray^[StartIndex] = nil) do - Inc(StartIndex); - if StartIndex < FLength then - begin - EndIndex := StartIndex; - while (EndIndex < FLength) and (FArray^[EndIndex] <> nil) do - Inc(EndIndex); - - Dec(EndIndex); - - if StartIndex > PackedCount then - Move(FArray^[StartIndex], FArray^[PackedCount], (EndIndex - StartIndex + 1) * SizeOf(Pointer)); - - Inc(PackedCount, EndIndex - StartIndex + 1); - StartIndex := EndIndex + 1; - end; - until StartIndex >= FLength; - FillChar(FArray^[PackedCount], (FLength - PackedCount) * sizeof(Pointer), 0); - FLength := PackedCount; - if all then - for j := 0 to FLength - 1 do - FArray^[j].Pack(all); - end; -end; - -constructor TSuperArray.Create; -begin - inherited Create; - FSize := SUPER_ARRAY_LIST_DEFAULT_SIZE; - FLength := 0; - GetMem(FArray, sizeof(Pointer) * FSize); - FillChar(FArray^, sizeof(Pointer) * FSize, 0); -end; - -destructor TSuperArray.Destroy; -begin - Clear; - FreeMem(FArray); - inherited; -end; - -procedure TSuperArray.Expand(max: Integer); -var - new_size: Integer; -begin - if (max < FSize) then - Exit; - if max < (FSize shl 1) then - new_size := (FSize shl 1) else - new_size := max + 1; - ReallocMem(FArray, new_size * sizeof(Pointer)); - FillChar(FArray^[FSize], (new_size - FSize) * sizeof(Pointer), 0); - FSize := new_size; -end; - -function TSuperArray.GetO(const index: Integer): ISuperObject; -begin - if(index >= FLength) then - Result := nil else - Result := FArray^[index]; -end; - -function TSuperArray.GetB(const index: integer): Boolean; -var - obj: ISuperObject; -begin - obj := GetO(index); - if obj <> nil then - Result := obj.AsBoolean else - Result := false; -end; - -function TSuperArray.GetD(const index: integer): Double; -var - obj: ISuperObject; -begin - obj := GetO(index); - if obj <> nil then - Result := obj.AsDouble else - Result := 0.0; -end; - -function TSuperArray.GetI(const index: integer): SuperInt; -var - obj: ISuperObject; -begin - obj := GetO(index); - if obj <> nil then - Result := obj.AsInteger else - Result := 0; -end; - -function TSuperArray.GetS(const index: integer): SOString; -var - obj: ISuperObject; -begin - obj := GetO(index); - if obj <> nil then - Result := obj.AsString else - Result := ''; -end; - -procedure TSuperArray.PutO(const index: Integer; const Value: ISuperObject); -begin - Expand(index); - FArray^[index] := value; - if(FLength <= index) then FLength := index + 1; -end; - -function TSuperArray.GetN(const index: integer): ISuperObject; -begin - Result := GetO(index); - if Result = nil then - Result := TSuperObject.Create(stNull); -end; - -procedure TSuperArray.PutN(const index: integer; const Value: ISuperObject); -begin - if Value <> nil then - PutO(index, Value) else - PutO(index, TSuperObject.Create(stNull)); -end; - -procedure TSuperArray.PutB(const index: integer; Value: Boolean); -begin - PutO(index, TSuperObject.Create(Value)); -end; - -procedure TSuperArray.PutD(const index: integer; Value: Double); -begin - PutO(index, TSuperObject.Create(Value)); -end; - -function TSuperArray.GetC(const index: integer): Currency; -var - obj: ISuperObject; -begin - obj := GetO(index); - if obj <> nil then - Result := obj.AsCurrency else - Result := 0.0; -end; - -procedure TSuperArray.PutC(const index: integer; Value: Currency); -begin - PutO(index, TSuperObject.CreateCurrency(Value)); -end; - -procedure TSuperArray.PutI(const index: integer; Value: SuperInt); -begin - PutO(index, TSuperObject.Create(Value)); -end; - -procedure TSuperArray.PutS(const index: integer; const Value: SOString); -begin - PutO(index, TSuperObject.Create(Value)); -end; - -{$IFDEF SUPER_METHOD} -function TSuperArray.GetM(const index: integer): TSuperMethod; -var - v: ISuperObject; -begin - v := GetO(index); - if (ObjectGetType(v) = stMethod) then - Result := v.AsMethod else - Result := nil; -end; -{$ENDIF} - -{$IFDEF SUPER_METHOD} -procedure TSuperArray.PutM(const index: integer; Value: TSuperMethod); -begin - PutO(index, TSuperObject.Create(Value)); -end; -{$ENDIF} - -{ TSuperWriterString } - -function TSuperWriterString.Append(buf: PSOChar; Size: Integer): Integer; - function max(a, b: Integer): integer; begin if a > b then Result := a else Result := b end; -begin - Result := size; - if Size > 0 then - begin - if (FSize - FBPos <= size) then - begin - FSize := max(FSize * 2, FBPos + size + 8); - ReallocMem(FBuf, FSize * SizeOf(SOChar)); - end; - // fast move - case size of - 1: FBuf[FBPos] := buf^; - 2: PInteger(@FBuf[FBPos])^ := PInteger(buf)^; - 4: PInt64(@FBuf[FBPos])^ := PInt64(buf)^; - else - move(buf^, FBuf[FBPos], size * SizeOf(SOChar)); - end; - inc(FBPos, size); - FBuf[FBPos] := #0; - end; -end; - -function TSuperWriterString.Append(buf: PSOChar): Integer; -begin - Result := Append(buf, strlen(buf)); -end; - -constructor TSuperWriterString.Create; -begin - inherited; - FSize := 32; - FBPos := 0; - GetMem(FBuf, FSize * SizeOf(SOChar)); -end; - -destructor TSuperWriterString.Destroy; -begin - inherited; - if FBuf <> nil then - FreeMem(FBuf) -end; - -function TSuperWriterString.GetString: SOString; -begin - SetString(Result, FBuf, FBPos); -end; - -procedure TSuperWriterString.Reset; -begin - FBuf[0] := #0; - FBPos := 0; -end; - -procedure TSuperWriterString.TrimRight; -begin - while (FBPos > 0) and (FBuf[FBPos-1] < #256) and (AnsiChar(FBuf[FBPos-1]) in [#32, #13, #10]) do - begin - dec(FBPos); - FBuf[FBPos] := #0; - end; -end; - -{ TSuperWriterStream } - -function TSuperWriterStream.Append(buf: PSOChar): Integer; -begin - Result := Append(buf, StrLen(buf)); -end; - -constructor TSuperWriterStream.Create(AStream: TStream); -begin - inherited Create; - FStream := AStream; -end; - -procedure TSuperWriterStream.Reset; -begin - FStream.Size := 0; -end; - -{ TSuperWriterStream } - -function TSuperAnsiWriterStream.Append(buf: PSOChar; Size: Integer): Integer; -var - Buffer: array[0..1023] of AnsiChar; - pBuffer: PAnsiChar; - i: Integer; -begin - if Size = 1 then - Result := FStream.Write(buf^, Size) else - begin - if Size > SizeOf(Buffer) then - GetMem(pBuffer, Size) else - pBuffer := @Buffer; - try - for i := 0 to Size - 1 do - pBuffer[i] := AnsiChar(buf[i]); - Result := FStream.Write(pBuffer^, Size); - finally - if pBuffer <> @Buffer then - FreeMem(pBuffer); - end; - end; -end; - -{ TSuperUnicodeWriterStream } - -function TSuperUnicodeWriterStream.Append(buf: PSOChar; Size: Integer): Integer; -begin - Result := FStream.Write(buf^, Size * 2); -end; - -{ TSuperWriterFake } - -function TSuperWriterFake.Append(buf: PSOChar; Size: Integer): Integer; -begin - inc(FSize, Size); - Result := FSize; -end; - -function TSuperWriterFake.Append(buf: PSOChar): Integer; -begin - inc(FSize, Strlen(buf)); - Result := FSize; -end; - -constructor TSuperWriterFake.Create; -begin - inherited Create; - FSize := 0; -end; - -procedure TSuperWriterFake.Reset; -begin - FSize := 0; -end; - -{ TSuperWriterSock } - -function TSuperWriterSock.Append(buf: PSOChar; Size: Integer): Integer; -var - Buffer: array[0..1023] of AnsiChar; - pBuffer: PAnsiChar; - i: Integer; -begin - if Size = 1 then -{$IFDEF FPC} - Result := fpsend(FSocket, buf, size, 0) else -{$ELSE} - Result := send(FSocket, buf^, size, 0) else -{$ENDIF} - begin - if Size > SizeOf(Buffer) then - GetMem(pBuffer, Size) else - pBuffer := @Buffer; - try - for i := 0 to Size - 1 do - pBuffer[i] := AnsiChar(buf[i]); -{$IFDEF FPC} - Result := fpsend(FSocket, pBuffer, size, 0); -{$ELSE} - Result := send(FSocket, pBuffer^, size, 0); -{$ENDIF} - finally - if pBuffer <> @Buffer then - FreeMem(pBuffer); - end; - end; - inc(FSize, Result); -end; - -function TSuperWriterSock.Append(buf: PSOChar): Integer; -begin - Result := Append(buf, StrLen(buf)); -end; - -constructor TSuperWriterSock.Create(ASocket: Integer); -begin - inherited Create; - FSocket := ASocket; - FSize := 0; -end; - -procedure TSuperWriterSock.Reset; -begin - FSize := 0; -end; - -{ TSuperTokenizer } - -constructor TSuperTokenizer.Create; -begin - pb := TSuperWriterString.Create; - line := 1; - col := 0; - Reset; -end; - -destructor TSuperTokenizer.Destroy; -begin - Reset; - pb.Free; - inherited; -end; - -procedure TSuperTokenizer.Reset; -var - i: integer; -begin - for i := depth downto 0 do - ResetLevel(i); - depth := 0; - err := teSuccess; -end; - -procedure TSuperTokenizer.ResetLevel(adepth: integer); -begin - stack[adepth].state := tsEatws; - stack[adepth].saved_state := tsStart; - stack[adepth].current := nil; - stack[adepth].field_name := ''; - stack[adepth].obj := nil; - stack[adepth].parent := nil; - stack[adepth].gparent := nil; -end; - -{ TSuperAvlTree } - -constructor TSuperAvlTree.Create; -begin - FRoot := nil; - FCount := 0; -end; - -destructor TSuperAvlTree.Destroy; -begin - Clear; - inherited; -end; - -function TSuperAvlTree.IsEmpty: boolean; -begin - result := FRoot = nil; -end; - -function TSuperAvlTree.balance(bal: TSuperAvlEntry): TSuperAvlEntry; -var - deep, old: TSuperAvlEntry; - bf: integer; -begin - if (bal.FBf > 0) then - begin - deep := bal.FGt; - if (deep.FBf < 0) then - begin - old := bal; - bal := deep.FLt; - old.FGt := bal.FLt; - deep.FLt := bal.FGt; - bal.FLt := old; - bal.FGt := deep; - bf := bal.FBf; - if (bf <> 0) then - begin - if (bf > 0) then - begin - old.FBf := -1; - deep.FBf := 0; - end else - begin - deep.FBf := 1; - old.FBf := 0; - end; - bal.FBf := 0; - end else - begin - old.FBf := 0; - deep.FBf := 0; - end; - end else - begin - bal.FGt := deep.FLt; - deep.FLt := bal; - if (deep.FBf = 0) then - begin - deep.FBf := -1; - bal.FBf := 1; - end else - begin - deep.FBf := 0; - bal.FBf := 0; - end; - bal := deep; - end; - end else - begin - (* "Less than" subtree is deeper. *) - - deep := bal.FLt; - if (deep.FBf > 0) then - begin - old := bal; - bal := deep.FGt; - old.FLt := bal.FGt; - deep.FGt := bal.FLt; - bal.FGt := old; - bal.FLt := deep; - - bf := bal.FBf; - if (bf <> 0) then - begin - if (bf < 0) then - begin - old.FBf := 1; - deep.FBf := 0; - end else - begin - deep.FBf := -1; - old.FBf := 0; - end; - bal.FBf := 0; - end else - begin - old.FBf := 0; - deep.FBf := 0; - end; - end else - begin - bal.FLt := deep.FGt; - deep.FGt := bal; - if (deep.FBf = 0) then - begin - deep.FBf := 1; - bal.FBf := -1; - end else - begin - deep.FBf := 0; - bal.FBf := 0; - end; - bal := deep; - end; - end; - Result := bal; -end; - -function TSuperAvlTree.Insert(h: TSuperAvlEntry): TSuperAvlEntry; -var - unbal, parentunbal, hh, parent: TSuperAvlEntry; - depth, unbaldepth: longint; - cmp: integer; - unbalbf: integer; - branch: TSuperAvlBitArray; - p: Pointer; -begin - inc(FCount); - h.FLt := nil; - h.FGt := nil; - h.FBf := 0; - branch := []; - - if (FRoot = nil) then - FRoot := h - else - begin - unbal := nil; - parentunbal := nil; - depth := 0; - unbaldepth := 0; - hh := FRoot; - parent := nil; - repeat - if (hh.FBf <> 0) then - begin - unbal := hh; - parentunbal := parent; - unbaldepth := depth; - end; - if hh.FHash <> h.FHash then - begin - if hh.FHash < h.FHash then cmp := -1 else - if hh.FHash > h.FHash then cmp := 1 else - cmp := 0; - end else - cmp := CompareNodeNode(h, hh); - if (cmp = 0) then - begin - Result := hh; - //exchange data - p := hh.Ptr; - hh.FPtr := h.Ptr; - h.FPtr := p; - doDeleteEntry(h, false); - dec(FCount); - exit; - end; - parent := hh; - if (cmp > 0) then - begin - hh := hh.FGt; - include(branch, depth); - end else - begin - hh := hh.FLt; - exclude(branch, depth); - end; - inc(depth); - until (hh = nil); - - if (cmp < 0) then - parent.FLt := h else - parent.FGt := h; - - depth := unbaldepth; - - if (unbal = nil) then - hh := FRoot - else - begin - if depth in branch then - cmp := 1 else - cmp := -1; - inc(depth); - unbalbf := unbal.FBf; - if (cmp < 0) then - dec(unbalbf) else - inc(unbalbf); - if cmp < 0 then - hh := unbal.FLt else - hh := unbal.FGt; - if ((unbalbf <> -2) and (unbalbf <> 2)) then - begin - unbal.FBf := unbalbf; - unbal := nil; - end; - end; - - if (hh <> nil) then - while (h <> hh) do - begin - if depth in branch then - cmp := 1 else - cmp := -1; - inc(depth); - if (cmp < 0) then - begin - hh.FBf := -1; - hh := hh.FLt; - end else (* cmp > 0 *) - begin - hh.FBf := 1; - hh := hh.FGt; - end; - end; - - if (unbal <> nil) then - begin - unbal := balance(unbal); - if (parentunbal = nil) then - FRoot := unbal - else - begin - depth := unbaldepth - 1; - if depth in branch then - cmp := 1 else - cmp := -1; - if (cmp < 0) then - parentunbal.FLt := unbal else - parentunbal.FGt := unbal; - end; - end; - end; - result := h; -end; - -function TSuperAvlTree.Search(const k: SOString; st: TSuperAvlSearchTypes): TSuperAvlEntry; -var - cmp, target_cmp: integer; - match_h, h: TSuperAvlEntry; - ha: Cardinal; -begin - ha := TSuperAvlEntry.Hash(k); - - match_h := nil; - h := FRoot; - - if (stLess in st) then - target_cmp := 1 else - if (stGreater in st) then - target_cmp := -1 else - target_cmp := 0; - - while (h <> nil) do - begin - if h.FHash < ha then cmp := -1 else - if h.FHash > ha then cmp := 1 else - cmp := 0; - - if cmp = 0 then - cmp := CompareKeyNode(PSOChar(k), h); - if (cmp = 0) then - begin - if (stEqual in st) then - begin - match_h := h; - break; - end; - cmp := -target_cmp; - end - else - if (target_cmp <> 0) then - if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then - match_h := h; - if cmp < 0 then - h := h.FLt else - h := h.FGt; - end; - result := match_h; -end; - -function TSuperAvlTree.Delete(const k: SOString): ISuperObject; -var - depth, rm_depth: longint; - branch: TSuperAvlBitArray; - h, parent, child, path, rm, parent_rm: TSuperAvlEntry; - cmp, cmp_shortened_sub_with_path, reduced_depth, bf: integer; - ha: Cardinal; -begin - ha := TSuperAvlEntry.Hash(k); - cmp_shortened_sub_with_path := 0; - branch := []; - - depth := 0; - h := FRoot; - parent := nil; - while true do - begin - if (h = nil) then - exit; - if h.FHash < ha then cmp := -1 else - if h.FHash > ha then cmp := 1 else - cmp := 0; - - if cmp = 0 then - cmp := CompareKeyNode(k, h); - if (cmp = 0) then - break; - parent := h; - if (cmp > 0) then - begin - h := h.FGt; - include(branch, depth) - end else - begin - h := h.FLt; - exclude(branch, depth) - end; - inc(depth); - cmp_shortened_sub_with_path := cmp; - end; - rm := h; - parent_rm := parent; - rm_depth := depth; - - if (h.FBf < 0) then - begin - child := h.FLt; - exclude(branch, depth); - cmp := -1; - end else - begin - child := h.FGt; - include(branch, depth); - cmp := 1; - end; - inc(depth); - - if (child <> nil) then - begin - cmp := -cmp; - repeat - parent := h; - h := child; - if (cmp < 0) then - begin - child := h.FLt; - exclude(branch, depth); - end else - begin - child := h.FGt; - include(branch, depth); - end; - inc(depth); - until (child = nil); - - if (parent = rm) then - cmp_shortened_sub_with_path := -cmp else - cmp_shortened_sub_with_path := cmp; - - if cmp > 0 then - child := h.FLt else - child := h.FGt; - end; - - if (parent = nil) then - FRoot := child else - if (cmp_shortened_sub_with_path < 0) then - parent.FLt := child else - parent.FGt := child; - - if parent = rm then - path := h else - path := parent; - - if (h <> rm) then - begin - h.FLt := rm.FLt; - h.FGt := rm.FGt; - h.FBf := rm.FBf; - if (parent_rm = nil) then - FRoot := h - else - begin - depth := rm_depth - 1; - if (depth in branch) then - parent_rm.FGt := h else - parent_rm.FLt := h; - end; - end; - - if (path <> nil) then - begin - h := FRoot; - parent := nil; - depth := 0; - while (h <> path) do - begin - if (depth in branch) then - begin - child := h.FGt; - h.FGt := parent; - end else - begin - child := h.FLt; - h.FLt := parent; - end; - inc(depth); - parent := h; - h := child; - end; - - reduced_depth := 1; - cmp := cmp_shortened_sub_with_path; - while true do - begin - if (reduced_depth <> 0) then - begin - bf := h.FBf; - if (cmp < 0) then - inc(bf) else - dec(bf); - if ((bf = -2) or (bf = 2)) then - begin - h := balance(h); - bf := h.FBf; - end else - h.FBf := bf; - reduced_depth := integer(bf = 0); - end; - if (parent = nil) then - break; - child := h; - h := parent; - dec(depth); - if depth in branch then - cmp := 1 else - cmp := -1; - if (cmp < 0) then - begin - parent := h.FLt; - h.FLt := child; - end else - begin - parent := h.FGt; - h.FGt := child; - end; - end; - FRoot := h; - end; - if rm <> nil then - begin - Result := rm.GetValue; - doDeleteEntry(rm, false); - dec(FCount); - end; -end; - -procedure TSuperAvlTree.Pack(all: boolean); -var - node1, node2: TSuperAvlEntry; - list: TList; - i: Integer; -begin - node1 := FRoot; - list := TList.Create; - while node1 <> nil do - begin - if (node1.FLt = nil) then - begin - node2 := node1.FGt; - if (node1.FPtr = nil) then - list.Add(node1) else - if all then - node1.Value.Pack(all); - end - else - begin - node2 := node1.FLt; - node1.FLt := node2.FGt; - node2.FGt := node1; - end; - node1 := node2; - end; - for i := 0 to list.Count - 1 do - Delete(TSuperAvlEntry(list[i]).FName); - list.Free; -end; - -procedure TSuperAvlTree.Clear(all: boolean); -var - node1, node2: TSuperAvlEntry; -begin - node1 := FRoot; - while node1 <> nil do - begin - if (node1.FLt = nil) then - begin - node2 := node1.FGt; - doDeleteEntry(node1, all); - end - else - begin - node2 := node1.FLt; - node1.FLt := node2.FGt; - node2.FGt := node1; - end; - node1 := node2; - end; - FRoot := nil; - FCount := 0; -end; - -function TSuperAvlTree.CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; -begin - Result := StrComp(PSOChar(k), PSOChar(h.FName)); -end; - -function TSuperAvlTree.CompareNodeNode(node1, node2: TSuperAvlEntry): integer; -begin - Result := StrComp(PSOChar(node1.FName), PSOChar(node2.FName)); -end; - -{ TSuperAvlIterator } - -(* Initialize depth to invalid value, to indicate iterator is -** invalid. (Depth is zero-base.) It's not necessary to initialize -** iterators prior to passing them to the "start" function. -*) - -constructor TSuperAvlIterator.Create(tree: TSuperAvlTree); -begin - FDepth := not 0; - FTree := tree; -end; - -procedure TSuperAvlIterator.Search(const k: SOString; st: TSuperAvlSearchTypes); -var - h: TSuperAvlEntry; - d: longint; - cmp, target_cmp: integer; - ha: Cardinal; -begin - ha := TSuperAvlEntry.Hash(k); - h := FTree.FRoot; - d := 0; - FDepth := not 0; - if (h = nil) then - exit; - - if (stLess in st) then - target_cmp := 1 else - if (stGreater in st) then - target_cmp := -1 else - target_cmp := 0; - - while true do - begin - if h.FHash < ha then cmp := -1 else - if h.FHash > ha then cmp := 1 else - cmp := 0; - - if cmp = 0 then - cmp := FTree.CompareKeyNode(k, h); - if (cmp = 0) then - begin - if (stEqual in st) then - begin - FDepth := d; - break; - end; - cmp := -target_cmp; - end - else - if (target_cmp <> 0) then - if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then - FDepth := d; - if cmp < 0 then - h := h.FLt else - h := h.FGt; - if (h = nil) then - break; - if (cmp > 0) then - include(FBranch, d) else - exclude(FBranch, d); - FPath[d] := h; - inc(d); - end; -end; - -procedure TSuperAvlIterator.First; -var - h: TSuperAvlEntry; -begin - h := FTree.FRoot; - FDepth := not 0; - FBranch := []; - while (h <> nil) do - begin - if (FDepth <> not 0) then - FPath[FDepth] := h; - inc(FDepth); - h := h.FLt; - end; -end; - -procedure TSuperAvlIterator.Last; -var - h: TSuperAvlEntry; -begin - h := FTree.FRoot; - FDepth := not 0; - FBranch := [0..SUPER_AVL_MAX_DEPTH - 1]; - while (h <> nil) do - begin - if (FDepth <> not 0) then - FPath[FDepth] := h; - inc(FDepth); - h := h.FGt; - end; -end; - -function TSuperAvlIterator.MoveNext: boolean; -begin - if FDepth = not 0 then - First else - Next; - Result := GetIter <> nil; -end; - -function TSuperAvlIterator.GetIter: TSuperAvlEntry; -begin - if (FDepth = not 0) then - begin - result := nil; - exit; - end; - if FDepth = 0 then - Result := FTree.FRoot else - Result := FPath[FDepth - 1]; -end; - -procedure TSuperAvlIterator.Next; -var - h: TSuperAvlEntry; -begin - if (FDepth <> not 0) then - begin - if FDepth = 0 then - h := FTree.FRoot.FGt else - h := FPath[FDepth - 1].FGt; - - if (h = nil) then - repeat - if (FDepth = 0) then - begin - FDepth := not 0; - break; - end; - dec(FDepth); - until (not (FDepth in FBranch)) - else - begin - include(FBranch, FDepth); - FPath[FDepth] := h; - inc(FDepth); - while true do - begin - h := h.FLt; - if (h = nil) then - break; - exclude(FBranch, FDepth); - FPath[FDepth] := h; - inc(FDepth); - end; - end; - end; -end; - -procedure TSuperAvlIterator.Prior; -var - h: TSuperAvlEntry; -begin - if (FDepth <> not 0) then - begin - if FDepth = 0 then - h := FTree.FRoot.FLt else - h := FPath[FDepth - 1].FLt; - if (h = nil) then - repeat - if (FDepth = 0) then - begin - FDepth := not 0; - break; - end; - dec(FDepth); - until (FDepth in FBranch) - else - begin - exclude(FBranch, FDepth); - FPath[FDepth] := h; - inc(FDepth); - while true do - begin - h := h.FGt; - if (h = nil) then - break; - include(FBranch, FDepth); - FPath[FDepth] := h; - inc(FDepth); - end; - end; - end; -end; - -procedure TSuperAvlTree.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); -begin - Entry.Free; -end; - -function TSuperAvlTree.GetEnumerator: TSuperAvlIterator; -begin - Result := TSuperAvlIterator.Create(Self); -end; - -{ TSuperAvlEntry } - -constructor TSuperAvlEntry.Create(const AName: SOString; Obj: Pointer); -begin - FName := AName; - FPtr := Obj; - FHash := Hash(FName); -end; - -function TSuperAvlEntry.GetValue: ISuperObject; -begin - Result := ISuperObject(FPtr) -end; - -class function TSuperAvlEntry.Hash(const k: SOString): Cardinal; -var - h: cardinal; - i: Integer; -begin - h := 0; -{$Q-} - for i := 1 to Length(k) do - h := h*129 + ord(k[i]) + $9e370001; -{$Q+} - Result := h; -end; - -procedure TSuperAvlEntry.SetValue(const val: ISuperObject); -begin - ISuperObject(FPtr) := val; -end; - -{ TSuperTableString } - -function TSuperTableString.GetValues: ISuperObject; -var - ite: TSuperAvlIterator; - obj: TSuperAvlEntry; -begin - Result := TSuperObject.Create(stArray); - ite := TSuperAvlIterator.Create(Self); - try - ite.First; - obj := ite.GetIter; - while obj <> nil do - begin - Result.AsArray.Add(obj.Value); - ite.Next; - obj := ite.GetIter; - end; - finally - ite.Free; - end; -end; - -function TSuperTableString.GetNames: ISuperObject; -var - ite: TSuperAvlIterator; - obj: TSuperAvlEntry; -begin - Result := TSuperObject.Create(stArray); - ite := TSuperAvlIterator.Create(Self); - try - ite.First; - obj := ite.GetIter; - while obj <> nil do - begin - Result.AsArray.Add(TSuperObject.Create(obj.FName)); - ite.Next; - obj := ite.GetIter; - end; - finally - ite.Free; - end; -end; - -procedure TSuperTableString.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); -begin - if Entry.Ptr <> nil then - begin - if all then Entry.Value.Clear(true); - Entry.Value := nil; - end; - inherited; -end; - -function TSuperTableString.GetO(const k: SOString): ISuperObject; -var - e: TSuperAvlEntry; -begin - e := Search(k); - if e <> nil then - Result := e.Value else - Result := nil -end; - -procedure TSuperTableString.PutO(const k: SOString; const value: ISuperObject); -var - entry: TSuperAvlEntry; -begin - entry := Insert(TSuperAvlEntry.Create(k, Pointer(value))); - if entry.FPtr <> nil then - ISuperObject(entry.FPtr)._AddRef; -end; - -procedure TSuperTableString.PutS(const k: SOString; const value: SOString); -begin - PutO(k, TSuperObject.Create(Value)); -end; - -function TSuperTableString.GetS(const k: SOString): SOString; -var - obj: ISuperObject; -begin - obj := GetO(k); - if obj <> nil then - Result := obj.AsString else - Result := ''; -end; - -procedure TSuperTableString.PutI(const k: SOString; value: SuperInt); -begin - PutO(k, TSuperObject.Create(Value)); -end; - -function TSuperTableString.GetI(const k: SOString): SuperInt; -var - obj: ISuperObject; -begin - obj := GetO(k); - if obj <> nil then - Result := obj.AsInteger else - Result := 0; -end; - -procedure TSuperTableString.PutD(const k: SOString; value: Double); -begin - PutO(k, TSuperObject.Create(Value)); -end; - -procedure TSuperTableString.PutC(const k: SOString; value: Currency); -begin - PutO(k, TSuperObject.CreateCurrency(Value)); -end; - -function TSuperTableString.GetC(const k: SOString): Currency; -var - obj: ISuperObject; -begin - obj := GetO(k); - if obj <> nil then - Result := obj.AsCurrency else - Result := 0.0; -end; - -function TSuperTableString.GetD(const k: SOString): Double; -var - obj: ISuperObject; -begin - obj := GetO(k); - if obj <> nil then - Result := obj.AsDouble else - Result := 0.0; -end; - -procedure TSuperTableString.PutB(const k: SOString; value: Boolean); -begin - PutO(k, TSuperObject.Create(Value)); -end; - -function TSuperTableString.GetB(const k: SOString): Boolean; -var - obj: ISuperObject; -begin - obj := GetO(k); - if obj <> nil then - Result := obj.AsBoolean else - Result := False; -end; - -{$IFDEF SUPER_METHOD} -procedure TSuperTableString.PutM(const k: SOString; value: TSuperMethod); -begin - PutO(k, TSuperObject.Create(Value)); -end; -{$ENDIF} - -{$IFDEF SUPER_METHOD} -function TSuperTableString.GetM(const k: SOString): TSuperMethod; -var - obj: ISuperObject; -begin - obj := GetO(k); - if obj <> nil then - Result := obj.AsMethod else - Result := nil; -end; -{$ENDIF} - -procedure TSuperTableString.PutN(const k: SOString; const value: ISuperObject); -begin - if value <> nil then - PutO(k, TSuperObject.Create(stNull)) else - PutO(k, value); -end; - -function TSuperTableString.GetN(const k: SOString): ISuperObject; -var - obj: ISuperObject; -begin - obj := GetO(k); - if obj <> nil then - Result := obj else - Result := TSuperObject.Create(stNull); -end; - - -{$IFDEF VER210} - -{ TSuperAttribute } - -constructor TSuperAttribute.Create(const AName: string); -begin - FName := AName; -end; - -{ TSuperRttiContext } - -constructor TSuperRttiContext.Create; -begin - Context := TRttiContext.Create; - SerialFromJson := TDictionary.Create; - SerialToJson := TDictionary.Create; - - SerialFromJson.Add(TypeInfo(Boolean), serialfromboolean); - SerialFromJson.Add(TypeInfo(TDateTime), serialfromdatetime); - SerialFromJson.Add(TypeInfo(TGUID), serialfromguid); - SerialToJson.Add(TypeInfo(Boolean), serialtoboolean); - SerialToJson.Add(TypeInfo(TDateTime), serialtodatetime); - SerialToJson.Add(TypeInfo(TGUID), serialtoguid); -end; - -destructor TSuperRttiContext.Destroy; -begin - SerialFromJson.Free; - SerialToJson.Free; - Context.Free; -end; - -class function TSuperRttiContext.GetFieldName(r: TRttiField): string; -var - o: TCustomAttribute; -begin - for o in r.GetAttributes do - if o is SOName then - Exit(SOName(o).Name); - Result := r.Name; -end; - -class function TSuperRttiContext.GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject; -var - o: TCustomAttribute; -begin - if not ObjectIsType(obj, stNull) then Exit(obj); - for o in r.GetAttributes do - if o is SODefault then - Exit(SO(SODefault(o).Name)); - Result := obj; -end; - -function TSuperRttiContext.AsType(const obj: ISuperObject): T; -var - ret: TValue; -begin - if FromJson(TypeInfo(T), obj, ret) then - Result := ret.AsType else - raise exception.Create('Marshalling error'); -end; - -function TSuperRttiContext.AsJson(const obj: T; const index: ISuperObject = nil): ISuperObject; -var - v: TValue; -begin - TValue.MakeWithoutCopy(@obj, TypeInfo(T), v); - if index <> nil then - Result := ToJson(v, index) else - Result := ToJson(v, so); -end; - -function TSuperRttiContext.FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; - var Value: TValue): Boolean; - - procedure FromChar; - begin - if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then - begin - Value := string(AnsiString(obj.AsString)[1]); - Result := True; - end else - Result := False; - end; - - procedure FromWideChar; - begin - if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then - begin - Value := obj.AsString[1]; - Result := True; - end else - Result := False; - end; - - procedure FromInt64; - var - i: Int64; - begin - case ObjectGetType(obj) of - stInt: - begin - TValue.Make(nil, TypeInfo, Value); - TValueData(Value).FAsSInt64 := obj.AsInteger; - Result := True; - end; - stString: - begin - if TryStrToInt64(obj.AsString, i) then - begin - TValue.Make(nil, TypeInfo, Value); - TValueData(Value).FAsSInt64 := i; - Result := True; - end else - Result := False; - end; - else - Result := False; - end; - end; - - procedure FromInt(const obj: ISuperObject); - var - TypeData: PTypeData; - i: Integer; - o: ISuperObject; - begin - case ObjectGetType(obj) of - stInt, stBoolean: - begin - i := obj.AsInteger; - TypeData := GetTypeData(TypeInfo); - Result := (i >= TypeData.MinValue) and (i <= TypeData.MaxValue); - if Result then - TValue.Make(@i, TypeInfo, Value); - end; - stString: - begin - o := SO(obj.AsString); - if not ObjectIsType(o, stString) then - FromInt(o) else - Result := False; - end; - else - Result := False; - end; - end; - - procedure fromSet; - begin - if ObjectIsType(obj, stInt) then - begin - TValue.Make(nil, TypeInfo, Value); - TValueData(Value).FAsSLong := obj.AsInteger; - Result := True; - end else - Result := False; - end; - - procedure FromFloat(const obj: ISuperObject); - var - o: ISuperObject; - begin - case ObjectGetType(obj) of - stInt, stDouble, stCurrency: - begin - TValue.Make(nil, TypeInfo, Value); - case GetTypeData(TypeInfo).FloatType of - ftSingle: TValueData(Value).FAsSingle := obj.AsDouble; - ftDouble: TValueData(Value).FAsDouble := obj.AsDouble; - ftExtended: TValueData(Value).FAsExtended := obj.AsDouble; - ftComp: TValueData(Value).FAsSInt64 := obj.AsInteger; - ftCurr: TValueData(Value).FAsCurr := obj.AsCurrency; - end; - Result := True; - end; - stString: - begin - o := SO(obj.AsString); - if not ObjectIsType(o, stString) then - FromFloat(o) else - Result := False; - end - else - Result := False; - end; - end; - - procedure FromString; - begin - case ObjectGetType(obj) of - stObject, stArray: - Result := False; - stnull: - begin - Value := ''; - Result := True; - end; - else - Value := obj.AsString; - Result := True; - end; - end; - - procedure FromClass; - var - f: TRttiField; - v: TValue; - begin - case ObjectGetType(obj) of - stObject: - begin - Result := True; - if Value.Kind <> tkClass then - Value := GetTypeData(TypeInfo).ClassType.Create; - for f in Context.GetType(Value.AsObject.ClassType).GetFields do - if f.FieldType <> nil then - begin - Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v); - if Result then - f.SetValue(Value.AsObject, v) else - Exit; - end; - end; - stNull: - begin - Value := nil; - Result := True; - end - else - // error - Value := nil; - Result := False; - end; - end; - - procedure FromRecord; - var - f: TRttiField; - p: Pointer; - v: TValue; - begin - Result := True; - TValue.Make(nil, TypeInfo, Value); - for f in Context.GetType(TypeInfo).GetFields do - begin - if ObjectIsType(obj, stObject) and (f.FieldType <> nil) then - begin - p := IValueData(TValueData(Value).FHeapData).GetReferenceToRawData; - Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v); - if Result then - f.SetValue(p, v) else - Exit; - end else - begin - Result := False; - Exit; - end; - end; - end; - - procedure FromDynArray; - var - i: Integer; - p: Pointer; - pb: PByte; - val: TValue; - typ: PTypeData; - el: PTypeInfo; - begin - case ObjectGetType(obj) of - stArray: - begin - i := obj.AsArray.Length; - p := nil; - DynArraySetLength(p, TypeInfo, 1, @i); - pb := p; - typ := GetTypeData(TypeInfo); - if typ.elType <> nil then - el := typ.elType^ else - el := typ.elType2^; - - Result := True; - for i := 0 to i - 1 do - begin - Result := FromJson(el, obj.AsArray[i], val); - if not Result then - Break; - val.ExtractRawData(pb); - val := TValue.Empty; - Inc(pb, typ.elSize); - end; - if Result then - TValue.MakeWithoutCopy(@p, TypeInfo, Value) else - DynArrayClear(p, TypeInfo); - end; - stNull: - begin - TValue.MakeWithoutCopy(nil, TypeInfo, Value); - Result := True; - end; - else - i := 1; - p := nil; - DynArraySetLength(p, TypeInfo, 1, @i); - pb := p; - typ := GetTypeData(TypeInfo); - if typ.elType <> nil then - el := typ.elType^ else - el := typ.elType2^; - - Result := FromJson(el, obj, val); - val.ExtractRawData(pb); - val := TValue.Empty; - - if Result then - TValue.MakeWithoutCopy(@p, TypeInfo, Value) else - DynArrayClear(p, TypeInfo); - end; - end; - - procedure FromArray; - var - ArrayData: PArrayTypeData; - idx: Integer; - function ProcessDim(dim: Byte; const o: ISuperobject): Boolean; - var - i: Integer; - v: TValue; - a: PTypeData; - begin - if ObjectIsType(o, stArray) and (ArrayData.Dims[dim-1] <> nil) then - begin - a := @GetTypeData(ArrayData.Dims[dim-1]^).ArrayData; - if (a.MaxValue - a.MinValue + 1) <> o.AsArray.Length then - begin - Result := False; - Exit; - end; - Result := True; - if dim = ArrayData.DimCount then - for i := a.MinValue to a.MaxValue do - begin - Result := FromJson(ArrayData.ElType^, o.AsArray[i], v); - if not Result then - Exit; - Value.SetArrayElement(idx, v); - inc(idx); - end - else - for i := a.MinValue to a.MaxValue do - begin - Result := ProcessDim(dim + 1, o.AsArray[i]); - if not Result then - Exit; - end; - end else - Result := False; - end; - var - i: Integer; - v: TValue; - begin - TValue.Make(nil, TypeInfo, Value); - ArrayData := @GetTypeData(TypeInfo).ArrayData; - idx := 0; - if ArrayData.DimCount = 1 then - begin - if ObjectIsType(obj, stArray) and (obj.AsArray.Length = ArrayData.ElCount) then - begin - Result := True; - for i := 0 to ArrayData.ElCount - 1 do - begin - Result := FromJson(ArrayData.ElType^, obj.AsArray[i], v); - if not Result then - Exit; - Value.SetArrayElement(idx, v); - v := TValue.Empty; - inc(idx); - end; - end else - Result := False; - end else - Result := ProcessDim(1, obj); - end; - - procedure FromClassRef; - var - r: TRttiType; - begin - if ObjectIsType(obj, stString) then - begin - r := Context.FindType(obj.AsString); - if r <> nil then - begin - Value := TRttiInstanceType(r).MetaclassType; - Result := True; - end else - Result := False; - end else - Result := False; - end; - - procedure FromUnknown; - begin - case ObjectGetType(obj) of - stBoolean: - begin - Value := obj.AsBoolean; - Result := True; - end; - stDouble: - begin - Value := obj.AsDouble; - Result := True; - end; - stCurrency: - begin - Value := obj.AsCurrency; - Result := True; - end; - stInt: - begin - Value := obj.AsInteger; - Result := True; - end; - stString: - begin - Value := obj.AsString; - Result := True; - end - else - Value := nil; - Result := False; - end; - end; - - procedure FromInterface; - const soguid: TGuid = '{4B86A9E3-E094-4E5A-954A-69048B7B6327}'; - var - o: ISuperObject; - begin - if CompareMem(@GetTypeData(TypeInfo).Guid, @soguid, SizeOf(TGUID)) then - begin - if obj <> nil then - TValue.Make(@obj, TypeInfo, Value) else - begin - o := TSuperObject.Create(stNull); - TValue.Make(@o, TypeInfo, Value); - end; - Result := True; - end else - Result := False; - end; -var - Serial: TSerialFromJson; -begin - if TypeInfo <> nil then - begin - if not SerialFromJson.TryGetValue(TypeInfo, Serial) then - case TypeInfo.Kind of - tkChar: FromChar; - tkInt64: FromInt64; - tkEnumeration, tkInteger: FromInt(obj); - tkSet: fromSet; - tkFloat: FromFloat(obj); - tkString, tkLString, tkUString, tkWString: FromString; - tkClass: FromClass; - tkMethod: ; - tkWChar: FromWideChar; - tkRecord: FromRecord; - tkPointer: ; - tkInterface: FromInterface; - tkArray: FromArray; - tkDynArray: FromDynArray; - tkClassRef: FromClassRef; - else - FromUnknown - end else - begin - TValue.Make(nil, TypeInfo, Value); - Result := Serial(Self, obj, Value); - end; - end else - Result := False; -end; - -function TSuperRttiContext.ToJson(var value: TValue; const index: ISuperObject): ISuperObject; - procedure ToInt64; - begin - Result := TSuperObject.Create(SuperInt(Value.AsInt64)); - end; - - procedure ToChar; - begin - Result := TSuperObject.Create(string(Value.AsType)); - end; - - procedure ToInteger; - begin - Result := TSuperObject.Create(TValueData(Value).FAsSLong); - end; - - procedure ToFloat; - begin - case Value.TypeData.FloatType of - ftSingle: Result := TSuperObject.Create(TValueData(Value).FAsSingle); - ftDouble: Result := TSuperObject.Create(TValueData(Value).FAsDouble); - ftExtended: Result := TSuperObject.Create(TValueData(Value).FAsExtended); - ftComp: Result := TSuperObject.Create(TValueData(Value).FAsSInt64); - ftCurr: Result := TSuperObject.CreateCurrency(TValueData(Value).FAsCurr); - end; - end; - - procedure ToString; - begin - Result := TSuperObject.Create(string(Value.AsType)); - end; - - procedure ToClass; - var - o: ISuperObject; - f: TRttiField; - v: TValue; - begin - if TValueData(Value).FAsObject <> nil then - begin - o := index[IntToStr(Integer(Value.AsObject))]; - if o = nil then - begin - Result := TSuperObject.Create(stObject); - index[IntToStr(Integer(Value.AsObject))] := Result; - for f in Context.GetType(Value.AsObject.ClassType).GetFields do - if f.FieldType <> nil then - begin - v := f.GetValue(Value.AsObject); - Result.AsObject[GetFieldName(f)] := ToJson(v, index); - end - end else - Result := o; - end else - Result := nil; - end; - - procedure ToWChar; - begin - Result := TSuperObject.Create(string(Value.AsType)); - end; - - procedure ToVariant; - begin - Result := SO(Value.AsVariant); - end; - - procedure ToRecord; - var - f: TRttiField; - v: TValue; - begin - Result := TSuperObject.Create(stObject); - for f in Context.GetType(Value.TypeInfo).GetFields do - begin - v := f.GetValue(IValueData(TValueData(Value).FHeapData).GetReferenceToRawData); - Result.AsObject[GetFieldName(f)] := ToJson(v, index); - end; - end; - - procedure ToArray; - var - idx: Integer; - ArrayData: PArrayTypeData; - - procedure ProcessDim(dim: Byte; const o: ISuperObject); - var - dt: PTypeData; - i: Integer; - o2: ISuperObject; - v: TValue; - begin - if ArrayData.Dims[dim-1] = nil then Exit; - dt := GetTypeData(ArrayData.Dims[dim-1]^); - if Dim = ArrayData.DimCount then - for i := dt.MinValue to dt.MaxValue do - begin - v := Value.GetArrayElement(idx); - o.AsArray.Add(toJSon(v, index)); - inc(idx); - end - else - for i := dt.MinValue to dt.MaxValue do - begin - o2 := TSuperObject.Create(stArray); - o.AsArray.Add(o2); - ProcessDim(dim + 1, o2); - end; - end; - var - i: Integer; - v: TValue; - begin - Result := TSuperObject.Create(stArray); - ArrayData := @Value.TypeData.ArrayData; - idx := 0; - if ArrayData.DimCount = 1 then - for i := 0 to ArrayData.ElCount - 1 do - begin - v := Value.GetArrayElement(i); - Result.AsArray.Add(toJSon(v, index)) - end - else - ProcessDim(1, Result); - end; - - procedure ToDynArray; - var - i: Integer; - v: TValue; - begin - Result := TSuperObject.Create(stArray); - for i := 0 to Value.GetArrayLength - 1 do - begin - v := Value.GetArrayElement(i); - Result.AsArray.Add(toJSon(v, index)); - end; - end; - - procedure ToClassRef; - begin - if TValueData(Value).FAsClass <> nil then - Result := TSuperObject.Create(string( - TValueData(Value).FAsClass.UnitName + '.' + - TValueData(Value).FAsClass.ClassName)) else - Result := nil; - end; - - procedure ToInterface; - begin - if TValueData(Value).FHeapData <> nil then - TValueData(Value).FHeapData.QueryInterface(ISuperObject, Result) else - Result := nil; - end; - -var - Serial: TSerialToJson; -begin - if not SerialToJson.TryGetValue(value.TypeInfo, Serial) then - case Value.Kind of - tkInt64: ToInt64; - tkChar: ToChar; - tkSet, tkInteger, tkEnumeration: ToInteger; - tkFloat: ToFloat; - tkString, tkLString, tkUString, tkWString: ToString; - tkClass: ToClass; - tkWChar: ToWChar; - tkVariant: ToVariant; - tkRecord: ToRecord; - tkArray: ToArray; - tkDynArray: ToDynArray; - tkClassRef: ToClassRef; - tkInterface: ToInterface; - else - result := nil; - end else - Result := Serial(Self, value, index); -end; - -{ TSuperObjectHelper } - -constructor TSuperObjectHelper.FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); -var - v: TValue; - ctxowned: Boolean; -begin - if ctx = nil then - begin - ctx := TSuperRttiContext.Create; - ctxowned := True; - end else - ctxowned := False; - try - v := Self; - if not ctx.FromJson(v.TypeInfo, obj, v) then - raise Exception.Create('Invalid object'); - finally - if ctxowned then - ctx.Free; - end; -end; - -constructor TSuperObjectHelper.FromJson(const str: string; ctx: TSuperRttiContext = nil); -begin - FromJson(SO(str), ctx); -end; - -function TSuperObjectHelper.ToJson(ctx: TSuperRttiContext = nil): ISuperObject; -var - v: TValue; - ctxowned: boolean; -begin - if ctx = nil then - begin - ctx := TSuperRttiContext.Create; - ctxowned := True; - end else - ctxowned := False; - try - v := Self; - Result := ctx.ToJson(v, SO); - finally - if ctxowned then - ctx.Free; - end; -end; - -{$ENDIF} - -{$IFDEF DEBUG} -initialization - -finalization - Assert(debugcount = 0, 'Memory leak'); -{$ENDIF} -end. - diff --git a/addons/superobject/superxmlparser.pas b/addons/superobject/superxmlparser.pas deleted file mode 100644 index 822db2c..0000000 --- a/addons/superobject/superxmlparser.pas +++ /dev/null @@ -1,1391 +0,0 @@ -unit superxmlparser; -{$IFDEF FPC} - {$MODE OBJFPC}{$H+} -{$ENDIF} - -interface - -uses superobject, classes; - - -type - TOnProcessingInstruction = procedure(const PI, PIParent: ISuperObject); - -function XMLParseString(const data: SOString; pack: Boolean = false; onpi: TOnProcessingInstruction = nil): ISuperObject; -function XMLParseStream(stream: TStream; pack: Boolean = false; onpi: TOnProcessingInstruction = nil): ISuperObject; -function XMLParseFile(const FileName: string; pack: Boolean = false; onpi: TOnProcessingInstruction = nil): ISuperObject; - -const - xmlname = '#name'; - xmlattributes = '#attributes'; - xmlchildren = '#children'; - - dtdname = '#name'; - dtdPubidLiteral = '#pubidliteral'; - dtdSystemLiteral = '#systemliteral'; - - -implementation -uses sysutils {$IFNDEF UNIX}, windows{$ENDIF}; - -const - XML_SPACE : PSOChar = #32; -// XML_ARL: PSOChar = '['; - XML_ARR: PSOChar = ']'; - XML_BIG: PSOChar = '>'; - XML_LOW: PSOChar = '<'; - XML_AMP: PSOChar = '&'; - XML_SQU: PSOChar = ''''; - XML_DQU: PSOChar = '"'; - -type - TSuperXMLState = ( - xsStart, // | - xsEatSpaces, // - xsElement, // <| - xsElementName, // <[a..z]| - xsAttributes, // ..<| - xsCloseElementName, // ..| - xsElementString, // |azer - xsElementComment, // - xsElementPI, // - xsElementCDATA, // - xsEscape, // &| - xsEscape_lt, // &l|t; - xsEscape_gt, // &g|t; - xsEscape_amp, // &a|mp; - xsEscape_apos, // &a|pos; - xsEscape_quot, // &q|uot; - xsEscape_char, // &#|; - xsEscape_char_num, // |123456; - xsEscape_char_hex, // &#x|000FFff; - xsEnd); - - TSuperXMLError = (xeSuccess, xeContinue, xeProcessInst, xeError); - TSuperXMLElementClass = (xcNone, xcElement, xcComment, xcString, xcCdata, xcDocType, xcProcessInst); - TSuperXMLEncoding = ({$IFNDEF UNIX}xnANSI,{$ENDIF} xnUTF8, xnUnicode); - - PSuperXMLStack = ^TSuperXMLStack; - TSuperXMLStack = record - state: TSuperXMLState; - savedstate: TSuperXMLState; - prev: PSuperXMLStack; - next: PSuperXMLStack; - clazz: TSuperXMLElementClass; - obj: ISuperObject; - end; - - TSuperXMLParser = class - private - FStack: PSuperXMLStack; - FDocType: ISuperObject; - FError: TSuperXMLError; - FStr: TSuperWriterString; - FValue: TSuperWriterString; - FPosition: Integer; - FAChar: SOChar; - FPack: Boolean; - procedure StackUp; - procedure StackDown; - procedure Reset; - function ParseBuffer(data: PSOChar; var PI, PIParent: ISuperObject; len: Integer = -1): Integer; - public - constructor Create(pack: Boolean); - destructor Destroy; override; - end; - -{ TXMLContext } - -constructor TSuperXMLParser.Create(pack: Boolean); -begin - FDocType := nil; - FStr := TSuperWriterString.Create; - FValue := TSuperWriterString.Create; - StackUp; - FError := xeSuccess; - FPack := pack; -end; - -destructor TSuperXMLParser.Destroy; -begin - while FStack <> nil do - StackDown; - FStr.Free; - FValue.Free; -end; - -procedure TSuperXMLParser.Reset; -begin - while FStack <> nil do - StackDown; - StackUp; - FError := xeSuccess; -end; - -function TSuperXMLParser.ParseBuffer(data: PSOChar; var PI, PIParent: ISuperObject; len: integer): Integer; -const - spaces = [#32,#9,#10,#13]; - alphas = ['a'..'z', 'A'..'Z', '_', ':', #161..#255]; - nums = ['0'..'9', '.', '-']; - hex = nums + ['a'..'f','A'..'F']; - alphanums = alphas + nums; - publitteral = [#32, #13, #10, 'a'..'z', 'A'..'Z', '0'..'9', '-', '''', '"', '(', ')', - '+', ',', '.', '/', ':', '=', '?', ';', '!', '*', '#', '@', '$', '_', '%']; - - function hexdigit(const x: SOChar): byte; - begin - if x <= '9' then - Result := byte(x) - byte('0') else - Result := (byte(x) and 7) + 9; - end; - - procedure putchildrenstr; - var - anobject: ISuperObject; - begin - anobject := FStack^.obj.AsObject[xmlchildren]; - if anobject = nil then - begin - anobject := TSuperObject.Create(stArray); - FStack^.obj.AsObject[xmlchildren] := anobject; - end; - anobject.AsArray.Add(TSuperObject.Create(FValue.Data)); - end; - - procedure AddProperty(const parent, value: ISuperObject; const name: SOString); - var - anobject: ISuperObject; - arr: ISuperObject; - begin - anobject := parent.AsObject[name]; - if anobject = nil then - parent.AsObject[name] := value else - begin - if (anobject.DataType = stArray) then - anobject.AsArray.Add(value) else - begin - arr := TSuperObject.Create(stArray); - arr.AsArray.Add(anobject); - arr.AsArray.Add(value); - parent.AsObject[name] := arr; - end; - end; - end; - - procedure packend; - var - anobject, anobject2: ISuperObject; - n: Integer; - begin - anobject := FStack^.obj.AsObject[xmlchildren]; - if (anobject <> nil) and (anobject.AsArray.Length = 1) and (anobject.AsArray[0].DataType = stString) then - begin - if FStack^.obj.AsObject.count = 2 then // name + children - begin - if FStack^.prev <> nil then - AddProperty(FStack^.prev^.obj, anobject.AsArray[0], FStack^.obj.AsObject.S[xmlname]) else - begin - AddProperty(FStack^.obj, anobject.AsArray[0], '#text'); - FStack^.obj.AsObject.Delete(xmlchildren); - end; - end - else - begin - AddProperty(FStack^.obj, anobject.AsArray[0], FStack^.obj.AsObject.S[xmlname]); - FStack^.obj.AsObject.Delete(xmlchildren); - if FStack^.prev <> nil then - AddProperty(FStack^.prev^.obj, FStack^.obj, FStack^.obj.AsObject.S[xmlname]) else - FStack^.obj.AsObject.Delete(xmlchildren); - FStack^.obj.AsObject.Delete(xmlname); - end; - end else - begin - if (anobject <> nil) then - begin - for n := 0 to anobject.AsArray.Length - 1 do - begin - anobject2 := anobject.AsArray[n]; - if ObjectIsType(anobject2, stObject) then - begin - AddProperty(FStack^.obj, anobject2, anobject2.AsObject.S[xmlname]); - anobject2.AsObject.Delete(xmlname); - end else - AddProperty(FStack^.obj, anobject2, '#text'); - end; - FStack^.obj.Delete(xmlchildren); - end; - if FStack^.prev <> nil then - AddProperty(FStack^.prev^.obj, FStack^.obj, FStack^.obj.AsObject.S[xmlname]); - FStack^.obj.Delete(xmlname); - end; - end; - -var - c: SOChar; - read: Integer; - p: PSOChar; - anobject: ISuperObject; -label - redo, err; -begin - p := data; - read := 0; - //Result := 0; - repeat - - if (read = len) then - begin - if (FStack^.prev = nil) and ((FStack^.state = xsEnd) or ((FStack^.state = xsEatSpaces) and (FStack^.savedstate = xsEnd))) then - begin - if FPack then - packend; - FError := xeSuccess; - end else - FError := xeContinue; - Result := read; - exit; - end; - c := p^; - redo: - case FStack^.state of - - xsEatSpaces: - if {$IFDEF UNICODE}(c < #256) and {$ENDIF} (AnsiChar(c) in spaces) then {nop} else - begin - FStack^.state := FStack^.savedstate; - goto redo; - end; - - xsStart: - case c of - '<': FStack^.state := xsElement; - else - goto err; - end; - xsElement: - begin - case c of - '?': - begin - FStack^.savedstate := xsStart; - FStack^.state := xsEatSpaces; - StackUp; - FStr.Reset; - FStack^.state := xsElementPI; - FStack^.clazz := xcProcessInst; - end; - '!': - begin - FPosition := 0; - FStack^.state := xsElementComment; - FStack^.clazz := xcComment; - end; - else - if ((c < #256) and (AnsiChar(c) in alphas)) or (c >= #256) then - begin - FStr.Reset; - FStack^.state := xsElementName; - FStack^.clazz := xcElement; - goto redo; - end else - goto err; - end; - end; - xsElementPI: - begin - if ((c < #256) and (AnsiChar(c) in alphanums)) or (c >= #256) then - FStr.Append(@c, 1) else - begin - FStack^.obj := TSuperObject.Create(stObject); - FStack^.obj.AsObject.S[xmlname] := FStr.Data; - FStack^.state := xsEatSpaces; - if FStr.Data = 'xml' then - FStack^.savedstate := xsAttributes else - begin - FValue.Reset; - FStack^.savedstate := xsElementDataPI; - end; - goto redo; - end; - end; - xsElementDataPI: - begin - case c of - '?': - begin - FStack^.obj.AsObject.S['data'] := FValue.Data; - FStack^.state := xsCloseElementPI; - end; - else - FValue.Append(@c, 1); - end; - end; - xsCloseElementPI: - begin - if (c <> '>') then goto err; - PI := FStack^.obj; - StackDown; - PIParent := FStack^.obj; - FError := xeProcessInst; - Result := read + 1; - Exit; - end; - xsElementName: - begin - if ((c < #256) and (AnsiChar(c) in alphanums)) or (c >= #256) then - FStr.Append(@c, 1) else - begin - FStack^.obj := TSuperObject.Create(stObject); - FStack^.obj.AsObject.S[xmlname] := FStr.Data; - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsAttributes; - goto redo; - end; - end; - xsChildren: - begin - case c of - '<': FStack^.state := xsTryCloseElement; - else - FValue.Reset; - FStack^.state := xsElementString; - FStack^.clazz := xcString; - goto redo; - end; - end; - xsCloseEmptyElement: - begin - case c of - '>': - begin - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsEnd; - end - else - goto err; - end; - end; - xsTryCloseElement: - begin - case c of - '/': begin - FStack^.state := xsCloseElementName; - FPosition := 0; - FStr.Reset; - FStr.Append(PSoChar(FStack^.obj.AsObject.S[xmlname])); - end; - '!': begin - FPosition := 0; - FStack^.state := xsElementComment; - FStack^.clazz := xcComment; - end; - '?': begin - FStack^.savedstate := xsChildren; - FStack^.state := xsEatSpaces; - StackUp; - FStr.Reset; - FStack^.state := xsElementPI; - FStack^.clazz := xcProcessInst; - end - else - FStack^.state := xsChildren; - StackUp; - if ((c < #256) and (AnsiChar(c) in alphas)) or (c >= #256) then - begin - FStr.Reset; - FStack^.state := xsElementName; - FStack^.clazz := xcElement; - goto redo; - end else - goto err; - end; - end; - xsCloseElementName: - begin - if FStr.Position = FPosition then - begin - FStack^.savedstate := xsCloseEmptyElement; - FStack^.state := xsEatSpaces; - goto redo; - end else - begin - if (c <> FStr.Data[FPosition]) then goto err; - inc(FPosition); - end; - end; - xsAttributes: - begin - case c of - '?': begin - if FStack^.clazz <> xcProcessInst then goto err; - FStack^.state := xsCloseElementPI; - end; - '/': begin - FStack^.state := xsCloseEmptyElement; - end; - '>': begin - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsChildren; - end - else - if ((c < #256) and (AnsiChar(c) in alphas)) or (c >= #256) then - begin - FStr.Reset; - FStr.Append(@c, 1); - FStack^.state := xsAttributeName; - end else - goto err; - end; - end; - xsAttributeName: - begin - if ((c < #256) and (AnsiChar(c) in alphanums)) or (c >= #256) then - FStr.Append(@c, 1) else - begin - // no duplicate attribute - if FPack then - begin - if FStack^.obj.AsObject[FStr.Data] <> nil then - goto err; - end else - begin - anobject := FStack^.obj.AsObject[xmlattributes]; - if (anobject <> nil) and (anobject.AsObject[FStr.Data] <> nil) then - goto err; - end; - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsEqual; - goto redo; - end; - end; - xsEqual: - begin - if c <> '=' then goto err; - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsAttributeValue; - FValue.Reset; - FPosition := 0; - FAChar := #0; - end; - xsAttributeValue: - begin - if FAChar <> #0 then - begin - if (c = FAChar) then - begin - if FPack then - begin - FStack^.obj.AsObject[FStr.Data] := TSuperObject.Create(Fvalue.Data); - end else - begin - anobject := FStack^.obj.AsObject[xmlattributes]; - if anobject = nil then - begin - anobject := TSuperObject.Create(stObject); - FStack^.obj.AsObject[xmlattributes] := anobject; - end; - anobject.AsObject[FStr.Data] := TSuperObject.Create(Fvalue.Data); - end; - FStack^.savedstate := xsAttributes; - FStack^.state := xsEatSpaces; - end else - case c of - '&': - begin - FStack^.state := xsEscape; - FStack^.savedstate := xsAttributeValue; - end; - #13, #10: - begin - FValue.TrimRight; - FValue.Append(XML_SPACE, 1); - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsAttributeValue; - end; - else - FValue.Append(@c, 1); - end; - - end else - begin - if (c < #256) and (AnsiChar(c) in ['"', '''']) then - begin - FAChar := c; - inc(FPosition); - - end else - goto err; - end; - end; - xsElementString: - begin - case c of - '<': begin - FValue.TrimRight; - putchildrenstr; - FStack^.state := xsTryCloseElement; - end; - #13, #10: - begin - FValue.TrimRight; - FValue.Append(XML_SPACE, 1); - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsElementString; - end; - '&': - begin - FStack^.state := xsEscape; - FStack^.savedstate := xsElementString; - end - else - FValue.Append(@c, 1); - end; - end; - xsElementComment: - begin - case FPosition of - 0: - begin - case c of - '-': Inc(FPosition); - '[': - begin - FValue.Reset; - FPosition := 0; - FStack^.state := xsElementCDATA; - FStack^.clazz := xcCdata; - end; - 'D': - begin - if (FStack^.prev = nil) and (FDocType = nil) then - begin - FStack^.state := xsElementDocType; - FPosition := 0; - FStack^.clazz := xcDocType; - end else - goto err; - end; - else - goto err; - end; - end; - 1: - begin - if c <> '-' then goto err; - Inc(FPosition); - end; - else - if c = '-' then - begin - FPosition := 0; - FStack^.state := xsCloseElementComment; - end; - end; - end; - xsCloseElementComment: - begin - case FPosition of - 0: begin - if c <> '-' then - begin - FPosition := 2; - FStack^.state := xsElementComment; - end else - Inc(FPosition); - end; - 1: begin - if c <> '>' then goto err; - FStack^.state := xsEatSpaces; - if FStack^.obj <> nil then - FStack^.savedstate := xsChildren else - FStack^.savedstate := xsStart; - end; - end; - end; - xsElementCDATA: - begin - case FPosition of - 0: if (c = 'C') then inc(FPosition) else goto err; - 1: if (c = 'D') then inc(FPosition) else goto err; - 2: if (c = 'A') then inc(FPosition) else goto err; - 3: if (c = 'T') then inc(FPosition) else goto err; - 4: if (c = 'A') then inc(FPosition) else goto err; - 5: if (c = '[') then inc(FPosition) else goto err; - else - case c of - ']': begin - FPosition := 0; - FStack^.state := xsClodeElementCDATA; - end; - else - FValue.Append(@c, 1); - end; - end; - end; - xsClodeElementCDATA: - begin - case FPosition of - 0: if (c = ']') then - inc(FPosition) else - begin - FValue.Append(XML_ARR, 1); - FValue.Append(@c, 1); - FPosition := 6; - FStack^.state := xsElementCDATA; - end; - 1: case c of - '>': - begin - putchildrenstr; - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsChildren; - end; - ']': - begin - FValue.Append(@c, 1); - end; - else - FValue.Append(@c, 1); - FStack^.state := xsElementCDATA; - end; - end; - end; - xsElementDocType: - begin - case FPosition of - 0: if (c = 'O') then inc(FPosition) else goto err; - 1: if (c = 'C') then inc(FPosition) else goto err; - 2: if (c = 'T') then inc(FPosition) else goto err; - 3: if (c = 'Y') then inc(FPosition) else goto err; - 4: if (c = 'P') then inc(FPosition) else goto err; - 5: if (c = 'E') then inc(FPosition) else goto err; - else - if (c < #256) and (AnsiChar(c) in spaces) then - begin - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsElementDocTypeName; - FStr.Reset; - end else - goto err; - end; - end; - xsElementDocTypeName: - begin - case FStr.Position of - 0: begin - case c of - '>': - begin - FStack^.state := xsEatSpaces; - FStack^.state := xsStart; - FStack^.clazz := xcNone; - end - else - if ((c < #256) and (AnsiChar(c) in alphas)) or (c > #256) then - FStr.Append(@c, 1) else - goto err; - end; - end; - else - if ((c < #256) and (AnsiChar(c) in alphanums)) or (c > #256) then - FStr.Append(@c, 1) else - if (c < #256) and (AnsiChar(c) in spaces) then - begin - FDocType := TSuperObject.Create(stObject); - FDocType.AsObject.S[xmlname] := FStr.Data; - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsElementDocTypeExternId; - end else - goto err; - end; - end; - xsElementDocTypeExternId: - begin - case c of - 'P': - begin - FPosition := 0; - FStack^.state := xsElementDocTypeExternIdPublic; - end; - 'S': - begin - FPosition := 0; - FStack^.state := xsElementDocTypeExternIdSystem; - end; - '[': - begin - FStack^.savedstate := xsElementDocTypeIntSubset; - FStack^.state := xsEatSpaces; - end; - '>': - begin - FStack^.savedstate := xsStart; - FStack^.state := xsEatSpaces - end - else - goto err; - end; - end; - xsElementDocTypeExternIdPublic: - begin - case FPosition of - 0: if (c = 'U') then inc(FPosition) else goto err; - 1: if (c = 'B') then inc(FPosition) else goto err; - 2: if (c = 'L') then inc(FPosition) else goto err; - 3: if (c = 'I') then inc(FPosition) else goto err; - 4: if (c = 'C') then inc(FPosition) else goto err; - else - if (c < #256) and (AnsiChar(c) in spaces) then - begin - FStr.Reset; - FPosition := 0; - FStack^.savedstate := xsElementDocTypePubIdLiteral; - FStack^.state := xsEatSpaces; - end else - goto err; - end; - end; - - xsElementDocTypeExternIdSystem: - begin - case FPosition of - 0: if (c = 'Y') then inc(FPosition) else goto err; - 1: if (c = 'S') then inc(FPosition) else goto err; - 2: if (c = 'T') then inc(FPosition) else goto err; - 3: if (c = 'E') then inc(FPosition) else goto err; - 4: if (c = 'M') then inc(FPosition) else goto err; - else - if (c < #256) and (AnsiChar(c) in spaces) then - begin - FStr.Reset; - FPosition := 0; - FStack^.savedstate := xsElementDocTypeSystemLiteral; - FStack^.state := xsEatSpaces; - end else - goto err; - end; - end; - xsElementDocTypePubIdLiteral: - begin - if FPosition = 0 then - case c of - '"', '''': - begin - FAChar := c; - FPosition := 1; - end - else - goto err; - end else - if c = FAChar then - begin - FDocType.AsObject.S[dtdPubidLiteral] := FStr.Data; - FStr.Reset; - FPosition := 0; - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsElementDocTypeSystemLiteral; - end else - if (c < #256) and (AnsiChar(c) in publitteral) then - FStr.Append(@c, 1); - end; - xsElementDocTypeSystemLiteral: - begin - if FPosition = 0 then - case c of - '"', '''': - begin - FAChar := c; - FPosition := 1; - end - else - goto err; - end else - if c = FAChar then - begin - FDocType.AsObject.S[dtdSystemLiteral] := FStr.Data; - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsElementDocTypeTryIntSubset; - end else - FStr.Append(@c, 1); - end; - - xsElementDocTypeTryIntSubset: - begin - case c of - '>': - begin - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsStart; - FStack^.clazz := xcNone; - end; - '[': - begin - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsElementDocTypeIntSubset; - end; - end; - end; - xsElementDocTypeIntSubset: - begin - case c of - ']': - begin - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsElementDocTypeTryClose; - end; - end; - end; - xsElementDocTypeTryClose: - begin - if c = '>' then - begin - FStack^.state := xsEatSpaces; - FStack^.savedstate := xsStart; - FStack^.clazz := xcNone; - end else - goto err; - end; - xsEscape: - begin - FPosition := 0; - case c of - 'l': FStack^.state := xsEscape_lt; - 'g': FStack^.state := xsEscape_gt; - 'a': FStack^.state := xsEscape_amp; - 'q': FStack^.state := xsEscape_quot; - '#': FStack^.state := xsEscape_char; - else - goto err; - end; - end; - xsEscape_lt: - begin - case FPosition of - 0: begin - if c <> 't' then goto err; - Inc(FPosition); - end; - 1: begin - if c <> ';' then goto err; - FValue.Append(XML_LOW, 1); - FStack^.state := FStack^.savedstate; - end; - end; - end; - xsEscape_gt: - begin - case FPosition of - 0: begin - if c <> 't' then goto err; - Inc(FPosition); - end; - 1: begin - if c <> ';' then goto err; - FValue.Append(XML_BIG, 1); - FStack^.state := FStack^.savedstate; - end; - end; - end; - xsEscape_amp: - begin - case FPosition of - 0: begin - case c of - 'm': Inc(FPosition); - 'p': begin - FStack^.state := xsEscape_apos; - Inc(FPosition); - end; - else - goto err; - end; - end; - 1: begin - if c <> 'p' then goto err; - Inc(FPosition); - end; - 2: begin - if c <> ';' then goto err; - FValue.Append(XML_AMP, 1); - FStack^.state := FStack^.savedstate; - end; - end; - end; - xsEscape_apos: - begin - case FPosition of - 0: begin - case c of - 'p': Inc(FPosition); - 'm': begin - FStack^.state := xsEscape_amp; - Inc(FPosition); - end; - else - goto err; - end; - end; - 1: begin - if c <> 'o' then goto err; - Inc(FPosition); - end; - 2: begin - if c <> 's' then goto err; - Inc(FPosition); - end; - 3: begin - if c <> ';' then goto err; - FValue.Append(XML_SQU, 1); - FStack^.state := FStack^.savedstate; - end; - end; - end; - xsEscape_quot: - begin - case FPosition of - 0: begin - if c <> 'u' then goto err; - Inc(FPosition); - end; - 1: begin - if c <> 'o' then goto err; - Inc(FPosition); - end; - 2: begin - if c <> 't' then goto err; - Inc(FPosition); - end; - 3: begin - if c <> ';' then goto err; - FValue.Append(XML_DQU, 1); - FStack^.state := FStack^.savedstate; - end; - end; - end; - xsEscape_char: - begin - if (SOIChar(c) >= 256) then goto err; - case AnsiChar(c) of - '0'..'9': - begin - FPosition := SOIChar(c) - 48; - FStack^.state := xsEscape_char_num; - end; - 'x': - begin - FStack^.state := xsEscape_char_hex; - end - else - goto err; - end; - end; - xsEscape_char_num: - begin - if (SOIChar(c) >= 256) then goto err; - case AnsiChar(c) of - '0'..'9':FPosition := (FPosition * 10) + (SOIChar(c) - 48); - ';': begin - FValue.Append(@FPosition, 1); - FStack^.state := FStack^.savedstate; - end; - else - goto err; - end; - end; - xsEscape_char_hex: - begin - if (c >= #256) then goto err; - if (AnsiChar(c) in hex) then - begin - FPosition := (FPosition * 16) + SOIChar(hexdigit(c)); - end else - if c = ';' then - begin - FValue.Append(@FPosition, 1); - FStack^.state := FStack^.savedstate; - end else - goto err; - end; - xsEnd: - begin - if(FStack^.prev = nil) then Break; - if FStack^.obj <> nil then - begin - if FPack then - packend else - begin - anobject := FStack^.prev^.obj.AsObject[xmlchildren]; - if anobject = nil then - begin - anobject := TSuperObject.Create(stArray); - FStack^.prev^.obj.AsObject[xmlchildren] := anobject; - end; - anobject.AsArray.Add(FStack^.obj); - end; - end; - StackDown; - goto redo; - end; - end; - inc(p); - inc(read); - until (c = #0); - - if FStack^.state = xsEnd then - begin - if FPack then - packend; - FError := xeSuccess; - end else - FError := xeError; - Result := read; - exit; -err: - FError := xeError; - Result := read; -end; - -function XMLParseFile(const FileName: string; pack: Boolean; onpi: TOnProcessingInstruction): ISuperObject; -var - stream: TFileStream; -begin - stream := TFileStream.Create(FileName, fmOpenRead, fmShareDenyWrite); - try - Result := XMLParseStream(stream, pack, onpi); - finally - stream.Free; - end; -end; - -procedure TSuperXMLParser.StackDown; -var - prev: PSuperXMLStack; -begin - if FStack <> nil then - begin - prev := FStack^.prev; - FStack^.obj := nil; - FreeMem(FStack); - FStack := prev; - if FStack <> nil then - FStack^.next := nil; - end; -end; - -procedure TSuperXMLParser.StackUp; -var - st: PSuperXMLStack; -begin -{$IFDEF FPC} - st := nil; -{$ENDIF} - GetMem(st, SizeOf(st^)); - FillChar(st^, SizeOf(st^), 0); - st^.state := xsEatSpaces; - st^.savedstate := xsStart; - st^.prev := FStack; - if st^.prev <> nil then - st^.prev^.next := st; - st^.next := nil; - st^.obj := nil; - FStack := st; -end; - -function utf8toucs2(src: PAnsiChar; srclen: Integer; dst: PWideChar; unused: PInteger): Integer; -var - ch: Byte; - ret: Word; - min: Cardinal; - rem, com: integer; -label - redo; -begin - Result := 0; - ret := 0; - rem := 0; - min := 0; - - if unused <> nil then - unused^ := 0; - - if(src = nil) or (srclen = 0) then - begin - dst^ := #0; - Exit; - end; - - while srclen > 0 do - begin - ch := Byte(src^); - inc(src); - dec(srclen); - -redo: - if (ch and $80) = 0 then - begin - dst^ := WideChar(ch); - inc(Result); - end else - begin - if((ch and $E0) = $C0) then - begin - min := $80; - rem := 1; - ret := ch and $1F; - end else - if((ch and $F0) = $E0) then - begin - min := $800; - rem := 2; - ret := ch and $0F; - end else - // too large utf8 bloc - // ignore and continue - continue; - - com := rem; - while(rem <> 0) do - begin - dec(rem); - if(srclen = 0) then - begin - if unused <> nil then - unused^ := com; - Exit; - end; - ch := Byte(src^); - inc(src); - dec(srclen); - if((ch and $C0) = $80) then - begin - ret := ret shl 6; - ret := ret or (ch and $3F); - end else - begin - // unterminated utf8 bloc :/ - // try next one - goto redo; - end; - end; - - if (ch >= min) then - begin - dst^ := WideChar(ret); - inc(Result); - end else - begin - // too small utf8 bloc - // ignore and continue - Continue; - end; - - end; - inc(dst); - end; -end; - -function XMLParseStream(stream: TStream; pack: Boolean; onpi: TOnProcessingInstruction): ISuperObject; -const - CP_UTF8 = 65001; -var - wbuffer: array[0..1023] of SOChar; - abuffer: array[0..1023] of AnsiChar; - len, read, cursor: Integer; - PI, PIParent: ISuperObject; - bom: array[0..2] of byte; - - encoding: TSuperXMLEncoding; - encodingstr: string; - cp: Integer; - ecp: ISuperObject; - - function getbuffer: Integer; - var - size, unusued: Integer; - begin - - case encoding of -{$IFNDEF UNIX} - xnANSI: - begin - size := stream.Read(abuffer, sizeof(abuffer)); - result := MultiByteToWideChar(cp, 0, @abuffer, size, @wbuffer, sizeof(wbuffer)); - end; -{$ENDIF} - xnUTF8: - begin - size := stream.Read(abuffer, sizeof(abuffer)); - result := utf8toucs2(@abuffer, size, @wbuffer, @unusued); - if unusued > 0 then - stream.Seek(-unusued, soFromCurrent); - end; - xnUnicode: Result := stream.Read(wbuffer, sizeof(wbuffer)) div sizeof(SOChar); - else - Result := 0; - end; - end; -label - redo, retry; -begin - // init knowned code pages - ecp := so('{iso-8859-1: 28591,'+ - 'iso-8859-2: 28592,'+ - 'iso-8859-3: 28593,'+ - 'iso-8859-4: 28594,'+ - 'iso-8859-5: 28595,'+ - 'iso-8859-6: 28596,'+ - 'iso-8859-7: 28597,'+ - 'iso-8859-8: 28598,'+ - 'iso-8859-9: 28599,'+ - 'iso 8859-15: 28605,'+ - 'iso-2022-jp: 50220,'+ - 'shift_jis: 932,'+ - 'euc-jp: 20932,'+ - 'ascii: 20127,'+ - 'windows-1251: 1251,'+ - 'windows-1252: 1252}'); - - // detect bom - stream.Seek(0, soFromBeginning); - len := stream.Read(bom, sizeof(bom)); - if (len >= 2) and (bom[0] = $FF) and (bom[1] = $FE) then - begin - encoding := xnUnicode; - stream.Seek(2, soFromBeginning); - end else - if (len = 3) and (bom[0] = $EF) and (bom[1] = $BB) and (bom[2] = $BF) then - begin - encoding := xnUTF8; - cp := CP_UTF8; - end else - begin - encoding := xnUTF8; - cp := 0; - stream.Seek(0, soFromBeginning); - end; - - with TSuperXMLParser.Create(pack) do - try - len := getbuffer; - while len > 0 do - begin -retry: - read := ParseBuffer(@wbuffer, PI, PIParent, len); - cursor := 0; -redo: - case FError of - xeContinue: len := getbuffer; - xeSuccess, xeError: Break; - xeProcessInst: - begin - if (PIParent = nil) and (PI.AsObject.S[xmlname] = 'xml') then - begin - if pack then - encodingstr := LowerCase(trim(PI.S['encoding'])) else - encodingstr := LowerCase(trim(PI.S[xmlattributes + '.encoding'])); - if (encodingstr <> '') then - case encoding of - xnUTF8: if(cp = CP_UTF8) then - begin - if (encodingstr <> 'utf-8') then - begin - FError := xeError; - Break; - end; - end else - begin - cp := ecp.I[encodingstr]; - if cp > 0 then - begin -{$IFNDEF UNIX} - encoding := xnANSI; - Reset; - stream.Seek(0, soFromBeginning); - len := getbuffer; - goto retry; -{$ELSE} - raise Exception.Create('charset not implemented'); -{$ENDIF} - end; - end; - xnUnicode: - if (encodingstr <> 'utf-16') and (encodingstr <> 'unicode') then - begin - FError := xeError; - Break; - end; - end; - end else - if Assigned(onpi) then - onpi(PI, PIParent); - - inc(cursor, read); - if cursor >= len then - begin - len := getbuffer; - continue; - end; - read := ParseBuffer(@wbuffer[cursor], PI, PIParent, len - cursor); - goto redo; - end; - end; - end; - if FError = xeSuccess then - Result := FStack^.obj else - Result := nil; - finally - Free; - end; -end; - -function XMLParseString(const data: SOString; pack: Boolean; onpi: TOnProcessingInstruction): ISuperObject; -var - PI, PIParent: ISuperObject; - cursor, read: Integer; -label - redo; -begin - with TSuperXMLParser.Create(pack) do - try - cursor := 0; - read := ParseBuffer(PSOChar(data), PI, PIParent); -redo: - case FError of - xeSuccess: Result := FStack^.obj; - xeError: Result := nil; - xeProcessInst: - begin - if Assigned(onpi) then - onpi(PI, PIParent); - inc(cursor, read); - read := ParseBuffer(@data[cursor+1], PI, PIParent); - goto redo; - end; - end; - finally - Free; - end; -end; - -end. diff --git a/addons/synapse/asn1util.pas b/addons/synapse/asn1util.pas deleted file mode 100644 index e0419c7..0000000 --- a/addons/synapse/asn1util.pas +++ /dev/null @@ -1,510 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.004.004 | -|==============================================================================| -| Content: support for ASN.1 BER coding and decoding | -|==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2003 | -| Portions created by Hernan Sanchez are Copyright (c) 2000. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Hernan Sanchez (hernan.sanchez@iname.com) | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{: @abstract(Utilities for handling ASN.1 BER encoding) -By this unit you can parse ASN.1 BER encoded data to elements or build back any - elements to ASN.1 BER encoded buffer. You can dump ASN.1 BER encoded data to - human readable form for easy debugging, too. - -Supported element types are: ASN1_BOOL, ASN1_INT, ASN1_OCTSTR, ASN1_NULL, - ASN1_OBJID, ASN1_ENUM, ASN1_SEQ, ASN1_SETOF, ASN1_IPADDR, ASN1_COUNTER, - ASN1_GAUGE, ASN1_TIMETICKS, ASN1_OPAQUE - -For sample of using, look to @link(TSnmpSend) or @link(TLdapSend)class. -} - -{$Q-} -{$H+} -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit asn1util; - -interface - -uses - SysUtils, Classes, synautil; - -const - ASN1_BOOL = $01; - ASN1_INT = $02; - ASN1_OCTSTR = $04; - ASN1_NULL = $05; - ASN1_OBJID = $06; - ASN1_ENUM = $0a; - ASN1_SEQ = $30; - ASN1_SETOF = $31; - ASN1_IPADDR = $40; - ASN1_COUNTER = $41; - ASN1_GAUGE = $42; - ASN1_TIMETICKS = $43; - ASN1_OPAQUE = $44; - -{:Encodes OID item to binary form.} -function ASNEncOIDItem(Value: Integer): AnsiString; - -{:Decodes an OID item of the next element in the "Buffer" from the "Start" - position.} -function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer; - -{:Encodes the length of ASN.1 element to binary.} -function ASNEncLen(Len: Integer): AnsiString; - -{:Decodes length of next element in "Buffer" from the "Start" position.} -function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer; - -{:Encodes a signed integer to ASN.1 binary} -function ASNEncInt(Value: Integer): AnsiString; - -{:Encodes unsigned integer into ASN.1 binary} -function ASNEncUInt(Value: Integer): AnsiString; - -{:Encodes ASN.1 object to binary form.} -function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString; - -{:Beginning with the "Start" position, decode the ASN.1 item of the next element - in "Buffer". Type of item is stored in "ValueType."} -function ASNItem(var Start: Integer; const Buffer: AnsiString; - var ValueType: Integer): AnsiString; - -{:Encodes an MIB OID string to binary form.} -function MibToId(Mib: String): AnsiString; - -{:Decodes MIB OID from binary form to string form.} -function IdToMib(const Id: AnsiString): String; - -{:Encodes an one number from MIB OID to binary form. (used internally from -@link(MibToId))} -function IntMibToStr(const Value: AnsiString): AnsiString; - -{:Convert ASN.1 BER encoded buffer to human readable form for debugging.} -function ASNdump(const Value: AnsiString): AnsiString; - -implementation - -{==============================================================================} -function ASNEncOIDItem(Value: Integer): AnsiString; -var - x, xm: Integer; - b: Boolean; -begin - x := Value; - b := False; - Result := ''; - repeat - xm := x mod 128; - x := x div 128; - if b then - xm := xm or $80; - if x > 0 then - b := True; - Result := AnsiChar(xm) + Result; - until x = 0; -end; - -{==============================================================================} -function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer; -var - x: Integer; - b: Boolean; -begin - Result := 0; - repeat - Result := Result * 128; - x := Ord(Buffer[Start]); - Inc(Start); - b := x > $7F; - x := x and $7F; - Result := Result + x; - until not b; -end; - -{==============================================================================} -function ASNEncLen(Len: Integer): AnsiString; -var - x, y: Integer; -begin - if Len < $80 then - Result := AnsiChar(Len) - else - begin - x := Len; - Result := ''; - repeat - y := x mod 256; - x := x div 256; - Result := AnsiChar(y) + Result; - until x = 0; - y := Length(Result); - y := y or $80; - Result := AnsiChar(y) + Result; - end; -end; - -{==============================================================================} -function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer; -var - x, n: Integer; -begin - x := Ord(Buffer[Start]); - Inc(Start); - if x < $80 then - Result := x - else - begin - Result := 0; - x := x and $7F; - for n := 1 to x do - begin - Result := Result * 256; - x := Ord(Buffer[Start]); - Inc(Start); - Result := Result + x; - end; - end; -end; - -{==============================================================================} -function ASNEncInt(Value: Integer): AnsiString; -var - x, y: Cardinal; - neg: Boolean; -begin - neg := Value < 0; - x := Abs(Value); - if neg then - x := not (x - 1); - Result := ''; - repeat - y := x mod 256; - x := x div 256; - Result := AnsiChar(y) + Result; - until x = 0; - if (not neg) and (Result[1] > #$7F) then - Result := #0 + Result; -end; - -{==============================================================================} -function ASNEncUInt(Value: Integer): AnsiString; -var - x, y: Integer; - neg: Boolean; -begin - neg := Value < 0; - x := Value; - if neg then - x := x and $7FFFFFFF; - Result := ''; - repeat - y := x mod 256; - x := x div 256; - Result := AnsiChar(y) + Result; - until x = 0; - if neg then - Result[1] := AnsiChar(Ord(Result[1]) or $80); -end; - -{==============================================================================} -function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString; -begin - Result := AnsiChar(ASNType) + ASNEncLen(Length(Data)) + Data; -end; - -{==============================================================================} -function ASNItem(var Start: Integer; const Buffer: AnsiString; - var ValueType: Integer): AnsiString; -var - ASNType: Integer; - ASNSize: Integer; - y, n: Integer; - x: byte; - s: AnsiString; - c: AnsiChar; - neg: Boolean; - l: Integer; -begin - Result := ''; - ValueType := ASN1_NULL; - l := Length(Buffer); - if l < (Start + 1) then - Exit; - ASNType := Ord(Buffer[Start]); - ValueType := ASNType; - Inc(Start); - ASNSize := ASNDecLen(Start, Buffer); - if (Start + ASNSize - 1) > l then - Exit; - if (ASNType and $20) > 0 then -// Result := '$' + IntToHex(ASNType, 2) - Result := Copy(Buffer, Start, ASNSize) - else - case ASNType of - ASN1_INT, ASN1_ENUM, ASN1_BOOL: - begin - y := 0; - neg := False; - for n := 1 to ASNSize do - begin - x := Ord(Buffer[Start]); - if (n = 1) and (x > $7F) then - neg := True; - if neg then - x := not x; - y := y * 256 + x; - Inc(Start); - end; - if neg then - y := -(y + 1); - Result := IntToStr(y); - end; - ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS: - begin - y := 0; - for n := 1 to ASNSize do - begin - y := y * 256 + Ord(Buffer[Start]); - Inc(Start); - end; - Result := IntToStr(y); - end; - ASN1_OCTSTR, ASN1_OPAQUE: - begin - for n := 1 to ASNSize do - begin - c := AnsiChar(Buffer[Start]); - Inc(Start); - s := s + c; - end; - Result := s; - end; - ASN1_OBJID: - begin - for n := 1 to ASNSize do - begin - c := AnsiChar(Buffer[Start]); - Inc(Start); - s := s + c; - end; - Result := IdToMib(s); - end; - ASN1_IPADDR: - begin - s := ''; - for n := 1 to ASNSize do - begin - if (n <> 1) then - s := s + '.'; - y := Ord(Buffer[Start]); - Inc(Start); - s := s + IntToStr(y); - end; - Result := s; - end; - ASN1_NULL: - begin - Result := ''; - Start := Start + ASNSize; - end; - else // unknown - begin - for n := 1 to ASNSize do - begin - c := AnsiChar(Buffer[Start]); - Inc(Start); - s := s + c; - end; - Result := s; - end; - end; -end; - -{==============================================================================} -function MibToId(Mib: String): AnsiString; -var - x: Integer; - - function WalkInt(var s: String): Integer; - var - x: Integer; - t: AnsiString; - begin - x := Pos('.', s); - if x < 1 then - begin - t := s; - s := ''; - end - else - begin - t := Copy(s, 1, x - 1); - s := Copy(s, x + 1, Length(s) - x); - end; - Result := StrToIntDef(t, 0); - end; - -begin - Result := ''; - x := WalkInt(Mib); - x := x * 40 + WalkInt(Mib); - Result := ASNEncOIDItem(x); - while Mib <> '' do - begin - x := WalkInt(Mib); - Result := Result + ASNEncOIDItem(x); - end; -end; - -{==============================================================================} -function IdToMib(const Id: AnsiString): String; -var - x, y, n: Integer; -begin - Result := ''; - n := 1; - while Length(Id) + 1 > n do - begin - x := ASNDecOIDItem(n, Id); - if (n - 1) = 1 then - begin - y := x div 40; - x := x mod 40; - Result := IntToStr(y); - end; - Result := Result + '.' + IntToStr(x); - end; -end; - -{==============================================================================} -function IntMibToStr(const Value: AnsiString): AnsiString; -var - n, y: Integer; -begin - y := 0; - for n := 1 to Length(Value) - 1 do - y := y * 256 + Ord(Value[n]); - Result := IntToStr(y); -end; - -{==============================================================================} -function ASNdump(const Value: AnsiString): AnsiString; -var - i, at, x, n: integer; - s, indent: AnsiString; - il: TStringList; -begin - il := TStringList.Create; - try - Result := ''; - i := 1; - indent := ''; - while i < Length(Value) do - begin - for n := il.Count - 1 downto 0 do - begin - x := StrToIntDef(il[n], 0); - if x <= i then - begin - il.Delete(n); - Delete(indent, 1, 2); - end; - end; - s := ASNItem(i, Value, at); - Result := Result + indent + '$' + IntToHex(at, 2); - if (at and $20) > 0 then - begin - x := Length(s); - Result := Result + ' constructed: length ' + IntToStr(x); - indent := indent + ' '; - il.Add(IntToStr(x + i - 1)); - end - else - begin - case at of - ASN1_BOOL: - Result := Result + ' BOOL: '; - ASN1_INT: - Result := Result + ' INT: '; - ASN1_ENUM: - Result := Result + ' ENUM: '; - ASN1_COUNTER: - Result := Result + ' COUNTER: '; - ASN1_GAUGE: - Result := Result + ' GAUGE: '; - ASN1_TIMETICKS: - Result := Result + ' TIMETICKS: '; - ASN1_OCTSTR: - Result := Result + ' OCTSTR: '; - ASN1_OPAQUE: - Result := Result + ' OPAQUE: '; - ASN1_OBJID: - Result := Result + ' OBJID: '; - ASN1_IPADDR: - Result := Result + ' IPADDR: '; - ASN1_NULL: - Result := Result + ' NULL: '; - else // other - Result := Result + ' unknown: '; - end; - if IsBinaryString(s) then - s := DumpExStr(s); - Result := Result + s; - end; - Result := Result + #$0d + #$0a; - end; - finally - il.Free; - end; -end; - -{==============================================================================} - -end. diff --git a/addons/synapse/blcksock.pas b/addons/synapse/blcksock.pas deleted file mode 100644 index ddefee3..0000000 --- a/addons/synapse/blcksock.pas +++ /dev/null @@ -1,4261 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 009.008.003 | -|==============================================================================| -| Content: Library base | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)1999-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{ -Special thanks to Gregor Ibic - (Intelicom d.o.o., http://www.intelicom.si) - for good inspiration about SSL programming. -} - -{$DEFINE ONCEWINSOCK} -{Note about define ONCEWINSOCK: -If you remove this compiler directive, then socket interface is loaded and -initialized on constructor of TBlockSocket class for each socket separately. -Socket interface is used only if your need it. - -If you leave this directive here, then socket interface is loaded and -initialized only once at start of your program! It boost performace on high -count of created and destroyed sockets. It eliminate possible small resource -leak on Windows systems too. -} - -//{$DEFINE RAISEEXCEPT} -{When you enable this define, then is Raiseexcept property is on by default -} - -{:@abstract(Synapse's library core) - -Core with implementation basic socket classes. -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$IFDEF VER125} - {$DEFINE BCB} -{$ENDIF} -{$IFDEF BCB} - {$ObjExportAll On} -{$ENDIF} -{$Q-} -{$H+} -{$M+} - -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit blcksock; - -interface - -uses - SysUtils, Classes, - synafpc, - synsock, synautil, synacode, synaip -{$IFDEF CIL} - ,System.Net - ,System.Net.Sockets - ,System.Text -{$ENDIF} - ; - -const - - SynapseRelease = '38'; - - cLocalhost = '127.0.0.1'; - cAnyHost = '0.0.0.0'; - cBroadcast = '255.255.255.255'; - c6Localhost = '::1'; - c6AnyHost = '::0'; - c6Broadcast = 'ffff::1'; - cAnyPort = '0'; - CR = #$0d; - LF = #$0a; - CRLF = CR + LF; - c64k = 65536; - -type - - {:@abstract(Exception clas used by Synapse) - When you enable generating of exceptions, this exception is raised by - Synapse's units.} - ESynapseError = class(Exception) - private - FErrorCode: Integer; - FErrorMessage: string; - published - {:Code of error. Value depending on used operating system} - property ErrorCode: Integer read FErrorCode Write FErrorCode; - {:Human readable description of error.} - property ErrorMessage: string read FErrorMessage Write FErrorMessage; - end; - - {:Types of OnStatus events} - THookSocketReason = ( - {:Resolving is begin. Resolved IP and port is in parameter in format like: - 'localhost.somewhere.com:25'.} - HR_ResolvingBegin, - {:Resolving is done. Resolved IP and port is in parameter in format like: - 'localhost.somewhere.com:25'. It is always same as in HR_ResolvingBegin!} - HR_ResolvingEnd, - {:Socket created by CreateSocket method. It reporting Family of created - socket too!} - HR_SocketCreate, - {:Socket closed by CloseSocket method.} - HR_SocketClose, - {:Socket binded to IP and Port. Binded IP and Port is in parameter in format - like: 'localhost.somewhere.com:25'.} - HR_Bind, - {:Socket connected to IP and Port. Connected IP and Port is in parameter in - format like: 'localhost.somewhere.com:25'.} - HR_Connect, - {:Called when CanRead method is used with @True result.} - HR_CanRead, - {:Called when CanWrite method is used with @True result.} - HR_CanWrite, - {:Socket is swithed to Listen mode. (TCP socket only)} - HR_Listen, - {:Socket Accepting client connection. (TCP socket only)} - HR_Accept, - {:report count of bytes readed from socket. Number is in parameter string. - If you need is in integer, you must use StrToInt function!} - HR_ReadCount, - {:report count of bytes writed to socket. Number is in parameter string. If - you need is in integer, you must use StrToInt function!} - HR_WriteCount, - {:If is limiting of bandwidth on, then this reason is called when sending or - receiving is stopped for satisfy bandwidth limit. Parameter is count of - waiting milliseconds.} - HR_Wait, - {:report situation where communication error occured. When raiseexcept is - @true, then exception is called after this Hook reason.} - HR_Error - ); - - {:Procedural type for OnStatus event. Sender is calling TBlockSocket object, - Reason is one of set Status events and value is optional data.} - THookSocketStatus = procedure(Sender: TObject; Reason: THookSocketReason; - const Value: String) of object; - - {:This procedural type is used for DataFilter hooks.} - THookDataFilter = procedure(Sender: TObject; var Value: AnsiString) of object; - - {:This procedural type is used for hook OnCreateSocket. By this hook you can - insert your code after initialisation of socket. (you can set special socket - options, etc.)} - THookCreateSocket = procedure(Sender: TObject) of object; - - {:This procedural type is used for monitoring of communication.} - THookMonitor = procedure(Sender: TObject; Writing: Boolean; - const Buffer: TMemory; Len: Integer) of object; - - {:This procedural type is used for hook OnAfterConnect. By this hook you can - insert your code after TCP socket has been sucessfully connected.} - THookAfterConnect = procedure(Sender: TObject) of object; - - {:This procedural type is used for hook OnHeartbeat. By this hook you can - call your code repeately during long socket operations. - You must enable heartbeats by @Link(HeartbeatRate) property!} - THookHeartbeat = procedure(Sender: TObject) of object; - - {:Specify family of socket.} - TSocketFamily = ( - {:Default mode. Socket family is defined by target address for connection. - It allows instant access to IPv4 and IPv6 nodes. When you need IPv6 address - as destination, then is used IPv6 mode. othervise is used IPv4 mode. - However this mode not working properly with preliminary IPv6 supports!} - SF_Any, - {:Turn this class to pure IPv4 mode. This mode is totally compatible with - previous Synapse releases.} - SF_IP4, - {:Turn to only IPv6 mode.} - SF_IP6 - ); - - {:specify possible values of SOCKS modes.} - TSocksType = ( - ST_Socks5, - ST_Socks4 - ); - - {:Specify requested SSL/TLS version for secure connection.} - TSSLType = ( - LT_all, - LT_SSLv2, - LT_SSLv3, - LT_TLSv1, - LT_TLSv1_1, - LT_SSHv2 - ); - - {:Specify type of socket delayed option.} - TSynaOptionType = ( - SOT_Linger, - SOT_RecvBuff, - SOT_SendBuff, - SOT_NonBlock, - SOT_RecvTimeout, - SOT_SendTimeout, - SOT_Reuse, - SOT_TTL, - SOT_Broadcast, - SOT_MulticastTTL, - SOT_MulticastLoop - ); - - {:@abstract(this object is used for remember delayed socket option set.)} - TSynaOption = class(TObject) - public - Option: TSynaOptionType; - Enabled: Boolean; - Value: Integer; - end; - - TCustomSSL = class; - TSSLClass = class of TCustomSSL; - - {:@abstract(Basic IP object.) - This is parent class for other class with protocol implementations. Do not - use this class directly! Use @link(TICMPBlockSocket), @link(TRAWBlockSocket), - @link(TTCPBlockSocket) or @link(TUDPBlockSocket) instead.} - TBlockSocket = class(TObject) - private - FOnStatus: THookSocketStatus; - FOnReadFilter: THookDataFilter; - FOnCreateSocket: THookCreateSocket; - FOnMonitor: THookMonitor; - FOnHeartbeat: THookHeartbeat; - FLocalSin: TVarSin; - FRemoteSin: TVarSin; - FTag: integer; - FBuffer: AnsiString; - FRaiseExcept: Boolean; - FNonBlockMode: Boolean; - FMaxLineLength: Integer; - FMaxSendBandwidth: Integer; - FNextSend: LongWord; - FMaxRecvBandwidth: Integer; - FNextRecv: LongWord; - FConvertLineEnd: Boolean; - FLastCR: Boolean; - FLastLF: Boolean; - FBinded: Boolean; - FFamily: TSocketFamily; - FFamilySave: TSocketFamily; - FIP6used: Boolean; - FPreferIP4: Boolean; - FDelayedOptions: TList; - FInterPacketTimeout: Boolean; - {$IFNDEF CIL} - FFDSet: TFDSet; - {$ENDIF} - FRecvCounter: Integer; - FSendCounter: Integer; - FSendMaxChunk: Integer; - FStopFlag: Boolean; - FNonblockSendTimeout: Integer; - FHeartbeatRate: integer; - function GetSizeRecvBuffer: Integer; - procedure SetSizeRecvBuffer(Size: Integer); - function GetSizeSendBuffer: Integer; - procedure SetSizeSendBuffer(Size: Integer); - procedure SetNonBlockMode(Value: Boolean); - procedure SetTTL(TTL: integer); - function GetTTL:integer; - procedure SetFamily(Value: TSocketFamily); virtual; - procedure SetSocket(Value: TSocket); virtual; - function GetWsaData: TWSAData; - function FamilyToAF(f: TSocketFamily): TAddrFamily; - protected - FSocket: TSocket; - FLastError: Integer; - FLastErrorDesc: string; - FOwner: TObject; - procedure SetDelayedOption(const Value: TSynaOption); - procedure DelayedOption(const Value: TSynaOption); - procedure ProcessDelayedOptions; - procedure InternalCreateSocket(Sin: TVarSin); - procedure SetSin(var Sin: TVarSin; IP, Port: string); - function GetSinIP(Sin: TVarSin): string; - function GetSinPort(Sin: TVarSin): Integer; - procedure DoStatus(Reason: THookSocketReason; const Value: string); - procedure DoReadFilter(Buffer: TMemory; var Len: Integer); - procedure DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer); - procedure DoCreateSocket; - procedure DoHeartbeat; - procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); - procedure SetBandwidth(Value: Integer); - function TestStopFlag: Boolean; - procedure InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); virtual; - function InternalCanRead(Timeout: Integer): Boolean; virtual; - public - constructor Create; - - {:Create object and load all necessary socket library. What library is - loaded is described by STUB parameter. If STUB is empty string, then is - loaded default libraries.} - constructor CreateAlternate(Stub: string); - destructor Destroy; override; - - {:If @link(family) is not SF_Any, then create socket with type defined in - @link(Family) property. If family is SF_Any, then do nothing! (socket is - created automaticly when you know what type of socket you need to create. - (i.e. inside @link(Connect) or @link(Bind) call.) When socket is created, - then is aplyed all stored delayed socket options.} - procedure CreateSocket; - - {:It create socket. Address resolving of Value tells what type of socket is - created. If Value is resolved as IPv4 IP, then is created IPv4 socket. If - value is resolved as IPv6 address, then is created IPv6 socket.} - procedure CreateSocketByName(const Value: String); - - {:Destroy socket in use. This method is also automatically called from - object destructor.} - procedure CloseSocket; virtual; - - {:Abort any work on Socket and destroy them.} - procedure AbortSocket; virtual; - - {:Connects socket to local IP address and PORT. IP address may be numeric or - symbolic ('192.168.74.50', 'cosi.nekde.cz', 'ff08::1'). The same for PORT - - it may be number or mnemonic port ('23', 'telnet'). - - If port value is '0', system chooses itself and conects unused port in the - range 1024 to 4096 (this depending by operating system!). Structure - LocalSin is filled after calling this method. - - Note: If you call this on non-created socket, then socket is created - automaticly. - - Warning: when you call : Bind('0.0.0.0','0'); then is nothing done! In this - case is used implicit system bind instead.} - procedure Bind(IP, Port: string); - - {:Connects socket to remote IP address and PORT. The same rules as with - @link(BIND) method are valid. The only exception is that PORT with 0 value - will not be connected! - - Structures LocalSin and RemoteSin will be filled with valid values. - - When you call this on non-created socket, then socket is created - automaticly. Type of created socket is by @link(Family) property. If is - used SF_IP4, then is created socket for IPv4. If is used SF_IP6, then is - created socket for IPv6. When you have family on SF_Any (default!), then - type of created socket is determined by address resolving of destination - address. (Not work properly on prilimitary winsock IPv6 support!)} - procedure Connect(IP, Port: string); virtual; - - {:Sets socket to receive mode for new incoming connections. It is necessary - to use @link(TBlockSocket.BIND) function call before this method to select - receiving port!} - procedure Listen; virtual; - - {:Waits until new incoming connection comes. After it comes a new socket is - automatically created (socket handler is returned by this function as - result).} - function Accept: TSocket; virtual; - - {:Sends data of LENGTH from BUFFER address via connected socket. System - automatically splits data to packets.} - function SendBuffer(Buffer: Tmemory; Length: Integer): Integer; virtual; - - {:One data BYTE is sent via connected socket.} - procedure SendByte(Data: Byte); virtual; - - {:Send data string via connected socket. Any terminator is not added! If you - need send true string with CR-LF termination, you must add CR-LF characters - to sended string! Because any termination is not added automaticly, you can - use this function for sending any binary data in binary string.} - procedure SendString(Data: AnsiString); virtual; - - {:Send integer as four bytes to socket.} - procedure SendInteger(Data: integer); virtual; - - {:Send data as one block to socket. Each block begin with 4 bytes with - length of data in block. This 4 bytes is added automaticly by this - function.} - procedure SendBlock(const Data: AnsiString); virtual; - - {:Send data from stream to socket.} - procedure SendStreamRaw(const Stream: TStream); virtual; - - {:Send content of stream to socket. It using @link(SendBlock) method} - procedure SendStream(const Stream: TStream); virtual; - - {:Send content of stream to socket. It using @link(SendBlock) method and - this is compatible with streams in Indy library.} - procedure SendStreamIndy(const Stream: TStream); virtual; - - {:Note: This is low-level receive function. You must be sure if data is - waiting for read before call this function for avoid deadlock! - - Waits until allocated buffer is filled by received data. Returns number of - data received, which equals to LENGTH value under normal operation. If it - is not equal the communication channel is possibly broken. - - On stream oriented sockets if is received 0 bytes, it mean 'socket is - closed!" - - On datagram socket is readed first waiting datagram.} - function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; virtual; - - {:Note: This is high-level receive function. It using internal - @link(LineBuffer) and you can combine this function freely with other - high-level functions! - - Method waits until data is received. If no data is received within TIMEOUT - (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT. Methods - serves for reading any size of data (i.e. one megabyte...). This method is - preffered for reading from stream sockets (like TCP).} - function RecvBufferEx(Buffer: Tmemory; Len: Integer; - Timeout: Integer): Integer; virtual; - - {:Similar to @link(RecvBufferEx), but readed data is stored in binary - string, not in memory buffer.} - function RecvBufferStr(Len: Integer; Timeout: Integer): AnsiString; virtual; - - {:Note: This is high-level receive function. It using internal - @link(LineBuffer) and you can combine this function freely with other - high-level functions. - - Waits until one data byte is received which is also returned as function - result. If no data is received within TIMEOUT (in milliseconds)period, - @link(LastError) is set to WSAETIMEDOUT and result have value 0.} - function RecvByte(Timeout: Integer): Byte; virtual; - - {:Note: This is high-level receive function. It using internal - @link(LineBuffer) and you can combine this function freely with other - high-level functions. - - Waits until one four bytes are received and return it as one Ineger Value. - If no data is received within TIMEOUT (in milliseconds)period, - @link(LastError) is set to WSAETIMEDOUT and result have value 0.} - function RecvInteger(Timeout: Integer): Integer; virtual; - - {:Note: This is high-level receive function. It using internal - @link(LineBuffer) and you can combine this function freely with other - high-level functions. - - Method waits until data string is received. This string is terminated by - CR-LF characters. The resulting string is returned without this termination - (CR-LF)! If @link(ConvertLineEnd) is used, then CR-LF sequence may not be - exactly CR-LF. See @link(ConvertLineEnd) description. If no data is - received within TIMEOUT (in milliseconds) period, @link(LastError) is set - to WSAETIMEDOUT. You may also specify maximum length of reading data by - @link(MaxLineLength) property.} - function RecvString(Timeout: Integer): AnsiString; virtual; - - {:Note: This is high-level receive function. It using internal - @link(LineBuffer) and you can combine this function freely with other - high-level functions. - - Method waits until data string is received. This string is terminated by - Terminator string. The resulting string is returned without this - termination. If no data is received within TIMEOUT (in milliseconds) - period, @link(LastError) is set to WSAETIMEDOUT. You may also specify - maximum length of reading data by @link(MaxLineLength) property.} - function RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; virtual; - - {:Note: This is high-level receive function. It using internal - @link(LineBuffer) and you can combine this function freely with other - high-level functions. - - Method reads all data waiting for read. If no data is received within - TIMEOUT (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT. - Methods serves for reading unknown size of data. Because before call this - function you don't know size of received data, returned data is stored in - dynamic size binary string. This method is preffered for reading from - stream sockets (like TCP). It is very goot for receiving datagrams too! - (UDP protocol)} - function RecvPacket(Timeout: Integer): AnsiString; virtual; - - {:Read one block of data from socket. Each block begin with 4 bytes with - length of data in block. This function read first 4 bytes for get lenght, - then it wait for reported count of bytes.} - function RecvBlock(Timeout: Integer): AnsiString; virtual; - - {:Read all data from socket to stream until socket is closed (or any error - occured.)} - procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual; - {:Read requested count of bytes from socket to stream.} - procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); - - {:Receive data to stream. It using @link(RecvBlock) method.} - procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual; - - {:Receive data to stream. This function is compatible with similar function - in Indy library. It using @link(RecvBlock) method.} - procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual; - - {:Same as @link(RecvBuffer), but readed data stays in system input buffer. - Warning: this function not respect data in @link(LineBuffer)! Is not - recommended to use this function!} - function PeekBuffer(Buffer: TMemory; Length: Integer): Integer; virtual; - - {:Same as @link(RecvByte), but readed data stays in input system buffer. - Warning: this function not respect data in @link(LineBuffer)! Is not - recommended to use this function!} - function PeekByte(Timeout: Integer): Byte; virtual; - - {:On stream sockets it returns number of received bytes waiting for picking. - 0 is returned when there is no such data. On datagram socket it returns - length of the first waiting datagram. Returns 0 if no datagram is waiting.} - function WaitingData: Integer; virtual; - - {:Same as @link(WaitingData), but if exists some of data in @link(Linebuffer), - return their length instead.} - function WaitingDataEx: Integer; - - {:Clear all waiting data for read from buffers.} - procedure Purge; - - {:Sets linger. Enabled linger means that the system waits another LINGER - (in milliseconds) time for delivery of sent data. This function is only for - stream type of socket! (TCP)} - procedure SetLinger(Enable: Boolean; Linger: Integer); - - {:Actualize values in @link(LocalSin).} - procedure GetSinLocal; - - {:Actualize values in @link(RemoteSin).} - procedure GetSinRemote; - - {:Actualize values in @link(LocalSin) and @link(RemoteSin).} - procedure GetSins; - - {:Reset @link(LastError) and @link(LastErrorDesc) to non-error state.} - procedure ResetLastError; - - {:If you "manually" call Socket API functions, forward their return code as - parameter to this function, which evaluates it, eventually calls - GetLastError and found error code returns and stores to @link(LastError).} - function SockCheck(SockResult: Integer): Integer; virtual; - - {:If @link(LastError) contains some error code and @link(RaiseExcept) - property is @true, raise adequate exception.} - procedure ExceptCheck; - - {:Returns local computer name as numerical or symbolic value. It try get - fully qualified domain name. Name is returned in the format acceptable by - functions demanding IP as input parameter.} - function LocalName: string; - - {:Try resolve name to all possible IP address. i.e. If you pass as name - result of @link(LocalName) method, you get all IP addresses used by local - system.} - procedure ResolveNameToIP(Name: string; const IPList: TStrings); - - {:Try resolve name to primary IP address. i.e. If you pass as name result of - @link(LocalName) method, you get primary IP addresses used by local system.} - function ResolveName(Name: string): string; - - {:Try resolve IP to their primary domain name. If IP not have domain name, - then is returned original IP.} - function ResolveIPToName(IP: string): string; - - {:Try resolve symbolic port name to port number. (i.e. 'Echo' to 8)} - function ResolvePort(Port: string): Word; - - {:Set information about remote side socket. It is good for seting remote - side for sending UDP packet, etc.} - procedure SetRemoteSin(IP, Port: string); - - {:Picks IP socket address from @link(LocalSin).} - function GetLocalSinIP: string; virtual; - - {:Picks IP socket address from @link(RemoteSin).} - function GetRemoteSinIP: string; virtual; - - {:Picks socket PORT number from @link(LocalSin).} - function GetLocalSinPort: Integer; virtual; - - {:Picks socket PORT number from @link(RemoteSin).} - function GetRemoteSinPort: Integer; virtual; - - {:Return @TRUE, if you can read any data from socket or is incoming - connection on TCP based socket. Status is tested for time Timeout (in - milliseconds). If value in Timeout is 0, status is only tested and - continue. If value in Timeout is -1, run is breaked and waiting for read - data maybe forever. - - This function is need only on special cases, when you need use - @link(RecvBuffer) function directly! read functioms what have timeout as - calling parameter, calling this function internally.} - function CanRead(Timeout: Integer): Boolean; virtual; - - {:Same as @link(CanRead), but additionally return @TRUE if is some data in - @link(LineBuffer).} - function CanReadEx(Timeout: Integer): Boolean; virtual; - - {:Return @TRUE, if you can to socket write any data (not full sending - buffer). Status is tested for time Timeout (in milliseconds). If value in - Timeout is 0, status is only tested and continue. If value in Timeout is - -1, run is breaked and waiting for write data maybe forever. - - This function is need only on special cases!} - function CanWrite(Timeout: Integer): Boolean; virtual; - - {:Same as @link(SendBuffer), but send datagram to address from - @link(RemoteSin). Usefull for sending reply to datagram received by - function @link(RecvBufferFrom).} - function SendBufferTo(Buffer: TMemory; Length: Integer): Integer; virtual; - - {:Note: This is low-lever receive function. You must be sure if data is - waiting for read before call this function for avoid deadlock! - - Receives first waiting datagram to allocated buffer. If there is no waiting - one, then waits until one comes. Returns length of datagram stored in - BUFFER. If length exceeds buffer datagram is truncated. After this - @link(RemoteSin) structure contains information about sender of UDP packet.} - function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; virtual; -{$IFNDEF CIL} - {:This function is for check for incoming data on set of sockets. Whitch - sockets is checked is decribed by SocketList Tlist with TBlockSocket - objects. TList may have maximal number of objects defined by FD_SETSIZE - constant. Return @TRUE, if you can from some socket read any data or is - incoming connection on TCP based socket. Status is tested for time Timeout - (in milliseconds). If value in Timeout is 0, status is only tested and - continue. If value in Timeout is -1, run is breaked and waiting for read - data maybe forever. If is returned @TRUE, CanReadList TList is filled by all - TBlockSocket objects what waiting for read.} - function GroupCanRead(const SocketList: TList; Timeout: Integer; - const CanReadList: TList): Boolean; -{$ENDIF} - {:By this method you may turn address reuse mode for local @link(bind). It - is good specially for UDP protocol. Using this with TCP protocol is - hazardous!} - procedure EnableReuse(Value: Boolean); - - {:Try set timeout for all sending and receiving operations, if socket - provider can do it. (It not supported by all socket providers!)} - procedure SetTimeout(Timeout: Integer); - - {:Try set timeout for all sending operations, if socket provider can do it. - (It not supported by all socket providers!)} - procedure SetSendTimeout(Timeout: Integer); - - {:Try set timeout for all receiving operations, if socket provider can do - it. (It not supported by all socket providers!)} - procedure SetRecvTimeout(Timeout: Integer); - - {:Return value of socket type.} - function GetSocketType: integer; Virtual; - - {:Return value of protocol type for socket creation.} - function GetSocketProtocol: integer; Virtual; - - {:WSA structure with information about socket provider. On non-windows - platforms this structure is simulated!} - property WSAData: TWSADATA read GetWsaData; - - {:FDset structure prepared for usage with this socket.} - property FDset: TFDSet read FFDset; - - {:Structure describing local socket side.} - property LocalSin: TVarSin read FLocalSin write FLocalSin; - - {:Structure describing remote socket side.} - property RemoteSin: TVarSin read FRemoteSin write FRemoteSin; - - {:Socket handler. Suitable for "manual" calls to socket API or manual - connection of socket to a previously created socket (i.e by Accept method - on TCP socket)} - property Socket: TSocket read FSocket write SetSocket; - - {:Last socket operation error code. Error codes are described in socket - documentation. Human readable error description is stored in - @link(LastErrorDesc) property.} - property LastError: Integer read FLastError; - - {:Human readable error description of @link(LastError) code.} - property LastErrorDesc: string read FLastErrorDesc; - - {:Buffer used by all high-level receiving functions. This buffer is used for - optimized reading of data from socket. In normal cases you not need access - to this buffer directly!} - property LineBuffer: AnsiString read FBuffer write FBuffer; - - {:Size of Winsock receive buffer. If it is not supported by socket provider, - it return as size one kilobyte.} - property SizeRecvBuffer: Integer read GetSizeRecvBuffer write SetSizeRecvBuffer; - - {:Size of Winsock send buffer. If it is not supported by socket provider, it - return as size one kilobyte.} - property SizeSendBuffer: Integer read GetSizeSendBuffer write SetSizeSendBuffer; - - {:If @True, turn class to non-blocking mode. Not all functions are working - properly in this mode, you must know exactly what you are doing! However - when you have big experience with non-blocking programming, then you can - optimise your program by non-block mode!} - property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode; - - {:Set Time-to-live value. (if system supporting it!)} - property TTL: Integer read GetTTL Write SetTTL; - - {:If is @true, then class in in IPv6 mode.} - property IP6used: Boolean read FIP6used; - - {:Return count of received bytes on this socket from begin of current - connection.} - property RecvCounter: Integer read FRecvCounter; - - {:Return count of sended bytes on this socket from begin of current - connection.} - property SendCounter: Integer read FSendCounter; - published - {:Return descriptive string for given error code. This is class function. - You may call it without created object!} - class function GetErrorDesc(ErrorCode: Integer): string; - - {:Return descriptive string for @link(LastError).} - function GetErrorDescEx: string; virtual; - - {:this value is for free use.} - property Tag: Integer read FTag write FTag; - - {:If @true, winsock errors raises exception. Otherwise is setted - @link(LastError) value only and you must check it from your program! Default - value is @false.} - property RaiseExcept: Boolean read FRaiseExcept write FRaiseExcept; - - {:Define maximum length in bytes of @link(LineBuffer) for high-level - receiving functions. If this functions try to read more data then this - limit, error is returned! If value is 0 (default), no limitation is used. - This is very good protection for stupid attacks to your server by sending - lot of data without proper terminator... until all your memory is allocated - by LineBuffer! - - Note: This maximum length is checked only in functions, what read unknown - number of bytes! (like @link(RecvString) or @link(RecvTerminated))} - property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength; - - {:Define maximal bandwidth for all sending operations in bytes per second. - If value is 0 (default), bandwidth limitation is not used.} - property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth; - - {:Define maximal bandwidth for all receiving operations in bytes per second. - If value is 0 (default), bandwidth limitation is not used.} - property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth; - - {:Define maximal bandwidth for all sending and receiving operations in bytes - per second. If value is 0 (default), bandwidth limitation is not used.} - property MaxBandwidth: Integer Write SetBandwidth; - - {:Do a conversion of non-standard line terminators to CRLF. (Off by default) - If @True, then terminators like sigle CR, single LF or LFCR are converted - to CRLF internally. This have effect only in @link(RecvString) method!} - property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd; - - {:Specified Family of this socket. When you are using Windows preliminary - support for IPv6, then I recommend to set this property!} - property Family: TSocketFamily read FFamily Write SetFamily; - - {:When resolving of domain name return both IPv4 and IPv6 addresses, then - specify if is used IPv4 (dafault - @true) or IPv6.} - property PreferIP4: Boolean read FPreferIP4 Write FPreferIP4; - - {:By default (@true) is all timeouts used as timeout between two packets in - reading operations. If you set this to @false, then Timeouts is for overall - reading operation!} - property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout; - - {:All sended datas was splitted by this value.} - property SendMaxChunk: Integer read FSendMaxChunk Write FSendMaxChunk; - - {:By setting this property to @true you can stop any communication. You can - use this property for soft abort of communication.} - property StopFlag: Boolean read FStopFlag Write FStopFlag; - - {:Timeout for data sending by non-blocking socket mode.} - property NonblockSendTimeout: Integer read FNonblockSendTimeout Write FNonblockSendTimeout; - - {:This event is called by various reasons. It is good for monitoring socket, - create gauges for data transfers, etc.} - property OnStatus: THookSocketStatus read FOnStatus write FOnStatus; - - {:this event is good for some internal thinks about filtering readed datas. - It is used by telnet client by example.} - property OnReadFilter: THookDataFilter read FOnReadFilter write FOnReadFilter; - - {:This event is called after real socket creation for setting special socket - options, because you not know when socket is created. (it is depended on - Ipv4, IPv6 or automatic mode)} - property OnCreateSocket: THookCreateSocket read FOnCreateSocket write FOnCreateSocket; - - {:This event is good for monitoring content of readed or writed datas.} - property OnMonitor: THookMonitor read FOnMonitor write FOnMonitor; - - {:This event is good for calling your code during long socket operations. - (Example, for refresing UI if class in not called within the thread.) - Rate of heartbeats can be modified by @link(HeartbeatRate) property.} - property OnHeartbeat: THookHeartbeat read FOnHeartbeat write FOnHeartbeat; - - {:Specify typical rate of @link(OnHeartbeat) event and @link(StopFlag) testing. - Default value 0 disabling heartbeats! Value is in milliseconds. - Real rate can be higher or smaller then this value, because it depending - on real socket operations too! - Note: Each heartbeat slowing socket processing.} - property HeartbeatRate: integer read FHeartbeatRate Write FHeartbeatRate; - {:What class own this socket? Used by protocol implementation classes.} - property Owner: TObject read FOwner Write FOwner; - end; - - {:@abstract(Support for SOCKS4 and SOCKS5 proxy) - Layer with definition all necessary properties and functions for - implementation SOCKS proxy client. Do not use this class directly.} - TSocksBlockSocket = class(TBlockSocket) - protected - FSocksIP: string; - FSocksPort: string; - FSocksTimeout: integer; - FSocksUsername: string; - FSocksPassword: string; - FUsingSocks: Boolean; - FSocksResolver: Boolean; - FSocksLastError: integer; - FSocksResponseIP: string; - FSocksResponsePort: string; - FSocksLocalIP: string; - FSocksLocalPort: string; - FSocksRemoteIP: string; - FSocksRemotePort: string; - FBypassFlag: Boolean; - FSocksType: TSocksType; - function SocksCode(IP, Port: string): Ansistring; - function SocksDecode(Value: Ansistring): integer; - public - constructor Create; - - {:Open connection to SOCKS proxy and if @link(SocksUsername) is set, do - authorisation to proxy. This is needed only in special cases! (it is called - internally!)} - function SocksOpen: Boolean; - - {:Send specified request to SOCKS proxy. This is needed only in special - cases! (it is called internally!)} - function SocksRequest(Cmd: Byte; const IP, Port: string): Boolean; - - {:Receive response to previosly sended request. This is needed only in - special cases! (it is called internally!)} - function SocksResponse: Boolean; - - {:Is @True when class is using SOCKS proxy.} - property UsingSocks: Boolean read FUsingSocks; - - {:If SOCKS proxy failed, here is error code returned from SOCKS proxy.} - property SocksLastError: integer read FSocksLastError; - published - {:Address of SOCKS server. If value is empty string, SOCKS support is - disabled. Assingning any value to this property enable SOCKS mode. - Warning: You cannot combine this mode with HTTP-tunneling mode!} - property SocksIP: string read FSocksIP write FSocksIP; - - {:Port of SOCKS server. Default value is '1080'.} - property SocksPort: string read FSocksPort write FSocksPort; - - {:If you need authorisation on SOCKS server, set username here.} - property SocksUsername: string read FSocksUsername write FSocksUsername; - - {:If you need authorisation on SOCKS server, set password here.} - property SocksPassword: string read FSocksPassword write FSocksPassword; - - {:Specify timeout for communicatin with SOCKS server. Default is one minute.} - property SocksTimeout: integer read FSocksTimeout write FSocksTimeout; - - {:If @True, all symbolic names of target hosts is not translated to IP's - locally, but resolving is by SOCKS proxy. Default is @True.} - property SocksResolver: Boolean read FSocksResolver write FSocksResolver; - - {:Specify SOCKS type. By default is used SOCKS5, but you can use SOCKS4 too. - When you select SOCKS4, then if @link(SOCKSResolver) is enabled, then is - used SOCKS4a. Othervise is used pure SOCKS4.} - property SocksType: TSocksType read FSocksType write FSocksType; - end; - - {:@abstract(Implementation of TCP socket.) - Supported features: IPv4, IPv6, SSL/TLS or SSH (depending on used plugin), - SOCKS5 proxy (outgoing connections and limited incomming), SOCKS4/4a proxy - (outgoing connections and limited incomming), TCP through HTTP proxy tunnel.} - TTCPBlockSocket = class(TSocksBlockSocket) - protected - FOnAfterConnect: THookAfterConnect; - FSSL: TCustomSSL; - FHTTPTunnelIP: string; - FHTTPTunnelPort: string; - FHTTPTunnel: Boolean; - FHTTPTunnelRemoteIP: string; - FHTTPTunnelRemotePort: string; - FHTTPTunnelUser: string; - FHTTPTunnelPass: string; - FHTTPTunnelTimeout: integer; - procedure SocksDoConnect(IP, Port: string); - procedure HTTPTunnelDoConnect(IP, Port: string); - procedure DoAfterConnect; - public - {:Create TCP socket class with default plugin for SSL/TSL/SSH implementation - (see @link(SSLImplementation))} - constructor Create; - - {:Create TCP socket class with desired plugin for SSL/TSL/SSH implementation} - constructor CreateWithSSL(SSLPlugin: TSSLClass); - destructor Destroy; override; - - {:See @link(TBlockSocket.CloseSocket)} - procedure CloseSocket; override; - - {:See @link(TBlockSocket.WaitingData)} - function WaitingData: Integer; override; - - {:Sets socket to receive mode for new incoming connections. It is necessary - to use @link(TBlockSocket.BIND) function call before this method to select - receiving port! - - If you use SOCKS, activate incoming TCP connection by this proxy. (By BIND - method of SOCKS.)} - procedure Listen; override; - - {:Waits until new incoming connection comes. After it comes a new socket is - automatically created (socket handler is returned by this function as - result). - - If you use SOCKS, new socket is not created! In this case is used same - socket as socket for listening! So, you can accept only one connection in - SOCKS mode.} - function Accept: TSocket; override; - - {:Connects socket to remote IP address and PORT. The same rules as with - @link(TBlockSocket.BIND) method are valid. The only exception is that PORT - with 0 value will not be connected. After call to this method - a communication channel between local and remote socket is created. Local - socket is assigned automatically if not controlled by previous call to - @link(TBlockSocket.BIND) method. Structures @link(TBlockSocket.LocalSin) - and @link(TBlockSocket.RemoteSin) will be filled with valid values. - - If you use SOCKS, activate outgoing TCP connection by SOCKS proxy specified - in @link(TSocksBlockSocket.SocksIP). (By CONNECT method of SOCKS.) - - If you use HTTP-tunnel mode, activate outgoing TCP connection by HTTP - tunnel specified in @link(HTTPTunnelIP). (By CONNECT method of HTTP - protocol.) - - Note: If you call this on non-created socket, then socket is created - automaticly.} - procedure Connect(IP, Port: string); override; - - {:If you need upgrade existing TCP connection to SSL/TLS (or SSH2, if plugin - allows it) mode, then call this method. This method switch this class to - SSL mode and do SSL/TSL handshake.} - procedure SSLDoConnect; - - {:By this method you can downgrade existing SSL/TLS connection to normal TCP - connection.} - procedure SSLDoShutdown; - - {:If you need use this component as SSL/TLS TCP server, then after accepting - of inbound connection you need start SSL/TLS session by this method. Before - call this function, you must have assigned all neeeded certificates and - keys!} - function SSLAcceptConnection: Boolean; - - {:See @link(TBlockSocket.GetLocalSinIP)} - function GetLocalSinIP: string; override; - - {:See @link(TBlockSocket.GetRemoteSinIP)} - function GetRemoteSinIP: string; override; - - {:See @link(TBlockSocket.GetLocalSinPort)} - function GetLocalSinPort: Integer; override; - - {:See @link(TBlockSocket.GetRemoteSinPort)} - function GetRemoteSinPort: Integer; override; - - {:See @link(TBlockSocket.SendBuffer)} - function SendBuffer(Buffer: TMemory; Length: Integer): Integer; override; - - {:See @link(TBlockSocket.RecvBuffer)} - function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; - - {:Return value of socket type. For TCP return SOCK_STREAM.} - function GetSocketType: integer; override; - - {:Return value of protocol type for socket creation. For TCP return - IPPROTO_TCP.} - function GetSocketProtocol: integer; override; - - {:Class implementing SSL/TLS support. It is allways some descendant - of @link(TCustomSSL) class. When programmer not select some SSL plugin - class, then is used @link(TSSLNone)} - property SSL: TCustomSSL read FSSL; - - {:@True if is used HTTP tunnel mode.} - property HTTPTunnel: Boolean read FHTTPTunnel; - published - {:Return descriptive string for @link(LastError). On case of error - in SSL/TLS subsystem, it returns right error description.} - function GetErrorDescEx: string; override; - - {:Specify IP address of HTTP proxy. Assingning non-empty value to this - property enable HTTP-tunnel mode. This mode is for tunnelling any outgoing - TCP connection through HTTP proxy server. (If policy on HTTP proxy server - allow this!) Warning: You cannot combine this mode with SOCK5 mode!} - property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP; - - {:Specify port of HTTP proxy for HTTP-tunneling.} - property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort; - - {:Specify authorisation username for access to HTTP proxy in HTTP-tunnel - mode. If you not need authorisation, then let this property empty.} - property HTTPTunnelUser: string read FHTTPTunnelUser Write FHTTPTunnelUser; - - {:Specify authorisation password for access to HTTP proxy in HTTP-tunnel - mode.} - property HTTPTunnelPass: string read FHTTPTunnelPass Write FHTTPTunnelPass; - - {:Specify timeout for communication with HTTP proxy in HTTPtunnel mode.} - property HTTPTunnelTimeout: integer read FHTTPTunnelTimeout Write FHTTPTunnelTimeout; - - {:This event is called after sucessful TCP socket connection.} - property OnAfterConnect: THookAfterConnect read FOnAfterConnect write FOnAfterConnect; - end; - - {:@abstract(Datagram based communication) - This class implementing datagram based communication instead default stream - based communication style.} - TDgramBlockSocket = class(TSocksBlockSocket) - public - {:Fill @link(TBlockSocket.RemoteSin) structure. This address is used for - sending data.} - procedure Connect(IP, Port: string); override; - - {:Silently redirected to @link(TBlockSocket.SendBufferTo).} - function SendBuffer(Buffer: TMemory; Length: Integer): Integer; override; - - {:Silently redirected to @link(TBlockSocket.RecvBufferFrom).} - function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; override; - end; - - {:@abstract(Implementation of UDP socket.) - NOTE: in this class is all receiving redirected to RecvBufferFrom. You can - use for reading any receive function. Preffered is RecvPacket! Similary all - sending is redirected to SendbufferTo. You can use for sending UDP packet any - sending function, like SendString. - - Supported features: IPv4, IPv6, unicasts, broadcasts, multicasts, SOCKS5 - proxy (only unicasts! Outgoing and incomming.)} - TUDPBlockSocket = class(TDgramBlockSocket) - protected - FSocksControlSock: TTCPBlockSocket; - function UdpAssociation: Boolean; - procedure SetMulticastTTL(TTL: integer); - function GetMulticastTTL:integer; - public - destructor Destroy; override; - - {:Enable or disable sending of broadcasts. If seting OK, result is @true. - This method is not supported in SOCKS5 mode! IPv6 does not support - broadcasts! In this case you must use Multicasts instead.} - procedure EnableBroadcast(Value: Boolean); - - {:See @link(TBlockSocket.SendBufferTo)} - function SendBufferTo(Buffer: TMemory; Length: Integer): Integer; override; - - {:See @link(TBlockSocket.RecvBufferFrom)} - function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; override; -{$IFNDEF CIL} - {:Add this socket to given multicast group. You cannot use Multicasts in - SOCKS mode!} - procedure AddMulticast(MCastIP:string); - - {:Remove this socket from given multicast group.} - procedure DropMulticast(MCastIP:string); -{$ENDIF} - {:All sended multicast datagrams is loopbacked to your interface too. (you - can read your sended datas.) You can disable this feature by this function. - This function not working on some Windows systems!} - procedure EnableMulticastLoop(Value: Boolean); - - {:Return value of socket type. For UDP return SOCK_DGRAM.} - function GetSocketType: integer; override; - - {:Return value of protocol type for socket creation. For UDP return - IPPROTO_UDP.} - function GetSocketProtocol: integer; override; - - {:Set Time-to-live value for multicasts packets. It define number of routers - for transfer of datas. If you set this to 1 (dafault system value), then - multicasts packet goes only to you local network. If you need transport - multicast packet to worldwide, then increase this value, but be carefull, - lot of routers on internet does not transport multicasts packets!} - property MulticastTTL: Integer read GetMulticastTTL Write SetMulticastTTL; - end; - - {:@abstract(Implementation of RAW ICMP socket.) - For this object you must have rights for creating RAW sockets!} - TICMPBlockSocket = class(TDgramBlockSocket) - public - {:Return value of socket type. For RAW and ICMP return SOCK_RAW.} - function GetSocketType: integer; override; - - {:Return value of protocol type for socket creation. For ICMP returns - IPPROTO_ICMP or IPPROTO_ICMPV6} - function GetSocketProtocol: integer; override; - end; - - {:@abstract(Implementation of RAW socket.) - For this object you must have rights for creating RAW sockets!} - TRAWBlockSocket = class(TBlockSocket) - public - {:Return value of socket type. For RAW and ICMP return SOCK_RAW.} - function GetSocketType: integer; override; - - {:Return value of protocol type for socket creation. For RAW returns - IPPROTO_RAW.} - function GetSocketProtocol: integer; override; - end; - - {:@abstract(Implementation of PGM-message socket.) - Not all systems supports this protocol!} - TPGMMessageBlockSocket = class(TBlockSocket) - public - {:Return value of socket type. For PGM-message return SOCK_RDM.} - function GetSocketType: integer; override; - - {:Return value of protocol type for socket creation. For PGM-message returns - IPPROTO_RM.} - function GetSocketProtocol: integer; override; - end; - - {:@abstract(Implementation of PGM-stream socket.) - Not all systems supports this protocol!} - TPGMStreamBlockSocket = class(TBlockSocket) - public - {:Return value of socket type. For PGM-stream return SOCK_STREAM.} - function GetSocketType: integer; override; - - {:Return value of protocol type for socket creation. For PGM-stream returns - IPPROTO_RM.} - function GetSocketProtocol: integer; override; - end; - - {:@abstract(Parent class for all SSL plugins.) - This is abstract class defining interface for other SSL plugins. - - Instance of this class will be created for each @link(TTCPBlockSocket). - - Warning: not all methods and propertis can work in all existing SSL plugins! - Please, read documentation of used SSL plugin.} - TCustomSSL = class(TObject) - protected - FSocket: TTCPBlockSocket; - FSSLEnabled: Boolean; - FLastError: integer; - FLastErrorDesc: string; - FSSLType: TSSLType; - FKeyPassword: string; - FCiphers: string; - FCertificateFile: string; - FPrivateKeyFile: string; - FCertificate: Ansistring; - FPrivateKey: Ansistring; - FPFX: Ansistring; - FPFXfile: string; - FCertCA: Ansistring; - FCertCAFile: string; - FTrustCertificate: Ansistring; - FTrustCertificateFile: string; - FVerifyCert: Boolean; - FUsername: string; - FPassword: string; - FSSHChannelType: string; - FSSHChannelArg1: string; - FSSHChannelArg2: string; - procedure ReturnError; - function CreateSelfSignedCert(Host: string): Boolean; virtual; - public - {: Create plugin class. it is called internally from @link(TTCPBlockSocket)} - constructor Create(const Value: TTCPBlockSocket); virtual; - - {: Assign settings (certificates and configuration) from another SSL plugin - class.} - procedure Assign(const Value: TCustomSSL); virtual; - - {: return description of used plugin. It usually return name and version - of used SSL library.} - function LibVersion: String; virtual; - - {: return name of used plugin.} - function LibName: String; virtual; - - {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! - - Here is needed code for start SSL connection.} - function Connect: boolean; virtual; - - {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! - - Here is needed code for acept new SSL connection.} - function Accept: boolean; virtual; - - {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! - - Here is needed code for hard shutdown of SSL connection. (for example, - before socket is closed)} - function Shutdown: boolean; virtual; - - {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! - - Here is needed code for soft shutdown of SSL connection. (for example, - when you need to continue with unprotected connection.)} - function BiShutdown: boolean; virtual; - - {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! - - Here is needed code for sending some datas by SSL connection.} - function SendBuffer(Buffer: TMemory; Len: Integer): Integer; virtual; - - {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! - - Here is needed code for receiving some datas by SSL connection.} - function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; virtual; - - {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! - - Here is needed code for getting count of datas what waiting for read. - If SSL plugin not allows this, then it should return 0.} - function WaitingData: Integer; virtual; - - {:Return string with identificator of SSL/TLS version of existing - connection.} - function GetSSLVersion: string; virtual; - - {:Return subject of remote SSL peer.} - function GetPeerSubject: string; virtual; - - {:Return issuer certificate of remote SSL peer.} - function GetPeerIssuer: string; virtual; - - {:Return peer name from remote side certificate. This is good for verify, - if certificate is generated for remote side IP name.} - function GetPeerName: string; virtual; - - {:Return fingerprint of remote SSL peer.} - function GetPeerFingerprint: string; virtual; - - {:Return all detailed information about certificate from remote side of - SSL/TLS connection. Result string can be multilined! Each plugin can return - this informations in different format!} - function GetCertInfo: string; virtual; - - {:Return currently used Cipher.} - function GetCipherName: string; virtual; - - {:Return currently used number of bits in current Cipher algorythm.} - function GetCipherBits: integer; virtual; - - {:Return number of bits in current Cipher algorythm.} - function GetCipherAlgBits: integer; virtual; - - {:Return result value of verify remote side certificate. Look to OpenSSL - documentation for possible values. For example 0 is successfuly verified - certificate, or 18 is self-signed certificate.} - function GetVerifyCert: integer; virtual; - - {: Resurn @true if SSL mode is enabled on existing cvonnection.} - property SSLEnabled: Boolean read FSSLEnabled; - - {:Return error code of last SSL operation. 0 is OK.} - property LastError: integer read FLastError; - - {:Return error description of last SSL operation.} - property LastErrorDesc: string read FLastErrorDesc; - published - {:Here you can specify requested SSL/TLS mode. Default is autodetection, but - on some servers autodetection not working properly. In this case you must - specify requested SSL/TLS mode by your hand!} - property SSLType: TSSLType read FSSLType write FSSLType; - - {:Password for decrypting of encoded certificate or key.} - property KeyPassword: string read FKeyPassword write FKeyPassword; - - {:Username for possible credentials.} - property Username: string read FUsername write FUsername; - - {:password for possible credentials.} - property Password: string read FPassword write FPassword; - - {:By this property you can modify default set of SSL/TLS ciphers.} - property Ciphers: string read FCiphers write FCiphers; - - {:Used for loading certificate from disk file. See to plugin documentation - if this method is supported and how!} - property CertificateFile: string read FCertificateFile write FCertificateFile; - - {:Used for loading private key from disk file. See to plugin documentation - if this method is supported and how!} - property PrivateKeyFile: string read FPrivateKeyFile write FPrivateKeyFile; - - {:Used for loading certificate from binary string. See to plugin documentation - if this method is supported and how!} - property Certificate: Ansistring read FCertificate write FCertificate; - - {:Used for loading private key from binary string. See to plugin documentation - if this method is supported and how!} - property PrivateKey: Ansistring read FPrivateKey write FPrivateKey; - - {:Used for loading PFX from binary string. See to plugin documentation - if this method is supported and how!} - property PFX: Ansistring read FPFX write FPFX; - - {:Used for loading PFX from disk file. See to plugin documentation - if this method is supported and how!} - property PFXfile: string read FPFXfile write FPFXfile; - - {:Used for loading trusted certificates from disk file. See to plugin documentation - if this method is supported and how!} - property TrustCertificateFile: string read FTrustCertificateFile write FTrustCertificateFile; - - {:Used for loading trusted certificates from binary string. See to plugin documentation - if this method is supported and how!} - property TrustCertificate: Ansistring read FTrustCertificate write FTrustCertificate; - - {:Used for loading CA certificates from binary string. See to plugin documentation - if this method is supported and how!} - property CertCA: Ansistring read FCertCA write FCertCA; - - {:Used for loading CA certificates from disk file. See to plugin documentation - if this method is supported and how!} - property CertCAFile: string read FCertCAFile write FCertCAFile; - - {:If @true, then is verified client certificate. (it is good for writing - SSL/TLS servers.) When you are not server, but you are client, then if this - property is @true, verify servers certificate.} - property VerifyCert: Boolean read FVerifyCert write FVerifyCert; - - {:channel type for possible SSH connections} - property SSHChannelType: string read FSSHChannelType write FSSHChannelType; - - {:First argument of channel type for possible SSH connections} - property SSHChannelArg1: string read FSSHChannelArg1 write FSSHChannelArg1; - - {:Second argument of channel type for possible SSH connections} - property SSHChannelArg2: string read FSSHChannelArg2 write FSSHChannelArg2; - end; - - {:@abstract(Default SSL plugin with no SSL support.) - Dummy SSL plugin implementation for applications without SSL/TLS support.} - TSSLNone = class (TCustomSSL) - public - {:See @inherited} - function LibVersion: String; override; - {:See @inherited} - function LibName: String; override; - end; - - {:@abstract(Record with definition of IP packet header.) - For reading data from ICMP or RAW sockets.} - TIPHeader = record - VerLen: Byte; - TOS: Byte; - TotalLen: Word; - Identifer: Word; - FragOffsets: Word; - TTL: Byte; - Protocol: Byte; - CheckSum: Word; - SourceIp: LongWord; - DestIp: LongWord; - Options: LongWord; - end; - - {:@abstract(Parent class of application protocol implementations.) - By this class is defined common properties.} - TSynaClient = Class(TObject) - protected - FTargetHost: string; - FTargetPort: string; - FIPInterface: string; - FTimeout: integer; - FUserName: string; - FPassword: string; - public - constructor Create; - published - {:Specify terget server IP (or symbolic name). Default is 'localhost'.} - property TargetHost: string read FTargetHost Write FTargetHost; - - {:Specify terget server port (or symbolic name).} - property TargetPort: string read FTargetPort Write FTargetPort; - - {:Defined local socket address. (outgoing IP address). By default is used - '0.0.0.0' as wildcard for default IP.} - property IPInterface: string read FIPInterface Write FIPInterface; - - {:Specify default timeout for socket operations.} - property Timeout: integer read FTimeout Write FTimeout; - - {:If protocol need user authorization, then fill here username.} - property UserName: string read FUserName Write FUserName; - - {:If protocol need user authorization, then fill here password.} - property Password: string read FPassword Write FPassword; - end; - -var - {:Selected SSL plugin. Default is @link(TSSLNone). - - Do not change this value directly!!! - - Just add your plugin unit to your project uses instead. Each plugin unit have - initialization code what modify this variable.} - SSLImplementation: TSSLClass = TSSLNone; - -implementation - -{$IFDEF ONCEWINSOCK} -var - WsaDataOnce: TWSADATA; - e: ESynapseError; -{$ENDIF} - - -constructor TBlockSocket.Create; -begin - CreateAlternate(''); -end; - -constructor TBlockSocket.CreateAlternate(Stub: string); -{$IFNDEF ONCEWINSOCK} -var - e: ESynapseError; -{$ENDIF} -begin - inherited Create; - FDelayedOptions := TList.Create; - FRaiseExcept := False; -{$IFDEF RAISEEXCEPT} - FRaiseExcept := True; -{$ENDIF} - FSocket := INVALID_SOCKET; - FBuffer := ''; - FLastCR := False; - FLastLF := False; - FBinded := False; - FNonBlockMode := False; - FMaxLineLength := 0; - FMaxSendBandwidth := 0; - FNextSend := 0; - FMaxRecvBandwidth := 0; - FNextRecv := 0; - FConvertLineEnd := False; - FFamily := SF_Any; - FFamilySave := SF_Any; - FIP6used := False; - FPreferIP4 := True; - FInterPacketTimeout := True; - FRecvCounter := 0; - FSendCounter := 0; - FSendMaxChunk := c64k; - FStopFlag := False; - FNonblockSendTimeout := 15000; - FHeartbeatRate := 0; - FOwner := nil; -{$IFNDEF ONCEWINSOCK} - if Stub = '' then - Stub := DLLStackName; - if not InitSocketInterface(Stub) then - begin - e := ESynapseError.Create('Error loading Socket interface (' + Stub + ')!'); - e.ErrorCode := 0; - e.ErrorMessage := 'Error loading Socket interface (' + Stub + ')!'; - raise e; - end; - SockCheck(synsock.WSAStartup(WinsockLevel, FWsaDataOnce)); - ExceptCheck; -{$ENDIF} -end; - -destructor TBlockSocket.Destroy; -var - n: integer; - p: TSynaOption; -begin - CloseSocket; -{$IFNDEF ONCEWINSOCK} - synsock.WSACleanup; - DestroySocketInterface; -{$ENDIF} - for n := FDelayedOptions.Count - 1 downto 0 do - begin - p := TSynaOption(FDelayedOptions[n]); - p.Free; - end; - FDelayedOptions.Free; - inherited Destroy; -end; - -function TBlockSocket.FamilyToAF(f: TSocketFamily): TAddrFamily; -begin - case f of - SF_ip4: - Result := AF_INET; - SF_ip6: - Result := AF_INET6; - else - Result := AF_UNSPEC; - end; -end; - -procedure TBlockSocket.SetDelayedOption(const Value: TSynaOption); -var - li: TLinger; - x: integer; - buf: TMemory; -{$IFNDEF MSWINDOWS} - timeval: TTimeval; -{$ENDIF} -begin - case value.Option of - SOT_Linger: - begin - {$IFDEF CIL} - li := TLinger.Create(Value.Enabled, Value.Value div 1000); - synsock.SetSockOptObj(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), li); - {$ELSE} - li.l_onoff := Ord(Value.Enabled); - li.l_linger := Value.Value div 1000; - buf := @li; - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), buf, SizeOf(li)); - {$ENDIF} - end; - SOT_RecvBuff: - begin - {$IFDEF CIL} - buf := System.BitConverter.GetBytes(value.Value); - {$ELSE} - buf := @Value.Value; - {$ENDIF} - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF), - buf, SizeOf(Value.Value)); - end; - SOT_SendBuff: - begin - {$IFDEF CIL} - buf := System.BitConverter.GetBytes(value.Value); - {$ELSE} - buf := @Value.Value; - {$ENDIF} - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF), - buf, SizeOf(Value.Value)); - end; - SOT_NonBlock: - begin - FNonBlockMode := Value.Enabled; - x := Ord(FNonBlockMode); - synsock.IoctlSocket(FSocket, FIONBIO, x); - end; - SOT_RecvTimeout: - begin - {$IFDEF CIL} - buf := System.BitConverter.GetBytes(value.Value); - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO), - buf, SizeOf(Value.Value)); - {$ELSE} - {$IFDEF MSWINDOWS} - buf := @Value.Value; - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO), - buf, SizeOf(Value.Value)); - {$ELSE} - timeval.tv_sec:=Value.Value div 1000; - timeval.tv_usec:=(Value.Value mod 1000) * 1000; - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO), - @timeval, SizeOf(timeval)); - {$ENDIF} - {$ENDIF} - end; - SOT_SendTimeout: - begin - {$IFDEF CIL} - buf := System.BitConverter.GetBytes(value.Value); - {$ELSE} - {$IFDEF MSWINDOWS} - buf := @Value.Value; - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO), - buf, SizeOf(Value.Value)); - {$ELSE} - timeval.tv_sec:=Value.Value div 1000; - timeval.tv_usec:=(Value.Value mod 1000) * 1000; - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO), - @timeval, SizeOf(timeval)); - {$ENDIF} - {$ENDIF} - end; - SOT_Reuse: - begin - x := Ord(Value.Enabled); - {$IFDEF CIL} - buf := System.BitConverter.GetBytes(x); - {$ELSE} - buf := @x; - {$ENDIF} - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_REUSEADDR), buf, SizeOf(x)); - end; - SOT_TTL: - begin - {$IFDEF CIL} - buf := System.BitConverter.GetBytes(value.Value); - {$ELSE} - buf := @Value.Value; - {$ENDIF} - if FIP6Used then - synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_UNICAST_HOPS), - buf, SizeOf(Value.Value)) - else - synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_TTL), - buf, SizeOf(Value.Value)); - end; - SOT_Broadcast: - begin -//#todo1 broadcasty na IP6 - x := Ord(Value.Enabled); - {$IFDEF CIL} - buf := System.BitConverter.GetBytes(x); - {$ELSE} - buf := @x; - {$ENDIF} - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_BROADCAST), buf, SizeOf(x)); - end; - SOT_MulticastTTL: - begin - {$IFDEF CIL} - buf := System.BitConverter.GetBytes(value.Value); - {$ELSE} - buf := @Value.Value; - {$ENDIF} - if FIP6Used then - synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_HOPS), - buf, SizeOf(Value.Value)) - else - synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_TTL), - buf, SizeOf(Value.Value)); - end; - SOT_MulticastLoop: - begin - x := Ord(Value.Enabled); - {$IFDEF CIL} - buf := System.BitConverter.GetBytes(x); - {$ELSE} - buf := @x; - {$ENDIF} - if FIP6Used then - synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_LOOP), buf, SizeOf(x)) - else - synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_LOOP), buf, SizeOf(x)); - end; - end; - Value.free; -end; - -procedure TBlockSocket.DelayedOption(const Value: TSynaOption); -begin - if FSocket = INVALID_SOCKET then - begin - FDelayedOptions.Insert(0, Value); - end - else - SetDelayedOption(Value); -end; - -procedure TBlockSocket.ProcessDelayedOptions; -var - n: integer; - d: TSynaOption; -begin - for n := FDelayedOptions.Count - 1 downto 0 do - begin - d := TSynaOption(FDelayedOptions[n]); - SetDelayedOption(d); - end; - FDelayedOptions.Clear; -end; - -procedure TBlockSocket.SetSin(var Sin: TVarSin; IP, Port: string); -var - f: TSocketFamily; -begin - DoStatus(HR_ResolvingBegin, IP + ':' + Port); - ResetLastError; - //if socket exists, then use their type, else use users selection - f := SF_Any; - if (FSocket = INVALID_SOCKET) and (FFamily = SF_any) then - begin - if IsIP(IP) then - f := SF_IP4 - else - if IsIP6(IP) then - f := SF_IP6; - end - else - f := FFamily; - FLastError := synsock.SetVarSin(sin, ip, port, FamilyToAF(f), - GetSocketprotocol, GetSocketType, FPreferIP4); - DoStatus(HR_ResolvingEnd, GetSinIP(sin) + ':' + IntTostr(GetSinPort(sin))); -end; - -function TBlockSocket.GetSinIP(Sin: TVarSin): string; -begin - Result := synsock.GetSinIP(sin); -end; - -function TBlockSocket.GetSinPort(Sin: TVarSin): Integer; -begin - Result := synsock.GetSinPort(sin); -end; - -procedure TBlockSocket.CreateSocket; -var - sin: TVarSin; -begin - //dummy for SF_Any Family mode - ResetLastError; - if (FFamily <> SF_Any) and (FSocket = INVALID_SOCKET) then - begin - {$IFDEF CIL} - if FFamily = SF_IP6 then - sin := TVarSin.Create(IPAddress.Parse('::0'), 0) - else - sin := TVarSin.Create(IPAddress.Parse('0.0.0.0'), 0); - {$ELSE} - FillChar(Sin, Sizeof(Sin), 0); - if FFamily = SF_IP6 then - sin.sin_family := AF_INET6 - else - sin.sin_family := AF_INET; - {$ENDIF} - InternalCreateSocket(Sin); - end; -end; - -procedure TBlockSocket.CreateSocketByName(const Value: String); -var - sin: TVarSin; -begin - ResetLastError; - if FSocket = INVALID_SOCKET then - begin - SetSin(sin, value, '0'); - if FLastError = 0 then - InternalCreateSocket(Sin); - end; -end; - -procedure TBlockSocket.InternalCreateSocket(Sin: TVarSin); -begin - FStopFlag := False; - FRecvCounter := 0; - FSendCounter := 0; - ResetLastError; - if FSocket = INVALID_SOCKET then - begin - FBuffer := ''; - FBinded := False; - FIP6Used := Sin.AddressFamily = AF_INET6; - FSocket := synsock.Socket(integer(Sin.AddressFamily), GetSocketType, GetSocketProtocol); - if FSocket = INVALID_SOCKET then - FLastError := synsock.WSAGetLastError; - {$IFNDEF CIL} - FD_ZERO(FFDSet); - FD_SET(FSocket, FFDSet); - {$ENDIF} - ExceptCheck; - if FIP6used then - DoStatus(HR_SocketCreate, 'IPv6') - else - DoStatus(HR_SocketCreate, 'IPv4'); - ProcessDelayedOptions; - DoCreateSocket; - end; -end; - -procedure TBlockSocket.CloseSocket; -begin - AbortSocket; -end; - -procedure TBlockSocket.AbortSocket; -var - n: integer; - p: TSynaOption; -begin - if FSocket <> INVALID_SOCKET then - synsock.CloseSocket(FSocket); - FSocket := INVALID_SOCKET; - for n := FDelayedOptions.Count - 1 downto 0 do - begin - p := TSynaOption(FDelayedOptions[n]); - p.Free; - end; - FDelayedOptions.Clear; - FFamily := FFamilySave; - DoStatus(HR_SocketClose, ''); -end; - -procedure TBlockSocket.Bind(IP, Port: string); -var - Sin: TVarSin; -begin - ResetLastError; - if (FSocket <> INVALID_SOCKET) - or not((FFamily = SF_ANY) and (IP = cAnyHost) and (Port = cAnyPort)) then - begin - SetSin(Sin, IP, Port); - if FLastError = 0 then - begin - if FSocket = INVALID_SOCKET then - InternalCreateSocket(Sin); - SockCheck(synsock.Bind(FSocket, Sin)); - GetSinLocal; - FBuffer := ''; - FBinded := True; - end; - ExceptCheck; - DoStatus(HR_Bind, IP + ':' + Port); - end; -end; - -procedure TBlockSocket.Connect(IP, Port: string); -var - Sin: TVarSin; -begin - SetSin(Sin, IP, Port); - if FLastError = 0 then - begin - if FSocket = INVALID_SOCKET then - InternalCreateSocket(Sin); - SockCheck(synsock.Connect(FSocket, Sin)); - if FLastError = 0 then - GetSins; - FBuffer := ''; - FLastCR := False; - FLastLF := False; - end; - ExceptCheck; - DoStatus(HR_Connect, IP + ':' + Port); -end; - -procedure TBlockSocket.Listen; -begin - SockCheck(synsock.Listen(FSocket, SOMAXCONN)); - GetSins; - ExceptCheck; - DoStatus(HR_Listen, ''); -end; - -function TBlockSocket.Accept: TSocket; -begin - Result := synsock.Accept(FSocket, FRemoteSin); -/// SockCheck(Result); - ExceptCheck; - DoStatus(HR_Accept, ''); -end; - -procedure TBlockSocket.GetSinLocal; -begin - synsock.GetSockName(FSocket, FLocalSin); -end; - -procedure TBlockSocket.GetSinRemote; -begin - synsock.GetPeerName(FSocket, FRemoteSin); -end; - -procedure TBlockSocket.GetSins; -begin - GetSinLocal; - GetSinRemote; -end; - -procedure TBlockSocket.SetBandwidth(Value: Integer); -begin - MaxSendBandwidth := Value; - MaxRecvBandwidth := Value; -end; - -procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); -var - x: LongWord; - y: LongWord; - n: integer; -begin - if FStopFlag then - exit; - 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 mod 250); - for n := 1 to x div 250 do - if FStopFlag then - Break - else - sleep(250); - end; - end; - Next := GetTick + Trunc((Length / MaxB) * 1000); - end; -end; - -function TBlockSocket.TestStopFlag: Boolean; -begin - DoHeartbeat; - Result := FStopFlag; - if Result then - begin - FStopFlag := False; - FLastError := WSAECONNABORTED; - ExceptCheck; - end; -end; - - -function TBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; -{$IFNDEF CIL} -var - x, y: integer; - l, r: integer; - p: Pointer; -{$ENDIF} -begin - Result := 0; - if TestStopFlag then - Exit; - DoMonitor(True, Buffer, Length); -{$IFDEF CIL} - Result := synsock.Send(FSocket, Buffer, Length, 0); -{$ELSE} - l := Length; - x := 0; - while x < l do - begin - y := l - x; - if y > FSendMaxChunk then - y := FSendMaxChunk; - if y > 0 then - begin - LimitBandwidth(y, FMaxSendBandwidth, FNextsend); - p := IncPoint(Buffer, x); - r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL); - SockCheck(r); - if FLastError = WSAEWOULDBLOCK then - begin - if CanWrite(FNonblockSendTimeout) then - begin - r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL); - SockCheck(r); - end - else - FLastError := WSAETIMEDOUT; - end; - if FLastError <> 0 then - Break; - Inc(x, r); - Inc(Result, r); - Inc(FSendCounter, r); - DoStatus(HR_WriteCount, IntToStr(r)); - end - else - break; - end; -{$ENDIF} - ExceptCheck; -end; - -procedure TBlockSocket.SendByte(Data: Byte); -{$IFDEF CIL} -var - buf: TMemory; -{$ENDIF} -begin -{$IFDEF CIL} - setlength(buf, 1); - buf[0] := Data; - SendBuffer(buf, 1); -{$ELSE} - SendBuffer(@Data, 1); -{$ENDIF} -end; - -procedure TBlockSocket.SendString(Data: AnsiString); -var - buf: TMemory; -begin - {$IFDEF CIL} - buf := BytesOf(Data); - {$ELSE} - buf := Pointer(data); - {$ENDIF} - SendBuffer(buf, Length(Data)); -end; - -procedure TBlockSocket.SendInteger(Data: integer); -var - buf: TMemory; -begin - {$IFDEF CIL} - buf := System.BitConverter.GetBytes(Data); - {$ELSE} - buf := @Data; - {$ENDIF} - SendBuffer(buf, SizeOf(Data)); -end; - -procedure TBlockSocket.SendBlock(const Data: AnsiString); -var - i: integer; -begin - i := SwapBytes(Length(data)); - SendString(Codelongint(i) + Data); -end; - -procedure TBlockSocket.InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); -var - l: integer; - yr: integer; - s: AnsiString; - b: boolean; -{$IFDEF CIL} - buf: TMemory; -{$ENDIF} -begin - b := true; - l := 0; - if WithSize then - begin - l := Stream.Size - Stream.Position;; - if not Indy then - l := synsock.HToNL(l); - end; - repeat - {$IFDEF CIL} - Setlength(buf, FSendMaxChunk); - yr := Stream.read(buf, FSendMaxChunk); - if yr > 0 then - begin - if WithSize and b then - begin - b := false; - SendString(CodeLongInt(l)); - end; - SendBuffer(buf, yr); - if FLastError <> 0 then - break; - end - {$ELSE} - Setlength(s, FSendMaxChunk); - yr := Stream.read(Pointer(s)^, FSendMaxChunk); - if yr > 0 then - begin - SetLength(s, yr); - if WithSize and b then - begin - b := false; - SendString(CodeLongInt(l) + s); - end - else - SendString(s); - if FLastError <> 0 then - break; - end - {$ENDIF} - until yr <= 0; -end; - -procedure TBlockSocket.SendStreamRaw(const Stream: TStream); -begin - InternalSendStream(Stream, false, false); -end; - -procedure TBlockSocket.SendStreamIndy(const Stream: TStream); -begin - InternalSendStream(Stream, true, true); -end; - -procedure TBlockSocket.SendStream(const Stream: TStream); -begin - InternalSendStream(Stream, true, false); -end; - -function TBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer; -begin - Result := 0; - if TestStopFlag then - Exit; - LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); -// Result := synsock.Recv(FSocket, Buffer^, Length, MSG_NOSIGNAL); - Result := synsock.Recv(FSocket, Buffer, Length, MSG_NOSIGNAL); - if Result = 0 then - FLastError := WSAECONNRESET - else - SockCheck(Result); - ExceptCheck; - if Result > 0 then - begin - Inc(FRecvCounter, Result); - DoStatus(HR_ReadCount, IntToStr(Result)); - DoMonitor(False, Buffer, Result); - DoReadFilter(Buffer, Result); - end; -end; - -function TBlockSocket.RecvBufferEx(Buffer: TMemory; Len: Integer; - Timeout: Integer): Integer; -var - s: AnsiString; - rl, l: integer; - ti: LongWord; -{$IFDEF CIL} - n: integer; - b: TMemory; -{$ENDIF} -begin - ResetLastError; - Result := 0; - if Len > 0 then - begin - rl := 0; - repeat - ti := GetTick; - s := RecvPacket(Timeout); - l := Length(s); - if (rl + l) > Len then - l := Len - rl; - {$IFDEF CIL} - b := BytesOf(s); - for n := 0 to l do - Buffer[rl + n] := b[n]; - {$ELSE} - Move(Pointer(s)^, IncPoint(Buffer, rl)^, l); - {$ENDIF} - rl := rl + l; - if FLastError <> 0 then - Break; - if rl >= Len then - Break; - if not FInterPacketTimeout then - begin - Timeout := Timeout - integer(TickDelta(ti, GetTick)); - if Timeout <= 0 then - begin - FLastError := WSAETIMEDOUT; - Break; - end; - end; - until False; - delete(s, 1, l); - FBuffer := s; - Result := rl; - end; -end; - -function TBlockSocket.RecvBufferStr(Len: Integer; Timeout: Integer): AnsiString; -var - x: integer; -{$IFDEF CIL} - buf: Tmemory; -{$ENDIF} -begin - Result := ''; - if Len > 0 then - begin - {$IFDEF CIL} - Setlength(Buf, Len); - x := RecvBufferEx(buf, Len , Timeout); - if FLastError = 0 then - begin - SetLength(Buf, x); - Result := StringOf(buf); - end - else - Result := ''; - {$ELSE} - Setlength(Result, Len); - x := RecvBufferEx(Pointer(Result), Len , Timeout); - if FLastError = 0 then - SetLength(Result, x) - else - Result := ''; - {$ENDIF} - end; -end; - -function TBlockSocket.RecvPacket(Timeout: Integer): AnsiString; -var - x: integer; -{$IFDEF CIL} - buf: TMemory; -{$ENDIF} -begin - Result := ''; - ResetLastError; - if FBuffer <> '' then - begin - Result := FBuffer; - FBuffer := ''; - end - else - begin - {$IFDEF MSWINDOWS} - //not drain CPU on large downloads... - Sleep(0); - {$ENDIF} - x := WaitingData; - if x > 0 then - begin - {$IFDEF CIL} - SetLength(Buf, x); - x := RecvBuffer(Buf, x); - if x >= 0 then - begin - SetLength(Buf, x); - Result := StringOf(Buf); - end; - {$ELSE} - SetLength(Result, x); - x := RecvBuffer(Pointer(Result), x); - if x >= 0 then - SetLength(Result, x); - {$ENDIF} - end - else - begin - if CanRead(Timeout) then - begin - x := WaitingData; - if x = 0 then - FLastError := WSAECONNRESET; - if x > 0 then - begin - {$IFDEF CIL} - SetLength(Buf, x); - x := RecvBuffer(Buf, x); - if x >= 0 then - begin - SetLength(Buf, x); - result := StringOf(Buf); - end; - {$ELSE} - SetLength(Result, x); - x := RecvBuffer(Pointer(Result), x); - if x >= 0 then - SetLength(Result, x); - {$ENDIF} - end; - end - else - FLastError := WSAETIMEDOUT; - end; - end; - if FConvertLineEnd and (Result <> '') then - begin - if FLastCR and (Result[1] = LF) then - Delete(Result, 1, 1); - if FLastLF and (Result[1] = CR) then - Delete(Result, 1, 1); - FLastCR := False; - FLastLF := False; - end; - ExceptCheck; -end; - - -function TBlockSocket.RecvByte(Timeout: Integer): Byte; -begin - Result := 0; - ResetLastError; - if FBuffer = '' then - FBuffer := RecvPacket(Timeout); - if (FLastError = 0) and (FBuffer <> '') then - begin - Result := Ord(FBuffer[1]); - Delete(FBuffer, 1, 1); - end; - ExceptCheck; -end; - -function TBlockSocket.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 TBlockSocket.RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; -var - x: Integer; - s: AnsiString; - l: Integer; - CorCRLF: Boolean; - t: AnsiString; - tl: integer; - ti: LongWord; -begin - ResetLastError; - Result := ''; - l := Length(Terminator); - if l = 0 then - Exit; - tl := l; - CorCRLF := FConvertLineEnd and (Terminator = CRLF); - s := ''; - x := 0; - repeat - //get rest of FBuffer or incomming new data... - ti := GetTick; - s := s + RecvPacket(Timeout); - if FLastError <> 0 then - Break; - x := 0; - if Length(s) > 0 then - if CorCRLF then - begin - t := ''; - x := PosCRLF(s, t); - tl := 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 (Length(s) > FMaxLineLength) then - begin - FLastError := WSAENOBUFS; - Break; - end; - if x > 0 then - Break; - if not FInterPacketTimeout then - begin - Timeout := Timeout - integer(TickDelta(ti, GetTick)); - if Timeout <= 0 then - begin - FLastError := WSAETIMEDOUT; - Break; - end; - end; - until False; - if x > 0 then - begin - Result := Copy(s, 1, x - 1); - Delete(s, 1, x + tl - 1); - end; - FBuffer := s; - ExceptCheck; -end; - -function TBlockSocket.RecvString(Timeout: Integer): AnsiString; -var - s: AnsiString; -begin - Result := ''; - s := RecvTerminated(Timeout, CRLF); - if FLastError = 0 then - Result := s; -end; - -function TBlockSocket.RecvBlock(Timeout: Integer): AnsiString; -var - x: integer; -begin - Result := ''; - x := RecvInteger(Timeout); - if FLastError = 0 then - Result := RecvBufferStr(x, Timeout); -end; - -procedure TBlockSocket.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 TBlockSocket.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); -var - s: AnsiString; - n: integer; -{$IFDEF CIL} - buf: TMemory; -{$ENDIF} -begin - for n := 1 to (Size div FSendMaxChunk) do - begin - {$IFDEF CIL} - SetLength(buf, FSendMaxChunk); - RecvBufferEx(buf, FSendMaxChunk, Timeout); - if FLastError <> 0 then - Exit; - Stream.Write(buf, FSendMaxChunk); - {$ELSE} - s := RecvBufferStr(FSendMaxChunk, Timeout); - if FLastError <> 0 then - Exit; - WriteStrToStream(Stream, s); - {$ENDIF} - end; - n := Size mod FSendMaxChunk; - if n > 0 then - begin - {$IFDEF CIL} - SetLength(buf, n); - RecvBufferEx(buf, n, Timeout); - if FLastError <> 0 then - Exit; - Stream.Write(buf, n); - {$ELSE} - s := RecvBufferStr(n, Timeout); - if FLastError <> 0 then - Exit; - WriteStrToStream(Stream, s); - {$ENDIF} - end; -end; - -procedure TBlockSocket.RecvStreamIndy(const Stream: TStream; Timeout: Integer); -var - x: integer; -begin - x := RecvInteger(Timeout); - x := synsock.NToHL(x); - if FLastError = 0 then - RecvStreamSize(Stream, Timeout, x); -end; - -procedure TBlockSocket.RecvStream(const Stream: TStream; Timeout: Integer); -var - x: integer; -begin - x := RecvInteger(Timeout); - if FLastError = 0 then - RecvStreamSize(Stream, Timeout, x); -end; - -function TBlockSocket.PeekBuffer(Buffer: TMemory; Length: Integer): Integer; -begin - {$IFNDEF CIL} -// Result := synsock.Recv(FSocket, Buffer^, Length, MSG_PEEK + MSG_NOSIGNAL); - Result := synsock.Recv(FSocket, Buffer, Length, MSG_PEEK + MSG_NOSIGNAL); - SockCheck(Result); - ExceptCheck; - {$ENDIF} -end; - -function TBlockSocket.PeekByte(Timeout: Integer): Byte; -var - s: string; -begin - {$IFNDEF CIL} - Result := 0; - if CanRead(Timeout) then - begin - SetLength(s, 1); - PeekBuffer(Pointer(s), 1); - if s <> '' then - Result := Ord(s[1]); - end - else - FLastError := WSAETIMEDOUT; - ExceptCheck; - {$ENDIF} -end; - -procedure TBlockSocket.ResetLastError; -begin - FLastError := 0; - FLastErrorDesc := ''; -end; - -function TBlockSocket.SockCheck(SockResult: Integer): Integer; -begin - ResetLastError; - if SockResult = integer(SOCKET_ERROR) then - begin - FLastError := synsock.WSAGetLastError; - FLastErrorDesc := GetErrorDescEx; - end; - Result := FLastError; -end; - -procedure TBlockSocket.ExceptCheck; -var - e: ESynapseError; -begin - FLastErrorDesc := GetErrorDescEx; - if (LastError <> 0) and (LastError <> WSAEINPROGRESS) - and (LastError <> WSAEWOULDBLOCK) then - begin - DoStatus(HR_Error, IntToStr(FLastError) + ',' + FLastErrorDesc); - if FRaiseExcept then - begin - e := ESynapseError.Create(Format('Synapse TCP/IP Socket error %d: %s', - [FLastError, FLastErrorDesc])); - e.ErrorCode := FLastError; - e.ErrorMessage := FLastErrorDesc; - raise e; - end; - end; -end; - -function TBlockSocket.WaitingData: Integer; -var - x: Integer; -begin - Result := 0; - if synsock.IoctlSocket(FSocket, FIONREAD, x) = 0 then - Result := x; - if Result > c64k then - Result := c64k; -end; - -function TBlockSocket.WaitingDataEx: Integer; -begin - if FBuffer <> '' then - Result := Length(FBuffer) - else - Result := WaitingData; -end; - -procedure TBlockSocket.Purge; -begin - Sleep(1); - try - while (Length(FBuffer) > 0) or (WaitingData > 0) do - begin - RecvPacket(0); - if FLastError <> 0 then - break; - end; - except - on exception do; - end; - ResetLastError; -end; - -procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_Linger; - d.Enabled := Enable; - d.Value := Linger; - DelayedOption(d); -end; - -function TBlockSocket.LocalName: string; -begin - Result := synsock.GetHostName; - if Result = '' then - Result := '127.0.0.1'; -end; - -procedure TBlockSocket.ResolveNameToIP(Name: string; const IPList: TStrings); -begin - IPList.Clear; - synsock.ResolveNameToIP(Name, FamilyToAF(FFamily), GetSocketprotocol, GetSocketType, IPList); - if IPList.Count = 0 then - IPList.Add(cAnyHost); -end; - -function TBlockSocket.ResolveName(Name: string): string; -var - l: TStringList; -begin - l := TStringList.Create; - try - ResolveNameToIP(Name, l); - Result := l[0]; - finally - l.Free; - end; -end; - -function TBlockSocket.ResolvePort(Port: string): Word; -begin - Result := synsock.ResolvePort(Port, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType); -end; - -function TBlockSocket.ResolveIPToName(IP: string): string; -begin - if not IsIP(IP) or not IsIp6(IP) then - IP := ResolveName(IP); - Result := synsock.ResolveIPToName(IP, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType); -end; - -procedure TBlockSocket.SetRemoteSin(IP, Port: string); -begin - SetSin(FRemoteSin, IP, Port); -end; - -function TBlockSocket.GetLocalSinIP: string; -begin - Result := GetSinIP(FLocalSin); -end; - -function TBlockSocket.GetRemoteSinIP: string; -begin - Result := GetSinIP(FRemoteSin); -end; - -function TBlockSocket.GetLocalSinPort: Integer; -begin - Result := GetSinPort(FLocalSin); -end; - -function TBlockSocket.GetRemoteSinPort: Integer; -begin - Result := GetSinPort(FRemoteSin); -end; - -function TBlockSocket.InternalCanRead(Timeout: Integer): Boolean; -{$IFDEF CIL} -begin - Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectRead); -{$ELSE} -var - TimeVal: PTimeVal; - TimeV: TTimeVal; - x: Integer; - FDSet: TFDSet; -begin - TimeV.tv_usec := (Timeout mod 1000) * 1000; - TimeV.tv_sec := Timeout div 1000; - TimeVal := @TimeV; - if Timeout = -1 then - TimeVal := nil; - FDSet := FFdSet; - x := synsock.Select(FSocket + 1, @FDSet, nil, nil, TimeVal); - SockCheck(x); - if FLastError <> 0 then - x := 0; - Result := x > 0; -{$ENDIF} -end; - -function TBlockSocket.CanRead(Timeout: Integer): Boolean; -var - ti, tr: Integer; - n: integer; -begin - if (FHeartbeatRate <> 0) and (Timeout <> -1) then - begin - ti := Timeout div FHeartbeatRate; - tr := Timeout mod FHeartbeatRate; - end - else - begin - ti := 0; - tr := Timeout; - end; - Result := InternalCanRead(tr); - if not Result then - for n := 0 to ti do - begin - DoHeartbeat; - if FStopFlag then - begin - Result := False; - FStopFlag := False; - Break; - end; - Result := InternalCanRead(FHeartbeatRate); - if Result then - break; - end; - ExceptCheck; - if Result then - DoStatus(HR_CanRead, ''); -end; - -function TBlockSocket.CanWrite(Timeout: Integer): Boolean; -{$IFDEF CIL} -begin - Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectWrite); -{$ELSE} -var - TimeVal: PTimeVal; - TimeV: TTimeVal; - x: Integer; - FDSet: TFDSet; -begin - TimeV.tv_usec := (Timeout mod 1000) * 1000; - TimeV.tv_sec := Timeout div 1000; - TimeVal := @TimeV; - if Timeout = -1 then - TimeVal := nil; - FDSet := FFdSet; - x := synsock.Select(FSocket + 1, nil, @FDSet, nil, TimeVal); - SockCheck(x); - if FLastError <> 0 then - x := 0; - Result := x > 0; -{$ENDIF} - ExceptCheck; - if Result then - DoStatus(HR_CanWrite, ''); -end; - -function TBlockSocket.CanReadEx(Timeout: Integer): Boolean; -begin - if FBuffer <> '' then - Result := True - else - Result := CanRead(Timeout); -end; - -function TBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer; -begin - Result := 0; - if TestStopFlag then - Exit; - DoMonitor(True, Buffer, Length); - LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); - Result := synsock.SendTo(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin); - SockCheck(Result); - ExceptCheck; - Inc(FSendCounter, Result); - DoStatus(HR_WriteCount, IntToStr(Result)); -end; - -function TBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; -begin - Result := 0; - if TestStopFlag then - Exit; - LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); - Result := synsock.RecvFrom(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin); - SockCheck(Result); - ExceptCheck; - Inc(FRecvCounter, Result); - DoStatus(HR_ReadCount, IntToStr(Result)); - DoMonitor(False, Buffer, Result); -end; - -function TBlockSocket.GetSizeRecvBuffer: Integer; -var - l: Integer; -{$IFDEF CIL} - buf: TMemory; -{$ENDIF} -begin -{$IFDEF CIL} - setlength(buf, 4); - SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF), buf, l)); - Result := System.BitConverter.ToInt32(buf,0); -{$ELSE} - l := SizeOf(Result); - SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_RCVBUF, @Result, l)); - if FLastError <> 0 then - Result := 1024; - ExceptCheck; -{$ENDIF} -end; - -procedure TBlockSocket.SetSizeRecvBuffer(Size: Integer); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_RecvBuff; - d.Value := Size; - DelayedOption(d); -end; - -function TBlockSocket.GetSizeSendBuffer: Integer; -var - l: Integer; -{$IFDEF CIL} - buf: TMemory; -{$ENDIF} -begin -{$IFDEF CIL} - setlength(buf, 4); - SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF), buf, l)); - Result := System.BitConverter.ToInt32(buf,0); -{$ELSE} - l := SizeOf(Result); - SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_SNDBUF, @Result, l)); - if FLastError <> 0 then - Result := 1024; - ExceptCheck; -{$ENDIF} -end; - -procedure TBlockSocket.SetSizeSendBuffer(Size: Integer); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_SendBuff; - d.Value := Size; - DelayedOption(d); -end; - -procedure TBlockSocket.SetNonBlockMode(Value: Boolean); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_nonblock; - d.Enabled := Value; - DelayedOption(d); -end; - -procedure TBlockSocket.SetTimeout(Timeout: Integer); -begin - SetSendTimeout(Timeout); - SetRecvTimeout(Timeout); -end; - -procedure TBlockSocket.SetSendTimeout(Timeout: Integer); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_sendtimeout; - d.Value := Timeout; - DelayedOption(d); -end; - -procedure TBlockSocket.SetRecvTimeout(Timeout: Integer); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_recvtimeout; - d.Value := Timeout; - DelayedOption(d); -end; - -{$IFNDEF CIL} -function TBlockSocket.GroupCanRead(const SocketList: TList; Timeout: Integer; - const CanReadList: TList): boolean; -var - FDSet: TFDSet; - TimeVal: PTimeVal; - TimeV: TTimeVal; - x, n: Integer; - Max: Integer; -begin - TimeV.tv_usec := (Timeout mod 1000) * 1000; - TimeV.tv_sec := Timeout div 1000; - TimeVal := @TimeV; - if Timeout = -1 then - TimeVal := nil; - FD_ZERO(FDSet); - Max := 0; - for n := 0 to SocketList.Count - 1 do - if TObject(SocketList.Items[n]) is TBlockSocket then - begin - if TBlockSocket(SocketList.Items[n]).Socket > Max then - Max := TBlockSocket(SocketList.Items[n]).Socket; - FD_SET(TBlockSocket(SocketList.Items[n]).Socket, FDSet); - end; - x := synsock.Select(Max + 1, @FDSet, nil, nil, TimeVal); - SockCheck(x); - ExceptCheck; - if FLastError <> 0 then - x := 0; - Result := x > 0; - CanReadList.Clear; - if Result then - for n := 0 to SocketList.Count - 1 do - if TObject(SocketList.Items[n]) is TBlockSocket then - if FD_ISSET(TBlockSocket(SocketList.Items[n]).Socket, FDSet) then - CanReadList.Add(TBlockSocket(SocketList.Items[n])); -end; -{$ENDIF} - -procedure TBlockSocket.EnableReuse(Value: Boolean); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_reuse; - d.Enabled := Value; - DelayedOption(d); -end; - -procedure TBlockSocket.SetTTL(TTL: integer); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_TTL; - d.Value := TTL; - DelayedOption(d); -end; - -function TBlockSocket.GetTTL:integer; -var - l: Integer; -begin -{$IFNDEF CIL} - l := SizeOf(Result); - if FIP6Used then - synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_UNICAST_HOPS, @Result, l) - else - synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_TTL, @Result, l); -{$ENDIF} -end; - -procedure TBlockSocket.SetFamily(Value: TSocketFamily); -begin - FFamily := Value; - FFamilySave := Value; -end; - -procedure TBlockSocket.SetSocket(Value: TSocket); -begin - FRecvCounter := 0; - FSendCounter := 0; - FSocket := Value; -{$IFNDEF CIL} - FD_ZERO(FFDSet); - FD_SET(FSocket, FFDSet); -{$ENDIF} - GetSins; - FIP6Used := FRemoteSin.AddressFamily = AF_INET6; -end; - -function TBlockSocket.GetWsaData: TWSAData; -begin - Result := WsaDataOnce; -end; - -function TBlockSocket.GetSocketType: integer; -begin - Result := 0; -end; - -function TBlockSocket.GetSocketProtocol: integer; -begin - Result := integer(IPPROTO_IP); -end; - -procedure TBlockSocket.DoStatus(Reason: THookSocketReason; const Value: string); -begin - if assigned(OnStatus) then - OnStatus(Self, Reason, Value); -end; - -procedure TBlockSocket.DoReadFilter(Buffer: TMemory; var Len: Integer); -var - s: AnsiString; -begin - if assigned(OnReadFilter) then - if Len > 0 then - begin - {$IFDEF CIL} - s := StringOf(Buffer); - {$ELSE} - SetLength(s, Len); - Move(Buffer^, Pointer(s)^, Len); - {$ENDIF} - OnReadFilter(Self, s); - if Length(s) > Len then - SetLength(s, Len); - Len := Length(s); - {$IFDEF CIL} - Buffer := BytesOf(s); - {$ELSE} - Move(Pointer(s)^, Buffer^, Len); - {$ENDIF} - end; -end; - -procedure TBlockSocket.DoCreateSocket; -begin - if assigned(OnCreateSocket) then - OnCreateSocket(Self); -end; - -procedure TBlockSocket.DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer); -begin - if assigned(OnMonitor) then - begin - OnMonitor(Self, Writing, Buffer, Len); - end; -end; - -procedure TBlockSocket.DoHeartbeat; -begin - if assigned(OnHeartbeat) and (FHeartbeatRate <> 0) then - begin - OnHeartbeat(Self); - end; -end; - -function TBlockSocket.GetErrorDescEx: string; -begin - Result := GetErrorDesc(FLastError); -end; - -class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string; -begin -{$IFDEF CIL} - if ErrorCode = 0 then - Result := '' - else - begin - Result := WSAGetLastErrorDesc; - if Result = '' then - Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')'; - end; -{$ELSE} - case ErrorCode of - 0: - Result := ''; - WSAEINTR: {10004} - Result := 'Interrupted system call'; - WSAEBADF: {10009} - Result := 'Bad file number'; - WSAEACCES: {10013} - Result := 'Permission denied'; - WSAEFAULT: {10014} - Result := 'Bad address'; - WSAEINVAL: {10022} - Result := 'Invalid argument'; - WSAEMFILE: {10024} - Result := 'Too many open files'; - WSAEWOULDBLOCK: {10035} - Result := 'Operation would block'; - WSAEINPROGRESS: {10036} - Result := 'Operation now in progress'; - WSAEALREADY: {10037} - Result := 'Operation already in progress'; - WSAENOTSOCK: {10038} - Result := 'Socket operation on nonsocket'; - WSAEDESTADDRREQ: {10039} - Result := 'Destination address required'; - WSAEMSGSIZE: {10040} - Result := 'Message too long'; - WSAEPROTOTYPE: {10041} - Result := 'Protocol wrong type for Socket'; - WSAENOPROTOOPT: {10042} - Result := 'Protocol not available'; - WSAEPROTONOSUPPORT: {10043} - Result := 'Protocol not supported'; - WSAESOCKTNOSUPPORT: {10044} - Result := 'Socket not supported'; - WSAEOPNOTSUPP: {10045} - Result := 'Operation not supported on Socket'; - WSAEPFNOSUPPORT: {10046} - Result := 'Protocol family not supported'; - WSAEAFNOSUPPORT: {10047} - Result := 'Address family not supported'; - WSAEADDRINUSE: {10048} - Result := 'Address already in use'; - WSAEADDRNOTAVAIL: {10049} - Result := 'Can''t assign requested address'; - WSAENETDOWN: {10050} - Result := 'Network is down'; - WSAENETUNREACH: {10051} - Result := 'Network is unreachable'; - WSAENETRESET: {10052} - Result := 'Network dropped connection on reset'; - WSAECONNABORTED: {10053} - Result := 'Software caused connection abort'; - WSAECONNRESET: {10054} - Result := 'Connection reset by peer'; - WSAENOBUFS: {10055} - Result := 'No Buffer space available'; - WSAEISCONN: {10056} - Result := 'Socket is already connected'; - WSAENOTCONN: {10057} - Result := 'Socket is not connected'; - WSAESHUTDOWN: {10058} - Result := 'Can''t send after Socket shutdown'; - WSAETOOMANYREFS: {10059} - Result := 'Too many references:can''t splice'; - WSAETIMEDOUT: {10060} - Result := 'Connection timed out'; - WSAECONNREFUSED: {10061} - Result := 'Connection refused'; - WSAELOOP: {10062} - Result := 'Too many levels of symbolic links'; - WSAENAMETOOLONG: {10063} - Result := 'File name is too long'; - WSAEHOSTDOWN: {10064} - Result := 'Host is down'; - WSAEHOSTUNREACH: {10065} - Result := 'No route to host'; - WSAENOTEMPTY: {10066} - Result := 'Directory is not empty'; - WSAEPROCLIM: {10067} - Result := 'Too many processes'; - WSAEUSERS: {10068} - Result := 'Too many users'; - WSAEDQUOT: {10069} - Result := 'Disk quota exceeded'; - WSAESTALE: {10070} - Result := 'Stale NFS file handle'; - WSAEREMOTE: {10071} - Result := 'Too many levels of remote in path'; - WSASYSNOTREADY: {10091} - Result := 'Network subsystem is unusable'; - WSAVERNOTSUPPORTED: {10092} - Result := 'Winsock DLL cannot support this application'; - WSANOTINITIALISED: {10093} - Result := 'Winsock not initialized'; - WSAEDISCON: {10101} - Result := 'Disconnect'; - WSAHOST_NOT_FOUND: {11001} - Result := 'Host not found'; - WSATRY_AGAIN: {11002} - Result := 'Non authoritative - host not found'; - WSANO_RECOVERY: {11003} - Result := 'Non recoverable error'; - WSANO_DATA: {11004} - Result := 'Valid name, no data record of requested type' - else - Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')'; - end; -{$ENDIF} -end; - -{======================================================================} - -constructor TSocksBlockSocket.Create; -begin - inherited Create; - FSocksIP:= ''; - FSocksPort:= '1080'; - FSocksTimeout:= 60000; - FSocksUsername:= ''; - FSocksPassword:= ''; - FUsingSocks := False; - FSocksResolver := True; - FSocksLastError := 0; - FSocksResponseIP := ''; - FSocksResponsePort := ''; - FSocksLocalIP := ''; - FSocksLocalPort := ''; - FSocksRemoteIP := ''; - FSocksRemotePort := ''; - FBypassFlag := False; - FSocksType := ST_Socks5; -end; - -function TSocksBlockSocket.SocksOpen: boolean; -var - Buf: AnsiString; - n: integer; -begin - Result := False; - FUsingSocks := False; - if FSocksType <> ST_Socks5 then - begin - FUsingSocks := True; - Result := True; - end - else - begin - FBypassFlag := True; - try - if FSocksUsername = '' then - Buf := #5 + #1 + #0 - else - Buf := #5 + #2 + #2 +#0; - SendString(Buf); - Buf := RecvBufferStr(2, FSocksTimeout); - if Length(Buf) < 2 then - Exit; - if Buf[1] <> #5 then - Exit; - n := Ord(Buf[2]); - case n of - 0: //not need authorisation - ; - 2: - begin - Buf := #1 + AnsiChar(Length(FSocksUsername)) + FSocksUsername - + AnsiChar(Length(FSocksPassword)) + FSocksPassword; - SendString(Buf); - Buf := RecvBufferStr(2, FSocksTimeout); - if Length(Buf) < 2 then - Exit; - if Buf[2] <> #0 then - Exit; - end; - else - //other authorisation is not supported! - Exit; - end; - FUsingSocks := True; - Result := True; - finally - FBypassFlag := False; - end; - end; -end; - -function TSocksBlockSocket.SocksRequest(Cmd: Byte; - const IP, Port: string): Boolean; -var - Buf: AnsiString; -begin - FBypassFlag := True; - try - if FSocksType <> ST_Socks5 then - Buf := #4 + AnsiChar(Cmd) + SocksCode(IP, Port) - else - Buf := #5 + AnsiChar(Cmd) + #0 + SocksCode(IP, Port); - SendString(Buf); - Result := FLastError = 0; - finally - FBypassFlag := False; - end; -end; - -function TSocksBlockSocket.SocksResponse: Boolean; -var - Buf, s: AnsiString; - x: integer; -begin - Result := False; - FBypassFlag := True; - try - FSocksResponseIP := ''; - FSocksResponsePort := ''; - FSocksLastError := -1; - if FSocksType <> ST_Socks5 then - begin - Buf := RecvBufferStr(8, FSocksTimeout); - if FLastError <> 0 then - Exit; - if Buf[1] <> #0 then - Exit; - FSocksLastError := Ord(Buf[2]); - end - else - begin - Buf := RecvBufferStr(4, FSocksTimeout); - if FLastError <> 0 then - Exit; - if Buf[1] <> #5 then - Exit; - case Ord(Buf[4]) of - 1: - s := RecvBufferStr(4, FSocksTimeout); - 3: - begin - x := RecvByte(FSocksTimeout); - if FLastError <> 0 then - Exit; - s := AnsiChar(x) + RecvBufferStr(x, FSocksTimeout); - end; - 4: - s := RecvBufferStr(16, FSocksTimeout); - else - Exit; - end; - Buf := Buf + s + RecvBufferStr(2, FSocksTimeout); - if FLastError <> 0 then - Exit; - FSocksLastError := Ord(Buf[2]); - end; - if ((FSocksLastError <> 0) and (FSocksLastError <> 90)) then - Exit; - SocksDecode(Buf); - Result := True; - finally - FBypassFlag := False; - end; -end; - -function TSocksBlockSocket.SocksCode(IP, Port: string): Ansistring; -var - ip6: TIp6Bytes; - n: integer; -begin - if FSocksType <> ST_Socks5 then - begin - Result := CodeInt(ResolvePort(Port)); - if not FSocksResolver then - IP := ResolveName(IP); - if IsIP(IP) then - begin - Result := Result + IPToID(IP); - Result := Result + FSocksUsername + #0; - end - else - begin - Result := Result + IPToID('0.0.0.1'); - Result := Result + FSocksUsername + #0; - Result := Result + IP + #0; - end; - end - else - begin - if not FSocksResolver then - IP := ResolveName(IP); - if IsIP(IP) then - Result := #1 + IPToID(IP) - else - if IsIP6(IP) then - begin - ip6 := StrToIP6(IP); - Result := #4; - for n := 0 to 15 do - Result := Result + AnsiChar(ip6[n]); - end - else - Result := #3 + AnsiChar(Length(IP)) + IP; - Result := Result + CodeInt(ResolvePort(Port)); - end; -end; - -function TSocksBlockSocket.SocksDecode(Value: Ansistring): integer; -var - Atyp: Byte; - y, n: integer; - w: Word; - ip6: TIp6Bytes; -begin - FSocksResponsePort := '0'; - Result := 0; - if FSocksType <> ST_Socks5 then - begin - if Length(Value) < 8 then - Exit; - Result := 3; - w := DecodeInt(Value, Result); - FSocksResponsePort := IntToStr(w); - FSocksResponseIP := Format('%d.%d.%d.%d', - [Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]); - Result := 9; - end - else - begin - if Length(Value) < 4 then - Exit; - Atyp := Ord(Value[4]); - Result := 5; - case Atyp of - 1: - begin - if Length(Value) < 10 then - Exit; - FSocksResponseIP := Format('%d.%d.%d.%d', - [Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]); - Result := 9; - end; - 3: - begin - y := Ord(Value[5]); - if Length(Value) < (5 + y + 2) then - Exit; - for n := 6 to 6 + y - 1 do - FSocksResponseIP := FSocksResponseIP + Value[n]; - Result := 5 + y + 1; - end; - 4: - begin - if Length(Value) < 22 then - Exit; - for n := 0 to 15 do - ip6[n] := ord(Value[n + 5]); - FSocksResponseIP := IP6ToStr(ip6); - Result := 21; - end; - else - Exit; - end; - w := DecodeInt(Value, Result); - FSocksResponsePort := IntToStr(w); - Result := Result + 2; - end; -end; - -{======================================================================} - -procedure TDgramBlockSocket.Connect(IP, Port: string); -begin - SetRemoteSin(IP, Port); - InternalCreateSocket(FRemoteSin); - FBuffer := ''; - DoStatus(HR_Connect, IP + ':' + Port); -end; - -function TDgramBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer; -begin - Result := RecvBufferFrom(Buffer, Length); -end; - -function TDgramBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; -begin - Result := SendBufferTo(Buffer, Length); -end; - -{======================================================================} - -destructor TUDPBlockSocket.Destroy; -begin - if Assigned(FSocksControlSock) then - FSocksControlSock.Free; - inherited; -end; - -procedure TUDPBlockSocket.EnableBroadcast(Value: Boolean); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_Broadcast; - d.Enabled := Value; - DelayedOption(d); -end; - -function TUDPBlockSocket.UdpAssociation: Boolean; -var - b: Boolean; -begin - Result := True; - FUsingSocks := False; - if FSocksIP <> '' then - begin - Result := False; - if not Assigned(FSocksControlSock) then - FSocksControlSock := TTCPBlockSocket.Create; - FSocksControlSock.CloseSocket; - FSocksControlSock.CreateSocketByName(FSocksIP); - FSocksControlSock.Connect(FSocksIP, FSocksPort); - if FSocksControlSock.LastError <> 0 then - Exit; - // if not assigned local port, assign it! - if not FBinded then - Bind(cAnyHost, cAnyPort); - //open control TCP connection to SOCKS - FSocksControlSock.FSocksUsername := FSocksUsername; - FSocksControlSock.FSocksPassword := FSocksPassword; - b := FSocksControlSock.SocksOpen; - if b then - b := FSocksControlSock.SocksRequest(3, GetLocalSinIP, IntToStr(GetLocalSinPort)); - if b then - b := FSocksControlSock.SocksResponse; - if not b and (FLastError = 0) then - FLastError := WSANO_RECOVERY; - FUsingSocks :=FSocksControlSock.UsingSocks; - FSocksRemoteIP := FSocksControlSock.FSocksResponseIP; - FSocksRemotePort := FSocksControlSock.FSocksResponsePort; - Result := b and (FLastError = 0); - end; -end; - -function TUDPBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer; -var - SIp: string; - SPort: integer; - Buf: Ansistring; -begin - Result := 0; - FUsingSocks := False; - if (FSocksIP <> '') and (not UdpAssociation) then - FLastError := WSANO_RECOVERY - else - begin - if FUsingSocks then - begin -{$IFNDEF CIL} - Sip := GetRemoteSinIp; - SPort := GetRemoteSinPort; - SetRemoteSin(FSocksRemoteIP, FSocksRemotePort); - SetLength(Buf,Length); - Move(Buffer^, Pointer(Buf)^, Length); - Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf; - Result := inherited SendBufferTo(Pointer(Buf), System.Length(buf)); - SetRemoteSin(Sip, IntToStr(SPort)); -{$ENDIF} - end - else - Result := inherited SendBufferTo(Buffer, Length); - end; -end; - -function TUDPBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; -var - Buf: Ansistring; - x: integer; -begin - Result := inherited RecvBufferFrom(Buffer, Length); - if FUsingSocks then - begin -{$IFNDEF CIL} - SetLength(Buf, Result); - Move(Buffer^, Pointer(Buf)^, Result); - x := SocksDecode(Buf); - Result := Result - x + 1; - Buf := Copy(Buf, x, Result); - Move(Pointer(Buf)^, Buffer^, Result); - SetRemoteSin(FSocksResponseIP, FSocksResponsePort); -{$ENDIF} - end; -end; - -{$IFNDEF CIL} -procedure TUDPBlockSocket.AddMulticast(MCastIP: string); -var - Multicast: TIP_mreq; - Multicast6: TIPv6_mreq; - n: integer; - ip6: Tip6bytes; -begin - if FIP6Used then - begin - ip6 := StrToIp6(MCastIP); - for n := 0 to 15 do - Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n]; - Multicast6.ipv6mr_interface := 0; - SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_JOIN_GROUP, - PAnsiChar(@Multicast6), SizeOf(Multicast6))); - end - else - begin - Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP)); - Multicast.imr_interface.S_addr := INADDR_ANY; - SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_ADD_MEMBERSHIP, - PAnsiChar(@Multicast), SizeOf(Multicast))); - end; - ExceptCheck; -end; - -procedure TUDPBlockSocket.DropMulticast(MCastIP: string); -var - Multicast: TIP_mreq; - Multicast6: TIPv6_mreq; - n: integer; - ip6: Tip6bytes; -begin - if FIP6Used then - begin - ip6 := StrToIp6(MCastIP); - for n := 0 to 15 do - Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n]; - Multicast6.ipv6mr_interface := 0; - SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_LEAVE_GROUP, - PAnsiChar(@Multicast6), SizeOf(Multicast6))); - end - else - begin - Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP)); - Multicast.imr_interface.S_addr := INADDR_ANY; - SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_DROP_MEMBERSHIP, - PAnsiChar(@Multicast), SizeOf(Multicast))); - end; - ExceptCheck; -end; -{$ENDIF} - -procedure TUDPBlockSocket.SetMulticastTTL(TTL: integer); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_MulticastTTL; - d.Value := TTL; - DelayedOption(d); -end; - -function TUDPBlockSocket.GetMulticastTTL:integer; -var - l: Integer; -begin -{$IFNDEF CIL} - l := SizeOf(Result); - if FIP6Used then - synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_MULTICAST_HOPS, @Result, l) - else - synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, @Result, l); -{$ENDIF} -end; - -procedure TUDPBlockSocket.EnableMulticastLoop(Value: Boolean); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_MulticastLoop; - d.Enabled := Value; - DelayedOption(d); -end; - -function TUDPBlockSocket.GetSocketType: integer; -begin - Result := integer(SOCK_DGRAM); -end; - -function TUDPBlockSocket.GetSocketProtocol: integer; -begin - Result := integer(IPPROTO_UDP); -end; - -{======================================================================} -constructor TTCPBlockSocket.CreateWithSSL(SSLPlugin: TSSLClass); -begin - inherited Create; - FSSL := SSLPlugin.Create(self); - FHTTPTunnelIP := ''; - FHTTPTunnelPort := ''; - FHTTPTunnel := False; - FHTTPTunnelRemoteIP := ''; - FHTTPTunnelRemotePort := ''; - FHTTPTunnelUser := ''; - FHTTPTunnelPass := ''; - FHTTPTunnelTimeout := 30000; -end; - -constructor TTCPBlockSocket.Create; -begin - CreateWithSSL(SSLImplementation); -end; - -destructor TTCPBlockSocket.Destroy; -begin - inherited Destroy; - FSSL.Free; -end; - -function TTCPBlockSocket.GetErrorDescEx: string; -begin - Result := inherited GetErrorDescEx; - if (FLastError = WSASYSNOTREADY) and (self.SSL.LastError <> 0) then - begin - Result := self.SSL.LastErrorDesc; - end; -end; - -procedure TTCPBlockSocket.CloseSocket; -begin - if FSSL.SSLEnabled then - FSSL.Shutdown; - if (FSocket <> INVALID_SOCKET) and (FLastError = 0) then - begin - Synsock.Shutdown(FSocket, 1); - Purge; - end; - inherited CloseSocket; -end; - -procedure TTCPBlockSocket.DoAfterConnect; -begin - if assigned(OnAfterConnect) then - begin - OnAfterConnect(Self); - end; -end; - -function TTCPBlockSocket.WaitingData: Integer; -begin - Result := 0; - if FSSL.SSLEnabled and (FSocket <> INVALID_SOCKET) then - Result := FSSL.WaitingData; - if Result = 0 then - Result := inherited WaitingData; -end; - -procedure TTCPBlockSocket.Listen; -var - b: Boolean; - Sip,SPort: string; -begin - if FSocksIP = '' then - begin - inherited Listen; - end - else - begin - Sip := GetLocalSinIP; - if Sip = cAnyHost then - Sip := LocalName; - SPort := IntToStr(GetLocalSinPort); - inherited Connect(FSocksIP, FSocksPort); - b := SocksOpen; - if b then - b := SocksRequest(2, Sip, SPort); - if b then - b := SocksResponse; - if not b and (FLastError = 0) then - FLastError := WSANO_RECOVERY; - FSocksLocalIP := FSocksResponseIP; - if FSocksLocalIP = cAnyHost then - FSocksLocalIP := FSocksIP; - FSocksLocalPort := FSocksResponsePort; - FSocksRemoteIP := ''; - FSocksRemotePort := ''; - ExceptCheck; - DoStatus(HR_Listen, ''); - end; -end; - -function TTCPBlockSocket.Accept: TSocket; -begin - if FUsingSocks then - begin - if not SocksResponse and (FLastError = 0) then - FLastError := WSANO_RECOVERY; - FSocksRemoteIP := FSocksResponseIP; - FSocksRemotePort := FSocksResponsePort; - Result := FSocket; - ExceptCheck; - DoStatus(HR_Accept, ''); - end - else - begin - result := inherited Accept; - end; -end; - -procedure TTCPBlockSocket.Connect(IP, Port: string); -begin - if FSocksIP <> '' then - SocksDoConnect(IP, Port) - else - if FHTTPTunnelIP <> '' then - HTTPTunnelDoConnect(IP, Port) - else - inherited Connect(IP, Port); - if FLasterror = 0 then - DoAfterConnect; -end; - -procedure TTCPBlockSocket.SocksDoConnect(IP, Port: string); -var - b: Boolean; -begin - inherited Connect(FSocksIP, FSocksPort); - if FLastError = 0 then - begin - b := SocksOpen; - if b then - b := SocksRequest(1, IP, Port); - if b then - b := SocksResponse; - if not b and (FLastError = 0) then - FLastError := WSASYSNOTREADY; - FSocksLocalIP := FSocksResponseIP; - FSocksLocalPort := FSocksResponsePort; - FSocksRemoteIP := IP; - FSocksRemotePort := Port; - end; - ExceptCheck; - DoStatus(HR_Connect, IP + ':' + Port); -end; - -procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string); -//bugfixed by Mike Green (mgreen@emixode.com) -var - s: string; -begin - Port := IntToStr(ResolvePort(Port)); - inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort); - if FLastError <> 0 then - Exit; - FHTTPTunnel := False; - if IsIP6(IP) then - IP := '[' + IP + ']'; - SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + CRLF); - if FHTTPTunnelUser <> '' then - Sendstring('Proxy-Authorization: Basic ' + - EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + CRLF); - SendString(CRLF); - repeat - s := RecvTerminated(FHTTPTunnelTimeout, #$0a); - if FLastError <> 0 then - Break; - if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then - FHTTPTunnel := s[10] = '2'; - until (s = '') or (s = #$0d); - if (FLasterror = 0) and not FHTTPTunnel then - FLastError := WSASYSNOTREADY; - FHTTPTunnelRemoteIP := IP; - FHTTPTunnelRemotePort := Port; - ExceptCheck; -end; - -procedure TTCPBlockSocket.SSLDoConnect; -begin - ResetLastError; - if not FSSL.Connect then - FLastError := WSASYSNOTREADY; - ExceptCheck; -end; - -procedure TTCPBlockSocket.SSLDoShutdown; -begin - ResetLastError; - FSSL.BiShutdown; -end; - -function TTCPBlockSocket.GetLocalSinIP: string; -begin - if FUsingSocks then - Result := FSocksLocalIP - else - Result := inherited GetLocalSinIP; -end; - -function TTCPBlockSocket.GetRemoteSinIP: string; -begin - if FUsingSocks then - Result := FSocksRemoteIP - else - if FHTTPTunnel then - Result := FHTTPTunnelRemoteIP - else - Result := inherited GetRemoteSinIP; -end; - -function TTCPBlockSocket.GetLocalSinPort: Integer; -begin - if FUsingSocks then - Result := StrToIntDef(FSocksLocalPort, 0) - else - Result := inherited GetLocalSinPort; -end; - -function TTCPBlockSocket.GetRemoteSinPort: Integer; -begin - if FUsingSocks then - Result := ResolvePort(FSocksRemotePort) - else - if FHTTPTunnel then - Result := StrToIntDef(FHTTPTunnelRemotePort, 0) - else - Result := inherited GetRemoteSinPort; -end; - -function TTCPBlockSocket.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; -begin - if FSSL.SSLEnabled then - begin - Result := 0; - if TestStopFlag then - Exit; - ResetLastError; - LimitBandwidth(Len, FMaxRecvBandwidth, FNextRecv); - Result := FSSL.RecvBuffer(Buffer, Len); - if FSSL.LastError <> 0 then - FLastError := WSASYSNOTREADY; - ExceptCheck; - Inc(FRecvCounter, Result); - DoStatus(HR_ReadCount, IntToStr(Result)); - DoMonitor(False, Buffer, Result); - DoReadFilter(Buffer, Result); - end - else - Result := inherited RecvBuffer(Buffer, Len); -end; - -function TTCPBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; -var - x, y: integer; - l, r: integer; -{$IFNDEF CIL} - p: Pointer; -{$ENDIF} -begin - if FSSL.SSLEnabled then - begin - Result := 0; - if TestStopFlag then - Exit; - ResetLastError; - DoMonitor(True, Buffer, Length); -{$IFDEF CIL} - Result := FSSL.SendBuffer(Buffer, Length); - if FSSL.LastError <> 0 then - FLastError := WSASYSNOTREADY; - Inc(FSendCounter, Result); - DoStatus(HR_WriteCount, IntToStr(Result)); -{$ELSE} - l := Length; - x := 0; - while x < l do - begin - y := l - x; - if y > FSendMaxChunk then - y := FSendMaxChunk; - if y > 0 then - begin - LimitBandwidth(y, FMaxSendBandwidth, FNextsend); - p := IncPoint(Buffer, x); - r := FSSL.SendBuffer(p, y); - if FSSL.LastError <> 0 then - FLastError := WSASYSNOTREADY; - if Flasterror <> 0 then - Break; - Inc(x, r); - Inc(Result, r); - Inc(FSendCounter, r); - DoStatus(HR_WriteCount, IntToStr(r)); - end - else - break; - end; -{$ENDIF} - ExceptCheck; - end - else - Result := inherited SendBuffer(Buffer, Length); -end; - -function TTCPBlockSocket.SSLAcceptConnection: Boolean; -begin - ResetLastError; - if not FSSL.Accept then - FLastError := WSASYSNOTREADY; - ExceptCheck; - Result := FLastError = 0; -end; - -function TTCPBlockSocket.GetSocketType: integer; -begin - Result := integer(SOCK_STREAM); -end; - -function TTCPBlockSocket.GetSocketProtocol: integer; -begin - Result := integer(IPPROTO_TCP); -end; - -{======================================================================} - -function TICMPBlockSocket.GetSocketType: integer; -begin - Result := integer(SOCK_RAW); -end; - -function TICMPBlockSocket.GetSocketProtocol: integer; -begin - if FIP6Used then - Result := integer(IPPROTO_ICMPV6) - else - Result := integer(IPPROTO_ICMP); -end; - -{======================================================================} - -function TRAWBlockSocket.GetSocketType: integer; -begin - Result := integer(SOCK_RAW); -end; - -function TRAWBlockSocket.GetSocketProtocol: integer; -begin - Result := integer(IPPROTO_RAW); -end; - -{======================================================================} - -function TPGMmessageBlockSocket.GetSocketType: integer; -begin - Result := integer(SOCK_RDM); -end; - -function TPGMmessageBlockSocket.GetSocketProtocol: integer; -begin - Result := integer(IPPROTO_RM); -end; - -{======================================================================} - -function TPGMstreamBlockSocket.GetSocketType: integer; -begin - Result := integer(SOCK_STREAM); -end; - -function TPGMstreamBlockSocket.GetSocketProtocol: integer; -begin - Result := integer(IPPROTO_RM); -end; - -{======================================================================} - -constructor TSynaClient.Create; -begin - inherited Create; - FIPInterface := cAnyHost; - FTargetHost := cLocalhost; - FTargetPort := cAnyPort; - FTimeout := 5000; - FUsername := ''; - FPassword := ''; -end; - -{======================================================================} - -constructor TCustomSSL.Create(const Value: TTCPBlockSocket); -begin - inherited Create; - FSocket := Value; - FSSLEnabled := False; - FUsername := ''; - FPassword := ''; - FLastError := 0; - FLastErrorDesc := ''; - FVerifyCert := False; - FSSLType := LT_all; - FKeyPassword := ''; - FCiphers := ''; - FCertificateFile := ''; - FPrivateKeyFile := ''; - FCertCAFile := ''; - FCertCA := ''; - FTrustCertificate := ''; - FTrustCertificateFile := ''; - FCertificate := ''; - FPrivateKey := ''; - FPFX := ''; - FPFXfile := ''; - FSSHChannelType := ''; - FSSHChannelArg1 := ''; - FSSHChannelArg2 := ''; -end; - -procedure TCustomSSL.Assign(const Value: TCustomSSL); -begin - FUsername := Value.Username; - FPassword := Value.Password; - FVerifyCert := Value.VerifyCert; - FSSLType := Value.SSLType; - FKeyPassword := Value.KeyPassword; - FCiphers := Value.Ciphers; - FCertificateFile := Value.CertificateFile; - FPrivateKeyFile := Value.PrivateKeyFile; - FCertCAFile := Value.CertCAFile; - FCertCA := Value.CertCA; - FTrustCertificate := Value.TrustCertificate; - FTrustCertificateFile := Value.TrustCertificateFile; - FCertificate := Value.Certificate; - FPrivateKey := Value.PrivateKey; - FPFX := Value.PFX; - FPFXfile := Value.PFXfile; -end; - -procedure TCustomSSL.ReturnError; -begin - FLastError := -1; - FLastErrorDesc := 'SSL/TLS support is not compiled!'; -end; - -function TCustomSSL.LibVersion: String; -begin - Result := ''; -end; - -function TCustomSSL.LibName: String; -begin - Result := ''; -end; - -function TCustomSSL.CreateSelfSignedCert(Host: string): Boolean; -begin - Result := False; -end; - -function TCustomSSL.Connect: boolean; -begin - ReturnError; - Result := False; -end; - -function TCustomSSL.Accept: boolean; -begin - ReturnError; - Result := False; -end; - -function TCustomSSL.Shutdown: boolean; -begin - ReturnError; - Result := False; -end; - -function TCustomSSL.BiShutdown: boolean; -begin - ReturnError; - Result := False; -end; - -function TCustomSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer; -begin - ReturnError; - Result := integer(SOCKET_ERROR); -end; - -function TCustomSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; -begin - ReturnError; - Result := integer(SOCKET_ERROR); -end; - -function TCustomSSL.WaitingData: Integer; -begin - ReturnError; - Result := 0; -end; - -function TCustomSSL.GetSSLVersion: string; -begin - Result := ''; -end; - -function TCustomSSL.GetPeerSubject: string; -begin - Result := ''; -end; - -function TCustomSSL.GetPeerName: string; -begin - Result := ''; -end; - -function TCustomSSL.GetPeerIssuer: string; -begin - Result := ''; -end; - -function TCustomSSL.GetPeerFingerprint: string; -begin - Result := ''; -end; - -function TCustomSSL.GetCertInfo: string; -begin - Result := ''; -end; - -function TCustomSSL.GetCipherName: string; -begin - Result := ''; -end; - -function TCustomSSL.GetCipherBits: integer; -begin - Result := 0; -end; - -function TCustomSSL.GetCipherAlgBits: integer; -begin - Result := 0; -end; - -function TCustomSSL.GetVerifyCert: integer; -begin - Result := 1; -end; - -{======================================================================} - -function TSSLNone.LibVersion: String; -begin - Result := 'Without SSL support'; -end; - -function TSSLNone.LibName: String; -begin - Result := 'ssl_none'; -end; - -{======================================================================} - -{$IFDEF ONCEWINSOCK} -initialization -begin - if not InitSocketInterface(DLLStackName) then - begin - e := ESynapseError.Create('Error loading Socket interface (' + DLLStackName + ')!'); - e.ErrorCode := 0; - e.ErrorMessage := 'Error loading Socket interface (' + DLLStackName + ')!'; - raise e; - end; - synsock.WSAStartup(WinsockLevel, WsaDataOnce); -end; -{$ENDIF} - -finalization -begin -{$IFDEF ONCEWINSOCK} - synsock.WSACleanup; - DestroySocketInterface; -{$ENDIF} -end; - -end. diff --git a/addons/synapse/clamsend.pas b/addons/synapse/clamsend.pas deleted file mode 100644 index 8d3c2d6..0000000 --- a/addons/synapse/clamsend.pas +++ /dev/null @@ -1,277 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.001 | -|==============================================================================| -| Content: ClamAV-daemon client | -|==============================================================================| -| Copyright (c)2005-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2005-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract( ClamAV-daemon client) - -This unit is capable to do antivirus scan of your data by TCP channel to ClamD -daemon from ClamAV. See more about ClamAV on @LINK(http://www.clamav.net) -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit clamsend; - -interface - -uses - SysUtils, Classes, - synsock, blcksock, synautil; - -const - cClamProtocol = '3310'; - -type - - {:@abstract(Implementation of ClamAV-daemon client protocol) - By this class you can scan any your data by ClamAV opensource antivirus. - - This class can connect to ClamD by TCP channel, send your data to ClamD - and read result.} - TClamSend = class(TSynaClient) - private - FSock: TTCPBlockSocket; - FDSock: TTCPBlockSocket; - FSession: boolean; - function Login: boolean; virtual; - function Logout: Boolean; virtual; - function OpenStream: Boolean; virtual; - public - constructor Create; - destructor Destroy; override; - - {:Call any command to ClamD. Used internally by other methods.} - function DoCommand(const Value: AnsiString): AnsiString; virtual; - - {:Return ClamAV version and version of loaded databases.} - function GetVersion: AnsiString; virtual; - - {:Scan content of TStrings.} - function ScanStrings(const Value: TStrings): AnsiString; virtual; - - {:Scan content of TStream.} - function ScanStream(const Value: TStream): AnsiString; virtual; - - {:Scan content of TStrings by new 0.95 API.} - function ScanStrings2(const Value: TStrings): AnsiString; virtual; - - {:Scan content of TStream by new 0.95 API.} - function ScanStream2(const Value: TStream): AnsiString; virtual; - published - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TTCPBlockSocket read FSock; - - {:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.} - property DSock: TTCPBlockSocket read FDSock; - - {:Can turn-on session mode of communication with ClamD. Default is @false, - because ClamAV developers design their TCP code very badly and session mode - is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs - and this mode will be possible in future.} - property Session: boolean read FSession write FSession; - end; - -implementation - -constructor TClamSend.Create; -begin - inherited Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FDSock := TTCPBlockSocket.Create; - FDSock.Owner := self; - FTimeout := 60000; - FTargetPort := cClamProtocol; - FSession := false; -end; - -destructor TClamSend.Destroy; -begin - Logout; - FDSock.Free; - FSock.Free; - inherited Destroy; -end; - -function TClamSend.DoCommand(const Value: AnsiString): AnsiString; -begin - Result := ''; - if not FSession then - FSock.CloseSocket - else - FSock.SendString(Value + LF); - if not FSession or (FSock.LastError <> 0) then - begin - if Login then - FSock.SendString(Value + LF) - else - Exit; - end; - Result := FSock.RecvTerminated(FTimeout, LF); -end; - -function TClamSend.Login: boolean; -begin - Result := False; - Sock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError <> 0 then - Exit; - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError <> 0 then - Exit; - if FSession then - FSock.SendString('SESSION' + LF); - Result := FSock.LastError = 0; -end; - -function TClamSend.Logout: Boolean; -begin - FSock.SendString('END' + LF); - Result := FSock.LastError = 0; - FSock.CloseSocket; -end; - -function TClamSend.GetVersion: AnsiString; -begin - Result := DoCommand('nVERSION'); -end; - -function TClamSend.OpenStream: Boolean; -var - S: AnsiString; -begin - Result := False; - s := DoCommand('nSTREAM'); - if (s <> '') and (Copy(s, 1, 4) = 'PORT') then - begin - s := SeparateRight(s, ' '); - FDSock.CloseSocket; - FDSock.Bind(FIPInterface, cAnyPort); - if FDSock.LastError <> 0 then - Exit; - FDSock.Connect(FTargetHost, s); - if FDSock.LastError <> 0 then - Exit; - Result := True; - end; -end; - -function TClamSend.ScanStrings(const Value: TStrings): AnsiString; -begin - Result := ''; - if OpenStream then - begin - DSock.SendString(Value.Text); - DSock.CloseSocket; - Result := FSock.RecvTerminated(FTimeout, LF); - end; -end; - -function TClamSend.ScanStream(const Value: TStream): AnsiString; -begin - Result := ''; - if OpenStream then - begin - DSock.SendStreamRaw(Value); - DSock.CloseSocket; - Result := FSock.RecvTerminated(FTimeout, LF); - end; -end; - -function TClamSend.ScanStrings2(const Value: TStrings): AnsiString; -var - i: integer; - s: AnsiString; -begin - Result := ''; - if not FSession then - FSock.CloseSocket - else - FSock.sendstring('nINSTREAM' + LF); - if not FSession or (FSock.LastError <> 0) then - begin - if Login then - FSock.sendstring('nINSTREAM' + LF) - else - Exit; - end; - s := Value.text; - i := length(s); - FSock.SendString(CodeLongint(i) + s + #0#0#0#0); - Result := FSock.RecvTerminated(FTimeout, LF); -end; - -function TClamSend.ScanStream2(const Value: TStream): AnsiString; -var - i: integer; -begin - Result := ''; - if not FSession then - FSock.CloseSocket - else - FSock.sendstring('nINSTREAM' + LF); - if not FSession or (FSock.LastError <> 0) then - begin - if Login then - FSock.sendstring('nINSTREAM' + LF) - else - Exit; - end; - i := value.Size; - FSock.SendString(CodeLongint(i)); - FSock.SendStreamRaw(Value); - FSock.SendString(#0#0#0#0); - Result := FSock.RecvTerminated(FTimeout, LF); -end; - -end. diff --git a/addons/synapse/dnssend.pas b/addons/synapse/dnssend.pas deleted file mode 100644 index 84c14cc..0000000 --- a/addons/synapse/dnssend.pas +++ /dev/null @@ -1,603 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.007.006 | -|==============================================================================| -| Content: DNS client | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} -{: @abstract(DNS client by UDP or TCP) -Support for sending DNS queries by UDP or TCP protocol. It can retrieve zone - transfers too! - -Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit dnssend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil, synaip, synsock; - -const - cDnsProtocol = '53'; - - QTYPE_A = 1; - QTYPE_NS = 2; - QTYPE_MD = 3; - QTYPE_MF = 4; - QTYPE_CNAME = 5; - QTYPE_SOA = 6; - QTYPE_MB = 7; - QTYPE_MG = 8; - QTYPE_MR = 9; - QTYPE_NULL = 10; - QTYPE_WKS = 11; // - QTYPE_PTR = 12; - QTYPE_HINFO = 13; - QTYPE_MINFO = 14; - QTYPE_MX = 15; - QTYPE_TXT = 16; - - QTYPE_RP = 17; - QTYPE_AFSDB = 18; - QTYPE_X25 = 19; - QTYPE_ISDN = 20; - QTYPE_RT = 21; - QTYPE_NSAP = 22; - QTYPE_NSAPPTR = 23; - QTYPE_SIG = 24; // RFC-2065 - QTYPE_KEY = 25; // RFC-2065 - QTYPE_PX = 26; - QTYPE_GPOS = 27; - QTYPE_AAAA = 28; - QTYPE_LOC = 29; // RFC-1876 - QTYPE_NXT = 30; // RFC-2065 - - QTYPE_SRV = 33; - QTYPE_NAPTR = 35; // RFC-2168 - QTYPE_KX = 36; - QTYPE_SPF = 99; - - QTYPE_AXFR = 252; - QTYPE_MAILB = 253; // - QTYPE_MAILA = 254; // - QTYPE_ALL = 255; - -type - {:@abstract(Implementation of DNS protocol by UDP or TCP protocol.) - - Note: Are you missing properties for specify server address and port? Look to - parent @link(TSynaClient) too!} - TDNSSend = class(TSynaClient) - private - FID: Word; - FRCode: Integer; - FBuffer: AnsiString; - FSock: TUDPBlockSocket; - FTCPSock: TTCPBlockSocket; - FUseTCP: Boolean; - FAnswerInfo: TStringList; - FNameserverInfo: TStringList; - FAdditionalInfo: TStringList; - FAuthoritative: Boolean; - FTruncated: Boolean; - function CompressName(const Value: AnsiString): AnsiString; - function CodeHeader: AnsiString; - function CodeQuery(const Name: AnsiString; QType: Integer): AnsiString; - function DecodeLabels(var From: Integer): AnsiString; - function DecodeString(var From: Integer): AnsiString; - function DecodeResource(var i: Integer; const Info: TStringList; - QType: Integer): AnsiString; - function RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString; - function DecodeResponse(const Buf: AnsiString; const Reply: TStrings; - QType: Integer):boolean; - public - constructor Create; - destructor Destroy; override; - - {:Query a DNSHost for QType resources correspond to a name. Supported QType - values are: Qtype_A, Qtype_NS, Qtype_MD, Qtype_MF, Qtype_CNAME, Qtype_SOA, - Qtype_MB, Qtype_MG, Qtype_MR, Qtype_NULL, Qtype_PTR, Qtype_HINFO, - Qtype_MINFO, Qtype_MX, Qtype_TXT, Qtype_RP, Qtype_AFSDB, Qtype_X25, - Qtype_ISDN, Qtype_RT, Qtype_NSAP, Qtype_NSAPPTR, Qtype_PX, Qtype_GPOS, - Qtype_KX. - - Type for zone transfers QTYPE_AXFR is supported too, but only in TCP mode! - - "Name" is domain name or host name for queried resource. If "name" is - IP address, automatically convert to reverse domain form (.in-addr.arpa). - - If result is @true, Reply contains resource records. One record on one line. - If Resource record have multiple fields, they are stored on line divided by - comma. (example: MX record contains value 'rs.cesnet.cz' with preference - number 10, string in Reply is: '10,rs.cesnet.cz'). All numbers or IP address - in resource are converted to string form.} - function DNSQuery(Name: AnsiString; QType: Integer; - const Reply: TStrings): Boolean; - published - - {:Socket object used for UDP operation. Good for seting OnStatus hook, etc.} - property Sock: TUDPBlockSocket read FSock; - - {:Socket object used for TCP operation. Good for seting OnStatus hook, etc.} - property TCPSock: TTCPBlockSocket read FTCPSock; - - {:if @true, then is used TCP protocol instead UDP. It is needed for zone - transfers, etc.} - property UseTCP: Boolean read FUseTCP Write FUseTCP; - - {:After DNS operation contains ResultCode of DNS operation. - Values are: 0-no error, 1-format error, 2-server failure, 3-name error, - 4-not implemented, 5-refused.} - property RCode: Integer read FRCode; - - {:@True, if answer is authoritative.} - property Authoritative: Boolean read FAuthoritative; - - {:@True, if answer is truncated to 512 bytes.} - property Truncated: Boolean read FTRuncated; - - {:Detailed informations from name server reply. One record per line. Record - have comma delimited entries with type number, TTL and data filelds. - This information contains detailed information about query reply.} - property AnswerInfo: TStringList read FAnswerInfo; - - {:Detailed informations from name server reply. One record per line. Record - have comma delimited entries with type number, TTL and data filelds. - This information contains detailed information about nameserver.} - property NameserverInfo: TStringList read FNameserverInfo; - - {:Detailed informations from name server reply. One record per line. Record - have comma delimited entries with type number, TTL and data filelds. - This information contains detailed additional information.} - property AdditionalInfo: TStringList read FAdditionalInfo; - end; - -{:A very useful function, and example of it's use is found in the TDNSSend object. - This function is used to get mail servers for a domain and sort them by - preference numbers. "Servers" contains only the domain names of the mail - servers in the right order (without preference number!). The first domain name - will always be the highest preferenced mail server. Returns boolean @TRUE if - all went well.} -function GetMailServers(const DNSHost, Domain: AnsiString; - const Servers: TStrings): Boolean; - -implementation - -constructor TDNSSend.Create; -begin - inherited Create; - FSock := TUDPBlockSocket.Create; - FSock.Owner := self; - FTCPSock := TTCPBlockSocket.Create; - FTCPSock.Owner := self; - FUseTCP := False; - FTimeout := 10000; - FTargetPort := cDnsProtocol; - FAnswerInfo := TStringList.Create; - FNameserverInfo := TStringList.Create; - FAdditionalInfo := TStringList.Create; - Randomize; -end; - -destructor TDNSSend.Destroy; -begin - FAnswerInfo.Free; - FNameserverInfo.Free; - FAdditionalInfo.Free; - FTCPSock.Free; - FSock.Free; - inherited Destroy; -end; - -function TDNSSend.CompressName(const Value: AnsiString): AnsiString; -var - n: Integer; - s: AnsiString; -begin - Result := ''; - if Value = '' then - Result := #0 - else - begin - s := ''; - for n := 1 to Length(Value) do - if Value[n] = '.' then - begin - Result := Result + AnsiChar(Length(s)) + s; - s := ''; - end - else - s := s + Value[n]; - if s <> '' then - Result := Result + AnsiChar(Length(s)) + s; - Result := Result + #0; - end; -end; - -function TDNSSend.CodeHeader: AnsiString; -begin - FID := Random(32767); - Result := CodeInt(FID); // ID - Result := Result + CodeInt($0100); // flags - Result := Result + CodeInt(1); // QDCount - Result := Result + CodeInt(0); // ANCount - Result := Result + CodeInt(0); // NSCount - Result := Result + CodeInt(0); // ARCount -end; - -function TDNSSend.CodeQuery(const Name: AnsiString; QType: Integer): AnsiString; -begin - Result := CompressName(Name); - Result := Result + CodeInt(QType); - Result := Result + CodeInt(1); // Type INTERNET -end; - -function TDNSSend.DecodeString(var From: Integer): AnsiString; -var - Len: integer; -begin - Len := Ord(FBuffer[From]); - Inc(From); - Result := Copy(FBuffer, From, Len); - Inc(From, Len); -end; - -function TDNSSend.DecodeLabels(var From: Integer): AnsiString; -var - l, f: Integer; -begin - Result := ''; - while True do - begin - if From >= Length(FBuffer) then - Break; - l := Ord(FBuffer[From]); - Inc(From); - if l = 0 then - Break; - if Result <> '' then - Result := Result + '.'; - if (l and $C0) = $C0 then - begin - f := l and $3F; - f := f * 256 + Ord(FBuffer[From]) + 1; - Inc(From); - Result := Result + DecodeLabels(f); - Break; - end - else - begin - Result := Result + Copy(FBuffer, From, l); - Inc(From, l); - end; - end; -end; - -function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList; - QType: Integer): AnsiString; -var - Rname: AnsiString; - RType, Len, j, x, y, z, n: Integer; - R: AnsiString; - t1, t2, ttl: integer; - ip6: TIp6bytes; -begin - Result := ''; - R := ''; - Rname := DecodeLabels(i); - RType := DecodeInt(FBuffer, i); - Inc(i, 4); - t1 := DecodeInt(FBuffer, i); - Inc(i, 2); - t2 := DecodeInt(FBuffer, i); - Inc(i, 2); - ttl := t1 * 65536 + t2; - Len := DecodeInt(FBuffer, i); - Inc(i, 2); // i point to begin of data - j := i; - i := i + len; // i point to next record - if Length(FBuffer) >= (i - 1) then - case RType of - QTYPE_A: - begin - R := IntToStr(Ord(FBuffer[j])); - Inc(j); - R := R + '.' + IntToStr(Ord(FBuffer[j])); - Inc(j); - R := R + '.' + IntToStr(Ord(FBuffer[j])); - Inc(j); - R := R + '.' + IntToStr(Ord(FBuffer[j])); - end; - QTYPE_AAAA: - begin - for n := 0 to 15 do - ip6[n] := ord(FBuffer[j + n]); - R := IP6ToStr(ip6); - end; - QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB, - QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP, - QTYPE_NSAPPTR: - R := DecodeLabels(j); - QTYPE_SOA: - begin - R := DecodeLabels(j); - R := R + ',' + DecodeLabels(j); - for n := 1 to 5 do - begin - x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2); - Inc(j, 4); - R := R + ',' + IntToStr(x); - end; - end; - QTYPE_NULL: - begin - end; - QTYPE_WKS: - begin - end; - QTYPE_HINFO: - begin - R := DecodeString(j); - R := R + ',' + DecodeString(j); - end; - QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN: - begin - R := DecodeLabels(j); - R := R + ',' + DecodeLabels(j); - end; - QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX: - begin - x := DecodeInt(FBuffer, j); - Inc(j, 2); - R := IntToStr(x); - R := R + ',' + DecodeLabels(j); - end; - QTYPE_TXT, QTYPE_SPF: - begin - R := ''; - while j < i do - R := R + DecodeString(j); - end; - QTYPE_GPOS: - begin - R := DecodeLabels(j); - R := R + ',' + DecodeLabels(j); - R := R + ',' + DecodeLabels(j); - end; - QTYPE_PX: - begin - x := DecodeInt(FBuffer, j); - Inc(j, 2); - R := IntToStr(x); - R := R + ',' + DecodeLabels(j); - R := R + ',' + DecodeLabels(j); - end; - QTYPE_SRV: - // Author: Dan - begin - x := DecodeInt(FBuffer, j); - Inc(j, 2); - y := DecodeInt(FBuffer, j); - Inc(j, 2); - z := DecodeInt(FBuffer, j); - Inc(j, 2); - R := IntToStr(x); // Priority - R := R + ',' + IntToStr(y); // Weight - R := R + ',' + IntToStr(z); // Port - R := R + ',' + DecodeLabels(j); // Server DNS Name - end; - end; - if R <> '' then - Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R); - if QType = RType then - Result := R; -end; - -function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString; -var - l: integer; -begin - Result := ''; - l := WorkSock.recvbyte(FTimeout) * 256 + WorkSock.recvbyte(FTimeout); - if l > 0 then - Result := WorkSock.RecvBufferStr(l, FTimeout); -end; - -function TDNSSend.DecodeResponse(const Buf: AnsiString; const Reply: TStrings; - QType: Integer):boolean; -var - n, i: Integer; - flag, qdcount, ancount, nscount, arcount: Integer; - s: AnsiString; -begin - Result := False; - Reply.Clear; - FAnswerInfo.Clear; - FNameserverInfo.Clear; - FAdditionalInfo.Clear; - FAuthoritative := False; - if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then - begin - Result := True; - flag := DecodeInt(Buf, 3); - FRCode := Flag and $000F; - FAuthoritative := (Flag and $0400) > 0; - FTruncated := (Flag and $0200) > 0; - if FRCode = 0 then - begin - qdcount := DecodeInt(Buf, 5); - ancount := DecodeInt(Buf, 7); - nscount := DecodeInt(Buf, 9); - arcount := DecodeInt(Buf, 11); - i := 13; //begin of body - if (qdcount > 0) and (Length(Buf) > i) then //skip questions - for n := 1 to qdcount do - begin - while (Buf[i] <> #0) and ((Ord(Buf[i]) and $C0) <> $C0) do - Inc(i); - Inc(i, 5); - end; - if (ancount > 0) and (Length(Buf) > i) then // decode reply - for n := 1 to ancount do - begin - s := DecodeResource(i, FAnswerInfo, QType); - if s <> '' then - Reply.Add(s); - end; - if (nscount > 0) and (Length(Buf) > i) then // decode nameserver info - for n := 1 to nscount do - DecodeResource(i, FNameserverInfo, QType); - if (arcount > 0) and (Length(Buf) > i) then // decode additional info - for n := 1 to arcount do - DecodeResource(i, FAdditionalInfo, QType); - end; - end; -end; - -function TDNSSend.DNSQuery(Name: AnsiString; QType: Integer; - const Reply: TStrings): Boolean; -var - WorkSock: TBlockSocket; - t: TStringList; - b: boolean; -begin - Result := False; - if IsIP(Name) then - Name := ReverseIP(Name) + '.in-addr.arpa'; - if IsIP6(Name) then - Name := ReverseIP6(Name) + '.ip6.arpa'; - FBuffer := CodeHeader + CodeQuery(Name, QType); - if FUseTCP then - WorkSock := FTCPSock - else - WorkSock := FSock; - WorkSock.Bind(FIPInterface, cAnyPort); - WorkSock.Connect(FTargetHost, FTargetPort); - if FUseTCP then - FBuffer := Codeint(length(FBuffer)) + FBuffer; - WorkSock.SendString(FBuffer); - if FUseTCP then - FBuffer := RecvTCPResponse(WorkSock) - else - FBuffer := WorkSock.RecvPacket(FTimeout); - if FUseTCP and (QType = QTYPE_AXFR) then //zone transfer - begin - t := TStringList.Create; - try - repeat - b := DecodeResponse(FBuffer, Reply, QType); - if (t.Count > 1) and (AnswerInfo.Count > 0) then //find end of transfer - b := b and (t[0] <> AnswerInfo[AnswerInfo.count - 1]); - if b then - begin - t.AddStrings(AnswerInfo); - FBuffer := RecvTCPResponse(WorkSock); - if FBuffer = '' then - Break; - if WorkSock.LastError <> 0 then - Break; - end; - until not b; - Reply.Assign(t); - Result := True; - finally - t.free; - end; - end - else //normal query - if WorkSock.LastError = 0 then - Result := DecodeResponse(FBuffer, Reply, QType); -end; - -{==============================================================================} - -function GetMailServers(const DNSHost, Domain: AnsiString; - const Servers: TStrings): Boolean; -var - DNS: TDNSSend; - t: TStringList; - n, m, x: Integer; -begin - Result := False; - Servers.Clear; - t := TStringList.Create; - DNS := TDNSSend.Create; - try - DNS.TargetHost := DNSHost; - if DNS.DNSQuery(Domain, QType_MX, t) then - begin - { normalize preference number to 5 digits } - for n := 0 to t.Count - 1 do - begin - x := Pos(',', t[n]); - if x > 0 then - for m := 1 to 6 - x do - t[n] := '0' + t[n]; - end; - { sort server list } - t.Sorted := True; - { result is sorted list without preference numbers } - for n := 0 to t.Count - 1 do - begin - x := Pos(',', t[n]); - Servers.Add(Copy(t[n], x + 1, Length(t[n]) - x)); - end; - Result := True; - end; - finally - DNS.Free; - t.Free; - end; -end; - -end. diff --git a/addons/synapse/ftpsend.pas b/addons/synapse/ftpsend.pas deleted file mode 100644 index cbbfb35..0000000 --- a/addons/synapse/ftpsend.pas +++ /dev/null @@ -1,1949 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 003.005.003 | -|==============================================================================| -| Content: FTP client | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Petr Esner | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{: @abstract(FTP client protocol) - -Used RFC: RFC-959, RFC-2228, RFC-2428 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit ftpsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil, synaip, synsock; - -const - cFtpProtocol = '21'; - cFtpDataProtocol = '20'; - - {:Terminating value for TLogonActions} - FTP_OK = 255; - {:Terminating value for TLogonActions} - FTP_ERR = 254; - -type - {:Array for holding definition of logon sequence.} - TLogonActions = array [0..17] of byte; - - {:Procedural type for OnStatus event. Sender is calling @link(TFTPSend) object. - Value is FTP command or reply to this comand. (if it is reply, Response - is @True).} - TFTPStatus = procedure(Sender: TObject; Response: Boolean; - const Value: string) of object; - - {: @abstract(Object for holding file information) parsed from directory - listing of FTP server.} - TFTPListRec = class(TObject) - private - FFileName: String; - FDirectory: Boolean; - FReadable: Boolean; - FFileSize: Longint; - FFileTime: TDateTime; - FOriginalLine: string; - FMask: string; - FPermission: String; - public - {: You can assign another TFTPListRec to this object.} - procedure Assign(Value: TFTPListRec); virtual; - {:name of file} - property FileName: string read FFileName write FFileName; - {:if name is subdirectory not file.} - property Directory: Boolean read FDirectory write FDirectory; - {:if you have rights to read} - property Readable: Boolean read FReadable write FReadable; - {:size of file in bytes} - property FileSize: Longint read FFileSize write FFileSize; - {:date and time of file. Local server timezone is used. Any timezone - conversions was not done!} - property FileTime: TDateTime read FFileTime write FFileTime; - {:original unparsed line} - property OriginalLine: string read FOriginalLine write FOriginalLine; - {:mask what was used for parsing} - property Mask: string read FMask write FMask; - {:permission string (depending on used mask!)} - property Permission: string read FPermission write FPermission; - end; - - {:@abstract(This is TList of TFTPListRec objects.) - This object is used for holding lististing of all files information in listed - directory on FTP server.} - TFTPList = class(TObject) - protected - FList: TList; - FLines: TStringList; - FMasks: TStringList; - FUnparsedLines: TStringList; - Monthnames: string; - BlockSize: string; - DirFlagValue: string; - FileName: string; - VMSFileName: string; - Day: string; - Month: string; - ThreeMonth: string; - YearTime: string; - Year: string; - Hours: string; - HoursModif: Ansistring; - Minutes: string; - Seconds: string; - Size: Ansistring; - Permissions: Ansistring; - DirFlag: string; - function GetListItem(Index: integer): TFTPListRec; virtual; - function ParseEPLF(Value: string): Boolean; virtual; - procedure ClearStore; virtual; - function ParseByMask(Value, NextValue, Mask: ansistring): Integer; virtual; - function CheckValues: Boolean; virtual; - procedure FillRecord(const Value: TFTPListRec); virtual; - public - {:Constructor. You not need create this object, it is created by TFTPSend - class as their property.} - constructor Create; - destructor Destroy; override; - - {:Clear list.} - procedure Clear; virtual; - - {:count of holded @link(TFTPListRec) objects} - function Count: integer; virtual; - - {:Assigns one list to another} - procedure Assign(Value: TFTPList); virtual; - - {:try to parse raw directory listing in @link(lines) to list of - @link(TFTPListRec).} - procedure ParseLines; virtual; - - {:By this property you have access to list of @link(TFTPListRec). - This is for compatibility only. Please, use @link(Items) instead.} - property List: TList read FList; - - {:By this property you have access to list of @link(TFTPListRec).} - property Items[Index: Integer]: TFTPListRec read GetListItem; default; - - {:Set of lines with RAW directory listing for @link(parseLines)} - property Lines: TStringList read FLines; - - {:Set of masks for directory listing parser. It is predefined by default, - however you can modify it as you need. (for example, you can add your own - definition mask.) Mask is same as mask used in TotalCommander.} - property Masks: TStringList read FMasks; - - {:After @link(ParseLines) it holding lines what was not sucessfully parsed.} - property UnparsedLines: TStringList read FUnparsedLines; - end; - - {:@abstract(Implementation of FTP protocol.) - Note: Are you missing properties for setting Username and Password? Look to - parent @link(TSynaClient) object! (Username and Password have default values - for "anonymous" FTP login) - - Are you missing properties for specify server address and port? Look to - parent @link(TSynaClient) too!} - TFTPSend = class(TSynaClient) - protected - FOnStatus: TFTPStatus; - FSock: TTCPBlockSocket; - FDSock: TTCPBlockSocket; - FResultCode: Integer; - FResultString: string; - FFullResult: TStringList; - FAccount: string; - FFWHost: string; - FFWPort: string; - FFWUsername: string; - FFWPassword: string; - FFWMode: integer; - FDataStream: TMemoryStream; - FDataIP: string; - FDataPort: string; - FDirectFile: Boolean; - FDirectFileName: string; - FCanResume: Boolean; - FPassiveMode: Boolean; - FForceDefaultPort: Boolean; - FForceOldPort: Boolean; - FFtpList: TFTPList; - FBinaryMode: Boolean; - FAutoTLS: Boolean; - FIsTLS: Boolean; - FIsDataTLS: Boolean; - FTLSonData: Boolean; - FFullSSL: Boolean; - function Auth(Mode: integer): Boolean; virtual; - function Connect: Boolean; virtual; - function InternalStor(const Command: string; RestoreAt: integer): Boolean; virtual; - function DataSocket: Boolean; virtual; - function AcceptDataSocket: Boolean; virtual; - procedure DoStatus(Response: Boolean; const Value: string); virtual; - public - {:Custom definition of login sequence. You can use this when you set - @link(FWMode) to value -1.} - CustomLogon: TLogonActions; - - constructor Create; - destructor Destroy; override; - - {:Waits and read FTP server response. You need this only in special cases!} - function ReadResult: Integer; virtual; - - {:Parse remote side information of data channel from value string (returned - by PASV command). This function you need only in special cases!} - procedure ParseRemote(Value: string); virtual; - - {:Parse remote side information of data channel from value string (returned - by EPSV command). This function you need only in special cases!} - procedure ParseRemoteEPSV(Value: string); virtual; - - {:Send Value as FTP command to FTP server. Returned result code is result of - this function. - This command is good for sending site specific command, or non-standard - commands.} - function FTPCommand(const Value: string): integer; virtual; - - {:Connect and logon to FTP server. If you specify any FireWall, connect to - firewall and throw them connect to FTP server. Login sequence depending on - @link(FWMode).} - function Login: Boolean; virtual; - - {:Logoff and disconnect from FTP server.} - function Logout: Boolean; virtual; - - {:Break current transmission of data. (You can call this method from - Sock.OnStatus event, or from another thread.)} - procedure Abort; virtual; - - {:Break current transmission of data. It is same as Abort, but it send abort - telnet commands prior ABOR FTP command. Some servers need it. (You can call - this method from Sock.OnStatus event, or from another thread.)} - procedure TelnetAbort; virtual; - - {:Download directory listing of Directory on FTP server. If Directory is - empty string, download listing of current working directory. - If NameList is @true, download only names of files in directory. - (internally use NLST command instead LIST command) - If NameList is @false, returned list is also parsed to @link(FTPList) - property.} - function List(Directory: string; NameList: Boolean): Boolean; virtual; - - {:Read data from FileName on FTP server. If Restore is @true and server - supports resume dowloads, download is resumed. (received is only rest - of file)} - function RetrieveFile(const FileName: string; Restore: Boolean): Boolean; virtual; - - {:Send data to FileName on FTP server. If Restore is @true and server - supports resume upload, upload is resumed. (send only rest of file) - In this case if remote file is same length as local file, nothing will be - done. If remote file is larger then local, resume is disabled and file is - transfered from begin!} - function StoreFile(const FileName: string; Restore: Boolean): Boolean; virtual; - - {:Send data to FTP server and assing unique name for this file.} - function StoreUniqueFile: Boolean; virtual; - - {:Append data to FileName on FTP server.} - function AppendFile(const FileName: string): Boolean; virtual; - - {:Rename on FTP server file with OldName to NewName.} - function RenameFile(const OldName, NewName: string): Boolean; virtual; - - {:Delete file FileName on FTP server.} - function DeleteFile(const FileName: string): Boolean; virtual; - - {:Return size of Filename file on FTP server. If command failed (i.e. not - implemented), return -1.} - function FileSize(const FileName: string): integer; virtual; - - {:Send NOOP command to FTP server for preserve of disconnect by inactivity - timeout.} - function NoOp: Boolean; virtual; - - {:Change currect working directory to Directory on FTP server.} - function ChangeWorkingDir(const Directory: string): Boolean; virtual; - - {:walk to upper directory on FTP server.} - function ChangeToParentDir: Boolean; virtual; - - {:walk to root directory on FTP server. (May not work with all servers properly!)} - function ChangeToRootDir: Boolean; virtual; - - {:Delete Directory on FTP server.} - function DeleteDir(const Directory: string): Boolean; virtual; - - {:Create Directory on FTP server.} - function CreateDir(const Directory: string): Boolean; virtual; - - {:Return current working directory on FTP server.} - function GetCurrentDir: String; virtual; - - {:Establish data channel to FTP server and retrieve data. - This function you need only in special cases, i.e. when you need to implement - some special unsupported FTP command!} - function DataRead(const DestStream: TStream): Boolean; virtual; - - {:Establish data channel to FTP server and send data. - This function you need only in special cases, i.e. when you need to implement - some special unsupported FTP command.} - function DataWrite(const SourceStream: TStream): Boolean; virtual; - published - {:After FTP command contains result number of this operation.} - property ResultCode: Integer read FResultCode; - - {:After FTP command contains main line of result.} - property ResultString: string read FResultString; - - {:After any FTP command it contains all lines of FTP server reply.} - property FullResult: TStringList read FFullResult; - - {:Account information used in some cases inside login sequence.} - property Account: string read FAccount Write FAccount; - - {:Address of firewall. If empty string (default), firewall not used.} - property FWHost: string read FFWHost Write FFWHost; - - {:port of firewall. standard value is same port as ftp server used. (21)} - property FWPort: string read FFWPort Write FFWPort; - - {:Username for login to firewall. (if needed)} - property FWUsername: string read FFWUsername Write FFWUsername; - - {:password for login to firewall. (if needed)} - property FWPassword: string read FFWPassword Write FFWPassword; - - {:Type of Firewall. Used only if you set some firewall address. Supported - predefined firewall login sequences are described by comments in source - file where you can see pseudocode decribing each sequence.} - property FWMode: integer read FFWMode Write FFWMode; - - {:Socket object used for TCP/IP operation on control channel. Good for - seting OnStatus hook, etc.} - property Sock: TTCPBlockSocket read FSock; - - {:Socket object used for TCP/IP operation on data channel. Good for seting - OnStatus hook, etc.} - property DSock: TTCPBlockSocket read FDSock; - - {:If you not use @link(DirectFile) mode, all data transfers is made to or - from this stream.} - property DataStream: TMemoryStream read FDataStream; - - {:After data connection is established, contains remote side IP of this - connection.} - property DataIP: string read FDataIP; - - {:After data connection is established, contains remote side port of this - connection.} - property DataPort: string read FDataPort; - - {:Mode of data handling by data connection. If @False, all data operations - are made to or from @link(DataStream) TMemoryStream. - If @true, data operations is made directly to file in your disk. (filename - is specified by @link(DirectFileName) property.) Dafault is @False!} - property DirectFile: Boolean read FDirectFile Write FDirectFile; - - {:Filename for direct disk data operations.} - property DirectFileName: string read FDirectFileName Write FDirectFileName; - - {:Indicate after @link(Login) if remote server support resume downloads and - uploads.} - property CanResume: Boolean read FCanResume; - - {:If true (default value), all transfers is made by passive method. - It is safer method for various firewalls.} - property PassiveMode: Boolean read FPassiveMode Write FPassiveMode; - - {:Force to listen for dataconnection on standard port (20). Default is @false, - dataconnections will be made to any non-standard port reported by PORT FTP - command. This setting is not used, if you use passive mode.} - property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort; - - {:When is @true, then is disabled EPSV and EPRT support. However without this - commands you cannot use IPv6! (Disabling of this commands is needed only - when you are behind some crap firewall/NAT.} - property ForceOldPort: Boolean read FForceOldPort Write FForceOldPort; - - {:You may set this hook for monitoring FTP commands and replies.} - property OnStatus: TFTPStatus read FOnStatus write FOnStatus; - - {:After LIST command is here parsed list of files in given directory.} - property FtpList: TFTPList read FFtpList; - - {:if @true (default), then data transfers is in binary mode. If this is set - to @false, then ASCII mode is used.} - property BinaryMode: Boolean read FBinaryMode Write FBinaryMode; - - {:if is true, then if server support upgrade to SSL/TLS mode, then use them.} - property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; - - {:if server listen on SSL/TLS port, then you set this to true.} - property FullSSL: Boolean read FFullSSL Write FFullSSL; - - {:Signalise, if control channel is in SSL/TLS mode.} - property IsTLS: Boolean read FIsTLS; - - {:Signalise, if data transfers is in SSL/TLS mode.} - property IsDataTLS: Boolean read FIsDataTLS; - - {:If @true (default), then try to use SSL/TLS on data transfers too. - If @false, then SSL/TLS is used only for control connection.} - property TLSonData: Boolean read FTLSonData write FTLSonData; - end; - -{:A very useful function, and example of use can be found in the TFtpSend object. - Dowload specified file from FTP server to LocalFile.} -function FtpGetFile(const IP, Port, FileName, LocalFile, - User, Pass: string): Boolean; - -{:A very useful function, and example of use can be found in the TFtpSend object. - Upload specified LocalFile to FTP server.} -function FtpPutFile(const IP, Port, FileName, LocalFile, - User, Pass: string): Boolean; - -{:A very useful function, and example of use can be found in the TFtpSend object. - Initiate transfer of file between two FTP servers.} -function FtpInterServerTransfer( - const FromIP, FromPort, FromFile, FromUser, FromPass: string; - const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean; - -implementation - -constructor TFTPSend.Create; -begin - inherited Create; - FFullResult := TStringList.Create; - FDataStream := TMemoryStream.Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FSock.ConvertLineEnd := True; - FDSock := TTCPBlockSocket.Create; - FDSock.Owner := self; - FFtpList := TFTPList.Create; - FTimeout := 300000; - FTargetPort := cFtpProtocol; - FUsername := 'anonymous'; - FPassword := 'anonymous@' + FSock.LocalName; - FDirectFile := False; - FPassiveMode := True; - FForceDefaultPort := False; - FForceOldPort := false; - FAccount := ''; - FFWHost := ''; - FFWPort := cFtpProtocol; - FFWUsername := ''; - FFWPassword := ''; - FFWMode := 0; - FBinaryMode := True; - FAutoTLS := False; - FFullSSL := False; - FIsTLS := False; - FIsDataTLS := False; - FTLSonData := True; -end; - -destructor TFTPSend.Destroy; -begin - FDSock.Free; - FSock.Free; - FFTPList.Free; - FDataStream.Free; - FFullResult.Free; - inherited Destroy; -end; - -procedure TFTPSend.DoStatus(Response: Boolean; const Value: string); -begin - if assigned(OnStatus) then - OnStatus(Self, Response, Value); -end; - -function TFTPSend.ReadResult: Integer; -var - s, c: AnsiString; -begin - FFullResult.Clear; - c := ''; - repeat - s := FSock.RecvString(FTimeout); - if c = '' then - if length(s) > 3 then - if s[4] in [' ', '-'] then - c :=Copy(s, 1, 3); - FResultString := s; - FFullResult.Add(s); - DoStatus(True, s); - if FSock.LastError <> 0 then - Break; - until (c <> '') and (Pos(c + ' ', s) = 1); - Result := StrToIntDef(c, 0); - FResultCode := Result; -end; - -function TFTPSend.FTPCommand(const Value: string): integer; -begin - FSock.Purge; - FSock.SendString(Value + CRLF); - DoStatus(False, Value); - Result := ReadResult; -end; - -// based on idea by Petr Esner -function TFTPSend.Auth(Mode: integer): Boolean; -const - //if not USER then - // if not PASS then - // if not ACCT then ERROR! - //OK! - Action0: TLogonActions = - (0, FTP_OK, 3, - 1, FTP_OK, 6, - 2, FTP_OK, FTP_ERR, - 0, 0, 0, 0, 0, 0, 0, 0, 0); - - //if not USER then - // if not PASS then ERROR! - //if SITE then ERROR! - //if not USER then - // if not PASS then - // if not ACCT then ERROR! - //OK! - Action1: TLogonActions = - (3, 6, 3, - 4, 6, FTP_ERR, - 5, FTP_ERR, 9, - 0, FTP_OK, 12, - 1, FTP_OK, 15, - 2, FTP_OK, FTP_ERR); - - //if not USER then - // if not PASS then ERROR! - //if USER '@' then OK! - //if not PASS then - // if not ACCT then ERROR! - //OK! - Action2: TLogonActions = - (3, 6, 3, - 4, 6, FTP_ERR, - 6, FTP_OK, 9, - 1, FTP_OK, 12, - 2, FTP_OK, FTP_ERR, - 0, 0, 0); - - //if not USER then - // if not PASS then ERROR! - //if not USER then - // if not PASS then - // if not ACCT then ERROR! - //OK! - Action3: TLogonActions = - (3, 6, 3, - 4, 6, FTP_ERR, - 0, FTP_OK, 9, - 1, FTP_OK, 12, - 2, FTP_OK, FTP_ERR, - 0, 0, 0); - - //OPEN - //if not USER then - // if not PASS then - // if not ACCT then ERROR! - //OK! - Action4: TLogonActions = - (7, 3, 3, - 0, FTP_OK, 6, - 1, FTP_OK, 9, - 2, FTP_OK, FTP_ERR, - 0, 0, 0, 0, 0, 0); - - //if USER '@' then OK! - //if not PASS then - // if not ACCT then ERROR! - //OK! - Action5: TLogonActions = - (6, FTP_OK, 3, - 1, FTP_OK, 6, - 2, FTP_OK, FTP_ERR, - 0, 0, 0, 0, 0, 0, 0, 0, 0); - - //if not USER @ then - // if not PASS then ERROR! - //if not USER then - // if not PASS then - // if not ACCT then ERROR! - //OK! - Action6: TLogonActions = - (8, 6, 3, - 4, 6, FTP_ERR, - 0, FTP_OK, 9, - 1, FTP_OK, 12, - 2, FTP_OK, FTP_ERR, - 0, 0, 0); - - //if USER @ then ERROR! - //if not PASS then - // if not ACCT then ERROR! - //OK! - Action7: TLogonActions = - (9, FTP_ERR, 3, - 1, FTP_OK, 6, - 2, FTP_OK, FTP_ERR, - 0, 0, 0, 0, 0, 0, 0, 0, 0); - - //if not USER @@ then - // if not PASS @ then - // if not ACCT then ERROR! - //OK! - Action8: TLogonActions = - (10, FTP_OK, 3, - 11, FTP_OK, 6, - 2, FTP_OK, FTP_ERR, - 0, 0, 0, 0, 0, 0, 0, 0, 0); -var - FTPServer: string; - LogonActions: TLogonActions; - i: integer; - s: string; - x: integer; -begin - Result := False; - if FFWHost = '' then - Mode := 0; - if (FTargetPort = cFtpProtocol) or (FTargetPort = '21') then - FTPServer := FTargetHost - else - FTPServer := FTargetHost + ':' + FTargetPort; - case Mode of - -1: - LogonActions := CustomLogon; - 1: - LogonActions := Action1; - 2: - LogonActions := Action2; - 3: - LogonActions := Action3; - 4: - LogonActions := Action4; - 5: - LogonActions := Action5; - 6: - LogonActions := Action6; - 7: - LogonActions := Action7; - 8: - LogonActions := Action8; - else - LogonActions := Action0; - end; - i := 0; - repeat - case LogonActions[i] of - 0: s := 'USER ' + FUserName; - 1: s := 'PASS ' + FPassword; - 2: s := 'ACCT ' + FAccount; - 3: s := 'USER ' + FFWUserName; - 4: s := 'PASS ' + FFWPassword; - 5: s := 'SITE ' + FTPServer; - 6: s := 'USER ' + FUserName + '@' + FTPServer; - 7: s := 'OPEN ' + FTPServer; - 8: s := 'USER ' + FFWUserName + '@' + FTPServer; - 9: s := 'USER ' + FUserName + '@' + FTPServer + ' ' + FFWUserName; - 10: s := 'USER ' + FUserName + '@' + FFWUserName + '@' + FTPServer; - 11: s := 'PASS ' + FPassword + '@' + FFWPassword; - end; - x := FTPCommand(s); - x := x div 100; - if (x <> 2) and (x <> 3) then - Exit; - i := LogonActions[i + x - 1]; - case i of - FTP_ERR: - Exit; - FTP_OK: - begin - Result := True; - Exit; - end; - end; - until False; -end; - - -function TFTPSend.Connect: Boolean; -begin - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError = 0 then - if FFWHost = '' then - FSock.Connect(FTargetHost, FTargetPort) - else - FSock.Connect(FFWHost, FFWPort); - if FSock.LastError = 0 then - if FFullSSL then - FSock.SSLDoConnect; - Result := FSock.LastError = 0; -end; - -function TFTPSend.Login: Boolean; -var - x: integer; -begin - Result := False; - FCanResume := False; - if not Connect then - Exit; - FIsTLS := FFullSSL; - FIsDataTLS := False; - repeat - x := ReadResult div 100; - until x <> 1; - if x <> 2 then - Exit; - if FAutoTLS and not(FIsTLS) then - if (FTPCommand('AUTH TLS') div 100) = 2 then - begin - FSock.SSLDoConnect; - FIsTLS := FSock.LastError = 0; - if not FIsTLS then - begin - Result := False; - Exit; - end; - end; - if not Auth(FFWMode) then - Exit; - if FIsTLS then - begin - FTPCommand('PBSZ 0'); - if FTLSonData then - FIsDataTLS := (FTPCommand('PROT P') div 100) = 2; - if not FIsDataTLS then - FTPCommand('PROT C'); - end; - FTPCommand('TYPE I'); - FTPCommand('STRU F'); - FTPCommand('MODE S'); - if FTPCommand('REST 0') = 350 then - if FTPCommand('REST 1') = 350 then - begin - FTPCommand('REST 0'); - FCanResume := True; - end; - Result := True; -end; - -function TFTPSend.Logout: Boolean; -begin - Result := (FTPCommand('QUIT') div 100) = 2; - FSock.CloseSocket; -end; - -procedure TFTPSend.ParseRemote(Value: string); -var - n: integer; - nb, ne: integer; - s: string; - x: integer; -begin - Value := trim(Value); - nb := Pos('(',Value); - ne := Pos(')',Value); - if (nb = 0) or (ne = 0) then - begin - nb:=RPos(' ',Value); - s:=Copy(Value, nb + 1, Length(Value) - nb); - end - else - begin - s:=Copy(Value,nb+1,ne-nb-1); - end; - for n := 1 to 4 do - if n = 1 then - FDataIP := Fetch(s, ',') - else - FDataIP := FDataIP + '.' + Fetch(s, ','); - x := StrToIntDef(Fetch(s, ','), 0) * 256; - x := x + StrToIntDef(Fetch(s, ','), 0); - FDataPort := IntToStr(x); -end; - -procedure TFTPSend.ParseRemoteEPSV(Value: string); -var - n: integer; - s, v: AnsiString; -begin - s := SeparateRight(Value, '('); - s := Trim(SeparateLeft(s, ')')); - Delete(s, Length(s), 1); - v := ''; - for n := Length(s) downto 1 do - if s[n] in ['0'..'9'] then - v := s[n] + v - else - Break; - FDataPort := v; - FDataIP := FTargetHost; -end; - -function TFTPSend.DataSocket: boolean; -var - s: string; -begin - Result := False; - if FIsDataTLS then - FPassiveMode := True; - if FPassiveMode then - begin - if FSock.IP6used then - s := '2' - else - s := '1'; - if not(FForceOldPort) and ((FTPCommand('EPSV ' + s) div 100) = 2) then - begin - ParseRemoteEPSV(FResultString); - end - else - if FSock.IP6used then - Exit - else - begin - if (FTPCommand('PASV') div 100) <> 2 then - Exit; - ParseRemote(FResultString); - end; - FDSock.CloseSocket; - FDSock.Bind(FIPInterface, cAnyPort); - FDSock.Connect(FDataIP, FDataPort); - Result := FDSock.LastError = 0; - end - else - begin - FDSock.CloseSocket; - if FForceDefaultPort then - s := cFtpDataProtocol - else - s := '0'; - //data conection from same interface as command connection - FDSock.Bind(FSock.GetLocalSinIP, s); - if FDSock.LastError <> 0 then - Exit; - FDSock.SetLinger(True, 10000); - FDSock.Listen; - FDSock.GetSins; - FDataIP := FDSock.GetLocalSinIP; - FDataIP := FDSock.ResolveName(FDataIP); - FDataPort := IntToStr(FDSock.GetLocalSinPort); - if not FForceOldPort then - begin - if IsIp6(FDataIP) then - s := '2' - else - s := '1'; - s := 'EPRT |' + s +'|' + FDataIP + '|' + FDataPort + '|'; - Result := (FTPCommand(s) div 100) = 2; - end; - if not Result and IsIP(FDataIP) then - begin - s := ReplaceString(FDataIP, '.', ','); - s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256) - + ',' + IntToStr(FDSock.GetLocalSinPort mod 256); - Result := (FTPCommand(s) div 100) = 2; - end; - end; -end; - -function TFTPSend.AcceptDataSocket: Boolean; -var - x: TSocket; -begin - if FPassiveMode then - Result := True - else - begin - Result := False; - if FDSock.CanRead(FTimeout) then - begin - x := FDSock.Accept; - if not FDSock.UsingSocks then - FDSock.CloseSocket; - FDSock.Socket := x; - Result := True; - end; - end; - if Result and FIsDataTLS then - begin - FDSock.SSL.Assign(FSock.SSL); - FDSock.SSLDoConnect; - Result := FDSock.LastError = 0; - end; -end; - -function TFTPSend.DataRead(const DestStream: TStream): Boolean; -var - x: integer; -begin - Result := False; - try - if not AcceptDataSocket then - Exit; - FDSock.RecvStreamRaw(DestStream, FTimeout); - FDSock.CloseSocket; - x := ReadResult; - Result := (x div 100) = 2; - finally - FDSock.CloseSocket; - end; -end; - -function TFTPSend.DataWrite(const SourceStream: TStream): Boolean; -var - x: integer; - b: Boolean; -begin - Result := False; - try - if not AcceptDataSocket then - Exit; - FDSock.SendStreamRaw(SourceStream); - b := FDSock.LastError = 0; - FDSock.CloseSocket; - x := ReadResult; - Result := b and ((x div 100) = 2); - finally - FDSock.CloseSocket; - end; -end; - -function TFTPSend.List(Directory: string; NameList: Boolean): Boolean; -var - x: integer; -begin - Result := False; - FDataStream.Clear; - FFTPList.Clear; - if Directory <> '' then - Directory := ' ' + Directory; - FTPCommand('TYPE A'); - if not DataSocket then - Exit; - if NameList then - x := FTPCommand('NLST' + Directory) - else - x := FTPCommand('LIST' + Directory); - if (x div 100) <> 1 then - Exit; - Result := DataRead(FDataStream); - if (not NameList) and Result then - begin - FDataStream.Position := 0; - FFTPList.Lines.LoadFromStream(FDataStream); - FFTPList.ParseLines; - end; - FDataStream.Position := 0; -end; - -function TFTPSend.RetrieveFile(const FileName: string; Restore: Boolean): Boolean; -var - RetrStream: TStream; -begin - Result := False; - if FileName = '' then - Exit; - if not DataSocket then - Exit; - Restore := Restore and FCanResume; - if FDirectFile then - if Restore and FileExists(FDirectFileName) then - RetrStream := TFileStream.Create(FDirectFileName, - fmOpenReadWrite or fmShareExclusive) - else - RetrStream := TFileStream.Create(FDirectFileName, - fmCreate or fmShareDenyWrite) - else - RetrStream := FDataStream; - try - if FBinaryMode then - FTPCommand('TYPE I') - else - FTPCommand('TYPE A'); - if Restore then - begin - RetrStream.Position := RetrStream.Size; - if (FTPCommand('REST ' + IntToStr(RetrStream.Size)) div 100) <> 3 then - Exit; - end - else - if RetrStream is TMemoryStream then - TMemoryStream(RetrStream).Clear; - if (FTPCommand('RETR ' + FileName) div 100) <> 1 then - Exit; - Result := DataRead(RetrStream); - if not FDirectFile then - RetrStream.Position := 0; - finally - if FDirectFile then - RetrStream.Free; - end; -end; - -function TFTPSend.InternalStor(const Command: string; RestoreAt: integer): Boolean; -var - SendStream: TStream; - StorSize: integer; -begin - Result := False; - if FDirectFile then - if not FileExists(FDirectFileName) then - Exit - else - SendStream := TFileStream.Create(FDirectFileName, - fmOpenRead or fmShareDenyWrite) - else - SendStream := FDataStream; - try - if not DataSocket then - Exit; - if FBinaryMode then - FTPCommand('TYPE I') - else - FTPCommand('TYPE A'); - StorSize := SendStream.Size; - if not FCanResume then - RestoreAt := 0; - if (StorSize > 0) and (RestoreAt = StorSize) then - begin - Result := True; - Exit; - end; - if RestoreAt > StorSize then - RestoreAt := 0; - FTPCommand('ALLO ' + IntToStr(StorSize - RestoreAt)); - if FCanResume then - if (FTPCommand('REST ' + IntToStr(RestoreAt)) div 100) <> 3 then - Exit; - SendStream.Position := RestoreAt; - if (FTPCommand(Command) div 100) <> 1 then - Exit; - Result := DataWrite(SendStream); - finally - if FDirectFile then - SendStream.Free; - end; -end; - -function TFTPSend.StoreFile(const FileName: string; Restore: Boolean): Boolean; -var - RestoreAt: integer; -begin - Result := False; - if FileName = '' then - Exit; - RestoreAt := 0; - Restore := Restore and FCanResume; - if Restore then - begin - RestoreAt := Self.FileSize(FileName); - if RestoreAt < 0 then - RestoreAt := 0; - end; - Result := InternalStor('STOR ' + FileName, RestoreAt); -end; - -function TFTPSend.StoreUniqueFile: Boolean; -begin - Result := InternalStor('STOU', 0); -end; - -function TFTPSend.AppendFile(const FileName: string): Boolean; -begin - Result := False; - if FileName = '' then - Exit; - Result := InternalStor('APPE '+FileName, 0); -end; - -function TFTPSend.NoOp: Boolean; -begin - Result := (FTPCommand('NOOP') div 100) = 2; -end; - -function TFTPSend.RenameFile(const OldName, NewName: string): Boolean; -begin - Result := False; - if (FTPCommand('RNFR ' + OldName) div 100) <> 3 then - Exit; - Result := (FTPCommand('RNTO ' + NewName) div 100) = 2; -end; - -function TFTPSend.DeleteFile(const FileName: string): Boolean; -begin - Result := (FTPCommand('DELE ' + FileName) div 100) = 2; -end; - -function TFTPSend.FileSize(const FileName: string): integer; -var - s: string; -begin - Result := -1; - if (FTPCommand('SIZE ' + FileName) div 100) = 2 then - begin - s := Trim(SeparateRight(ResultString, ' ')); - s := Trim(SeparateLeft(s, ' ')); - Result := StrToIntDef(s, -1); - end; -end; - -function TFTPSend.ChangeWorkingDir(const Directory: string): Boolean; -begin - Result := (FTPCommand('CWD ' + Directory) div 100) = 2; -end; - -function TFTPSend.ChangeToParentDir: Boolean; -begin - Result := (FTPCommand('CDUP') div 100) = 2; -end; - -function TFTPSend.ChangeToRootDir: Boolean; -begin - Result := ChangeWorkingDir('/'); -end; - -function TFTPSend.DeleteDir(const Directory: string): Boolean; -begin - Result := (FTPCommand('RMD ' + Directory) div 100) = 2; -end; - -function TFTPSend.CreateDir(const Directory: string): Boolean; -begin - Result := (FTPCommand('MKD ' + Directory) div 100) = 2; -end; - -function TFTPSend.GetCurrentDir: String; -begin - Result := ''; - if (FTPCommand('PWD') div 100) = 2 then - begin - Result := SeparateRight(FResultString, '"'); - Result := Trim(Separateleft(Result, '"')); - end; -end; - -procedure TFTPSend.Abort; -begin - FSock.SendString('ABOR' + CRLF); - FDSock.StopFlag := True; -end; - -procedure TFTPSend.TelnetAbort; -begin - FSock.SendString(#$FF + #$F4 + #$FF + #$F2); - Abort; -end; - -{==============================================================================} - -procedure TFTPListRec.Assign(Value: TFTPListRec); -begin - FFileName := Value.FileName; - FDirectory := Value.Directory; - FReadable := Value.Readable; - FFileSize := Value.FileSize; - FFileTime := Value.FileTime; - FOriginalLine := Value.OriginalLine; - FMask := Value.Mask; -end; - -constructor TFTPList.Create; -begin - inherited Create; - FList := TList.Create; - FLines := TStringList.Create; - FMasks := TStringList.Create; - FUnparsedLines := TStringList.Create; - //various UNIX - FMasks.add('pppppppppp $!!!S*$TTT$DD$hh mm ss$YYYY$n*'); - FMasks.add('pppppppppp $!!!S*$DD$TTT$hh mm ss$YYYY$n*'); - FMasks.add('pppppppppp $!!!S*$TTT$DD$UUUUU$n*'); //mostly used UNIX format - FMasks.add('pppppppppp $!!!S*$DD$TTT$UUUUU$n*'); - //MacOS - FMasks.add('pppppppppp $!!S*$TTT$DD$UUUUU$n*'); - FMasks.add('pppppppppp $!S*$TTT$DD$UUUUU$n*'); - //Novell - FMasks.add('d $!S*$TTT$DD$UUUUU$n*'); - //Windows - FMasks.add('MM DD YY hh mmH !S* n*'); - FMasks.add('MM DD YY hh mmH $ d!n*'); - FMasks.add('MM DD YYYY hh mmH !S* n*'); - FMasks.add('MM DD YYYY hh mmH $ d!n*'); - FMasks.add('DD MM YYYY hh mmH !S* n*'); - FMasks.add('DD MM YYYY hh mmH $ d!n*'); - //VMS - FMasks.add('v*$ DD TTT YYYY hh mm'); - FMasks.add('v*$!DD TTT YYYY hh mm'); - FMasks.add('n*$ YYYY MM DD hh mm$S*'); - //AS400 - FMasks.add('!S*$MM DD YY hh mm ss !n*'); - FMasks.add('!S*$DD MM YY hh mm ss !n*'); - FMasks.add('n*!S*$MM DD YY hh mm ss d'); - FMasks.add('n*!S*$DD MM YY hh mm ss d'); - //VxWorks - FMasks.add('$S* TTT DD YYYY hh mm ss $n* $ d'); - FMasks.add('$S* TTT DD YYYY hh mm ss $n*'); - //Distinct - FMasks.add('d $S*$TTT DD YYYY hh mm$n*'); - FMasks.add('d $S*$TTT DD$hh mm$n*'); - //PC-NFSD - FMasks.add('nnnnnnnn.nnn dSSSSSSSSSSS MM DD YY hh mmH'); - //VOS - FMasks.add('- SSSSS YY MM DD hh mm ss n*'); - FMasks.add('- d= SSSSS YY MM DD hh mm ss n*'); - //Unissys ClearPath - FMasks.add('nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn SSSSSSSSS MM DD YYYY hh mm'); - FMasks.add('n*\x SSSSSSSSS MM DD YYYY hh mm'); - //IBM - FMasks.add('- SSSSSSSSSSSS d MM DD YYYY hh mm n*'); - //OS9 - FMasks.add('- YY MM DD hhmm d SSSSSSSSS n*'); - //tandem - FMasks.add('nnnnnnnn SSSSSSS DD TTT YY hh mm ss'); - //MVS - FMasks.add('- YYYY MM DD SSSSS d=O n*'); - //BullGCOS8 - FMasks.add(' $S* MM DD YY hh mm ss !n*'); - FMasks.add('d $S* MM DD YY !n*'); - //BullGCOS7 - FMasks.add(' TTT DD YYYY n*'); - FMasks.add(' d n*'); -end; - -destructor TFTPList.Destroy; -begin - Clear; - FList.Free; - FLines.Free; - FMasks.Free; - FUnparsedLines.Free; - inherited Destroy; -end; - -procedure TFTPList.Clear; -var - n:integer; -begin - for n := 0 to FList.Count - 1 do - if Assigned(FList[n]) then - TFTPListRec(FList[n]).Free; - FList.Clear; - FLines.Clear; - FUnparsedLines.Clear; -end; - -function TFTPList.Count: integer; -begin - Result := FList.Count; -end; - -function TFTPList.GetListItem(Index: integer): TFTPListRec; -begin - Result := nil; - if Index < Count then - Result := TFTPListRec(FList[Index]); -end; - -procedure TFTPList.Assign(Value: TFTPList); -var - flr: TFTPListRec; - n: integer; -begin - Clear; - for n := 0 to Value.Count - 1 do - begin - flr := TFTPListRec.Create; - flr.Assign(Value[n]); - Flist.Add(flr); - end; - Lines.Assign(Value.Lines); - Masks.Assign(Value.Masks); - UnparsedLines.Assign(Value.UnparsedLines); -end; - -procedure TFTPList.ClearStore; -begin - Monthnames := ''; - BlockSize := ''; - DirFlagValue := ''; - FileName := ''; - VMSFileName := ''; - Day := ''; - Month := ''; - ThreeMonth := ''; - YearTime := ''; - Year := ''; - Hours := ''; - HoursModif := ''; - Minutes := ''; - Seconds := ''; - Size := ''; - Permissions := ''; - DirFlag := ''; -end; - -function TFTPList.ParseByMask(Value, NextValue, Mask: AnsiString): Integer; -var - Ivalue, IMask: integer; - MaskC, LastMaskC: AnsiChar; - c: AnsiChar; - s: string; -begin - ClearStore; - Result := 0; - if Value = '' then - Exit; - if Mask = '' then - Exit; - Ivalue := 1; - IMask := 1; - Result := 1; - LastMaskC := ' '; - while Imask <= Length(mask) do - begin - if (Mask[Imask] <> '*') and (Ivalue > Length(Value)) then - begin - Result := 0; - Exit; - end; - MaskC := Mask[Imask]; - if Ivalue > Length(Value) then - Exit; - c := Value[Ivalue]; - case MaskC of - 'n': - FileName := FileName + c; - 'v': - VMSFileName := VMSFileName + c; - '.': - begin - if c in ['.', ' '] then - FileName := TrimSP(FileName) + '.' - else - begin - Result := 0; - Exit; - end; - end; - 'D': - Day := Day + c; - 'M': - Month := Month + c; - 'T': - ThreeMonth := ThreeMonth + c; - 'U': - YearTime := YearTime + c; - 'Y': - Year := Year + c; - 'h': - Hours := Hours + c; - 'H': - HoursModif := HoursModif + c; - 'm': - Minutes := Minutes + c; - 's': - Seconds := Seconds + c; - 'S': - Size := Size + c; - 'p': - Permissions := Permissions + c; - 'd': - DirFlag := DirFlag + c; - 'x': - if c <> ' ' then - begin - Result := 0; - Exit; - end; - '*': - begin - s := ''; - if LastMaskC in ['n', 'v'] then - begin - if Imask = Length(Mask) then - s := Copy(Value, IValue, Maxint) - else - while IValue <= Length(Value) do - begin - if Value[Ivalue] = ' ' then - break; - s := s + Value[Ivalue]; - Inc(Ivalue); - end; - if LastMaskC = 'n' then - FileName := FileName + s - else - VMSFileName := VMSFileName + s; - end - else - begin - while IValue <= Length(Value) do - begin - if not(Value[Ivalue] in ['0'..'9']) then - break; - s := s + Value[Ivalue]; - Inc(Ivalue); - end; - case LastMaskC of - 'S': - Size := Size + s; - end; - end; - Dec(IValue); - end; - '!': - begin - while IValue <= Length(Value) do - begin - if Value[Ivalue] = ' ' then - break; - Inc(Ivalue); - end; - while IValue <= Length(Value) do - begin - if Value[Ivalue] <> ' ' then - break; - Inc(Ivalue); - end; - Dec(IValue); - end; - '$': - begin - while IValue <= Length(Value) do - begin - if not(Value[Ivalue] in [' ', #9]) then - break; - Inc(Ivalue); - end; - Dec(IValue); - end; - '=': - begin - s := ''; - case LastmaskC of - 'S': - begin - while Imask <= Length(Mask) do - begin - if not(Mask[Imask] in ['0'..'9']) then - break; - s := s + Mask[Imask]; - Inc(Imask); - end; - Dec(Imask); - BlockSize := s; - end; - 'T': - begin - Monthnames := Copy(Mask, IMask, 12 * 3); - Inc(IMask, 12 * 3); - end; - 'd': - begin - Inc(Imask); - DirFlagValue := Mask[Imask]; - end; - end; - end; - '\': - begin - Value := NextValue; - IValue := 0; - Result := 2; - end; - end; - Inc(Ivalue); - Inc(Imask); - LastMaskC := MaskC; - end; -end; - -function TFTPList.CheckValues: Boolean; -var - x, n: integer; -begin - Result := false; - if FileName <> '' then - begin - if pos('?', VMSFilename) > 0 then - Exit; - if pos('*', VMSFilename) > 0 then - Exit; - end; - if VMSFileName <> '' then - if pos(';', VMSFilename) <= 0 then - Exit; - if (FileName = '') and (VMSFileName = '') then - Exit; - if Permissions <> '' then - begin - if length(Permissions) <> 10 then - Exit; - for n := 1 to 10 do - if not(Permissions[n] in - ['a', 'b', 'c', 'd', 'h', 'l', 'p', 'r', 's', 't', 'w', 'x', 'y', '-']) then - Exit; - end; - if Day <> '' then - begin - Day := TrimSP(Day); - x := StrToIntDef(day, -1); - if (x < 1) or (x > 31) then - Exit; - end; - if Month <> '' then - begin - Month := TrimSP(Month); - x := StrToIntDef(Month, -1); - if (x < 1) or (x > 12) then - Exit; - end; - if Hours <> '' then - begin - Hours := TrimSP(Hours); - x := StrToIntDef(Hours, -1); - if (x < 0) or (x > 24) then - Exit; - end; - if HoursModif <> '' then - begin - if not (HoursModif[1] in ['a', 'A', 'p', 'P']) then - Exit; - end; - if Minutes <> '' then - begin - Minutes := TrimSP(Minutes); - x := StrToIntDef(Minutes, -1); - if (x < 0) or (x > 59) then - Exit; - end; - if Seconds <> '' then - begin - Seconds := TrimSP(Seconds); - x := StrToIntDef(Seconds, -1); - if (x < 0) or (x > 59) then - Exit; - end; - if Size <> '' then - begin - Size := TrimSP(Size); - for n := 1 to Length(Size) do - if not (Size[n] in ['0'..'9']) then - Exit; - end; - - if length(Monthnames) = (12 * 3) then - for n := 1 to 12 do - CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3); - if ThreeMonth <> '' then - begin - x := GetMonthNumber(ThreeMonth); - if (x = 0) then - Exit; - end; - if YearTime <> '' then - begin - YearTime := ReplaceString(YearTime, '-', ':'); - if pos(':', YearTime) > 0 then - begin - if (GetTimeFromstr(YearTime) = -1) then - Exit; - end - else - begin - YearTime := TrimSP(YearTime); - x := StrToIntDef(YearTime, -1); - if (x = -1) then - Exit; - if (x < 1900) or (x > 2100) then - Exit; - end; - end; - if Year <> '' then - begin - Year := TrimSP(Year); - x := StrToIntDef(Year, -1); - if (x = -1) then - Exit; - if Length(Year) = 4 then - begin - if not((x > 1900) and (x < 2100)) then - Exit; - end - else - if Length(Year) = 2 then - begin - if not((x >= 0) and (x <= 99)) then - Exit; - end - else - if Length(Year) = 3 then - begin - if not((x >= 100) and (x <= 110)) then - Exit; - end - else - Exit; - end; - Result := True; -end; - -procedure TFTPList.FillRecord(const Value: TFTPListRec); -var - s: string; - x: integer; - myear: Word; - mmonth: Word; - mday: Word; - mhours, mminutes, mseconds: word; - n: integer; -begin - s := DirFlagValue; - if s = '' then - s := 'D'; - s := Uppercase(s); - Value.Directory := s = Uppercase(DirFlag); - if FileName <> '' then - Value.FileName := SeparateLeft(Filename, ' -> '); - if VMSFileName <> '' then - begin - Value.FileName := VMSFilename; - Value.Directory := Pos('.DIR;',VMSFilename) > 0; - end; - Value.FileName := TrimSPRight(Value.FileName); - Value.Readable := not Value.Directory; - if BlockSize <> '' then - x := StrToIntDef(BlockSize, 1) - else - x := 1; - Value.FileSize := x * StrToIntDef(Size, 0); - - DecodeDate(Date,myear,mmonth,mday); - mhours := 0; - mminutes := 0; - mseconds := 0; - - if Day <> '' then - mday := StrToIntDef(day, 1); - if Month <> '' then - mmonth := StrToIntDef(Month, 1); - if length(Monthnames) = (12 * 3) then - for n := 1 to 12 do - CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3); - if ThreeMonth <> '' then - mmonth := GetMonthNumber(ThreeMonth); - if Year <> '' then - begin - myear := StrToIntDef(Year, 0); - if (myear <= 99) and (myear > 50) then - myear := myear + 1900; - if myear <= 50 then - myear := myear + 2000; - end; - if YearTime <> '' then - begin - if pos(':', YearTime) > 0 then - begin - YearTime := TrimSP(YearTime); - mhours := StrToIntDef(Separateleft(YearTime, ':'), 0); - mminutes := StrToIntDef(SeparateRight(YearTime, ':'), 0); - if (Encodedate(myear, mmonth, mday) - + EncodeTime(mHours, mminutes, 0, 0)) > now then - Dec(mYear); - end - else - myear := StrToIntDef(YearTime, 0); - end; - if Minutes <> '' then - mminutes := StrToIntDef(Minutes, 0); - if Seconds <> '' then - mseconds := StrToIntDef(Seconds, 0); - if Hours <> '' then - begin - mHours := StrToIntDef(Hours, 0); - if HoursModif <> '' then - if Uppercase(HoursModif[1]) = 'P' then - if mHours <> 12 then - mHours := MHours + 12; - end; - Value.FileTime := Encodedate(myear, mmonth, mday) - + EncodeTime(mHours, mminutes, mseconds, 0); - if Permissions <> '' then - begin - Value.Permission := Permissions; - Value.Readable := Uppercase(permissions)[2] = 'R'; - if Uppercase(permissions)[1] = 'D' then - begin - Value.Directory := True; - Value.Readable := false; - end - else - if Uppercase(permissions)[1] = 'L' then - Value.Directory := True; - end; -end; - -function TFTPList.ParseEPLF(Value: string): Boolean; -var - s, os: string; - flr: TFTPListRec; -begin - Result := False; - if Value <> '' then - if Value[1] = '+' then - begin - os := Value; - Delete(Value, 1, 1); - flr := TFTPListRec.create; - flr.FileName := SeparateRight(Value, #9); - s := Fetch(Value, ','); - while s <> '' do - begin - if s[1] = #9 then - Break; - case s[1] of - '/': - flr.Directory := true; - 'r': - flr.Readable := true; - 's': - flr.FileSize := StrToIntDef(Copy(s, 2, Length(s) - 1), 0); - 'm': - flr.FileTime := (StrToIntDef(Copy(s, 2, Length(s) - 1), 0) / 86400) - + 25569; - end; - s := Fetch(Value, ','); - end; - if flr.FileName <> '' then - if (flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..'))) - or (flr.FileName = '') then - flr.free - else - begin - flr.OriginalLine := os; - flr.Mask := 'EPLF'; - Flist.Add(flr); - Result := True; - end; - end; -end; - -procedure TFTPList.ParseLines; -var - flr: TFTPListRec; - n, m: Integer; - S: string; - x: integer; - b: Boolean; -begin - n := 0; - while n < Lines.Count do - begin - if n = Lines.Count - 1 then - s := '' - else - s := Lines[n + 1]; - b := False; - x := 0; - if ParseEPLF(Lines[n]) then - begin - b := True; - x := 1; - end - else - for m := 0 to Masks.Count - 1 do - begin - x := ParseByMask(Lines[n], s, Masks[m]); - if x > 0 then - if CheckValues then - begin - flr := TFTPListRec.create; - FillRecord(flr); - flr.OriginalLine := Lines[n]; - flr.Mask := Masks[m]; - if flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')) then - flr.free - else - Flist.Add(flr); - b := True; - Break; - end; - end; - if not b then - FUnparsedLines.Add(Lines[n]); - Inc(n); - if x > 1 then - Inc(n, x - 1); - end; -end; - -{==============================================================================} - -function FtpGetFile(const IP, Port, FileName, LocalFile, - User, Pass: string): Boolean; -begin - Result := False; - with TFTPSend.Create do - try - if User <> '' then - begin - Username := User; - Password := Pass; - end; - TargetHost := IP; - TargetPort := Port; - if not Login then - Exit; - DirectFileName := LocalFile; - DirectFile:=True; - Result := RetrieveFile(FileName, False); - Logout; - finally - Free; - end; -end; - -function FtpPutFile(const IP, Port, FileName, LocalFile, - User, Pass: string): Boolean; -begin - Result := False; - with TFTPSend.Create do - try - if User <> '' then - begin - Username := User; - Password := Pass; - end; - TargetHost := IP; - TargetPort := Port; - if not Login then - Exit; - DirectFileName := LocalFile; - DirectFile:=True; - Result := StoreFile(FileName, False); - Logout; - finally - Free; - end; -end; - -function FtpInterServerTransfer( - const FromIP, FromPort, FromFile, FromUser, FromPass: string; - const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean; -var - FromFTP, ToFTP: TFTPSend; - s: string; - x: integer; -begin - Result := False; - FromFTP := TFTPSend.Create; - toFTP := TFTPSend.Create; - try - if FromUser <> '' then - begin - FromFTP.Username := FromUser; - FromFTP.Password := FromPass; - end; - if ToUser <> '' then - begin - ToFTP.Username := ToUser; - ToFTP.Password := ToPass; - end; - FromFTP.TargetHost := FromIP; - FromFTP.TargetPort := FromPort; - ToFTP.TargetHost := ToIP; - ToFTP.TargetPort := ToPort; - if not FromFTP.Login then - Exit; - if not ToFTP.Login then - Exit; - if (FromFTP.FTPCommand('PASV') div 100) <> 2 then - Exit; - FromFTP.ParseRemote(FromFTP.ResultString); - s := ReplaceString(FromFTP.DataIP, '.', ','); - s := 'PORT ' + s + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) div 256) - + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) mod 256); - if (ToFTP.FTPCommand(s) div 100) <> 2 then - Exit; - x := ToFTP.FTPCommand('RETR ' + FromFile); - if (x div 100) <> 1 then - Exit; - x := FromFTP.FTPCommand('STOR ' + ToFile); - if (x div 100) <> 1 then - Exit; - FromFTP.Timeout := 21600000; - x := FromFTP.ReadResult; - if (x div 100) <> 2 then - Exit; - ToFTP.Timeout := 21600000; - x := ToFTP.ReadResult; - if (x div 100) <> 2 then - Exit; - Result := True; - finally - ToFTP.Free; - FromFTP.Free; - end; -end; - -end. diff --git a/addons/synapse/ftptsend.pas b/addons/synapse/ftptsend.pas deleted file mode 100644 index 6ab4173..0000000 --- a/addons/synapse/ftptsend.pas +++ /dev/null @@ -1,403 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.001 | -|==============================================================================| -| Content: Trivial FTP (TFTP) client and server | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2003-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{: @abstract(TFTP client and server protocol) - -Used RFC: RFC-1350 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit ftptsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil; - -const - cTFTPProtocol = '69'; - - cTFTP_RRQ = word(1); - cTFTP_WRQ = word(2); - cTFTP_DTA = word(3); - cTFTP_ACK = word(4); - cTFTP_ERR = word(5); - -type - {:@abstract(Implementation of TFTP client and server) - Note: Are you missing properties for specify server address and port? Look to - parent @link(TSynaClient) too!} - TTFTPSend = class(TSynaClient) - private - FSock: TUDPBlockSocket; - FErrorCode: integer; - FErrorString: string; - FData: TMemoryStream; - FRequestIP: string; - FRequestPort: string; - function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean; - function RecvPacket(Serial: word; var Value: string): Boolean; - public - constructor Create; - destructor Destroy; override; - - {:Upload @link(data) as file to TFTP server.} - function SendFile(const Filename: string): Boolean; - - {:Download file from TFTP server to @link(data).} - function RecvFile(const Filename: string): Boolean; - - {:Acts as TFTP server and wait for client request. When some request - incoming within Timeout, result is @true and parametres is filled with - information from request. You must handle this request, validate it, and - call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply - to TFTP Client.} - function WaitForRequest(var Req: word; var filename: string): Boolean; - - {:send error to TFTP client, when you acts as TFTP server.} - procedure ReplyError(Error: word; Description: string); - - {:Accept uploaded file from TFTP client to @link(data), when you acts as - TFTP server.} - function ReplyRecv: Boolean; - - {:Accept download request file from TFTP client and send content of - @link(data), when you acts as TFTP server.} - function ReplySend: Boolean; - published - {:Code of TFTP error.} - property ErrorCode: integer read FErrorCode; - - {:Human readable decription of TFTP error. (if is sended by remote side)} - property ErrorString: string read FErrorString; - - {:MemoryStream with datas for sending or receiving} - property Data: TMemoryStream read FData; - - {:Address of TFTP remote side.} - property RequestIP: string read FRequestIP write FRequestIP; - - {:Port of TFTP remote side.} - property RequestPort: string read FRequestPort write FRequestPort; - end; - -implementation - -constructor TTFTPSend.Create; -begin - inherited Create; - FSock := TUDPBlockSocket.Create; - FSock.Owner := self; - FTargetPort := cTFTPProtocol; - FData := TMemoryStream.Create; - FErrorCode := 0; - FErrorString := ''; -end; - -destructor TTFTPSend.Destroy; -begin - FSock.Free; - FData.Free; - inherited Destroy; -end; - -function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean; -var - s, sh: string; -begin - FErrorCode := 0; - FErrorString := ''; - Result := false; - if Cmd <> 2 then - s := CodeInt(Cmd) + CodeInt(Serial) + Value - else - s := CodeInt(Cmd) + Value; - FSock.SendString(s); - s := FSock.RecvPacket(FTimeout); - if FSock.LastError = 0 then - if length(s) >= 4 then - begin - sh := CodeInt(4) + CodeInt(Serial); - if Pos(sh, s) = 1 then - Result := True - else - if s[1] = #5 then - begin - FErrorCode := DecodeInt(s, 3); - Delete(s, 1, 4); - FErrorString := SeparateLeft(s, #0); - end; - end; -end; - -function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean; -var - s: string; - ser: word; -begin - FErrorCode := 0; - FErrorString := ''; - Result := False; - Value := ''; - s := FSock.RecvPacket(FTimeout); - if FSock.LastError = 0 then - if length(s) >= 4 then - if DecodeInt(s, 1) = 3 then - begin - ser := DecodeInt(s, 3); - if ser = Serial then - begin - Delete(s, 1, 4); - Value := s; - S := CodeInt(4) + CodeInt(ser); - FSock.SendString(s); - Result := FSock.LastError = 0; - end - else - begin - S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0; - FSock.SendString(s); - end; - end; - if DecodeInt(s, 1) = 5 then - begin - FErrorCode := DecodeInt(s, 3); - Delete(s, 1, 4); - FErrorString := SeparateLeft(s, #0); - end; -end; - -function TTFTPSend.SendFile(const Filename: string): Boolean; -var - s: string; - ser: word; - n, n1, n2: integer; -begin - Result := False; - FErrorCode := 0; - FErrorString := ''; - FSock.CloseSocket; - FSock.Connect(FTargetHost, FTargetPort); - try - if FSock.LastError = 0 then - begin - s := Filename + #0 + 'octet' + #0; - if not Sendpacket(2, 0, s) then - Exit; - ser := 1; - FData.Position := 0; - n1 := FData.Size div 512; - n2 := FData.Size mod 512; - for n := 1 to n1 do - begin - s := ReadStrFromStream(FData, 512); -// SetLength(s, 512); -// FData.Read(pointer(s)^, 512); - if not Sendpacket(3, ser, s) then - Exit; - inc(ser); - end; - s := ReadStrFromStream(FData, n2); -// SetLength(s, n2); -// FData.Read(pointer(s)^, n2); - if not Sendpacket(3, ser, s) then - Exit; - Result := True; - end; - finally - FSock.CloseSocket; - end; -end; - -function TTFTPSend.RecvFile(const Filename: string): Boolean; -var - s: string; - ser: word; -begin - Result := False; - FErrorCode := 0; - FErrorString := ''; - FSock.CloseSocket; - FSock.Connect(FTargetHost, FTargetPort); - try - if FSock.LastError = 0 then - begin - s := CodeInt(1) + Filename + #0 + 'octet' + #0; - FSock.SendString(s); - if FSock.LastError <> 0 then - Exit; - FData.Clear; - ser := 1; - repeat - if not RecvPacket(ser, s) then - Exit; - inc(ser); - WriteStrToStream(FData, s); -// FData.Write(pointer(s)^, length(s)); - until length(s) <> 512; - FData.Position := 0; - Result := true; - end; - finally - FSock.CloseSocket; - end; -end; - -function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean; -var - s: string; -begin - Result := False; - FErrorCode := 0; - FErrorString := ''; - FSock.CloseSocket; - FSock.Bind('0.0.0.0', FTargetPort); - if FSock.LastError = 0 then - begin - s := FSock.RecvPacket(FTimeout); - if FSock.LastError = 0 then - if Length(s) >= 4 then - begin - FRequestIP := FSock.GetRemoteSinIP; - FRequestPort := IntToStr(FSock.GetRemoteSinPort); - Req := DecodeInt(s, 1); - delete(s, 1, 2); - filename := Trim(SeparateLeft(s, #0)); - s := SeparateRight(s, #0); - s := SeparateLeft(s, #0); - Result := lowercase(trim(s)) = 'octet'; - end; - end; -end; - -procedure TTFTPSend.ReplyError(Error: word; Description: string); -var - s: string; -begin - FSock.CloseSocket; - FSock.Connect(FRequestIP, FRequestPort); - s := CodeInt(5) + CodeInt(Error) + Description + #0; - FSock.SendString(s); - FSock.CloseSocket; -end; - -function TTFTPSend.ReplyRecv: Boolean; -var - s: string; - ser: integer; -begin - Result := False; - FErrorCode := 0; - FErrorString := ''; - FSock.CloseSocket; - FSock.Connect(FRequestIP, FRequestPort); - try - s := CodeInt(4) + CodeInt(0); - FSock.SendString(s); - FData.Clear; - ser := 1; - repeat - if not RecvPacket(ser, s) then - Exit; - inc(ser); - WriteStrToStream(FData, s); -// FData.Write(pointer(s)^, length(s)); - until length(s) <> 512; - FData.Position := 0; - Result := true; - finally - FSock.CloseSocket; - end; -end; - -function TTFTPSend.ReplySend: Boolean; -var - s: string; - ser: word; - n, n1, n2: integer; -begin - Result := False; - FErrorCode := 0; - FErrorString := ''; - FSock.CloseSocket; - FSock.Connect(FRequestIP, FRequestPort); - try - ser := 1; - FData.Position := 0; - n1 := FData.Size div 512; - n2 := FData.Size mod 512; - for n := 1 to n1 do - begin - s := ReadStrFromStream(FData, 512); -// SetLength(s, 512); -// FData.Read(pointer(s)^, 512); - if not Sendpacket(3, ser, s) then - Exit; - inc(ser); - end; - s := ReadStrFromStream(FData, n2); -// SetLength(s, n2); -// FData.Read(pointer(s)^, n2); - if not Sendpacket(3, ser, s) then - Exit; - Result := True; - finally - FSock.CloseSocket; - end; -end; - -{==============================================================================} - -end. diff --git a/addons/synapse/httpsend.pas b/addons/synapse/httpsend.pas deleted file mode 100644 index ce86023..0000000 --- a/addons/synapse/httpsend.pas +++ /dev/null @@ -1,840 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 003.012.004 | -|==============================================================================| -| Content: HTTP client | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(HTTP protocol client) - -Used RFC: RFC-1867, RFC-1947, RFC-2388, RFC-2616 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit httpsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil, synaip, synacode, synsock; - -const - cHttpProtocol = '80'; - -type - {:These encoding types are used internally by the THTTPSend object to identify - the transfer data types.} - TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED); - - {:abstract(Implementation of HTTP protocol.)} - THTTPSend = class(TSynaClient) - protected - FSock: TTCPBlockSocket; - FTransferEncoding: TTransferEncoding; - FAliveHost: string; - FAlivePort: string; - FHeaders: TStringList; - FDocument: TMemoryStream; - FMimeType: string; - FProtocol: string; - FKeepAlive: Boolean; - FKeepAliveTimeout: integer; - FStatus100: Boolean; - FProxyHost: string; - FProxyPort: string; - FProxyUser: string; - FProxyPass: string; - FResultCode: Integer; - FResultString: string; - FUserAgent: string; - FCookies: TStringList; - FDownloadSize: integer; - FUploadSize: integer; - FRangeStart: integer; - FRangeEnd: integer; - FAddPortNumberToHost: Boolean; - function ReadUnknown: Boolean; - function ReadIdentity(Size: Integer): Boolean; - function ReadChunked: Boolean; - procedure ParseCookies; - function PrepareHeaders: AnsiString; - function InternalDoConnect(needssl: Boolean): Boolean; - function InternalConnect(needssl: Boolean): Boolean; - public - constructor Create; - destructor Destroy; override; - - {:Reset headers and document and Mimetype.} - procedure Clear; - - {:Decode ResultCode and ResultString from Value.} - procedure DecodeStatus(const Value: string); - - {:Connects to host define in URL and access to resource defined in URL by - method. If Document is not empty, send it to server as part of HTTP request. - Server response is in Document and headers. Connection may be authorised - by username and password in URL. If you define proxy properties, connection - is made by this proxy. If all OK, result is @true, else result is @false. - - If you use in URL 'https:' instead only 'http:', then your request is made - by SSL/TLS connection (if you not specify port, then port 443 is used - instead standard port 80). If you use SSL/TLS request and you have defined - HTTP proxy, then HTTP-tunnel mode is automaticly used .} - function HTTPMethod(const Method, URL: string): Boolean; - - {:You can call this method from OnStatus event for break current data - transfer. (or from another thread.)} - procedure Abort; - published - {:Before HTTP operation you may define any non-standard headers for HTTP - request, except of: 'Expect: 100-continue', 'Content-Length', 'Content-Type', - 'Connection', 'Authorization', 'Proxy-Authorization' and 'Host' headers. - After HTTP operation contains full headers of returned document.} - property Headers: TStringList read FHeaders; - - {:This is stringlist with name-value stringlist pairs. Each this pair is one - cookie. After HTTP request is returned cookies parsed to this stringlist. - You can leave this cookies untouched for next HTTP request. You can also - save this stringlist for later use.} - property Cookies: TStringList read FCookies; - - {:Stream with document to send (before request, or with document received - from HTTP server (after request).} - property Document: TMemoryStream read FDocument; - - {:If you need download only part of requested document, here specify - possition of subpart begin. If here 0, then is requested full document.} - property RangeStart: integer read FRangeStart Write FRangeStart; - - {:If you need download only part of requested document, here specify - possition of subpart end. If here 0, then is requested document from - rangeStart to end of document. (for broken download restoration, - for example.)} - property RangeEnd: integer read FRangeEnd Write FRangeEnd; - - {:Mime type of sending data. Default is: 'text/html'.} - property MimeType: string read FMimeType Write FMimeType; - - {:Define protocol version. Possible values are: '1.1', '1.0' (default) - and '0.9'.} - property Protocol: string read FProtocol Write FProtocol; - - {:If @true (default value), keepalives in HTTP protocol 1.1 is enabled.} - property KeepAlive: Boolean read FKeepAlive Write FKeepAlive; - - {:Define timeout for keepalives in seconds!} - property KeepAliveTimeout: integer read FKeepAliveTimeout Write FKeepAliveTimeout; - - {:if @true, then server is requested for 100status capability when uploading - data. Default is @false (off).} - property Status100: Boolean read FStatus100 Write FStatus100; - - {:Address of proxy server (IP address or domain name) where you want to - connect in @link(HTTPMethod) method.} - property ProxyHost: string read FProxyHost Write FProxyHost; - - {:Port number for proxy connection. Default value is 8080.} - property ProxyPort: string read FProxyPort Write FProxyPort; - - {:Username for connect to proxy server where you want to connect in - HTTPMethod method.} - property ProxyUser: string read FProxyUser Write FProxyUser; - - {:Password for connect to proxy server where you want to connect in - HTTPMethod method.} - property ProxyPass: string read FProxyPass Write FProxyPass; - - {:Here you can specify custom User-Agent indentification. By default is - used: 'Mozilla/4.0 (compatible; Synapse)'} - property UserAgent: string read FUserAgent Write FUserAgent; - - {:After successful @link(HTTPMethod) method contains result code of - operation.} - property ResultCode: Integer read FResultCode; - - {:After successful @link(HTTPMethod) method contains string after result code.} - property ResultString: string read FResultString; - - {:if this value is not 0, then data download pending. In this case you have - here total sice of downloaded data. It is good for draw download - progressbar from OnStatus event.} - property DownloadSize: integer read FDownloadSize; - - {:if this value is not 0, then data upload pending. In this case you have - here total sice of uploaded data. It is good for draw upload progressbar - from OnStatus event.} - property UploadSize: integer read FUploadSize; - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TTCPBlockSocket read FSock; - - {:To have possibility to switch off port number in 'Host:' HTTP header, by - default @TRUE. Some buggy servers not like port informations in this header.} - property AddPortNumberToHost: Boolean read FAddPortNumberToHost write FAddPortNumberToHost; - end; - -{:A very usefull function, and example of use can be found in the THTTPSend - object. It implements the GET method of the HTTP protocol. This function sends - the GET method for URL document to an HTTP server. Returned document is in the - "Response" stringlist (without any headers). Returns boolean TRUE if all went - well.} -function HttpGetText(const URL: string; const Response: TStrings): Boolean; - -{:A very usefull function, and example of use can be found in the THTTPSend - object. It implements the GET method of the HTTP protocol. This function sends - the GET method for URL document to an HTTP server. Returned document is in the - "Response" stream. Returns boolean TRUE if all went well.} -function HttpGetBinary(const URL: string; const Response: TStream): Boolean; - -{:A very useful function, and example of use can be found in the THTTPSend - object. It implements the POST method of the HTTP protocol. This function sends - the SEND method for a URL document to an HTTP server. The document to be sent - is located in "Data" stream. The returned document is in the "Data" stream. - Returns boolean TRUE if all went well.} -function HttpPostBinary(const URL: string; const Data: TStream): Boolean; - -{:A very useful function, and example of use can be found in the THTTPSend - object. It implements the POST method of the HTTP protocol. This function is - good for POSTing form data. It sends the POST method for a URL document to - an HTTP server. You must prepare the form data in the same manner as you would - the URL data, and pass this prepared data to "URLdata". The following is - a sample of how the data would appear: 'name=Lukas&field1=some%20data'. - The information in the field must be encoded by EncodeURLElement function. - The returned document is in the "Data" stream. Returns boolean TRUE if all - went well.} -function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean; - -{:A very useful function, and example of use can be found in the THTTPSend - object. It implements the POST method of the HTTP protocol. This function sends - the POST method for a URL document to an HTTP server. This function simulate - posting of file by HTML form used method 'multipart/form-data'. Posting file - is in DATA stream. Its name is Filename string. Fieldname is for name of - formular field with file. (simulate HTML INPUT FILE) The returned document is - in the ResultData Stringlist. Returns boolean TRUE if all went well.} -function HttpPostFile(const URL, FieldName, FileName: string; - const Data: TStream; const ResultData: TStrings): Boolean; - -implementation - -constructor THTTPSend.Create; -begin - inherited Create; - FHeaders := TStringList.Create; - FCookies := TStringList.Create; - FDocument := TMemoryStream.Create; - FSock := TTCPBlockSocket.Create; -// FSock.Owner := self; - FSock.ConvertLineEnd := True; - FSock.SizeRecvBuffer := c64k; - FSock.SizeSendBuffer := c64k; - FTimeout := 90000; - FTargetPort := cHttpProtocol; - FProxyHost := ''; - FProxyPort := '8080'; - FProxyUser := ''; - FProxyPass := ''; - FAliveHost := ''; - FAlivePort := ''; - FProtocol := '1.0'; - FKeepAlive := True; - FStatus100 := False; - FUserAgent := 'Mozilla/4.0 (compatible; Synapse)'; - FDownloadSize := 0; - FUploadSize := 0; - FAddPortNumberToHost := true; - FKeepAliveTimeout := 300; - Clear; -end; - -destructor THTTPSend.Destroy; -begin - FSock.Free; - FDocument.Free; - FCookies.Free; - FHeaders.Free; - inherited Destroy; -end; - -procedure THTTPSend.Clear; -begin - FRangeStart := 0; - FRangeEnd := 0; - FDocument.Clear; - FHeaders.Clear; - FMimeType := 'text/html'; -end; - -procedure THTTPSend.DecodeStatus(const Value: string); -var - s, su: string; -begin - s := Trim(SeparateRight(Value, ' ')); - su := Trim(SeparateLeft(s, ' ')); - FResultCode := StrToIntDef(su, 0); - FResultString := Trim(SeparateRight(s, ' ')); - if FResultString = s then - FResultString := ''; -end; - -function THTTPSend.PrepareHeaders: AnsiString; -begin - if FProtocol = '0.9' then - Result := FHeaders[0] + CRLF - else -{$IFNDEF MSWINDOWS} - Result := {$IFDEF UNICODE}AnsiString{$ENDIF}(AdjustLineBreaks(FHeaders.Text, tlbsCRLF)); -{$ELSE} - Result := FHeaders.Text; -{$ENDIF} -end; - -function THTTPSend.InternalDoConnect(needssl: Boolean): Boolean; -begin - Result := False; - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError <> 0 then - Exit; - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError <> 0 then - Exit; - if needssl then - begin - FSock.SSLDoConnect; - if FSock.LastError <> 0 then - Exit; - end; - FAliveHost := FTargetHost; - FAlivePort := FTargetPort; - Result := True; -end; - -function THTTPSend.InternalConnect(needssl: Boolean): Boolean; -begin - if FSock.Socket = INVALID_SOCKET then - Result := InternalDoConnect(needssl) - else - if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort) - or FSock.CanRead(0) then - Result := InternalDoConnect(needssl) - else - Result := True; -end; - -function THTTPSend.HTTPMethod(const Method, URL: string): Boolean; -var - Sending, Receiving: Boolean; - status100: Boolean; - status100error: string; - ToClose: Boolean; - Size: Integer; - Prot, User, Pass, Host, Port, Path, Para, URI: string; - s, su: AnsiString; - HttpTunnel: Boolean; - n: integer; - pp: string; - UsingProxy: boolean; - l: TStringList; - x: integer; -begin - {initial values} - Result := False; - FResultCode := 500; - FResultString := ''; - FDownloadSize := 0; - FUploadSize := 0; - - URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para); - if User = '' then - begin - User := FUsername; - Pass := FPassword; - end; - if UpperCase(Prot) = 'HTTPS' then - begin - HttpTunnel := FProxyHost <> ''; - FSock.HTTPTunnelIP := FProxyHost; - FSock.HTTPTunnelPort := FProxyPort; - FSock.HTTPTunnelUser := FProxyUser; - FSock.HTTPTunnelPass := FProxyPass; - end - else - begin - HttpTunnel := False; - FSock.HTTPTunnelIP := ''; - FSock.HTTPTunnelPort := ''; - FSock.HTTPTunnelUser := ''; - FSock.HTTPTunnelPass := ''; - end; - UsingProxy := (FProxyHost <> '') and not(HttpTunnel); - Sending := FDocument.Size > 0; - {Headers for Sending data} - status100 := FStatus100 and Sending and (FProtocol = '1.1'); - if status100 then - FHeaders.Insert(0, 'Expect: 100-continue'); - if Sending then - begin - FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size)); - if FMimeType <> '' then - FHeaders.Insert(0, 'Content-Type: ' + FMimeType); - end; - { setting User-agent } - if FUserAgent <> '' then - FHeaders.Insert(0, 'User-Agent: ' + FUserAgent); - { setting Ranges } - if (FRangeStart > 0) or (FRangeEnd > 0) then - begin - if FRangeEnd >= FRangeStart then - FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd)) - else - FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-'); - end; - { setting Cookies } - s := ''; - for n := 0 to FCookies.Count - 1 do - begin - if s <> '' then - s := s + '; '; - s := s + FCookies[n]; - end; - if s <> '' then - FHeaders.Insert(0, 'Cookie: ' + s); - { setting KeepAlives } - pp := ''; - if UsingProxy then - pp := 'Proxy-'; - if FKeepAlive then - begin - FHeaders.Insert(0, pp + 'Connection: keep-alive'); - FHeaders.Insert(0, 'Keep-Alive: ' + IntToStr(FKeepAliveTimeout)); - end - else - FHeaders.Insert(0, pp + 'Connection: close'); - { set target servers/proxy, authorizations, etc... } - if User <> '' then - FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(User + ':' + Pass)); - if UsingProxy and (FProxyUser <> '') then - FHeaders.Insert(0, 'Proxy-Authorization: Basic ' + - EncodeBase64(FProxyUser + ':' + FProxyPass)); - if isIP6(Host) then - s := '[' + Host + ']' - else - s := Host; - if FAddPortNumberToHost and (Port <> '80') then - FHeaders.Insert(0, 'Host: ' + s + ':' + Port) - else - FHeaders.Insert(0, 'Host: ' + s); - if UsingProxy then - URI := Prot + '://' + s + ':' + Port + URI; - if URI = '/*' then - URI := '*'; - if FProtocol = '0.9' then - FHeaders.Insert(0, UpperCase(Method) + ' ' + URI) - else - FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol); - if UsingProxy then - begin - FTargetHost := FProxyHost; - FTargetPort := FProxyPort; - end - else - begin - FTargetHost := Host; - FTargetPort := Port; - end; - if FHeaders[FHeaders.Count - 1] <> '' then - FHeaders.Add(''); - - { connect } - if not InternalConnect(UpperCase(Prot) = 'HTTPS') then - begin - FAliveHost := ''; - FAlivePort := ''; - Exit; - end; - - { reading Status } - FDocument.Position := 0; - Status100Error := ''; - if status100 then - begin - { send Headers } - FSock.SendString(PrepareHeaders); - if FSock.LastError <> 0 then - Exit; - repeat - s := FSock.RecvString(FTimeout); - if s <> '' then - Break; - until FSock.LastError <> 0; - DecodeStatus(s); - Status100Error := s; - repeat - s := FSock.recvstring(FTimeout); - if s = '' then - Break; - until FSock.LastError <> 0; - if (FResultCode >= 100) and (FResultCode < 200) then - begin - { we can upload content } - Status100Error := ''; - FUploadSize := FDocument.Size; - FSock.SendBuffer(FDocument.Memory, FDocument.Size); - end; - end - else - { upload content } - if sending then - begin - if FDocument.Size >= c64k then - begin - FSock.SendString(PrepareHeaders); - FUploadSize := FDocument.Size; - FSock.SendBuffer(FDocument.Memory, FDocument.Size); - end - else - begin - s := PrepareHeaders + ReadStrFromStream(FDocument, FDocument.Size); - FUploadSize := Length(s); - FSock.SendString(s); - end; - end - else - begin - { we not need to upload document, send headers only } - FSock.SendString(PrepareHeaders); - end; - - if FSock.LastError <> 0 then - Exit; - - Clear; - Size := -1; - FTransferEncoding := TE_UNKNOWN; - - { read status } - if Status100Error = '' then - begin - repeat - repeat - s := FSock.RecvString(FTimeout); - if s <> '' then - Break; - until FSock.LastError <> 0; - if Pos('HTTP/', UpperCase(s)) = 1 then - begin - FHeaders.Add(s); - DecodeStatus(s); - end - else - begin - { old HTTP 0.9 and some buggy servers not send result } - s := s + CRLF; - WriteStrToStream(FDocument, s); - FResultCode := 0; - end; - until (FSock.LastError <> 0) or (FResultCode <> 100); - end - else - FHeaders.Add(Status100Error); - - { if need receive headers, receive and parse it } - ToClose := FProtocol <> '1.1'; - if FHeaders.Count > 0 then - begin - l := TStringList.Create; - try - repeat - s := FSock.RecvString(FTimeout); - l.Add(s); - if s = '' then - Break; - until FSock.LastError <> 0; - x := 0; - while l.Count > x do - begin - s := NormalizeHeader(l, x); - FHeaders.Add(s); - su := UpperCase(s); - if Pos('CONTENT-LENGTH:', su) = 1 then - begin - Size := StrToIntDef(Trim(SeparateRight(s, ' ')), -1); - if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then - FTransferEncoding := TE_IDENTITY; - end; - if Pos('CONTENT-TYPE:', su) = 1 then - FMimeType := Trim(SeparateRight(s, ' ')); - if Pos('TRANSFER-ENCODING:', su) = 1 then - begin - s := Trim(SeparateRight(su, ' ')); - if Pos('CHUNKED', s) > 0 then - FTransferEncoding := TE_CHUNKED; - end; - if UsingProxy then - begin - if Pos('PROXY-CONNECTION:', su) = 1 then - if Pos('CLOSE', su) > 0 then - ToClose := True; - end - else - begin - if Pos('CONNECTION:', su) = 1 then - if Pos('CLOSE', su) > 0 then - ToClose := True; - end; - end; - finally - l.free; - end; - end; - - Result := FSock.LastError = 0; - if not Result then - Exit; - - {if need receive response body, read it} - Receiving := Method <> 'HEAD'; - Receiving := Receiving and (FResultCode <> 204); - Receiving := Receiving and (FResultCode <> 304); - if Receiving then - case FTransferEncoding of - TE_UNKNOWN: - Result := ReadUnknown; - TE_IDENTITY: - Result := ReadIdentity(Size); - TE_CHUNKED: - Result := ReadChunked; - end; - - FDocument.Seek(0, soFromBeginning); - if ToClose then - begin - FSock.CloseSocket; - FAliveHost := ''; - FAlivePort := ''; - end; - ParseCookies; -end; - -function THTTPSend.ReadUnknown: Boolean; -var - s: string; -begin - Result := false; - repeat - s := FSock.RecvPacket(FTimeout); - if FSock.LastError = 0 then - WriteStrToStream(FDocument, s); - until FSock.LastError <> 0; - if FSock.LastError = WSAECONNRESET then - begin - Result := true; - FSock.ResetLastError; - end; -end; - -function THTTPSend.ReadIdentity(Size: Integer): Boolean; -begin - if Size > 0 then - begin - FDownloadSize := Size; - FSock.RecvStreamSize(FDocument, FTimeout, Size); - FDocument.Position := FDocument.Size; - Result := FSock.LastError = 0; - end - else - Result := true; -end; - -function THTTPSend.ReadChunked: Boolean; -var - s: string; - Size: Integer; -begin - repeat - repeat - s := FSock.RecvString(FTimeout); - until (s <> '') or (FSock.LastError <> 0); - if FSock.LastError <> 0 then - Break; - s := Trim(SeparateLeft(s, ' ')); - s := Trim(SeparateLeft(s, ';')); - Size := StrToIntDef('$' + s, 0); - if Size = 0 then - Break; - if not ReadIdentity(Size) then - break; - until False; - Result := FSock.LastError = 0; -end; - -procedure THTTPSend.ParseCookies; -var - n: integer; - s: string; - sn, sv: string; -begin - for n := 0 to FHeaders.Count - 1 do - if Pos('set-cookie:', lowercase(FHeaders[n])) = 1 then - begin - s := SeparateRight(FHeaders[n], ':'); - s := trim(SeparateLeft(s, ';')); - sn := trim(SeparateLeft(s, '=')); - sv := trim(SeparateRight(s, '=')); - FCookies.Values[sn] := sv; - end; -end; - -procedure THTTPSend.Abort; -begin - FSock.StopFlag := True; -end; - -{==============================================================================} - -function HttpGetText(const URL: string; const Response: TStrings): Boolean; -var - HTTP: THTTPSend; -begin - HTTP := THTTPSend.Create; - try - Result := HTTP.HTTPMethod('GET', URL); - if Result then - Response.LoadFromStream(HTTP.Document); - finally - HTTP.Free; - end; -end; - -function HttpGetBinary(const URL: string; const Response: TStream): Boolean; -var - HTTP: THTTPSend; -begin - HTTP := THTTPSend.Create; - try - Result := HTTP.HTTPMethod('GET', URL); - if Result then - begin - Response.Seek(0, soFromBeginning); - Response.CopyFrom(HTTP.Document, 0); - end; - finally - HTTP.Free; - end; -end; - -function HttpPostBinary(const URL: string; const Data: TStream): Boolean; -var - HTTP: THTTPSend; -begin - HTTP := THTTPSend.Create; - try - HTTP.Document.CopyFrom(Data, 0); - HTTP.MimeType := 'Application/octet-stream'; - Result := HTTP.HTTPMethod('POST', URL); - Data.Size := 0; - if Result then - begin - Data.Seek(0, soFromBeginning); - Data.CopyFrom(HTTP.Document, 0); - end; - finally - HTTP.Free; - end; -end; - -function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean; -var - HTTP: THTTPSend; -begin - HTTP := THTTPSend.Create; - try - WriteStrToStream(HTTP.Document, URLData); - HTTP.MimeType := 'application/x-www-form-urlencoded'; - Result := HTTP.HTTPMethod('POST', URL); - if Result then - Data.CopyFrom(HTTP.Document, 0); - finally - HTTP.Free; - end; -end; - -function HttpPostFile(const URL, FieldName, FileName: string; - const Data: TStream; const ResultData: TStrings): Boolean; -var - HTTP: THTTPSend; - Bound, s: string; -begin - Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary'; - HTTP := THTTPSend.Create; - try - s := '--' + Bound + CRLF; - s := s + 'content-disposition: form-data; name="' + FieldName + '";'; - s := s + ' filename="' + FileName +'"' + CRLF; - s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF; - WriteStrToStream(HTTP.Document, s); - HTTP.Document.CopyFrom(Data, 0); - s := CRLF + '--' + Bound + '--' + CRLF; - WriteStrToStream(HTTP.Document, s); - HTTP.MimeType := 'multipart/form-data; boundary=' + Bound; - Result := HTTP.HTTPMethod('POST', URL); - if Result then - ResultData.LoadFromStream(HTTP.Document); - finally - HTTP.Free; - end; -end; - -end. diff --git a/addons/synapse/imapsend.pas b/addons/synapse/imapsend.pas deleted file mode 100644 index 55f5339..0000000 --- a/addons/synapse/imapsend.pas +++ /dev/null @@ -1,869 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.005.002 | -|==============================================================================| -| Content: IMAP4rev1 client | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2001-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(IMAP4 rev1 protocol client) - -Used RFC: RFC-2060, RFC-2595 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit imapsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil; - -const - cIMAPProtocol = '143'; - -type - {:@abstract(Implementation of IMAP4 protocol.) - Note: Are you missing properties for setting Username and Password? Look to - parent @link(TSynaClient) object! - - Are you missing properties for specify server address and port? Look to - parent @link(TSynaClient) too!} - TIMAPSend = class(TSynaClient) - protected - FSock: TTCPBlockSocket; - FTagCommand: integer; - FResultString: string; - FFullResult: TStringList; - FIMAPcap: TStringList; - FAuthDone: Boolean; - FSelectedFolder: string; - FSelectedCount: integer; - FSelectedRecent: integer; - FSelectedUIDvalidity: integer; - FUID: Boolean; - FAutoTLS: Boolean; - FFullSSL: Boolean; - function ReadResult: string; - function AuthLogin: Boolean; - function Connect: Boolean; - procedure ParseMess(Value:TStrings); - procedure ParseFolderList(Value:TStrings); - procedure ParseSelect; - procedure ParseSearch(Value:TStrings); - procedure ProcessLiterals; - public - constructor Create; - destructor Destroy; override; - - {:By this function you can call any IMAP command. Result of this command is - in adequate properties.} - function IMAPcommand(Value: string): string; - - {:By this function you can call any IMAP command what need upload any data. - Result of this command is in adequate properties.} - function IMAPuploadCommand(Value: string; const Data:TStrings): string; - - {:Call CAPABILITY command and fill IMAPcap property by new values.} - function Capability: Boolean; - - {:Connect to IMAP server and do login to this server. This command begin - session.} - function Login: Boolean; - - {:Disconnect from IMAP server and terminate session session. If exists some - deleted and non-purged messages, these messages are not deleted!} - function Logout: Boolean; - - {:Do NOOP. It is for prevent disconnect by timeout.} - function NoOp: Boolean; - - {:Lists folder names. You may specify level of listing. If you specify - FromFolder as empty string, return is all folders in system.} - function List(FromFolder: string; const FolderList: TStrings): Boolean; - - {:Lists folder names what match search criteria. You may specify level of - listing. If you specify FromFolder as empty string, return is all folders - in system.} - function ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean; - - {:Lists subscribed folder names. You may specify level of listing. If you - specify FromFolder as empty string, return is all subscribed folders in - system.} - function ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean; - - {:Lists subscribed folder names what matching search criteria. You may - specify level of listing. If you specify FromFolder as empty string, return - is all subscribed folders in system.} - function ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean; - - {:Create a new folder.} - function CreateFolder(FolderName: string): Boolean; - - {:Delete a folder.} - function DeleteFolder(FolderName: string): Boolean; - - {:Rename folder names.} - function RenameFolder(FolderName, NewFolderName: string): Boolean; - - {:Subscribe folder.} - function SubscribeFolder(FolderName: string): Boolean; - - {:Unsubscribe folder.} - function UnsubscribeFolder(FolderName: string): Boolean; - - {:Select folder.} - function SelectFolder(FolderName: string): Boolean; - - {:Select folder, but only for reading. Any changes are not allowed!} - function SelectROFolder(FolderName: string): Boolean; - - {:Close a folder. (end of Selected state)} - function CloseFolder: Boolean; - - {:Ask for given status of folder. I.e. if you specify as value 'UNSEEN', - result is number of unseen messages in folder. For another status - indentificator check IMAP documentation and documentation of your IMAP - server (each IMAP server can have their own statuses.)} - function StatusFolder(FolderName, Value: string): integer; - - {:Hardly delete all messages marked as 'deleted' in current selected folder.} - function ExpungeFolder: Boolean; - - {:Touch to folder. (use as update status of folder, etc.)} - function CheckFolder: Boolean; - - {:Append given message to specified folder.} - function AppendMess(ToFolder: string; const Mess: TStrings): Boolean; - - {:'Delete' message from current selected folder. It mark message as Deleted. - Real deleting will be done after sucessfull @link(CloseFolder) or - @link(ExpungeFolder)} - function DeleteMess(MessID: integer): boolean; - - {:Get full message from specified message in selected folder.} - function FetchMess(MessID: integer; const Mess: TStrings): Boolean; - - {:Get message headers only from specified message in selected folder.} - function FetchHeader(MessID: integer; const Headers: TStrings): Boolean; - - {:Return message size of specified message from current selected folder.} - function MessageSize(MessID: integer): integer; - - {:Copy message from current selected folder to another folder.} - function CopyMess(MessID: integer; ToFolder: string): Boolean; - - {:Return message numbers from currently selected folder as result - of searching. Search criteria is very complex language (see to IMAP - specification) similar to SQL (but not same syntax!).} - function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean; - - {:Sets flags of message from current selected folder.} - function SetFlagsMess(MessID: integer; Flags: string): Boolean; - - {:Gets flags of message from current selected folder.} - function GetFlagsMess(MessID: integer; var Flags: string): Boolean; - - {:Add flags to message's flags.} - function AddFlagsMess(MessID: integer; Flags: string): Boolean; - - {:Remove flags from message's flags.} - function DelFlagsMess(MessID: integer; Flags: string): Boolean; - - {:Call STARTTLS command for upgrade connection to SSL/TLS mode.} - function StartTLS: Boolean; - - {:return UID of requested message ID.} - function GetUID(MessID: integer; var UID : Integer): Boolean; - - {:Try to find given capabily in capabilty string returned from IMAP server.} - function FindCap(const Value: string): string; - published - {:Status line with result of last operation.} - property ResultString: string read FResultString; - - {:Full result of last IMAP operation.} - property FullResult: TStringList read FFullResult; - - {:List of server capabilites.} - property IMAPcap: TStringList read FIMAPcap; - - {:Authorization is successful done.} - property AuthDone: Boolean read FAuthDone; - - {:Turn on or off usage of UID (unicate identificator) of messages instead - only sequence numbers.} - property UID: Boolean read FUID Write FUID; - - {:Name of currently selected folder.} - property SelectedFolder: string read FSelectedFolder; - - {:Count of messages in currently selected folder.} - property SelectedCount: integer read FSelectedCount; - - {:Count of not-visited messages in currently selected folder.} - property SelectedRecent: integer read FSelectedRecent; - - {:This number with name of folder is unique indentificator of folder. - (If someone delete folder and next create new folder with exactly same name - of folder, this number is must be different!)} - property SelectedUIDvalidity: integer read FSelectedUIDvalidity; - - {:If is set to true, then upgrade to SSL/TLS mode if remote server support it.} - property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; - - {:SSL/TLS mode is used from first contact to server. Servers with full - SSL/TLS mode usualy using non-standard TCP port!} - property FullSSL: Boolean read FFullSSL Write FFullSSL; - - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TTCPBlockSocket read FSock; - end; - -implementation - -constructor TIMAPSend.Create; -begin - inherited Create; - FFullResult := TStringList.Create; - FIMAPcap := TStringList.Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FSock.ConvertLineEnd := True; - FSock.SizeRecvBuffer := 32768; - FSock.SizeSendBuffer := 32768; - FTimeout := 60000; - FTargetPort := cIMAPProtocol; - FTagCommand := 0; - FSelectedFolder := ''; - FSelectedCount := 0; - FSelectedRecent := 0; - FSelectedUIDvalidity := 0; - FUID := False; - FAutoTLS := False; - FFullSSL := False; -end; - -destructor TIMAPSend.Destroy; -begin - FSock.Free; - FIMAPcap.Free; - FFullResult.Free; - inherited Destroy; -end; - - -function TIMAPSend.ReadResult: string; -var - s: string; - x, l: integer; -begin - Result := ''; - FFullResult.Clear; - FResultString := ''; - repeat - s := FSock.RecvString(FTimeout); - if Pos('S' + IntToStr(FTagCommand) + ' ', s) = 1 then - begin - FResultString := s; - break; - end - else - FFullResult.Add(s); - if (s <> '') and (s[Length(s)]='}') then - begin - s := Copy(s, 1, Length(s) - 1); - x := RPos('{', s); - s := Copy(s, x + 1, Length(s) - x); - l := StrToIntDef(s, -1); - if l <> -1 then - begin - s := FSock.RecvBufferStr(l, FTimeout); - FFullResult.Add(s); - end; - end; - until FSock.LastError <> 0; - s := Trim(separateright(FResultString, ' ')); - Result:=uppercase(Trim(separateleft(s, ' '))); -end; - -procedure TIMAPSend.ProcessLiterals; -var - l: TStringList; - n, x: integer; - b: integer; - s: string; -begin - l := TStringList.Create; - try - l.Assign(FFullResult); - FFullResult.Clear; - b := 0; - for n := 0 to l.Count - 1 do - begin - s := l[n]; - if b > 0 then - begin - FFullResult[FFullresult.Count - 1] := - FFullResult[FFullresult.Count - 1] + s; - inc(b); - if b > 2 then - b := 0; - end - else - begin - if (s <> '') and (s[Length(s)]='}') then - begin - x := RPos('{', s); - Delete(s, x, Length(s) - x + 1); - b := 1; - end - else - b := 0; - FFullResult.Add(s); - end; - end; - finally - l.Free; - end; -end; - -function TIMAPSend.IMAPcommand(Value: string): string; -begin - Inc(FTagCommand); - FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + CRLF); - Result := ReadResult; -end; - -function TIMAPSend.IMAPuploadCommand(Value: string; const Data:TStrings): string; -var - l: integer; -begin - Inc(FTagCommand); - l := Length(Data.Text); - FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF); - FSock.RecvString(FTimeout); - FSock.SendString(Data.Text + CRLF); - Result := ReadResult; -end; - -procedure TIMAPSend.ParseMess(Value:TStrings); -var - n: integer; -begin - Value.Clear; - for n := 0 to FFullResult.Count - 2 do - if FFullResult[n][Length(FFullResult[n])] = '}' then - begin - Value.Text := FFullResult[n + 1]; - Break; - end; -end; - -procedure TIMAPSend.ParseFolderList(Value:TStrings); -var - n, x: integer; - s: string; -begin - ProcessLiterals; - Value.Clear; - for n := 0 to FFullResult.Count - 1 do - begin - s := FFullResult[n]; - if (s <> '') and (Pos('\NOSELECT', UpperCase(s)) = 0) then - begin - if s[Length(s)] = '"' then - begin - Delete(s, Length(s), 1); - x := RPos('"', s); - end - else - x := RPos(' ', s); - if (x > 0) then - Value.Add(Copy(s, x + 1, Length(s) - x)); - end; - end; -end; - -procedure TIMAPSend.ParseSelect; -var - n: integer; - s, t: string; -begin - ProcessLiterals; - FSelectedCount := 0; - FSelectedRecent := 0; - FSelectedUIDvalidity := 0; - for n := 0 to FFullResult.Count - 1 do - begin - s := uppercase(FFullResult[n]); - if Pos(' EXISTS', s) > 0 then - begin - t := Trim(separateleft(s, ' EXISTS')); - t := Trim(separateright(t, '* ')); - FSelectedCount := StrToIntDef(t, 0); - end; - if Pos(' RECENT', s) > 0 then - begin - t := Trim(separateleft(s, ' RECENT')); - t := Trim(separateright(t, '* ')); - FSelectedRecent := StrToIntDef(t, 0); - end; - if Pos('UIDVALIDITY', s) > 0 then - begin - t := Trim(separateright(s, 'UIDVALIDITY ')); - t := Trim(separateleft(t, ']')); - FSelectedUIDvalidity := StrToIntDef(t, 0); - end; - end; -end; - -procedure TIMAPSend.ParseSearch(Value:TStrings); -var - n: integer; - s: string; -begin - ProcessLiterals; - Value.Clear; - for n := 0 to FFullResult.Count - 1 do - begin - s := uppercase(FFullResult[n]); - if Pos('* SEARCH', s) = 1 then - begin - s := Trim(SeparateRight(s, '* SEARCH')); - while s <> '' do - Value.Add(Fetch(s, ' ')); - end; - end; -end; - -function TIMAPSend.FindCap(const Value: string): string; -var - n: Integer; - s: string; -begin - s := UpperCase(Value); - Result := ''; - for n := 0 to FIMAPcap.Count - 1 do - if Pos(s, UpperCase(FIMAPcap[n])) = 1 then - begin - Result := FIMAPcap[n]; - Break; - end; -end; - -function TIMAPSend.AuthLogin: Boolean; -begin - Result := IMAPcommand('LOGIN "' + FUsername + '" "' + FPassword + '"') = 'OK'; -end; - -function TIMAPSend.Connect: Boolean; -begin - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError = 0 then - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError = 0 then - if FFullSSL then - FSock.SSLDoConnect; - Result := FSock.LastError = 0; -end; - -function TIMAPSend.Capability: Boolean; -var - n: Integer; - s, t: string; -begin - Result := False; - FIMAPcap.Clear; - s := IMAPcommand('CAPABILITY'); - if s = 'OK' then - begin - ProcessLiterals; - for n := 0 to FFullResult.Count - 1 do - if Pos('* CAPABILITY ', FFullResult[n]) = 1 then - begin - s := Trim(SeparateRight(FFullResult[n], '* CAPABILITY ')); - while not (s = '') do - begin - t := Trim(separateleft(s, ' ')); - s := Trim(separateright(s, ' ')); - if s = t then - s := ''; - FIMAPcap.Add(t); - end; - end; - Result := True; - end; -end; - -function TIMAPSend.Login: Boolean; -var - s: string; -begin - FSelectedFolder := ''; - FSelectedCount := 0; - FSelectedRecent := 0; - FSelectedUIDvalidity := 0; - Result := False; - FAuthDone := False; - if not Connect then - Exit; - s := FSock.RecvString(FTimeout); - if Pos('* PREAUTH', s) = 1 then - FAuthDone := True - else - if Pos('* OK', s) = 1 then - FAuthDone := False - else - Exit; - if Capability then - begin - if Findcap('IMAP4rev1') = '' then - Exit; - if FAutoTLS and (Findcap('STARTTLS') <> '') then - if StartTLS then - Capability; - end; - Result := AuthLogin; -end; - -function TIMAPSend.Logout: Boolean; -begin - Result := IMAPcommand('LOGOUT') = 'OK'; - FSelectedFolder := ''; - FSock.CloseSocket; -end; - -function TIMAPSend.NoOp: Boolean; -begin - Result := IMAPcommand('NOOP') = 'OK'; -end; - -function TIMAPSend.List(FromFolder: string; const FolderList: TStrings): Boolean; -begin - Result := IMAPcommand('LIST "' + FromFolder + '" *') = 'OK'; - ParseFolderList(FolderList); -end; - -function TIMAPSend.ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean; -begin - Result := IMAPcommand('LIST "' + FromFolder + '" "' + Search +'"') = 'OK'; - ParseFolderList(FolderList); -end; - -function TIMAPSend.ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean; -begin - Result := IMAPcommand('LSUB "' + FromFolder + '" *') = 'OK'; - ParseFolderList(FolderList); -end; - -function TIMAPSend.ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean; -begin - Result := IMAPcommand('LSUB "' + FromFolder + '" "' + Search +'"') = 'OK'; - ParseFolderList(FolderList); -end; - -function TIMAPSend.CreateFolder(FolderName: string): Boolean; -begin - Result := IMAPcommand('CREATE "' + FolderName + '"') = 'OK'; -end; - -function TIMAPSend.DeleteFolder(FolderName: string): Boolean; -begin - Result := IMAPcommand('DELETE "' + FolderName + '"') = 'OK'; -end; - -function TIMAPSend.RenameFolder(FolderName, NewFolderName: string): Boolean; -begin - Result := IMAPcommand('RENAME "' + FolderName + '" "' + NewFolderName + '"') = 'OK'; -end; - -function TIMAPSend.SubscribeFolder(FolderName: string): Boolean; -begin - Result := IMAPcommand('SUBSCRIBE "' + FolderName + '"') = 'OK'; -end; - -function TIMAPSend.UnsubscribeFolder(FolderName: string): Boolean; -begin - Result := IMAPcommand('UNSUBSCRIBE "' + FolderName + '"') = 'OK'; -end; - -function TIMAPSend.SelectFolder(FolderName: string): Boolean; -begin - Result := IMAPcommand('SELECT "' + FolderName + '"') = 'OK'; - FSelectedFolder := FolderName; - ParseSelect; -end; - -function TIMAPSend.SelectROFolder(FolderName: string): Boolean; -begin - Result := IMAPcommand('EXAMINE "' + FolderName + '"') = 'OK'; - FSelectedFolder := FolderName; - ParseSelect; -end; - -function TIMAPSend.CloseFolder: Boolean; -begin - Result := IMAPcommand('CLOSE') = 'OK'; - FSelectedFolder := ''; -end; - -function TIMAPSend.StatusFolder(FolderName, Value: string): integer; -var - n: integer; - s, t: string; -begin - Result := -1; - Value := Uppercase(Value); - if IMAPcommand('STATUS "' + FolderName + '" (' + Value + ')' ) = 'OK' then - begin - ProcessLiterals; - for n := 0 to FFullResult.Count - 1 do - begin - s := FFullResult[n]; -// s := UpperCase(FFullResult[n]); - if (Pos('* ', s) = 1) and (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then - begin - t := SeparateRight(s, Value); - t := SeparateLeft(t, ')'); - t := trim(t); - Result := StrToIntDef(t, -1); - Break; - end; - end; - end; -end; - -function TIMAPSend.ExpungeFolder: Boolean; -begin - Result := IMAPcommand('EXPUNGE') = 'OK'; -end; - -function TIMAPSend.CheckFolder: Boolean; -begin - Result := IMAPcommand('CHECK') = 'OK'; -end; - -function TIMAPSend.AppendMess(ToFolder: string; const Mess: TStrings): Boolean; -begin - Result := IMAPuploadCommand('APPEND "' + ToFolder + '"', Mess) = 'OK'; -end; - -function TIMAPSend.DeleteMess(MessID: integer): boolean; -var - s: string; -begin - s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (\Deleted)'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; -end; - -function TIMAPSend.FetchMess(MessID: integer; const Mess: TStrings): Boolean; -var - s: string; -begin - s := 'FETCH ' + IntToStr(MessID) + ' (RFC822)'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; - ParseMess(Mess); -end; - -function TIMAPSend.FetchHeader(MessID: integer; const Headers: TStrings): Boolean; -var - s: string; -begin - s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.HEADER)'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; - ParseMess(Headers); -end; - -function TIMAPSend.MessageSize(MessID: integer): integer; -var - n: integer; - s, t: string; -begin - Result := -1; - s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.SIZE)'; - if FUID then - s := 'UID ' + s; - if IMAPcommand(s) = 'OK' then - begin - ProcessLiterals; - for n := 0 to FFullResult.Count - 1 do - begin - s := UpperCase(FFullResult[n]); - if (Pos('* ', s) = 1) and (Pos('RFC822.SIZE', s) > 0 ) then - begin - t := SeparateRight(s, 'RFC822.SIZE '); - t := Trim(SeparateLeft(t, ')')); - t := Trim(SeparateLeft(t, ' ')); - Result := StrToIntDef(t, -1); - Break; - end; - end; - end; -end; - -function TIMAPSend.CopyMess(MessID: integer; ToFolder: string): Boolean; -var - s: string; -begin - s := 'COPY ' + IntToStr(MessID) + ' "' + ToFolder + '"'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; -end; - -function TIMAPSend.SearchMess(Criteria: string; const FoundMess: TStrings): Boolean; -var - s: string; -begin - s := 'SEARCH ' + Criteria; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; - ParseSearch(FoundMess); -end; - -function TIMAPSend.SetFlagsMess(MessID: integer; Flags: string): Boolean; -var - s: string; -begin - s := 'STORE ' + IntToStr(MessID) + ' FLAGS.SILENT (' + Flags + ')'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; -end; - -function TIMAPSend.AddFlagsMess(MessID: integer; Flags: string): Boolean; -var - s: string; -begin - s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (' + Flags + ')'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; -end; - -function TIMAPSend.DelFlagsMess(MessID: integer; Flags: string): Boolean; -var - s: string; -begin - s := 'STORE ' + IntToStr(MessID) + ' -FLAGS.SILENT (' + Flags + ')'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; -end; - -function TIMAPSend.GetFlagsMess(MessID: integer; var Flags: string): Boolean; -var - s: string; - n: integer; -begin - Flags := ''; - s := 'FETCH ' + IntToStr(MessID) + ' (FLAGS)'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; - ProcessLiterals; - for n := 0 to FFullResult.Count - 1 do - begin - s := uppercase(FFullResult[n]); - if (Pos('* ', s) = 1) and (Pos('FLAGS', s) > 0 ) then - begin - s := SeparateRight(s, 'FLAGS'); - s := Separateright(s, '('); - Flags := Trim(SeparateLeft(s, ')')); - end; - end; -end; - -function TIMAPSend.StartTLS: Boolean; -begin - Result := False; - if FindCap('STARTTLS') <> '' then - begin - if IMAPcommand('STARTTLS') = 'OK' then - begin - Fsock.SSLDoConnect; - Result := FSock.LastError = 0; - end; - end; -end; - -//Paul Buskermolen -function TIMAPSend.GetUID(MessID: integer; var UID : Integer): boolean; -var - s, sUid: string; - n: integer; -begin - sUID := ''; - s := 'FETCH ' + IntToStr(MessID) + ' UID'; - Result := IMAPcommand(s) = 'OK'; - ProcessLiterals; - for n := 0 to FFullResult.Count - 1 do - begin - s := uppercase(FFullResult[n]); - if Pos('FETCH (UID', s) >= 1 then - begin - s := Separateright(s, '(UID '); - sUID := Trim(SeparateLeft(s, ')')); - end; - end; - UID := StrToIntDef(sUID, 0); -end; - -{==============================================================================} - -end. diff --git a/addons/synapse/laz_synapse.lpk b/addons/synapse/laz_synapse.lpk deleted file mode 100644 index e686e41..0000000 --- a/addons/synapse/laz_synapse.lpk +++ /dev/null @@ -1,170 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/addons/synapse/laz_synapse.pas b/addons/synapse/laz_synapse.pas deleted file mode 100644 index 2eaa540..0000000 --- a/addons/synapse/laz_synapse.pas +++ /dev/null @@ -1,24 +0,0 @@ -{ This file was automatically created by Lazarus. Do not edit! - This source is only used to compile and install the package. - } - -unit laz_synapse; - -interface - -uses - asn1util, blcksock, clamsend, dnssend, ftpsend, ftptsend, httpsend, - imapsend, ldapsend, mimeinln, mimemess, mimepart, nntpsend, pingsend, - pop3send, slogsend, smtpsend, snmpsend, sntpsend, synachar, synacode, - synacrypt, synadbg, synafpc, synaicnv, synaip, synamisc, synaser, synautil, - synsock, tlntsend, LazarusPackageIntf; - -implementation - -procedure Register; -begin -end; - -initialization - RegisterPackage('laz_synapse', @Register); -end. diff --git a/addons/synapse/ldapsend.pas b/addons/synapse/ldapsend.pas deleted file mode 100644 index ece52d6..0000000 --- a/addons/synapse/ldapsend.pas +++ /dev/null @@ -1,1208 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.007.000 | -|==============================================================================| -| Content: LDAP client | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2003-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(LDAP client) - -Used RFC: RFC-2251, RFC-2254, RFC-2829, RFC-2830 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit ldapsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil, asn1util, synacode; - -const - cLDAPProtocol = '389'; - - LDAP_ASN1_BIND_REQUEST = $60; - LDAP_ASN1_BIND_RESPONSE = $61; - LDAP_ASN1_UNBIND_REQUEST = $42; - LDAP_ASN1_SEARCH_REQUEST = $63; - LDAP_ASN1_SEARCH_ENTRY = $64; - LDAP_ASN1_SEARCH_DONE = $65; - LDAP_ASN1_SEARCH_REFERENCE = $73; - LDAP_ASN1_MODIFY_REQUEST = $66; - LDAP_ASN1_MODIFY_RESPONSE = $67; - LDAP_ASN1_ADD_REQUEST = $68; - LDAP_ASN1_ADD_RESPONSE = $69; - LDAP_ASN1_DEL_REQUEST = $4A; - LDAP_ASN1_DEL_RESPONSE = $6B; - LDAP_ASN1_MODIFYDN_REQUEST = $6C; - LDAP_ASN1_MODIFYDN_RESPONSE = $6D; - LDAP_ASN1_COMPARE_REQUEST = $6E; - LDAP_ASN1_COMPARE_RESPONSE = $6F; - LDAP_ASN1_ABANDON_REQUEST = $70; - LDAP_ASN1_EXT_REQUEST = $77; - LDAP_ASN1_EXT_RESPONSE = $78; - - -type - - {:@abstract(LDAP attribute with list of their values) - This class holding name of LDAP attribute and list of their values. This is - descendant of TStringList class enhanced by some new properties.} - TLDAPAttribute = class(TStringList) - private - FAttributeName: AnsiString; - FIsBinary: Boolean; - protected - function Get(Index: integer): string; override; - procedure Put(Index: integer; const Value: string); override; - procedure SetAttributeName(Value: AnsiString); - published - {:Name of LDAP attribute.} - property AttributeName: AnsiString read FAttributeName Write SetAttributeName; - {:Return @true when attribute contains binary data.} - property IsBinary: Boolean read FIsBinary; - end; - - {:@abstract(List of @link(TLDAPAttribute)) - This object can hold list of TLDAPAttribute objects.} - TLDAPAttributeList = class(TObject) - private - FAttributeList: TList; - function GetAttribute(Index: integer): TLDAPAttribute; - public - constructor Create; - destructor Destroy; override; - {:Clear list.} - procedure Clear; - {:Return count of TLDAPAttribute objects in list.} - function Count: integer; - {:Add new TLDAPAttribute object to list.} - function Add: TLDAPAttribute; - {:Delete one TLDAPAttribute object from list.} - procedure Del(Index: integer); - {:Find and return attribute with requested name. Returns nil if not found.} - function Find(AttributeName: AnsiString): TLDAPAttribute; - {:Find and return attribute value with requested name. Returns empty string if not found.} - function Get(AttributeName: AnsiString): string; - {:List of TLDAPAttribute objects.} - property Items[Index: Integer]: TLDAPAttribute read GetAttribute; default; - end; - - {:@abstract(LDAP result object) - This object can hold LDAP object. (their name and all their attributes with - values)} - TLDAPResult = class(TObject) - private - FObjectName: AnsiString; - FAttributes: TLDAPAttributeList; - public - constructor Create; - destructor Destroy; override; - published - {:Name of this LDAP object.} - property ObjectName: AnsiString read FObjectName write FObjectName; - {:Here is list of object attributes.} - property Attributes: TLDAPAttributeList read FAttributes; - end; - - {:@abstract(List of LDAP result objects) - This object can hold list of LDAP objects. (for example result of LDAP SEARCH.)} - TLDAPResultList = class(TObject) - private - FResultList: TList; - function GetResult(Index: integer): TLDAPResult; - public - constructor Create; - destructor Destroy; override; - {:Clear all TLDAPResult objects in list.} - procedure Clear; - {:Return count of TLDAPResult objects in list.} - function Count: integer; - {:Create and add new TLDAPResult object to list.} - function Add: TLDAPResult; - {:List of TLDAPResult objects.} - property Items[Index: Integer]: TLDAPResult read GetResult; default; - end; - - {:Define possible operations for LDAP MODIFY operations.} - TLDAPModifyOp = ( - MO_Add, - MO_Delete, - MO_Replace - ); - - {:Specify possible values for search scope.} - TLDAPSearchScope = ( - SS_BaseObject, - SS_SingleLevel, - SS_WholeSubtree - ); - - {:Specify possible values about alias dereferencing.} - TLDAPSearchAliases = ( - SA_NeverDeref, - SA_InSearching, - SA_FindingBaseObj, - SA_Always - ); - - {:@abstract(Implementation of LDAP client) - (version 2 and 3) - - Note: Are you missing properties for setting Username and Password? Look to - parent @link(TSynaClient) object! - - Are you missing properties for specify server address and port? Look to - parent @link(TSynaClient) too!} - TLDAPSend = class(TSynaClient) - private - FSock: TTCPBlockSocket; - FResultCode: Integer; - FResultString: AnsiString; - FFullResult: AnsiString; - FAutoTLS: Boolean; - FFullSSL: Boolean; - FSeq: integer; - FResponseCode: integer; - FResponseDN: AnsiString; - FReferals: TStringList; - FVersion: integer; - FSearchScope: TLDAPSearchScope; - FSearchAliases: TLDAPSearchAliases; - FSearchSizeLimit: integer; - FSearchTimeLimit: integer; - FSearchResult: TLDAPResultList; - FExtName: AnsiString; - FExtValue: AnsiString; - function Connect: Boolean; - function BuildPacket(const Value: AnsiString): AnsiString; - function ReceiveResponse: AnsiString; - function DecodeResponse(const Value: AnsiString): AnsiString; - function LdapSasl(Value: AnsiString): AnsiString; - function TranslateFilter(Value: AnsiString): AnsiString; - function GetErrorString(Value: integer): AnsiString; - public - constructor Create; - destructor Destroy; override; - - {:Try to connect to LDAP server and start secure channel, when it is required.} - function Login: Boolean; - - {:Try to bind to LDAP server with @link(TSynaClient.Username) and - @link(TSynaClient.Password). If this is empty strings, then it do annonymous - Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous - mode. - - This method using plaintext transport of password! It is not secure!} - function Bind: Boolean; - - {:Try to bind to LDAP server with @link(TSynaClient.Username) and - @link(TSynaClient.Password). If this is empty strings, then it do annonymous - Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous - mode. - - This method using SASL with DIGEST-MD5 method for secure transfer of your - password.} - function BindSasl: Boolean; - - {:Close connection to LDAP server.} - function Logout: Boolean; - - {:Modify content of LDAP attribute on this object.} - function Modify(obj: AnsiString; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean; - - {:Add list of attributes to specified object.} - function Add(obj: AnsiString; const Value: TLDAPAttributeList): Boolean; - - {:Delete this LDAP object from server.} - function Delete(obj: AnsiString): Boolean; - - {:Modify object name of this LDAP object.} - function ModifyDN(obj, newRDN, newSuperior: AnsiString; DeleteoldRDN: Boolean): Boolean; - - {:Try to compare Attribute value with this LDAP object.} - function Compare(obj, AttributeValue: AnsiString): Boolean; - - {:Search LDAP base for LDAP objects by Filter.} - function Search(obj: AnsiString; TypesOnly: Boolean; Filter: AnsiString; - const Attributes: TStrings): Boolean; - - {:Call any LDAPv3 extended command.} - function Extended(const Name, Value: AnsiString): Boolean; - - {:Try to start SSL/TLS connection to LDAP server.} - function StartTLS: Boolean; - published - {:Specify version of used LDAP protocol. Default value is 3.} - property Version: integer read FVersion Write FVersion; - - {:Result code of last LDAP operation.} - property ResultCode: Integer read FResultCode; - - {:Human readable description of result code of last LDAP operation.} - property ResultString: AnsiString read FResultString; - - {:Binary string with full last response of LDAP server. This string is - encoded by ASN.1 BER encoding! You need this only for debugging.} - property FullResult: AnsiString read FFullResult; - - {:If @true, then try to start TSL mode in Login procedure.} - property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; - - {:If @true, then use connection to LDAP server through SSL/TLS tunnel.} - property FullSSL: Boolean read FFullSSL Write FFullSSL; - - {:Sequence number of last LDAp command. It is incremented by any LDAP command.} - property Seq: integer read FSeq; - - {:Specify what search scope is used in search command.} - property SearchScope: TLDAPSearchScope read FSearchScope Write FSearchScope; - - {:Specify how to handle aliases in search command.} - property SearchAliases: TLDAPSearchAliases read FSearchAliases Write FSearchAliases; - - {:Specify result size limit in search command. Value 0 means without limit.} - property SearchSizeLimit: integer read FSearchSizeLimit Write FSearchSizeLimit; - - {:Specify search time limit in search command (seconds). Value 0 means - without limit.} - property SearchTimeLimit: integer read FSearchTimeLimit Write FSearchTimeLimit; - - {:Here is result of search command.} - property SearchResult: TLDAPResultList read FSearchResult; - - {:On each LDAP operation can LDAP server return some referals URLs. Here is - their list.} - property Referals: TStringList read FReferals; - - {:When you call @link(Extended) operation, then here is result Name returned - by server.} - property ExtName: AnsiString read FExtName; - - {:When you call @link(Extended) operation, then here is result Value returned - by server.} - property ExtValue: AnsiString read FExtValue; - - {:TCP socket used by all LDAP operations.} - property Sock: TTCPBlockSocket read FSock; - end; - -{:Dump result of LDAP SEARCH into human readable form. Good for debugging.} -function LDAPResultDump(const Value: TLDAPResultList): AnsiString; - -implementation - -{==============================================================================} -function TLDAPAttribute.Get(Index: integer): string; -begin - Result := inherited Get(Index); - if FIsbinary then - Result := DecodeBase64(Result); -end; - -procedure TLDAPAttribute.Put(Index: integer; const Value: string); -var - s: AnsiString; -begin - s := Value; - if FIsbinary then - s := EncodeBase64(Value) - else - s :=UnquoteStr(s, '"'); - inherited Put(Index, s); -end; - -procedure TLDAPAttribute.SetAttributeName(Value: AnsiString); -begin - FAttributeName := Value; - FIsBinary := Pos(';binary', Lowercase(value)) > 0; -end; - -{==============================================================================} -constructor TLDAPAttributeList.Create; -begin - inherited Create; - FAttributeList := TList.Create; -end; - -destructor TLDAPAttributeList.Destroy; -begin - Clear; - FAttributeList.Free; - inherited Destroy; -end; - -procedure TLDAPAttributeList.Clear; -var - n: integer; - x: TLDAPAttribute; -begin - for n := Count - 1 downto 0 do - begin - x := GetAttribute(n); - if Assigned(x) then - x.Free; - end; - FAttributeList.Clear; -end; - -function TLDAPAttributeList.Count: integer; -begin - Result := FAttributeList.Count; -end; - -function TLDAPAttributeList.Get(AttributeName: AnsiString): string; -var - x: TLDAPAttribute; -begin - Result := ''; - x := self.Find(AttributeName); - if x <> nil then - if x.Count > 0 then - Result := x[0]; -end; - -function TLDAPAttributeList.GetAttribute(Index: integer): TLDAPAttribute; -begin - Result := nil; - if Index < Count then - Result := TLDAPAttribute(FAttributeList[Index]); -end; - -function TLDAPAttributeList.Add: TLDAPAttribute; -begin - Result := TLDAPAttribute.Create; - FAttributeList.Add(Result); -end; - -procedure TLDAPAttributeList.Del(Index: integer); -var - x: TLDAPAttribute; -begin - x := GetAttribute(Index); - if Assigned(x) then - x.free; - FAttributeList.Delete(Index); -end; - -function TLDAPAttributeList.Find(AttributeName: AnsiString): TLDAPAttribute; -var - n: integer; - x: TLDAPAttribute; -begin - Result := nil; - AttributeName := lowercase(AttributeName); - for n := 0 to Count - 1 do - begin - x := GetAttribute(n); - if Assigned(x) then - if lowercase(x.AttributeName) = Attributename then - begin - result := x; - break; - end; - end; -end; - -{==============================================================================} -constructor TLDAPResult.Create; -begin - inherited Create; - FAttributes := TLDAPAttributeList.Create; -end; - -destructor TLDAPResult.Destroy; -begin - FAttributes.Free; - inherited Destroy; -end; - -{==============================================================================} -constructor TLDAPResultList.Create; -begin - inherited Create; - FResultList := TList.Create; -end; - -destructor TLDAPResultList.Destroy; -begin - Clear; - FResultList.Free; - inherited Destroy; -end; - -procedure TLDAPResultList.Clear; -var - n: integer; - x: TLDAPResult; -begin - for n := Count - 1 downto 0 do - begin - x := GetResult(n); - if Assigned(x) then - x.Free; - end; - FResultList.Clear; -end; - -function TLDAPResultList.Count: integer; -begin - Result := FResultList.Count; -end; - -function TLDAPResultList.GetResult(Index: integer): TLDAPResult; -begin - Result := nil; - if Index < Count then - Result := TLDAPResult(FResultList[Index]); -end; - -function TLDAPResultList.Add: TLDAPResult; -begin - Result := TLDAPResult.Create; - FResultList.Add(Result); -end; - -{==============================================================================} -constructor TLDAPSend.Create; -begin - inherited Create; - FReferals := TStringList.Create; - FFullResult := ''; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FTimeout := 60000; - FTargetPort := cLDAPProtocol; - FAutoTLS := False; - FFullSSL := False; - FSeq := 0; - FVersion := 3; - FSearchScope := SS_WholeSubtree; - FSearchAliases := SA_Always; - FSearchSizeLimit := 0; - FSearchTimeLimit := 0; - FSearchResult := TLDAPResultList.Create; -end; - -destructor TLDAPSend.Destroy; -begin - FSock.Free; - FSearchResult.Free; - FReferals.Free; - inherited Destroy; -end; - -function TLDAPSend.GetErrorString(Value: integer): AnsiString; -begin - case Value of - 0: - Result := 'Success'; - 1: - Result := 'Operations error'; - 2: - Result := 'Protocol error'; - 3: - Result := 'Time limit Exceeded'; - 4: - Result := 'Size limit Exceeded'; - 5: - Result := 'Compare FALSE'; - 6: - Result := 'Compare TRUE'; - 7: - Result := 'Auth method not supported'; - 8: - Result := 'Strong auth required'; - 9: - Result := '-- reserved --'; - 10: - Result := 'Referal'; - 11: - Result := 'Admin limit exceeded'; - 12: - Result := 'Unavailable critical extension'; - 13: - Result := 'Confidentality required'; - 14: - Result := 'Sasl bind in progress'; - 16: - Result := 'No such attribute'; - 17: - Result := 'Undefined attribute type'; - 18: - Result := 'Inappropriate matching'; - 19: - Result := 'Constraint violation'; - 20: - Result := 'Attribute or value exists'; - 21: - Result := 'Invalid attribute syntax'; - 32: - Result := 'No such object'; - 33: - Result := 'Alias problem'; - 34: - Result := 'Invalid DN syntax'; - 36: - Result := 'Alias dereferencing problem'; - 48: - Result := 'Inappropriate authentication'; - 49: - Result := 'Invalid credentials'; - 50: - Result := 'Insufficient access rights'; - 51: - Result := 'Busy'; - 52: - Result := 'Unavailable'; - 53: - Result := 'Unwilling to perform'; - 54: - Result := 'Loop detect'; - 64: - Result := 'Naming violation'; - 65: - Result := 'Object class violation'; - 66: - Result := 'Not allowed on non leaf'; - 67: - Result := 'Not allowed on RDN'; - 68: - Result := 'Entry already exists'; - 69: - Result := 'Object class mods prohibited'; - 71: - Result := 'Affects multiple DSAs'; - 80: - Result := 'Other'; - else - Result := '--unknown--'; - end; -end; - -function TLDAPSend.Connect: Boolean; -begin - // Do not call this function! It is calling by LOGIN method! - FSock.CloseSocket; - FSock.LineBuffer := ''; - FSeq := 0; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError = 0 then - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError = 0 then - if FFullSSL then - FSock.SSLDoConnect; - Result := FSock.LastError = 0; -end; - -function TLDAPSend.BuildPacket(const Value: AnsiString): AnsiString; -begin - Inc(FSeq); - Result := ASNObject(ASNObject(ASNEncInt(FSeq), ASN1_INT) + Value, ASN1_SEQ); -end; - -function TLDAPSend.ReceiveResponse: AnsiString; -var - x: Byte; - i,j: integer; -begin - Result := ''; - FFullResult := ''; - x := FSock.RecvByte(FTimeout); - if x <> ASN1_SEQ then - Exit; - Result := AnsiChar(x); - x := FSock.RecvByte(FTimeout); - Result := Result + AnsiChar(x); - if x < $80 then - i := 0 - else - i := x and $7F; - if i > 0 then - Result := Result + FSock.RecvBufferStr(i, Ftimeout); - if FSock.LastError <> 0 then - begin - Result := ''; - Exit; - end; - //get length of LDAP packet - j := 2; - i := ASNDecLen(j, Result); - //retreive rest of LDAP packet - if i > 0 then - Result := Result + FSock.RecvBufferStr(i, Ftimeout); - if FSock.LastError <> 0 then - begin - Result := ''; - Exit; - end; - FFullResult := Result; -end; - -function TLDAPSend.DecodeResponse(const Value: AnsiString): AnsiString; -var - i, x: integer; - Svt: Integer; - s, t: AnsiString; -begin - Result := ''; - FResultCode := -1; - FResultstring := ''; - FResponseCode := -1; - FResponseDN := ''; - FReferals.Clear; - i := 1; - ASNItem(i, Value, Svt); - x := StrToIntDef(ASNItem(i, Value, Svt), 0); - if (svt <> ASN1_INT) or (x <> FSeq) then - Exit; - s := ASNItem(i, Value, Svt); - FResponseCode := svt; - if FResponseCode in [LDAP_ASN1_BIND_RESPONSE, LDAP_ASN1_SEARCH_DONE, - LDAP_ASN1_MODIFY_RESPONSE, LDAP_ASN1_ADD_RESPONSE, LDAP_ASN1_DEL_RESPONSE, - LDAP_ASN1_MODIFYDN_RESPONSE, LDAP_ASN1_COMPARE_RESPONSE, - LDAP_ASN1_EXT_RESPONSE] then - begin - FResultCode := StrToIntDef(ASNItem(i, Value, Svt), -1); - FResponseDN := ASNItem(i, Value, Svt); - FResultString := ASNItem(i, Value, Svt); - if FResultString = '' then - FResultString := GetErrorString(FResultCode); - if FResultCode = 10 then - begin - s := ASNItem(i, Value, Svt); - if svt = $A3 then - begin - x := 1; - while x < Length(s) do - begin - t := ASNItem(x, s, Svt); - FReferals.Add(t); - end; - end; - end; - end; - Result := Copy(Value, i, Length(Value) - i + 1); -end; - -function TLDAPSend.LdapSasl(Value: AnsiString): AnsiString; -var - nonce, cnonce, nc, realm, qop, uri, response: AnsiString; - s: AnsiString; - a1, a2: AnsiString; - l: TStringList; - n: integer; -begin - l := TStringList.Create; - try - nonce := ''; - realm := ''; - l.CommaText := Value; - n := IndexByBegin('nonce=', l); - if n >= 0 then - nonce := UnQuoteStr(Trim(SeparateRight(l[n], 'nonce=')), '"'); - n := IndexByBegin('realm=', l); - if n >= 0 then - realm := UnQuoteStr(Trim(SeparateRight(l[n], 'realm=')), '"'); - cnonce := IntToHex(GetTick, 8); - nc := '00000001'; - qop := 'auth'; - uri := 'ldap/' + FSock.ResolveIpToName(FSock.GetRemoteSinIP); - a1 := md5(FUsername + ':' + realm + ':' + FPassword) - + ':' + nonce + ':' + cnonce; - a2 := 'AUTHENTICATE:' + uri; - s := strtohex(md5(a1))+':' + nonce + ':' + nc + ':' + cnonce + ':' - + qop +':'+strtohex(md5(a2)); - response := strtohex(md5(s)); - - Result := 'username="' + Fusername + '",realm="' + realm + '",nonce="'; - Result := Result + nonce + '",cnonce="' + cnonce + '",nc=' + nc + ',qop='; - Result := Result + qop + ',digest-uri="' + uri + '",response=' + response; - finally - l.Free; - end; -end; - -function TLDAPSend.TranslateFilter(Value: AnsiString): AnsiString; -var - x: integer; - s, t, l: AnsiString; - r: string; - c: Ansichar; - attr, rule: AnsiString; - dn: Boolean; -begin - Result := ''; - if Value = '' then - Exit; - s := Value; - if Value[1] = '(' then - begin - x := RPos(')', Value); - s := Copy(Value, 2, x - 2); - end; - if s = '' then - Exit; - case s[1] of - '!': - // NOT rule (recursive call) - begin - Result := ASNOBject(TranslateFilter(GetBetween('(', ')', s)), $A2); - end; - '&': - // AND rule (recursive call) - begin - repeat - t := GetBetween('(', ')', s); - s := Trim(SeparateRight(s, t)); - if s <> '' then - if s[1] = ')' then - {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1); - Result := Result + TranslateFilter(t); - until s = ''; - Result := ASNOBject(Result, $A0); - end; - '|': - // OR rule (recursive call) - begin - repeat - t := GetBetween('(', ')', s); - s := Trim(SeparateRight(s, t)); - if s <> '' then - if s[1] = ')' then - {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1); - Result := Result + TranslateFilter(t); - until s = ''; - Result := ASNOBject(Result, $A1); - end; - else - begin - l := Trim(SeparateLeft(s, '=')); - r := Trim(SeparateRight(s, '=')); - if l <> '' then - begin - c := l[Length(l)]; - case c of - ':': - // Extensible match - begin - {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); - dn := False; - attr := ''; - rule := ''; - if Pos(':dn', l) > 0 then - begin - dn := True; - l := ReplaceString(l, ':dn', ''); - end; - attr := Trim(SeparateLeft(l, ':')); - rule := Trim(SeparateRight(l, ':')); - if rule = l then - rule := ''; - if rule <> '' then - Result := ASNObject(rule, $81); - if attr <> '' then - Result := Result + ASNObject(attr, $82); - Result := Result + ASNObject(DecodeTriplet(r, '\'), $83); - if dn then - Result := Result + ASNObject(AsnEncInt($ff), $84) - else - Result := Result + ASNObject(AsnEncInt(0), $84); - Result := ASNOBject(Result, $a9); - end; - '~': - // Approx match - begin - {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); - Result := ASNOBject(l, ASN1_OCTSTR) - + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); - Result := ASNOBject(Result, $a8); - end; - '>': - // Greater or equal match - begin - {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); - Result := ASNOBject(l, ASN1_OCTSTR) - + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); - Result := ASNOBject(Result, $a5); - end; - '<': - // Less or equal match - begin - {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); - Result := ASNOBject(l, ASN1_OCTSTR) - + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); - Result := ASNOBject(Result, $a6); - end; - else - // present - if r = '*' then - Result := ASNOBject(l, $87) - else - if Pos('*', r) > 0 then - // substrings - begin - s := Fetch(r, '*'); - if s <> '' then - Result := ASNOBject(DecodeTriplet(s, '\'), $80); - while r <> '' do - begin - if Pos('*', r) <= 0 then - break; - s := Fetch(r, '*'); - Result := Result + ASNOBject(DecodeTriplet(s, '\'), $81); - end; - if r <> '' then - Result := Result + ASNOBject(DecodeTriplet(r, '\'), $82); - Result := ASNOBject(l, ASN1_OCTSTR) - + ASNOBject(Result, ASN1_SEQ); - Result := ASNOBject(Result, $a4); - end - else - begin - // Equality match - Result := ASNOBject(l, ASN1_OCTSTR) - + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); - Result := ASNOBject(Result, $a3); - end; - end; - end; - end; - end; -end; - -function TLDAPSend.Login: Boolean; -begin - Result := False; - if not Connect then - Exit; - Result := True; - if FAutoTLS then - Result := StartTLS; -end; - -function TLDAPSend.Bind: Boolean; -var - s: AnsiString; -begin - s := ASNObject(ASNEncInt(FVersion), ASN1_INT) - + ASNObject(FUsername, ASN1_OCTSTR) - + ASNObject(FPassword, $80); - s := ASNObject(s, LDAP_ASN1_BIND_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - DecodeResponse(s); - Result := FResultCode = 0; -end; - -function TLDAPSend.BindSasl: Boolean; -var - s, t: AnsiString; - x, xt: integer; - digreq: AnsiString; -begin - Result := False; - if FPassword = '' then - Result := Bind - else - begin - digreq := ASNObject(ASNEncInt(FVersion), ASN1_INT) - + ASNObject('', ASN1_OCTSTR) - + ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR), $A3); - digreq := ASNObject(digreq, LDAP_ASN1_BIND_REQUEST); - Fsock.SendString(BuildPacket(digreq)); - s := ReceiveResponse; - t := DecodeResponse(s); - if FResultCode = 14 then - begin - s := t; - x := 1; - t := ASNItem(x, s, xt); - s := ASNObject(ASNEncInt(FVersion), ASN1_INT) - + ASNObject('', ASN1_OCTSTR) - + ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR) - + ASNObject(LdapSasl(t), ASN1_OCTSTR), $A3); - s := ASNObject(s, LDAP_ASN1_BIND_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - DecodeResponse(s); - if FResultCode = 14 then - begin - Fsock.SendString(BuildPacket(digreq)); - s := ReceiveResponse; - DecodeResponse(s); - end; - Result := FResultCode = 0; - end; - end; -end; - -function TLDAPSend.Logout: Boolean; -begin - Fsock.SendString(BuildPacket(ASNObject('', LDAP_ASN1_UNBIND_REQUEST))); - FSock.CloseSocket; - Result := True; -end; - -function TLDAPSend.Modify(obj: AnsiString; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean; -var - s: AnsiString; - n: integer; -begin - s := ''; - for n := 0 to Value.Count -1 do - s := s + ASNObject(Value[n], ASN1_OCTSTR); - s := ASNObject(Value.AttributeName, ASN1_OCTSTR) + ASNObject(s, ASN1_SETOF); - s := ASNObject(ASNEncInt(Ord(Op)), ASN1_ENUM) + ASNObject(s, ASN1_SEQ); - s := ASNObject(s, ASN1_SEQ); - s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); - s := ASNObject(s, LDAP_ASN1_MODIFY_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - DecodeResponse(s); - Result := FResultCode = 0; -end; - -function TLDAPSend.Add(obj: AnsiString; const Value: TLDAPAttributeList): Boolean; -var - s, t: AnsiString; - n, m: integer; -begin - s := ''; - for n := 0 to Value.Count - 1 do - begin - t := ''; - for m := 0 to Value[n].Count - 1 do - t := t + ASNObject(Value[n][m], ASN1_OCTSTR); - t := ASNObject(Value[n].AttributeName, ASN1_OCTSTR) - + ASNObject(t, ASN1_SETOF); - s := s + ASNObject(t, ASN1_SEQ); - end; - s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); - s := ASNObject(s, LDAP_ASN1_ADD_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - DecodeResponse(s); - Result := FResultCode = 0; -end; - -function TLDAPSend.Delete(obj: AnsiString): Boolean; -var - s: AnsiString; -begin - s := ASNObject(obj, LDAP_ASN1_DEL_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - DecodeResponse(s); - Result := FResultCode = 0; -end; - -function TLDAPSend.ModifyDN(obj, newRDN, newSuperior: AnsiString; DeleteOldRDN: Boolean): Boolean; -var - s: AnsiString; -begin - s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(newRDN, ASN1_OCTSTR); - if DeleteOldRDN then - s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL) - else - s := s + ASNObject(ASNEncInt(0), ASN1_BOOL); - if newSuperior <> '' then - s := s + ASNObject(newSuperior, $80); - s := ASNObject(s, LDAP_ASN1_MODIFYDN_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - DecodeResponse(s); - Result := FResultCode = 0; -end; - -function TLDAPSend.Compare(obj, AttributeValue: AnsiString): Boolean; -var - s: AnsiString; -begin - s := ASNObject(Trim(SeparateLeft(AttributeValue, '=')), ASN1_OCTSTR) - + ASNObject(Trim(SeparateRight(AttributeValue, '=')), ASN1_OCTSTR); - s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); - s := ASNObject(s, LDAP_ASN1_COMPARE_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - DecodeResponse(s); - Result := FResultCode = 0; -end; - -function TLDAPSend.Search(obj: AnsiString; TypesOnly: Boolean; Filter: AnsiString; - const Attributes: TStrings): Boolean; -var - s, t, u: AnsiString; - n, i, x: integer; - r: TLDAPResult; - a: TLDAPAttribute; -begin - FSearchResult.Clear; - FReferals.Clear; - s := ASNObject(obj, ASN1_OCTSTR); - s := s + ASNObject(ASNEncInt(Ord(FSearchScope)), ASN1_ENUM); - s := s + ASNObject(ASNEncInt(Ord(FSearchAliases)), ASN1_ENUM); - s := s + ASNObject(ASNEncInt(FSearchSizeLimit), ASN1_INT); - s := s + ASNObject(ASNEncInt(FSearchTimeLimit), ASN1_INT); - if TypesOnly then - s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL) - else - s := s + ASNObject(ASNEncInt(0), ASN1_BOOL); - if Filter = '' then - Filter := '(objectclass=*)'; - t := TranslateFilter(Filter); - if t = '' then - s := s + ASNObject('', ASN1_NULL) - else - s := s + t; - t := ''; - for n := 0 to Attributes.Count - 1 do - t := t + ASNObject(Attributes[n], ASN1_OCTSTR); - s := s + ASNObject(t, ASN1_SEQ); - s := ASNObject(s, LDAP_ASN1_SEARCH_REQUEST); - Fsock.SendString(BuildPacket(s)); - repeat - s := ReceiveResponse; - t := DecodeResponse(s); - if FResponseCode = LDAP_ASN1_SEARCH_ENTRY then - begin - //dekoduj zaznam - r := FSearchResult.Add; - n := 1; - r.ObjectName := ASNItem(n, t, x); - ASNItem(n, t, x); - if x = ASN1_SEQ then - begin - while n < Length(t) do - begin - s := ASNItem(n, t, x); - if x = ASN1_SEQ then - begin - i := n + Length(s); - a := r.Attributes.Add; - u := ASNItem(n, t, x); - a.AttributeName := u; - ASNItem(n, t, x); - if x = ASN1_SETOF then - while n < i do - begin - u := ASNItem(n, t, x); - a.Add(u); - end; - end; - end; - end; - end; - if FResponseCode = LDAP_ASN1_SEARCH_REFERENCE then - begin - n := 1; - while n < Length(t) do - FReferals.Add(ASNItem(n, t, x)); - end; - until FResponseCode = LDAP_ASN1_SEARCH_DONE; - Result := FResultCode = 0; -end; - -function TLDAPSend.Extended(const Name, Value: AnsiString): Boolean; -var - s, t: AnsiString; - x, xt: integer; -begin - s := ASNObject(Name, $80); - if Value <> '' then - s := s + ASNObject(Value, $81); - s := ASNObject(s, LDAP_ASN1_EXT_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - t := DecodeResponse(s); - Result := FResultCode = 0; - if Result then - begin - x := 1; - FExtName := ASNItem(x, t, xt); - FExtValue := ASNItem(x, t, xt); - end; -end; - - -function TLDAPSend.StartTLS: Boolean; -begin - Result := Extended('1.3.6.1.4.1.1466.20037', ''); - if Result then - begin - Fsock.SSLDoConnect; - Result := FSock.LastError = 0; - end; -end; - -{==============================================================================} -function LDAPResultDump(const Value: TLDAPResultList): AnsiString; -var - n, m, o: integer; - r: TLDAPResult; - a: TLDAPAttribute; -begin - Result := 'Results: ' + IntToStr(Value.Count) + CRLF +CRLF; - for n := 0 to Value.Count - 1 do - begin - Result := Result + 'Result: ' + IntToStr(n) + CRLF; - r := Value[n]; - Result := Result + ' Object: ' + r.ObjectName + CRLF; - for m := 0 to r.Attributes.Count - 1 do - begin - a := r.Attributes[m]; - Result := Result + ' Attribute: ' + a.AttributeName + CRLF; - for o := 0 to a.Count - 1 do - Result := Result + ' ' + a[o] + CRLF; - end; - end; -end; - -end. diff --git a/addons/synapse/mimeinln.pas b/addons/synapse/mimeinln.pas deleted file mode 100644 index 924dd5f..0000000 --- a/addons/synapse/mimeinln.pas +++ /dev/null @@ -1,263 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.011 | -|==============================================================================| -| Content: Inline MIME support procedures and functions | -|==============================================================================| -| Copyright (c)1999-2006, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2006. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(Utilities for inline MIME) -Support for Inline MIME encoding and decoding. - -Used RFC: RFC-2047, RFC-2231 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit mimeinln; - -interface - -uses - SysUtils, Classes, - synachar, synacode, synautil; - -{:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".} -function InlineDecode(const Value: string; CP: TMimeChar): string; - -{:Encodes string to MIME inline encoding. The source characterset is "CP", and - the target charset is "MimeP".} -function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string; - -{:Returns @true, if "Value" contains characters needed for inline coding.} -function NeedInline(const Value: AnsiString): boolean; - -{:Inline mime encoding similar to @link(InlineEncode), but you can specify - source charset, and the target characterset is automatically assigned.} -function InlineCodeEx(const Value: string; FromCP: TMimeChar): string; - -{:Inline MIME encoding similar to @link(InlineEncode), but the source charset - is automatically set to the system default charset, and the target charset is - automatically assigned from set of allowed encoding for MIME.} -function InlineCode(const Value: string): string; - -{:Converts e-mail address to canonical mime form. You can specify source charset.} -function InlineEmailEx(const Value: string; FromCP: TMimeChar): string; - -{:Converts e-mail address to canonical mime form. Source charser it system - default charset.} -function InlineEmail(const Value: string): string; - -implementation - -{==============================================================================} - -function InlineDecode(const Value: string; CP: TMimeChar): string; -var - s, su, v: string; - x, y, z, n: Integer; - ichar: TMimeChar; - c: Char; - - function SearchEndInline(const Value: string; be: Integer): Integer; - var - n, q: Integer; - begin - q := 0; - Result := 0; - for n := be + 2 to Length(Value) - 1 do - if Value[n] = '?' then - begin - Inc(q); - if (q > 2) and (Value[n + 1] = '=') then - begin - Result := n; - Break; - end; - end; - end; - -begin - Result := ''; - v := Value; - x := Pos('=?', v); - y := SearchEndInline(v, x); - //fix for broken coding with begin, but not with end. - if (x > 0) and (y <= 0) then - y := Length(Result); - while (y > x) and (x > 0) do - begin - s := Copy(v, 1, x - 1); - if Trim(s) <> '' then - Result := Result + s; - s := Copy(v, x, y - x + 2); - Delete(v, 1, y + 1); - su := Copy(s, 3, Length(s) - 4); - z := Pos('?', su); - if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then - begin - ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*')); - c := UpperCase(su)[z + 1]; - su := Copy(su, z + 3, Length(su) - z - 2); - if c = 'B' then - begin - s := DecodeBase64(su); - s := CharsetConversion(s, ichar, CP); - end; - if c = 'Q' then - begin - s := ''; - for n := 1 to Length(su) do - if su[n] = '_' then - s := s + ' ' - else - s := s + su[n]; - s := DecodeQuotedPrintable(s); - s := CharsetConversion(s, ichar, CP); - end; - end; - Result := Result + s; - x := Pos('=?', v); - y := SearchEndInline(v, x); - end; - Result := Result + v; -end; - -{==============================================================================} - -function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string; -var - s, s1, e: string; - n: Integer; -begin - s := CharsetConversion(Value, CP, MimeP); - s := EncodeSafeQuotedPrintable(s); - e := GetIdFromCP(MimeP); - s1 := ''; - Result := ''; - for n := 1 to Length(s) do - if s[n] = ' ' then - begin -// s1 := s1 + '=20'; - s1 := s1 + '_'; - if Length(s1) > 32 then - begin - if Result <> '' then - Result := Result + ' '; - Result := Result + '=?' + e + '?Q?' + s1 + '?='; - s1 := ''; - end; - end - else - s1 := s1 + s[n]; - if s1 <> '' then - begin - if Result <> '' then - Result := Result + ' '; - Result := Result + '=?' + e + '?Q?' + s1 + '?='; - end; -end; - -{==============================================================================} - -function NeedInline(const Value: AnsiString): boolean; -var - n: Integer; -begin - Result := False; - for n := 1 to Length(Value) do - if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then - begin - Result := True; - Break; - end; -end; - -{==============================================================================} - -function InlineCodeEx(const Value: string; FromCP: TMimeChar): string; -var - c: TMimeChar; -begin - if NeedInline(Value) then - begin - c := IdealCharsetCoding(Value, FromCP, IdealCharsets); - Result := InlineEncode(Value, FromCP, c); - end - else - Result := Value; -end; - -{==============================================================================} - -function InlineCode(const Value: string): string; -begin - Result := InlineCodeEx(Value, GetCurCP); -end; - -{==============================================================================} - -function InlineEmailEx(const Value: string; FromCP: TMimeChar): string; -var - sd, se: string; -begin - sd := GetEmailDesc(Value); - se := GetEmailAddr(Value); - if sd = '' then - Result := se - else - Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>'; -end; - -{==============================================================================} - -function InlineEmail(const Value: string): string; -begin - Result := InlineEmailEx(Value, GetCurCP); -end; - -end. diff --git a/addons/synapse/mimemess.pas b/addons/synapse/mimemess.pas deleted file mode 100644 index 261c942..0000000 --- a/addons/synapse/mimemess.pas +++ /dev/null @@ -1,824 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.005.002 | -|==============================================================================| -| Content: MIME message object | -|==============================================================================| -| Copyright (c)1999-2006, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2006. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM From distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(MIME message handling) -Classes for easy handling with e-mail message. -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -unit mimemess; - -interface - -uses - Classes, SysUtils, - mimepart, synachar, synautil, mimeinln; - -type - - {:Possible values for message priority} - TMessPriority = (MP_unknown, MP_low, MP_normal, MP_high); - - {:@abstract(Object for basic e-mail header fields.)} - TMessHeader = class(TObject) - private - FFrom: string; - FToList: TStringList; - FCCList: TStringList; - FSubject: string; - FOrganization: string; - FCustomHeaders: TStringList; - FDate: TDateTime; - FXMailer: string; - FCharsetCode: TMimeChar; - FReplyTo: string; - FMessageID: string; - FPriority: TMessPriority; - Fpri: TMessPriority; - Fxpri: TMessPriority; - Fxmspri: TMessPriority; - protected - function ParsePriority(value: string): TMessPriority; - function DecodeHeader(value: string): boolean; virtual; - public - constructor Create; virtual; - destructor Destroy; override; - - {:Clears all data fields.} - procedure Clear; virtual; - - {Add headers from from this object to Value.} - procedure EncodeHeaders(const Value: TStrings); virtual; - - {:Parse header from Value to this object.} - procedure DecodeHeaders(const Value: TStrings); - - {:Try find specific header in CustomHeader. Search is case insensitive. - This is good for reading any non-parsed header.} - function FindHeader(Value: string): string; - - {:Try find specific headers in CustomHeader. This metod is for repeatly used - headers like 'received' header, etc. Search is case insensitive. - This is good for reading ano non-parsed header.} - procedure FindHeaderList(Value: string; const HeaderList: TStrings); - published - {:Sender of message.} - property From: string read FFrom Write FFrom; - - {:Stringlist with receivers of message. (one per line)} - property ToList: TStringList read FToList; - - {:Stringlist with Carbon Copy receivers of message. (one per line)} - property CCList: TStringList read FCCList; - - {:Subject of message.} - property Subject: string read FSubject Write FSubject; - - {:Organization string.} - property Organization: string read FOrganization Write FOrganization; - - {:After decoding contains all headers lines witch not have parsed to any - other structures in this object. It mean: this conatins all other headers - except: - - X-MAILER, FROM, SUBJECT, ORGANIZATION, TO, CC, DATE, MIME-VERSION, - CONTENT-TYPE, CONTENT-DESCRIPTION, CONTENT-DISPOSITION, CONTENT-ID, - CONTENT-TRANSFER-ENCODING, REPLY-TO, MESSAGE-ID, X-MSMAIL-PRIORITY, - X-PRIORITY, PRIORITY - - When you encode headers, all this lines is added as headers. Be carefull - for duplicites!} - property CustomHeaders: TStringList read FCustomHeaders; - - {:Date and time of message.} - property Date: TDateTime read FDate Write FDate; - - {:Mailer identification.} - property XMailer: string read FXMailer Write FXMailer; - - {:Address for replies} - property ReplyTo: string read FReplyTo Write FReplyTo; - - {:message indetifier} - property MessageID: string read FMessageID Write FMessageID; - - {:message priority} - property Priority: TMessPriority read FPriority Write FPriority; - - {:Specify base charset. By default is used system charset.} - property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode; - end; - - TMessHeaderClass = class of TMessHeader; - - {:@abstract(Object for handling of e-mail message.)} - TMimeMess = class(TObject) - private - FMessagePart: TMimePart; - FLines: TStringList; - FHeader: TMessHeader; - public - constructor Create; - {:create this object and assign your own descendant of @link(TMessHeader) - object to @link(header) property. So, you can create your own message - headers parser and use it by this object.} - constructor CreateAltHeaders(HeadClass: TMessHeaderClass); - destructor Destroy; override; - - {:Reset component to default state.} - procedure Clear; virtual; - - {:Add MIME part as subpart of PartParent. If you need set root MIME part, - then set as PartParent @NIL value. If you need set more then one subpart, - you must have PartParent of multipart type!} - function AddPart(const PartParent: TMimePart): TMimePart; - - {:Add MIME part as subpart of PartParent. If you need set root MIME part, - then set as PartParent @NIL value. If you need set more then 1 subpart, you - must have PartParent of multipart type! - - This part is marked as multipart with secondary MIME type specified by - MultipartType parameter. (typical value is 'mixed') - - This part can be used as PartParent for another parts (include next - multipart). If you need only one part, then you not need Multipart part.} - function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart; - - {:Add MIME part as subpart of PartParent. If you need set root MIME part, - then set as PartParent @NIL value. If you need set more then 1 subpart, you - must have PartParent of multipart type! - - After creation of part set type to text part and set all necessary - properties. Content of part is readed from value stringlist.} - function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart; - - {:Add MIME part as subpart of PartParent. If you need set root MIME part, - then set as PartParent @NIL value. If you need set more then 1 subpart, you - must have PartParent of multipart type! - - After creation of part set type to text part and set all necessary - properties. Content of part is readed from value stringlist. You can select - your charset and your encoding type. If Raw is @true, then it not doing - charset conversion!} - function AddPartTextEx(const Value: TStrings; const PartParent: TMimePart; - PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart; - - {:Add MIME part as subpart of PartParent. If you need set root MIME part, - then set as PartParent @NIL value. If you need set more then 1 subpart, you - must have PartParent of multipart type! - - After creation of part set type to text part to HTML type and set all - necessary properties. Content of HTML part is readed from Value stringlist.} - function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart; - - {:Same as @link(AddPartText), but content is readed from file} - function AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; - - {:Same as @link(AddPartHTML), but content is readed from file} - function AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; - - {:Add MIME part as subpart of PartParent. If you need set root MIME part, - then set as PartParent @NIL value. If you need set more then 1 subpart, - you must have PartParent of multipart type! - - After creation of part set type to binary and set all necessary properties. - MIME primary and secondary types defined automaticly by filename extension. - Content of binary part is readed from Stream. This binary part is encoded - as file attachment.} - function AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart; - - {:Same as @link(AddPartBinary), but content is readed from file} - function AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart; - - {:Add MIME part as subpart of PartParent. If you need set root MIME part, - then set as PartParent @NIL value. If you need set more then 1 subpart, you - must have PartParent of multipart type! - - After creation of part set type to binary and set all necessary properties. - MIME primary and secondary types defined automaticly by filename extension. - Content of binary part is readed from Stream. - - This binary part is encoded as inline data with given Conten ID (cid). - Content ID can be used as reference ID in HTML source in HTML part.} - function AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart; - - {:Same as @link(AddPartHTMLBinary), but content is readed from file} - function AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart; - - {:Add MIME part as subpart of PartParent. If you need set root MIME part, - then set as PartParent @NIL value. If you need set more then 1 subpart, you - must have PartParent of multipart type! - - After creation of part set type to message and set all necessary properties. - MIME primary and secondary types are setted to 'message/rfc822'. - Content of raw RFC-822 message is readed from Stream.} - function AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart; - - {:Same as @link(AddPartMess), but content is readed from file} - function AddPartMessFromFile(const FileName: string; const PartParent: TMimePart): TMimepart; - - {:Compose message from @link(MessagePart) to @link(Lines). Headers from - @link(Header) object is added also.} - procedure EncodeMessage; - - {:Decode message from @link(Lines) to @link(MessagePart). Massage headers - are parsed into @link(Header) object.} - procedure DecodeMessage; - published - {:@link(TMimePart) object with decoded MIME message. This object can handle - any number of nested @link(TMimePart) objects itself. It is used for handle - any tree of MIME subparts.} - property MessagePart: TMimePart read FMessagePart; - - {:Raw MIME encoded message.} - property Lines: TStringList read FLines; - - {:Object for e-mail header fields. This object is created automaticly. - Do not free this object!} - property Header: TMessHeader read FHeader; - end; - -implementation - -{==============================================================================} - -constructor TMessHeader.Create; -begin - inherited Create; - FToList := TStringList.Create; - FCCList := TStringList.Create; - FCustomHeaders := TStringList.Create; - FCharsetCode := GetCurCP; -end; - -destructor TMessHeader.Destroy; -begin - FCustomHeaders.Free; - FCCList.Free; - FToList.Free; - inherited Destroy; -end; - -{==============================================================================} - -procedure TMessHeader.Clear; -begin - FFrom := ''; - FToList.Clear; - FCCList.Clear; - FSubject := ''; - FOrganization := ''; - FCustomHeaders.Clear; - FDate := 0; - FXMailer := ''; - FReplyTo := ''; - FMessageID := ''; - FPriority := MP_unknown; -end; - -procedure TMessHeader.EncodeHeaders(const Value: TStrings); -var - n: Integer; - s: string; -begin - if FDate = 0 then - FDate := Now; - for n := FCustomHeaders.Count - 1 downto 0 do - if FCustomHeaders[n] <> '' then - Value.Insert(0, FCustomHeaders[n]); - if FPriority <> MP_unknown then - case FPriority of - MP_high: - begin - Value.Insert(0, 'X-MSMAIL-Priority: High'); - Value.Insert(0, 'X-Priority: 1'); - Value.Insert(0, 'Priority: urgent'); - end; - MP_low: - begin - Value.Insert(0, 'X-MSMAIL-Priority: low'); - Value.Insert(0, 'X-Priority: 5'); - Value.Insert(0, 'Priority: non-urgent'); - end; - end; - if FReplyTo <> '' then - Value.Insert(0, 'Reply-To: ' + GetEmailAddr(FReplyTo)); - if FMessageID <> '' then - Value.Insert(0, 'Message-ID: <' + trim(FMessageID) + '>'); - if FXMailer = '' then - Value.Insert(0, 'X-mailer: Synapse - Pascal TCP/IP library by Lukas Gebauer') - else - Value.Insert(0, 'X-mailer: ' + FXMailer); - Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)'); - if FOrganization <> '' then - Value.Insert(0, 'Organization: ' + InlineCodeEx(FOrganization, FCharsetCode)); - s := ''; - for n := 0 to FCCList.Count - 1 do - if s = '' then - s := InlineEmailEx(FCCList[n], FCharsetCode) - else - s := s + ', ' + InlineEmailEx(FCCList[n], FCharsetCode); - if s <> '' then - Value.Insert(0, 'CC: ' + s); - Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate)); - if FSubject <> '' then - Value.Insert(0, 'Subject: ' + InlineCodeEx(FSubject, FCharsetCode)); - s := ''; - for n := 0 to FToList.Count - 1 do - if s = '' then - s := InlineEmailEx(FToList[n], FCharsetCode) - else - s := s + ', ' + InlineEmailEx(FToList[n], FCharsetCode); - if s <> '' then - Value.Insert(0, 'To: ' + s); - Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode)); -end; - -function TMessHeader.ParsePriority(value: string): TMessPriority; -var - s: string; - x: integer; -begin - Result := MP_unknown; - s := Trim(separateright(value, ':')); - s := Separateleft(s, ' '); - x := StrToIntDef(s, -1); - if x >= 0 then - case x of - 1, 2: - Result := MP_High; - 3: - Result := MP_Normal; - 4, 5: - Result := MP_Low; - end - else - begin - s := lowercase(s); - if (s = 'urgent') or (s = 'high') or (s = 'highest') then - Result := MP_High; - if (s = 'normal') or (s = 'medium') then - Result := MP_Normal; - if (s = 'low') or (s = 'lowest') - or (s = 'no-priority') or (s = 'non-urgent') then - Result := MP_Low; - end; -end; - -function TMessHeader.DecodeHeader(value: string): boolean; -var - s, t: string; - cp: TMimeChar; -begin - Result := True; - cp := FCharsetCode; - s := uppercase(value); - if Pos('X-MAILER:', s) = 1 then - begin - FXMailer := Trim(SeparateRight(Value, ':')); - Exit; - end; - if Pos('FROM:', s) = 1 then - begin - FFrom := InlineDecode(Trim(SeparateRight(Value, ':')), cp); - Exit; - end; - if Pos('SUBJECT:', s) = 1 then - begin - FSubject := InlineDecode(Trim(SeparateRight(Value, ':')), cp); - Exit; - end; - if Pos('ORGANIZATION:', s) = 1 then - begin - FOrganization := InlineDecode(Trim(SeparateRight(Value, ':')), cp); - Exit; - end; - if Pos('TO:', s) = 1 then - begin - s := Trim(SeparateRight(Value, ':')); - repeat - t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp); - if t <> '' then - FToList.Add(t); - until s = ''; - Exit; - end; - if Pos('CC:', s) = 1 then - begin - s := Trim(SeparateRight(Value, ':')); - repeat - t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp); - if t <> '' then - FCCList.Add(t); - until s = ''; - Exit; - end; - if Pos('DATE:', s) = 1 then - begin - FDate := DecodeRfcDateTime(Trim(SeparateRight(Value, ':'))); - Exit; - end; - if Pos('REPLY-TO:', s) = 1 then - begin - FReplyTo := InlineDecode(Trim(SeparateRight(Value, ':')), cp); - Exit; - end; - if Pos('MESSAGE-ID:', s) = 1 then - begin - FMessageID := GetEmailAddr(Trim(SeparateRight(Value, ':'))); - Exit; - end; - if Pos('PRIORITY:', s) = 1 then - begin - FPri := ParsePriority(value); - Exit; - end; - if Pos('X-PRIORITY:', s) = 1 then - begin - FXPri := ParsePriority(value); - Exit; - end; - if Pos('X-MSMAIL-PRIORITY:', s) = 1 then - begin - FXmsPri := ParsePriority(value); - Exit; - end; - if Pos('MIME-VERSION:', s) = 1 then - Exit; - if Pos('CONTENT-TYPE:', s) = 1 then - Exit; - if Pos('CONTENT-DESCRIPTION:', s) = 1 then - Exit; - if Pos('CONTENT-DISPOSITION:', s) = 1 then - Exit; - if Pos('CONTENT-ID:', s) = 1 then - Exit; - if Pos('CONTENT-TRANSFER-ENCODING:', s) = 1 then - Exit; - Result := False; -end; - -procedure TMessHeader.DecodeHeaders(const Value: TStrings); -var - s: string; - x: Integer; -begin - Clear; - Fpri := MP_unknown; - Fxpri := MP_unknown; - Fxmspri := MP_unknown; - x := 0; - while Value.Count > x do - begin - s := NormalizeHeader(Value, x); - if s = '' then - Break; - if not DecodeHeader(s) then - FCustomHeaders.Add(s); - end; - if Fpri <> MP_unknown then - FPriority := Fpri - else - if Fxpri <> MP_unknown then - FPriority := Fxpri - else - if Fxmspri <> MP_unknown then - FPriority := Fxmspri -end; - -function TMessHeader.FindHeader(Value: string): string; -var - n: integer; -begin - Result := ''; - for n := 0 to FCustomHeaders.Count - 1 do - if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then - begin - Result := Trim(SeparateRight(FCustomHeaders[n], ':')); - break; - end; -end; - -procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStrings); -var - n: integer; -begin - HeaderList.Clear; - for n := 0 to FCustomHeaders.Count - 1 do - if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then - begin - HeaderList.Add(Trim(SeparateRight(FCustomHeaders[n], ':'))); - end; -end; - -{==============================================================================} - -constructor TMimeMess.Create; -begin - CreateAltHeaders(TMessHeader); -end; - -constructor TMimeMess.CreateAltHeaders(HeadClass: TMessHeaderClass); -begin - inherited Create; - FMessagePart := TMimePart.Create; - FLines := TStringList.Create; - FHeader := HeadClass.Create; -end; - -destructor TMimeMess.Destroy; -begin - FMessagePart.Free; - FHeader.Free; - FLines.Free; - inherited Destroy; -end; - -{==============================================================================} - -procedure TMimeMess.Clear; -begin - FMessagePart.Clear; - FLines.Clear; - FHeader.Clear; -end; - -{==============================================================================} - -function TMimeMess.AddPart(const PartParent: TMimePart): TMimePart; -begin - if PartParent = nil then - Result := FMessagePart - else - Result := PartParent.AddSubPart; - Result.Clear; -end; - -{==============================================================================} - -function TMimeMess.AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart; -begin - Result := AddPart(PartParent); - with Result do - begin - Primary := 'Multipart'; - Secondary := MultipartType; - Description := 'Multipart message'; - Boundary := GenerateBoundary; - EncodePartHeader; - end; -end; - -function TMimeMess.AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart; -begin - Result := AddPart(PartParent); - with Result do - begin - Value.SaveToStream(DecodedLines); - Primary := 'text'; - Secondary := 'plain'; - Description := 'Message text'; - Disposition := 'inline'; - CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, IdealCharsets); - EncodingCode := ME_QUOTED_PRINTABLE; - EncodePart; - EncodePartHeader; - end; -end; - -function TMimeMess.AddPartTextEx(const Value: TStrings; const PartParent: TMimePart; - PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart; -begin - Result := AddPart(PartParent); - with Result do - begin - Value.SaveToStream(DecodedLines); - Primary := 'text'; - Secondary := 'plain'; - Description := 'Message text'; - Disposition := 'inline'; - CharsetCode := PartCharset; - EncodingCode := PartEncoding; - ConvertCharset := not Raw; - EncodePart; - EncodePartHeader; - end; -end; - -function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart; -begin - Result := AddPart(PartParent); - with Result do - begin - Value.SaveToStream(DecodedLines); - Primary := 'text'; - Secondary := 'html'; - Description := 'HTML text'; - Disposition := 'inline'; - CharsetCode := UTF_8; - EncodingCode := ME_QUOTED_PRINTABLE; - EncodePart; - EncodePartHeader; - end; -end; - -function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; -var - tmp: TStrings; -begin - tmp := TStringList.Create; - try - tmp.LoadFromFile(FileName); - Result := AddPartText(tmp, PartParent); - Finally - tmp.Free; - end; -end; - -function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; -var - tmp: TStrings; -begin - tmp := TStringList.Create; - try - tmp.LoadFromFile(FileName); - Result := AddPartHTML(tmp, PartParent); - Finally - tmp.Free; - end; -end; - -function TMimeMess.AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart; -begin - Result := AddPart(PartParent); - Result.DecodedLines.LoadFromStream(Stream); - Result.MimeTypeFromExt(FileName); - Result.Description := 'Attached file: ' + FileName; - Result.Disposition := 'attachment'; - Result.FileName := FileName; - Result.EncodingCode := ME_BASE64; - Result.EncodePart; - Result.EncodePartHeader; -end; - -function TMimeMess.AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart; -var - tmp: TMemoryStream; -begin - tmp := TMemoryStream.Create; - try - tmp.LoadFromFile(FileName); - Result := AddPartBinary(tmp, ExtractFileName(FileName), PartParent); - finally - tmp.Free; - end; -end; - -function TMimeMess.AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart; -begin - Result := AddPart(PartParent); - Result.DecodedLines.LoadFromStream(Stream); - Result.MimeTypeFromExt(FileName); - Result.Description := 'Included file: ' + FileName; - Result.Disposition := 'inline'; - Result.ContentID := Cid; - Result.FileName := FileName; - Result.EncodingCode := ME_BASE64; - Result.EncodePart; - Result.EncodePartHeader; -end; - -function TMimeMess.AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart; -var - tmp: TMemoryStream; -begin - tmp := TMemoryStream.Create; - try - tmp.LoadFromFile(FileName); - Result :=AddPartHTMLBinary(tmp, ExtractFileName(FileName), Cid, PartParent); - finally - tmp.Free; - end; -end; - -function TMimeMess.AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart; -var - part: Tmimepart; -begin - Result := AddPart(PartParent); - part := AddPart(result); - part.lines.addstrings(Value); - part.DecomposeParts; - with Result do - begin - Primary := 'message'; - Secondary := 'rfc822'; - Description := 'E-mail Message'; - EncodePart; - EncodePartHeader; - end; -end; - -function TMimeMess.AddPartMessFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; -var - tmp: TStrings; -begin - tmp := TStringList.Create; - try - tmp.LoadFromFile(FileName); - Result := AddPartMess(tmp, PartParent); - Finally - tmp.Free; - end; -end; - -{==============================================================================} - -procedure TMimeMess.EncodeMessage; -var - l: TStringList; - x: integer; -begin - //merge headers from THeaders and header field from MessagePart - l := TStringList.Create; - try - FHeader.EncodeHeaders(l); - x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers); - if x >= 0 then - l.add(FMessagePart.Headers[x]); - x := IndexByBegin('CONTENT-DESCRIPTION', FMessagePart.Headers); - if x >= 0 then - l.add(FMessagePart.Headers[x]); - x := IndexByBegin('CONTENT-DISPOSITION', FMessagePart.Headers); - if x >= 0 then - l.add(FMessagePart.Headers[x]); - x := IndexByBegin('CONTENT-ID', FMessagePart.Headers); - if x >= 0 then - l.add(FMessagePart.Headers[x]); - x := IndexByBegin('CONTENT-TRANSFER-ENCODING', FMessagePart.Headers); - if x >= 0 then - l.add(FMessagePart.Headers[x]); - FMessagePart.Headers.Assign(l); - finally - l.Free; - end; - FMessagePart.ComposeParts; - FLines.Assign(FMessagePart.Lines); -end; - -{==============================================================================} - -procedure TMimeMess.DecodeMessage; -begin - FHeader.Clear; - FHeader.DecodeHeaders(FLines); - FMessagePart.Lines.Assign(FLines); - FMessagePart.DecomposeParts; -end; - -end. diff --git a/addons/synapse/mimepart.pas b/addons/synapse/mimepart.pas deleted file mode 100644 index 93e0b91..0000000 --- a/addons/synapse/mimepart.pas +++ /dev/null @@ -1,1094 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.008.000 | -|==============================================================================| -| Content: MIME support procedures and functions | -|==============================================================================| -| Copyright (c)1999-2008, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2008. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(MIME part handling) -Handling with MIME parts. - -Used RFC: RFC-2045 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} -{$Q-} -{$R-} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit mimepart; - -interface - -uses - SysUtils, Classes, - synafpc, - synachar, synacode, synautil, mimeinln; - -type - - TMimePart = class; - - {:@abstract(Procedural type for @link(TMimepart.Walkpart) hook). This hook is used for - easy walking through MIME subparts.} - THookWalkPart = procedure(const Sender: TMimePart) of object; - - {:The four types of MIME parts. (textual, multipart, message or any other - binary data.)} - TMimePrimary = (MP_TEXT, MP_MULTIPART, MP_MESSAGE, MP_BINARY); - - {:The various types of possible part encodings.} - TMimeEncoding = (ME_7BIT, ME_8BIT, ME_QUOTED_PRINTABLE, - ME_BASE64, ME_UU, ME_XX); - - {:@abstract(Object for working with parts of MIME e-mail.) - Each TMimePart object can handle any number of nested subparts as new - TMimepart objects. It can handle any tree hierarchy structure of nested MIME - subparts itself. - - Basic tasks are: - - Decoding of MIME message: - - store message into Lines property - - call DecomposeParts. Now you have decomposed MIME parts in all nested levels! - - now you can explore all properties and subparts. (You can use WalkPart method) - - if you need decode part, call DecodePart. - - Encoding of MIME message: - - - if you need multipart message, you must create subpart by AddSubPart. - - set all properties of all parts. - - set content of part into DecodedLines stream - - encode this stream by EncodePart. - - compose full message by ComposeParts. (it build full MIME message from all subparts. Do not call this method for each subpart! It is needed on root part!) - - encoded MIME message is stored in Lines property. - } - TMimePart = class(TObject) - private - FPrimary: string; - FPrimaryCode: TMimePrimary; - FSecondary: string; - FEncoding: string; - FEncodingCode: TMimeEncoding; - FDefaultCharset: string; - FCharset: string; - FCharsetCode: TMimeChar; - FTargetCharset: TMimeChar; - FDescription: string; - FDisposition: string; - FContentID: string; - FBoundary: string; - FFileName: string; - FLines: TStringList; - FPartBody: TStringList; - FHeaders: TStringList; - FPrePart: TStringList; - FPostPart: TStringList; - FDecodedLines: TMemoryStream; - FSubParts: TList; - FOnWalkPart: THookWalkPart; - FMaxLineLength: integer; - FSubLevel: integer; - FMaxSubLevel: integer; - FAttachInside: boolean; - FConvertCharset: Boolean; - FForcedHTMLConvert: Boolean; - procedure SetPrimary(Value: string); - procedure SetEncoding(Value: string); - procedure SetCharset(Value: string); - function IsUUcode(Value: string): boolean; - public - constructor Create; - destructor Destroy; override; - - {:Assign content of another object to this object. (Only this part, - not subparts!)} - procedure Assign(Value: TMimePart); - - {:Assign content of another object to this object. (With all subparts!)} - procedure AssignSubParts(Value: TMimePart); - - {:Clear all data values to default values. It also call @link(ClearSubparts).} - procedure Clear; - - {:Decode Mime part from @link(Lines) to @link(DecodedLines).} - procedure DecodePart; - - {:Parse header lines from Headers property into another properties.} - procedure DecodePartHeader; - - {:Encode mime part from @link(DecodedLines) to @link(Lines) and build mime - headers.} - procedure EncodePart; - - {:Build header lines in Headers property from another properties.} - procedure EncodePartHeader; - - {:generate primary and secondary mime type from filename extension in value. - If type not recognised, it return 'Application/octet-string' type.} - procedure MimeTypeFromExt(Value: string); - - {:Return number of decomposed subparts. (On this level! Each of this - subparts can hold any number of their own nested subparts!)} - function GetSubPartCount: integer; - - {:Get nested subpart object as new TMimePart. For getting maximum possible - index you can use @link(GetSubPartCount) method.} - function GetSubPart(index: integer): TMimePart; - - {:delete subpart on given index.} - procedure DeleteSubPart(index: integer); - - {:Clear and destroy all subpart TMimePart objects.} - procedure ClearSubParts; - - {:Add and create new subpart.} - function AddSubPart: TMimePart; - - {:E-mail message in @link(Lines) property is parsed into this object. - E-mail headers are stored in @link(Headers) property and is parsed into - another properties automaticly. Not need call @link(DecodePartHeader)! - Content of message (part) is stored into @link(PartBody) property. This - part is in undecoded form! If you need decode it, then you must call - @link(DecodePart) method by your hands. Lot of another properties is filled - also. - - Decoding of parts you must call separately due performance reasons. (Not - needed to decode all parts in all reasons.) - - For each MIME subpart is created new TMimepart object (accessible via - method @link(GetSubPart)).} - procedure DecomposeParts; - - {:This part and all subparts is composed into one MIME message stored in - @link(Lines) property.} - procedure ComposeParts; - - {:By calling this method is called @link(OnWalkPart) event for each part - and their subparts. It is very good for calling some code for each part in - MIME message} - procedure WalkPart; - - {:Return @true when is possible create next subpart. (@link(maxSublevel) - is still not reached)} - function CanSubPart: boolean; - published - {:Primary Mime type of part. (i.e. 'application') Writing to this property - automaticly generate value of @link(PrimaryCode).} - property Primary: string read FPrimary write SetPrimary; - - {:String representation of used Mime encoding in part. (i.e. 'base64') - Writing to this property automaticly generate value of @link(EncodingCode).} - property Encoding: string read FEncoding write SetEncoding; - - {:String representation of used Mime charset in part. (i.e. 'iso-8859-1') - Writing to this property automaticly generate value of @link(CharsetCode). - Charset is used only for text parts.} - property Charset: string read FCharset write SetCharset; - - {:Define default charset for decoding text MIME parts without charset - specification. Default value is 'ISO-8859-1' by RCF documents. - But Microsoft Outlook use windows codings as default. This property allows - properly decode textual parts from some broken versions of Microsoft - Outlook. (this is bad software!)} - property DefaultCharset: string read FDefaultCharset write FDefaultCharset; - - {:Decoded primary type. Possible values are: MP_TEXT, MP_MULTIPART, - MP_MESSAGE and MP_BINARY. If type not recognised, result is MP_BINARY.} - property PrimaryCode: TMimePrimary read FPrimaryCode Write FPrimaryCode; - - {:Decoded encoding type. Possible values are: ME_7BIT, ME_8BIT, - ME_QUOTED_PRINTABLE and ME_BASE64. If type not recognised, result is - ME_7BIT.} - property EncodingCode: TMimeEncoding read FEncodingCode Write FEncodingCode; - - {:Decoded charset type. Possible values are defined in @link(SynaChar) unit.} - property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode; - - {:System charset type. Default value is charset used by default in your - operating system.} - property TargetCharset: TMimeChar read FTargetCharset Write FTargetCharset; - - {:If @true, then do internal charset translation of part content between @link(CharsetCode) - and @link(TargetCharset)} - property ConvertCharset: Boolean read FConvertCharset Write FConvertCharset; - - {:If @true, then allways do internal charset translation of HTML parts - by MIME even it have their own charset in META tag. Default is @false.} - property ForcedHTMLConvert: Boolean read FForcedHTMLConvert Write FForcedHTMLConvert; - - {:Secondary Mime type of part. (i.e. 'mixed')} - property Secondary: string read FSecondary Write FSecondary; - - {:Description of Mime part.} - property Description: string read FDescription Write FDescription; - - {:Value of content disposition field. (i.e. 'inline' or 'attachment')} - property Disposition: string read FDisposition Write FDisposition; - - {:Content ID.} - property ContentID: string read FContentID Write FContentID; - - {:Boundary delimiter of multipart Mime part. Used only in multipart part.} - property Boundary: string read FBoundary Write FBoundary; - - {:Filename of file in binary part.} - property FileName: string read FFileName Write FFileName; - - {:String list with lines contains mime part (It can be a full message).} - property Lines: TStringList read FLines; - - {:Encoded form of MIME part data.} - property PartBody: TStringList read FPartBody; - - {:All header lines of MIME part.} - property Headers: TStringList read FHeaders; - - {:On multipart this contains part of message between first line of message - and first boundary.} - property PrePart: TStringList read FPrePart; - - {:On multipart this contains part of message between last boundary and end - of message.} - property PostPart: TStringList read FPostPart; - - {:Stream with decoded form of budy part.} - property DecodedLines: TMemoryStream read FDecodedLines; - - {:Show nested level in subpart tree. Value 0 means root part. 1 means - subpart from this root. etc.} - property SubLevel: integer read FSubLevel write FSubLevel; - - {:Specify maximum sublevel value for decomposing.} - property MaxSubLevel: integer read FMaxSubLevel write FMaxSubLevel; - - {:When is @true, then this part maybe(!) have included some uuencoded binary - data.} - property AttachInside: boolean read FAttachInside; - - {:Here you can assign hook procedure for walking through all part and their - subparts.} - property OnWalkPart: THookWalkPart read FOnWalkPart write FOnWalkPart; - - {:Here you can specify maximum line length for encoding of MIME part. - If line is longer, then is splitted by standard of MIME. Correct MIME - mailers can de-split this line into original length.} - property MaxLineLength: integer read FMaxLineLength Write FMaxLineLength; - end; - -const - MaxMimeType = 25; - MimeType: array[0..MaxMimeType, 0..2] of string = - ( - ('AU', 'audio', 'basic'), - ('AVI', 'video', 'x-msvideo'), - ('BMP', 'image', 'BMP'), - ('DOC', 'application', 'MSWord'), - ('EPS', 'application', 'Postscript'), - ('GIF', 'image', 'GIF'), - ('JPEG', 'image', 'JPEG'), - ('JPG', 'image', 'JPEG'), - ('MID', 'audio', 'midi'), - ('MOV', 'video', 'quicktime'), - ('MPEG', 'video', 'MPEG'), - ('MPG', 'video', 'MPEG'), - ('MP2', 'audio', 'mpeg'), - ('MP3', 'audio', 'mpeg'), - ('PDF', 'application', 'PDF'), - ('PNG', 'image', 'PNG'), - ('PS', 'application', 'Postscript'), - ('QT', 'video', 'quicktime'), - ('RA', 'audio', 'x-realaudio'), - ('RTF', 'application', 'RTF'), - ('SND', 'audio', 'basic'), - ('TIF', 'image', 'TIFF'), - ('TIFF', 'image', 'TIFF'), - ('WAV', 'audio', 'x-wav'), - ('WPD', 'application', 'Wordperfect5.1'), - ('ZIP', 'application', 'ZIP') - ); - -{:Generates a unique boundary string.} -function GenerateBoundary: string; - -implementation - -{==============================================================================} - -constructor TMIMEPart.Create; -begin - inherited Create; - FOnWalkPart := nil; - FLines := TStringList.Create; - FPartBody := TStringList.Create; - FHeaders := TStringList.Create; - FPrePart := TStringList.Create; - FPostPart := TStringList.Create; - FDecodedLines := TMemoryStream.Create; - FSubParts := TList.Create; - FTargetCharset := GetCurCP; - //was 'US-ASCII' before, but RFC-ignorant Outlook sometimes using default - //system charset instead. - FDefaultCharset := GetIDFromCP(GetCurCP); - FMaxLineLength := 78; - FSubLevel := 0; - FMaxSubLevel := -1; - FAttachInside := false; - FConvertCharset := true; - FForcedHTMLConvert := false; -end; - -destructor TMIMEPart.Destroy; -begin - ClearSubParts; - FSubParts.Free; - FDecodedLines.Free; - FPartBody.Free; - FLines.Free; - FHeaders.Free; - FPrePart.Free; - FPostPart.Free; - inherited Destroy; -end; - -{==============================================================================} - -procedure TMIMEPart.Clear; -begin - FPrimary := ''; - FEncoding := ''; - FCharset := ''; - FPrimaryCode := MP_TEXT; - FEncodingCode := ME_7BIT; - FCharsetCode := ISO_8859_1; - FTargetCharset := GetCurCP; - FSecondary := ''; - FDisposition := ''; - FContentID := ''; - FDescription := ''; - FBoundary := ''; - FFileName := ''; - FAttachInside := False; - FPartBody.Clear; - FHeaders.Clear; - FPrePart.Clear; - FPostPart.Clear; - FDecodedLines.Clear; - FConvertCharset := true; - FForcedHTMLConvert := false; - ClearSubParts; -end; - -{==============================================================================} - -procedure TMIMEPart.Assign(Value: TMimePart); -begin - Primary := Value.Primary; - Encoding := Value.Encoding; - Charset := Value.Charset; - DefaultCharset := Value.DefaultCharset; - PrimaryCode := Value.PrimaryCode; - EncodingCode := Value.EncodingCode; - CharsetCode := Value.CharsetCode; - TargetCharset := Value.TargetCharset; - Secondary := Value.Secondary; - Description := Value.Description; - Disposition := Value.Disposition; - ContentID := Value.ContentID; - Boundary := Value.Boundary; - FileName := Value.FileName; - Lines.Assign(Value.Lines); - PartBody.Assign(Value.PartBody); - Headers.Assign(Value.Headers); - PrePart.Assign(Value.PrePart); - PostPart.Assign(Value.PostPart); - MaxLineLength := Value.MaxLineLength; - FAttachInside := Value.AttachInside; - FConvertCharset := Value.ConvertCharset; -end; - -{==============================================================================} - -procedure TMIMEPart.AssignSubParts(Value: TMimePart); -var - n: integer; - p: TMimePart; -begin - Assign(Value); - for n := 0 to Value.GetSubPartCount - 1 do - begin - p := AddSubPart; - p.AssignSubParts(Value.GetSubPart(n)); - end; -end; - -{==============================================================================} - -function TMIMEPart.GetSubPartCount: integer; -begin - Result := FSubParts.Count; -end; - -{==============================================================================} - -function TMIMEPart.GetSubPart(index: integer): TMimePart; -begin - Result := nil; - if Index < GetSubPartCount then - Result := TMimePart(FSubParts[Index]); -end; - -{==============================================================================} - -procedure TMIMEPart.DeleteSubPart(index: integer); -begin - if Index < GetSubPartCount then - begin - GetSubPart(Index).Free; - FSubParts.Delete(Index); - end; -end; - -{==============================================================================} - -procedure TMIMEPart.ClearSubParts; -var - n: integer; -begin - for n := 0 to GetSubPartCount - 1 do - TMimePart(FSubParts[n]).Free; - FSubParts.Clear; -end; - -{==============================================================================} - -function TMIMEPart.AddSubPart: TMimePart; -begin - Result := TMimePart.Create; - Result.DefaultCharset := FDefaultCharset; - FSubParts.Add(Result); - Result.SubLevel := FSubLevel + 1; - Result.MaxSubLevel := FMaxSubLevel; -end; - -{==============================================================================} - -procedure TMIMEPart.DecomposeParts; -var - x: integer; - s: string; - Mime: TMimePart; - - procedure SkipEmpty; - begin - while FLines.Count > x do - begin - s := TrimRight(FLines[x]); - if s <> '' then - Break; - Inc(x); - end; - end; - -begin - x := 0; - Clear; - //extract headers - while FLines.Count > x do - begin - s := NormalizeHeader(FLines, x); - if s = '' then - Break; - FHeaders.Add(s); - end; - DecodePartHeader; - //extract prepart - if FPrimaryCode = MP_MULTIPART then - begin - while FLines.Count > x do - begin - s := FLines[x]; - Inc(x); - if TrimRight(s) = '--' + FBoundary then - Break; - FPrePart.Add(s); - if not FAttachInside then - FAttachInside := IsUUcode(s); - end; - end; - //extract body part - if FPrimaryCode = MP_MULTIPART then - begin - repeat - if CanSubPart then - begin - Mime := AddSubPart; - while FLines.Count > x do - begin - s := FLines[x]; - Inc(x); - if Pos('--' + FBoundary, s) = 1 then - Break; - Mime.Lines.Add(s); - end; - Mime.DecomposeParts; - end - else - begin - s := FLines[x]; - Inc(x); - FPartBody.Add(s); - end; - if x >= FLines.Count then - break; - until s = '--' + FBoundary + '--'; - end; - if (FPrimaryCode = MP_MESSAGE) and CanSubPart then - begin - Mime := AddSubPart; - SkipEmpty; - while FLines.Count > x do - begin - s := TrimRight(FLines[x]); - Inc(x); - Mime.Lines.Add(s); - end; - Mime.DecomposeParts; - end - else - begin - while FLines.Count > x do - begin - s := FLines[x]; - Inc(x); - FPartBody.Add(s); - if not FAttachInside then - FAttachInside := IsUUcode(s); - end; - end; - //extract postpart - if FPrimaryCode = MP_MULTIPART then - begin - while FLines.Count > x do - begin - s := TrimRight(FLines[x]); - Inc(x); - FPostPart.Add(s); - if not FAttachInside then - FAttachInside := IsUUcode(s); - end; - end; -end; - -{==============================================================================} - -procedure TMIMEPart.ComposeParts; -var - n: integer; - mime: TMimePart; - s, t: string; - d1, d2, d3: integer; - x: integer; -begin - FLines.Clear; - //add headers - for n := 0 to FHeaders.Count -1 do - begin - s := FHeaders[n]; - repeat - if Length(s) < FMaxLineLength then - begin - t := s; - s := ''; - end - else - begin - d1 := RPosEx('; ', s, FMaxLineLength); - d2 := RPosEx(' ', s, FMaxLineLength); - d3 := RPosEx(', ', s, FMaxLineLength); - if (d1 <= 1) and (d2 <= 1) and (d3 <= 1) then - begin - x := Pos(' ', Copy(s, 2, Length(s) - 1)); - if x < 1 then - x := Length(s); - end - else - if d1 > 0 then - x := d1 - else - if d3 > 0 then - x := d3 - else - x := d2 - 1; - t := Copy(s, 1, x); - Delete(s, 1, x); - end; - Flines.Add(t); - until s = ''; - end; - - Flines.Add(''); - //add body - //if multipart - if FPrimaryCode = MP_MULTIPART then - begin - Flines.AddStrings(FPrePart); - for n := 0 to GetSubPartCount - 1 do - begin - Flines.Add('--' + FBoundary); - mime := GetSubPart(n); - mime.ComposeParts; - FLines.AddStrings(mime.Lines); - end; - Flines.Add('--' + FBoundary + '--'); - Flines.AddStrings(FPostPart); - end; - //if message - if FPrimaryCode = MP_MESSAGE then - begin - if GetSubPartCount > 0 then - begin - mime := GetSubPart(0); - mime.ComposeParts; - FLines.AddStrings(mime.Lines); - end; - end - else - //if normal part - begin - FLines.AddStrings(FPartBody); - end; -end; - -{==============================================================================} - -procedure TMIMEPart.DecodePart; -var - n: Integer; - s, t, t2: string; - b: Boolean; -begin - FDecodedLines.Clear; - case FEncodingCode of - ME_QUOTED_PRINTABLE: - s := DecodeQuotedPrintable(FPartBody.Text); - ME_BASE64: - s := DecodeBase64(FPartBody.Text); - ME_UU, ME_XX: - begin - s := ''; - for n := 0 to FPartBody.Count - 1 do - if FEncodingCode = ME_UU then - s := s + DecodeUU(FPartBody[n]) - else - s := s + DecodeXX(FPartBody[n]); - end; - else - s := FPartBody.Text; - end; - if FConvertCharset and (FPrimaryCode = MP_TEXT) then - if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then - begin - b := false; - t2 := uppercase(s); - t := SeparateLeft(t2, ''); - if length(t) <> length(s) then - begin - t := SeparateRight(t, ''); - t := ReplaceString(t, '"', ''); - t := ReplaceString(t, ' ', ''); - b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0; - end; - //workaround for shitty M$ Outlook 11 which is placing this information - //outside section - if not b then - begin - t := Copy(t2, 1, 2048); - t := ReplaceString(t, '"', ''); - t := ReplaceString(t, ' ', ''); - b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0; - end; - if not b then - s := CharsetConversion(s, FCharsetCode, FTargetCharset); - end - else - s := CharsetConversion(s, FCharsetCode, FTargetCharset); - WriteStrToStream(FDecodedLines, s); - FDecodedLines.Seek(0, soFromBeginning); -end; - -{==============================================================================} - -procedure TMIMEPart.DecodePartHeader; -var - n: integer; - s, su, fn: string; - st, st2: string; -begin - Primary := 'text'; - FSecondary := 'plain'; - FDescription := ''; - Charset := FDefaultCharset; - FFileName := ''; - //was 7bit before, but this is more compatible with RFC-ignorant outlook - Encoding := '8BIT'; - FDisposition := ''; - FContentID := ''; - fn := ''; - for n := 0 to FHeaders.Count - 1 do - if FHeaders[n] <> '' then - begin - s := FHeaders[n]; - su := UpperCase(s); - if Pos('CONTENT-TYPE:', su) = 1 then - begin - st := Trim(SeparateRight(su, ':')); - st2 := Trim(SeparateLeft(st, ';')); - Primary := Trim(SeparateLeft(st2, '/')); - FSecondary := Trim(SeparateRight(st2, '/')); - if (FSecondary = Primary) and (Pos('/', st2) < 1) then - FSecondary := ''; - case FPrimaryCode of - MP_TEXT: - begin - Charset := UpperCase(GetParameter(s, 'charset')); - FFileName := GetParameter(s, 'name'); - end; - MP_MULTIPART: - FBoundary := GetParameter(s, 'Boundary'); - MP_MESSAGE: - begin - end; - MP_BINARY: - FFileName := GetParameter(s, 'name'); - end; - end; - if Pos('CONTENT-TRANSFER-ENCODING:', su) = 1 then - Encoding := Trim(SeparateRight(su, ':')); - if Pos('CONTENT-DESCRIPTION:', su) = 1 then - FDescription := Trim(SeparateRight(s, ':')); - if Pos('CONTENT-DISPOSITION:', su) = 1 then - begin - FDisposition := SeparateRight(su, ':'); - FDisposition := Trim(SeparateLeft(FDisposition, ';')); - fn := GetParameter(s, 'FileName'); - end; - if Pos('CONTENT-ID:', su) = 1 then - FContentID := Trim(SeparateRight(s, ':')); - end; - if fn <> '' then - FFileName := fn; - FFileName := InlineDecode(FFileName, FTargetCharset); - FFileName := ExtractFileName(FFileName); -end; - -{==============================================================================} - -procedure TMIMEPart.EncodePart; -var - l: TStringList; - s, t: string; - n, x: Integer; - d1, d2: integer; -begin - if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then - Encoding := 'base64'; - l := TStringList.Create; - FPartBody.Clear; - FDecodedLines.Seek(0, soFromBeginning); - try - case FPrimaryCode of - MP_MULTIPART, MP_MESSAGE: - FPartBody.LoadFromStream(FDecodedLines); - MP_TEXT, MP_BINARY: - begin - s := ReadStrFromStream(FDecodedLines, FDecodedLines.Size); - if FConvertCharset and (FPrimaryCode = MP_TEXT) and (FEncodingCode <> ME_7BIT) then - s := GetBOM(FCharSetCode) + CharsetConversion(s, FTargetCharset, FCharsetCode); - if FEncodingCode = ME_BASE64 then - begin - x := 1; - while x <= length(s) do - begin - t := copy(s, x, 54); - x := x + length(t); - t := EncodeBase64(t); - FPartBody.Add(t); - end; - end - else - begin - if FPrimaryCode = MP_BINARY then - l.Add(s) - else - l.Text := s; - for n := 0 to l.Count - 1 do - begin - s := l[n]; - if FEncodingCode = ME_QUOTED_PRINTABLE then - begin - s := EncodeQuotedPrintable(s); - repeat - if Length(s) < FMaxLineLength then - begin - t := s; - s := ''; - end - else - begin - d1 := RPosEx('=', s, FMaxLineLength); - d2 := RPosEx(' ', s, FMaxLineLength); - if (d1 = 0) and (d2 = 0) then - x := FMaxLineLength - else - if d1 > d2 then - x := d1 - 1 - else - x := d2 - 1; - if x = 0 then - x := FMaxLineLength; - t := Copy(s, 1, x); - Delete(s, 1, x); - if s <> '' then - t := t + '='; - end; - FPartBody.Add(t); - until s = ''; - end - else - FPartBody.Add(s); - end; - if (FPrimaryCode = MP_BINARY) - and (FEncodingCode = ME_QUOTED_PRINTABLE) then - FPartBody[FPartBody.Count - 1] := FPartBody[FPartBody.Count - 1] + '='; - end; - end; - end; - finally - l.Free; - end; -end; - -{==============================================================================} - -procedure TMIMEPart.EncodePartHeader; -var - s: string; -begin - FHeaders.Clear; - if FSecondary = '' then - case FPrimaryCode of - MP_TEXT: - FSecondary := 'plain'; - MP_MULTIPART: - FSecondary := 'mixed'; - MP_MESSAGE: - FSecondary := 'rfc822'; - MP_BINARY: - FSecondary := 'octet-stream'; - end; - if FDescription <> '' then - FHeaders.Insert(0, 'Content-Description: ' + FDescription); - if FDisposition <> '' then - begin - s := ''; - if FFileName <> '' then - s := '; FileName=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"'); - FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s); - end; - if FContentID <> '' then - FHeaders.Insert(0, 'Content-ID: ' + FContentID); - - case FEncodingCode of - ME_7BIT: - s := '7bit'; - ME_8BIT: - s := '8bit'; - ME_QUOTED_PRINTABLE: - s := 'Quoted-printable'; - ME_BASE64: - s := 'Base64'; - end; - case FPrimaryCode of - MP_TEXT, - MP_BINARY: FHeaders.Insert(0, 'Content-Transfer-Encoding: ' + s); - end; - case FPrimaryCode of - MP_TEXT: - s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode); - MP_MULTIPART: - s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"'; - MP_MESSAGE, MP_BINARY: - s := FPrimary + '/' + FSecondary; - end; - if FFileName <> '' then - s := s + '; name=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"'); - FHeaders.Insert(0, 'Content-type: ' + s); -end; - -{==============================================================================} - -procedure TMIMEPart.MimeTypeFromExt(Value: string); -var - s: string; - n: Integer; -begin - Primary := ''; - FSecondary := ''; - s := UpperCase(ExtractFileExt(Value)); - if s = '' then - s := UpperCase(Value); - s := SeparateRight(s, '.'); - for n := 0 to MaxMimeType do - if MimeType[n, 0] = s then - begin - Primary := MimeType[n, 1]; - FSecondary := MimeType[n, 2]; - Break; - end; - if Primary = '' then - Primary := 'application'; - if FSecondary = '' then - FSecondary := 'octet-stream'; -end; - -{==============================================================================} - -procedure TMIMEPart.WalkPart; -var - n: integer; - m: TMimepart; -begin - if assigned(OnWalkPart) then - begin - OnWalkPart(self); - for n := 0 to GetSubPartCount - 1 do - begin - m := GetSubPart(n); - m.OnWalkPart := OnWalkPart; - m.WalkPart; - end; - end; -end; - -{==============================================================================} - -procedure TMIMEPart.SetPrimary(Value: string); -var - s: string; -begin - FPrimary := Value; - s := UpperCase(Value); - FPrimaryCode := MP_BINARY; - if Pos('TEXT', s) = 1 then - FPrimaryCode := MP_TEXT; - if Pos('MULTIPART', s) = 1 then - FPrimaryCode := MP_MULTIPART; - if Pos('MESSAGE', s) = 1 then - FPrimaryCode := MP_MESSAGE; -end; - -procedure TMIMEPart.SetEncoding(Value: string); -var - s: string; -begin - FEncoding := Value; - s := UpperCase(Value); - FEncodingCode := ME_7BIT; - if Pos('8BIT', s) = 1 then - FEncodingCode := ME_8BIT; - if Pos('QUOTED-PRINTABLE', s) = 1 then - FEncodingCode := ME_QUOTED_PRINTABLE; - if Pos('BASE64', s) = 1 then - FEncodingCode := ME_BASE64; - if Pos('X-UU', s) = 1 then - FEncodingCode := ME_UU; - if Pos('X-XX', s) = 1 then - FEncodingCode := ME_XX; -end; - -procedure TMIMEPart.SetCharset(Value: string); -begin - if value <> '' then - begin - FCharset := Value; - FCharsetCode := GetCPFromID(Value); - end; -end; - -function TMIMEPart.CanSubPart: boolean; -begin - Result := True; - if FMaxSubLevel <> -1 then - Result := FMaxSubLevel > FSubLevel; -end; - -function TMIMEPart.IsUUcode(Value: string): boolean; -begin - Value := UpperCase(Value); - Result := (pos('BEGIN ', Value) = 1) and (Trim(SeparateRight(Value, ' ')) <> ''); -end; - -{==============================================================================} - -function GenerateBoundary: string; -var - x, y: Integer; -begin - y := GetTick; - x := y; - while TickDelta(y, x) = 0 do - begin - Sleep(1); - x := GetTick; - end; - Randomize; - y := Random(MaxInt); - Result := IntToHex(x, 8) + '_' + IntToHex(y, 8) + '_Synapse_boundary'; -end; - -end. diff --git a/addons/synapse/nntpsend.pas b/addons/synapse/nntpsend.pas deleted file mode 100644 index d0c1960..0000000 --- a/addons/synapse/nntpsend.pas +++ /dev/null @@ -1,481 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.005.002 | -|==============================================================================| -| Content: NNTP client | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(NNTP client) -NNTP (network news transfer protocol) - -Used RFC: RFC-977, RFC-2980 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} - {$WARN SUSPICIOUS_TYPECAST OFF} -{$ENDIF} - -unit nntpsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil; - -const - cNNTPProtocol = '119'; - -type - - {:abstract(Implementation of Network News Transfer Protocol. - - Note: Are you missing properties for setting Username and Password? Look to - parent @link(TSynaClient) object! - - Are you missing properties for specify server address and port? Look to - parent @link(TSynaClient) too!} - TNNTPSend = class(TSynaClient) - private - FSock: TTCPBlockSocket; - FResultCode: Integer; - FResultString: string; - FData: TStringList; - FDataToSend: TStringList; - FAutoTLS: Boolean; - FFullSSL: Boolean; - FNNTPcap: TStringList; - function ReadResult: Integer; - function ReadData: boolean; - function SendData: boolean; - function Connect: Boolean; - public - constructor Create; - destructor Destroy; override; - - {:Connects to NNTP server and begin session.} - function Login: Boolean; - - {:Logout from NNTP server and terminate session.} - function Logout: Boolean; - - {:By this you can call any NNTP command.} - function DoCommand(const Command: string): boolean; - - {:by this you can call any NNTP command. This variant is used for commands - for download information from server.} - function DoCommandRead(const Command: string): boolean; - - {:by this you can call any NNTP command. This variant is used for commands - for upload information to server.} - function DoCommandWrite(const Command: string): boolean; - - {:Download full message to @link(data) property. Value can be number of - message or message-id (in brackets).} - function GetArticle(const Value: string): Boolean; - - {:Download only body of message to @link(data) property. Value can be number - of message or message-id (in brackets).} - function GetBody(const Value: string): Boolean; - - {:Download only headers of message to @link(data) property. Value can be - number of message or message-id (in brackets).} - function GetHead(const Value: string): Boolean; - - {:Get message status. Value can be number of message or message-id - (in brackets).} - function GetStat(const Value: string): Boolean; - - {:Select given group.} - function SelectGroup(const Value: string): Boolean; - - {:Tell to server 'I have mesage with given message-ID.' If server need this - message, message is uploaded to server.} - function IHave(const MessID: string): Boolean; - - {:Move message pointer to last item in group.} - function GotoLast: Boolean; - - {:Move message pointer to next item in group.} - function GotoNext: Boolean; - - {:Download to @link(data) property list of all groups on NNTP server.} - function ListGroups: Boolean; - - {:Download to @link(data) property list of all groups created after given time.} - function ListNewGroups(Since: TDateTime): Boolean; - - {:Download to @link(data) property list of message-ids in given group since - given time.} - function NewArticles(const Group: string; Since: TDateTime): Boolean; - - {:Upload new article to server. (for new messages by you)} - function PostArticle: Boolean; - - {:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP - server'.} - function SwitchToSlave: Boolean; - - {:Call NNTP XOVER command.} - function Xover(xoStart, xoEnd: string): boolean; - - {:Call STARTTLS command for upgrade connection to SSL/TLS mode.} - function StartTLS: Boolean; - - {:Try to find given capability in extension list. This list is getted after - successful login to NNTP server. If extension capability is not found, - then return is empty string.} - function FindCap(const Value: string): string; - - {:Try get list of server extensions. List is returned in @link(data) property.} - function ListExtensions: Boolean; - published - {:Result code number of last operation.} - property ResultCode: Integer read FResultCode; - - {:String description of last result code from NNTP server.} - property ResultString: string read FResultString; - - {:Readed data. (message, etc.)} - property Data: TStringList read FData; - - {:If is set to @true, then upgrade to SSL/TLS mode after login if remote - server support it.} - property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; - - {:SSL/TLS mode is used from first contact to server. Servers with full - SSL/TLS mode usualy using non-standard TCP port!} - property FullSSL: Boolean read FFullSSL Write FFullSSL; - - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TTCPBlockSocket read FSock; - end; - -implementation - -constructor TNNTPSend.Create; -begin - inherited Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FData := TStringList.Create; - FDataToSend := TStringList.Create; - FNNTPcap := TStringList.Create; - FSock.ConvertLineEnd := True; - FTimeout := 60000; - FTargetPort := cNNTPProtocol; - FAutoTLS := False; - FFullSSL := False; -end; - -destructor TNNTPSend.Destroy; -begin - FSock.Free; - FDataToSend.Free; - FData.Free; - FNNTPcap.Free; - inherited Destroy; -end; - -function TNNTPSend.ReadResult: Integer; -var - s: string; -begin - Result := 0; - FData.Clear; - s := FSock.RecvString(FTimeout); - FResultString := Copy(s, 5, Length(s) - 4); - if FSock.LastError <> 0 then - Exit; - if Length(s) >= 3 then - Result := StrToIntDef(Copy(s, 1, 3), 0); - FResultCode := Result; -end; - -function TNNTPSend.ReadData: boolean; -var - s: string; -begin - repeat - s := FSock.RecvString(FTimeout); - if s = '.' then - break; - if (s <> '') and (s[1] = '.') then - s := Copy(s, 2, Length(s) - 1); - FData.Add(s); - until FSock.LastError <> 0; - Result := FSock.LastError = 0; -end; - -function TNNTPSend.SendData: boolean; -var - s: string; - n: integer; -begin - for n := 0 to FDataToSend.Count - 1 do - begin - s := FDataToSend[n]; - if (s <> '') and (s[1] = '.') then - s := s + '.'; - FSock.SendString(s + CRLF); - if FSock.LastError <> 0 then - break; - end; - if FDataToSend.Count = 0 then - FSock.SendString(CRLF); - if FSock.LastError = 0 then - FSock.SendString('.' + CRLF); - FDataToSend.Clear; - Result := FSock.LastError = 0; -end; - -function TNNTPSend.Connect: Boolean; -begin - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError = 0 then - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError = 0 then - if FFullSSL then - FSock.SSLDoConnect; - Result := FSock.LastError = 0; -end; - -function TNNTPSend.Login: Boolean; -begin - Result := False; - FNNTPcap.Clear; - if not Connect then - Exit; - Result := (ReadResult div 100) = 2; - ListExtensions; - FNNTPcap.Assign(Fdata); - if Result then - if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then - Result := StartTLS; - if (FUsername <> '') and Result then - begin - FSock.SendString('AUTHINFO USER ' + FUsername + CRLF); - if (ReadResult div 100) = 3 then - begin - FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF); - Result := (ReadResult div 100) = 2; - end; - end; -end; - -function TNNTPSend.Logout: Boolean; -begin - FSock.SendString('QUIT' + CRLF); - Result := (ReadResult div 100) = 2; - FSock.CloseSocket; -end; - -function TNNTPSend.DoCommand(const Command: string): Boolean; -begin - FSock.SendString(Command + CRLF); - Result := (ReadResult div 100) = 2; - Result := Result and (FSock.LastError = 0); -end; - -function TNNTPSend.DoCommandRead(const Command: string): Boolean; -begin - Result := DoCommand(Command); - if Result then - begin - Result := ReadData; - Result := Result and (FSock.LastError = 0); - end; -end; - -function TNNTPSend.DoCommandWrite(const Command: string): Boolean; -var - x: integer; -begin - FDataToSend.Assign(FData); - FSock.SendString(Command + CRLF); - x := (ReadResult div 100); - if x = 3 then - begin - SendData; - x := (ReadResult div 100); - end; - Result := x = 2; - Result := Result and (FSock.LastError = 0); -end; - -function TNNTPSend.GetArticle(const Value: string): Boolean; -var - s: string; -begin - s := 'ARTICLE'; - if Value <> '' then - s := s + ' ' + Value; - Result := DoCommandRead(s); -end; - -function TNNTPSend.GetBody(const Value: string): Boolean; -var - s: string; -begin - s := 'BODY'; - if Value <> '' then - s := s + ' ' + Value; - Result := DoCommandRead(s); -end; - -function TNNTPSend.GetHead(const Value: string): Boolean; -var - s: string; -begin - s := 'HEAD'; - if Value <> '' then - s := s + ' ' + Value; - Result := DoCommandRead(s); -end; - -function TNNTPSend.GetStat(const Value: string): Boolean; -var - s: string; -begin - s := 'STAT'; - if Value <> '' then - s := s + ' ' + Value; - Result := DoCommand(s); -end; - -function TNNTPSend.SelectGroup(const Value: string): Boolean; -begin - Result := DoCommand('GROUP ' + Value); -end; - -function TNNTPSend.IHave(const MessID: string): Boolean; -begin - Result := DoCommandWrite('IHAVE ' + MessID); -end; - -function TNNTPSend.GotoLast: Boolean; -begin - Result := DoCommand('LAST'); -end; - -function TNNTPSend.GotoNext: Boolean; -begin - Result := DoCommand('NEXT'); -end; - -function TNNTPSend.ListGroups: Boolean; -begin - Result := DoCommandRead('LIST'); -end; - -function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean; -begin - Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT'); -end; - -function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean; -begin - Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT'); -end; - -function TNNTPSend.PostArticle: Boolean; -begin - Result := DoCommandWrite('POST'); -end; - -function TNNTPSend.SwitchToSlave: Boolean; -begin - Result := DoCommand('SLAVE'); -end; - -function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean; -var - s: string; -begin - s := 'XOVER ' + xoStart; - if xoEnd <> xoStart then - s := s + '-' + xoEnd; - Result := DoCommandRead(s); -end; - -function TNNTPSend.StartTLS: Boolean; -begin - Result := False; - if FindCap('STARTTLS') <> '' then - begin - if DoCommand('STARTTLS') then - begin - Fsock.SSLDoConnect; - Result := FSock.LastError = 0; - end; - end; -end; - -function TNNTPSend.ListExtensions: Boolean; -begin - Result := DoCommandRead('LIST EXTENSIONS'); -end; - -function TNNTPSend.FindCap(const Value: string): string; -var - n: Integer; - s: string; -begin - s := UpperCase(Value); - Result := ''; - for n := 0 to FNNTPcap.Count - 1 do - if Pos(s, UpperCase(FNNTPcap[n])) = 1 then - begin - Result := FNNTPcap[n]; - Break; - end; -end; - -{==============================================================================} - -end. diff --git a/addons/synapse/pingsend.pas b/addons/synapse/pingsend.pas deleted file mode 100644 index 1a4e331..0000000 --- a/addons/synapse/pingsend.pas +++ /dev/null @@ -1,720 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 004.000.002 | -|==============================================================================| -| Content: PING sender | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(ICMP PING implementation.) -Allows create PING and TRACEROUTE. Or you can diagnose your network. - -This unit using IpHlpApi (on WinXP or higher) if available. Otherwise it trying - to use RAW sockets. - -Warning: For use of RAW sockets you must have some special rights on some - systems. So, it working allways when you have administator/root rights. - Otherwise you can have problems! - -Note: This unit is NOT portable to .NET! - Use native .NET classes for Ping instead. -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$R-} -{$H+} - -{$IFDEF CIL} - Sorry, this unit is not for .NET! -{$ENDIF} -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit pingsend; - -interface - -uses - SysUtils, - synsock, blcksock, synautil, synafpc, synaip -{$IFDEF MSWINDOWS} - , windows -{$ENDIF} - ; - -const - ICMP_ECHO = 8; - ICMP_ECHOREPLY = 0; - ICMP_UNREACH = 3; - ICMP_TIME_EXCEEDED = 11; -//rfc-2292 - ICMP6_ECHO = 128; - ICMP6_ECHOREPLY = 129; - ICMP6_UNREACH = 1; - ICMP6_TIME_EXCEEDED = 3; - -type - {:List of possible ICMP reply packet types.} - TICMPError = ( - IE_NoError, - IE_Other, - IE_TTLExceed, - IE_UnreachOther, - IE_UnreachRoute, - IE_UnreachAdmin, - IE_UnreachAddr, - IE_UnreachPort - ); - - {:@abstract(Implementation of ICMP PING and ICMPv6 PING.)} - TPINGSend = class(TSynaClient) - private - FSock: TICMPBlockSocket; - FBuffer: Ansistring; - FSeq: Integer; - FId: Integer; - FPacketSize: Integer; - FPingTime: Integer; - FIcmpEcho: Byte; - FIcmpEchoReply: Byte; - FIcmpUnreach: Byte; - FReplyFrom: string; - FReplyType: byte; - FReplyCode: byte; - FReplyError: TICMPError; - FReplyErrorDesc: string; - FTTL: Byte; - Fsin: TVarSin; - function Checksum(Value: AnsiString): Word; - function Checksum6(Value: AnsiString): Word; - function ReadPacket: Boolean; - procedure TranslateError; - procedure TranslateErrorIpHlp(value: integer); - function InternalPing(const Host: string): Boolean; - function InternalPingIpHlp(const Host: string): Boolean; - function IsHostIP6(const Host: string): Boolean; - procedure GenErrorDesc; - public - {:Send ICMP ping to host and count @link(pingtime). If ping OK, result is - @true.} - function Ping(const Host: string): Boolean; - constructor Create; - destructor Destroy; override; - published - {:Size of PING packet. Default size is 32 bytes.} - property PacketSize: Integer read FPacketSize Write FPacketSize; - - {:Time between request and reply.} - property PingTime: Integer read FPingTime; - - {:From this address is sended reply for your PING request. It maybe not your - requested destination, when some error occured!} - property ReplyFrom: string read FReplyFrom; - - {:ICMP type of PING reply. Each protocol using another values! For IPv4 and - IPv6 are used different values!} - property ReplyType: byte read FReplyType; - - {:ICMP code of PING reply. Each protocol using another values! For IPv4 and - IPv6 are used different values! For protocol independent value look to - @link(ReplyError)} - property ReplyCode: byte read FReplyCode; - - {:Return type of returned ICMP message. This value is independent on used - protocol!} - property ReplyError: TICMPError read FReplyError; - - {:Return human readable description of returned packet type.} - property ReplyErrorDesc: string read FReplyErrorDesc; - - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TICMPBlockSocket read FSock; - - {:TTL value for ICMP query} - property TTL: byte read FTTL write FTTL; - end; - -{:A very useful function and example of its use would be found in the TPINGSend - object. Use it to ping to any host. If successful, returns the ping time in - milliseconds. Returns -1 if an error occurred.} -function PingHost(const Host: string): Integer; - -{:A very useful function and example of its use would be found in the TPINGSend - object. Use it to TraceRoute to any host.} -function TraceRouteHost(const Host: string): string; - -implementation - -type - {:Record for ICMP ECHO packet header.} - TIcmpEchoHeader = packed record - i_type: Byte; - i_code: Byte; - i_checkSum: Word; - i_Id: Word; - i_seq: Word; - TimeStamp: integer; - end; - - {:record used internally by TPingSend for compute checksum of ICMPv6 packet - pseudoheader.} - TICMP6Packet = packed record - in_source: TInAddr6; - in_dest: TInAddr6; - Length: integer; - free0: Byte; - free1: Byte; - free2: Byte; - proto: Byte; - end; - -{$IFDEF MSWINDOWS} -const - DLLIcmpName = 'iphlpapi.dll'; -type - TIP_OPTION_INFORMATION = record - TTL: Byte; - TOS: Byte; - Flags: Byte; - OptionsSize: Byte; - OptionsData: PAnsiChar; - end; - PIP_OPTION_INFORMATION = ^TIP_OPTION_INFORMATION; - - TICMP_ECHO_REPLY = record - Address: TInAddr; - Status: integer; - RoundTripTime: integer; - DataSize: Word; - Reserved: Word; - Data: pointer; - Options: TIP_OPTION_INFORMATION; - end; - PICMP_ECHO_REPLY = ^TICMP_ECHO_REPLY; - - TICMPV6_ECHO_REPLY = record - Address: TSockAddrIn6; - Status: integer; - RoundTripTime: integer; - end; - PICMPV6_ECHO_REPLY = ^TICMPV6_ECHO_REPLY; - - TIcmpCreateFile = function: integer; stdcall; - TIcmpCloseHandle = function(handle: integer): boolean; stdcall; - TIcmpSendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer; - ApcContext: pointer; DestinationAddress: TInAddr; RequestData: pointer; - RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION; - ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall; - TIcmp6CreateFile = function: integer; stdcall; - TIcmp6SendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer; - ApcContext: pointer; SourceAddress: PSockAddrIn6; DestinationAddress: PSockAddrIn6; - RequestData: pointer; RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION; - ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall; - -var - IcmpDllHandle: TLibHandle = 0; - IcmpHelper4: boolean = false; - IcmpHelper6: boolean = false; - IcmpCreateFile: TIcmpCreateFile = nil; - IcmpCloseHandle: TIcmpCloseHandle = nil; - IcmpSendEcho2: TIcmpSendEcho2 = nil; - Icmp6CreateFile: TIcmp6CreateFile = nil; - Icmp6SendEcho2: TIcmp6SendEcho2 = nil; -{$ENDIF} -{==============================================================================} - -constructor TPINGSend.Create; -begin - inherited Create; - FSock := TICMPBlockSocket.Create; - FSock.Owner := self; - FTimeout := 5000; - FPacketSize := 32; - FSeq := 0; - Randomize; - FTTL := 128; -end; - -destructor TPINGSend.Destroy; -begin - FSock.Free; - inherited Destroy; -end; - -function TPINGSend.ReadPacket: Boolean; -begin - FBuffer := FSock.RecvPacket(Ftimeout); - Result := FSock.LastError = 0; -end; - -procedure TPINGSend.GenErrorDesc; -begin - case FReplyError of - IE_NoError: - FReplyErrorDesc := ''; - IE_Other: - FReplyErrorDesc := 'Unknown error'; - IE_TTLExceed: - FReplyErrorDesc := 'TTL Exceeded'; - IE_UnreachOther: - FReplyErrorDesc := 'Unknown unreachable'; - IE_UnreachRoute: - FReplyErrorDesc := 'No route to destination'; - IE_UnreachAdmin: - FReplyErrorDesc := 'Administratively prohibited'; - IE_UnreachAddr: - FReplyErrorDesc := 'Address unreachable'; - IE_UnreachPort: - FReplyErrorDesc := 'Port unreachable'; - end; -end; - -function TPINGSend.IsHostIP6(const Host: string): Boolean; -var - f: integer; -begin - f := AF_UNSPEC; - if IsIp(Host) then - f := AF_INET - else - if IsIp6(Host) then - f := AF_INET6; - synsock.SetVarSin(Fsin, host, '0', f, - IPPROTO_UDP, SOCK_DGRAM, Fsock.PreferIP4); - result := Fsin.sin_family = AF_INET6; -end; - -function TPINGSend.Ping(const Host: string): Boolean; -var - b: boolean; -begin - FPingTime := -1; - FReplyFrom := ''; - FReplyType := 0; - FReplyCode := 0; - FReplyError := IE_Other; - GenErrorDesc; - FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize); -{$IFDEF MSWINDOWS} - b := IsHostIP6(host); - if not(b) and IcmpHelper4 then - result := InternalPingIpHlp(host) - else - if b and IcmpHelper6 then - result := InternalPingIpHlp(host) - else - result := InternalPing(host); -{$ELSE} - result := InternalPing(host); -{$ENDIF} -end; - -function TPINGSend.InternalPing(const Host: string): Boolean; -var - IPHeadPtr: ^TIPHeader; - IpHdrLen: Integer; - IcmpEchoHeaderPtr: ^TICMPEchoHeader; - t: Boolean; - x: cardinal; - IcmpReqHead: string; -begin - Result := False; - FSock.TTL := FTTL; - FSock.Bind(FIPInterface, cAnyPort); - FSock.Connect(Host, '0'); - if FSock.LastError <> 0 then - Exit; - FSock.SizeRecvBuffer := 60 * 1024; - if FSock.IP6used then - begin - FIcmpEcho := ICMP6_ECHO; - FIcmpEchoReply := ICMP6_ECHOREPLY; - FIcmpUnreach := ICMP6_UNREACH; - end - else - begin - FIcmpEcho := ICMP_ECHO; - FIcmpEchoReply := ICMP_ECHOREPLY; - FIcmpUnreach := ICMP_UNREACH; - end; - IcmpEchoHeaderPtr := Pointer(FBuffer); - with IcmpEchoHeaderPtr^ do - begin - i_type := FIcmpEcho; - i_code := 0; - i_CheckSum := 0; - FId := System.Random(32767); - i_Id := FId; - TimeStamp := GetTick; - Inc(FSeq); - i_Seq := FSeq; - if fSock.IP6used then - i_CheckSum := CheckSum6(FBuffer) - else - i_CheckSum := CheckSum(FBuffer); - end; - FSock.SendString(FBuffer); - // remember first 8 bytes of ICMP packet - IcmpReqHead := Copy(FBuffer, 1, 8); - x := GetTick; - repeat - t := ReadPacket; - if not t then - break; - if fSock.IP6used then - begin -{$IFNDEF MSWINDOWS} - IcmpEchoHeaderPtr := Pointer(FBuffer); -{$ELSE} -//WinXP SP1 with networking update doing this think by another way ;-O -// FBuffer := StringOfChar(#0, 4) + FBuffer; - IcmpEchoHeaderPtr := Pointer(FBuffer); -// IcmpEchoHeaderPtr^.i_type := FIcmpEchoReply; -{$ENDIF} - end - else - begin - IPHeadPtr := Pointer(FBuffer); - IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4; - IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1]; - end; - //check for timeout - if TickDelta(x, GetTick) > FTimeout then - begin - t := false; - Break; - end; - //it discard sometimes possible 'echoes' of previosly sended packet - //or other unwanted ICMP packets... - until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho) - and ((IcmpEchoHeaderPtr^.i_id = FId) - or (Pos(IcmpReqHead, FBuffer) > 0)); - if t then - begin - FPingTime := TickDelta(x, GetTick); - FReplyFrom := FSock.GetRemoteSinIP; - FReplyType := IcmpEchoHeaderPtr^.i_type; - FReplyCode := IcmpEchoHeaderPtr^.i_code; - TranslateError; - Result := True; - end; -end; - -function TPINGSend.Checksum(Value: AnsiString): Word; -var - CkSum: integer; - Num, Remain: Integer; - n, i: Integer; -begin - Num := Length(Value) div 2; - Remain := Length(Value) mod 2; - CkSum := 0; - i := 1; - for n := 0 to Num - 1 do - begin - CkSum := CkSum + Synsock.HtoNs(DecodeInt(Value, i)); - inc(i, 2); - end; - if Remain <> 0 then - CkSum := CkSum + Ord(Value[Length(Value)]); - CkSum := (CkSum shr 16) + (CkSum and $FFFF); - CkSum := CkSum + (CkSum shr 16); - Result := Word(not CkSum); -end; - -function TPINGSend.Checksum6(Value: AnsiString): Word; -const - IOC_OUT = $40000000; - IOC_IN = $80000000; - IOC_INOUT = (IOC_IN or IOC_OUT); - IOC_WS2 = $08000000; - SIO_ROUTING_INTERFACE_QUERY = 20 or IOC_WS2 or IOC_INOUT; -var - ICMP6Ptr: ^TICMP6Packet; - s: AnsiString; - b: integer; - ip6: TSockAddrIn6; - x: integer; -begin - Result := 0; -{$IFDEF MSWINDOWS} - s := StringOfChar(#0, SizeOf(TICMP6Packet)) + Value; - ICMP6Ptr := Pointer(s); - x := synsock.WSAIoctl(FSock.Socket, SIO_ROUTING_INTERFACE_QUERY, - @FSock.RemoteSin, SizeOf(FSock.RemoteSin), - @ip6, SizeOf(ip6), @b, nil, nil); - if x <> -1 then - ICMP6Ptr^.in_dest := ip6.sin6_addr - else - ICMP6Ptr^.in_dest := FSock.LocalSin.sin6_addr; - ICMP6Ptr^.in_source := FSock.RemoteSin.sin6_addr; - ICMP6Ptr^.Length := synsock.htonl(Length(Value)); - ICMP6Ptr^.proto := IPPROTO_ICMPV6; - Result := Checksum(s); -{$ENDIF} -end; - -procedure TPINGSend.TranslateError; -begin - if fSock.IP6used then - begin - case FReplyType of - ICMP6_ECHOREPLY: - FReplyError := IE_NoError; - ICMP6_TIME_EXCEEDED: - FReplyError := IE_TTLExceed; - ICMP6_UNREACH: - case FReplyCode of - 0: - FReplyError := IE_UnreachRoute; - 3: - FReplyError := IE_UnreachAddr; - 4: - FReplyError := IE_UnreachPort; - 1: - FReplyError := IE_UnreachAdmin; - else - FReplyError := IE_UnreachOther; - end; - else - FReplyError := IE_Other; - end; - end - else - begin - case FReplyType of - ICMP_ECHOREPLY: - FReplyError := IE_NoError; - ICMP_TIME_EXCEEDED: - FReplyError := IE_TTLExceed; - ICMP_UNREACH: - case FReplyCode of - 0: - FReplyError := IE_UnreachRoute; - 1: - FReplyError := IE_UnreachAddr; - 3: - FReplyError := IE_UnreachPort; - 13: - FReplyError := IE_UnreachAdmin; - else - FReplyError := IE_UnreachOther; - end; - else - FReplyError := IE_Other; - end; - end; - GenErrorDesc; -end; - -procedure TPINGSend.TranslateErrorIpHlp(value: integer); -begin - case value of - 11000, 0: - FReplyError := IE_NoError; - 11013: - FReplyError := IE_TTLExceed; - 11002: - FReplyError := IE_UnreachRoute; - 11003: - FReplyError := IE_UnreachAddr; - 11005: - FReplyError := IE_UnreachPort; - 11004: - FReplyError := IE_UnreachAdmin; - else - FReplyError := IE_Other; - end; - GenErrorDesc; -end; - -function TPINGSend.InternalPingIpHlp(const Host: string): Boolean; -{$IFDEF MSWINDOWS} -var - PingIp6: boolean; - PingHandle: integer; - r: integer; - ipo: TIP_OPTION_INFORMATION; - RBuff: Ansistring; - ip4reply: PICMP_ECHO_REPLY; - ip6reply: PICMPV6_ECHO_REPLY; - ip6: TSockAddrIn6; -begin - Result := False; - PingIp6 := Fsin.sin_family = AF_INET6; - if pingIp6 then - PingHandle := Icmp6CreateFile - else - PingHandle := IcmpCreateFile; - if PingHandle <> -1 then - begin - try - ipo.TTL := FTTL; - ipo.TOS := 0; - ipo.Flags := 0; - ipo.OptionsSize := 0; - ipo.OptionsData := nil; - setlength(RBuff, 4096); - if pingIp6 then - begin - FillChar(ip6, sizeof(ip6), 0); - r := Icmp6SendEcho2(PingHandle, nil, nil, nil, @ip6, @Fsin, - PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout); - if r > 0 then - begin - RBuff := #0 + #0 + RBuff; - ip6reply := PICMPV6_ECHO_REPLY(pointer(RBuff)); - FPingTime := ip6reply^.RoundTripTime; - ip6reply^.Address.sin6_family := AF_INET6; - FReplyFrom := GetSinIp(TVarSin(ip6reply^.Address)); - TranslateErrorIpHlp(ip6reply^.Status); - Result := True; - end; - end - else - begin - r := IcmpSendEcho2(PingHandle, nil, nil, nil, Fsin.sin_addr, - PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout); - if r > 0 then - begin - ip4reply := PICMP_ECHO_REPLY(pointer(RBuff)); - FPingTime := ip4reply^.RoundTripTime; - FReplyFrom := IpToStr(swapbytes(ip4reply^.Address.S_addr)); - TranslateErrorIpHlp(ip4reply^.Status); - Result := True; - end; - end - finally - IcmpCloseHandle(PingHandle); - end; - end; -end; -{$ELSE} -begin - result := false; -end; -{$ENDIF} - -{==============================================================================} - -function PingHost(const Host: string): Integer; -begin - with TPINGSend.Create do - try - Result := -1; - if Ping(Host) then - if ReplyError = IE_NoError then - Result := PingTime; - finally - Free; - end; -end; - -function TraceRouteHost(const Host: string): string; -var - Ping: TPingSend; - ttl : byte; -begin - Result := ''; - Ping := TPINGSend.Create; - try - ttl := 1; - repeat - ping.TTL := ttl; - inc(ttl); - if ttl > 30 then - Break; - if not ping.Ping(Host) then - begin - Result := Result + cAnyHost+ ' Timeout' + CRLF; - continue; - end; - if (ping.ReplyError <> IE_NoError) - and (ping.ReplyError <> IE_TTLExceed) then - begin - Result := Result + Ping.ReplyFrom + ' ' + Ping.ReplyErrorDesc + CRLF; - break; - end; - Result := Result + Ping.ReplyFrom + ' ' + IntToStr(Ping.PingTime) + CRLF; - until ping.ReplyError = IE_NoError; - finally - Ping.Free; - end; -end; - -{$IFDEF MSWINDOWS} -initialization -begin - IcmpHelper4 := false; - IcmpHelper6 := false; - IcmpDllHandle := LoadLibrary(DLLIcmpName); - if IcmpDllHandle <> 0 then - begin - IcmpCreateFile := GetProcAddress(IcmpDLLHandle, 'IcmpCreateFile'); - IcmpCloseHandle := GetProcAddress(IcmpDLLHandle, 'IcmpCloseHandle'); - IcmpSendEcho2 := GetProcAddress(IcmpDLLHandle, 'IcmpSendEcho2'); - Icmp6CreateFile := GetProcAddress(IcmpDLLHandle, 'Icmp6CreateFile'); - Icmp6SendEcho2 := GetProcAddress(IcmpDLLHandle, 'Icmp6SendEcho2'); - IcmpHelper4 := assigned(IcmpCreateFile) - and assigned(IcmpCloseHandle) - and assigned(IcmpSendEcho2); - IcmpHelper6 := assigned(Icmp6CreateFile) - and assigned(Icmp6SendEcho2); - end; -end; - -finalization -begin - FreeLibrary(IcmpDllHandle); -end; -{$ENDIF} - -end. diff --git a/addons/synapse/pop3send.pas b/addons/synapse/pop3send.pas deleted file mode 100644 index 05c5ac0..0000000 --- a/addons/synapse/pop3send.pas +++ /dev/null @@ -1,483 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.006.002 | -|==============================================================================| -| Content: POP3 client | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2001-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(POP3 protocol client) - -Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} -{$M+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit pop3send; - -interface - -uses - SysUtils, Classes, - blcksock, synautil, synacode; - -const - cPop3Protocol = '110'; - -type - - {:The three types of possible authorization methods for "logging in" to a POP3 - server.} - TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP); - - {:@abstract(Implementation of POP3 client protocol.) - - Note: Are you missing properties for setting Username and Password? Look to - parent @link(TSynaClient) object! - - Are you missing properties for specify server address and port? Look to - parent @link(TSynaClient) too!} - TPOP3Send = class(TSynaClient) - private - FSock: TTCPBlockSocket; - FResultCode: Integer; - FResultString: string; - FFullResult: TStringList; - FStatCount: Integer; - FStatSize: Integer; - FListSize: Integer; - FTimeStamp: string; - FAuthType: TPOP3AuthType; - FPOP3cap: TStringList; - FAutoTLS: Boolean; - FFullSSL: Boolean; - function ReadResult(Full: Boolean): Integer; - function Connect: Boolean; - function AuthLogin: Boolean; - function AuthApop: Boolean; - public - constructor Create; - destructor Destroy; override; - - {:You can call any custom by this method. Call Command without trailing CRLF. - If MultiLine parameter is @true, multilined response are expected. - Result is @true on sucess.} - function CustomCommand(const Command: string; MultiLine: Boolean): boolean; - - {:Call CAPA command for get POP3 server capabilites. - note: not all servers support this command!} - function Capability: Boolean; - - {:Connect to remote POP3 host. If all OK, result is @true.} - function Login: Boolean; - - {:Disconnects from POP3 server.} - function Logout: Boolean; - - {:Send RSET command. If all OK, result is @true.} - function Reset: Boolean; - - {:Send NOOP command. If all OK, result is @true.} - function NoOp: Boolean; - - {:Send STAT command and fill @link(StatCount) and @link(StatSize) property. - If all OK, result is @true.} - function Stat: Boolean; - - {:Send LIST command. If Value is 0, LIST is for all messages. After - successful operation is listing in FullResult. If all OK, result is @True.} - function List(Value: Integer): Boolean; - - {:Send RETR command. After successful operation dowloaded message in - @link(FullResult). If all OK, result is @true.} - function Retr(Value: Integer): Boolean; - - {:Send RETR command. After successful operation dowloaded message in - @link(Stream). If all OK, result is @true.} - function RetrStream(Value: Integer; Stream: TStream): Boolean; - - {:Send DELE command for delete specified message. If all OK, result is @true.} - function Dele(Value: Integer): Boolean; - - {:Send TOP command. After successful operation dowloaded headers of message - and maxlines count of message in @link(FullResult). If all OK, result is - @true.} - function Top(Value, Maxlines: Integer): Boolean; - - {:Send UIDL command. If Value is 0, UIDL is for all messages. After - successful operation is listing in FullResult. If all OK, result is @True.} - function Uidl(Value: Integer): Boolean; - - {:Call STLS command for upgrade connection to SSL/TLS mode.} - function StartTLS: Boolean; - - {:Try to find given capabily in capabilty string returned from POP3 server - by CAPA command.} - function FindCap(const Value: string): string; - published - {:Result code of last POP3 operation. 0 - error, 1 - OK.} - property ResultCode: Integer read FResultCode; - - {:Result string of last POP3 operation.} - property ResultString: string read FResultString; - - {:Stringlist with full lines returned as result of POP3 operation. I.e. if - operation is LIST, this property is filled by list of messages. If - operation is RETR, this property have downloaded message.} - property FullResult: TStringList read FFullResult; - - {:After STAT command is there count of messages in inbox.} - property StatCount: Integer read FStatCount; - - {:After STAT command is there size of all messages in inbox.} - property StatSize: Integer read FStatSize; - - {:After LIST 0 command size of all messages on server, After LIST x size of message x on server} - property ListSize: Integer read FListSize; - - {:If server support this, after comnnect is in this property timestamp of - remote server.} - property TimeStamp: string read FTimeStamp; - - {:Type of authorisation for login to POP3 server. Dafault is autodetect one - of possible authorisation. Autodetect do this: - - If remote POP3 server support APOP, try login by APOP method. If APOP is - not supported, or if APOP login failed, try classic USER+PASS login method.} - property AuthType: TPOP3AuthType read FAuthType Write FAuthType; - - {:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.} - property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; - - {:SSL/TLS mode is used from first contact to server. Servers with full - SSL/TLS mode usualy using non-standard TCP port!} - property FullSSL: Boolean read FFullSSL Write FFullSSL; - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TTCPBlockSocket read FSock; - end; - -implementation - -constructor TPOP3Send.Create; -begin - inherited Create; - FFullResult := TStringList.Create; - FPOP3cap := TStringList.Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FSock.ConvertLineEnd := true; - FTimeout := 60000; - FTargetPort := cPop3Protocol; - FStatCount := 0; - FStatSize := 0; - FListSize := 0; - FAuthType := POP3AuthAll; - FAutoTLS := False; - FFullSSL := False; -end; - -destructor TPOP3Send.Destroy; -begin - FSock.Free; - FPOP3cap.Free; - FullResult.Free; - inherited Destroy; -end; - -function TPOP3Send.ReadResult(Full: Boolean): Integer; -var - s: AnsiString; -begin - Result := 0; - FFullResult.Clear; - s := FSock.RecvString(FTimeout); - if Pos('+OK', s) = 1 then - Result := 1; - FResultString := s; - if Full and (Result = 1) then - repeat - s := FSock.RecvString(FTimeout); - if s = '.' then - Break; - if s <> '' then - if s[1] = '.' then - Delete(s, 1, 1); - FFullResult.Add(s); - until FSock.LastError <> 0; - if not Full and (Result = 1) then - FFullResult.Add(SeparateRight(FResultString, ' ')); - if FSock.LastError <> 0 then - Result := 0; - FResultCode := Result; -end; - -function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean; -begin - FSock.SendString(Command + CRLF); - Result := ReadResult(MultiLine) <> 0; -end; - -function TPOP3Send.AuthLogin: Boolean; -begin - Result := False; - if not CustomCommand('USER ' + FUserName, False) then - exit; - Result := CustomCommand('PASS ' + FPassword, False) -end; - -function TPOP3Send.AuthAPOP: Boolean; -var - s: string; -begin - s := StrToHex(MD5(FTimeStamp + FPassWord)); - Result := CustomCommand('APOP ' + FUserName + ' ' + s, False); -end; - -function TPOP3Send.Connect: Boolean; -begin - // Do not call this function! It is calling by LOGIN method! - FStatCount := 0; - FStatSize := 0; - FSock.CloseSocket; - FSock.LineBuffer := ''; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError = 0 then - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError = 0 then - if FFullSSL then - FSock.SSLDoConnect; - Result := FSock.LastError = 0; -end; - -function TPOP3Send.Capability: Boolean; -begin - FPOP3cap.Clear; - Result := CustomCommand('CAPA', True); - if Result then - FPOP3cap.AddStrings(FFullResult); -end; - -function TPOP3Send.Login: Boolean; -var - s, s1: string; -begin - Result := False; - FTimeStamp := ''; - if not Connect then - Exit; - if ReadResult(False) <> 1 then - Exit; - s := SeparateRight(FResultString, '<'); - if s <> FResultString then - begin - s1 := Trim(SeparateLeft(s, '>')); - if s1 <> s then - FTimeStamp := '<' + s1 + '>'; - end; - Result := False; - if Capability then - if FAutoTLS and (Findcap('STLS') <> '') then - if StartTLS then - Capability - else - begin - Result := False; - Exit; - end; - if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then - begin - Result := AuthApop; - if not Result then - begin - if not Connect then - Exit; - if ReadResult(False) <> 1 then - Exit; - end; - end; - if not Result and not (FAuthType = POP3AuthAPOP) then - Result := AuthLogin; -end; - -function TPOP3Send.Logout: Boolean; -begin - Result := CustomCommand('QUIT', False); - FSock.CloseSocket; -end; - -function TPOP3Send.Reset: Boolean; -begin - Result := CustomCommand('RSET', False); -end; - -function TPOP3Send.NoOp: Boolean; -begin - Result := CustomCommand('NOOP', False); -end; - -function TPOP3Send.Stat: Boolean; -var - s: string; -begin - Result := CustomCommand('STAT', False); - if Result then - begin - s := SeparateRight(ResultString, '+OK '); - FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0); - FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0); - end; -end; - -function TPOP3Send.List(Value: Integer): Boolean; -var - s: string; - n: integer; -begin - if Value = 0 then - s := 'LIST' - else - s := 'LIST ' + IntToStr(Value); - Result := CustomCommand(s, Value = 0); - FListSize := 0; - if Result then - if Value <> 0 then - begin - s := SeparateRight(ResultString, '+OK '); - FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); - end - else - for n := 0 to FFullResult.Count - 1 do - FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); -end; - -function TPOP3Send.Retr(Value: Integer): Boolean; -begin - Result := CustomCommand('RETR ' + IntToStr(Value), True); -end; - -//based on code by Miha Vrhovnik -function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean; -var - s: string; -begin - Result := False; - FFullResult.Clear; - Stream.Size := 0; - FSock.SendString('RETR ' + IntToStr(Value) + CRLF); - - s := FSock.RecvString(FTimeout); - if Pos('+OK', s) = 1 then - Result := True; - FResultString := s; - if Result then begin - repeat - s := FSock.RecvString(FTimeout); - if s = '.' then - Break; - if s <> '' then begin - if s[1] = '.' then - Delete(s, 1, 1); - end; - WriteStrToStream(Stream, s); - WriteStrToStream(Stream, CRLF); - until FSock.LastError <> 0; - end; - - if Result then - FResultCode := 1 - else - FResultCode := 0; -end; - -function TPOP3Send.Dele(Value: Integer): Boolean; -begin - Result := CustomCommand('DELE ' + IntToStr(Value), False); -end; - -function TPOP3Send.Top(Value, Maxlines: Integer): Boolean; -begin - Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True); -end; - -function TPOP3Send.Uidl(Value: Integer): Boolean; -var - s: string; -begin - if Value = 0 then - s := 'UIDL' - else - s := 'UIDL ' + IntToStr(Value); - Result := CustomCommand(s, Value = 0); -end; - -function TPOP3Send.StartTLS: Boolean; -begin - Result := False; - if CustomCommand('STLS', False) then - begin - Fsock.SSLDoConnect; - Result := FSock.LastError = 0; - end; -end; - -function TPOP3Send.FindCap(const Value: string): string; -var - n: Integer; - s: string; -begin - s := UpperCase(Value); - Result := ''; - for n := 0 to FPOP3cap.Count - 1 do - if Pos(s, UpperCase(FPOP3cap[n])) = 1 then - begin - Result := FPOP3cap[n]; - Break; - end; -end; - -end. diff --git a/addons/synapse/slogsend.pas b/addons/synapse/slogsend.pas deleted file mode 100644 index 900f6c0..0000000 --- a/addons/synapse/slogsend.pas +++ /dev/null @@ -1,320 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.002.003 | -|==============================================================================| -| Content: SysLog client | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2001-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Christian Brosius | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(BSD SYSLOG protocol) - -Used RFC: RFC-3164 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -unit slogsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil; - -const - cSysLogProtocol = '514'; - - FCL_Kernel = 0; - FCL_UserLevel = 1; - FCL_MailSystem = 2; - FCL_System = 3; - FCL_Security = 4; - FCL_Syslogd = 5; - FCL_Printer = 6; - FCL_News = 7; - FCL_UUCP = 8; - FCL_Clock = 9; - FCL_Authorization = 10; - FCL_FTP = 11; - FCL_NTP = 12; - FCL_LogAudit = 13; - FCL_LogAlert = 14; - FCL_Time = 15; - FCL_Local0 = 16; - FCL_Local1 = 17; - FCL_Local2 = 18; - FCL_Local3 = 19; - FCL_Local4 = 20; - FCL_Local5 = 21; - FCL_Local6 = 22; - FCL_Local7 = 23; - -type - {:@abstract(Define possible priority of Syslog message)} - TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info, - Debug); - - {:@abstract(encoding or decoding of SYSLOG message)} - TSyslogMessage = class(TObject) - private - FFacility:Byte; - FSeverity:TSyslogSeverity; - FDateTime:TDateTime; - FTag:String; - FMessage:String; - FLocalIP:String; - function GetPacketBuf:String; - procedure SetPacketBuf(Value:String); - public - {:Reset values to defaults} - procedure Clear; - published - {:Define facilicity of Syslog message. For specify you may use predefined - FCL_* constants. Default is "FCL_Local0".} - property Facility:Byte read FFacility write FFacility; - - {:Define possible priority of Syslog message. Default is "Debug".} - property Severity:TSyslogSeverity read FSeverity write FSeverity; - - {:date and time of Syslog message} - property DateTime:TDateTime read FDateTime write FDateTime; - - {:This is used for identify process of this message. Default is filename - of your executable file.} - property Tag:String read FTag write FTag; - - {:Text of your message for log.} - property LogMessage:String read FMessage write FMessage; - - {:IP address of message sender.} - property LocalIP:String read FLocalIP write FLocalIP; - - {:This property holds encoded binary SYSLOG packet} - property PacketBuf:String read GetPacketBuf write SetPacketBuf; - end; - - {:@abstract(This object implement BSD SysLog client) - - Note: Are you missing properties for specify server address and port? Look to - parent @link(TSynaClient) too!} - TSyslogSend = class(TSynaClient) - private - FSock: TUDPBlockSocket; - FSysLogMessage: TSysLogMessage; - public - constructor Create; - destructor Destroy; override; - {:Send Syslog UDP packet defined by @link(SysLogMessage).} - function DoIt: Boolean; - published - {:Syslog message for send} - property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage; - end; - -{:Simply send packet to specified Syslog server.} -function ToSysLog(const SyslogServer: string; Facil: Byte; - Sever: TSyslogSeverity; const Content: string): Boolean; - -implementation - -function TSyslogMessage.GetPacketBuf:String; -begin - Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>'; - Result := Result + CDateTime(FDateTime) + ' '; - Result := Result + FLocalIP + ' '; - Result := Result + FTag + ': ' + FMessage; -end; - -procedure TSyslogMessage.SetPacketBuf(Value:String); -var StrBuf:String; - IntBuf,Pos:Integer; -begin - if Length(Value) < 1 then exit; - Pos := 1; - if Value[Pos] <> '<' then exit; - Inc(Pos); - // Facility and Severity - StrBuf := ''; - while (Value[Pos] <> '>')do - begin - StrBuf := StrBuf + Value[Pos]; - Inc(Pos); - end; - IntBuf := StrToInt(StrBuf); - FFacility := IntBuf div 8; - case (IntBuf mod 8)of - 0:FSeverity := Emergency; - 1:FSeverity := Alert; - 2:FSeverity := Critical; - 3:FSeverity := Error; - 4:FSeverity := Warning; - 5:FSeverity := Notice; - 6:FSeverity := Info; - 7:FSeverity := Debug; - end; - // DateTime - Inc(Pos); - StrBuf := ''; - // Month - while (Value[Pos] <> ' ')do - begin - StrBuf := StrBuf + Value[Pos]; - Inc(Pos); - end; - StrBuf := StrBuf + Value[Pos]; - Inc(Pos); - // Day - while (Value[Pos] <> ' ')do - begin - StrBuf := StrBuf + Value[Pos]; - Inc(Pos); - end; - StrBuf := StrBuf + Value[Pos]; - Inc(Pos); - // Time - while (Value[Pos] <> ' ')do - begin - StrBuf := StrBuf + Value[Pos]; - Inc(Pos); - end; - FDateTime := DecodeRFCDateTime(StrBuf); - Inc(Pos); - - // LocalIP - StrBuf := ''; - while (Value[Pos] <> ' ')do - begin - StrBuf := StrBuf + Value[Pos]; - Inc(Pos); - end; - FLocalIP := StrBuf; - Inc(Pos); - // Tag - StrBuf := ''; - while (Value[Pos] <> ':')do - begin - StrBuf := StrBuf + Value[Pos]; - Inc(Pos); - end; - FTag := StrBuf; - // LogMessage - Inc(Pos); - StrBuf := ''; - while (Pos <= Length(Value))do - begin - StrBuf := StrBuf + Value[Pos]; - Inc(Pos); - end; - FMessage := TrimSP(StrBuf); -end; - -procedure TSysLogMessage.Clear; -begin - FFacility := FCL_Local0; - FSeverity := Debug; - FTag := ExtractFileName(ParamStr(0)); - FMessage := ''; - FLocalIP := '0.0.0.0'; -end; - -//------------------------------------------------------------------------------ - -constructor TSyslogSend.Create; -begin - inherited Create; - FSock := TUDPBlockSocket.Create; - FSock.Owner := self; - FSysLogMessage := TSysLogMessage.Create; - FTargetPort := cSysLogProtocol; -end; - -destructor TSyslogSend.Destroy; -begin - FSock.Free; - FSysLogMessage.Free; - inherited Destroy; -end; - -function TSyslogSend.DoIt: Boolean; -var - L: TStringList; -begin - Result := False; - L := TStringList.Create; - try - FSock.ResolveNameToIP(FSock.Localname, L); - if L.Count < 1 then - FSysLogMessage.LocalIP := '0.0.0.0' - else - FSysLogMessage.LocalIP := L[0]; - finally - L.Free; - end; - FSysLogMessage.DateTime := Now; - if Length(FSysLogMessage.PacketBuf) <= 1024 then - begin - FSock.Connect(FTargetHost, FTargetPort); - FSock.SendString(FSysLogMessage.PacketBuf); - Result := FSock.LastError = 0; - end; -end; - -{==============================================================================} - -function ToSysLog(const SyslogServer: string; Facil: Byte; - Sever: TSyslogSeverity; const Content: string): Boolean; -begin - with TSyslogSend.Create do - try - TargetHost :=SyslogServer; - SysLogMessage.Facility := Facil; - SysLogMessage.Severity := Sever; - SysLogMessage.LogMessage := Content; - Result := DoIt; - finally - Free; - end; -end; - -end. diff --git a/addons/synapse/smtpsend.pas b/addons/synapse/smtpsend.pas deleted file mode 100644 index 532af07..0000000 --- a/addons/synapse/smtpsend.pas +++ /dev/null @@ -1,725 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 003.005.001 | -|==============================================================================| -| Content: SMTP client | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(SMTP client) - -Used RFC: RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487, - RFC-2554, RFC-2821 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit smtpsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil, synacode; - -const - cSmtpProtocol = '25'; - -type - {:@abstract(Implementation of SMTP and ESMTP procotol), - include some ESMTP extensions, include SSL/TLS too. - - Note: Are you missing properties for setting Username and Password for ESMTP? - Look to parent @link(TSynaClient) object! - - Are you missing properties for specify server address and port? Look to - parent @link(TSynaClient) too!} - TSMTPSend = class(TSynaClient) - private - FSock: TTCPBlockSocket; - FResultCode: Integer; - FResultString: string; - FFullResult: TStringList; - FESMTPcap: TStringList; - FESMTP: Boolean; - FAuthDone: Boolean; - FESMTPSize: Boolean; - FMaxSize: Integer; - FEnhCode1: Integer; - FEnhCode2: Integer; - FEnhCode3: Integer; - FSystemName: string; - FAutoTLS: Boolean; - FFullSSL: Boolean; - procedure EnhancedCode(const Value: string); - function ReadResult: Integer; - function AuthLogin: Boolean; - function AuthCram: Boolean; - function AuthPlain: Boolean; - function Helo: Boolean; - function Ehlo: Boolean; - function Connect: Boolean; - public - constructor Create; - destructor Destroy; override; - - {:Connects to SMTP server (defined in @link(TSynaClient.TargetHost)) and - begin SMTP session. (First try ESMTP EHLO, next old HELO handshake). Parses - ESMTP capabilites and if you specified Username and password and remote - server can handle AUTH command, try login by AUTH command. Preffered login - method is CRAM-MD5 (if safer!). If all OK, result is @true, else result is - @false.} - function Login: Boolean; - - {:Close SMTP session (QUIT command) and disconnect from SMTP server.} - function Logout: Boolean; - - {:Send RSET SMTP command for reset SMTP session. If all OK, result is @true, - else result is @false.} - function Reset: Boolean; - - {:Send NOOP SMTP command for keep SMTP session. If all OK, result is @true, - else result is @false.} - function NoOp: Boolean; - - {:Send MAIL FROM SMTP command for set sender e-mail address. If sender's - e-mail address is empty string, transmited message is error message. - - If size not 0 and remote server can handle SIZE parameter, append SIZE - parameter to request. If all OK, result is @true, else result is @false.} - function MailFrom(const Value: string; Size: Integer): Boolean; - - {:Send RCPT TO SMTP command for set receiver e-mail address. It cannot be an - empty string. If all OK, result is @true, else result is @false.} - function MailTo(const Value: string): Boolean; - - {:Send DATA SMTP command and transmit message data. If all OK, result is - @true, else result is @false.} - function MailData(const Value: Tstrings): Boolean; - - {:Send ETRN SMTP command for start sending of remote queue for domain in - Value. If all OK, result is @true, else result is @false.} - function Etrn(const Value: string): Boolean; - - {:Send VRFY SMTP command for check receiver e-mail address. It cannot be - an empty string. If all OK, result is @true, else result is @false.} - function Verify(const Value: string): Boolean; - - {:Call STARTTLS command for upgrade connection to SSL/TLS mode.} - function StartTLS: Boolean; - - {:Return string descriptive text for enhanced result codes stored in - @link(EnhCode1), @link(EnhCode2) and @link(EnhCode3).} - function EnhCodeString: string; - - {:Try to find specified capability in ESMTP response.} - function FindCap(const Value: string): string; - published - {:result code of last SMTP command.} - property ResultCode: Integer read FResultCode; - - {:result string of last SMTP command (begin with string representation of - result code).} - property ResultString: string read FResultString; - - {:All result strings of last SMTP command (result is maybe multiline!).} - property FullResult: TStringList read FFullResult; - - {:List of ESMTP capabilites of remote ESMTP server. (If you connect to ESMTP - server only!).} - property ESMTPcap: TStringList read FESMTPcap; - - {:@TRUE if you successfuly logged to ESMTP server.} - property ESMTP: Boolean read FESMTP; - - {:@TRUE if you successfuly pass authorisation to remote server.} - property AuthDone: Boolean read FAuthDone; - - {:@TRUE if remote server can handle SIZE parameter.} - property ESMTPSize: Boolean read FESMTPSize; - - {:When @link(ESMTPsize) is @TRUE, contains max length of message that remote - server can handle.} - property MaxSize: Integer read FMaxSize; - - {:First digit of Enhanced result code. If last operation does not have - enhanced result code, values is 0.} - property EnhCode1: Integer read FEnhCode1; - - {:Second digit of Enhanced result code. If last operation does not have - enhanced result code, values is 0.} - property EnhCode2: Integer read FEnhCode2; - - {:Third digit of Enhanced result code. If last operation does not have - enhanced result code, values is 0.} - property EnhCode3: Integer read FEnhCode3; - - {:name of our system used in HELO and EHLO command. Implicit value is - internet address of your machine.} - property SystemName: string read FSystemName Write FSystemName; - - {:If is set to true, then upgrade to SSL/TLS mode if remote server support it.} - property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; - - {:SSL/TLS mode is used from first contact to server. Servers with full - SSL/TLS mode usualy using non-standard TCP port!} - property FullSSL: Boolean read FFullSSL Write FFullSSL; - - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TTCPBlockSocket read FSock; - end; - -{:A very useful function and example of its use would be found in the TSMTPsend - object. Send maildata (text of e-mail with all SMTP headers! For example when - text of message is created by @link(TMimemess) object) from "MailFrom" e-mail - address to "MailTo" e-mail address (If you need more then one receiver, then - separate their addresses by comma). - - Function sends e-mail to a SMTP server defined in "SMTPhost" parameter. - Username and password are used for authorization to the "SMTPhost". If you - don't want authorization, set "Username" and "Password" to empty strings. If - e-mail message is successfully sent, the result returns @true. - - If you need use different port number then standard, then add this port number - to SMTPhost after colon. (i.e. '127.0.0.1:1025')} -function SendToRaw(const MailFrom, MailTo, SMTPHost: string; - const MailData: TStrings; const Username, Password: string): Boolean; - -{:A very useful function and example of its use would be found in the TSMTPsend - object. Send "Maildata" (text of e-mail without any SMTP headers!) from - "MailFrom" e-mail address to "MailTo" e-mail address with "Subject". (If you - need more then one receiver, then separate their addresses by comma). - - This function constructs all needed SMTP headers (with DATE header) and sends - the e-mail to the SMTP server defined in the "SMTPhost" parameter. If the - e-mail message is successfully sent, the result will be @TRUE. - - If you need use different port number then standard, then add this port number - to SMTPhost after colon. (i.e. '127.0.0.1:1025')} -function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string; - const MailData: TStrings): Boolean; - -{:A very useful function and example of its use would be found in the TSMTPsend - object. Sends "MailData" (text of e-mail without any SMTP headers!) from - "MailFrom" e-mail address to "MailTo" e-mail address (If you need more then one - receiver, then separate their addresses by comma). - - This function sends the e-mail to the SMTP server defined in the "SMTPhost" - parameter. Username and password are used for authorization to the "SMTPhost". - If you dont want authorization, set "Username" and "Password" to empty Strings. - If the e-mail message is successfully sent, the result will be @TRUE. - - If you need use different port number then standard, then add this port number - to SMTPhost after colon. (i.e. '127.0.0.1:1025')} -function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string; - const MailData: TStrings; const Username, Password: string): Boolean; - -implementation - -constructor TSMTPSend.Create; -begin - inherited Create; - FFullResult := TStringList.Create; - FESMTPcap := TStringList.Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FSock.ConvertLineEnd := true; - FTimeout := 60000; - FTargetPort := cSmtpProtocol; - FSystemName := FSock.LocalName; - FAutoTLS := False; - FFullSSL := False; -end; - -destructor TSMTPSend.Destroy; -begin - FSock.Free; - FESMTPcap.Free; - FFullResult.Free; - inherited Destroy; -end; - -procedure TSMTPSend.EnhancedCode(const Value: string); -var - s, t: string; - e1, e2, e3: Integer; -begin - FEnhCode1 := 0; - FEnhCode2 := 0; - FEnhCode3 := 0; - s := Copy(Value, 5, Length(Value) - 4); - t := Trim(SeparateLeft(s, '.')); - s := Trim(SeparateRight(s, '.')); - if t = '' then - Exit; - if Length(t) > 1 then - Exit; - e1 := StrToIntDef(t, 0); - if e1 = 0 then - Exit; - t := Trim(SeparateLeft(s, '.')); - s := Trim(SeparateRight(s, '.')); - if t = '' then - Exit; - if Length(t) > 3 then - Exit; - e2 := StrToIntDef(t, 0); - t := Trim(SeparateLeft(s, ' ')); - if t = '' then - Exit; - if Length(t) > 3 then - Exit; - e3 := StrToIntDef(t, 0); - FEnhCode1 := e1; - FEnhCode2 := e2; - FEnhCode3 := e3; -end; - -function TSMTPSend.ReadResult: Integer; -var - s: String; -begin - Result := 0; - FFullResult.Clear; - repeat - s := FSock.RecvString(FTimeout); - FResultString := s; - FFullResult.Add(s); - if FSock.LastError <> 0 then - Break; - until Pos('-', s) <> 4; - s := FFullResult[0]; - if Length(s) >= 3 then - Result := StrToIntDef(Copy(s, 1, 3), 0); - FResultCode := Result; - EnhancedCode(s); -end; - -function TSMTPSend.AuthLogin: Boolean; -begin - Result := False; - FSock.SendString('AUTH LOGIN' + CRLF); - if ReadResult <> 334 then - Exit; - FSock.SendString(EncodeBase64(FUsername) + CRLF); - if ReadResult <> 334 then - Exit; - FSock.SendString(EncodeBase64(FPassword) + CRLF); - Result := ReadResult = 235; -end; - -function TSMTPSend.AuthCram: Boolean; -var - s: ansistring; -begin - Result := False; - FSock.SendString('AUTH CRAM-MD5' + CRLF); - if ReadResult <> 334 then - Exit; - s := Copy(FResultString, 5, Length(FResultString) - 4); - s := DecodeBase64(s); - s := HMAC_MD5(s, FPassword); - s := FUsername + ' ' + StrToHex(s); - FSock.SendString(EncodeBase64(s) + CRLF); - Result := ReadResult = 235; -end; - -function TSMTPSend.AuthPlain: Boolean; -var - s: ansistring; -begin - Result := False; - s := ansichar(0) + FUsername + ansichar(0) + FPassword; - FSock.SendString('AUTH PLAIN ' + EncodeBase64(s) + CRLF); - Result := ReadResult = 235; -end; - -function TSMTPSend.Connect: Boolean; -begin - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError = 0 then - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError = 0 then - if FFullSSL then - FSock.SSLDoConnect; - Result := FSock.LastError = 0; -end; - -function TSMTPSend.Helo: Boolean; -var - x: Integer; -begin - FSock.SendString('HELO ' + FSystemName + CRLF); - x := ReadResult; - Result := (x >= 250) and (x <= 259); -end; - -function TSMTPSend.Ehlo: Boolean; -var - x: Integer; -begin - FSock.SendString('EHLO ' + FSystemName + CRLF); - x := ReadResult; - Result := (x >= 250) and (x <= 259); -end; - -function TSMTPSend.Login: Boolean; -var - n: Integer; - auths: string; - s: string; -begin - Result := False; - FESMTP := True; - FAuthDone := False; - FESMTPcap.clear; - FESMTPSize := False; - FMaxSize := 0; - if not Connect then - Exit; - if ReadResult <> 220 then - Exit; - if not Ehlo then - begin - FESMTP := False; - if not Helo then - Exit; - end; - Result := True; - if FESMTP then - begin - for n := 1 to FFullResult.Count - 1 do - FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4)); - if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then - if StartTLS then - begin - Ehlo; - FESMTPcap.Clear; - for n := 1 to FFullResult.Count - 1 do - FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4)); - end - else - begin - Result := False; - Exit; - end; - if not ((FUsername = '') and (FPassword = '')) then - begin - s := FindCap('AUTH '); - if s = '' then - s := FindCap('AUTH='); - auths := UpperCase(s); - if s <> '' then - begin - if Pos('CRAM-MD5', auths) > 0 then - FAuthDone := AuthCram; - if (not FauthDone) and (Pos('PLAIN', auths) > 0) then - FAuthDone := AuthPlain; - if (not FauthDone) and (Pos('LOGIN', auths) > 0) then - FAuthDone := AuthLogin; - end; - end; - s := FindCap('SIZE'); - if s <> '' then - begin - FESMTPsize := True; - FMaxSize := StrToIntDef(Copy(s, 6, Length(s) - 5), 0); - end; - end; -end; - -function TSMTPSend.Logout: Boolean; -begin - FSock.SendString('QUIT' + CRLF); - Result := ReadResult = 221; - FSock.CloseSocket; -end; - -function TSMTPSend.Reset: Boolean; -begin - FSock.SendString('RSET' + CRLF); - Result := ReadResult div 100 = 2; -end; - -function TSMTPSend.NoOp: Boolean; -begin - FSock.SendString('NOOP' + CRLF); - Result := ReadResult div 100 = 2; -end; - -function TSMTPSend.MailFrom(const Value: string; Size: Integer): Boolean; -var - s: string; -begin - s := 'MAIL FROM:<' + Value + '>'; - if FESMTPsize and (Size > 0) then - s := s + ' SIZE=' + IntToStr(Size); - FSock.SendString(s + CRLF); - Result := ReadResult div 100 = 2; -end; - -function TSMTPSend.MailTo(const Value: string): Boolean; -begin - FSock.SendString('RCPT TO:<' + Value + '>' + CRLF); - Result := ReadResult div 100 = 2; -end; - -function TSMTPSend.MailData(const Value: TStrings): Boolean; -var - n: Integer; - s: string; - t: string; - x: integer; -begin - Result := False; - FSock.SendString('DATA' + CRLF); - if ReadResult <> 354 then - Exit; - t := ''; - x := 1500; - for n := 0 to Value.Count - 1 do - begin - s := Value[n]; - if Length(s) >= 1 then - if s[1] = '.' then - s := '.' + s; - if Length(t) + Length(s) >= x then - begin - FSock.SendString(t); - t := ''; - end; - t := t + s + CRLF; - end; - if t <> '' then - FSock.SendString(t); - FSock.SendString('.' + CRLF); - Result := ReadResult div 100 = 2; -end; - -function TSMTPSend.Etrn(const Value: string): Boolean; -var - x: Integer; -begin - FSock.SendString('ETRN ' + Value + CRLF); - x := ReadResult; - Result := (x >= 250) and (x <= 259); -end; - -function TSMTPSend.Verify(const Value: string): Boolean; -var - x: Integer; -begin - FSock.SendString('VRFY ' + Value + CRLF); - x := ReadResult; - Result := (x >= 250) and (x <= 259); -end; - -function TSMTPSend.StartTLS: Boolean; -begin - Result := False; - if FindCap('STARTTLS') <> '' then - begin - FSock.SendString('STARTTLS' + CRLF); - if (ReadResult = 220) and (FSock.LastError = 0) then - begin - Fsock.SSLDoConnect; - Result := FSock.LastError = 0; - end; - end; -end; - -function TSMTPSend.EnhCodeString: string; -var - s, t: string; -begin - s := IntToStr(FEnhCode2) + '.' + IntToStr(FEnhCode3); - t := ''; - if s = '0.0' then t := 'Other undefined Status'; - if s = '1.0' then t := 'Other address status'; - if s = '1.1' then t := 'Bad destination mailbox address'; - if s = '1.2' then t := 'Bad destination system address'; - if s = '1.3' then t := 'Bad destination mailbox address syntax'; - if s = '1.4' then t := 'Destination mailbox address ambiguous'; - if s = '1.5' then t := 'Destination mailbox address valid'; - if s = '1.6' then t := 'Mailbox has moved'; - if s = '1.7' then t := 'Bad sender''s mailbox address syntax'; - if s = '1.8' then t := 'Bad sender''s system address'; - if s = '2.0' then t := 'Other or undefined mailbox status'; - if s = '2.1' then t := 'Mailbox disabled, not accepting messages'; - if s = '2.2' then t := 'Mailbox full'; - if s = '2.3' then t := 'Message Length exceeds administrative limit'; - if s = '2.4' then t := 'Mailing list expansion problem'; - if s = '3.0' then t := 'Other or undefined mail system status'; - if s = '3.1' then t := 'Mail system full'; - if s = '3.2' then t := 'System not accepting network messages'; - if s = '3.3' then t := 'System not capable of selected features'; - if s = '3.4' then t := 'Message too big for system'; - if s = '3.5' then t := 'System incorrectly configured'; - if s = '4.0' then t := 'Other or undefined network or routing status'; - if s = '4.1' then t := 'No answer from host'; - if s = '4.2' then t := 'Bad connection'; - if s = '4.3' then t := 'Routing server failure'; - if s = '4.4' then t := 'Unable to route'; - if s = '4.5' then t := 'Network congestion'; - if s = '4.6' then t := 'Routing loop detected'; - if s = '4.7' then t := 'Delivery time expired'; - if s = '5.0' then t := 'Other or undefined protocol status'; - if s = '5.1' then t := 'Invalid command'; - if s = '5.2' then t := 'Syntax error'; - if s = '5.3' then t := 'Too many recipients'; - if s = '5.4' then t := 'Invalid command arguments'; - if s = '5.5' then t := 'Wrong protocol version'; - if s = '6.0' then t := 'Other or undefined media error'; - if s = '6.1' then t := 'Media not supported'; - if s = '6.2' then t := 'Conversion required and prohibited'; - if s = '6.3' then t := 'Conversion required but not supported'; - if s = '6.4' then t := 'Conversion with loss performed'; - if s = '6.5' then t := 'Conversion failed'; - if s = '7.0' then t := 'Other or undefined security status'; - if s = '7.1' then t := 'Delivery not authorized, message refused'; - if s = '7.2' then t := 'Mailing list expansion prohibited'; - if s = '7.3' then t := 'Security conversion required but not possible'; - if s = '7.4' then t := 'Security features not supported'; - if s = '7.5' then t := 'Cryptographic failure'; - if s = '7.6' then t := 'Cryptographic algorithm not supported'; - if s = '7.7' then t := 'Message integrity failure'; - s := '???-'; - if FEnhCode1 = 2 then s := 'Success-'; - if FEnhCode1 = 4 then s := 'Persistent Transient Failure-'; - if FEnhCode1 = 5 then s := 'Permanent Failure-'; - Result := s + t; -end; - -function TSMTPSend.FindCap(const Value: string): string; -var - n: Integer; - s: string; -begin - s := UpperCase(Value); - Result := ''; - for n := 0 to FESMTPcap.Count - 1 do - if Pos(s, UpperCase(FESMTPcap[n])) = 1 then - begin - Result := FESMTPcap[n]; - Break; - end; -end; - -{==============================================================================} - -function SendToRaw(const MailFrom, MailTo, SMTPHost: string; - const MailData: TStrings; const Username, Password: string): Boolean; -var - SMTP: TSMTPSend; - s, t: string; -begin - Result := False; - SMTP := TSMTPSend.Create; - try -// if you need SOCKS5 support, uncomment next lines: - // SMTP.Sock.SocksIP := '127.0.0.1'; - // SMTP.Sock.SocksPort := '1080'; -// if you need support for upgrade session to TSL/SSL, uncomment next lines: - // SMTP.AutoTLS := True; -// if you need support for TSL/SSL tunnel, uncomment next lines: - // SMTP.FullSSL := True; - SMTP.TargetHost := Trim(SeparateLeft(SMTPHost, ':')); - s := Trim(SeparateRight(SMTPHost, ':')); - if (s <> '') and (s <> SMTPHost) then - SMTP.TargetPort := s; - SMTP.Username := Username; - SMTP.Password := Password; - if SMTP.Login then - begin - if SMTP.MailFrom(GetEmailAddr(MailFrom), Length(MailData.Text)) then - begin - s := MailTo; - repeat - t := GetEmailAddr(Trim(FetchEx(s, ',', '"'))); - if t <> '' then - Result := SMTP.MailTo(t); - if not Result then - Break; - until s = ''; - if Result then - Result := SMTP.MailData(MailData); - end; - SMTP.Logout; - end; - finally - SMTP.Free; - end; -end; - -function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string; - const MailData: TStrings; const Username, Password: string): Boolean; -var - t: TStrings; -begin - t := TStringList.Create; - try - t.Assign(MailData); - t.Insert(0, ''); - t.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer'); - t.Insert(0, 'Subject: ' + Subject); - t.Insert(0, 'Date: ' + Rfc822DateTime(now)); - t.Insert(0, 'To: ' + MailTo); - t.Insert(0, 'From: ' + MailFrom); - Result := SendToRaw(MailFrom, MailTo, SMTPHost, t, Username, Password); - finally - t.Free; - end; -end; - -function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string; - const MailData: TStrings): Boolean; -begin - Result := SendToEx(MailFrom, MailTo, Subject, SMTPHost, MailData, '', ''); -end; - -end. diff --git a/addons/synapse/snmpsend.pas b/addons/synapse/snmpsend.pas deleted file mode 100644 index 431f5e4..0000000 --- a/addons/synapse/snmpsend.pas +++ /dev/null @@ -1,1089 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 003.000.010 | -|==============================================================================| -| Content: SNMP client | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Jean-Fabien Connault (cycocrew@worldnet.fr) | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(SNMP client) -Supports SNMPv1 include traps, SNMPv2c and SNMPv3 include authorization - (encryption not yet supported!) - -Used RFC: RFC-1157, RFC-1901, RFC-3412, RFC-3414, RFC-3416 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit snmpsend; - -interface - -uses - Classes, SysUtils, - blcksock, synautil, asn1util, synaip, synacode; - -const - cSnmpProtocol = '161'; - cSnmpTrapProtocol = '162'; - - SNMP_V1 = 0; - SNMP_V2C = 1; - SNMP_V3 = 3; - - //PDU type - PDUGetRequest = $A0; - PDUGetNextRequest = $A1; - PDUGetResponse = $A2; - PDUSetRequest = $A3; - PDUTrap = $A4; //Obsolete - //for SNMPv2 - PDUGetBulkRequest = $A5; - PDUInformRequest = $A6; - PDUTrapV2 = $A7; - PDUReport = $A8; - - //errors - ENoError = 0; - ETooBig = 1; - ENoSuchName = 2; - EBadValue = 3; - EReadOnly = 4; - EGenErr = 5; - //errors SNMPv2 - ENoAccess = 6; - EWrongType = 7; - EWrongLength = 8; - EWrongEncoding = 9; - EWrongValue = 10; - ENoCreation = 11; - EInconsistentValue = 12; - EResourceUnavailable = 13; - ECommitFailed = 14; - EUndoFailed = 15; - EAuthorizationError = 16; - ENotWritable = 17; - EInconsistentName = 18; - -type - - {:@abstract(Possible values for SNMPv3 flags.) - This flags specify level of authorization and encryption.} - TV3Flags = ( - NoAuthNoPriv, - AuthNoPriv, - AuthPriv); - - {:@abstract(Type of SNMPv3 authorization)} - TV3Auth = ( - AuthMD5, - AuthSHA1); - - {:@abstract(Data object with one record of MIB OID and corresponding values.)} - TSNMPMib = class(TObject) - protected - FOID: AnsiString; - FValue: AnsiString; - FValueType: Integer; - published - {:OID number in string format.} - property OID: AnsiString read FOID write FOID; - - {:Value of OID object in string format.} - property Value: AnsiString read FValue write FValue; - - {:Define type of Value. Supported values are defined in @link(asn1util). - For queries use ASN1_NULL, becouse you don't know type in response!} - property ValueType: Integer read FValueType write FValueType; - end; - - {:@abstract(It holding all information for SNMPv3 agent synchronization) - Used internally.} - TV3Sync = record - EngineID: AnsiString; - EngineBoots: integer; - EngineTime: integer; - EngineStamp: Cardinal; - end; - - {:@abstract(Data object abstracts SNMP data packet)} - TSNMPRec = class(TObject) - protected - FVersion: Integer; - FPDUType: Integer; - FID: Integer; - FErrorStatus: Integer; - FErrorIndex: Integer; - FCommunity: AnsiString; - FSNMPMibList: TList; - FMaxSize: Integer; - FFlags: TV3Flags; - FFlagReportable: Boolean; - FContextEngineID: AnsiString; - FContextName: AnsiString; - FAuthMode: TV3Auth; - FAuthEngineID: AnsiString; - FAuthEngineBoots: integer; - FAuthEngineTime: integer; - FAuthEngineTimeStamp: cardinal; - FUserName: AnsiString; - FPassword: AnsiString; - FAuthKey: AnsiString; - FPrivKey: AnsiString; - FOldTrapEnterprise: AnsiString; - FOldTrapHost: AnsiString; - FOldTrapGen: Integer; - FOldTrapSpec: Integer; - FOldTrapTimeTicks: Integer; - function Pass2Key(const Value: AnsiString): AnsiString; - public - constructor Create; - destructor Destroy; override; - - {:Decode SNMP packet in buffer to object properties.} - function DecodeBuf(const Buffer: AnsiString): Boolean; - - {:Encode obeject properties to SNMP packet.} - function EncodeBuf: AnsiString; - - {:Clears all object properties to default values.} - procedure Clear; - - {:Add entry to @link(SNMPMibList). For queries use value as empty string, - and ValueType as ASN1_NULL.} - procedure MIBAdd(const MIB, Value: AnsiString; ValueType: Integer); - - {:Delete entry from @link(SNMPMibList).} - procedure MIBDelete(Index: Integer); - - {:Search @link(SNMPMibList) list for MIB and return correspond value.} - function MIBGet(const MIB: AnsiString): AnsiString; - - {:return number of entries in MIB array.} - function MIBCount: integer; - - {:Return MIB information from given row of MIB array.} - function MIBByIndex(Index: Integer): TSNMPMib; - - {:List of @link(TSNMPMib) objects.} - property SNMPMibList: TList read FSNMPMibList; - published - {:Version of SNMP packet. Default value is 0 (SNMP ver. 1). You can use - value 1 for SNMPv2c or value 3 for SNMPv3.} - property Version: Integer read FVersion write FVersion; - - {:Community string for autorize access to SNMP server. (Case sensitive!) - Community string is not used in SNMPv3! Use @link(Username) and - @link(password) instead!} - property Community: AnsiString read FCommunity write FCommunity; - - {:Define type of SNMP operation.} - property PDUType: Integer read FPDUType write FPDUType; - - {:Contains ID number. Not need to use.} - property ID: Integer read FID write FID; - - {:When packet is reply, contains error code. Supported values are defined by - E* constants.} - property ErrorStatus: Integer read FErrorStatus write FErrorStatus; - - {:Point to error position in reply packet. Not usefull for users. It only - good for debugging!} - property ErrorIndex: Integer read FErrorIndex write FErrorIndex; - - {:special value for GetBulkRequest of SNMPv2 and v3.} - property NonRepeaters: Integer read FErrorStatus write FErrorStatus; - - {:special value for GetBulkRequest of SNMPv2 and v3.} - property MaxRepetitions: Integer read FErrorIndex write FErrorIndex; - - {:Maximum message size in bytes for SNMPv3. For sending is default 1472 bytes.} - property MaxSize: Integer read FMaxSize write FMaxSize; - - {:Specify if message is authorised or encrypted. Used only in SNMPv3, and - encryption is not yet supported!} - property Flags: TV3Flags read FFlags write FFlags; - - {:For SNMPv3.... If is @true, SNMP agent must send reply (at least with some - error).} - property FlagReportable: Boolean read FFlagReportable write FFlagReportable; - - {:For SNMPv3. If not specified, is used value from @link(AuthEngineID)} - property ContextEngineID: AnsiString read FContextEngineID write FContextEngineID; - - {:For SNMPv3.} - property ContextName: AnsiString read FContextName write FContextName; - - {:For SNMPv3. Specify Authorization mode. (specify used hash for - authorization)} - property AuthMode: TV3Auth read FAuthMode write FAuthMode; - - {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} - property AuthEngineID: AnsiString read FAuthEngineID write FAuthEngineID; - - {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} - property AuthEngineBoots: Integer read FAuthEngineBoots write FAuthEngineBoots; - - {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} - property AuthEngineTime: Integer read FAuthEngineTime write FAuthEngineTime; - - {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} - property AuthEngineTimeStamp: Cardinal read FAuthEngineTimeStamp Write FAuthEngineTimeStamp; - - {:SNMPv3 authorization username} - property UserName: AnsiString read FUserName write FUserName; - - {:SNMPv3 authorization password} - property Password: AnsiString read FPassword write FPassword; - - {:For SNMPv3. Computed Athorization key from @link(password).} - property AuthKey: AnsiString read FAuthKey write FAuthKey; - - {:For SNMPv3. Encryption key for message encryption. Not yet used!} - property PrivKey: AnsiString read FPrivKey write FPrivKey; - - {:MIB value to identify the object that sent the TRAPv1.} - property OldTrapEnterprise: AnsiString read FOldTrapEnterprise write FOldTrapEnterprise; - - {:Address of TRAPv1 sender (IP address).} - property OldTrapHost: AnsiString read FOldTrapHost write FOldTrapHost; - - {:Generic TRAPv1 identification.} - property OldTrapGen: Integer read FOldTrapGen write FOldTrapGen; - - {:Specific TRAPv1 identification.} - property OldTrapSpec: Integer read FOldTrapSpec write FOldTrapSpec; - - {:Number of 1/100th of seconds since last reboot or power up. (for TRAPv1)} - property OldTrapTimeTicks: Integer read FOldTrapTimeTicks write FOldTrapTimeTicks; - end; - - {:@abstract(Implementation of SNMP protocol.) - - Note: Are you missing properties for specify server address and port? Look to - parent @link(TSynaClient) too!} - TSNMPSend = class(TSynaClient) - protected - FSock: TUDPBlockSocket; - FBuffer: AnsiString; - FHostIP: AnsiString; - FQuery: TSNMPRec; - FReply: TSNMPRec; - function InternalSendSnmp(const Value: TSNMPRec): Boolean; - function InternalRecvSnmp(const Value: TSNMPRec): Boolean; - function InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean; - function GetV3EngineID: AnsiString; - function GetV3Sync: TV3Sync; - public - constructor Create; - destructor Destroy; override; - - {:Connects to a Host and send there query. If in timeout SNMP server send - back query, result is @true. If is used SNMPv3, then it synchronize self - with SNMPv3 agent first. (It is needed for SNMPv3 auhorization!)} - function SendRequest: Boolean; - - {:Send SNMP packet only, but not waits for reply. Good for sending traps.} - function SendTrap: Boolean; - - {:Receive SNMP packet only. Good for receiving traps.} - function RecvTrap: Boolean; - - {:Mapped to @link(SendRequest) internally. This function is only for - backward compatibility.} - function DoIt: Boolean; - published - {:contains raw binary form of SNMP packet. Good for debugging.} - property Buffer: AnsiString read FBuffer write FBuffer; - - {:After SNMP operation hold IP address of remote side.} - property HostIP: AnsiString read FHostIP; - - {:Data object contains SNMP query.} - property Query: TSNMPRec read FQuery; - - {:Data object contains SNMP reply.} - property Reply: TSNMPRec read FReply; - - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TUDPBlockSocket read FSock; - end; - -{:A very useful function and example of its use would be found in the TSNMPSend - object. It implements basic GET method of the SNMP protocol. The MIB value is - located in the "OID" variable, and is sent to the requested "SNMPHost" with - the proper "Community" access identifier. Upon a successful retrieval, "Value" - will contain the information requested. If the SNMP operation is successful, - the result returns @true.} -function SNMPGet(const OID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; - -{:This is useful function and example of use TSNMPSend object. It implements - the basic SET method of the SNMP protocol. If the SNMP operation is successful, - the result is @true. "Value" is value of MIB Oid for "SNMPHost" with "Community" - access identifier. You must specify "ValueType" too.} -function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; ValueType: Integer): Boolean; - -{:A very useful function and example of its use would be found in the TSNMPSend - object. It implements basic GETNEXT method of the SNMP protocol. The MIB value - is located in the "OID" variable, and is sent to the requested "SNMPHost" with - the proper "Community" access identifier. Upon a successful retrieval, "Value" - will contain the information requested. If the SNMP operation is successful, - the result returns @true.} -function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; - -{:A very useful function and example of its use would be found in the TSNMPSend - object. It implements basic read of SNMP MIB tables. As BaseOID you must - specify basic MIB OID of requested table (base IOD is OID without row and - column specificator!) - Table is readed into stringlist, where each string is comma delimited string. - - Warning: this function is not have best performance. For better performance - you must write your own function. best performace you can get by knowledge - of structuture of table and by more then one MIB on one query. } -function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean; - -{:A very useful function and example of its use would be found in the TSNMPSend - object. It implements basic read of SNMP MIB table element. As BaseOID you must - specify basic MIB OID of requested table (base IOD is OID without row and - column specificator!) - As next you must specify identificator of row and column for specify of needed - field of table.} -function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; - -{:A very useful function and example of its use would be found in the TSNMPSend - object. It implements a TRAPv1 to send with all data in the parameters.} -function SendTrap(const Dest, Source, Enterprise, Community: AnsiString; - Generic, Specific, Seconds: Integer; const MIBName, MIBValue: AnsiString; - MIBtype: Integer): Integer; - -{:A very useful function and example of its use would be found in the TSNMPSend - object. It receives a TRAPv1 and returns all the data that comes with it.} -function RecvTrap(var Dest, Source, Enterprise, Community: AnsiString; - var Generic, Specific, Seconds: Integer; const MIBName, - MIBValue: TStringList): Integer; - -implementation - -{==============================================================================} - -constructor TSNMPRec.Create; -begin - inherited Create; - FSNMPMibList := TList.Create; - Clear; - FID := 1; - FMaxSize := 1472; -end; - -destructor TSNMPRec.Destroy; -var - i: Integer; -begin - for i := 0 to FSNMPMibList.Count - 1 do - TSNMPMib(FSNMPMibList[i]).Free; - FSNMPMibList.Clear; - FSNMPMibList.Free; - inherited Destroy; -end; - -function TSNMPRec.Pass2Key(const Value: AnsiString): AnsiString; -var - key: AnsiString; -begin - case FAuthMode of - AuthMD5: - begin - key := MD5LongHash(Value, 1048576); - Result := MD5(key + FAuthEngineID + key); - end; - AuthSHA1: - begin - key := SHA1LongHash(Value, 1048576); - Result := SHA1(key + FAuthEngineID + key); - end; - else - Result := ''; - end; -end; - - -function TSNMPRec.DecodeBuf(const Buffer: AnsiString): Boolean; -var - Pos: Integer; - EndPos: Integer; - sm, sv: AnsiString; - Svt: Integer; - s: AnsiString; - Spos: integer; - x: Byte; -begin - Clear; - Result := False; - if Length(Buffer) < 2 then - Exit; - if (Ord(Buffer[1]) and $20) = 0 then - Exit; - Pos := 2; - EndPos := ASNDecLen(Pos, Buffer); - if Length(Buffer) < (EndPos + 2) then - Exit; - Self.FVersion := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); - - if FVersion = 3 then - begin - ASNItem(Pos, Buffer, Svt); //header data seq - ASNItem(Pos, Buffer, Svt); //ID - FMaxSize := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); - s := ASNItem(Pos, Buffer, Svt); - x := 0; - if s <> '' then - x := Ord(s[1]); - FFlagReportable := (x and 4) > 0; - x := x and 3; - case x of - 1: - FFlags := AuthNoPriv; - 3: - FFlags := AuthPriv; - else - FFlags := NoAuthNoPriv; - end; - - x := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); - s := ASNItem(Pos, Buffer, Svt); //SecurityParameters - //if SecurityModel is USM, then try to decode SecurityParameters - if (x = 3) and (s <> '') then - begin - spos := 1; - ASNItem(SPos, s, Svt); - FAuthEngineID := ASNItem(SPos, s, Svt); - FAuthEngineBoots := StrToIntDef(ASNItem(SPos, s, Svt), 0); - FAuthEngineTime := StrToIntDef(ASNItem(SPos, s, Svt), 0); - FAuthEngineTimeStamp := GetTick; - FUserName := ASNItem(SPos, s, Svt); - FAuthKey := ASNItem(SPos, s, Svt); - FPrivKey := ASNItem(SPos, s, Svt); - end; - //scopedPDU - s := ASNItem(Pos, Buffer, Svt); - if Svt = ASN1_OCTSTR then - begin - //decrypt! - end; - FContextEngineID := ASNItem(Pos, Buffer, Svt); - FContextName := ASNItem(Pos, Buffer, Svt); - end - else - begin - //old packet - Self.FCommunity := ASNItem(Pos, Buffer, Svt); - end; - - ASNItem(Pos, Buffer, Svt); - Self.FPDUType := Svt; - if Self.FPDUType = PDUTrap then - begin - FOldTrapEnterprise := ASNItem(Pos, Buffer, Svt); - FOldTrapHost := ASNItem(Pos, Buffer, Svt); - FOldTrapGen := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); - FOldTrapSpec := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); - FOldTrapTimeTicks := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); - end - else - begin - Self.FID := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); - Self.FErrorStatus := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); - Self.FErrorIndex := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); - end; - ASNItem(Pos, Buffer, Svt); - while Pos < EndPos do - begin - ASNItem(Pos, Buffer, Svt); - Sm := ASNItem(Pos, Buffer, Svt); - Sv := ASNItem(Pos, Buffer, Svt); - Self.MIBAdd(sm, sv, Svt); - end; - Result := True; -end; - -function TSNMPRec.EncodeBuf: AnsiString; -var - s: AnsiString; - SNMPMib: TSNMPMib; - n: Integer; - pdu, head, auth, authbeg: AnsiString; - x: Byte; -begin - pdu := ''; - for n := 0 to FSNMPMibList.Count - 1 do - begin - SNMPMib := TSNMPMib(FSNMPMibList[n]); - case SNMPMib.ValueType of - ASN1_INT: - s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + - ASNObject(ASNEncInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType); - ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS: - s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + - ASNObject(ASNEncUInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType); - ASN1_OBJID: - s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + - ASNObject(MibToID(SNMPMib.Value), SNMPMib.ValueType); - ASN1_IPADDR: - s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + - ASNObject(IPToID(SNMPMib.Value), SNMPMib.ValueType); - ASN1_NULL: - s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + - ASNObject('', ASN1_NULL); - else - s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + - ASNObject(SNMPMib.Value, SNMPMib.ValueType); - end; - pdu := pdu + ASNObject(s, ASN1_SEQ); - end; - pdu := ASNObject(pdu, ASN1_SEQ); - - if Self.FPDUType = PDUTrap then - pdu := ASNObject(MibToID(FOldTrapEnterprise), ASN1_OBJID) + - ASNObject(IPToID(FOldTrapHost), ASN1_IPADDR) + - ASNObject(ASNEncInt(FOldTrapGen), ASN1_INT) + - ASNObject(ASNEncInt(FOldTrapSpec), ASN1_INT) + - ASNObject(ASNEncUInt(FOldTrapTimeTicks), ASN1_TIMETICKS) + - pdu - else - pdu := ASNObject(ASNEncInt(Self.FID), ASN1_INT) + - ASNObject(ASNEncInt(Self.FErrorStatus), ASN1_INT) + - ASNObject(ASNEncInt(Self.FErrorIndex), ASN1_INT) + - pdu; - pdu := ASNObject(pdu, Self.FPDUType); - - if FVersion = 3 then - begin - if FContextEngineID = '' then - FContextEngineID := FAuthEngineID; - //complete PDUv3... - pdu := ASNObject(FContextEngineID, ASN1_OCTSTR) - + ASNObject(FContextName, ASN1_OCTSTR) - + pdu; - //maybe encrypt pdu... in future - pdu := ASNObject(pdu, ASN1_SEQ); - - //prepare flags - case FFlags of - AuthNoPriv: - x := 1; - AuthPriv: - x := 3; - else - x := 0; - end; - if FFlagReportable then - x := x or 4; - head := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT); - s := ASNObject(ASNEncInt(FID), ASN1_INT) - + ASNObject(ASNEncInt(FMaxSize), ASN1_INT) - + ASNObject(AnsiChar(x), ASN1_OCTSTR) - //encode security model USM - + ASNObject(ASNEncInt(3), ASN1_INT); - head := head + ASNObject(s, ASN1_SEQ); - - //compute engine time difference - x := TickDelta(FAuthEngineTimeStamp, GetTick) div 1000; - - authbeg := ASNObject(FAuthEngineID, ASN1_OCTSTR) - + ASNObject(ASNEncInt(FAuthEngineBoots), ASN1_INT) - + ASNObject(ASNEncInt(FAuthEngineTime + x), ASN1_INT) - + ASNObject(FUserName, ASN1_OCTSTR); - - - case FFlags of - AuthNoPriv, - AuthPriv: - begin - s := authbeg + ASNObject(StringOfChar(#0, 12), ASN1_OCTSTR) - + ASNObject(FPrivKey, ASN1_OCTSTR); - s := ASNObject(s, ASN1_SEQ); - s := head + ASNObject(s, ASN1_OCTSTR); - s := ASNObject(s + pdu, ASN1_SEQ); - //in s is entire packet without auth info... - case FAuthMode of - AuthMD5: - begin - s := HMAC_MD5(s, Pass2Key(FPassword) + StringOfChar(#0, 48)); - //strip to HMAC-MD5-96 - delete(s, 13, 4); - end; - AuthSHA1: - begin - s := HMAC_SHA1(s, Pass2Key(FPassword) + StringOfChar(#0, 44)); - //strip to HMAC-SHA-96 - delete(s, 13, 8); - end; - else - s := ''; - end; - FAuthKey := s; - end; - end; - - auth := authbeg + ASNObject(FAuthKey, ASN1_OCTSTR) - + ASNObject(FPrivKey, ASN1_OCTSTR); - auth := ASNObject(auth, ASN1_SEQ); - - head := head + ASNObject(auth, ASN1_OCTSTR); - Result := ASNObject(head + pdu, ASN1_SEQ); - end - else - begin - head := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT) + - ASNObject(Self.FCommunity, ASN1_OCTSTR); - Result := ASNObject(head + pdu, ASN1_SEQ); - end; - inc(self.FID); -end; - -procedure TSNMPRec.Clear; -var - i: Integer; -begin - FVersion := SNMP_V1; - FCommunity := 'public'; - FUserName := ''; - FPassword := ''; - FPDUType := 0; - FErrorStatus := 0; - FErrorIndex := 0; - for i := 0 to FSNMPMibList.Count - 1 do - TSNMPMib(FSNMPMibList[i]).Free; - FSNMPMibList.Clear; - FOldTrapEnterprise := ''; - FOldTrapHost := ''; - FOldTrapGen := 0; - FOldTrapSpec := 0; - FOldTrapTimeTicks := 0; - FFlags := NoAuthNoPriv; - FFlagReportable := false; - FContextEngineID := ''; - FContextName := ''; - FAuthMode := AuthMD5; - FAuthEngineID := ''; - FAuthEngineBoots := 0; - FAuthEngineTime := 0; - FAuthEngineTimeStamp := 0; - FAuthKey := ''; - FPrivKey := ''; -end; - -procedure TSNMPRec.MIBAdd(const MIB, Value: AnsiString; ValueType: Integer); -var - SNMPMib: TSNMPMib; -begin - SNMPMib := TSNMPMib.Create; - SNMPMib.OID := MIB; - SNMPMib.Value := Value; - SNMPMib.ValueType := ValueType; - FSNMPMibList.Add(SNMPMib); -end; - -procedure TSNMPRec.MIBDelete(Index: Integer); -begin - if (Index >= 0) and (Index < MIBCount) then - begin - TSNMPMib(FSNMPMibList[Index]).Free; - FSNMPMibList.Delete(Index); - end; -end; - -function TSNMPRec.MIBCount: integer; -begin - Result := FSNMPMibList.Count; -end; - -function TSNMPRec.MIBByIndex(Index: Integer): TSNMPMib; -begin - Result := nil; - if (Index >= 0) and (Index < MIBCount) then - Result := TSNMPMib(FSNMPMibList[Index]); -end; - -function TSNMPRec.MIBGet(const MIB: AnsiString): AnsiString; -var - i: Integer; -begin - Result := ''; - for i := 0 to MIBCount - 1 do - begin - if ((TSNMPMib(FSNMPMibList[i])).OID = MIB) then - begin - Result := (TSNMPMib(FSNMPMibList[i])).Value; - Break; - end; - end; -end; - -{==============================================================================} - -constructor TSNMPSend.Create; -begin - inherited Create; - FQuery := TSNMPRec.Create; - FReply := TSNMPRec.Create; - FQuery.Clear; - FReply.Clear; - FSock := TUDPBlockSocket.Create; - FSock.Owner := self; - FTimeout := 5000; - FTargetPort := cSnmpProtocol; - FHostIP := ''; -end; - -destructor TSNMPSend.Destroy; -begin - FSock.Free; - FReply.Free; - FQuery.Free; - inherited Destroy; -end; - -function TSNMPSend.InternalSendSnmp(const Value: TSNMPRec): Boolean; -begin - FBuffer := Value.EncodeBuf; - FSock.SendString(FBuffer); - Result := FSock.LastError = 0; -end; - -function TSNMPSend.InternalRecvSnmp(const Value: TSNMPRec): Boolean; -begin - Result := False; - FReply.Clear; - FHostIP := cAnyHost; - FBuffer := FSock.RecvPacket(FTimeout); - if FSock.LastError = 0 then - begin - FHostIP := FSock.GetRemoteSinIP; - Result := Value.DecodeBuf(FBuffer); - end; -end; - -function TSNMPSend.InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean; -begin - Result := False; - FSock.Bind(FIPInterface, cAnyPort); - FSock.Connect(FTargetHost, FTargetPort); - if InternalSendSnmp(QValue) then - Result := InternalRecvSnmp(RValue); -end; - -function TSNMPSend.SendRequest: Boolean; -var - sync: TV3Sync; -begin - Result := False; - if FQuery.FVersion = 3 then - begin - sync := GetV3Sync; - FQuery.AuthEngineBoots := Sync.EngineBoots; - FQuery.AuthEngineTime := Sync.EngineTime; - FQuery.AuthEngineTimeStamp := Sync.EngineStamp; - FQuery.AuthEngineID := Sync.EngineID; - end; - FSock.Bind(FIPInterface, cAnyPort); - FSock.Connect(FTargetHost, FTargetPort); - if InternalSendSnmp(FQuery) then - Result := InternalRecvSnmp(FReply); -end; - -function TSNMPSend.SendTrap: Boolean; -begin - FSock.Bind(FIPInterface, cAnyPort); - FSock.Connect(FTargetHost, FTargetPort); - Result := InternalSendSnmp(FQuery); -end; - -function TSNMPSend.RecvTrap: Boolean; -begin - FSock.Bind(FIPInterface, FTargetPort); - Result := InternalRecvSnmp(FReply); -end; - -function TSNMPSend.DoIt: Boolean; -begin - Result := SendRequest; -end; - -function TSNMPSend.GetV3EngineID: AnsiString; -var - DisQuery: TSNMPRec; -begin - Result := ''; - DisQuery := TSNMPRec.Create; - try - DisQuery.Version := 3; - DisQuery.UserName := ''; - DisQuery.FlagReportable := True; - DisQuery.PDUType := PDUGetRequest; - if InternalSendRequest(DisQuery, FReply) then - Result := FReply.FAuthEngineID; - finally - DisQuery.Free; - end; -end; - -function TSNMPSend.GetV3Sync: TV3Sync; -var - SyncQuery: TSNMPRec; -begin - Result.EngineID := GetV3EngineID; - Result.EngineBoots := FReply.AuthEngineBoots; - Result.EngineTime := FReply.AuthEngineTime; - Result.EngineStamp := FReply.AuthEngineTimeStamp; - if Result.EngineTime = 0 then - begin - //still not have sync... - SyncQuery := TSNMPRec.Create; - try - SyncQuery.Version := 3; - SyncQuery.UserName := FQuery.UserName; - SyncQuery.Password := FQuery.Password; - SyncQuery.FlagReportable := True; - SyncQuery.Flags := FQuery.Flags; - SyncQuery.PDUType := PDUGetRequest; - SyncQuery.AuthEngineID := FReply.FAuthEngineID; - if InternalSendRequest(SyncQuery, FReply) then - begin - Result.EngineBoots := FReply.AuthEngineBoots; - Result.EngineTime := FReply.AuthEngineTime; - Result.EngineStamp := FReply.AuthEngineTimeStamp; - end; - finally - SyncQuery.Free; - end; - end; -end; - -{==============================================================================} - -function SNMPGet(const OID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; -var - SNMPSend: TSNMPSend; -begin - SNMPSend := TSNMPSend.Create; - try - SNMPSend.Query.Clear; - SNMPSend.Query.Community := Community; - SNMPSend.Query.PDUType := PDUGetRequest; - SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL); - SNMPSend.TargetHost := SNMPHost; - Result := SNMPSend.SendRequest; - Value := ''; - if Result then - Value := SNMPSend.Reply.MIBGet(OID); - finally - SNMPSend.Free; - end; -end; - -function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; ValueType: Integer): Boolean; -var - SNMPSend: TSNMPSend; -begin - SNMPSend := TSNMPSend.Create; - try - SNMPSend.Query.Clear; - SNMPSend.Query.Community := Community; - SNMPSend.Query.PDUType := PDUSetRequest; - SNMPSend.Query.MIBAdd(OID, Value, ValueType); - SNMPSend.TargetHost := SNMPHost; - Result := SNMPSend.Sendrequest = True; - finally - SNMPSend.Free; - end; -end; - -function InternalGetNext(const SNMPSend: TSNMPSend; var OID: AnsiString; - const Community: AnsiString; var Value: AnsiString): Boolean; -begin - SNMPSend.Query.Clear; - SNMPSend.Query.ID := SNMPSend.Query.ID + 1; - SNMPSend.Query.Community := Community; - SNMPSend.Query.PDUType := PDUGetNextRequest; - SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL); - Result := SNMPSend.Sendrequest; - Value := ''; - if Result then - if SNMPSend.Reply.SNMPMibList.Count > 0 then - begin - OID := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).OID; - Value := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).Value; - end; -end; - -function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; -var - SNMPSend: TSNMPSend; -begin - SNMPSend := TSNMPSend.Create; - try - SNMPSend.TargetHost := SNMPHost; - Result := InternalGetNext(SNMPSend, OID, Community, Value); - finally - SNMPSend.Free; - end; -end; - -function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean; -var - OID: AnsiString; - s: AnsiString; - col,row: String; - x: integer; - SNMPSend: TSNMPSend; - RowList: TStringList; -begin - Value.Clear; - SNMPSend := TSNMPSend.Create; - RowList := TStringList.Create; - try - SNMPSend.TargetHost := SNMPHost; - OID := BaseOID; - repeat - Result := InternalGetNext(SNMPSend, OID, Community, s); - if Pos(BaseOID, OID) <> 1 then - break; - row := separateright(oid, baseoid + '.'); - col := fetch(row, '.'); - - if IsBinaryString(s) then - s := StrToHex(s); - x := RowList.indexOf(Row); - if x < 0 then - begin - x := RowList.add(Row); - Value.Add(''); - end; - if (Value[x] <> '') then - Value[x] := Value[x] + ','; - Value[x] := Value[x] + AnsiQuotedStr(s, '"'); - until not result; - finally - SNMPSend.Free; - RowList.Free; - end; -end; - -function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; -var - s: AnsiString; -begin - s := BaseOID + '.' + ColID + '.' + RowID; - Result := SnmpGet(s, Community, SNMPHost, Value); -end; - -function SendTrap(const Dest, Source, Enterprise, Community: AnsiString; - Generic, Specific, Seconds: Integer; const MIBName, MIBValue: AnsiString; - MIBtype: Integer): Integer; -var - SNMPSend: TSNMPSend; -begin - SNMPSend := TSNMPSend.Create; - try - SNMPSend.TargetHost := Dest; - SNMPSend.TargetPort := cSnmpTrapProtocol; - SNMPSend.Query.Community := Community; - SNMPSend.Query.Version := SNMP_V1; - SNMPSend.Query.PDUType := PDUTrap; - SNMPSend.Query.OldTrapHost := Source; - SNMPSend.Query.OldTrapEnterprise := Enterprise; - SNMPSend.Query.OldTrapGen := Generic; - SNMPSend.Query.OldTrapSpec := Specific; - SNMPSend.Query.OldTrapTimeTicks := Seconds; - SNMPSend.Query.MIBAdd(MIBName, MIBValue, MIBType); - Result := Ord(SNMPSend.SendTrap); - finally - SNMPSend.Free; - end; -end; - -function RecvTrap(var Dest, Source, Enterprise, Community: AnsiString; - var Generic, Specific, Seconds: Integer; - const MIBName, MIBValue: TStringList): Integer; -var - SNMPSend: TSNMPSend; - i: Integer; -begin - SNMPSend := TSNMPSend.Create; - try - Result := 0; - SNMPSend.TargetPort := cSnmpTrapProtocol; - if SNMPSend.RecvTrap then - begin - Result := 1; - Dest := SNMPSend.HostIP; - Community := SNMPSend.Reply.Community; - Source := SNMPSend.Reply.OldTrapHost; - Enterprise := SNMPSend.Reply.OldTrapEnterprise; - Generic := SNMPSend.Reply.OldTrapGen; - Specific := SNMPSend.Reply.OldTrapSpec; - Seconds := SNMPSend.Reply.OldTrapTimeTicks; - MIBName.Clear; - MIBValue.Clear; - for i := 0 to SNMPSend.Reply.SNMPMibList.Count - 1 do - begin - MIBName.Add(TSNMPMib(SNMPSend.Reply.SNMPMibList[i]).OID); - MIBValue.Add(TSNMPMib(SNMPSend.Reply.SNMPMibList[i]).Value); - end; - end; - finally - SNMPSend.Free; - end; -end; - - -end. - - diff --git a/addons/synapse/sntpsend.pas b/addons/synapse/sntpsend.pas deleted file mode 100644 index 4aa0bbf..0000000 --- a/addons/synapse/sntpsend.pas +++ /dev/null @@ -1,374 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 003.000.003 | -|==============================================================================| -| Content: SNTP client | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Patrick Chevalley | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract( NTP and SNTP client) - -Used RFC: RFC-1305, RFC-2030 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -unit sntpsend; - -interface - -uses - SysUtils, - synsock, blcksock, synautil; - -const - cNtpProtocol = '123'; - -type - - {:@abstract(Record containing the NTP packet.)} - TNtp = packed record - mode: Byte; - stratum: Byte; - poll: Byte; - Precision: Byte; - RootDelay: Longint; - RootDisperson: Longint; - RefID: Longint; - Ref1: Longint; - Ref2: Longint; - Org1: Longint; - Org2: Longint; - Rcv1: Longint; - Rcv2: Longint; - Xmit1: Longint; - Xmit2: Longint; - end; - - {:@abstract(Implementation of NTP and SNTP client protocol), - include time synchronisation. It can send NTP or SNTP time queries, or it - can receive NTP broadcasts too. - - Note: Are you missing properties for specify server address and port? Look to - parent @link(TSynaClient) too!} - TSNTPSend = class(TSynaClient) - private - FNTPReply: TNtp; - FNTPTime: TDateTime; - FNTPOffset: double; - FNTPDelay: double; - FMaxSyncDiff: double; - FSyncTime: Boolean; - FSock: TUDPBlockSocket; - FBuffer: AnsiString; - FLi, FVn, Fmode : byte; - function StrToNTP(const Value: AnsiString): TNtp; - function NTPtoStr(const Value: Tntp): AnsiString; - procedure ClearNTP(var Value: Tntp); - public - constructor Create; - destructor Destroy; override; - - {:Decode 128 bit timestamp used in NTP packet to TDateTime type.} - function DecodeTs(Nsec, Nfrac: Longint): TDateTime; - - {:Decode TDateTime type to 128 bit timestamp used in NTP packet.} - procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); - - {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all - is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are - valid.} - function GetSNTP: Boolean; - - {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all - is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are - valid. Result time is after all needed corrections.} - function GetNTP: Boolean; - - {:Wait for broadcast NTP packet. If all OK, result is @true and - @link(NTPReply) and @link(NTPTime) are valid.} - function GetBroadcastNTP: Boolean; - - {:Holds last received NTP packet.} - property NTPReply: TNtp read FNTPReply; - published - {:Date and time of remote NTP or SNTP server. (UTC time!!!)} - property NTPTime: TDateTime read FNTPTime; - - {:Offset between your computer and remote NTP or SNTP server.} - property NTPOffset: Double read FNTPOffset; - - {:Delay between your computer and remote NTP or SNTP server.} - property NTPDelay: Double read FNTPDelay; - - {:Define allowed maximum difference between your time and remote time for - synchronising time. If difference is bigger, your system time is not - changed!} - property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff; - - {:If @true, after successfull getting time is local computer clock - synchronised to given time. - For synchronising time you must have proper rights! (Usually Administrator)} - property SyncTime: Boolean read FSyncTime write FSyncTime; - - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TUDPBlockSocket read FSock; - end; - -implementation - -constructor TSNTPSend.Create; -begin - inherited Create; - FSock := TUDPBlockSocket.Create; - FSock.Owner := self; - FTimeout := 5000; - FTargetPort := cNtpProtocol; - FMaxSyncDiff := 3600; - FSyncTime := False; -end; - -destructor TSNTPSend.Destroy; -begin - FSock.Free; - inherited Destroy; -end; - -function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp; -begin - if length(FBuffer) >= SizeOf(Result) then - begin - Result.mode := ord(Value[1]); - Result.stratum := ord(Value[2]); - Result.poll := ord(Value[3]); - Result.Precision := ord(Value[4]); - Result.RootDelay := DecodeLongInt(value, 5); - Result.RootDisperson := DecodeLongInt(value, 9); - Result.RefID := DecodeLongInt(value, 13); - Result.Ref1 := DecodeLongInt(value, 17); - Result.Ref2 := DecodeLongInt(value, 21); - Result.Org1 := DecodeLongInt(value, 25); - Result.Org2 := DecodeLongInt(value, 29); - Result.Rcv1 := DecodeLongInt(value, 33); - Result.Rcv2 := DecodeLongInt(value, 37); - Result.Xmit1 := DecodeLongInt(value, 41); - Result.Xmit2 := DecodeLongInt(value, 45); - end; - -end; - -function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString; -begin - SetLength(Result, 4); - Result[1] := AnsiChar(Value.mode); - Result[2] := AnsiChar(Value.stratum); - Result[3] := AnsiChar(Value.poll); - Result[4] := AnsiChar(Value.precision); - Result := Result + CodeLongInt(Value.RootDelay); - Result := Result + CodeLongInt(Value.RootDisperson); - Result := Result + CodeLongInt(Value.RefID); - Result := Result + CodeLongInt(Value.Ref1); - Result := Result + CodeLongInt(Value.Ref2); - Result := Result + CodeLongInt(Value.Org1); - Result := Result + CodeLongInt(Value.Org2); - Result := Result + CodeLongInt(Value.Rcv1); - Result := Result + CodeLongInt(Value.Rcv2); - Result := Result + CodeLongInt(Value.Xmit1); - Result := Result + CodeLongInt(Value.Xmit2); -end; - -procedure TSNTPSend.ClearNTP(var Value: Tntp); -begin - Value.mode := 0; - Value.stratum := 0; - Value.poll := 0; - Value.Precision := 0; - Value.RootDelay := 0; - Value.RootDisperson := 0; - Value.RefID := 0; - Value.Ref1 := 0; - Value.Ref2 := 0; - Value.Org1 := 0; - Value.Org2 := 0; - Value.Rcv1 := 0; - Value.Rcv2 := 0; - Value.Xmit1 := 0; - Value.Xmit2 := 0; -end; - -function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime; -const - maxi = 4294967295.0; -var - d, d1: Double; -begin - d := Nsec; - if d < 0 then - d := maxi + d + 1; - d1 := Nfrac; - if d1 < 0 then - d1 := maxi + d1 + 1; - d1 := d1 / maxi; - d1 := Trunc(d1 * 10000) / 10000; - Result := (d + d1) / 86400; - Result := Result + 2; -end; - -procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); -const - maxi = 4294967295.0; - maxilongint = 2147483647; -var - d, d1: Double; -begin - d := (dt - 2) * 86400; - d1 := frac(d); - if d > maxilongint then - d := d - maxi - 1; - d := trunc(d); - d1 := Trunc(d1 * 10000) / 10000; - d1 := d1 * maxi; - if d1 > maxilongint then - d1 := d1 - maxi - 1; - Nsec:=trunc(d); - Nfrac:=trunc(d1); -end; - -function TSNTPSend.GetBroadcastNTP: Boolean; -var - x: Integer; -begin - Result := False; - FSock.Bind(FIPInterface, FTargetPort); - FBuffer := FSock.RecvPacket(FTimeout); - if FSock.LastError = 0 then - begin - x := Length(FBuffer); - if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then - if x >= SizeOf(NTPReply) then - begin - FNTPReply := StrToNTP(FBuffer); - FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); - if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then - SetUTTime(FNTPTime); - Result := True; - end; - end; -end; - -function TSNTPSend.GetSNTP: Boolean; -var - q: TNtp; - x: Integer; -begin - Result := False; - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - FSock.Connect(FTargetHost, FTargetPort); - ClearNtp(q); - q.mode := $1B; - FBuffer := NTPtoStr(q); - FSock.SendString(FBuffer); - FBuffer := FSock.RecvPacket(FTimeout); - if FSock.LastError = 0 then - begin - x := Length(FBuffer); - if x >= SizeOf(NTPReply) then - begin - FNTPReply := StrToNTP(FBuffer); - FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); - if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then - SetUTTime(FNTPTime); - Result := True; - end; - end; -end; - -function TSNTPSend.GetNTP: Boolean; -var - q: TNtp; - x: Integer; - t1, t2, t3, t4 : TDateTime; -begin - Result := False; - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - FSock.Connect(FTargetHost, FTargetPort); - ClearNtp(q); - q.mode := $1B; - t1 := GetUTTime; - EncodeTs(t1, q.org1, q.org2); - FBuffer := NTPtoStr(q); - FSock.SendString(FBuffer); - FBuffer := FSock.RecvPacket(FTimeout); - if FSock.LastError = 0 then - begin - x := Length(FBuffer); - t4 := GetUTTime; - if x >= SizeOf(NTPReply) then - begin - FNTPReply := StrToNTP(FBuffer); - FLi := (NTPReply.mode and $C0) shr 6; - FVn := (NTPReply.mode and $38) shr 3; - Fmode := NTPReply.mode and $07; - if (Fli < 3) and (Fmode = 4) and - (NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and - (NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0) - then begin - t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2); - t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); - FNTPDelay := (T4 - T1) - (T2 - T3); - FNTPTime := t3 + FNTPDelay / 2; - FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400; - FNTPDelay := FNTPDelay * 86400; - if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then - SetUTTime(FNTPTime); - Result := True; - end - else result:=false; - end; - end; -end; - -end. diff --git a/addons/synapse/ssdotnet.pas b/addons/synapse/ssdotnet.pas deleted file mode 100644 index 8a54cd8..0000000 --- a/addons/synapse/ssdotnet.pas +++ /dev/null @@ -1,1099 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.000.002 | -|==============================================================================| -| Content: Socket Independent Platform Layer - .NET definition include | -|==============================================================================| -| Copyright (c)2004, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2004. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@exclude} - -{$IFDEF CIL} - -interface - -uses - SyncObjs, SysUtils, Classes, - System.Net, - System.Net.Sockets; - -const - DLLStackName = ''; - WinsockLevel = $0202; - -function InitSocketInterface(stack: string): Boolean; -function DestroySocketInterface: Boolean; - -type - u_char = Char; - u_short = Word; - u_int = Integer; - u_long = Longint; - pu_long = ^u_long; - pu_short = ^u_short; - PSockAddr = IPEndPoint; - DWORD = integer; - ULong = cardinal; - TMemory = Array of byte; - TLinger = LingerOption; - TSocket = socket; - TAddrFamily = AddressFamily; - -const - WSADESCRIPTION_LEN = 256; - WSASYS_STATUS_LEN = 128; -type - PWSAData = ^TWSAData; - TWSAData = packed record - wVersion: Word; - wHighVersion: Word; - szDescription: array[0..WSADESCRIPTION_LEN] of Char; - szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; - iMaxSockets: Word; - iMaxUdpDg: Word; -// lpVendorInfo: PChar; - end; - -const - MSG_NOSIGNAL = 0; - INVALID_SOCKET = nil; - AF_UNSPEC = AddressFamily.Unspecified; - AF_INET = AddressFamily.InterNetwork; - AF_INET6 = AddressFamily.InterNetworkV6; - SOCKET_ERROR = integer(-1); - - FIONREAD = integer($4004667f); - FIONBIO = integer($8004667e); - FIOASYNC = integer($8004667d); - - SOMAXCONN = integer($7fffffff); - - IPPROTO_IP = ProtocolType.IP; - IPPROTO_ICMP = ProtocolType.Icmp; - IPPROTO_IGMP = ProtocolType.Igmp; - IPPROTO_TCP = ProtocolType.Tcp; - IPPROTO_UDP = ProtocolType.Udp; - IPPROTO_RAW = ProtocolType.Raw; - IPPROTO_IPV6 = ProtocolType.IPV6; -// - IPPROTO_ICMPV6 = ProtocolType.Icmp; //?? - - SOCK_STREAM = SocketType.Stream; - SOCK_DGRAM = SocketType.Dgram; - SOCK_RAW = SocketType.Raw; - SOCK_RDM = SocketType.Rdm; - SOCK_SEQPACKET = SocketType.Seqpacket; - - SOL_SOCKET = SocketOptionLevel.Socket; - SOL_IP = SocketOptionLevel.Ip; - - - IP_OPTIONS = SocketOptionName.IPOptions; - IP_HDRINCL = SocketOptionName.HeaderIncluded; - IP_TOS = SocketOptionName.TypeOfService; { set/get IP Type Of Service } - IP_TTL = SocketOptionName.IpTimeToLive; { set/get IP Time To Live } - IP_MULTICAST_IF = SocketOptionName.MulticastInterface; { set/get IP multicast interface } - IP_MULTICAST_TTL = SocketOptionName.MulticastTimeToLive; { set/get IP multicast timetolive } - IP_MULTICAST_LOOP = SocketOptionName.MulticastLoopback; { set/get IP multicast loopback } - IP_ADD_MEMBERSHIP = SocketOptionName.AddMembership; { add an IP group membership } - IP_DROP_MEMBERSHIP = SocketOptionName.DropMembership; { drop an IP group membership } - IP_DONTFRAGMENT = SocketOptionName.DontFragment; { set/get IP Don't Fragment flag } - - IPV6_UNICAST_HOPS = 8; // TTL - IPV6_MULTICAST_IF = 9; // set/get IP multicast i/f - IPV6_MULTICAST_HOPS = 10; // set/get IP multicast ttl - IPV6_MULTICAST_LOOP = 11; // set/get IP multicast loopback - IPV6_JOIN_GROUP = 12; // add an IP group membership - IPV6_LEAVE_GROUP = 13; // drop an IP group membership - - SO_DEBUG = SocketOptionName.Debug; { turn on debugging info recording } - SO_ACCEPTCONN = SocketOptionName.AcceptConnection; { socket has had listen() } - SO_REUSEADDR = SocketOptionName.ReuseAddress; { allow local address reuse } - SO_KEEPALIVE = SocketOptionName.KeepAlive; { keep connections alive } - SO_DONTROUTE = SocketOptionName.DontRoute; { just use interface addresses } - SO_BROADCAST = SocketOptionName.Broadcast; { permit sending of broadcast msgs } - SO_USELOOPBACK = SocketOptionName.UseLoopback; { bypass hardware when possible } - SO_LINGER = SocketOptionName.Linger; { linger on close if data present } - SO_OOBINLINE = SocketOptionName.OutOfBandInline; { leave received OOB data in line } - SO_DONTLINGER = SocketOptionName.DontLinger; -{ Additional options. } - SO_SNDBUF = SocketOptionName.SendBuffer; { send buffer size } - SO_RCVBUF = SocketOptionName.ReceiveBuffer; { receive buffer size } - SO_SNDLOWAT = SocketOptionName.SendLowWater; { send low-water mark } - SO_RCVLOWAT = SocketOptionName.ReceiveLowWater; { receive low-water mark } - SO_SNDTIMEO = SocketOptionName.SendTimeout; { send timeout } - SO_RCVTIMEO = SocketOptionName.ReceiveTimeout; { receive timeout } - SO_ERROR = SocketOptionName.Error; { get error status and clear } - SO_TYPE = SocketOptionName.Type; { get socket type } - -{ WinSock 2 extension -- new options } -// SO_GROUP_ID = $2001; { ID of a socket group} -// SO_GROUP_PRIORITY = $2002; { the relative priority within a group} -// SO_MAX_MSG_SIZE = $2003; { maximum message size } -// SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure } -// SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure } -// SO_PROTOCOL_INFO = SO_PROTOCOL_INFOA; -// PVD_CONFIG = $3001; {configuration info for service provider } -{ Option for opening sockets for synchronous access. } -// SO_OPENTYPE = $7008; -// SO_SYNCHRONOUS_ALERT = $10; -// SO_SYNCHRONOUS_NONALERT = $20; -{ Other NT-specific options. } -// SO_MAXDG = $7009; -// SO_MAXPATHDG = $700A; -// SO_UPDATE_ACCEPT_CONTEXT = $700B; -// SO_CONNECT_TIME = $700C; - - - { All Windows Sockets error constants are biased by WSABASEERR from the "normal" } - WSABASEERR = 10000; - -{ Windows Sockets definitions of regular Microsoft C error constants } - - WSAEINTR = (WSABASEERR+4); - WSAEBADF = (WSABASEERR+9); - WSAEACCES = (WSABASEERR+13); - WSAEFAULT = (WSABASEERR+14); - WSAEINVAL = (WSABASEERR+22); - WSAEMFILE = (WSABASEERR+24); - -{ Windows Sockets definitions of regular Berkeley error constants } - - WSAEWOULDBLOCK = (WSABASEERR+35); - WSAEINPROGRESS = (WSABASEERR+36); - WSAEALREADY = (WSABASEERR+37); - WSAENOTSOCK = (WSABASEERR+38); - WSAEDESTADDRREQ = (WSABASEERR+39); - WSAEMSGSIZE = (WSABASEERR+40); - WSAEPROTOTYPE = (WSABASEERR+41); - WSAENOPROTOOPT = (WSABASEERR+42); - WSAEPROTONOSUPPORT = (WSABASEERR+43); - WSAESOCKTNOSUPPORT = (WSABASEERR+44); - WSAEOPNOTSUPP = (WSABASEERR+45); - WSAEPFNOSUPPORT = (WSABASEERR+46); - WSAEAFNOSUPPORT = (WSABASEERR+47); - WSAEADDRINUSE = (WSABASEERR+48); - WSAEADDRNOTAVAIL = (WSABASEERR+49); - WSAENETDOWN = (WSABASEERR+50); - WSAENETUNREACH = (WSABASEERR+51); - WSAENETRESET = (WSABASEERR+52); - WSAECONNABORTED = (WSABASEERR+53); - WSAECONNRESET = (WSABASEERR+54); - WSAENOBUFS = (WSABASEERR+55); - WSAEISCONN = (WSABASEERR+56); - WSAENOTCONN = (WSABASEERR+57); - WSAESHUTDOWN = (WSABASEERR+58); - WSAETOOMANYREFS = (WSABASEERR+59); - WSAETIMEDOUT = (WSABASEERR+60); - WSAECONNREFUSED = (WSABASEERR+61); - WSAELOOP = (WSABASEERR+62); - WSAENAMETOOLONG = (WSABASEERR+63); - WSAEHOSTDOWN = (WSABASEERR+64); - WSAEHOSTUNREACH = (WSABASEERR+65); - WSAENOTEMPTY = (WSABASEERR+66); - WSAEPROCLIM = (WSABASEERR+67); - WSAEUSERS = (WSABASEERR+68); - WSAEDQUOT = (WSABASEERR+69); - WSAESTALE = (WSABASEERR+70); - WSAEREMOTE = (WSABASEERR+71); - -{ Extended Windows Sockets error constant definitions } - - WSASYSNOTREADY = (WSABASEERR+91); - WSAVERNOTSUPPORTED = (WSABASEERR+92); - WSANOTINITIALISED = (WSABASEERR+93); - WSAEDISCON = (WSABASEERR+101); - WSAENOMORE = (WSABASEERR+102); - WSAECANCELLED = (WSABASEERR+103); - WSAEEINVALIDPROCTABLE = (WSABASEERR+104); - WSAEINVALIDPROVIDER = (WSABASEERR+105); - WSAEPROVIDERFAILEDINIT = (WSABASEERR+106); - WSASYSCALLFAILURE = (WSABASEERR+107); - WSASERVICE_NOT_FOUND = (WSABASEERR+108); - WSATYPE_NOT_FOUND = (WSABASEERR+109); - WSA_E_NO_MORE = (WSABASEERR+110); - WSA_E_CANCELLED = (WSABASEERR+111); - WSAEREFUSED = (WSABASEERR+112); - -{ Error return codes from gethostbyname() and gethostbyaddr() - (when using the resolver). Note that these errors are - retrieved via WSAGetLastError() and must therefore follow - the rules for avoiding clashes with error numbers from - specific implementations or language run-time systems. - For this reason the codes are based at WSABASEERR+1001. - Note also that [WSA]NO_ADDRESS is defined only for - compatibility purposes. } - -{ Authoritative Answer: Host not found } - WSAHOST_NOT_FOUND = (WSABASEERR+1001); - HOST_NOT_FOUND = WSAHOST_NOT_FOUND; -{ Non-Authoritative: Host not found, or SERVERFAIL } - WSATRY_AGAIN = (WSABASEERR+1002); - TRY_AGAIN = WSATRY_AGAIN; -{ Non recoverable errors, FORMERR, REFUSED, NOTIMP } - WSANO_RECOVERY = (WSABASEERR+1003); - NO_RECOVERY = WSANO_RECOVERY; -{ Valid name, no data record of requested type } - WSANO_DATA = (WSABASEERR+1004); - NO_DATA = WSANO_DATA; -{ no address, look for MX record } - WSANO_ADDRESS = WSANO_DATA; - NO_ADDRESS = WSANO_ADDRESS; - - EWOULDBLOCK = WSAEWOULDBLOCK; - EINPROGRESS = WSAEINPROGRESS; - EALREADY = WSAEALREADY; - ENOTSOCK = WSAENOTSOCK; - EDESTADDRREQ = WSAEDESTADDRREQ; - EMSGSIZE = WSAEMSGSIZE; - EPROTOTYPE = WSAEPROTOTYPE; - ENOPROTOOPT = WSAENOPROTOOPT; - EPROTONOSUPPORT = WSAEPROTONOSUPPORT; - ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT; - EOPNOTSUPP = WSAEOPNOTSUPP; - EPFNOSUPPORT = WSAEPFNOSUPPORT; - EAFNOSUPPORT = WSAEAFNOSUPPORT; - EADDRINUSE = WSAEADDRINUSE; - EADDRNOTAVAIL = WSAEADDRNOTAVAIL; - ENETDOWN = WSAENETDOWN; - ENETUNREACH = WSAENETUNREACH; - ENETRESET = WSAENETRESET; - ECONNABORTED = WSAECONNABORTED; - ECONNRESET = WSAECONNRESET; - ENOBUFS = WSAENOBUFS; - EISCONN = WSAEISCONN; - ENOTCONN = WSAENOTCONN; - ESHUTDOWN = WSAESHUTDOWN; - ETOOMANYREFS = WSAETOOMANYREFS; - ETIMEDOUT = WSAETIMEDOUT; - ECONNREFUSED = WSAECONNREFUSED; - ELOOP = WSAELOOP; - ENAMETOOLONG = WSAENAMETOOLONG; - EHOSTDOWN = WSAEHOSTDOWN; - EHOSTUNREACH = WSAEHOSTUNREACH; - ENOTEMPTY = WSAENOTEMPTY; - EPROCLIM = WSAEPROCLIM; - EUSERS = WSAEUSERS; - EDQUOT = WSAEDQUOT; - ESTALE = WSAESTALE; - EREMOTE = WSAEREMOTE; - - -type - TVarSin = IPEndpoint; - -{ function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; - function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; - function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; - function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; - function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; - function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; - procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); - procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); -var - in6addr_any, in6addr_loopback : TInAddr6; -} - -{procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); -function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; -procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); -procedure FD_ZERO(var FDSet: TFDSet); -} -{=============================================================================} - - function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; - function WSACleanup: Integer; - function WSAGetLastError: Integer; - function WSAGetLastErrorDesc: String; - function GetHostName: string; - function Shutdown(s: TSocket; how: Integer): Integer; -// function SetSockOpt(s: TSocket; level, optname: Integer; optval: PChar; -// optlen: Integer): Integer; - function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; - optlen: Integer): Integer; - function SetSockOptObj(s: TSocket; level, optname: Integer; optval: TObject): Integer; - function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; - var optlen: Integer): Integer; -// function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; -// tolen: Integer): Integer; -/// function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: TVarSin): Integer; -/// function Send(s: TSocket; const Buf; len, flags: Integer): Integer; -/// function Recv(s: TSocket; var Buf; len, flags: Integer): Integer; -// function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; -// var fromlen: Integer): Integer; -/// function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: TVarSin): Integer; -function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; -function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; - function ntohs(netshort: u_short): u_short; - function ntohl(netlong: u_long): u_long; - function Listen(s: TSocket; backlog: Integer): Integer; - function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; - function htons(hostshort: u_short): u_short; - function htonl(hostlong: u_long): u_long; -// function GetSockName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; - function GetSockName(s: TSocket; var name: TVarSin): Integer; -// function GetPeerName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; - function GetPeerName(s: TSocket; var name: TVarSin): Integer; -// function Connect(s: TSocket; name: PSockAddr; namelen: Integer): Integer; - function Connect(s: TSocket; const name: TVarSin): Integer; - function CloseSocket(s: TSocket): Integer; -// function Bind(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; - function Bind(s: TSocket; const addr: TVarSin): Integer; -// function Accept(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; - function Accept(s: TSocket; var addr: TVarSin): TSocket; - function Socket(af, Struc, Protocol: Integer): TSocket; -// Select = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; -// timeout: PTimeVal): Longint; -// {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF}; - -// TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; -// cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; -// lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; -// lpCompletionRoutine: pointer): u_int; -// stdcall; - - function GetPortService(value: string): integer; - -function IsNewApi(Family: TAddrFamily): Boolean; -function SetVarSin(var Sin: TVarSin; IP, Port: string; Family: TAddrFamily; SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -function GetSinIP(Sin: TVarSin): string; -function GetSinPort(Sin: TVarSin): Integer; -procedure ResolveNameToIP(Name: string; Family: TAddrFamily; SockProtocol, SockType: integer; const IPList: TStrings); -function ResolveIPToName(IP: string; Family: TAddrFamily; SockProtocol, SockType: integer): string; -function ResolvePort(Port: string; Family: TAddrFamily; SockProtocol, SockType: integer): Word; - -var - SynSockCS: SyncObjs.TCriticalSection; - SockEnhancedApi: Boolean; - SockWship6Api: Boolean; - -{==============================================================================} -implementation - -threadvar - WSALastError: integer; - WSALastErrorDesc: string; - -var - services: Array [0..139, 0..1] of string = - ( - ('echo', '7'), - ('discard', '9'), - ('sink', '9'), - ('null', '9'), - ('systat', '11'), - ('users', '11'), - ('daytime', '13'), - ('qotd', '17'), - ('quote', '17'), - ('chargen', '19'), - ('ttytst', '19'), - ('source', '19'), - ('ftp-data', '20'), - ('ftp', '21'), - ('telnet', '23'), - ('smtp', '25'), - ('mail', '25'), - ('time', '37'), - ('timeserver', '37'), - ('rlp', '39'), - ('nameserver', '42'), - ('name', '42'), - ('nickname', '43'), - ('whois', '43'), - ('domain', '53'), - ('bootps', '67'), - ('dhcps', '67'), - ('bootpc', '68'), - ('dhcpc', '68'), - ('tftp', '69'), - ('gopher', '70'), - ('finger', '79'), - ('http', '80'), - ('www', '80'), - ('www-http', '80'), - ('kerberos', '88'), - ('hostname', '101'), - ('hostnames', '101'), - ('iso-tsap', '102'), - ('rtelnet', '107'), - ('pop2', '109'), - ('postoffice', '109'), - ('pop3', '110'), - ('sunrpc', '111'), - ('rpcbind', '111'), - ('portmap', '111'), - ('auth', '113'), - ('ident', '113'), - ('tap', '113'), - ('uucp-path', '117'), - ('nntp', '119'), - ('usenet', '119'), - ('ntp', '123'), - ('epmap', '135'), - ('loc-srv', '135'), - ('netbios-ns', '137'), - ('nbname', '137'), - ('netbios-dgm', '138'), - ('nbdatagram', '138'), - ('netbios-ssn', '139'), - ('nbsession', '139'), - ('imap', '143'), - ('imap4', '143'), - ('pcmail-srv', '158'), - ('snmp', '161'), - ('snmptrap', '162'), - ('snmp-trap', '162'), - ('print-srv', '170'), - ('bgp', '179'), - ('irc', '194'), - ('ipx', '213'), - ('ldap', '389'), - ('https', '443'), - ('mcom', '443'), - ('microsoft-ds', '445'), - ('kpasswd', '464'), - ('isakmp', '500'), - ('ike', '500'), - ('exec', '512'), - ('biff', '512'), - ('comsat', '512'), - ('login', '513'), - ('who', '513'), - ('whod', '513'), - ('cmd', '514'), - ('shell', '514'), - ('syslog', '514'), - ('printer', '515'), - ('spooler', '515'), - ('talk', '517'), - ('ntalk', '517'), - ('efs', '520'), - ('router', '520'), - ('route', '520'), - ('routed', '520'), - ('timed', '525'), - ('timeserver', '525'), - ('tempo', '526'), - ('newdate', '526'), - ('courier', '530'), - ('rpc', '530'), - ('conference', '531'), - ('chat', '531'), - ('netnews', '532'), - ('readnews', '532'), - ('netwall', '533'), - ('uucp', '540'), - ('uucpd', '540'), - ('klogin', '543'), - ('kshell', '544'), - ('krcmd', '544'), - ('new-rwho', '550'), - ('new-who', '550'), - ('remotefs', '556'), - ('rfs', '556'), - ('rfs_server', '556'), - ('rmonitor', '560'), - ('rmonitord', '560'), - ('monitor', '561'), - ('ldaps', '636'), - ('sldap', '636'), - ('doom', '666'), - ('kerberos-adm', '749'), - ('kerberos-iv', '750'), - ('kpop', '1109'), - ('phone', '1167'), - ('ms-sql-s', '1433'), - ('ms-sql-m', '1434'), - ('wins', '1512'), - ('ingreslock', '1524'), - ('ingres', '1524'), - ('l2tp', '1701'), - ('pptp', '1723'), - ('radius', '1812'), - ('radacct', '1813'), - ('nfsd', '2049'), - ('nfs', '2049'), - ('knetd', '2053'), - ('gds_db', '3050'), - ('man', '9535') - ); - -{function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; -begin - Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and - (a^.s_un_dw.s_dw3 = 0) and (a^.s_un_dw.s_dw4 = 0)); -end; - -function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; -begin - Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and - (a^.s_un_dw.s_dw3 = 0) and - (a^.s_un_b.s_b13 = char(0)) and (a^.s_un_b.s_b14 = char(0)) and - (a^.s_un_b.s_b15 = char(0)) and (a^.s_un_b.s_b16 = char(1))); -end; - -function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($80))); -end; - -function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($C0))); -end; - -function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; -begin - Result := (a^.s_un_b.s_b1 = char($FF)); -end; - -function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; -begin - Result := (CompareMem( a, b, sizeof(TInAddr6))); -end; - -procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); -begin - FillChar(a^, sizeof(TInAddr6), 0); -end; - -procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); -begin - FillChar(a^, sizeof(TInAddr6), 0); - a^.s_un_b.s_b16 := char(1); -end; -} - -{=============================================================================} - -procedure NullErr; -begin - WSALastError := 0; - WSALastErrorDesc := ''; -end; - -procedure GetErrCode(E: System.Exception); -var - SE: System.Net.Sockets.SocketException; -begin - if E is System.Net.Sockets.SocketException then - begin - SE := E as System.Net.Sockets.SocketException; - WSALastError := SE.ErrorCode; - WSALastErrorDesc := SE.Message; - end -end; - -function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; -begin - NullErr; - with WSData do - begin - wVersion := wVersionRequired; - wHighVersion := $202; - szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; - szSystemStatus := 'Running on .NET'; - iMaxSockets := 32768; - iMaxUdpDg := 8192; - end; - Result := 0; -end; - -function WSACleanup: Integer; -begin - NullErr; - Result := 0; -end; - -function WSAGetLastError: Integer; -begin - Result := WSALastError; -end; - -function WSAGetLastErrorDesc: String; -begin - Result := WSALastErrorDesc; -end; - -function GetHostName: string; -begin - Result := System.Net.DNS.GetHostName; -end; - -function Shutdown(s: TSocket; how: Integer): Integer; -begin - Result := 0; - NullErr; - try - s.ShutDown(SocketShutdown(how)); - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := integer(SOCKET_ERROR); - end; - end; -end; - -function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; - optlen: Integer): Integer; -begin - Result := 0; - NullErr; - try - s.SetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval); - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := integer(SOCKET_ERROR); - end; - end; -end; - -function SetSockOptObj(s: TSocket; level, optname: Integer; optval: TObject): Integer; -begin - Result := 0; - NullErr; - try - s.SetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval); - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := integer(SOCKET_ERROR); - end; - end; -end; - -function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; - var optlen: Integer): Integer; -begin - Result := 0; - NullErr; - try - s.GetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval); - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := integer(SOCKET_ERROR); - end; - end; -end; - -function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; -//function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: TVarSin): Integer; -begin - NullErr; - try - result := s.SendTo(Buf, len, SocketFlags(flags), addrto); - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := integer(SOCKET_ERROR); - end; - end; -end; - -function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -//function Send(s: TSocket; const Buf; len, flags: Integer): Integer; -begin - NullErr; - try - result := s.Send(Buf, len, SocketFlags(flags)); - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := integer(SOCKET_ERROR); - end; - end; -end; - -function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -//function Recv(s: TSocket; var Buf; len, flags: Integer): Integer; -begin - NullErr; - try - result := s.Receive(Buf, len, SocketFlags(flags)); - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := integer(SOCKET_ERROR); - end; - end; -end; - -//function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; -// var fromlen: Integer): Integer; -function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; -//function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: TVarSin): Integer; -var - EP: EndPoint; -begin - NullErr; - try - EP := from; - result := s.ReceiveFrom(Buf, len, SocketFlags(flags), EndPoint(EP)); - from := EP as IPEndPoint; - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := integer(SOCKET_ERROR); - end; - end; -end; - -function ntohs(netshort: u_short): u_short; -begin - Result := IPAddress.NetworkToHostOrder(NetShort); -end; - -function ntohl(netlong: u_long): u_long; -begin - Result := IPAddress.NetworkToHostOrder(NetLong); -end; - -function Listen(s: TSocket; backlog: Integer): Integer; -begin - Result := 0; - NullErr; - try - s.Listen(backlog); - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := integer(SOCKET_ERROR); - end; - end; -end; - -function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; -var - inv, outv: TMemory; -begin - Result := 0; - NullErr; - try - if cmd = DWORD(FIONBIO) then - s.Blocking := arg = 0 - else - begin - inv := BitConverter.GetBytes(arg); - outv := BitConverter.GetBytes(integer(0)); - s.IOControl(cmd, inv, outv); - arg := BitConverter.ToInt32(outv, 0); - end; - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := integer(SOCKET_ERROR); - end; - end; -end; - -function htons(hostshort: u_short): u_short; -begin - Result := IPAddress.HostToNetworkOrder(Hostshort); -end; - -function htonl(hostlong: u_long): u_long; -begin - Result := IPAddress.HostToNetworkOrder(HostLong); -end; - -//function GetSockName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; -function GetSockName(s: TSocket; var name: TVarSin): Integer; -begin - Result := 0; - NullErr; - try - Name := s.localEndPoint as IPEndpoint; - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := integer(SOCKET_ERROR); - end; - end; -end; - -//function GetPeerName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; -function GetPeerName(s: TSocket; var name: TVarSin): Integer; -begin - Result := 0; - NullErr; - try - Name := s.RemoteEndPoint as IPEndpoint; - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := integer(SOCKET_ERROR); - end; - end; -end; - -//function Connect(s: TSocket; name: PSockAddr; namelen: Integer): Integer; -function Connect(s: TSocket; const name: TVarSin): Integer; -begin - Result := 0; - NullErr; - try - s.Connect(name); - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := integer(SOCKET_ERROR); - end; - end; -end; - -function CloseSocket(s: TSocket): Integer; -begin - Result := 0; - NullErr; - try - s.Close; - except - on e: System.Net.Sockets.SocketException do - begin - Result := integer(SOCKET_ERROR); - end; - end; -end; - -//function Bind(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; -function Bind(s: TSocket; const addr: TVarSin): Integer; -begin - Result := 0; - NullErr; - try - s.Bind(addr); - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := integer(SOCKET_ERROR); - end; - end; -end; - -//function Accept(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; -function Accept(s: TSocket; var addr: TVarSin): TSocket; -begin - NullErr; - try - result := s.Accept(); - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := nil; - end; - end; -end; - -function Socket(af, Struc, Protocol: Integer): TSocket; -begin - NullErr; - try - result := TSocket.Create(AddressFamily(af), SocketType(Struc), ProtocolType(Protocol)); - except - on e: System.Net.Sockets.SocketException do - begin - GetErrCode(e); - Result := nil; - end; - end; -end; - -{=============================================================================} -function GetPortService(value: string): integer; -var - n: integer; -begin - Result := 0; - value := Lowercase(value); - for n := 0 to High(Services) do - if services[n, 0] = value then - begin - Result := strtointdef(services[n, 1], 0); - break; - end; - if Result = 0 then - Result := StrToIntDef(value, 0); -end; - -{=============================================================================} -function IsNewApi(Family: TAddrFamily): Boolean; -begin - Result := true; -end; - -function SetVarSin(var Sin: TVarSin; IP, Port: string; Family: TAddrFamily; SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -var - IPs: array of IPAddress; - n: integer; - ip4, ip6: string; - sip: string; -begin - sip := ''; - ip4 := ''; - ip6 := ''; - IPs := Dns.Resolve(IP).AddressList; - for n :=low(IPs) to high(IPs) do begin - if (ip4 = '') and (IPs[n].AddressFamily = AF_INET) then - ip4 := IPs[n].toString; - if (ip6 = '') and (IPs[n].AddressFamily = AF_INET6) then - ip6 := IPs[n].toString; - if (ip4 <> '') and (ip6 <> '') then - break; - end; - case Family of - AF_UNSPEC: - begin - if (ip4 <> '') and (ip6 <> '') then - begin - if PreferIP4 then - sip := ip4 - else - Sip := ip6; - end - else - begin - sip := ip4; - if (ip6 <> '') then - sip := ip6; - end; - end; - AF_INET: - sip := ip4; - AF_INET6: - sip := ip6; - end; - sin := TVarSin.Create(IPAddress.Parse(sip), GetPortService(Port)); -end; - -function GetSinIP(Sin: TVarSin): string; -begin - Result := Sin.Address.ToString; -end; - -function GetSinPort(Sin: TVarSin): Integer; -begin - Result := Sin.Port; -end; - -procedure ResolveNameToIP(Name: string; Family: TAddrFamily; SockProtocol, SockType: integer; const IPList: TStrings); -var - IPs :array of IPAddress; - n: integer; -begin - IPList.Clear; - IPs := Dns.Resolve(Name).AddressList; - for n := low(IPs) to high(IPs) do - begin - if not(((Family = AF_INET6) and (IPs[n].AddressFamily = AF_INET)) - or ((Family = AF_INET) and (IPs[n].AddressFamily = AF_INET6))) then - begin - IPList.Add(IPs[n].toString); - end; - end; -end; - -function ResolvePort(Port: string; Family: TAddrFamily; SockProtocol, SockType: integer): Word; -var - n: integer; -begin - Result := StrToIntDef(port, 0); - if Result = 0 then - begin - port := Lowercase(port); - for n := 0 to High(Services) do - if services[n, 0] = port then - begin - Result := strtointdef(services[n, 1], 0); - break; - end; - end; -end; - -function ResolveIPToName(IP: string; Family: TAddrFamily; SockProtocol, SockType: integer): string; -begin - Result := Dns.GetHostByAddress(IP).HostName; -end; - - -{=============================================================================} -function InitSocketInterface(stack: string): Boolean; -begin - Result := True; -end; - -function DestroySocketInterface: Boolean; -begin - NullErr; - Result := True; -end; - -initialization -begin - SynSockCS := SyncObjs.TCriticalSection.Create; -// SET_IN6_IF_ADDR_ANY (@in6addr_any); -// SET_LOOPBACK_ADDR6 (@in6addr_loopback); -end; - -finalization -begin - NullErr; - SynSockCS.Free; -end; - -{$ENDIF} diff --git a/addons/synapse/ssfpc.pas b/addons/synapse/ssfpc.pas deleted file mode 100644 index 9b73f73..0000000 --- a/addons/synapse/ssfpc.pas +++ /dev/null @@ -1,898 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.003 | -|==============================================================================| -| Content: Socket Independent Platform Layer - FreePascal definition include | -|==============================================================================| -| Copyright (c)2006-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2006-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@exclude} - -{$IFDEF FPC} -{For FreePascal 2.x.x} - -//{$DEFINE FORCEOLDAPI} -{Note about define FORCEOLDAPI: -If you activate this compiler directive, then is allways used old socket API -for name resolution. If you leave this directive inactive, then the new API -is used, when running system allows it. - -For IPv6 support you must have new API! -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$ifdef FreeBSD} -{$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr -{$endif} -{$ifdef darwin} -{$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr -{$endif} - -interface - -uses - SyncObjs, SysUtils, Classes, - synafpc, BaseUnix, Unix, termio, sockets, netdb; - -function InitSocketInterface(stack: string): Boolean; -function DestroySocketInterface: Boolean; - -const - DLLStackName = ''; - WinsockLevel = $0202; - - cLocalHost = '127.0.0.1'; - cAnyHost = '0.0.0.0'; - c6AnyHost = '::0'; - c6Localhost = '::1'; - cLocalHostStr = 'localhost'; - -type - TSocket = longint; - TAddrFamily = integer; - - TMemory = pointer; - - -type - TFDSet = Baseunix.TFDSet; - PFDSet = ^TFDSet; - Ptimeval = Baseunix.ptimeval; - Ttimeval = Baseunix.ttimeval; - -const - FIONREAD = termio.FIONREAD; - FIONBIO = termio.FIONBIO; - FIOASYNC = termio.FIOASYNC; - -const - IPPROTO_IP = 0; { Dummy } - IPPROTO_ICMP = 1; { Internet Control Message Protocol } - IPPROTO_IGMP = 2; { Internet Group Management Protocol} - IPPROTO_TCP = 6; { TCP } - IPPROTO_UDP = 17; { User Datagram Protocol } - IPPROTO_IPV6 = 41; - IPPROTO_ICMPV6 = 58; - IPPROTO_RM = 113; - - IPPROTO_RAW = 255; - IPPROTO_MAX = 256; - -type - PInAddr = ^TInAddr; - TInAddr = sockets.in_addr; - - PSockAddrIn = ^TSockAddrIn; - TSockAddrIn = sockets.TInetSockAddr; - - - TIP_mreq = record - imr_multiaddr: TInAddr; // IP multicast address of group - imr_interface: TInAddr; // local IP address of interface - end; - - - PInAddr6 = ^TInAddr6; - TInAddr6 = sockets.Tin6_addr; - - PSockAddrIn6 = ^TSockAddrIn6; - TSockAddrIn6 = sockets.TInetSockAddr6; - - - TIPv6_mreq = record - ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. - ipv6mr_interface: integer; // Interface index. - end; - -const - INADDR_ANY = $00000000; - INADDR_LOOPBACK = $7F000001; - INADDR_BROADCAST = $FFFFFFFF; - INADDR_NONE = $FFFFFFFF; - ADDR_ANY = INADDR_ANY; - INVALID_SOCKET = TSocket(NOT(0)); - SOCKET_ERROR = -1; - -Const - IP_TOS = sockets.IP_TOS; { int; IP type of service and precedence. } - IP_TTL = sockets.IP_TTL; { int; IP time to live. } - IP_HDRINCL = sockets.IP_HDRINCL; { int; Header is included with data. } - IP_OPTIONS = sockets.IP_OPTIONS; { ip_opts; IP per-packet options. } -// IP_ROUTER_ALERT = sockets.IP_ROUTER_ALERT; { bool } - IP_RECVOPTS = sockets.IP_RECVOPTS; { bool } - IP_RETOPTS = sockets.IP_RETOPTS; { bool } -// IP_PKTINFO = sockets.IP_PKTINFO; { bool } -// IP_PKTOPTIONS = sockets.IP_PKTOPTIONS; -// IP_PMTUDISC = sockets.IP_PMTUDISC; { obsolete name? } -// IP_MTU_DISCOVER = sockets.IP_MTU_DISCOVER; { int; see below } -// IP_RECVERR = sockets.IP_RECVERR; { bool } -// IP_RECVTTL = sockets.IP_RECVTTL; { bool } -// IP_RECVTOS = sockets.IP_RECVTOS; { bool } - IP_MULTICAST_IF = sockets.IP_MULTICAST_IF; { in_addr; set/get IP multicast i/f } - IP_MULTICAST_TTL = sockets.IP_MULTICAST_TTL; { u_char; set/get IP multicast ttl } - IP_MULTICAST_LOOP = sockets.IP_MULTICAST_LOOP; { i_char; set/get IP multicast loopback } - IP_ADD_MEMBERSHIP = sockets.IP_ADD_MEMBERSHIP; { ip_mreq; add an IP group membership } - IP_DROP_MEMBERSHIP = sockets.IP_DROP_MEMBERSHIP; { ip_mreq; drop an IP group membership } - - SOL_SOCKET = sockets.SOL_SOCKET; - - SO_DEBUG = sockets.SO_DEBUG; - SO_REUSEADDR = sockets.SO_REUSEADDR; - SO_TYPE = sockets.SO_TYPE; - SO_ERROR = sockets.SO_ERROR; - SO_DONTROUTE = sockets.SO_DONTROUTE; - SO_BROADCAST = sockets.SO_BROADCAST; - SO_SNDBUF = sockets.SO_SNDBUF; - SO_RCVBUF = sockets.SO_RCVBUF; - SO_KEEPALIVE = sockets.SO_KEEPALIVE; - SO_OOBINLINE = sockets.SO_OOBINLINE; -// SO_NO_CHECK = sockets.SO_NO_CHECK; -// SO_PRIORITY = sockets.SO_PRIORITY; - SO_LINGER = sockets.SO_LINGER; -// SO_BSDCOMPAT = sockets.SO_BSDCOMPAT; -// SO_REUSEPORT = sockets.SO_REUSEPORT; -// SO_PASSCRED = sockets.SO_PASSCRED; -// SO_PEERCRED = sockets.SO_PEERCRED; - SO_RCVLOWAT = sockets.SO_RCVLOWAT; - SO_SNDLOWAT = sockets.SO_SNDLOWAT; - SO_RCVTIMEO = sockets.SO_RCVTIMEO; - SO_SNDTIMEO = sockets.SO_SNDTIMEO; -{ Security levels - as per NRL IPv6 - don't actually do anything } -// SO_SECURITY_AUTHENTICATION = sockets.SO_SECURITY_AUTHENTICATION; -// SO_SECURITY_ENCRYPTION_TRANSPORT = sockets.SO_SECURITY_ENCRYPTION_TRANSPORT; -// SO_SECURITY_ENCRYPTION_NETWORK = sockets.SO_SECURITY_ENCRYPTION_NETWORK; -// SO_BINDTODEVICE = sockets.SO_BINDTODEVICE; -{ Socket filtering } -// SO_ATTACH_FILTER = sockets.SO_ATTACH_FILTER; -// SO_DETACH_FILTER = sockets.SO_DETACH_FILTER; - - SOMAXCONN = 1024; - - IPV6_UNICAST_HOPS = sockets.IPV6_UNICAST_HOPS; - IPV6_MULTICAST_IF = sockets.IPV6_MULTICAST_IF; - IPV6_MULTICAST_HOPS = sockets.IPV6_MULTICAST_HOPS; - IPV6_MULTICAST_LOOP = sockets.IPV6_MULTICAST_LOOP; - IPV6_JOIN_GROUP = sockets.IPV6_JOIN_GROUP; - IPV6_LEAVE_GROUP = sockets.IPV6_LEAVE_GROUP; - -const - SOCK_STREAM = 1; { stream socket } - SOCK_DGRAM = 2; { datagram socket } - SOCK_RAW = 3; { raw-protocol interface } - SOCK_RDM = 4; { reliably-delivered message } - SOCK_SEQPACKET = 5; { sequenced packet stream } - -{ TCP options. } - TCP_NODELAY = $0001; - -{ Address families. } - - AF_UNSPEC = 0; { unspecified } - AF_INET = 2; { internetwork: UDP, TCP, etc. } - AF_INET6 = 10; { Internetwork Version 6 } - AF_MAX = 24; - -{ Protocol families, same as address families for now. } - PF_UNSPEC = AF_UNSPEC; - PF_INET = AF_INET; - PF_INET6 = AF_INET6; - PF_MAX = AF_MAX; - -type -{ Structure used for manipulating linger option. } - PLinger = ^TLinger; - TLinger = packed record - l_onoff: integer; - l_linger: integer; - end; - -const - - MSG_OOB = sockets.MSG_OOB; // Process out-of-band data. - MSG_PEEK = sockets.MSG_PEEK; // Peek at incoming messages. - {$ifdef DARWIN} - MSG_NOSIGNAL = $20000; // Do not generate SIGPIPE. - // Works under MAC OS X, but is undocumented, - // So FPC doesn't include it - {$else} - MSG_NOSIGNAL = sockets.MSG_NOSIGNAL; // Do not generate SIGPIPE. - {$endif} - -const - WSAEINTR = ESysEINTR; - WSAEBADF = ESysEBADF; - WSAEACCES = ESysEACCES; - WSAEFAULT = ESysEFAULT; - WSAEINVAL = ESysEINVAL; - WSAEMFILE = ESysEMFILE; - WSAEWOULDBLOCK = ESysEWOULDBLOCK; - WSAEINPROGRESS = ESysEINPROGRESS; - WSAEALREADY = ESysEALREADY; - WSAENOTSOCK = ESysENOTSOCK; - WSAEDESTADDRREQ = ESysEDESTADDRREQ; - WSAEMSGSIZE = ESysEMSGSIZE; - WSAEPROTOTYPE = ESysEPROTOTYPE; - WSAENOPROTOOPT = ESysENOPROTOOPT; - WSAEPROTONOSUPPORT = ESysEPROTONOSUPPORT; - WSAESOCKTNOSUPPORT = ESysESOCKTNOSUPPORT; - WSAEOPNOTSUPP = ESysEOPNOTSUPP; - WSAEPFNOSUPPORT = ESysEPFNOSUPPORT; - WSAEAFNOSUPPORT = ESysEAFNOSUPPORT; - WSAEADDRINUSE = ESysEADDRINUSE; - WSAEADDRNOTAVAIL = ESysEADDRNOTAVAIL; - WSAENETDOWN = ESysENETDOWN; - WSAENETUNREACH = ESysENETUNREACH; - WSAENETRESET = ESysENETRESET; - WSAECONNABORTED = ESysECONNABORTED; - WSAECONNRESET = ESysECONNRESET; - WSAENOBUFS = ESysENOBUFS; - WSAEISCONN = ESysEISCONN; - WSAENOTCONN = ESysENOTCONN; - WSAESHUTDOWN = ESysESHUTDOWN; - WSAETOOMANYREFS = ESysETOOMANYREFS; - WSAETIMEDOUT = ESysETIMEDOUT; - WSAECONNREFUSED = ESysECONNREFUSED; - WSAELOOP = ESysELOOP; - WSAENAMETOOLONG = ESysENAMETOOLONG; - WSAEHOSTDOWN = ESysEHOSTDOWN; - WSAEHOSTUNREACH = ESysEHOSTUNREACH; - WSAENOTEMPTY = ESysENOTEMPTY; - WSAEPROCLIM = -1; - WSAEUSERS = ESysEUSERS; - WSAEDQUOT = ESysEDQUOT; - WSAESTALE = ESysESTALE; - WSAEREMOTE = ESysEREMOTE; - WSASYSNOTREADY = -2; - WSAVERNOTSUPPORTED = -3; - WSANOTINITIALISED = -4; - WSAEDISCON = -5; - WSAHOST_NOT_FOUND = 1; - WSATRY_AGAIN = 2; - WSANO_RECOVERY = 3; - WSANO_DATA = -6; - -const - WSADESCRIPTION_LEN = 256; - WSASYS_STATUS_LEN = 128; -type - PWSAData = ^TWSAData; - TWSAData = packed record - wVersion: Word; - wHighVersion: Word; - szDescription: array[0..WSADESCRIPTION_LEN] of Char; - szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; - iMaxSockets: Word; - iMaxUdpDg: Word; - lpVendorInfo: PChar; - end; - - function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; - function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; - function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; - function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; - function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; - function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; - procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); - procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); - -var - in6addr_any, in6addr_loopback : TInAddr6; - -procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); -function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; -procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); -procedure FD_ZERO(var FDSet: TFDSet); - -{=============================================================================} - -var - SynSockCS: SyncObjs.TCriticalSection; - SockEnhancedApi: Boolean; - SockWship6Api: Boolean; - -type - TVarSin = packed record - {$ifdef SOCK_HAS_SINLEN} - sin_len : cuchar; - {$endif} - case integer of - 0: (AddressFamily: sa_family_t); - 1: ( - case sin_family: sa_family_t of - AF_INET: (sin_port: word; - sin_addr: TInAddr; - sin_zero: array[0..7] of Char); - AF_INET6: (sin6_port: word; - sin6_flowinfo: longword; - sin6_addr: TInAddr6; - sin6_scope_id: longword); - ); - end; - -function SizeOfVarSin(sin: TVarSin): integer; - - function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; - function WSACleanup: Integer; - function WSAGetLastError: Integer; - function GetHostName: string; - function Shutdown(s: TSocket; how: Integer): Integer; - function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; - optlen: Integer): Integer; - function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; - var optlen: Integer): Integer; - function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; - function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; - function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; - function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; - function ntohs(netshort: word): word; - function ntohl(netlong: longword): longword; - function Listen(s: TSocket; backlog: Integer): Integer; - function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; - function htons(hostshort: word): word; - function htonl(hostlong: longword): longword; - function GetSockName(s: TSocket; var name: TVarSin): Integer; - function GetPeerName(s: TSocket; var name: TVarSin): Integer; - function Connect(s: TSocket; const name: TVarSin): Integer; - function CloseSocket(s: TSocket): Integer; - function Bind(s: TSocket; const addr: TVarSin): Integer; - function Accept(s: TSocket; var addr: TVarSin): TSocket; - function Socket(af, Struc, Protocol: Integer): TSocket; - function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; - timeout: PTimeVal): Longint; - -function IsNewApi(Family: integer): Boolean; -function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -function GetSinIP(Sin: TVarSin): string; -function GetSinPort(Sin: TVarSin): Integer; -procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); -function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; -function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; - - -{==============================================================================} -implementation - - -function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and - (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); -end; - -function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and - (a^.u6_addr32[2] = 0) and - (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and - (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); -end; - -function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); -end; - -function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); -end; - -function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; -begin - Result := (a^.u6_addr8[0] = $FF); -end; - -function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; -begin - Result := (CompareMem( a, b, sizeof(TInAddr6))); -end; - -procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); -begin - FillChar(a^, sizeof(TInAddr6), 0); -end; - -procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); -begin - FillChar(a^, sizeof(TInAddr6), 0); - a^.u6_addr8[15] := 1; -end; - -{=============================================================================} - -function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; -begin - with WSData do - begin - wVersion := wVersionRequired; - wHighVersion := $202; - szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; - szSystemStatus := 'Running on Unix/Linux by FreePascal'; - iMaxSockets := 32768; - iMaxUdpDg := 8192; - end; - Result := 0; -end; - -function WSACleanup: Integer; -begin - Result := 0; -end; - -function WSAGetLastError: Integer; -begin - Result := fpGetErrno; -end; - -function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean; -begin - Result := fpFD_ISSET(socket, fdset) <> 0; -end; - -procedure FD_SET(Socket: TSocket; var fdset: TFDSet); -begin - fpFD_SET(Socket, fdset); -end; - -procedure FD_CLR(Socket: TSocket; var fdset: TFDSet); -begin - fpFD_CLR(Socket, fdset); -end; - -procedure FD_ZERO(var fdset: TFDSet); -begin - fpFD_ZERO(fdset); -end; - -{=============================================================================} - -function SizeOfVarSin(sin: TVarSin): integer; -begin - case sin.sin_family of - AF_INET: - Result := SizeOf(TSockAddrIn); - AF_INET6: - Result := SizeOf(TSockAddrIn6); - else - Result := 0; - end; -end; - -{=============================================================================} - -function Bind(s: TSocket; const addr: TVarSin): Integer; -begin - if fpBind(s, @addr, SizeOfVarSin(addr)) = 0 then - Result := 0 - else - Result := SOCKET_ERROR; -end; - -function Connect(s: TSocket; const name: TVarSin): Integer; -begin - if fpConnect(s, @name, SizeOfVarSin(name)) = 0 then - Result := 0 - else - Result := SOCKET_ERROR; -end; - -function GetSockName(s: TSocket; var name: TVarSin): Integer; -var - len: integer; -begin - len := SizeOf(name); - FillChar(name, len, 0); - Result := fpGetSockName(s, @name, @Len); -end; - -function GetPeerName(s: TSocket; var name: TVarSin): Integer; -var - len: integer; -begin - len := SizeOf(name); - FillChar(name, len, 0); - Result := fpGetPeerName(s, @name, @Len); -end; - -function GetHostName: string; -begin - Result := unix.GetHostName; -end; - -function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -begin - Result := fpSend(s, pointer(Buf), len, flags); -end; - -function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -begin - Result := fpRecv(s, pointer(Buf), len, flags); -end; - -function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; -begin - Result := fpSendTo(s, pointer(Buf), len, flags, @addrto, SizeOfVarSin(addrto)); -end; - -function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; -var - x: integer; -begin - x := SizeOf(from); - Result := fpRecvFrom(s, pointer(Buf), len, flags, @from, @x); -end; - -function Accept(s: TSocket; var addr: TVarSin): TSocket; -var - x: integer; -begin - x := SizeOf(addr); - Result := fpAccept(s, @addr, @x); -end; - -function Shutdown(s: TSocket; how: Integer): Integer; -begin - Result := fpShutdown(s, how); -end; - -function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; - optlen: Integer): Integer; -begin - Result := fpsetsockopt(s, level, optname, pointer(optval), optlen); -end; - -function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; - var optlen: Integer): Integer; -begin - Result := fpgetsockopt(s, level, optname, pointer(optval), @optlen); -end; - -function ntohs(netshort: word): word; -begin - Result := sockets.ntohs(NetShort); -end; - -function ntohl(netlong: longword): longword; -begin - Result := sockets.ntohl(NetLong); -end; - -function Listen(s: TSocket; backlog: Integer): Integer; -begin - if fpListen(s, backlog) = 0 then - Result := 0 - else - Result := SOCKET_ERROR; -end; - -function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; -begin - Result := fpIoctl(s, cmd, @arg); -end; - -function htons(hostshort: word): word; -begin - Result := sockets.htons(Hostshort); -end; - -function htonl(hostlong: longword): longword; -begin - Result := sockets.htonl(HostLong); -end; - -function CloseSocket(s: TSocket): Integer; -begin - Result := sockets.CloseSocket(s); -end; - -function Socket(af, Struc, Protocol: Integer): TSocket; -begin - Result := fpSocket(af, struc, protocol); -end; - -function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; - timeout: PTimeVal): Longint; -begin - Result := fpSelect(nfds, readfds, writefds, exceptfds, timeout); -end; - -{=============================================================================} -function IsNewApi(Family: integer): Boolean; -begin - Result := SockEnhancedApi; - if not Result then - Result := (Family = AF_INET6) and SockWship6Api; -end; - -function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -var - TwoPass: boolean; - f1, f2: integer; - - function GetAddr(f:integer): integer; - var - a4: array [1..1] of in_addr; - a6: array [1..1] of Tin6_addr; - begin - Result := WSAEPROTONOSUPPORT; - case f of - AF_INET: - begin - if IP = cAnyHost then - begin - Sin.sin_family := AF_INET; - Result := 0; - end - else - begin - if lowercase(IP) = cLocalHostStr then - a4[1].s_addr := htonl(INADDR_LOOPBACK) - else - begin - a4[1].s_addr := 0; - Result := WSAHOST_NOT_FOUND; - a4[1] := StrTonetAddr(IP); - if a4[1].s_addr = INADDR_ANY then - Resolvename(ip, a4); - end; - if a4[1].s_addr <> INADDR_ANY then - begin - Sin.sin_family := AF_INET; - sin.sin_addr := a4[1]; - Result := 0; - end; - end; - end; - AF_INET6: - begin - if IP = c6AnyHost then - begin - Sin.sin_family := AF_INET6; - Result := 0; - end - else - begin - if lowercase(IP) = cLocalHostStr then - SET_LOOPBACK_ADDR6(@a6[1]) - else - begin - Result := WSAHOST_NOT_FOUND; - SET_IN6_IF_ADDR_ANY(@a6[1]); - a6[1] := StrTonetAddr6(IP); - if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then - Resolvename6(ip, a6); - end; - if not IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then - begin - Sin.sin_family := AF_INET6; - sin.sin6_addr := a6[1]; - Result := 0; - end; - end; - end; - end; - end; -begin - Result := 0; - FillChar(Sin, Sizeof(Sin), 0); - Sin.sin_port := Resolveport(port, family, SockProtocol, SockType); - TwoPass := False; - if Family = AF_UNSPEC then - begin - if PreferIP4 then - begin - f1 := AF_INET; - f2 := AF_INET6; - TwoPass := True; - end - else - begin - f2 := AF_INET; - f1 := AF_INET6; - TwoPass := True; - end; - end - else - f1 := Family; - Result := GetAddr(f1); - if Result <> 0 then - if TwoPass then - Result := GetAddr(f2); -end; - -function GetSinIP(Sin: TVarSin): string; -begin - Result := ''; - case sin.AddressFamily of - AF_INET: - begin - result := NetAddrToStr(sin.sin_addr); - end; - AF_INET6: - begin - result := NetAddrToStr6(sin.sin6_addr); - end; - end; -end; - -function GetSinPort(Sin: TVarSin): Integer; -begin - if (Sin.sin_family = AF_INET6) then - Result := synsock.ntohs(Sin.sin6_port) - else - Result := synsock.ntohs(Sin.sin_port); -end; - -procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); -var - x, n: integer; - a4: array [1..255] of in_addr; - a6: array [1..255] of Tin6_addr; -begin - IPList.Clear; - if (family = AF_INET) or (family = AF_UNSPEC) then - begin - if lowercase(name) = cLocalHostStr then - IpList.Add(cLocalHost) - else - begin - a4[1] := StrTonetAddr(name); - if a4[1].s_addr = INADDR_ANY then - x := Resolvename(name, a4) - else - x := 1; - for n := 1 to x do - IpList.Add(netaddrToStr(a4[n])); - end; - end; - - if (family = AF_INET6) or (family = AF_UNSPEC) then - begin - if lowercase(name) = cLocalHostStr then - IpList.Add(c6LocalHost) - else - begin - a6[1] := StrTonetAddr6(name); - if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then - x := Resolvename6(name, a6) - else - x := 1; - for n := 1 to x do - IpList.Add(netaddrToStr6(a6[n])); - end; - end; - - if IPList.Count = 0 then - IPList.Add(cLocalHost); -end; - -function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; -var - ProtoEnt: TProtocolEntry; - ServEnt: TServiceEntry; -begin - Result := synsock.htons(StrToIntDef(Port, 0)); - if Result = 0 then - begin - ProtoEnt.Name := ''; - GetProtocolByNumber(SockProtocol, ProtoEnt); - ServEnt.port := 0; - GetServiceByName(Port, ProtoEnt.Name, ServEnt); - Result := ServEnt.port; - end; -end; - -function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; -var - n: integer; - a4: array [1..1] of in_addr; - a6: array [1..1] of Tin6_addr; - a: array [1..1] of string; -begin - Result := IP; - a4[1] := StrToNetAddr(IP); - if a4[1].s_addr <> INADDR_ANY then - begin -//why ResolveAddress need address in HOST order? :-O - n := ResolveAddress(nettohost(a4[1]), a); - if n > 0 then - Result := a[1]; - end - else - begin - a6[1] := StrToNetAddr6(IP); - n := ResolveAddress6(a6[1], a); - if n > 0 then - Result := a[1]; - end; -end; - -{=============================================================================} - -function InitSocketInterface(stack: string): Boolean; -begin - SockEnhancedApi := False; - SockWship6Api := False; -// Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN)); - Result := True; -end; - -function DestroySocketInterface: Boolean; -begin - Result := True; -end; - -initialization -begin - SynSockCS := SyncObjs.TCriticalSection.Create; - SET_IN6_IF_ADDR_ANY (@in6addr_any); - SET_LOOPBACK_ADDR6 (@in6addr_loopback); -end; - -finalization -begin - SynSockCS.Free; -end; - -{$ENDIF} - diff --git a/addons/synapse/ssl_cryptlib.pas b/addons/synapse/ssl_cryptlib.pas deleted file mode 100644 index 84dd4d8..0000000 --- a/addons/synapse/ssl_cryptlib.pas +++ /dev/null @@ -1,569 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.000 | -|==============================================================================| -| Content: SSL/SSH support by Peter Gutmann's CryptLib | -|==============================================================================| -| Copyright (c)1999-2005, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2005. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(SSL/SSH plugin for CryptLib) - -This plugin requires cl32.dll at least version 3.2.0! It can be used on Win32 -and Linux. This library is staticly linked - when you compile your application -with this plugin, you MUST distribute it with Cryptib library, otherwise you -cannot run your application! - -It can work with keys and certificates stored as PKCS#15 only! It must be stored -as disk file only, you cannot load them from memory! Each file can hold multiple -keys and certificates. You must identify it by 'label' stored in -@link(TSSLCryptLib.PrivateKeyLabel). - -If you need to use secure connection and authorize self by certificate -(each SSL/TLS server or client with client authorization), then use -@link(TCustomSSL.PrivateKeyFile), @link(TSSLCryptLib.PrivateKeyLabel) and -@link(TCustomSSL.KeyPassword) properties. - -If you need to use server what verifying client certificates, then use -@link(TCustomSSL.CertCAFile) as PKCS#15 file with public keyas of allowed clients. Clients -with non-matching certificates will be rejected by cryptLib. - -This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS -server without explicitly assigned key and certificate, then this plugin create -Ad-Hoc key and certificate for each incomming connection by self. It slowdown -accepting of new connections! - -You can use this plugin for SSHv2 connections too! You must explicitly set -@link(TCustomSSL.SSLType) to value LT_SSHv2 and set @link(TCustomSSL.username) -and @link(TCustomSSL.password). You can use special SSH channels too, see -@link(TCustomSSL). -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -unit ssl_cryptlib; - -interface - -uses - SysUtils, - blcksock, synsock, synautil, synacode, - cryptlib; - -type - {:@abstract(class implementing CryptLib SSL/SSH plugin.) - Instance of this class will be created for each @link(TTCPBlockSocket). - You not need to create instance of this class, all is done by Synapse itself!} - TSSLCryptLib = class(TCustomSSL) - protected - FCryptSession: CRYPT_SESSION; - FPrivateKeyLabel: string; - FDelCert: Boolean; - FReadBuffer: string; - function SSLCheck(Value: integer): Boolean; - function Init(server:Boolean): Boolean; - function DeInit: Boolean; - function Prepare(server:Boolean): Boolean; - function GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string; - function CreateSelfSignedCert(Host: string): Boolean; override; - function PopAll: string; - public - {:See @inherited} - constructor Create(const Value: TTCPBlockSocket); override; - destructor Destroy; override; - {:See @inherited} - function LibVersion: String; override; - {:See @inherited} - function LibName: String; override; - {:See @inherited} - procedure Assign(const Value: TCustomSSL); override; - {:See @inherited and @link(ssl_cryptlib) for more details.} - function Connect: boolean; override; - {:See @inherited and @link(ssl_cryptlib) for more details.} - function Accept: boolean; override; - {:See @inherited} - function Shutdown: boolean; override; - {:See @inherited} - function BiShutdown: boolean; override; - {:See @inherited} - function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function WaitingData: Integer; override; - {:See @inherited} - function GetSSLVersion: string; override; - {:See @inherited} - function GetPeerSubject: string; override; - {:See @inherited} - function GetPeerIssuer: string; override; - {:See @inherited} - function GetPeerName: string; override; - {:See @inherited} - function GetPeerFingerprint: string; override; - published - {:name of certificate/key within PKCS#15 file. It can hold more then one - certificate/key and each certificate/key must have unique label within one file.} - property PrivateKeyLabel: string read FPrivateKeyLabel Write FPrivateKeyLabel; - end; - -implementation - -{==============================================================================} - -constructor TSSLCryptLib.Create(const Value: TTCPBlockSocket); -begin - inherited Create(Value); - FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); - FPrivateKeyLabel := 'synapse'; - FDelCert := false; -end; - -destructor TSSLCryptLib.Destroy; -begin - DeInit; - inherited Destroy; -end; - -procedure TSSLCryptLib.Assign(const Value: TCustomSSL); -begin - inherited Assign(Value); - if Value is TSSLCryptLib then - begin - FPrivateKeyLabel := TSSLCryptLib(Value).privatekeyLabel; - end; -end; - -function TSSLCryptLib.GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string; -var - l: integer; -begin - l := 0; - cryptGetAttributeString(cryptHandle, attributeType, nil, l); - setlength(Result, l); - cryptGetAttributeString(cryptHandle, attributeType, pointer(Result), l); - setlength(Result, l); -end; - -function TSSLCryptLib.LibVersion: String; -var - x: integer; -begin - Result := GetString(CRYPT_UNUSED, CRYPT_OPTION_INFO_DESCRIPTION); - cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION, x); - Result := Result + ' v' + IntToStr(x); - cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION, x); - Result := Result + '.' + IntToStr(x); - cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_STEPPING, x); - Result := Result + '.' + IntToStr(x); -end; - -function TSSLCryptLib.LibName: String; -begin - Result := 'ssl_cryptlib'; -end; - -function TSSLCryptLib.SSLCheck(Value: integer): Boolean; -begin - Result := true; - FLastErrorDesc := ''; - if Value = CRYPT_ERROR_COMPLETE then - Value := 0; - FLastError := Value; - if FLastError <> 0 then - begin - Result := False; - FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE); - end; -end; - -function TSSLCryptLib.CreateSelfSignedCert(Host: string): Boolean; -var - privateKey: CRYPT_CONTEXT; - keyset: CRYPT_KEYSET; - cert: CRYPT_CERTIFICATE; - publicKey: CRYPT_CONTEXT; -begin - Result := False; - if FPrivatekeyFile = '' then - FPrivatekeyFile := GetTempFile('', 'key'); - cryptCreateContext(privateKey, CRYPT_UNUSED, CRYPT_ALGO_RSA); - cryptSetAttributeString(privateKey, CRYPT_CTXINFO_LABEL, Pointer(FPrivatekeyLabel), - Length(FPrivatekeyLabel)); - cryptSetAttribute(privateKey, CRYPT_CTXINFO_KEYSIZE, 1024); - cryptGenerateKey(privateKey); - cryptKeysetOpen(keyset, CRYPT_UNUSED, CRYPT_KEYSET_FILE, PChar(FPrivatekeyFile), CRYPT_KEYOPT_CREATE); - FDelCert := True; - cryptAddPrivateKey(keyset, privateKey, PChar(FKeyPassword)); - cryptCreateCert(cert, CRYPT_UNUSED, CRYPT_CERTTYPE_CERTIFICATE); - cryptSetAttribute(cert, CRYPT_CERTINFO_XYZZY, 1); - cryptGetPublicKey(keyset, publicKey, CRYPT_KEYID_NAME, PChar(FPrivatekeyLabel)); - cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTPUBLICKEYINFO, publicKey); - cryptSetAttributeString(cert, CRYPT_CERTINFO_COMMONNAME, Pointer(host), Length(host)); - cryptSignCert(cert, privateKey); - cryptAddPublicKey(keyset, cert); - cryptKeysetClose(keyset); - cryptDestroyCert(cert); - cryptDestroyContext(privateKey); - cryptDestroyContext(publicKey); - Result := True; -end; - -function TSSLCryptLib.PopAll: string; -const - BufferMaxSize = 32768; -var - Outbuffer: string; - WriteLen: integer; -begin - Result := ''; - repeat - setlength(outbuffer, BufferMaxSize); - Writelen := 0; - SSLCheck(CryptPopData(FCryptSession, @OutBuffer[1], BufferMaxSize, Writelen)); - if FLastError <> 0 then - Break; - if WriteLen > 0 then - begin - setlength(outbuffer, WriteLen); - Result := Result + outbuffer; - end; - until WriteLen = 0; -end; - -function TSSLCryptLib.Init(server:Boolean): Boolean; -var - st: CRYPT_SESSION_TYPE; - keysetobj: CRYPT_KEYSET; - cryptContext: CRYPT_CONTEXT; - x: integer; -begin - Result := False; - FLastErrorDesc := ''; - FLastError := 0; - FDelCert := false; - FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); - if server then - case FSSLType of - LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1: - st := CRYPT_SESSION_SSL_SERVER; - LT_SSHv2: - st := CRYPT_SESSION_SSH_SERVER; - else - Exit; - end - else - case FSSLType of - LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1: - st := CRYPT_SESSION_SSL; - LT_SSHv2: - st := CRYPT_SESSION_SSH; - else - Exit; - end; - if not SSLCheck(cryptCreateSession(FcryptSession, CRYPT_UNUSED, st)) then - Exit; - x := -1; - case FSSLType of - LT_SSLv3: - x := 0; - LT_TLSv1: - x := 1; - LT_TLSv1_1: - x := 2; - end; - if x >= 0 then - if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then - Exit; - if FUsername <> '' then - begin - cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME, - Pointer(FUsername), Length(FUsername)); - cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD, - Pointer(FPassword), Length(FPassword)); - end; - if FSSLType = LT_SSHv2 then - if FSSHChannelType <> '' then - begin - cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL, CRYPT_UNUSED); - cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_TYPE, - Pointer(FSSHChannelType), Length(FSSHChannelType)); - if FSSHChannelArg1 <> '' then - cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG1, - Pointer(FSSHChannelArg1), Length(FSSHChannelArg1)); - if FSSHChannelArg2 <> '' then - cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG2, - Pointer(FSSHChannelArg2), Length(FSSHChannelArg2)); - end; - - - if server and (FPrivatekeyFile = '') then - begin - if FPrivatekeyLabel = '' then - FPrivatekeyLabel := 'synapse'; - if FkeyPassword = '' then - FkeyPassword := 'synapse'; - CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP)); - end; - - if (FPrivatekeyLabel <> '') and (FPrivatekeyFile <> '') then - begin - if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE, - PChar(FPrivatekeyFile), CRYPT_KEYOPT_READONLY)) then - Exit; - try - if not SSLCheck(cryptGetPrivateKey(KeySetObj, cryptcontext, CRYPT_KEYID_NAME, - PChar(FPrivatekeyLabel), PChar(FKeyPassword))) then - Exit; - if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_PRIVATEKEY, - cryptcontext)) then - Exit; - finally - cryptKeysetClose(keySetObj); - cryptDestroyContext(cryptcontext); - end; - end; - if server and FVerifyCert then - begin - if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE, - PChar(FCertCAFile), CRYPT_KEYOPT_READONLY)) then - Exit; - try - if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_KEYSET, - keySetObj)) then - Exit; - finally - cryptKeysetClose(keySetObj); - end; - end; - Result := true; -end; - -function TSSLCryptLib.DeInit: Boolean; -begin - Result := True; - if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then - CryptDestroySession(FcryptSession); - FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); - FSSLEnabled := False; - if FDelCert then - Deletefile(FPrivatekeyFile); -end; - -function TSSLCryptLib.Prepare(server:Boolean): Boolean; -begin - Result := false; - DeInit; - if Init(server) then - Result := true - else - DeInit; -end; - -function TSSLCryptLib.Connect: boolean; -begin - Result := False; - if FSocket.Socket = INVALID_SOCKET then - Exit; - if Prepare(false) then - begin - if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then - Exit; - if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then - Exit; - FSSLEnabled := True; - Result := True; - FReadBuffer := ''; - end; -end; - -function TSSLCryptLib.Accept: boolean; -begin - Result := False; - if FSocket.Socket = INVALID_SOCKET then - Exit; - if Prepare(true) then - begin - if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then - Exit; - if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then - Exit; - FSSLEnabled := True; - Result := True; - FReadBuffer := ''; - end; -end; - -function TSSLCryptLib.Shutdown: boolean; -begin - Result := BiShutdown; -end; - -function TSSLCryptLib.BiShutdown: boolean; -begin - if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then - cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0); - DeInit; - FReadBuffer := ''; - Result := True; -end; - -function TSSLCryptLib.SendBuffer(Buffer: TMemory; Len: Integer): Integer; -var - l: integer; -begin - FLastError := 0; - FLastErrorDesc := ''; - SSLCheck(cryptPushData(FCryptSession, Buffer, Len, L)); - cryptFlushData(FcryptSession); - Result := l; -end; - -function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; -var - l: integer; -begin - FLastError := 0; - FLastErrorDesc := ''; - if Length(FReadBuffer) = 0 then - FReadBuffer := PopAll; - if Len > Length(FReadBuffer) then - Len := Length(FReadBuffer); - Move(Pointer(FReadBuffer)^, buffer^, Len); - Delete(FReadBuffer, 1, Len); - Result := Len; -end; - -function TSSLCryptLib.WaitingData: Integer; -begin - Result := Length(FReadBuffer); -end; - -function TSSLCryptLib.GetSSLVersion: string; -var - x: integer; -begin - Result := ''; - if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then - Exit; - cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x); - if FSSLType in [LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_all] then - case x of - 0: - Result := 'SSLv3'; - 1: - Result := 'TLSv1'; - 2: - Result := 'TLSv1.1'; - end; - if FSSLType in [LT_SSHv2] then - case x of - 0: - Result := 'SSHv1'; - 1: - Result := 'SSHv2'; - end; -end; - -function TSSLCryptLib.GetPeerSubject: string; -var - cert: CRYPT_CERTIFICATE; -begin - Result := ''; - if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then - Exit; - cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); - cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTNAME, CRYPT_UNUSED); - Result := GetString(cert, CRYPT_CERTINFO_DN); - cryptDestroyCert(cert); -end; - -function TSSLCryptLib.GetPeerName: string; -var - cert: CRYPT_CERTIFICATE; -begin - Result := ''; - if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then - Exit; - cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); - cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED); - Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME); - cryptDestroyCert(cert); -end; - -function TSSLCryptLib.GetPeerIssuer: string; -var - cert: CRYPT_CERTIFICATE; -begin - Result := ''; - if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then - Exit; - cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); - cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED); - Result := GetString(cert, CRYPT_CERTINFO_DN); - cryptDestroyCert(cert); -end; - -function TSSLCryptLib.GetPeerFingerprint: string; -var - cert: CRYPT_CERTIFICATE; -begin - Result := ''; - if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then - Exit; - cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); - Result := GetString(cert, CRYPT_CERTINFO_FINGERPRINT); - Result := MD5(Result); - cryptDestroyCert(cert); -end; - -{==============================================================================} - -initialization - if cryptInit = CRYPT_OK then - SSLImplementation := TSSLCryptLib; - cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL); - -finalization - cryptEnd; - -end. - diff --git a/addons/synapse/ssl_openssl.pas b/addons/synapse/ssl_openssl.pas deleted file mode 100644 index 1629bab..0000000 --- a/addons/synapse/ssl_openssl.pas +++ /dev/null @@ -1,825 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.001 | -|==============================================================================| -| Content: SSL support by OpenSSL | -|==============================================================================| -| Copyright (c)1999-2008, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2005-2008. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -//requires OpenSSL libraries! - -{:@abstract(SSL plugin for OpenSSL) - -You need OpenSSL libraries version 0.9.7. It can work with 0.9.6 too, but -application mysteriously crashing when you are using freePascal on Linux. -Use Kylix on Linux is OK! If you have version 0.9.7 on Linux, then I not see -any problems with FreePascal. - -OpenSSL libraries are loaded dynamicly - you not need OpenSSl librares even you -compile your application with this unit. SSL just not working when you not have -OpenSSL libraries. - -This plugin have limited support for .NET too! Because is not possible to use -callbacks with CDECL calling convention under .NET, is not supported -key/certificate passwords and multithread locking. :-( - -For handling keys and certificates you can use this properties: - -@link(TCustomSSL.CertificateFile) for PEM or ASN1 DER (cer) format. @br -@link(TCustomSSL.Certificate) for ASN1 DER format only. @br -@link(TCustomSSL.PrivateKeyFile) for PEM or ASN1 DER (key) format. @br -@link(TCustomSSL.PrivateKey) for ASN1 DER format only. @br -@link(TCustomSSL.CertCAFile) for PEM CA certificate bundle. @br -@link(TCustomSSL.PFXFile) for PFX format. @br -@link(TCustomSSL.PFX) for PFX format from binary string. @br - -This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS -server without explicitly assigned key and certificate, then this plugin create -Ad-Hoc key and certificate for each incomming connection by self. It slowdown -accepting of new connections! -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit ssl_openssl; - -interface - -uses - SysUtils, Classes, - blcksock, synsock, synautil, -{$IFDEF CIL} - System.Text, -{$ENDIF} - ssl_openssl_lib; - -type - {:@abstract(class implementing OpenSSL SSL plugin.) - Instance of this class will be created for each @link(TTCPBlockSocket). - You not need to create instance of this class, all is done by Synapse itself!} - TSSLOpenSSL = class(TCustomSSL) - protected - FSsl: PSSL; - Fctx: PSSL_CTX; - function SSLCheck: Boolean; - function SetSslKeys: boolean; - function Init(server:Boolean): Boolean; - function DeInit: Boolean; - function Prepare(server:Boolean): Boolean; - function LoadPFX(pfxdata: ansistring): Boolean; - function CreateSelfSignedCert(Host: string): Boolean; override; - public - {:See @inherited} - constructor Create(const Value: TTCPBlockSocket); override; - destructor Destroy; override; - {:See @inherited} - function LibVersion: String; override; - {:See @inherited} - function LibName: String; override; - {:See @inherited and @link(ssl_cryptlib) for more details.} - function Connect: boolean; override; - {:See @inherited and @link(ssl_cryptlib) for more details.} - function Accept: boolean; override; - {:See @inherited} - function Shutdown: boolean; override; - {:See @inherited} - function BiShutdown: boolean; override; - {:See @inherited} - function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function WaitingData: Integer; override; - {:See @inherited} - function GetSSLVersion: string; override; - {:See @inherited} - function GetPeerSubject: string; override; - {:See @inherited} - function GetPeerIssuer: string; override; - {:See @inherited} - function GetPeerName: string; override; - {:See @inherited} - function GetPeerFingerprint: string; override; - {:See @inherited} - function GetCertInfo: string; override; - {:See @inherited} - function GetCipherName: string; override; - {:See @inherited} - function GetCipherBits: integer; override; - {:See @inherited} - function GetCipherAlgBits: integer; override; - {:See @inherited} - function GetVerifyCert: integer; override; - end; - -implementation - -{==============================================================================} - -{$IFNDEF CIL} -function PasswordCallback(buf:PAnsiChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl; -var - Password: AnsiString; -begin - Password := ''; - if TCustomSSL(userdata) is TCustomSSL then - Password := TCustomSSL(userdata).KeyPassword; - if Length(Password) > (Size - 1) then - SetLength(Password, Size - 1); - Result := Length(Password); - StrLCopy(buf, PAnsiChar(Password + #0), Result + 1); -end; -{$ENDIF} - -{==============================================================================} - -constructor TSSLOpenSSL.Create(const Value: TTCPBlockSocket); -begin - inherited Create(Value); - FCiphers := 'DEFAULT'; - FSsl := nil; - Fctx := nil; -end; - -destructor TSSLOpenSSL.Destroy; -begin - DeInit; - inherited Destroy; -end; - -function TSSLOpenSSL.LibVersion: String; -begin - Result := SSLeayversion(0); -end; - -function TSSLOpenSSL.LibName: String; -begin - Result := 'ssl_openssl'; -end; - -function TSSLOpenSSL.SSLCheck: Boolean; -var -{$IFDEF CIL} - sb: StringBuilder; -{$ENDIF} - s : AnsiString; -begin - Result := true; - FLastErrorDesc := ''; - FLastError := ErrGetError; - ErrClearError; - if FLastError <> 0 then - begin - Result := False; -{$IFDEF CIL} - sb := StringBuilder.Create(256); - ErrErrorString(FLastError, sb, 256); - FLastErrorDesc := Trim(sb.ToString); -{$ELSE} - s := StringOfChar(#0, 256); - ErrErrorString(FLastError, s, Length(s)); - FLastErrorDesc := s; -{$ENDIF} - end; -end; - -function TSSLOpenSSL.CreateSelfSignedCert(Host: string): Boolean; -var - pk: EVP_PKEY; - x: PX509; - rsa: PRSA; - t: PASN1_UTCTIME; - name: PX509_NAME; - b: PBIO; - xn, y: integer; - s: AnsiString; -{$IFDEF CIL} - sb: StringBuilder; -{$ENDIF} -begin - Result := True; - pk := EvpPkeynew; - x := X509New; - try - rsa := RsaGenerateKey(1024, $10001, nil, nil); - EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa); - X509SetVersion(x, 2); - Asn1IntegerSet(X509getSerialNumber(x), 0); - t := Asn1UtctimeNew; - try - X509GmtimeAdj(t, -60 * 60 *24); - X509SetNotBefore(x, t); - X509GmtimeAdj(t, 60 * 60 * 60 *24); - X509SetNotAfter(x, t); - finally - Asn1UtctimeFree(t); - end; - X509SetPubkey(x, pk); - Name := X509GetSubjectName(x); - X509NameAddEntryByTxt(Name, 'C', $1001, 'CZ', -1, -1, 0); - X509NameAddEntryByTxt(Name, 'CN', $1001, host, -1, -1, 0); - x509SetIssuerName(x, Name); - x509Sign(x, pk, EvpGetDigestByName('SHA1')); - b := BioNew(BioSMem); - try - i2dX509Bio(b, x); - xn := bioctrlpending(b); -{$IFDEF CIL} - sb := StringBuilder.Create(xn); - y := bioread(b, sb, xn); - if y > 0 then - begin - sb.Length := y; - s := sb.ToString; - end; -{$ELSE} - setlength(s, xn); - y := bioread(b, s, xn); - if y > 0 then - setlength(s, y); -{$ENDIF} - finally - BioFreeAll(b); - end; - FCertificate := s; - b := BioNew(BioSMem); - try - i2dPrivatekeyBio(b, pk); - xn := bioctrlpending(b); -{$IFDEF CIL} - sb := StringBuilder.Create(xn); - y := bioread(b, sb, xn); - if y > 0 then - begin - sb.Length := y; - s := sb.ToString; - end; -{$ELSE} - setlength(s, xn); - y := bioread(b, s, xn); - if y > 0 then - setlength(s, y); -{$ENDIF} - finally - BioFreeAll(b); - end; - FPrivatekey := s; - finally - X509free(x); - EvpPkeyFree(pk); - end; -end; - -function TSSLOpenSSL.LoadPFX(pfxdata: Ansistring): Boolean; -var - cert, pkey, ca: SslPtr; - b: PBIO; - p12: SslPtr; -begin - Result := False; - b := BioNew(BioSMem); - try - BioWrite(b, pfxdata, Length(PfxData)); - p12 := d2iPKCS12bio(b, nil); - if not Assigned(p12) then - Exit; - try - cert := nil; - pkey := nil; - ca := nil; - if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then - if SSLCTXusecertificate(Fctx, cert) > 0 then - if SSLCTXusePrivateKey(Fctx, pkey) > 0 then - Result := True; - finally - PKCS12free(p12); - end; - finally - BioFreeAll(b); - end; -end; - -function TSSLOpenSSL.SetSslKeys: boolean; -var - st: TFileStream; - s: string; -begin - Result := False; - if not assigned(FCtx) then - Exit; - try - if FCertificateFile <> '' then - if SslCtxUseCertificateChainFile(FCtx, FCertificateFile) <> 1 then - if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_PEM) <> 1 then - if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_ASN1) <> 1 then - Exit; - if FCertificate <> '' then - if SslCtxUseCertificateASN1(FCtx, length(FCertificate), FCertificate) <> 1 then - Exit; - SSLCheck; - if FPrivateKeyFile <> '' then - if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_PEM) <> 1 then - if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_ASN1) <> 1 then - Exit; - if FPrivateKey <> '' then - if SslCtxUsePrivateKeyASN1(EVP_PKEY_RSA, FCtx, FPrivateKey, length(FPrivateKey)) <> 1 then - Exit; - SSLCheck; - if FCertCAFile <> '' then - if SslCtxLoadVerifyLocations(FCtx, FCertCAFile, '') <> 1 then - Exit; - if FPFXfile <> '' then - begin - try - st := TFileStream.Create(FPFXfile, fmOpenRead or fmShareDenyNone); - try - s := ReadStrFromStream(st, st.Size); - finally - st.Free; - end; - if not LoadPFX(s) then - Exit; - except - on Exception do - Exit; - end; - end; - if FPFX <> '' then - if not LoadPFX(FPfx) then - Exit; - SSLCheck; - Result := True; - finally - SSLCheck; - end; -end; - -function TSSLOpenSSL.Init(server:Boolean): Boolean; -var - s: AnsiString; -begin - Result := False; - FLastErrorDesc := ''; - FLastError := 0; - Fctx := nil; - case FSSLType of - LT_SSLv2: - Fctx := SslCtxNew(SslMethodV2); - LT_SSLv3: - Fctx := SslCtxNew(SslMethodV3); - LT_TLSv1: - Fctx := SslCtxNew(SslMethodTLSV1); - LT_all: - Fctx := SslCtxNew(SslMethodV23); - else - Exit; - end; - if Fctx = nil then - begin - SSLCheck; - Exit; - end - else - begin - s := FCiphers; - SslCtxSetCipherList(Fctx, s); - if FVerifyCert then - SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil) - else - SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil); -{$IFNDEF CIL} - SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback); - SslCtxSetDefaultPasswdCbUserdata(FCtx, self); -{$ENDIF} - - if server and (FCertificateFile = '') and (FCertificate = '') - and (FPFXfile = '') and (FPFX = '') then - begin - CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP)); - end; - - if not SetSSLKeys then - Exit - else - begin - Fssl := nil; - Fssl := SslNew(Fctx); - if Fssl = nil then - begin - SSLCheck; - exit; - end; - end; - end; - Result := true; -end; - -function TSSLOpenSSL.DeInit: Boolean; -begin - Result := True; - if assigned (Fssl) then - sslfree(Fssl); - Fssl := nil; - if assigned (Fctx) then - begin - SslCtxFree(Fctx); - Fctx := nil; - ErrRemoveState(0); - end; - FSSLEnabled := False; -end; - -function TSSLOpenSSL.Prepare(server:Boolean): Boolean; -begin - Result := false; - DeInit; - if Init(server) then - Result := true - else - DeInit; -end; - -function TSSLOpenSSL.Connect: boolean; -var - x: integer; -begin - Result := False; - if FSocket.Socket = INVALID_SOCKET then - Exit; - if Prepare(False) then - begin -{$IFDEF CIL} - if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then -{$ELSE} - if sslsetfd(FSsl, FSocket.Socket) < 1 then -{$ENDIF} - begin - SSLCheck; - Exit; - end; - x := sslconnect(FSsl); - if x < 1 then - begin - SSLcheck; - Exit; - end; - if FverifyCert then - if GetVerifyCert <> 0 then - Exit; - FSSLEnabled := True; - Result := True; - end; -end; - -function TSSLOpenSSL.Accept: boolean; -var - x: integer; -begin - Result := False; - if FSocket.Socket = INVALID_SOCKET then - Exit; - if Prepare(True) then - begin -{$IFDEF CIL} - if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then -{$ELSE} - if sslsetfd(FSsl, FSocket.Socket) < 1 then -{$ENDIF} - begin - SSLCheck; - Exit; - end; - x := sslAccept(FSsl); - if x < 1 then - begin - SSLcheck; - Exit; - end; - FSSLEnabled := True; - Result := True; - end; -end; - -function TSSLOpenSSL.Shutdown: boolean; -begin - if assigned(FSsl) then - sslshutdown(FSsl); - DeInit; - Result := True; -end; - -function TSSLOpenSSL.BiShutdown: boolean; -var - x: integer; -begin - if assigned(FSsl) then - begin - x := sslshutdown(FSsl); - if x = 0 then - begin - Synsock.Shutdown(FSocket.Socket, 1); - sslshutdown(FSsl); - end; - end; - DeInit; - Result := True; -end; - -function TSSLOpenSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer; -var - err: integer; -{$IFDEF CIL} - s: ansistring; -{$ENDIF} -begin - FLastError := 0; - FLastErrorDesc := ''; - repeat -{$IFDEF CIL} - s := StringOf(Buffer); - Result := SslWrite(FSsl, s, Len); -{$ELSE} - Result := SslWrite(FSsl, Buffer , Len); -{$ENDIF} - err := SslGetError(FSsl, Result); - until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); - if err = SSL_ERROR_ZERO_RETURN then - Result := 0 - else - if (err <> 0) then - FLastError := err; -end; - -function TSSLOpenSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; -var - err: integer; -{$IFDEF CIL} - sb: stringbuilder; - s: ansistring; -{$ENDIF} -begin - FLastError := 0; - FLastErrorDesc := ''; - repeat -{$IFDEF CIL} - sb := StringBuilder.Create(Len); - Result := SslRead(FSsl, sb, Len); - if Result > 0 then - begin - sb.Length := Result; - s := sb.ToString; - System.Array.Copy(BytesOf(s), Buffer, length(s)); - end; -{$ELSE} - Result := SslRead(FSsl, Buffer , Len); -{$ENDIF} - err := SslGetError(FSsl, Result); - until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); - if err = SSL_ERROR_ZERO_RETURN then - Result := 0; - if (err <> 0) then - FLastError := err; -end; - -function TSSLOpenSSL.WaitingData: Integer; -begin - Result := sslpending(Fssl); -end; - -function TSSLOpenSSL.GetSSLVersion: string; -begin - if not assigned(FSsl) then - Result := '' - else - Result := SSlGetVersion(FSsl); -end; - -function TSSLOpenSSL.GetPeerSubject: string; -var - cert: PX509; - s: ansistring; -{$IFDEF CIL} - sb: StringBuilder; -{$ENDIF} -begin - if not assigned(FSsl) then - begin - Result := ''; - Exit; - end; - cert := SSLGetPeerCertificate(Fssl); - if not assigned(cert) then - begin - Result := ''; - Exit; - end; -{$IFDEF CIL} - sb := StringBuilder.Create(4096); - Result := X509NameOneline(X509GetSubjectName(cert), sb, 4096); -{$ELSE} - setlength(s, 4096); - Result := X509NameOneline(X509GetSubjectName(cert), s, Length(s)); -{$ENDIF} - X509Free(cert); -end; - -function TSSLOpenSSL.GetPeerName: string; -var - s: ansistring; -begin - s := GetPeerSubject; - s := SeparateRight(s, '/CN='); - Result := Trim(SeparateLeft(s, '/')); -end; - -function TSSLOpenSSL.GetPeerIssuer: string; -var - cert: PX509; - s: ansistring; -{$IFDEF CIL} - sb: StringBuilder; -{$ENDIF} -begin - if not assigned(FSsl) then - begin - Result := ''; - Exit; - end; - cert := SSLGetPeerCertificate(Fssl); - if not assigned(cert) then - begin - Result := ''; - Exit; - end; -{$IFDEF CIL} - sb := StringBuilder.Create(4096); - Result := X509NameOneline(X509GetIssuerName(cert), sb, 4096); -{$ELSE} - setlength(s, 4096); - Result := X509NameOneline(X509GetIssuerName(cert), s, Length(s)); -{$ENDIF} - X509Free(cert); -end; - -function TSSLOpenSSL.GetPeerFingerprint: string; -var - cert: PX509; - x: integer; -{$IFDEF CIL} - sb: StringBuilder; -{$ENDIF} -begin - if not assigned(FSsl) then - begin - Result := ''; - Exit; - end; - cert := SSLGetPeerCertificate(Fssl); - if not assigned(cert) then - begin - Result := ''; - Exit; - end; -{$IFDEF CIL} - sb := StringBuilder.Create(EVP_MAX_MD_SIZE); - X509Digest(cert, EvpGetDigestByName('MD5'), sb, x); - sb.Length := x; - Result := sb.ToString; -{$ELSE} - setlength(Result, EVP_MAX_MD_SIZE); - X509Digest(cert, EvpGetDigestByName('MD5'), Result, x); - SetLength(Result, x); -{$ENDIF} - X509Free(cert); -end; - -function TSSLOpenSSL.GetCertInfo: string; -var - cert: PX509; - x, y: integer; - b: PBIO; - s: AnsiString; -{$IFDEF CIL} - sb: stringbuilder; -{$ENDIF} -begin - if not assigned(FSsl) then - begin - Result := ''; - Exit; - end; - cert := SSLGetPeerCertificate(Fssl); - if not assigned(cert) then - begin - Result := ''; - Exit; - end; - b := BioNew(BioSMem); - try - X509Print(b, cert); - x := bioctrlpending(b); -{$IFDEF CIL} - sb := StringBuilder.Create(x); - y := bioread(b, sb, x); - if y > 0 then - begin - sb.Length := y; - s := sb.ToString; - end; -{$ELSE} - setlength(s,x); - y := bioread(b,s,x); - if y > 0 then - setlength(s, y); -{$ENDIF} - Result := ReplaceString(s, LF, CRLF); - finally - BioFreeAll(b); - end; -end; - -function TSSLOpenSSL.GetCipherName: string; -begin - if not assigned(FSsl) then - Result := '' - else - Result := SslCipherGetName(SslGetCurrentCipher(FSsl)); -end; - -function TSSLOpenSSL.GetCipherBits: integer; -var - x: integer; -begin - if not assigned(FSsl) then - Result := 0 - else - Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), x); -end; - -function TSSLOpenSSL.GetCipherAlgBits: integer; -begin - if not assigned(FSsl) then - Result := 0 - else - SSLCipherGetBits(SslGetCurrentCipher(FSsl), Result); -end; - -function TSSLOpenSSL.GetVerifyCert: integer; -begin - if not assigned(FSsl) then - Result := 1 - else - Result := SslGetVerifyResult(FSsl); -end; - -{==============================================================================} - -initialization - if InitSSLInterface then - SSLImplementation := TSSLOpenSSL; - -end. diff --git a/addons/synapse/ssl_openssl_lib.pas b/addons/synapse/ssl_openssl_lib.pas deleted file mode 100644 index f073c58..0000000 --- a/addons/synapse/ssl_openssl_lib.pas +++ /dev/null @@ -1,2047 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 003.006.002 | -|==============================================================================| -| Content: SSL support by OpenSSL | -|==============================================================================| -| 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/) | -|==============================================================================} - -{ -Special thanks to Gregor Ibic - (Intelicom d.o.o., http://www.intelicom.si) - for good inspiration about begin with SSL programming. -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} -{$IFDEF VER125} - {$DEFINE BCB} -{$ENDIF} -{$IFDEF BCB} - {$ObjExportAll On} - (*$HPPEMIT 'namespace ssl_openssl_lib { using System::Shortint; }' *) -{$ENDIF} - -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -{:@abstract(OpenSSL support) - -This unit is Pascal interface to OpenSSL library (used by @link(ssl_openssl) unit). -OpenSSL is loaded dynamicly on-demand. If this library is not found in system, -requested OpenSSL function just return errorcode. -} -unit ssl_openssl_lib; - -interface - -uses -{$IFDEF CIL} - System.Runtime.InteropServices, - System.Text, -{$ENDIF} - Classes, - synafpc, -{$IFNDEF MSWINDOWS} - {$IFDEF FPC} - BaseUnix, SysUtils; - {$ELSE} - Libc, SysUtils; - {$ENDIF} -{$ELSE} - Windows; -{$ENDIF} - - -{$IFDEF CIL} -const - {$IFDEF LINUX} - DLLSSLName = 'libssl.so'; - DLLUtilName = 'libcrypto.so'; - {$ELSE} - DLLSSLName = 'ssleay32.dll'; - DLLUtilName = 'libeay32.dll'; - {$ENDIF} -{$ELSE} -var - {$IFNDEF MSWINDOWS} - DLLSSLName: string = 'libssl.so'; - DLLUtilName: string = 'libcrypto.so'; - {$ELSE} - DLLSSLName: string = 'ssleay32.dll'; - DLLSSLName2: string = 'libssl32.dll'; - DLLUtilName: string = 'libeay32.dll'; - {$ENDIF} -{$ENDIF} - -type -{$IFDEF CIL} - SslPtr = IntPtr; -{$ELSE} - SslPtr = Pointer; -{$ENDIF} - PSslPtr = ^SslPtr; - PSSL_CTX = SslPtr; - PSSL = SslPtr; - PSSL_METHOD = SslPtr; - PX509 = SslPtr; - PX509_NAME = SslPtr; - PEVP_MD = SslPtr; - PInteger = ^Integer; - PBIO_METHOD = SslPtr; - PBIO = SslPtr; - EVP_PKEY = SslPtr; - PRSA = SslPtr; - PASN1_UTCTIME = SslPtr; - PASN1_INTEGER = SslPtr; - PPasswdCb = SslPtr; - PFunction = procedure; - - DES_cblock = array[0..7] of Byte; - PDES_cblock = ^DES_cblock; - des_ks_struct = packed record - ks: DES_cblock; - weak_key: Integer; - end; - des_key_schedule = array[1..16] of des_ks_struct; - -const - EVP_MAX_MD_SIZE = 16 + 20; - - SSL_ERROR_NONE = 0; - SSL_ERROR_SSL = 1; - SSL_ERROR_WANT_READ = 2; - SSL_ERROR_WANT_WRITE = 3; - SSL_ERROR_WANT_X509_LOOKUP = 4; - SSL_ERROR_SYSCALL = 5; //look at error stack/return value/errno - SSL_ERROR_ZERO_RETURN = 6; - SSL_ERROR_WANT_CONNECT = 7; - SSL_ERROR_WANT_ACCEPT = 8; - - SSL_OP_NO_SSLv2 = $01000000; - SSL_OP_NO_SSLv3 = $02000000; - SSL_OP_NO_TLSv1 = $04000000; - SSL_OP_ALL = $000FFFFF; - SSL_VERIFY_NONE = $00; - SSL_VERIFY_PEER = $01; - - OPENSSL_DES_DECRYPT = 0; - OPENSSL_DES_ENCRYPT = 1; - - X509_V_OK = 0; - X509_V_ILLEGAL = 1; - X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT = 2; - X509_V_ERR_UNABLE_TO_GET_CRL = 3; - X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE = 4; - X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE = 5; - X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY = 6; - X509_V_ERR_CERT_SIGNATURE_FAILURE = 7; - X509_V_ERR_CRL_SIGNATURE_FAILURE = 8; - X509_V_ERR_CERT_NOT_YET_VALID = 9; - X509_V_ERR_CERT_HAS_EXPIRED = 10; - X509_V_ERR_CRL_NOT_YET_VALID = 11; - X509_V_ERR_CRL_HAS_EXPIRED = 12; - X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD = 13; - X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD = 14; - X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD = 15; - X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD = 16; - X509_V_ERR_OUT_OF_MEM = 17; - X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT = 18; - X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN = 19; - X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY = 20; - X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE = 21; - X509_V_ERR_CERT_CHAIN_TOO_LONG = 22; - X509_V_ERR_CERT_REVOKED = 23; - X509_V_ERR_INVALID_CA = 24; - X509_V_ERR_PATH_LENGTH_EXCEEDED = 25; - X509_V_ERR_INVALID_PURPOSE = 26; - X509_V_ERR_CERT_UNTRUSTED = 27; - X509_V_ERR_CERT_REJECTED = 28; - //These are 'informational' when looking for issuer cert - X509_V_ERR_SUBJECT_ISSUER_MISMATCH = 29; - X509_V_ERR_AKID_SKID_MISMATCH = 30; - X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH = 31; - X509_V_ERR_KEYUSAGE_NO_CERTSIGN = 32; - X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER = 33; - X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION = 34; - //The application is not happy - X509_V_ERR_APPLICATION_VERIFICATION = 50; - - SSL_FILETYPE_ASN1 = 2; - SSL_FILETYPE_PEM = 1; - EVP_PKEY_RSA = 6; - -var - SSLLibHandle: TLibHandle = 0; - SSLUtilHandle: TLibHandle = 0; - SSLLibFile: string = ''; - SSLUtilFile: string = ''; - -{$IFDEF CIL} - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_get_error')] - function SslGetError(s: PSSL; ret_code: Integer): Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_library_init')] - function SslLibraryInit: Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_load_error_strings')] - procedure SslLoadErrorStrings; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_set_cipher_list')] - function SslCtxSetCipherList(arg0: PSSL_CTX; var str: String): Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_new')] - function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_free')] - procedure SslCtxFree (arg0: PSSL_CTX); external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_set_fd')] - function SslSetFd(s: PSSL; fd: Integer):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSLv2_method')] - function SslMethodV2 : PSSL_METHOD; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSLv3_method')] - function SslMethodV3 : PSSL_METHOD; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'TLSv1_method')] - function SslMethodTLSV1:PSSL_METHOD; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSLv23_method')] - function SslMethodV23 : PSSL_METHOD; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_use_PrivateKey')] - function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_use_PrivateKey_ASN1')] - function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: String; len: integer):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_use_RSAPrivateKey_file')] - function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_use_certificate')] - function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_use_certificate_ASN1')] - function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: String):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_use_certificate_file')] - function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer;external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_use_certificate_chain_file')] - function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: String):Integer;external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_check_private_key')] - function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_set_default_passwd_cb')] - procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_set_default_passwd_cb_userdata')] - procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: IntPtr); external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_load_verify_locations')] - function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; CAfile: string; CApath: String):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_ctrl')] - function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: IntPtr): integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_new')] - function SslNew(ctx: PSSL_CTX):PSSL; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_free')] - procedure SslFree(ssl: PSSL); external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_accept')] - function SslAccept(ssl: PSSL):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_connect')] - function SslConnect(ssl: PSSL):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_shutdown')] - function SslShutdown(s: PSSL):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_read')] - function SslRead(ssl: PSSL; buf: StringBuilder; num: Integer):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_peek')] - function SslPeek(ssl: PSSL; buf: StringBuilder; num: Integer):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_write')] - function SslWrite(ssl: PSSL; buf: String; num: Integer):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_pending')] - function SslPending(ssl: PSSL):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_get_version')] - function SslGetVersion(ssl: PSSL):String; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_get_peer_certificate')] - function SslGetPeerCertificate(s: PSSL):PX509; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_set_verify')] - procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_get_current_cipher')] - function SSLGetCurrentCipher(s: PSSL): SslPtr; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CIPHER_get_name')] - function SSLCipherGetName(c: SslPtr):String; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CIPHER_get_bits')] - function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_get_verify_result')] - function SSLGetVerifyResult(ssl: PSSL):Integer;external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_new')] - function X509New: PX509; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_free')] - procedure X509Free(x: PX509); external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_NAME_oneline')] - function X509NameOneline(a: PX509_NAME; buf: StringBuilder; size: Integer): String; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_get_subject_name')] - function X509GetSubjectName(a: PX509):PX509_NAME; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_get_issuer_name')] - function X509GetIssuerName(a: PX509):PX509_NAME; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_NAME_hash')] - function X509NameHash(x: PX509_NAME):Cardinal; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_digest')] - function X509Digest (data: PX509; _type: PEVP_MD; md: StringBuilder; var len: Integer):Integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_set_version')] - function X509SetVersion(x: PX509; version: integer): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_set_pubkey')] - function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_set_issuer_name')] - function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_NAME_add_entry_by_txt')] - function X509NameAddEntryByTxt(name: PX509_NAME; field: string; _type: integer; - bytes: string; len, loc, _set: integer): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_sign')] - function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_print')] - function X509print(b: PBIO; a: PX509): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_gmtime_adj')] - function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_set_notBefore')] - function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_set_notAfter')] - function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_get_serialNumber')] - function X509GetSerialNumber(x: PX509): PASN1_INTEGER; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'EVP_PKEY_new')] - function EvpPkeyNew: EVP_PKEY; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'EVP_PKEY_free')] - procedure EvpPkeyFree(pk: EVP_PKEY); external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'EVP_PKEY_assign')] - function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'EVP_get_digestbyname')] - function EvpGetDigestByName(Name: String): PEVP_MD; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'EVP_cleanup')] - procedure EVPcleanup; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSLeay_version')] - function SSLeayversion(t: integer): String; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'ERR_error_string_n')] - procedure ErrErrorString(e: integer; buf: StringBuilder; len: integer); external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'ERR_get_error')] - function ErrGetError: integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'ERR_clear_error')] - procedure ErrClearError; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'ERR_free_strings')] - procedure ErrFreeStrings; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'ERR_remove_state')] - procedure ErrRemoveState(pid: integer); external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'OPENSSL_add_all_algorithms_noconf')] - procedure OPENSSLaddallalgorithms; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'CRYPTO_cleanup_all_ex_data')] - procedure CRYPTOcleanupAllExData; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'RAND_screen')] - procedure RandScreen; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'BIO_new')] - function BioNew(b: PBIO_METHOD): PBIO; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'BIO_free_all')] - procedure BioFreeAll(b: PBIO); external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'BIO_s_mem')] - function BioSMem: PBIO_METHOD; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'BIO_ctrl_pending')] - function BioCtrlPending(b: PBIO): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'BIO_read')] - function BioRead(b: PBIO; Buf: StringBuilder; Len: integer): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'BIO_write')] - function BioWrite(b: PBIO; var Buf: String; Len: integer): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'd2i_PKCS12_bio')] - function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'PKCS12_parse')] - function PKCS12parse(p12: SslPtr; pass: string; var pkey, cert, ca: SslPtr): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'PKCS12_free')] - procedure PKCS12free(p12: SslPtr); external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'RSA_generate_key')] - function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'ASN1_UTCTIME_new')] - function Asn1UtctimeNew: PASN1_UTCTIME; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'ASN1_UTCTIME_free')] - procedure Asn1UtctimeFree(a: PASN1_UTCTIME); external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'ASN1_INTEGER_set')] - function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'i2d_X509_bio')] - function i2dX509bio(b: PBIO; x: PX509): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'i2d_PrivateKey_bio')] - function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; external; - - // 3DES functions - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'DES_set_odd_parity')] - procedure DESsetoddparity(Key: des_cblock); external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'DES_set_key_checked')] - function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'DES_ecb_encrypt')] - procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); external; - -{$ELSE} -// libssl.dll - function SslGetError(s: PSSL; ret_code: Integer):Integer; - function SslLibraryInit:Integer; - procedure SslLoadErrorStrings; -// function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer; - function SslCtxSetCipherList(arg0: PSSL_CTX; var str: AnsiString):Integer; - function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; - procedure SslCtxFree(arg0: PSSL_CTX); - function SslSetFd(s: PSSL; fd: Integer):Integer; - function SslMethodV2:PSSL_METHOD; - function SslMethodV3:PSSL_METHOD; - function SslMethodTLSV1:PSSL_METHOD; - function SslMethodV23:PSSL_METHOD; - function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; - function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: AnsiString; len: integer):Integer; -// function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; - function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer; - function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; - function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: AnsiString):Integer; - function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer; -// function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; - function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: AnsiString):Integer; - function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; - procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); - procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr); -// function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; - function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: AnsiString; const CApath: AnsiString):Integer; - function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; - function SslNew(ctx: PSSL_CTX):PSSL; - procedure SslFree(ssl: PSSL); - function SslAccept(ssl: PSSL):Integer; - function SslConnect(ssl: PSSL):Integer; - function SslShutdown(ssl: PSSL):Integer; - function SslRead(ssl: PSSL; buf: SslPtr; num: Integer):Integer; - function SslPeek(ssl: PSSL; buf: SslPtr; num: Integer):Integer; - function SslWrite(ssl: PSSL; buf: SslPtr; num: Integer):Integer; - function SslPending(ssl: PSSL):Integer; - function SslGetVersion(ssl: PSSL):AnsiString; - function SslGetPeerCertificate(ssl: PSSL):PX509; - procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); - function SSLGetCurrentCipher(s: PSSL):SslPtr; - function SSLCipherGetName(c: SslPtr): AnsiString; - function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; - function SSLGetVerifyResult(ssl: PSSL):Integer; - -// libeay.dll - function X509New: PX509; - procedure X509Free(x: PX509); - function X509NameOneline(a: PX509_NAME; var buf: AnsiString; size: Integer):AnsiString; - function X509GetSubjectName(a: PX509):PX509_NAME; - function X509GetIssuerName(a: PX509):PX509_NAME; - function X509NameHash(x: PX509_NAME):Cardinal; -// function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; - function X509Digest(data: PX509; _type: PEVP_MD; md: AnsiString; var len: Integer):Integer; - function X509print(b: PBIO; a: PX509): integer; - function X509SetVersion(x: PX509; version: integer): integer; - function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; - function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; - function X509NameAddEntryByTxt(name: PX509_NAME; field: Ansistring; _type: integer; - bytes: Ansistring; len, loc, _set: integer): integer; - function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; - function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; - function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; - function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; - function X509GetSerialNumber(x: PX509): PASN1_INTEGER; - function EvpPkeyNew: EVP_PKEY; - procedure EvpPkeyFree(pk: EVP_PKEY); - function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; - function EvpGetDigestByName(Name: AnsiString): PEVP_MD; - procedure EVPcleanup; -// function ErrErrorString(e: integer; buf: PChar): PChar; - function SSLeayversion(t: integer): Ansistring; - procedure ErrErrorString(e: integer; var buf: Ansistring; len: integer); - function ErrGetError: integer; - procedure ErrClearError; - procedure ErrFreeStrings; - procedure ErrRemoveState(pid: integer); - procedure OPENSSLaddallalgorithms; - procedure CRYPTOcleanupAllExData; - procedure RandScreen; - function BioNew(b: PBIO_METHOD): PBIO; - procedure BioFreeAll(b: PBIO); - function BioSMem: PBIO_METHOD; - function BioCtrlPending(b: PBIO): integer; - function BioRead(b: PBIO; var Buf: AnsiString; Len: integer): integer; - function BioWrite(b: PBIO; Buf: AnsiString; Len: integer): integer; - function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; - function PKCS12parse(p12: SslPtr; pass: Ansistring; var pkey, cert, ca: SslPtr): integer; - procedure PKCS12free(p12: SslPtr); - function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; - function Asn1UtctimeNew: PASN1_UTCTIME; - procedure Asn1UtctimeFree(a: PASN1_UTCTIME); - function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; - function i2dX509bio(b: PBIO; x: PX509): integer; - function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; - - // 3DES functions - procedure DESsetoddparity(Key: des_cblock); - function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; - procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); - -{$ENDIF} - -function IsSSLloaded: Boolean; -function InitSSLInterface: Boolean; -function DestroySSLInterface: Boolean; - -implementation - -uses SyncObjs; - -{$IFNDEF CIL} -type -// libssl.dll - TSslGetError = function(s: PSSL; ret_code: Integer):Integer; cdecl; - TSslLibraryInit = function:Integer; cdecl; - TSslLoadErrorStrings = procedure; cdecl; - TSslCtxSetCipherList = function(arg0: PSSL_CTX; str: PAnsiChar):Integer; cdecl; - TSslCtxNew = function(meth: PSSL_METHOD):PSSL_CTX; cdecl; - TSslCtxFree = procedure(arg0: PSSL_CTX); cdecl; - TSslSetFd = function(s: PSSL; fd: Integer):Integer; cdecl; - TSslMethodV2 = function:PSSL_METHOD; cdecl; - TSslMethodV3 = function:PSSL_METHOD; cdecl; - TSslMethodTLSV1 = function:PSSL_METHOD; cdecl; - TSslMethodV23 = function:PSSL_METHOD; cdecl; - TSslCtxUsePrivateKey = function(ctx: PSSL_CTX; pkey: sslptr):Integer; cdecl; - TSslCtxUsePrivateKeyASN1 = function(pk: integer; ctx: PSSL_CTX; d: sslptr; len: integer):Integer; cdecl; - TSslCtxUsePrivateKeyFile = function(ctx: PSSL_CTX; const _file: PAnsiChar; _type: Integer):Integer; cdecl; - TSslCtxUseCertificate = function(ctx: PSSL_CTX; x: SslPtr):Integer; cdecl; - TSslCtxUseCertificateASN1 = function(ctx: PSSL_CTX; len: Integer; d: SslPtr):Integer; cdecl; - TSslCtxUseCertificateFile = function(ctx: PSSL_CTX; const _file: PAnsiChar; _type: Integer):Integer; cdecl; - TSslCtxUseCertificateChainFile = function(ctx: PSSL_CTX; const _file: PAnsiChar):Integer; cdecl; - TSslCtxCheckPrivateKeyFile = function(ctx: PSSL_CTX):Integer; cdecl; - TSslCtxSetDefaultPasswdCb = procedure(ctx: PSSL_CTX; cb: SslPtr); cdecl; - TSslCtxSetDefaultPasswdCbUserdata = procedure(ctx: PSSL_CTX; u: SslPtr); cdecl; - TSslCtxLoadVerifyLocations = function(ctx: PSSL_CTX; const CAfile: PAnsiChar; const CApath: PAnsiChar):Integer; cdecl; - TSslCtxCtrl = function(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; cdecl; - TSslNew = function(ctx: PSSL_CTX):PSSL; cdecl; - TSslFree = procedure(ssl: PSSL); cdecl; - TSslAccept = function(ssl: PSSL):Integer; cdecl; - TSslConnect = function(ssl: PSSL):Integer; cdecl; - TSslShutdown = function(ssl: PSSL):Integer; cdecl; - TSslRead = function(ssl: PSSL; buf: PAnsiChar; num: Integer):Integer; cdecl; - TSslPeek = function(ssl: PSSL; buf: PAnsiChar; num: Integer):Integer; cdecl; - TSslWrite = function(ssl: PSSL; const buf: PAnsiChar; num: Integer):Integer; cdecl; - TSslPending = function(ssl: PSSL):Integer; cdecl; - TSslGetVersion = function(ssl: PSSL):PAnsiChar; cdecl; - TSslGetPeerCertificate = function(ssl: PSSL):PX509; cdecl; - TSslCtxSetVerify = procedure(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); cdecl; - TSSLGetCurrentCipher = function(s: PSSL):SslPtr; cdecl; - TSSLCipherGetName = function(c: Sslptr):PAnsiChar; cdecl; - TSSLCipherGetBits = function(c: SslPtr; alg_bits: PInteger):Integer; cdecl; - TSSLGetVerifyResult = function(ssl: PSSL):Integer; cdecl; - -// libeay.dll - TX509New = function: PX509; cdecl; - TX509Free = procedure(x: PX509); cdecl; - TX509NameOneline = function(a: PX509_NAME; buf: PAnsiChar; size: Integer):PAnsiChar; cdecl; - TX509GetSubjectName = function(a: PX509):PX509_NAME; cdecl; - TX509GetIssuerName = function(a: PX509):PX509_NAME; cdecl; - TX509NameHash = function(x: PX509_NAME):Cardinal; cdecl; - TX509Digest = function(data: PX509; _type: PEVP_MD; md: PAnsiChar; len: PInteger):Integer; cdecl; - TX509print = function(b: PBIO; a: PX509): integer; cdecl; - TX509SetVersion = function(x: PX509; version: integer): integer; cdecl; - TX509SetPubkey = function(x: PX509; pkey: EVP_PKEY): integer; cdecl; - TX509SetIssuerName = function(x: PX509; name: PX509_NAME): integer; cdecl; - TX509NameAddEntryByTxt = function(name: PX509_NAME; field: PAnsiChar; _type: integer; - bytes: PAnsiChar; len, loc, _set: integer): integer; cdecl; - TX509Sign = function(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; cdecl; - TX509GmtimeAdj = function(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; cdecl; - TX509SetNotBefore = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl; - TX509SetNotAfter = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl; - TX509GetSerialNumber = function(x: PX509): PASN1_INTEGER; cdecl; - TEvpPkeyNew = function: EVP_PKEY; cdecl; - TEvpPkeyFree = procedure(pk: EVP_PKEY); cdecl; - TEvpPkeyAssign = function(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; cdecl; - TEvpGetDigestByName = function(Name: PAnsiChar): PEVP_MD; cdecl; - TEVPcleanup = procedure; cdecl; - TSSLeayversion = function(t: integer): PAnsiChar; cdecl; - TErrErrorString = procedure(e: integer; buf: PAnsiChar; len: integer); cdecl; - TErrGetError = function: integer; cdecl; - TErrClearError = procedure; cdecl; - TErrFreeStrings = procedure; cdecl; - TErrRemoveState = procedure(pid: integer); cdecl; - TOPENSSLaddallalgorithms = procedure; cdecl; - TCRYPTOcleanupAllExData = procedure; cdecl; - TRandScreen = procedure; cdecl; - TBioNew = function(b: PBIO_METHOD): PBIO; cdecl; - TBioFreeAll = procedure(b: PBIO); cdecl; - TBioSMem = function: PBIO_METHOD; cdecl; - TBioCtrlPending = function(b: PBIO): integer; cdecl; - TBioRead = function(b: PBIO; Buf: PAnsiChar; Len: integer): integer; cdecl; - TBioWrite = function(b: PBIO; Buf: PAnsiChar; Len: integer): integer; cdecl; - Td2iPKCS12bio = function(b:PBIO; Pkcs12: SslPtr): SslPtr; cdecl; - TPKCS12parse = function(p12: SslPtr; pass: PAnsiChar; var pkey, cert, ca: SslPtr): integer; cdecl; - TPKCS12free = procedure(p12: SslPtr); cdecl; - TRsaGenerateKey = function(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; cdecl; - TAsn1UtctimeNew = function: PASN1_UTCTIME; cdecl; - TAsn1UtctimeFree = procedure(a: PASN1_UTCTIME); cdecl; - TAsn1IntegerSet = function(a: PASN1_INTEGER; v: integer): integer; cdecl; - Ti2dX509bio = function(b: PBIO; x: PX509): integer; cdecl; - Ti2dPrivateKeyBio= function(b: PBIO; pkey: EVP_PKEY): integer; cdecl; - - // 3DES functions - TDESsetoddparity = procedure(Key: des_cblock); cdecl; - TDESsetkeychecked = function(key: des_cblock; schedule: des_key_schedule): Integer; cdecl; - TDESecbencrypt = procedure(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); cdecl; - //thread lock functions - TCRYPTOnumlocks = function: integer; cdecl; - TCRYPTOSetLockingCallback = procedure(cb: Sslptr); cdecl; - -var -// libssl.dll - _SslGetError: TSslGetError = nil; - _SslLibraryInit: TSslLibraryInit = nil; - _SslLoadErrorStrings: TSslLoadErrorStrings = nil; - _SslCtxSetCipherList: TSslCtxSetCipherList = nil; - _SslCtxNew: TSslCtxNew = nil; - _SslCtxFree: TSslCtxFree = nil; - _SslSetFd: TSslSetFd = nil; - _SslMethodV2: TSslMethodV2 = nil; - _SslMethodV3: TSslMethodV3 = nil; - _SslMethodTLSV1: TSslMethodTLSV1 = nil; - _SslMethodV23: TSslMethodV23 = nil; - _SslCtxUsePrivateKey: TSslCtxUsePrivateKey = nil; - _SslCtxUsePrivateKeyASN1: TSslCtxUsePrivateKeyASN1 = nil; - _SslCtxUsePrivateKeyFile: TSslCtxUsePrivateKeyFile = nil; - _SslCtxUseCertificate: TSslCtxUseCertificate = nil; - _SslCtxUseCertificateASN1: TSslCtxUseCertificateASN1 = nil; - _SslCtxUseCertificateFile: TSslCtxUseCertificateFile = nil; - _SslCtxUseCertificateChainFile: TSslCtxUseCertificateChainFile = nil; - _SslCtxCheckPrivateKeyFile: TSslCtxCheckPrivateKeyFile = nil; - _SslCtxSetDefaultPasswdCb: TSslCtxSetDefaultPasswdCb = nil; - _SslCtxSetDefaultPasswdCbUserdata: TSslCtxSetDefaultPasswdCbUserdata = nil; - _SslCtxLoadVerifyLocations: TSslCtxLoadVerifyLocations = nil; - _SslCtxCtrl: TSslCtxCtrl = nil; - _SslNew: TSslNew = nil; - _SslFree: TSslFree = nil; - _SslAccept: TSslAccept = nil; - _SslConnect: TSslConnect = nil; - _SslShutdown: TSslShutdown = nil; - _SslRead: TSslRead = nil; - _SslPeek: TSslPeek = nil; - _SslWrite: TSslWrite = nil; - _SslPending: TSslPending = nil; - _SslGetVersion: TSslGetVersion = nil; - _SslGetPeerCertificate: TSslGetPeerCertificate = nil; - _SslCtxSetVerify: TSslCtxSetVerify = nil; - _SSLGetCurrentCipher: TSSLGetCurrentCipher = nil; - _SSLCipherGetName: TSSLCipherGetName = nil; - _SSLCipherGetBits: TSSLCipherGetBits = nil; - _SSLGetVerifyResult: TSSLGetVerifyResult = nil; - -// libeay.dll - _X509New: TX509New = nil; - _X509Free: TX509Free = nil; - _X509NameOneline: TX509NameOneline = nil; - _X509GetSubjectName: TX509GetSubjectName = nil; - _X509GetIssuerName: TX509GetIssuerName = nil; - _X509NameHash: TX509NameHash = nil; - _X509Digest: TX509Digest = nil; - _X509print: TX509print = nil; - _X509SetVersion: TX509SetVersion = nil; - _X509SetPubkey: TX509SetPubkey = nil; - _X509SetIssuerName: TX509SetIssuerName = nil; - _X509NameAddEntryByTxt: TX509NameAddEntryByTxt = nil; - _X509Sign: TX509Sign = nil; - _X509GmtimeAdj: TX509GmtimeAdj = nil; - _X509SetNotBefore: TX509SetNotBefore = nil; - _X509SetNotAfter: TX509SetNotAfter = nil; - _X509GetSerialNumber: TX509GetSerialNumber = nil; - _EvpPkeyNew: TEvpPkeyNew = nil; - _EvpPkeyFree: TEvpPkeyFree = nil; - _EvpPkeyAssign: TEvpPkeyAssign = nil; - _EvpGetDigestByName: TEvpGetDigestByName = nil; - _EVPcleanup: TEVPcleanup = nil; - _SSLeayversion: TSSLeayversion = nil; - _ErrErrorString: TErrErrorString = nil; - _ErrGetError: TErrGetError = nil; - _ErrClearError: TErrClearError = nil; - _ErrFreeStrings: TErrFreeStrings = nil; - _ErrRemoveState: TErrRemoveState = nil; - _OPENSSLaddallalgorithms: TOPENSSLaddallalgorithms = nil; - _CRYPTOcleanupAllExData: TCRYPTOcleanupAllExData = nil; - _RandScreen: TRandScreen = nil; - _BioNew: TBioNew = nil; - _BioFreeAll: TBioFreeAll = nil; - _BioSMem: TBioSMem = nil; - _BioCtrlPending: TBioCtrlPending = nil; - _BioRead: TBioRead = nil; - _BioWrite: TBioWrite = nil; - _d2iPKCS12bio: Td2iPKCS12bio = nil; - _PKCS12parse: TPKCS12parse = nil; - _PKCS12free: TPKCS12free = nil; - _RsaGenerateKey: TRsaGenerateKey = nil; - _Asn1UtctimeNew: TAsn1UtctimeNew = nil; - _Asn1UtctimeFree: TAsn1UtctimeFree = nil; - _Asn1IntegerSet: TAsn1IntegerSet = nil; - _i2dX509bio: Ti2dX509bio = nil; - _i2dPrivateKeyBio: Ti2dPrivateKeyBio = nil; - - // 3DES functions - _DESsetoddparity: TDESsetoddparity = nil; - _DESsetkeychecked: TDESsetkeychecked = nil; - _DESecbencrypt: TDESecbencrypt = nil; - //thread lock functions - _CRYPTOnumlocks: TCRYPTOnumlocks = nil; - _CRYPTOSetLockingCallback: TCRYPTOSetLockingCallback = nil; -{$ENDIF} - -var - SSLCS: TCriticalSection; - SSLloaded: boolean = false; -{$IFNDEF CIL} - Locks: TList; -{$ENDIF} - -{$IFNDEF CIL} -// libssl.dll -function SslGetError(s: PSSL; ret_code: Integer):Integer; -begin - if InitSSLInterface and Assigned(_SslGetError) then - Result := _SslGetError(s, ret_code) - else - Result := SSL_ERROR_SSL; -end; - -function SslLibraryInit:Integer; -begin - if InitSSLInterface and Assigned(_SslLibraryInit) then - Result := _SslLibraryInit - else - Result := 1; -end; - -procedure SslLoadErrorStrings; -begin - if InitSSLInterface and Assigned(_SslLoadErrorStrings) then - _SslLoadErrorStrings; -end; - -//function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer; -function SslCtxSetCipherList(arg0: PSSL_CTX; var str: AnsiString):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxSetCipherList) then - Result := _SslCtxSetCipherList(arg0, PAnsiChar(str)) - else - Result := 0; -end; - -function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; -begin - if InitSSLInterface and Assigned(_SslCtxNew) then - Result := _SslCtxNew(meth) - else - Result := nil; -end; - -procedure SslCtxFree(arg0: PSSL_CTX); -begin - if InitSSLInterface and Assigned(_SslCtxFree) then - _SslCtxFree(arg0); -end; - -function SslSetFd(s: PSSL; fd: Integer):Integer; -begin - if InitSSLInterface and Assigned(_SslSetFd) then - Result := _SslSetFd(s, fd) - else - Result := 0; -end; - -function SslMethodV2:PSSL_METHOD; -begin - if InitSSLInterface and Assigned(_SslMethodV2) then - Result := _SslMethodV2 - else - Result := nil; -end; - -function SslMethodV3:PSSL_METHOD; -begin - if InitSSLInterface and Assigned(_SslMethodV3) then - Result := _SslMethodV3 - else - Result := nil; -end; - -function SslMethodTLSV1:PSSL_METHOD; -begin - if InitSSLInterface and Assigned(_SslMethodTLSV1) then - Result := _SslMethodTLSV1 - else - Result := nil; -end; - -function SslMethodV23:PSSL_METHOD; -begin - if InitSSLInterface and Assigned(_SslMethodV23) then - Result := _SslMethodV23 - else - Result := nil; -end; - -function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxUsePrivateKey) then - Result := _SslCtxUsePrivateKey(ctx, pkey) - else - Result := 0; -end; - -function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: AnsiString; len: integer):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyASN1) then - Result := _SslCtxUsePrivateKeyASN1(pk, ctx, Sslptr(d), len) - else - Result := 0; -end; - -//function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; -function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyFile) then - Result := _SslCtxUsePrivateKeyFile(ctx, PAnsiChar(_file), _type) - else - Result := 0; -end; - -function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxUseCertificate) then - Result := _SslCtxUseCertificate(ctx, x) - else - Result := 0; -end; - -function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: AnsiString):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxUseCertificateASN1) then - Result := _SslCtxUseCertificateASN1(ctx, len, SslPtr(d)) - else - Result := 0; -end; - -function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxUseCertificateFile) then - Result := _SslCtxUseCertificateFile(ctx, PAnsiChar(_file), _type) - else - Result := 0; -end; - -//function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; -function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: AnsiString):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxUseCertificateChainFile) then - Result := _SslCtxUseCertificateChainFile(ctx, PAnsiChar(_file)) - else - Result := 0; -end; - -function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxCheckPrivateKeyFile) then - Result := _SslCtxCheckPrivateKeyFile(ctx) - else - Result := 0; -end; - -procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); -begin - if InitSSLInterface and Assigned(_SslCtxSetDefaultPasswdCb) then - _SslCtxSetDefaultPasswdCb(ctx, cb); -end; - -procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr); -begin - if InitSSLInterface and Assigned(_SslCtxSetDefaultPasswdCbUserdata) then - _SslCtxSetDefaultPasswdCbUserdata(ctx, u); -end; - -//function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; -function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: AnsiString; const CApath: AnsiString):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxLoadVerifyLocations) then - Result := _SslCtxLoadVerifyLocations(ctx, SslPtr(CAfile), SslPtr(CApath)) - else - Result := 0; -end; - -function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; -begin - if InitSSLInterface and Assigned(_SslCtxCtrl) then - Result := _SslCtxCtrl(ctx, cmd, larg, parg) - else - Result := 0; -end; - -function SslNew(ctx: PSSL_CTX):PSSL; -begin - if InitSSLInterface and Assigned(_SslNew) then - Result := _SslNew(ctx) - else - Result := nil; -end; - -procedure SslFree(ssl: PSSL); -begin - if InitSSLInterface and Assigned(_SslFree) then - _SslFree(ssl); -end; - -function SslAccept(ssl: PSSL):Integer; -begin - if InitSSLInterface and Assigned(_SslAccept) then - Result := _SslAccept(ssl) - else - Result := -1; -end; - -function SslConnect(ssl: PSSL):Integer; -begin - if InitSSLInterface and Assigned(_SslConnect) then - Result := _SslConnect(ssl) - else - Result := -1; -end; - -function SslShutdown(ssl: PSSL):Integer; -begin - if InitSSLInterface and Assigned(_SslShutdown) then - Result := _SslShutdown(ssl) - else - Result := -1; -end; - -//function SslRead(ssl: PSSL; buf: PChar; num: Integer):Integer; -function SslRead(ssl: PSSL; buf: SslPtr; num: Integer):Integer; -begin - if InitSSLInterface and Assigned(_SslRead) then - Result := _SslRead(ssl, PAnsiChar(buf), num) - else - Result := -1; -end; - -//function SslPeek(ssl: PSSL; buf: PChar; num: Integer):Integer; -function SslPeek(ssl: PSSL; buf: SslPtr; num: Integer):Integer; -begin - if InitSSLInterface and Assigned(_SslPeek) then - Result := _SslPeek(ssl, PAnsiChar(buf), num) - else - Result := -1; -end; - -//function SslWrite(ssl: PSSL; const buf: PChar; num: Integer):Integer; -function SslWrite(ssl: PSSL; buf: SslPtr; num: Integer):Integer; -begin - if InitSSLInterface and Assigned(_SslWrite) then - Result := _SslWrite(ssl, PAnsiChar(buf), num) - else - Result := -1; -end; - -function SslPending(ssl: PSSL):Integer; -begin - if InitSSLInterface and Assigned(_SslPending) then - Result := _SslPending(ssl) - else - Result := 0; -end; - -//function SslGetVersion(ssl: PSSL):PChar; -function SslGetVersion(ssl: PSSL):AnsiString; -begin - if InitSSLInterface and Assigned(_SslGetVersion) then - Result := _SslGetVersion(ssl) - else - Result := ''; -end; - -function SslGetPeerCertificate(ssl: PSSL):PX509; -begin - if InitSSLInterface and Assigned(_SslGetPeerCertificate) then - Result := _SslGetPeerCertificate(ssl) - else - Result := nil; -end; - -//procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); -procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); -begin - if InitSSLInterface and Assigned(_SslCtxSetVerify) then - _SslCtxSetVerify(ctx, mode, @arg2); -end; - -function SSLGetCurrentCipher(s: PSSL):SslPtr; -begin - if InitSSLInterface and Assigned(_SSLGetCurrentCipher) then -{$IFDEF CIL} -{$ELSE} - Result := _SSLGetCurrentCipher(s) -{$ENDIF} - else - Result := nil; -end; - -//function SSLCipherGetName(c: SslPtr):PChar; -function SSLCipherGetName(c: SslPtr):AnsiString; -begin - if InitSSLInterface and Assigned(_SSLCipherGetName) then - Result := _SSLCipherGetName(c) - else - Result := ''; -end; - -//function SSLCipherGetBits(c: SslPtr; alg_bits: PInteger):Integer; -function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; -begin - if InitSSLInterface and Assigned(_SSLCipherGetBits) then - Result := _SSLCipherGetBits(c, @alg_bits) - else - Result := 0; -end; - -function SSLGetVerifyResult(ssl: PSSL):Integer; -begin - if InitSSLInterface and Assigned(_SSLGetVerifyResult) then - Result := _SSLGetVerifyResult(ssl) - else - Result := X509_V_ERR_APPLICATION_VERIFICATION; -end; - -// libeay.dll -function X509New: PX509; -begin - if InitSSLInterface and Assigned(_X509New) then - Result := _X509New - else - Result := nil; -end; - -procedure X509Free(x: PX509); -begin - if InitSSLInterface and Assigned(_X509Free) then - _X509Free(x); -end; - -//function SslX509NameOneline(a: PX509_NAME; buf: PChar; size: Integer):PChar; -function X509NameOneline(a: PX509_NAME; var buf: AnsiString; size: Integer):AnsiString; -begin - if InitSSLInterface and Assigned(_X509NameOneline) then - Result := _X509NameOneline(a, PAnsiChar(buf),size) - else - Result := ''; -end; - -function X509GetSubjectName(a: PX509):PX509_NAME; -begin - if InitSSLInterface and Assigned(_X509GetSubjectName) then - Result := _X509GetSubjectName(a) - else - Result := nil; -end; - -function X509GetIssuerName(a: PX509):PX509_NAME; -begin - if InitSSLInterface and Assigned(_X509GetIssuerName) then - Result := _X509GetIssuerName(a) - else - Result := nil; -end; - -function X509NameHash(x: PX509_NAME):Cardinal; -begin - if InitSSLInterface and Assigned(_X509NameHash) then - Result := _X509NameHash(x) - else - Result := 0; -end; - -//function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; -function X509Digest(data: PX509; _type: PEVP_MD; md: AnsiString; var len: Integer):Integer; -begin - if InitSSLInterface and Assigned(_X509Digest) then - Result := _X509Digest(data, _type, PAnsiChar(md), @len) - else - Result := 0; -end; - -function EvpPkeyNew: EVP_PKEY; -begin - if InitSSLInterface and Assigned(_EvpPkeyNew) then - Result := _EvpPkeyNew - else - Result := nil; -end; - -procedure EvpPkeyFree(pk: EVP_PKEY); -begin - if InitSSLInterface and Assigned(_EvpPkeyFree) then - _EvpPkeyFree(pk); -end; - -function SSLeayversion(t: integer): Ansistring; -begin - if InitSSLInterface and Assigned(_SSLeayversion) then - Result := PAnsiChar(_SSLeayversion(t)) - else - Result := ''; -end; - -procedure ErrErrorString(e: integer; var buf: Ansistring; len: integer); -begin - if InitSSLInterface and Assigned(_ErrErrorString) then - _ErrErrorString(e, Pointer(buf), len); - buf := PAnsiChar(Buf); -end; - -function ErrGetError: integer; -begin - if InitSSLInterface and Assigned(_ErrGetError) then - Result := _ErrGetError - else - Result := SSL_ERROR_SSL; -end; - -procedure ErrClearError; -begin - if InitSSLInterface and Assigned(_ErrClearError) then - _ErrClearError; -end; - -procedure ErrFreeStrings; -begin - if InitSSLInterface and Assigned(_ErrFreeStrings) then - _ErrFreeStrings; -end; - -procedure ErrRemoveState(pid: integer); -begin - if InitSSLInterface and Assigned(_ErrRemoveState) then - _ErrRemoveState(pid); -end; - -procedure OPENSSLaddallalgorithms; -begin - if InitSSLInterface and Assigned(_OPENSSLaddallalgorithms) then - _OPENSSLaddallalgorithms; -end; - -procedure EVPcleanup; -begin - if InitSSLInterface and Assigned(_EVPcleanup) then - _EVPcleanup; -end; - -procedure CRYPTOcleanupAllExData; -begin - if InitSSLInterface and Assigned(_CRYPTOcleanupAllExData) then - _CRYPTOcleanupAllExData; -end; - -procedure RandScreen; -begin - if InitSSLInterface and Assigned(_RandScreen) then - _RandScreen; -end; - -function BioNew(b: PBIO_METHOD): PBIO; -begin - if InitSSLInterface and Assigned(_BioNew) then - Result := _BioNew(b) - else - Result := nil; -end; - -procedure BioFreeAll(b: PBIO); -begin - if InitSSLInterface and Assigned(_BioFreeAll) then - _BioFreeAll(b); -end; - -function BioSMem: PBIO_METHOD; -begin - if InitSSLInterface and Assigned(_BioSMem) then - Result := _BioSMem - else - Result := nil; -end; - -function BioCtrlPending(b: PBIO): integer; -begin - if InitSSLInterface and Assigned(_BioCtrlPending) then - Result := _BioCtrlPending(b) - else - Result := 0; -end; - -//function BioRead(b: PBIO; Buf: PChar; Len: integer): integer; -function BioRead(b: PBIO; var Buf: AnsiString; Len: integer): integer; -begin - if InitSSLInterface and Assigned(_BioRead) then - Result := _BioRead(b, PAnsiChar(Buf), Len) - else - Result := -2; -end; - -//function BioWrite(b: PBIO; Buf: PChar; Len: integer): integer; -function BioWrite(b: PBIO; Buf: AnsiString; Len: integer): integer; -begin - if InitSSLInterface and Assigned(_BioWrite) then - Result := _BioWrite(b, PAnsiChar(Buf), Len) - else - Result := -2; -end; - -function X509print(b: PBIO; a: PX509): integer; -begin - if InitSSLInterface and Assigned(_X509print) then - Result := _X509print(b, a) - else - Result := 0; -end; - -function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; -begin - if InitSSLInterface and Assigned(_d2iPKCS12bio) then - Result := _d2iPKCS12bio(b, Pkcs12) - else - Result := nil; -end; - -function PKCS12parse(p12: SslPtr; pass: Ansistring; var pkey, cert, ca: SslPtr): integer; -begin - if InitSSLInterface and Assigned(_PKCS12parse) then - Result := _PKCS12parse(p12, SslPtr(pass), pkey, cert, ca) - else - Result := 0; -end; - -procedure PKCS12free(p12: SslPtr); -begin - if InitSSLInterface and Assigned(_PKCS12free) then - _PKCS12free(p12); -end; - -function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; -begin - if InitSSLInterface and Assigned(_RsaGenerateKey) then - Result := _RsaGenerateKey(bits, e, callback, cb_arg) - else - Result := nil; -end; - -function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; -begin - if InitSSLInterface and Assigned(_EvpPkeyAssign) then - Result := _EvpPkeyAssign(pkey, _type, key) - else - Result := 0; -end; - -function X509SetVersion(x: PX509; version: integer): integer; -begin - if InitSSLInterface and Assigned(_X509SetVersion) then - Result := _X509SetVersion(x, version) - else - Result := 0; -end; - -function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; -begin - if InitSSLInterface and Assigned(_X509SetPubkey) then - Result := _X509SetPubkey(x, pkey) - else - Result := 0; -end; - -function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; -begin - if InitSSLInterface and Assigned(_X509SetIssuerName) then - Result := _X509SetIssuerName(x, name) - else - Result := 0; -end; - -function X509NameAddEntryByTxt(name: PX509_NAME; field: Ansistring; _type: integer; - bytes: Ansistring; len, loc, _set: integer): integer; -begin - if InitSSLInterface and Assigned(_X509NameAddEntryByTxt) then - Result := _X509NameAddEntryByTxt(name, PAnsiChar(field), _type, PAnsiChar(Bytes), len, loc, _set) - else - Result := 0; -end; - -function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; -begin - if InitSSLInterface and Assigned(_X509Sign) then - Result := _X509Sign(x, pkey, md) - else - Result := 0; -end; - -function Asn1UtctimeNew: PASN1_UTCTIME; -begin - if InitSSLInterface and Assigned(_Asn1UtctimeNew) then - Result := _Asn1UtctimeNew - else - Result := nil; -end; - -procedure Asn1UtctimeFree(a: PASN1_UTCTIME); -begin - if InitSSLInterface and Assigned(_Asn1UtctimeFree) then - _Asn1UtctimeFree(a); -end; - -function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; -begin - if InitSSLInterface and Assigned(_X509GmtimeAdj) then - Result := _X509GmtimeAdj(s, adj) - else - Result := nil; -end; - -function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; -begin - if InitSSLInterface and Assigned(_X509SetNotBefore) then - Result := _X509SetNotBefore(x, tm) - else - Result := 0; -end; - -function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; -begin - if InitSSLInterface and Assigned(_X509SetNotAfter) then - Result := _X509SetNotAfter(x, tm) - else - Result := 0; -end; - -function i2dX509bio(b: PBIO; x: PX509): integer; -begin - if InitSSLInterface and Assigned(_i2dX509bio) then - Result := _i2dX509bio(b, x) - else - Result := 0; -end; - -function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; -begin - if InitSSLInterface and Assigned(_i2dPrivateKeyBio) then - Result := _i2dPrivateKeyBio(b, pkey) - else - Result := 0; -end; - -function EvpGetDigestByName(Name: AnsiString): PEVP_MD; -begin - if InitSSLInterface and Assigned(_EvpGetDigestByName) then - Result := _EvpGetDigestByName(PAnsiChar(Name)) - else - Result := nil; -end; - -function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; -begin - if InitSSLInterface and Assigned(_Asn1IntegerSet) then - Result := _Asn1IntegerSet(a, v) - else - Result := 0; -end; - -function X509GetSerialNumber(x: PX509): PASN1_INTEGER; -begin - if InitSSLInterface and Assigned(_X509GetSerialNumber) then - Result := _X509GetSerialNumber(x) - else - Result := nil; -end; - -// 3DES functions -procedure DESsetoddparity(Key: des_cblock); -begin - if InitSSLInterface and Assigned(_DESsetoddparity) then - _DESsetoddparity(Key); -end; - -function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; -begin - if InitSSLInterface and Assigned(_DESsetkeychecked) then - Result := _DESsetkeychecked(key, schedule) - else - Result := -1; -end; - -procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); -begin - if InitSSLInterface and Assigned(_DESecbencrypt) then - _DESecbencrypt(Input, output, ks, enc); -end; - -procedure locking_callback(mode, ltype: integer; lfile: PChar; line: integer); cdecl; -begin - if (mode and 1) > 0 then - TCriticalSection(Locks[ltype]).Enter - else - TCriticalSection(Locks[ltype]).Leave; -end; - -procedure InitLocks; -var - n: integer; - max: integer; -begin - Locks := TList.Create; - max := _CRYPTOnumlocks; - for n := 1 to max do - Locks.Add(TCriticalSection.Create); - _CRYPTOsetlockingcallback(@locking_callback); -end; - -procedure FreeLocks; -var - n: integer; -begin - _CRYPTOsetlockingcallback(nil); - for n := 0 to Locks.Count - 1 do - TCriticalSection(Locks[n]).Free; - Locks.Free; -end; - -{$ENDIF} - -function LoadLib(const Value: String): HModule; -begin -{$IFDEF CIL} - Result := LoadLibrary(Value); -{$ELSE} - Result := LoadLibrary(PChar(Value)); -{$ENDIF} -end; - -function GetProcAddr(module: HModule; const ProcName: string): SslPtr; -begin -{$IFDEF CIL} - Result := GetProcAddress(module, ProcName); -{$ELSE} - Result := GetProcAddress(module, PChar(ProcName)); -{$ENDIF} -end; - -function InitSSLInterface: Boolean; -var - s: string; - x: integer; -begin - SSLCS.Enter; - try - if not IsSSLloaded then - begin -{$IFDEF CIL} - SSLLibHandle := 1; - SSLUtilHandle := 1; -{$ELSE} - SSLLibHandle := LoadLib(DLLSSLName); - SSLUtilHandle := LoadLib(DLLUtilName); - {$IFDEF MSWINDOWS} - if (SSLLibHandle = 0) then - SSLLibHandle := LoadLib(DLLSSLName2); - {$ENDIF} -{$ENDIF} - if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then - begin -{$IFNDEF CIL} - _SslGetError := GetProcAddr(SSLLibHandle, 'SSL_get_error'); - _SslLibraryInit := GetProcAddr(SSLLibHandle, 'SSL_library_init'); - _SslLoadErrorStrings := GetProcAddr(SSLLibHandle, 'SSL_load_error_strings'); - _SslCtxSetCipherList := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_cipher_list'); - _SslCtxNew := GetProcAddr(SSLLibHandle, 'SSL_CTX_new'); - _SslCtxFree := GetProcAddr(SSLLibHandle, 'SSL_CTX_free'); - _SslSetFd := GetProcAddr(SSLLibHandle, 'SSL_set_fd'); - _SslMethodV2 := GetProcAddr(SSLLibHandle, 'SSLv2_method'); - _SslMethodV3 := GetProcAddr(SSLLibHandle, 'SSLv3_method'); - _SslMethodTLSV1 := GetProcAddr(SSLLibHandle, 'TLSv1_method'); - _SslMethodV23 := GetProcAddr(SSLLibHandle, 'SSLv23_method'); - _SslCtxUsePrivateKey := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey'); - _SslCtxUsePrivateKeyASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey_ASN1'); - //use SSL_CTX_use_RSAPrivateKey_file instead SSL_CTX_use_PrivateKey_file, - //because SSL_CTX_use_PrivateKey_file not support DER format. :-O - _SslCtxUsePrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_RSAPrivateKey_file'); - _SslCtxUseCertificate := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate'); - _SslCtxUseCertificateASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_ASN1'); - _SslCtxUseCertificateFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_file'); - _SslCtxUseCertificateChainFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_chain_file'); - _SslCtxCheckPrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_check_private_key'); - _SslCtxSetDefaultPasswdCb := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb'); - _SslCtxSetDefaultPasswdCbUserdata := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb_userdata'); - _SslCtxLoadVerifyLocations := GetProcAddr(SSLLibHandle, 'SSL_CTX_load_verify_locations'); - _SslCtxCtrl := GetProcAddr(SSLLibHandle, 'SSL_CTX_ctrl'); - _SslNew := GetProcAddr(SSLLibHandle, 'SSL_new'); - _SslFree := GetProcAddr(SSLLibHandle, 'SSL_free'); - _SslAccept := GetProcAddr(SSLLibHandle, 'SSL_accept'); - _SslConnect := GetProcAddr(SSLLibHandle, 'SSL_connect'); - _SslShutdown := GetProcAddr(SSLLibHandle, 'SSL_shutdown'); - _SslRead := GetProcAddr(SSLLibHandle, 'SSL_read'); - _SslPeek := GetProcAddr(SSLLibHandle, 'SSL_peek'); - _SslWrite := GetProcAddr(SSLLibHandle, 'SSL_write'); - _SslPending := GetProcAddr(SSLLibHandle, 'SSL_pending'); - _SslGetPeerCertificate := GetProcAddr(SSLLibHandle, 'SSL_get_peer_certificate'); - _SslGetVersion := GetProcAddr(SSLLibHandle, 'SSL_get_version'); - _SslCtxSetVerify := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_verify'); - _SslGetCurrentCipher := GetProcAddr(SSLLibHandle, 'SSL_get_current_cipher'); - _SslCipherGetName := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_name'); - _SslCipherGetBits := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_bits'); - _SslGetVerifyResult := GetProcAddr(SSLLibHandle, 'SSL_get_verify_result'); - - _X509New := GetProcAddr(SSLUtilHandle, 'X509_new'); - _X509Free := GetProcAddr(SSLUtilHandle, 'X509_free'); - _X509NameOneline := GetProcAddr(SSLUtilHandle, 'X509_NAME_oneline'); - _X509GetSubjectName := GetProcAddr(SSLUtilHandle, 'X509_get_subject_name'); - _X509GetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_get_issuer_name'); - _X509NameHash := GetProcAddr(SSLUtilHandle, 'X509_NAME_hash'); - _X509Digest := GetProcAddr(SSLUtilHandle, 'X509_digest'); - _X509print := GetProcAddr(SSLUtilHandle, 'X509_print'); - _X509SetVersion := GetProcAddr(SSLUtilHandle, 'X509_set_version'); - _X509SetPubkey := GetProcAddr(SSLUtilHandle, 'X509_set_pubkey'); - _X509SetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_set_issuer_name'); - _X509NameAddEntryByTxt := GetProcAddr(SSLUtilHandle, 'X509_NAME_add_entry_by_txt'); - _X509Sign := GetProcAddr(SSLUtilHandle, 'X509_sign'); - _X509GmtimeAdj := GetProcAddr(SSLUtilHandle, 'X509_gmtime_adj'); - _X509SetNotBefore := GetProcAddr(SSLUtilHandle, 'X509_set_notBefore'); - _X509SetNotAfter := GetProcAddr(SSLUtilHandle, 'X509_set_notAfter'); - _X509GetSerialNumber := GetProcAddr(SSLUtilHandle, 'X509_get_serialNumber'); - _EvpPkeyNew := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_new'); - _EvpPkeyFree := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_free'); - _EvpPkeyAssign := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_assign'); - _EVPCleanup := GetProcAddr(SSLUtilHandle, 'EVP_cleanup'); - _EvpGetDigestByName := GetProcAddr(SSLUtilHandle, 'EVP_get_digestbyname'); - _SSLeayversion := GetProcAddr(SSLUtilHandle, 'SSLeay_version'); - _ErrErrorString := GetProcAddr(SSLUtilHandle, 'ERR_error_string_n'); - _ErrGetError := GetProcAddr(SSLUtilHandle, 'ERR_get_error'); - _ErrClearError := GetProcAddr(SSLUtilHandle, 'ERR_clear_error'); - _ErrFreeStrings := GetProcAddr(SSLUtilHandle, 'ERR_free_strings'); - _ErrRemoveState := GetProcAddr(SSLUtilHandle, 'ERR_remove_state'); - _OPENSSLaddallalgorithms := GetProcAddr(SSLUtilHandle, 'OPENSSL_add_all_algorithms_noconf'); - _CRYPTOcleanupAllExData := GetProcAddr(SSLUtilHandle, 'CRYPTO_cleanup_all_ex_data'); - _RandScreen := GetProcAddr(SSLUtilHandle, 'RAND_screen'); - _BioNew := GetProcAddr(SSLUtilHandle, 'BIO_new'); - _BioFreeAll := GetProcAddr(SSLUtilHandle, 'BIO_free_all'); - _BioSMem := GetProcAddr(SSLUtilHandle, 'BIO_s_mem'); - _BioCtrlPending := GetProcAddr(SSLUtilHandle, 'BIO_ctrl_pending'); - _BioRead := GetProcAddr(SSLUtilHandle, 'BIO_read'); - _BioWrite := GetProcAddr(SSLUtilHandle, 'BIO_write'); - _d2iPKCS12bio := GetProcAddr(SSLUtilHandle, 'd2i_PKCS12_bio'); - _PKCS12parse := GetProcAddr(SSLUtilHandle, 'PKCS12_parse'); - _PKCS12free := GetProcAddr(SSLUtilHandle, 'PKCS12_free'); - _RsaGenerateKey := GetProcAddr(SSLUtilHandle, 'RSA_generate_key'); - _Asn1UtctimeNew := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_new'); - _Asn1UtctimeFree := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_free'); - _Asn1IntegerSet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_set'); - _i2dX509bio := GetProcAddr(SSLUtilHandle, 'i2d_X509_bio'); - _i2dPrivateKeyBio := GetProcAddr(SSLUtilHandle, 'i2d_PrivateKey_bio'); - - // 3DES functions - _DESsetoddparity := GetProcAddr(SSLUtilHandle, 'DES_set_odd_parity'); - _DESsetkeychecked := GetProcAddr(SSLUtilHandle, 'DES_set_key_checked'); - _DESecbencrypt := GetProcAddr(SSLUtilHandle, 'DES_ecb_encrypt'); - // - _CRYPTOnumlocks := GetProcAddr(SSLUtilHandle, 'CRYPTO_num_locks'); - _CRYPTOsetlockingcallback := GetProcAddr(SSLUtilHandle, 'CRYPTO_set_locking_callback'); -{$ENDIF} -{$IFDEF CIL} - SslLibraryInit; - SslLoadErrorStrings; - OPENSSLaddallalgorithms; - RandScreen; -{$ELSE} - SetLength(s, 1024); - x := GetModuleFilename(SSLLibHandle,PChar(s),Length(s)); - SetLength(s, x); - SSLLibFile := s; - SetLength(s, 1024); - x := GetModuleFilename(SSLUtilHandle,PChar(s),Length(s)); - SetLength(s, x); - SSLUtilFile := s; - //init library - if assigned(_SslLibraryInit) then - _SslLibraryInit; - if assigned(_SslLoadErrorStrings) then - _SslLoadErrorStrings; - if assigned(_OPENSSLaddallalgorithms) then - _OPENSSLaddallalgorithms; - if assigned(_RandScreen) then - _RandScreen; - if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then - InitLocks; -{$ENDIF} - Result := True; - SSLloaded := True; - end - else - begin - //load failed! - if SSLLibHandle <> 0 then - begin -{$IFNDEF CIL} - FreeLibrary(SSLLibHandle); -{$ENDIF} - SSLLibHandle := 0; - end; - if SSLUtilHandle <> 0 then - begin -{$IFNDEF CIL} - FreeLibrary(SSLUtilHandle); -{$ENDIF} - SSLLibHandle := 0; - end; - Result := False; - end; - end - else - //loaded before... - Result := true; - finally - SSLCS.Leave; - end; -end; - -function DestroySSLInterface: Boolean; -begin - SSLCS.Enter; - try - if IsSSLLoaded then - begin - //deinit library -{$IFNDEF CIL} - if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then - FreeLocks; -{$ENDIF} - EVPCleanup; - CRYPTOcleanupAllExData; - ErrRemoveState(0); - end; - SSLloaded := false; - if SSLLibHandle <> 0 then - begin -{$IFNDEF CIL} - FreeLibrary(SSLLibHandle); -{$ENDIF} - SSLLibHandle := 0; - end; - if SSLUtilHandle <> 0 then - begin -{$IFNDEF CIL} - FreeLibrary(SSLUtilHandle); -{$ENDIF} - SSLLibHandle := 0; - end; - -{$IFNDEF CIL} - _SslGetError := nil; - _SslLibraryInit := nil; - _SslLoadErrorStrings := nil; - _SslCtxSetCipherList := nil; - _SslCtxNew := nil; - _SslCtxFree := nil; - _SslSetFd := nil; - _SslMethodV2 := nil; - _SslMethodV3 := nil; - _SslMethodTLSV1 := nil; - _SslMethodV23 := nil; - _SslCtxUsePrivateKey := nil; - _SslCtxUsePrivateKeyASN1 := nil; - _SslCtxUsePrivateKeyFile := nil; - _SslCtxUseCertificate := nil; - _SslCtxUseCertificateASN1 := nil; - _SslCtxUseCertificateFile := nil; - _SslCtxUseCertificateChainFile := nil; - _SslCtxCheckPrivateKeyFile := nil; - _SslCtxSetDefaultPasswdCb := nil; - _SslCtxSetDefaultPasswdCbUserdata := nil; - _SslCtxLoadVerifyLocations := nil; - _SslCtxCtrl := nil; - _SslNew := nil; - _SslFree := nil; - _SslAccept := nil; - _SslConnect := nil; - _SslShutdown := nil; - _SslRead := nil; - _SslPeek := nil; - _SslWrite := nil; - _SslPending := nil; - _SslGetPeerCertificate := nil; - _SslGetVersion := nil; - _SslCtxSetVerify := nil; - _SslGetCurrentCipher := nil; - _SslCipherGetName := nil; - _SslCipherGetBits := nil; - _SslGetVerifyResult := nil; - - _X509New := nil; - _X509Free := nil; - _X509NameOneline := nil; - _X509GetSubjectName := nil; - _X509GetIssuerName := nil; - _X509NameHash := nil; - _X509Digest := nil; - _X509print := nil; - _X509SetVersion := nil; - _X509SetPubkey := nil; - _X509SetIssuerName := nil; - _X509NameAddEntryByTxt := nil; - _X509Sign := nil; - _X509GmtimeAdj := nil; - _X509SetNotBefore := nil; - _X509SetNotAfter := nil; - _X509GetSerialNumber := nil; - _EvpPkeyNew := nil; - _EvpPkeyFree := nil; - _EvpPkeyAssign := nil; - _EVPCleanup := nil; - _EvpGetDigestByName := nil; - _SSLeayversion := nil; - _ErrErrorString := nil; - _ErrGetError := nil; - _ErrClearError := nil; - _ErrFreeStrings := nil; - _ErrRemoveState := nil; - _OPENSSLaddallalgorithms := nil; - _CRYPTOcleanupAllExData := nil; - _RandScreen := nil; - _BioNew := nil; - _BioFreeAll := nil; - _BioSMem := nil; - _BioCtrlPending := nil; - _BioRead := nil; - _BioWrite := nil; - _d2iPKCS12bio := nil; - _PKCS12parse := nil; - _PKCS12free := nil; - _RsaGenerateKey := nil; - _Asn1UtctimeNew := nil; - _Asn1UtctimeFree := nil; - _Asn1IntegerSet := nil; - _i2dX509bio := nil; - _i2dPrivateKeyBio := nil; - - // 3DES functions - _DESsetoddparity := nil; - _DESsetkeychecked := nil; - _DESecbencrypt := nil; - // - _CRYPTOnumlocks := nil; - _CRYPTOsetlockingcallback := nil; -{$ENDIF} - finally - SSLCS.Leave; - end; - Result := True; -end; - -function IsSSLloaded: Boolean; -begin - Result := SSLLoaded; -end; - -initialization -begin - SSLCS:= TCriticalSection.Create; -end; - -finalization -begin -{$IFNDEF CIL} - DestroySSLInterface; -{$ENDIF} - SSLCS.Free; -end; - -end. diff --git a/addons/synapse/ssl_sbb.pas b/addons/synapse/ssl_sbb.pas deleted file mode 100644 index c9380a4..0000000 --- a/addons/synapse/ssl_sbb.pas +++ /dev/null @@ -1,697 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.000.003 | -|==============================================================================| -| Content: SSL support for SecureBlackBox | -|==============================================================================| -| Copyright (c)1999-2005, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2005. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Allen Drennan (adrennan@wiredred.com) | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(SSL plugin for Eldos SecureBlackBox) - -For handling keys and certificates you can use this properties: -@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA), -@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate), -@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey), -@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate), -@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats -of keys and certificates refer to SecureBlackBox documentation. -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -unit ssl_sbb; - -interface - -uses - SysUtils, Classes, Windows, blcksock, synsock, synautil, synacode, - SBClient, SBServer, SBX509, SBWinCertStorage, SBCustomCertStorage, - SBUtils, SBConstants, SBSessionPool; - -const - DEFAULT_RECV_BUFFER=32768; - -type - {:@abstract(class implementing SecureBlackbox SSL plugin.) - Instance of this class will be created for each @link(TTCPBlockSocket). - You not need to create instance of this class, all is done by Synapse itself!} - TSSLSBB=class(TCustomSSL) - protected - FServer: Boolean; - FElSecureClient:TElSecureClient; - FElSecureServer:TElSecureServer; - FElCertStorage:TElMemoryCertStorage; - FElX509Certificate:TElX509Certificate; - FElX509CACertificate:TElX509Certificate; - FCipherSuites:TBits; - private - FRecvBuffer:String; - FRecvBuffers:String; - FRecvBuffersLock:TRTLCriticalSection; - FRecvDecodedBuffers:String; - function GetCipherSuite:Integer; - procedure Reset; - function Prepare(Server:Boolean):Boolean; - procedure OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean); - procedure OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt); - procedure OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;var Written:LongInt); - procedure OnData(Sender:TObject;Buffer:Pointer;Size:LongInt); - public - constructor Create(const Value: TTCPBlockSocket); override; - destructor Destroy; override; - {:See @inherited} - function LibVersion: String; override; - {:See @inherited} - function LibName: String; override; - {:See @inherited and @link(ssl_sbb) for more details.} - function Connect: boolean; override; - {:See @inherited and @link(ssl_sbb) for more details.} - function Accept: boolean; override; - {:See @inherited} - function Shutdown: boolean; override; - {:See @inherited} - function BiShutdown: boolean; override; - {:See @inherited} - function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function WaitingData: Integer; override; - {:See @inherited} - function GetSSLVersion: string; override; - {:See @inherited} - function GetPeerSubject: string; override; - {:See @inherited} - function GetPeerIssuer: string; override; - {:See @inherited} - function GetPeerName: string; override; - {:See @inherited} - function GetPeerFingerprint: string; override; - {:See @inherited} - function GetCertInfo: string; override; - published - property ElSecureClient:TElSecureClient read FElSecureClient write FElSecureClient; - property ElSecureServer:TElSecureServer read FElSecureServer write FElSecureServer; - property CipherSuites:TBits read FCipherSuites write FCipherSuites; - property CipherSuite:Integer read GetCipherSuite; - end; - -implementation - -var - FAcceptThread:THandle=0; - -// on error -procedure TSSLSBB.OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean); - -begin - FLastErrorDesc:=''; - FLastError:=ErrorCode; -end; - -// on send -procedure TSSLSBB.OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt); - -var - lResult:Integer; - -begin - if FSocket.Socket=INVALID_SOCKET then - Exit; - lResult:=Send(FSocket.Socket,Buffer,Size,0); - if lResult=SOCKET_ERROR then - begin - FLastErrorDesc:=''; - FLastError:=WSAGetLastError; - end; -end; - -// on receive -procedure TSSLSBB.OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;var Written:LongInt); - -begin - if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock); - try - if Length(FRecvBuffers)<=MaxSize then - begin - Written:=Length(FRecvBuffers); - Move(FRecvBuffers[1],Buffer^,Written); - FRecvBuffers:=''; - end - else - begin - Written:=MaxSize; - Move(FRecvBuffers[1],Buffer^,Written); - Delete(FRecvBuffers,1,Written); - end; - finally - if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); - end; -end; - -// on data -procedure TSSLSBB.OnData(Sender:TObject;Buffer:Pointer;Size:LongInt); - -var - lString:String; - -begin - SetLength(lString,Size); - Move(Buffer^,lString[1],Size); - FRecvDecodedBuffers:=FRecvDecodedBuffers+lString; -end; - -{ inherited } - -constructor TSSLSBB.Create(const Value: TTCPBlockSocket); - -var - loop1:Integer; - -begin - inherited Create(Value); - FServer:=FALSE; - FElSecureClient:=NIL; - FElSecureServer:=NIL; - FElCertStorage:=NIL; - FElX509Certificate:=NIL; - FElX509CACertificate:=NIL; - SetLength(FRecvBuffer,DEFAULT_RECV_BUFFER); - FRecvBuffers:=''; - InitializeCriticalSection(FRecvBuffersLock); - FRecvDecodedBuffers:=''; - FCipherSuites:=TBits.Create; - if FCipherSuites<>NIL then - begin - FCipherSuites.Size:=SB_SUITE_LAST+1; - for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do - FCipherSuites[loop1]:=TRUE; - end; -end; - -destructor TSSLSBB.Destroy; - -begin - Reset; - inherited Destroy; - if FCipherSuites<>NIL then - FreeAndNIL(FCipherSuites); - DeleteCriticalSection(FRecvBuffersLock); -end; - -function TSSLSBB.LibVersion: String; - -begin - Result:='SecureBlackBox'; -end; - -function TSSLSBB.LibName: String; - -begin - Result:='ssl_sbb'; -end; - -function FileToString(lFile:String):String; - -var - lStream:TMemoryStream; - -begin - Result:=''; - lStream:=TMemoryStream.Create; - if lStream<>NIL then - begin - lStream.LoadFromFile(lFile); - if lStream.Size>0 then - begin - lStream.Position:=0; - SetLength(Result,lStream.Size); - Move(lStream.Memory^,Result[1],lStream.Size); - end; - lStream.Free; - end; -end; - -function TSSLSBB.GetCipherSuite:Integer; - -begin - if FServer then - Result:=FElSecureServer.CipherSuite - else - Result:=FElSecureClient.CipherSuite; -end; - -procedure TSSLSBB.Reset; - -begin - if FElSecureServer<>NIL then - FreeAndNIL(FElSecureServer); - if FElSecureClient<>NIL then - FreeAndNIL(FElSecureClient); - if FElX509Certificate<>NIL then - FreeAndNIL(FElX509Certificate); - if FElX509CACertificate<>NIL then - FreeAndNIL(FElX509CACertificate); - if FElCertStorage<>NIL then - FreeAndNIL(FElCertStorage); - FSSLEnabled:=FALSE; -end; - -function TSSLSBB.Prepare(Server:Boolean): Boolean; - -var - loop1:Integer; - lStream:TMemoryStream; - lCertificate,lPrivateKey,lCertCA:String; - -begin - Result:=FALSE; - FServer:=Server; - - // reset, if necessary - Reset; - - // init, certificate - if FCertificateFile<>'' then - lCertificate:=FileToString(FCertificateFile) - else - lCertificate:=FCertificate; - if FPrivateKeyFile<>'' then - lPrivateKey:=FileToString(FPrivateKeyFile) - else - lPrivateKey:=FPrivateKey; - if FCertCAFile<>'' then - lCertCA:=FileToString(FCertCAFile) - else - lCertCA:=FCertCA; - if (lCertificate<>'') and (lPrivateKey<>'') then - begin - FElCertStorage:=TElMemoryCertStorage.Create(NIL); - if FElCertStorage<>NIL then - FElCertStorage.Clear; - - // apply ca certificate - if lCertCA<>'' then - begin - FElX509CACertificate:=TElX509Certificate.Create(NIL); - if FElX509CACertificate<>NIL then - begin - with FElX509CACertificate do - begin - lStream:=TMemoryStream.Create; - try - WriteStrToStream(lStream,lCertCA); - lStream.Seek(0,soFromBeginning); - LoadFromStream(lStream); - finally - lStream.Free; - end; - end; - if FElCertStorage<>NIL then - FElCertStorage.Add(FElX509CACertificate); - end; - end; - - // apply certificate - FElX509Certificate:=TElX509Certificate.Create(NIL); - if FElX509Certificate<>NIL then - begin - with FElX509Certificate do - begin - lStream:=TMemoryStream.Create; - try - WriteStrToStream(lStream,lCertificate); - lStream.Seek(0,soFromBeginning); - LoadFromStream(lStream); - finally - lStream.Free; - end; - lStream:=TMemoryStream.Create; - try - WriteStrToStream(lStream,lPrivateKey); - lStream.Seek(0,soFromBeginning); - LoadKeyFromStream(lStream); - finally - lStream.Free; - end; - if FElCertStorage<>NIL then - FElCertStorage.Add(FElX509Certificate); - end; - end; - end; - - // init, as server - if FServer then - begin - FElSecureServer:=TElSecureServer.Create(NIL); - if FElSecureServer<>NIL then - begin - // init, ciphers - for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do - FElSecureServer.CipherSuites[loop1]:=FCipherSuites[loop1]; - FElSecureServer.Versions:=[sbSSL2,sbSSL3,sbTLS1]; - FElSecureServer.ClientAuthentication:=FALSE; - FElSecureServer.OnError:=OnError; - FElSecureServer.OnSend:=OnSend; - FElSecureServer.OnReceive:=OnReceive; - FElSecureServer.OnData:=OnData; - FElSecureServer.CertStorage:=FElCertStorage; - Result:=TRUE; - end; - end - else - // init, as client - begin - FElSecureClient:=TElSecureClient.Create(NIL); - if FElSecureClient<>NIL then - begin - // init, ciphers - for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do - FElSecureClient.CipherSuites[loop1]:=FCipherSuites[loop1]; - FElSecureClient.Versions:=[sbSSL3,sbTLS1]; - FElSecureClient.OnError:=OnError; - FElSecureClient.OnSend:=OnSend; - FElSecureClient.OnReceive:=OnReceive; - FElSecureClient.OnData:=OnData; - FElSecureClient.CertStorage:=FElCertStorage; - Result:=TRUE; - end; - end; -end; - -function TSSLSBB.Connect:Boolean; - -var - lResult:Integer; - -begin - Result:=FALSE; - if FSocket.Socket=INVALID_SOCKET then - Exit; - if Prepare(FALSE) then - begin - FElSecureClient.Open; - - // reset - FRecvBuffers:=''; - FRecvDecodedBuffers:=''; - - // wait for open or error - while (not FElSecureClient.Active) and - (FLastError=0) do - begin - // data available? - if FRecvBuffers<>'' then - FElSecureClient.DataAvailable - else - begin - // socket recv - lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); - if lResult=SOCKET_ERROR then - begin - FLastErrorDesc:=''; - FLastError:=WSAGetLastError; - end - else - begin - if lResult>0 then - FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult) - else - Break; - end; - end; - end; - if FLastError<>0 then - Exit; - FSSLEnabled:=FElSecureClient.Active; - Result:=FSSLEnabled; - end; -end; - -function TSSLSBB.Accept:Boolean; - -var - lResult:Integer; - -begin - Result:=FALSE; - if FSocket.Socket=INVALID_SOCKET then - Exit; - if Prepare(TRUE) then - begin - FAcceptThread:=GetCurrentThreadId; - FElSecureServer.Open; - - // reset - FRecvBuffers:=''; - FRecvDecodedBuffers:=''; - - // wait for open or error - while (not FElSecureServer.Active) and - (FLastError=0) do - begin - // data available? - if FRecvBuffers<>'' then - FElSecureServer.DataAvailable - else - begin - // socket recv - lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); - if lResult=SOCKET_ERROR then - begin - FLastErrorDesc:=''; - FLastError:=WSAGetLastError; - end - else - begin - if lResult>0 then - FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult) - else - Break; - end; - end; - end; - if FLastError<>0 then - Exit; - FSSLEnabled:=FElSecureServer.Active; - Result:=FSSLEnabled; - end; -end; - -function TSSLSBB.Shutdown:Boolean; - -begin - Result:=BiShutdown; -end; - -function TSSLSBB.BiShutdown: boolean; - -begin - Reset; - Result:=TRUE; -end; - -function TSSLSBB.SendBuffer(Buffer: TMemory; Len: Integer): Integer; - -begin - if FServer then - FElSecureServer.SendData(Buffer,Len) - else - FElSecureClient.SendData(Buffer,Len); - Result:=Len; -end; - -function TSSLSBB.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; - -begin - Result:=0; - try - // recv waiting, if necessary - if FRecvDecodedBuffers='' then - WaitingData; - - // received - if Length(FRecvDecodedBuffers)FAcceptThread then EnterCriticalSection(FRecvBuffersLock); - try - lRecvBuffers:=FRecvBuffers<>''; - finally - if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); - end; - if lRecvBuffers then - begin - if FServer then - FElSecureServer.DataAvailable - else - FElSecureClient.DataAvailable; - end - else - begin - // socket recv - lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); - if lResult=SOCKET_ERROR then - begin - FLastErrorDesc:=''; - FLastError:=WSAGetLastError; - end - else - begin - if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock); - try - FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult); - finally - if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); - end; - - // data available? - if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock); - try - lRecvBuffers:=FRecvBuffers<>''; - finally - if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); - end; - if lRecvBuffers then - begin - if FServer then - FElSecureServer.DataAvailable - else - FElSecureClient.DataAvailable; - end; - end; - end; - - // decoded buffers result - Result:=Length(FRecvDecodedBuffers); -end; - -function TSSLSBB.GetSSLVersion: string; - -begin - Result:='SSLv3 or TLSv1'; -end; - -function TSSLSBB.GetPeerSubject: string; - -begin - Result := ''; -// if FServer then - // must return subject of the client certificate -// else - // must return subject of the server certificate -end; - -function TSSLSBB.GetPeerName: string; - -begin - Result := ''; -// if FServer then - // must return commonname of the client certificate -// else - // must return commonname of the server certificate -end; - -function TSSLSBB.GetPeerIssuer: string; - -begin - Result := ''; -// if FServer then - // must return issuer of the client certificate -// else - // must return issuer of the server certificate -end; - -function TSSLSBB.GetPeerFingerprint: string; - -begin - Result := ''; -// if FServer then - // must return a unique hash string of the client certificate -// else - // must return a unique hash string of the server certificate -end; - -function TSSLSBB.GetCertInfo: string; - -begin - Result := ''; -// if FServer then - // must return a text representation of the ASN of the client certificate -// else - // must return a text representation of the ASN of the server certificate -end; - -{==============================================================================} - -initialization - SSLImplementation := TSSLSBB; - -finalization - -end. diff --git a/addons/synapse/ssl_streamsec.pas b/addons/synapse/ssl_streamsec.pas deleted file mode 100644 index 8c36ac8..0000000 --- a/addons/synapse/ssl_streamsec.pas +++ /dev/null @@ -1,539 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.000.006 | -|==============================================================================| -| Content: SSL support by StreamSecII | -|==============================================================================| -| Copyright (c)1999-2005, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2005. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Henrick Hellstrцm | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(SSL plugin for StreamSecII or OpenStreamSecII) - -StreamSecII is native pascal library, you not need any external libraries! - -You can tune lot of StreamSecII properties by using your GlobalServer. If you not -using your GlobalServer, then this plugin create own TSimpleTLSInternalServer -instance for each TCP connection. Formore information about GlobalServer usage -refer StreamSecII documentation. - -If you are not using key and certificate by GlobalServer, then you can use -properties of this plugin instead, but this have limited features and -@link(TCustomSSL.KeyPassword) not working properly yet! - -For handling keys and certificates you can use this properties: -@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA), -@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate), -@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey), -@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate), -@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats -of keys and certificates refer to StreamSecII documentation. -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -unit ssl_streamsec; - -interface - -uses - SysUtils, Classes, - blcksock, synsock, synautil, synacode, - TlsInternalServer, TlsSynaSock, TlsConst, StreamSecII, Asn1, X509Base, - SecUtils; - -type - {:@exclude} - TMyTLSSynSockSlave = class(TTLSSynSockSlave) - protected - procedure SetMyTLSServer(const Value: TCustomTLSInternalServer); - function GetMyTLSServer: TCustomTLSInternalServer; - published - property MyTLSServer: TCustomTLSInternalServer read GetMyTLSServer write SetMyTLSServer; - end; - - {:@abstract(class implementing StreamSecII SSL plugin.) - Instance of this class will be created for each @link(TTCPBlockSocket). - You not need to create instance of this class, all is done by Synapse itself!} - TSSLStreamSec = class(TCustomSSL) - protected - FSlave: TMyTLSSynSockSlave; - FIsServer: Boolean; - FTLSServer: TCustomTLSInternalServer; - FServerCreated: Boolean; - function SSLCheck: Boolean; - function Init(server:Boolean): Boolean; - function DeInit: Boolean; - function Prepare(server:Boolean): Boolean; - procedure NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean); - function X500StrToStr(const Prefix: string; const Value: TX500String): string; - function X501NameToStr(const Value: TX501Name): string; - function GetCert: PASN1Struct; - public - constructor Create(const Value: TTCPBlockSocket); override; - destructor Destroy; override; - {:See @inherited} - function LibVersion: String; override; - {:See @inherited} - function LibName: String; override; - {:See @inherited and @link(ssl_streamsec) for more details.} - function Connect: boolean; override; - {:See @inherited and @link(ssl_streamsec) for more details.} - function Accept: boolean; override; - {:See @inherited} - function Shutdown: boolean; override; - {:See @inherited} - function BiShutdown: boolean; override; - {:See @inherited} - function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function WaitingData: Integer; override; - {:See @inherited} - function GetSSLVersion: string; override; - {:See @inherited} - function GetPeerSubject: string; override; - {:See @inherited} - function GetPeerIssuer: string; override; - {:See @inherited} - function GetPeerName: string; override; - {:See @inherited} - function GetPeerFingerprint: string; override; - {:See @inherited} - function GetCertInfo: string; override; - published - {:TLS server for tuning of StreamSecII.} - property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer; - end; - -implementation - -{==============================================================================} -procedure TMyTLSSynSockSlave.SetMyTLSServer(const Value: TCustomTLSInternalServer); -begin - TLSServer := Value; -end; - -function TMyTLSSynSockSlave.GetMyTLSServer: TCustomTLSInternalServer; -begin - Result := TLSServer; -end; - -{==============================================================================} - -constructor TSSLStreamSec.Create(const Value: TTCPBlockSocket); -begin - inherited Create(Value); - FSlave := nil; - FIsServer := False; - FTLSServer := nil; -end; - -destructor TSSLStreamSec.Destroy; -begin - DeInit; - inherited Destroy; -end; - -function TSSLStreamSec.LibVersion: String; -begin - Result := 'StreamSecII'; -end; - -function TSSLStreamSec.LibName: String; -begin - Result := 'ssl_streamsec'; -end; - -function TSSLStreamSec.SSLCheck: Boolean; -begin - Result := true; - FLastErrorDesc := ''; - if not Assigned(FSlave) then - Exit; - FLastError := FSlave.ErrorCode; - if FLastError <> 0 then - begin - FLastErrorDesc := TlsConst.AlertMsg(FLastError); - end; -end; - -procedure TSSLStreamSec.NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean); -begin - ExplicitTrust := true; -end; - -function TSSLStreamSec.Init(server:Boolean): Boolean; -var - st: TMemoryStream; - pass: ISecretKey; - ws: WideString; -begin - Result := False; - ws := FKeyPassword; - pass := TSecretKey.CreateBmpStr(PWideChar(ws), length(ws)); - try - FIsServer := Server; - FSlave := TMyTLSSynSockSlave.CreateSocket(FSocket.Socket); - if Assigned(FTLSServer) then - FSlave.MyTLSServer := FTLSServer - else - if Assigned(TLSInternalServer.GlobalServer) then - FSlave.MyTLSServer := TLSInternalServer.GlobalServer - else begin - FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil); - FServerCreated := True; - end; - if server then - FSlave.MyTLSServer.ClientOrServer := cosServerSide - else - FSlave.MyTLSServer.ClientOrServer := cosClientSide; - if not FVerifyCert then - begin - FSlave.MyTLSServer.OnCertNotTrusted := NotTrustEvent; - end; - FSlave.MyTLSServer.Options.VerifyServerName := []; - FSlave.MyTLSServer.Options.Export40Bit := prAllowed; - FSlave.MyTLSServer.Options.Export56Bit := prAllowed; - FSlave.MyTLSServer.Options.RequestClientCertificate := False; - FSlave.MyTLSServer.Options.RequireClientCertificate := False; - if server and FVerifyCert then - begin - FSlave.MyTLSServer.Options.RequestClientCertificate := True; - FSlave.MyTLSServer.Options.RequireClientCertificate := True; - end; - if FCertCAFile <> '' then - FSlave.MyTLSServer.LoadRootCertsFromFile(CertCAFile); - if FCertCA <> '' then - begin - st := TMemoryStream.Create; - try - WriteStrToStream(st, FCertCA); - st.Seek(0, soFromBeginning); - FSlave.MyTLSServer.LoadRootCertsFromStream(st); - finally - st.free; - end; - end; - if FTrustCertificateFile <> '' then - FSlave.MyTLSServer.LoadTrustedCertsFromFile(FTrustCertificateFile); - if FTrustCertificate <> '' then - begin - st := TMemoryStream.Create; - try - WriteStrToStream(st, FTrustCertificate); - st.Seek(0, soFromBeginning); - FSlave.MyTLSServer.LoadTrustedCertsFromStream(st); - finally - st.free; - end; - end; - if FPrivateKeyFile <> '' then - FSlave.MyTLSServer.LoadPrivateKeyRingFromFile(FPrivateKeyFile, pass); -// FSlave.MyTLSServer.PrivateKeyRing.LoadPrivateKeyFromFile(FPrivateKeyFile, pass); - if FPrivateKey <> '' then - begin - st := TMemoryStream.Create; - try - WriteStrToStream(st, FPrivateKey); - st.Seek(0, soFromBeginning); - FSlave.MyTLSServer.LoadPrivateKeyRingFromStream(st, pass); - finally - st.free; - end; - end; - if FCertificateFile <> '' then - FSlave.MyTLSServer.LoadMyCertsFromFile(FCertificateFile); - if FCertificate <> '' then - begin - st := TMemoryStream.Create; - try - WriteStrToStream(st, FCertificate); - st.Seek(0, soFromBeginning); - FSlave.MyTLSServer.LoadMyCertsFromStream(st); - finally - st.free; - end; - end; - if FPFXfile <> '' then - FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass); - if server and FServerCreated then - begin - FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer; - FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed; - FSlave.MyTLSServer.Options.EphemeralECDHKeySize := ecs256; - FSlave.MyTLSServer.Options.SignatureRSA := prPrefer; - FSlave.MyTLSServer.Options.KeyAgreementRSA := prAllowed; - FSlave.MyTLSServer.Options.KeyAgreementECDHE := prAllowed; - FSlave.MyTLSServer.Options.KeyAgreementDHE := prPrefer; - FSlave.MyTLSServer.TLSSetupServer; - end; - Result := true; - finally - pass := nil; - end; -end; - -function TSSLStreamSec.DeInit: Boolean; -var - obj: TObject; -begin - Result := True; - if assigned(FSlave) then - begin - FSlave.Close; - if FServerCreated then - obj := FSlave.TLSServer - else - obj := nil; - FSlave.Free; - obj.Free; - FSlave := nil; - end; - FSSLEnabled := false; -end; - -function TSSLStreamSec.Prepare(server:Boolean): Boolean; -begin - Result := false; - DeInit; - if Init(server) then - Result := true - else - DeInit; -end; - -function TSSLStreamSec.Connect: boolean; -begin - Result := False; - if FSocket.Socket = INVALID_SOCKET then - Exit; - if Prepare(false) then - begin - FSlave.Open; - SSLCheck; - if FLastError <> 0 then - Exit; - FSSLEnabled := True; - Result := True; - end; -end; - -function TSSLStreamSec.Accept: boolean; -begin - Result := False; - if FSocket.Socket = INVALID_SOCKET then - Exit; - if Prepare(true) then - begin - FSlave.DoConnect; - SSLCheck; - if FLastError <> 0 then - Exit; - FSSLEnabled := True; - Result := True; - end; -end; - -function TSSLStreamSec.Shutdown: boolean; -begin - Result := BiShutdown; -end; - -function TSSLStreamSec.BiShutdown: boolean; -begin - DeInit; - Result := True; -end; - -function TSSLStreamSec.SendBuffer(Buffer: TMemory; Len: Integer): Integer; -var - l: integer; -begin - l := len; - FSlave.SendBuf(Buffer^, l, true); - Result := l; - SSLCheck; -end; - -function TSSLStreamSec.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; -var - l: integer; -begin - l := Len; - Result := FSlave.ReceiveBuf(Buffer^, l); - SSLCheck; -end; - -function TSSLStreamSec.WaitingData: Integer; -begin - Result := 0; - while FSlave.Connected do begin - Result := FSlave.ReceiveLength; - if Result > 0 then - Break; - Sleep(1); - end; -end; - -function TSSLStreamSec.GetSSLVersion: string; -begin - Result := 'SSLv3 or TLSv1'; -end; - -function TSSLStreamSec.GetCert: PASN1Struct; -begin - if FIsServer then - Result := FSlave.GetClientCert - else - Result := FSlave.GetServerCert; -end; - -function TSSLStreamSec.GetPeerSubject: string; -var - XName: TX501Name; - Cert: PASN1Struct; -begin - Result := ''; - Cert := GetCert; - if Assigned(cert) then - begin - ExtractSubject(Cert^,XName, false); - Result := X501NameToStr(XName); - end; -end; - -function TSSLStreamSec.GetPeerName: string; -var - XName: TX501Name; - Cert: PASN1Struct; -begin - Result := ''; - Cert := GetCert; - if Assigned(cert) then - begin - ExtractSubject(Cert^,XName, false); - Result := XName.commonName.Str; - end; -end; - -function TSSLStreamSec.GetPeerIssuer: string; -var - XName: TX501Name; - Cert: PASN1Struct; -begin - Result := ''; - Cert := GetCert; - if Assigned(cert) then - begin - ExtractIssuer(Cert^, XName, false); - Result := X501NameToStr(XName); - end; -end; - -function TSSLStreamSec.GetPeerFingerprint: string; -var - Cert: PASN1Struct; -begin - Result := ''; - Cert := GetCert; - if Assigned(cert) then - Result := MD5(Cert.ContentAsOctetString); -end; - -function TSSLStreamSec.GetCertInfo: string; -var - Cert: PASN1Struct; - l: Tstringlist; -begin - Result := ''; - Cert := GetCert; - if Assigned(cert) then - begin - l := TStringList.Create; - try - Asn1.RenderAsText(cert^, l, true, true, true, 2); - Result := l.Text; - finally - l.free; - end; - end; -end; - -function TSSLStreamSec.X500StrToStr(const Prefix: string; - const Value: TX500String): string; -begin - if Value.Str = '' then - Result := '' - else - Result := '/' + Prefix + '=' + Value.Str; -end; - -function TSSLStreamSec.X501NameToStr(const Value: TX501Name): string; -begin - Result := X500StrToStr('CN',Value.commonName) + - X500StrToStr('C',Value.countryName) + - X500StrToStr('L',Value.localityName) + - X500StrToStr('ST',Value.stateOrProvinceName) + - X500StrToStr('O',Value.organizationName) + - X500StrToStr('OU',Value.organizationalUnitName) + - X500StrToStr('T',Value.title) + - X500StrToStr('N',Value.name) + - X500StrToStr('G',Value.givenName) + - X500StrToStr('I',Value.initials) + - X500StrToStr('SN',Value.surname) + - X500StrToStr('GQ',Value.generationQualifier) + - X500StrToStr('DNQ',Value.dnQualifier) + - X500StrToStr('E',Value.emailAddress); -end; - - -{==============================================================================} - -initialization - SSLImplementation := TSSLStreamSec; - -finalization - -end. - - diff --git a/addons/synapse/sslinux.pas b/addons/synapse/sslinux.pas deleted file mode 100644 index 2a23146..0000000 --- a/addons/synapse/sslinux.pas +++ /dev/null @@ -1,1314 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.000.009 | -|==============================================================================| -| Content: Socket Independent Platform Layer - Linux definition include | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2003-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@exclude} - -{$IFDEF LINUX} - -//{$DEFINE FORCEOLDAPI} -{Note about define FORCEOLDAPI: -If you activate this compiler directive, then is allways used old socket API -for name resolution. If you leave this directive inactive, then the new API -is used, when running system allows it. - -For IPv6 support you must have new API! -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} -interface - -uses - SyncObjs, SysUtils, Classes, - synafpc, - Libc; - -function InitSocketInterface(stack: string): Boolean; -function DestroySocketInterface: Boolean; - -const - WinsockLevel = $0202; - -type - u_char = Char; - u_short = Word; - u_int = Integer; - u_long = Longint; - pu_long = ^u_long; - pu_short = ^u_short; - TSocket = u_int; - TAddrFamily = integer; - - TMemory = pointer; - - -const - DLLStackName = 'libc.so.6'; - - cLocalhost = '127.0.0.1'; - cAnyHost = '0.0.0.0'; - cBroadcast = '255.255.255.255'; - c6Localhost = '::1'; - c6AnyHost = '::0'; - c6Broadcast = 'ffff::1'; - cAnyPort = '0'; - -type - DWORD = Integer; - __fd_mask = LongWord; -const - __FD_SETSIZE = 1024; - __NFDBITS = 8 * sizeof(__fd_mask); -type - __fd_set = {packed} record - fds_bits: packed array[0..(__FD_SETSIZE div __NFDBITS)-1] of __fd_mask; - end; - TFDSet = __fd_set; - PFDSet = ^TFDSet; - -const - FIONREAD = $541B; - FIONBIO = $5421; - FIOASYNC = $5452; - -type - PTimeVal = ^TTimeVal; - TTimeVal = packed record - tv_sec: Longint; - tv_usec: Longint; - end; - -const - IPPROTO_IP = 0; { Dummy } - IPPROTO_ICMP = 1; { Internet Control Message Protocol } - IPPROTO_IGMP = 2; { Internet Group Management Protocol} - IPPROTO_TCP = 6; { TCP } - IPPROTO_UDP = 17; { User Datagram Protocol } - IPPROTO_IPV6 = 41; - IPPROTO_ICMPV6 = 58; - IPPROTO_RM = 113; - - IPPROTO_RAW = 255; - IPPROTO_MAX = 256; - -type - PInAddr = ^TInAddr; - TInAddr = packed record - case integer of - 0: (S_bytes: packed array [0..3] of byte); - 1: (S_addr: u_long); - end; - - PSockAddrIn = ^TSockAddrIn; - TSockAddrIn = packed record - case Integer of - 0: (sin_family: u_short; - sin_port: u_short; - sin_addr: TInAddr; - sin_zero: array[0..7] of Char); - 1: (sa_family: u_short; - sa_data: array[0..13] of Char) - end; - - TIP_mreq = record - imr_multiaddr: TInAddr; { IP multicast address of group } - imr_interface: TInAddr; { local IP address of interface } - end; - - PInAddr6 = ^TInAddr6; - TInAddr6 = packed record - case integer of - 0: (S6_addr: packed array [0..15] of byte); - 1: (u6_addr8: packed array [0..15] of byte); - 2: (u6_addr16: packed array [0..7] of word); - 3: (u6_addr32: packed array [0..3] of integer); - end; - - PSockAddrIn6 = ^TSockAddrIn6; - TSockAddrIn6 = packed record - sin6_family: u_short; // AF_INET6 - sin6_port: u_short; // Transport level port number - sin6_flowinfo: u_long; // IPv6 flow information - sin6_addr: TInAddr6; // IPv6 address - sin6_scope_id: u_long; // Scope Id: IF number for link-local - // SITE id for site-local - end; - - TIPv6_mreq = record - ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. - ipv6mr_interface: integer; // Interface index. - padding: u_long; - end; - - PHostEnt = ^THostEnt; - THostent = record - h_name: PChar; - h_aliases: PPChar; - h_addrtype: Integer; - h_length: Cardinal; - case Byte of - 0: (h_addr_list: PPChar); - 1: (h_addr: PPChar); - end; - - PNetEnt = ^TNetEnt; - TNetEnt = record - n_name: PChar; - n_aliases: PPChar; - n_addrtype: Integer; - n_net: uint32_t; - end; - - PServEnt = ^TServEnt; - TServEnt = record - s_name: PChar; - s_aliases: PPChar; - s_port: Integer; - s_proto: PChar; - end; - - PProtoEnt = ^TProtoEnt; - TProtoEnt = record - p_name: PChar; - p_aliases: ^PChar; - p_proto: u_short; - end; - -const - INADDR_ANY = $00000000; - INADDR_LOOPBACK = $7F000001; - INADDR_BROADCAST = $FFFFFFFF; - INADDR_NONE = $FFFFFFFF; - ADDR_ANY = INADDR_ANY; - INVALID_SOCKET = TSocket(NOT(0)); - SOCKET_ERROR = -1; - -Const - IP_TOS = 1; { int; IP type of service and precedence. } - IP_TTL = 2; { int; IP time to live. } - IP_HDRINCL = 3; { int; Header is included with data. } - IP_OPTIONS = 4; { ip_opts; IP per-packet options. } - IP_ROUTER_ALERT = 5; { bool } - IP_RECVOPTS = 6; { bool } - IP_RETOPTS = 7; { bool } - IP_PKTINFO = 8; { bool } - IP_PKTOPTIONS = 9; - IP_PMTUDISC = 10; { obsolete name? } - IP_MTU_DISCOVER = 10; { int; see below } - IP_RECVERR = 11; { bool } - IP_RECVTTL = 12; { bool } - IP_RECVTOS = 13; { bool } - IP_MULTICAST_IF = 32; { in_addr; set/get IP multicast i/f } - IP_MULTICAST_TTL = 33; { u_char; set/get IP multicast ttl } - IP_MULTICAST_LOOP = 34; { i_char; set/get IP multicast loopback } - IP_ADD_MEMBERSHIP = 35; { ip_mreq; add an IP group membership } - IP_DROP_MEMBERSHIP = 36; { ip_mreq; drop an IP group membership } - - SOL_SOCKET = 1; - - SO_DEBUG = 1; - SO_REUSEADDR = 2; - SO_TYPE = 3; - SO_ERROR = 4; - SO_DONTROUTE = 5; - SO_BROADCAST = 6; - SO_SNDBUF = 7; - SO_RCVBUF = 8; - SO_KEEPALIVE = 9; - SO_OOBINLINE = 10; - SO_NO_CHECK = 11; - SO_PRIORITY = 12; - SO_LINGER = 13; - SO_BSDCOMPAT = 14; - SO_REUSEPORT = 15; - SO_PASSCRED = 16; - SO_PEERCRED = 17; - SO_RCVLOWAT = 18; - SO_SNDLOWAT = 19; - SO_RCVTIMEO = 20; - SO_SNDTIMEO = 21; -{ Security levels - as per NRL IPv6 - don't actually do anything } - SO_SECURITY_AUTHENTICATION = 22; - SO_SECURITY_ENCRYPTION_TRANSPORT = 23; - SO_SECURITY_ENCRYPTION_NETWORK = 24; - SO_BINDTODEVICE = 25; -{ Socket filtering } - SO_ATTACH_FILTER = 26; - SO_DETACH_FILTER = 27; - - SOMAXCONN = 128; - - IPV6_UNICAST_HOPS = 16; - IPV6_MULTICAST_IF = 17; - IPV6_MULTICAST_HOPS = 18; - IPV6_MULTICAST_LOOP = 19; - IPV6_JOIN_GROUP = 20; - IPV6_LEAVE_GROUP = 21; - - MSG_NOSIGNAL = $4000; // Do not generate SIGPIPE. - - // getnameinfo constants - NI_MAXHOST = 1025; - NI_MAXSERV = 32; - NI_NOFQDN = $4; - NI_NUMERICHOST = $1; - NI_NAMEREQD = $8; - NI_NUMERICSERV = $2; - NI_DGRAM = $10; - -const - SOCK_STREAM = 1; { stream socket } - SOCK_DGRAM = 2; { datagram socket } - SOCK_RAW = 3; { raw-protocol interface } - SOCK_RDM = 4; { reliably-delivered message } - SOCK_SEQPACKET = 5; { sequenced packet stream } - -{ TCP options. } - TCP_NODELAY = $0001; - -{ Address families. } - - AF_UNSPEC = 0; { unspecified } - AF_INET = 2; { internetwork: UDP, TCP, etc. } - AF_INET6 = 10; { Internetwork Version 6 } - AF_MAX = 24; - -{ Protocol families, same as address families for now. } - PF_UNSPEC = AF_UNSPEC; - PF_INET = AF_INET; - PF_INET6 = AF_INET6; - PF_MAX = AF_MAX; - -type - { Structure used by kernel to store most addresses. } - PSockAddr = ^TSockAddr; - TSockAddr = TSockAddrIn; - - { Structure used by kernel to pass protocol information in raw sockets. } - PSockProto = ^TSockProto; - TSockProto = packed record - sp_family: u_short; - sp_protocol: u_short; - end; - -type - PAddrInfo = ^TAddrInfo; - TAddrInfo = record - ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST. - ai_family: integer; // PF_xxx. - ai_socktype: integer; // SOCK_xxx. - ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6. - ai_addrlen: u_int; // Length of ai_addr. - ai_addr: PSockAddr; // Binary address. - ai_canonname: PChar; // Canonical name for nodename. - ai_next: PAddrInfo; // Next structure in linked list. - end; - -const - // Flags used in "hints" argument to getaddrinfo(). - AI_PASSIVE = $1; // Socket address will be used in bind() call. - AI_CANONNAME = $2; // Return canonical name in first ai_canonname. - AI_NUMERICHOST = $4; // Nodename must be a numeric address string. - -type -{ Structure used for manipulating linger option. } - PLinger = ^TLinger; - TLinger = packed record - l_onoff: integer; - l_linger: integer; - end; - -const - - MSG_OOB = $01; // Process out-of-band data. - MSG_PEEK = $02; // Peek at incoming messages. - -const - WSAEINTR = EINTR; - WSAEBADF = EBADF; - WSAEACCES = EACCES; - WSAEFAULT = EFAULT; - WSAEINVAL = EINVAL; - WSAEMFILE = EMFILE; - WSAEWOULDBLOCK = EWOULDBLOCK; - WSAEINPROGRESS = EINPROGRESS; - WSAEALREADY = EALREADY; - WSAENOTSOCK = ENOTSOCK; - WSAEDESTADDRREQ = EDESTADDRREQ; - WSAEMSGSIZE = EMSGSIZE; - WSAEPROTOTYPE = EPROTOTYPE; - WSAENOPROTOOPT = ENOPROTOOPT; - WSAEPROTONOSUPPORT = EPROTONOSUPPORT; - WSAESOCKTNOSUPPORT = ESOCKTNOSUPPORT; - WSAEOPNOTSUPP = EOPNOTSUPP; - WSAEPFNOSUPPORT = EPFNOSUPPORT; - WSAEAFNOSUPPORT = EAFNOSUPPORT; - WSAEADDRINUSE = EADDRINUSE; - WSAEADDRNOTAVAIL = EADDRNOTAVAIL; - WSAENETDOWN = ENETDOWN; - WSAENETUNREACH = ENETUNREACH; - WSAENETRESET = ENETRESET; - WSAECONNABORTED = ECONNABORTED; - WSAECONNRESET = ECONNRESET; - WSAENOBUFS = ENOBUFS; - WSAEISCONN = EISCONN; - WSAENOTCONN = ENOTCONN; - WSAESHUTDOWN = ESHUTDOWN; - WSAETOOMANYREFS = ETOOMANYREFS; - WSAETIMEDOUT = ETIMEDOUT; - WSAECONNREFUSED = ECONNREFUSED; - WSAELOOP = ELOOP; - WSAENAMETOOLONG = ENAMETOOLONG; - WSAEHOSTDOWN = EHOSTDOWN; - WSAEHOSTUNREACH = EHOSTUNREACH; - WSAENOTEMPTY = ENOTEMPTY; - WSAEPROCLIM = -1; - WSAEUSERS = EUSERS; - WSAEDQUOT = EDQUOT; - WSAESTALE = ESTALE; - WSAEREMOTE = EREMOTE; - WSASYSNOTREADY = -2; - WSAVERNOTSUPPORTED = -3; - WSANOTINITIALISED = -4; - WSAEDISCON = -5; - WSAHOST_NOT_FOUND = HOST_NOT_FOUND; - WSATRY_AGAIN = TRY_AGAIN; - WSANO_RECOVERY = NO_RECOVERY; - WSANO_DATA = -6; - - EAI_BADFLAGS = -1; { Invalid value for `ai_flags' field. } - EAI_NONAME = -2; { NAME or SERVICE is unknown. } - EAI_AGAIN = -3; { Temporary failure in name resolution. } - EAI_FAIL = -4; { Non-recoverable failure in name res. } - EAI_NODATA = -5; { No address associated with NAME. } - EAI_FAMILY = -6; { `ai_family' not supported. } - EAI_SOCKTYPE = -7; { `ai_socktype' not supported. } - EAI_SERVICE = -8; { SERVICE not supported for `ai_socktype'. } - EAI_ADDRFAMILY = -9; { Address family for NAME not supported. } - EAI_MEMORY = -10; { Memory allocation failure. } - EAI_SYSTEM = -11; { System error returned in `errno'. } - -const - WSADESCRIPTION_LEN = 256; - WSASYS_STATUS_LEN = 128; -type - PWSAData = ^TWSAData; - TWSAData = packed record - wVersion: Word; - wHighVersion: Word; - szDescription: array[0..WSADESCRIPTION_LEN] of Char; - szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; - iMaxSockets: Word; - iMaxUdpDg: Word; - lpVendorInfo: PChar; - end; - - function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; - function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; - function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; - function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; - function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; - function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; - procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); - procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); -var - in6addr_any, in6addr_loopback : TInAddr6; - -procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); -function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; -procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); -procedure FD_ZERO(var FDSet: TFDSet); - -{=============================================================================} - -type - TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer; - cdecl; - TWSACleanup = function: Integer; - cdecl; - TWSAGetLastError = function: Integer; - cdecl; - TGetServByName = function(name, proto: PChar): PServEnt; - cdecl; - TGetServByPort = function(port: Integer; proto: PChar): PServEnt; - cdecl; - TGetProtoByName = function(name: PChar): PProtoEnt; - cdecl; - TGetProtoByNumber = function(proto: Integer): PProtoEnt; - cdecl; - TGetHostByName = function(name: PChar): PHostEnt; - cdecl; - TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt; - cdecl; - TGetHostName = function(name: PChar; len: Integer): Integer; - cdecl; - TShutdown = function(s: TSocket; how: Integer): Integer; - cdecl; - TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar; - optlen: Integer): Integer; - cdecl; - TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar; - var optlen: Integer): Integer; - cdecl; - TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; - tolen: Integer): Integer; - cdecl; - TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer; - cdecl; - TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer; - cdecl; - TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; - var fromlen: Integer): Integer; - cdecl; - Tntohs = function(netshort: u_short): u_short; - cdecl; - Tntohl = function(netlong: u_long): u_long; - cdecl; - TListen = function(s: TSocket; backlog: Integer): Integer; - cdecl; - TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: integer): Integer; - cdecl; - TInet_ntoa = function(inaddr: TInAddr): PChar; - cdecl; - TInet_addr = function(cp: PChar): u_long; - cdecl; - Thtons = function(hostshort: u_short): u_short; - cdecl; - Thtonl = function(hostlong: u_long): u_long; - cdecl; - TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; - cdecl; - TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; - cdecl; - TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer; - cdecl; - TCloseSocket = function(s: TSocket): Integer; - cdecl; - TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; - cdecl; - TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; - cdecl; - TTSocket = function(af, Struc, Protocol: Integer): TSocket; - cdecl; - TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; - timeout: PTimeVal): Longint; - cdecl; - - TGetAddrInfo = function(NodeName: PChar; ServName: PChar; Hints: PAddrInfo; - var Addrinfo: PAddrInfo): integer; - cdecl; - TFreeAddrInfo = procedure(ai: PAddrInfo); - cdecl; - TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PChar; - hostlen: DWORD; serv: PChar; servlen: DWORD; flags: integer): integer; - cdecl; - -var - WSAStartup: TWSAStartup = nil; - WSACleanup: TWSACleanup = nil; - WSAGetLastError: TWSAGetLastError = nil; - GetServByName: TGetServByName = nil; - GetServByPort: TGetServByPort = nil; - GetProtoByName: TGetProtoByName = nil; - GetProtoByNumber: TGetProtoByNumber = nil; - GetHostByName: TGetHostByName = nil; - GetHostByAddr: TGetHostByAddr = nil; - ssGetHostName: TGetHostName = nil; - Shutdown: TShutdown = nil; - SetSockOpt: TSetSockOpt = nil; - GetSockOpt: TGetSockOpt = nil; - ssSendTo: TSendTo = nil; - ssSend: TSend = nil; - ssRecv: TRecv = nil; - ssRecvFrom: TRecvFrom = nil; - ntohs: Tntohs = nil; - ntohl: Tntohl = nil; - Listen: TListen = nil; - IoctlSocket: TIoctlSocket = nil; - Inet_ntoa: TInet_ntoa = nil; - Inet_addr: TInet_addr = nil; - htons: Thtons = nil; - htonl: Thtonl = nil; - ssGetSockName: TGetSockName = nil; - ssGetPeerName: TGetPeerName = nil; - ssConnect: TConnect = nil; - CloseSocket: TCloseSocket = nil; - ssBind: TBind = nil; - ssAccept: TAccept = nil; - Socket: TTSocket = nil; - Select: TSelect = nil; - - GetAddrInfo: TGetAddrInfo = nil; - FreeAddrInfo: TFreeAddrInfo = nil; - GetNameInfo: TGetNameInfo = nil; - -function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; cdecl; -function LSWSACleanup: Integer; cdecl; -function LSWSAGetLastError: Integer; cdecl; - -var - SynSockCS: SyncObjs.TCriticalSection; - SockEnhancedApi: Boolean; - SockWship6Api: Boolean; - -type - TVarSin = packed record - case integer of - 0: (AddressFamily: u_short); - 1: ( - case sin_family: u_short of - AF_INET: (sin_port: u_short; - sin_addr: TInAddr; - sin_zero: array[0..7] of Char); - AF_INET6: (sin6_port: u_short; - sin6_flowinfo: u_long; - sin6_addr: TInAddr6; - sin6_scope_id: u_long); - ); - end; - -function SizeOfVarSin(sin: TVarSin): integer; - -function Bind(s: TSocket; const addr: TVarSin): Integer; -function Connect(s: TSocket; const name: TVarSin): Integer; -function GetSockName(s: TSocket; var name: TVarSin): Integer; -function GetPeerName(s: TSocket; var name: TVarSin): Integer; -function GetHostName: string; -function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; -function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; -function Accept(s: TSocket; var addr: TVarSin): TSocket; - -function IsNewApi(Family: integer): Boolean; -function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -function GetSinIP(Sin: TVarSin): string; -function GetSinPort(Sin: TVarSin): Integer; -procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); -function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; -function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; - -{==============================================================================} -implementation - -var - SynSockCount: Integer = 0; - LibHandle: TLibHandle = 0; - Libwship6Handle: TLibHandle = 0; - -function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and - (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); -end; - -function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and - (a^.u6_addr32[2] = 0) and - (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and - (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); -end; - -function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); -end; - -function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); -end; - -function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; -begin - Result := (a^.u6_addr8[0] = $FF); -end; - -function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; -begin - Result := (CompareMem( a, b, sizeof(TInAddr6))); -end; - -procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); -begin - FillChar(a^, sizeof(TInAddr6), 0); -end; - -procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); -begin - FillChar(a^, sizeof(TInAddr6), 0); - a^.u6_addr8[15] := 1; -end; - -{=============================================================================} -var -{$IFNDEF VER1_0} //FTP version 1.0.x - errno_loc: function: PInteger cdecl = nil; -{$ELSE} - errno_loc: function: PInteger = nil; cdecl; -{$ENDIF} - -function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; -begin - with WSData do - begin - wVersion := wVersionRequired; - wHighVersion := $202; - szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; - szSystemStatus := 'Running on Linux'; - iMaxSockets := 32768; - iMaxUdpDg := 8192; - end; - Result := 0; -end; - -function LSWSACleanup: Integer; -begin - Result := 0; -end; - -function LSWSAGetLastError: Integer; -var - p: PInteger; -begin - p := errno_loc; - Result := p^; -end; - -function __FDELT(Socket: TSocket): Integer; -begin - Result := Socket div __NFDBITS; -end; - -function __FDMASK(Socket: TSocket): __fd_mask; -begin - Result := LongWord(1) shl (Socket mod __NFDBITS); -end; - -function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean; -begin - Result := (fdset.fds_bits[__FDELT(Socket)] and __FDMASK(Socket)) <> 0; -end; - -procedure FD_SET(Socket: TSocket; var fdset: TFDSet); -begin - fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] or __FDMASK(Socket); -end; - -procedure FD_CLR(Socket: TSocket; var fdset: TFDSet); -begin - fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] and (not __FDMASK(Socket)); -end; - -procedure FD_ZERO(var fdset: TFDSet); -var - I: Integer; -begin - with fdset do - for I := Low(fds_bits) to High(fds_bits) do - fds_bits[I] := 0; -end; - -{=============================================================================} - -function SizeOfVarSin(sin: TVarSin): integer; -begin - case sin.sin_family of - AF_INET: - Result := SizeOf(TSockAddrIn); - AF_INET6: - Result := SizeOf(TSockAddrIn6); - else - Result := 0; - end; -end; - -{=============================================================================} - -function Bind(s: TSocket; const addr: TVarSin): Integer; -begin - Result := ssBind(s, @addr, SizeOfVarSin(addr)); -end; - -function Connect(s: TSocket; const name: TVarSin): Integer; -begin - Result := ssConnect(s, @name, SizeOfVarSin(name)); -end; - -function GetSockName(s: TSocket; var name: TVarSin): Integer; -var - len: integer; -begin - len := SizeOf(name); - FillChar(name, len, 0); - Result := ssGetSockName(s, @name, Len); -end; - -function GetPeerName(s: TSocket; var name: TVarSin): Integer; -var - len: integer; -begin - len := SizeOf(name); - FillChar(name, len, 0); - Result := ssGetPeerName(s, @name, Len); -end; - -function GetHostName: string; -var - s: string; -begin - Result := ''; - setlength(s, 255); - ssGetHostName(pchar(s), Length(s) - 1); - Result := Pchar(s); -end; - -function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -begin - Result := ssSend(s, Buf^, len, flags); -end; - -function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -begin - Result := ssRecv(s, Buf^, len, flags); -end; - -function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; -begin - Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto)); -end; - -function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; -var - x: integer; -begin - x := SizeOf(from); - Result := ssRecvFrom(s, Buf^, len, flags, @from, x); -end; - -function Accept(s: TSocket; var addr: TVarSin): TSocket; -var - x: integer; -begin - x := SizeOf(addr); - Result := ssAccept(s, @addr, x); -end; - -{=============================================================================} -function IsNewApi(Family: integer): Boolean; -begin - Result := SockEnhancedApi; - if not Result then - Result := (Family = AF_INET6) and SockWship6Api; -end; - -function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -type - pu_long = ^u_long; -var - ProtoEnt: PProtoEnt; - ServEnt: PServEnt; - HostEnt: PHostEnt; - r: integer; - Hints1, Hints2: TAddrInfo; - Sin1, Sin2: TVarSin; - TwoPass: boolean; - - function GetAddr(const IP, port: string; Hints: TAddrInfo; var Sin: TVarSin): integer; - var - Addr: PAddrInfo; - begin - Addr := nil; - try - FillChar(Sin, Sizeof(Sin), 0); - if Hints.ai_socktype = SOCK_RAW then - begin - Hints.ai_socktype := 0; - Hints.ai_protocol := 0; - Result := synsock.GetAddrInfo(PChar(IP), nil, @Hints, Addr); - end - else - begin - if (IP = cAnyHost) or (IP = c6AnyHost) then - begin - Hints.ai_flags := AI_PASSIVE; - Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); - end - else - if (IP = cLocalhost) or (IP = c6Localhost) then - begin - Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); - end - else - begin - Result := synsock.GetAddrInfo(PChar(IP), PChar(Port), @Hints, Addr); - end; - end; - if Result = 0 then - if (Addr <> nil) then - Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen); - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; - -begin - Result := 0; - FillChar(Sin, Sizeof(Sin), 0); - if not IsNewApi(family) then - begin - SynSockCS.Enter; - try - Sin.sin_family := AF_INET; - ProtoEnt := synsock.GetProtoByNumber(SockProtocol); - ServEnt := nil; - if ProtoEnt <> nil then - ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); - if ServEnt = nil then - Sin.sin_port := synsock.htons(StrToIntDef(Port, 0)) - else - Sin.sin_port := ServEnt^.s_port; - if IP = cBroadcast then - Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) - else - begin - Sin.sin_addr.s_addr := synsock.inet_addr(PChar(IP)); - if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then - begin - HostEnt := synsock.GetHostByName(PChar(IP)); - Result := synsock.WSAGetLastError; - if HostEnt <> nil then - Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); - end; - end; - finally - SynSockCS.Leave; - end; - end - else - begin - FillChar(Hints1, Sizeof(Hints1), 0); - FillChar(Hints2, Sizeof(Hints2), 0); - TwoPass := False; - if Family = AF_UNSPEC then - begin - if PreferIP4 then - begin - Hints1.ai_family := AF_INET; - Hints2.ai_family := AF_INET6; - TwoPass := True; - end - else - begin - Hints2.ai_family := AF_INET; - Hints1.ai_family := AF_INET6; - TwoPass := True; - end; - end - else - Hints1.ai_family := Family; - - Hints1.ai_socktype := SockType; - Hints1.ai_protocol := SockProtocol; - Hints2.ai_socktype := Hints1.ai_socktype; - Hints2.ai_protocol := Hints1.ai_protocol; - - r := GetAddr(IP, Port, Hints1, Sin1); - Result := r; - sin := sin1; - if r <> 0 then - if TwoPass then - begin - r := GetAddr(IP, Port, Hints2, Sin2); - Result := r; - if r = 0 then - sin := sin2; - end; - end; -end; - -function GetSinIP(Sin: TVarSin): string; -var - p: PChar; - host, serv: string; - hostlen, servlen: integer; - r: integer; -begin - Result := ''; - if not IsNewApi(Sin.AddressFamily) then - begin - p := synsock.inet_ntoa(Sin.sin_addr); - if p <> nil then - Result := p; - end - else - begin - hostlen := NI_MAXHOST; - servlen := NI_MAXSERV; - setlength(host, hostlen); - setlength(serv, servlen); - r := getnameinfo(@sin, SizeOfVarSin(sin), PChar(host), hostlen, - PChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); - if r = 0 then - Result := PChar(host); - end; -end; - -function GetSinPort(Sin: TVarSin): Integer; -begin - if (Sin.sin_family = AF_INET6) then - Result := synsock.ntohs(Sin.sin6_port) - else - Result := synsock.ntohs(Sin.sin_port); -end; - -procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); -type - TaPInAddr = array[0..250] of PInAddr; - PaPInAddr = ^TaPInAddr; -var - Hints: TAddrInfo; - Addr: PAddrInfo; - AddrNext: PAddrInfo; - r: integer; - host, serv: string; - hostlen, servlen: integer; - RemoteHost: PHostEnt; - IP: u_long; - PAdrPtr: PaPInAddr; - i: Integer; - s: string; - InAddr: TInAddr; -begin - IPList.Clear; - if not IsNewApi(Family) then - begin - IP := synsock.inet_addr(PChar(Name)); - if IP = u_long(INADDR_NONE) then - begin - SynSockCS.Enter; - try - RemoteHost := synsock.GetHostByName(PChar(Name)); - if RemoteHost <> nil then - begin - PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); - i := 0; - while PAdrPtr^[i] <> nil do - begin - InAddr := PAdrPtr^[i]^; - s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1], - InAddr.S_bytes[2], InAddr.S_bytes[3]]); - IPList.Add(s); - Inc(i); - end; - end; - finally - SynSockCS.Leave; - end; - end - else - IPList.Add(Name); - end - else - begin - Addr := nil; - try - FillChar(Hints, Sizeof(Hints), 0); - Hints.ai_family := AF_UNSPEC; - Hints.ai_socktype := SockType; - Hints.ai_protocol := SockProtocol; - Hints.ai_flags := 0; - r := synsock.GetAddrInfo(PChar(Name), nil, @Hints, Addr); - if r = 0 then - begin - AddrNext := Addr; - while not(AddrNext = nil) do - begin - if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET)) - or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then - begin - hostlen := NI_MAXHOST; - servlen := NI_MAXSERV; - setlength(host, hostlen); - setlength(serv, servlen); - r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen, - PChar(host), hostlen, PChar(serv), servlen, - NI_NUMERICHOST + NI_NUMERICSERV); - if r = 0 then - begin - host := PChar(host); - IPList.Add(host); - end; - end; - AddrNext := AddrNext^.ai_next; - end; - end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; - if IPList.Count = 0 then - IPList.Add(cAnyHost); -end; - -function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; -var - ProtoEnt: PProtoEnt; - ServEnt: PServEnt; - Hints: TAddrInfo; - Addr: PAddrInfo; - r: integer; -begin - Result := 0; - if not IsNewApi(Family) then - begin - SynSockCS.Enter; - try - ProtoEnt := synsock.GetProtoByNumber(SockProtocol); - ServEnt := nil; - if ProtoEnt <> nil then - ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); - if ServEnt = nil then - Result := StrToIntDef(Port, 0) - else - Result := synsock.htons(ServEnt^.s_port); - finally - SynSockCS.Leave; - end; - end - else - begin - Addr := nil; - try - FillChar(Hints, Sizeof(Hints), 0); - Hints.ai_family := AF_UNSPEC; - Hints.ai_socktype := SockType; - Hints.ai_protocol := Sockprotocol; - Hints.ai_flags := AI_PASSIVE; - r := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); - if (r = 0) and Assigned(Addr) then - begin - if Addr^.ai_family = AF_INET then - Result := synsock.htons(Addr^.ai_addr^.sin_port); - if Addr^.ai_family = AF_INET6 then - Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port); - end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; -end; - -function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; -var - Hints: TAddrInfo; - Addr: PAddrInfo; - r: integer; - host, serv: string; - hostlen, servlen: integer; - RemoteHost: PHostEnt; - IPn: u_long; -begin - Result := IP; - if not IsNewApi(Family) then - begin - IPn := synsock.inet_addr(PChar(IP)); - if IPn <> u_long(INADDR_NONE) then - begin - SynSockCS.Enter; - try - RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET); - if RemoteHost <> nil then - Result := RemoteHost^.h_name; - finally - SynSockCS.Leave; - end; - end; - end - else - begin - Addr := nil; - try - FillChar(Hints, Sizeof(Hints), 0); - Hints.ai_family := AF_UNSPEC; - Hints.ai_socktype := SockType; - Hints.ai_protocol := SockProtocol; - Hints.ai_flags := 0; - r := synsock.GetAddrInfo(PChar(IP), nil, @Hints, Addr); - if (r = 0) and Assigned(Addr)then - begin - hostlen := NI_MAXHOST; - servlen := NI_MAXSERV; - setlength(host, hostlen); - setlength(serv, servlen); - r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen, - PChar(host), hostlen, PChar(serv), servlen, - NI_NUMERICSERV); - if r = 0 then - Result := PChar(host); - end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; -end; - -{=============================================================================} - -function InitSocketInterface(stack: string): Boolean; -begin - Result := False; - SockEnhancedApi := False; - if stack = '' then - stack := DLLStackName; - SynSockCS.Enter; - try - if SynSockCount = 0 then - begin - SockEnhancedApi := False; - SockWship6Api := False; - Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN)); - LibHandle := LoadLibrary(PChar(Stack)); - if LibHandle <> 0 then - begin - errno_loc := GetProcAddress(LibHandle, PChar('__errno_location')); - CloseSocket := GetProcAddress(LibHandle, PChar('close')); - IoctlSocket := GetProcAddress(LibHandle, PChar('ioctl')); - WSAGetLastError := LSWSAGetLastError; - WSAStartup := LSWSAStartup; - WSACleanup := LSWSACleanup; - ssAccept := GetProcAddress(LibHandle, PChar('accept')); - ssBind := GetProcAddress(LibHandle, PChar('bind')); - ssConnect := GetProcAddress(LibHandle, PChar('connect')); - ssGetPeerName := GetProcAddress(LibHandle, PChar('getpeername')); - ssGetSockName := GetProcAddress(LibHandle, PChar('getsockname')); - GetSockOpt := GetProcAddress(LibHandle, PChar('getsockopt')); - Htonl := GetProcAddress(LibHandle, PChar('htonl')); - Htons := GetProcAddress(LibHandle, PChar('htons')); - Inet_Addr := GetProcAddress(LibHandle, PChar('inet_addr')); - Inet_Ntoa := GetProcAddress(LibHandle, PChar('inet_ntoa')); - Listen := GetProcAddress(LibHandle, PChar('listen')); - Ntohl := GetProcAddress(LibHandle, PChar('ntohl')); - Ntohs := GetProcAddress(LibHandle, PChar('ntohs')); - ssRecv := GetProcAddress(LibHandle, PChar('recv')); - ssRecvFrom := GetProcAddress(LibHandle, PChar('recvfrom')); - Select := GetProcAddress(LibHandle, PChar('select')); - ssSend := GetProcAddress(LibHandle, PChar('send')); - ssSendTo := GetProcAddress(LibHandle, PChar('sendto')); - SetSockOpt := GetProcAddress(LibHandle, PChar('setsockopt')); - ShutDown := GetProcAddress(LibHandle, PChar('shutdown')); - Socket := GetProcAddress(LibHandle, PChar('socket')); - GetHostByAddr := GetProcAddress(LibHandle, PChar('gethostbyaddr')); - GetHostByName := GetProcAddress(LibHandle, PChar('gethostbyname')); - GetProtoByName := GetProcAddress(LibHandle, PChar('getprotobyname')); - GetProtoByNumber := GetProcAddress(LibHandle, PChar('getprotobynumber')); - GetServByName := GetProcAddress(LibHandle, PChar('getservbyname')); - GetServByPort := GetProcAddress(LibHandle, PChar('getservbyport')); - ssGetHostName := GetProcAddress(LibHandle, PChar('gethostname')); - -{$IFNDEF FORCEOLDAPI} - GetAddrInfo := GetProcAddress(LibHandle, PChar('getaddrinfo')); - FreeAddrInfo := GetProcAddress(LibHandle, PChar('freeaddrinfo')); - GetNameInfo := GetProcAddress(LibHandle, PChar('getnameinfo')); - SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) - and Assigned(GetNameInfo); -{$ENDIF} - Result := True; - end; - end - else Result := True; - if Result then - Inc(SynSockCount); - finally - SynSockCS.Leave; - end; -end; - -function DestroySocketInterface: Boolean; -begin - SynSockCS.Enter; - try - Dec(SynSockCount); - if SynSockCount < 0 then - SynSockCount := 0; - if SynSockCount = 0 then - begin - if LibHandle <> 0 then - begin - FreeLibrary(libHandle); - LibHandle := 0; - end; - if LibWship6Handle <> 0 then - begin - FreeLibrary(LibWship6Handle); - LibWship6Handle := 0; - end; - end; - finally - SynSockCS.Leave; - end; - Result := True; -end; - -initialization -begin - SynSockCS := SyncObjs.TCriticalSection.Create; - SET_IN6_IF_ADDR_ANY (@in6addr_any); - SET_LOOPBACK_ADDR6 (@in6addr_loopback); -end; - -finalization -begin - SynSockCS.Free; -end; - -{$ENDIF} - diff --git a/addons/synapse/sswin32.pas b/addons/synapse/sswin32.pas deleted file mode 100644 index 30848d8..0000000 --- a/addons/synapse/sswin32.pas +++ /dev/null @@ -1,1599 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.002.003 | -|==============================================================================| -| Content: Socket Independent Platform Layer - Win32 definition include | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2003-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@exclude} - -//{$DEFINE WINSOCK1} -{Note about define WINSOCK1: -If you activate this compiler directive, then socket interface level 1.1 is -used instead default level 2.2. Level 2.2 is not available on old W95, however -you can install update. -} - -//{$DEFINE FORCEOLDAPI} -{Note about define FORCEOLDAPI: -If you activate this compiler directive, then is allways used old socket API -for name resolution. If you leave this directive inactive, then the new API -is used, when running system allows it. - -For IPv6 support you must have new API! -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} -{$IFDEF VER125} - {$DEFINE BCB} -{$ENDIF} -{$IFDEF BCB} - {$ObjExportAll On} - (*$HPPEMIT '/* EDE 2003-02-19 */' *) - (*$HPPEMIT 'namespace Synsock { using System::Shortint; }' *) - (*$HPPEMIT '#undef h_addr' *) - (*$HPPEMIT '#undef IOCPARM_MASK' *) - (*$HPPEMIT '#undef FD_SETSIZE' *) - (*$HPPEMIT '#undef IOC_VOID' *) - (*$HPPEMIT '#undef IOC_OUT' *) - (*$HPPEMIT '#undef IOC_IN' *) - (*$HPPEMIT '#undef IOC_INOUT' *) - (*$HPPEMIT '#undef FIONREAD' *) - (*$HPPEMIT '#undef FIONBIO' *) - (*$HPPEMIT '#undef FIOASYNC' *) - (*$HPPEMIT '#undef IPPROTO_IP' *) - (*$HPPEMIT '#undef IPPROTO_ICMP' *) - (*$HPPEMIT '#undef IPPROTO_IGMP' *) - (*$HPPEMIT '#undef IPPROTO_TCP' *) - (*$HPPEMIT '#undef IPPROTO_UDP' *) - (*$HPPEMIT '#undef IPPROTO_RAW' *) - (*$HPPEMIT '#undef IPPROTO_MAX' *) - (*$HPPEMIT '#undef INADDR_ANY' *) - (*$HPPEMIT '#undef INADDR_LOOPBACK' *) - (*$HPPEMIT '#undef INADDR_BROADCAST' *) - (*$HPPEMIT '#undef INADDR_NONE' *) - (*$HPPEMIT '#undef INVALID_SOCKET' *) - (*$HPPEMIT '#undef SOCKET_ERROR' *) - (*$HPPEMIT '#undef WSADESCRIPTION_LEN' *) - (*$HPPEMIT '#undef WSASYS_STATUS_LEN' *) - (*$HPPEMIT '#undef IP_OPTIONS' *) - (*$HPPEMIT '#undef IP_TOS' *) - (*$HPPEMIT '#undef IP_TTL' *) - (*$HPPEMIT '#undef IP_MULTICAST_IF' *) - (*$HPPEMIT '#undef IP_MULTICAST_TTL' *) - (*$HPPEMIT '#undef IP_MULTICAST_LOOP' *) - (*$HPPEMIT '#undef IP_ADD_MEMBERSHIP' *) - (*$HPPEMIT '#undef IP_DROP_MEMBERSHIP' *) - (*$HPPEMIT '#undef IP_DONTFRAGMENT' *) - (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_TTL' *) - (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_LOOP' *) - (*$HPPEMIT '#undef IP_MAX_MEMBERSHIPS' *) - (*$HPPEMIT '#undef SOL_SOCKET' *) - (*$HPPEMIT '#undef SO_DEBUG' *) - (*$HPPEMIT '#undef SO_ACCEPTCONN' *) - (*$HPPEMIT '#undef SO_REUSEADDR' *) - (*$HPPEMIT '#undef SO_KEEPALIVE' *) - (*$HPPEMIT '#undef SO_DONTROUTE' *) - (*$HPPEMIT '#undef SO_BROADCAST' *) - (*$HPPEMIT '#undef SO_USELOOPBACK' *) - (*$HPPEMIT '#undef SO_LINGER' *) - (*$HPPEMIT '#undef SO_OOBINLINE' *) - (*$HPPEMIT '#undef SO_DONTLINGER' *) - (*$HPPEMIT '#undef SO_SNDBUF' *) - (*$HPPEMIT '#undef SO_RCVBUF' *) - (*$HPPEMIT '#undef SO_SNDLOWAT' *) - (*$HPPEMIT '#undef SO_RCVLOWAT' *) - (*$HPPEMIT '#undef SO_SNDTIMEO' *) - (*$HPPEMIT '#undef SO_RCVTIMEO' *) - (*$HPPEMIT '#undef SO_ERROR' *) - (*$HPPEMIT '#undef SO_OPENTYPE' *) - (*$HPPEMIT '#undef SO_SYNCHRONOUS_ALERT' *) - (*$HPPEMIT '#undef SO_SYNCHRONOUS_NONALERT' *) - (*$HPPEMIT '#undef SO_MAXDG' *) - (*$HPPEMIT '#undef SO_MAXPATHDG' *) - (*$HPPEMIT '#undef SO_UPDATE_ACCEPT_CONTEXT' *) - (*$HPPEMIT '#undef SO_CONNECT_TIME' *) - (*$HPPEMIT '#undef SO_TYPE' *) - (*$HPPEMIT '#undef SOCK_STREAM' *) - (*$HPPEMIT '#undef SOCK_DGRAM' *) - (*$HPPEMIT '#undef SOCK_RAW' *) - (*$HPPEMIT '#undef SOCK_RDM' *) - (*$HPPEMIT '#undef SOCK_SEQPACKET' *) - (*$HPPEMIT '#undef TCP_NODELAY' *) - (*$HPPEMIT '#undef AF_UNSPEC' *) - (*$HPPEMIT '#undef SOMAXCONN' *) - (*$HPPEMIT '#undef AF_INET' *) - (*$HPPEMIT '#undef AF_MAX' *) - (*$HPPEMIT '#undef PF_UNSPEC' *) - (*$HPPEMIT '#undef PF_INET' *) - (*$HPPEMIT '#undef PF_MAX' *) - (*$HPPEMIT '#undef MSG_OOB' *) - (*$HPPEMIT '#undef MSG_PEEK' *) - (*$HPPEMIT '#undef WSABASEERR' *) - (*$HPPEMIT '#undef WSAEINTR' *) - (*$HPPEMIT '#undef WSAEBADF' *) - (*$HPPEMIT '#undef WSAEACCES' *) - (*$HPPEMIT '#undef WSAEFAULT' *) - (*$HPPEMIT '#undef WSAEINVAL' *) - (*$HPPEMIT '#undef WSAEMFILE' *) - (*$HPPEMIT '#undef WSAEWOULDBLOCK' *) - (*$HPPEMIT '#undef WSAEINPROGRESS' *) - (*$HPPEMIT '#undef WSAEALREADY' *) - (*$HPPEMIT '#undef WSAENOTSOCK' *) - (*$HPPEMIT '#undef WSAEDESTADDRREQ' *) - (*$HPPEMIT '#undef WSAEMSGSIZE' *) - (*$HPPEMIT '#undef WSAEPROTOTYPE' *) - (*$HPPEMIT '#undef WSAENOPROTOOPT' *) - (*$HPPEMIT '#undef WSAEPROTONOSUPPORT' *) - (*$HPPEMIT '#undef WSAESOCKTNOSUPPORT' *) - (*$HPPEMIT '#undef WSAEOPNOTSUPP' *) - (*$HPPEMIT '#undef WSAEPFNOSUPPORT' *) - (*$HPPEMIT '#undef WSAEAFNOSUPPORT' *) - (*$HPPEMIT '#undef WSAEADDRINUSE' *) - (*$HPPEMIT '#undef WSAEADDRNOTAVAIL' *) - (*$HPPEMIT '#undef WSAENETDOWN' *) - (*$HPPEMIT '#undef WSAENETUNREACH' *) - (*$HPPEMIT '#undef WSAENETRESET' *) - (*$HPPEMIT '#undef WSAECONNABORTED' *) - (*$HPPEMIT '#undef WSAECONNRESET' *) - (*$HPPEMIT '#undef WSAENOBUFS' *) - (*$HPPEMIT '#undef WSAEISCONN' *) - (*$HPPEMIT '#undef WSAENOTCONN' *) - (*$HPPEMIT '#undef WSAESHUTDOWN' *) - (*$HPPEMIT '#undef WSAETOOMANYREFS' *) - (*$HPPEMIT '#undef WSAETIMEDOUT' *) - (*$HPPEMIT '#undef WSAECONNREFUSED' *) - (*$HPPEMIT '#undef WSAELOOP' *) - (*$HPPEMIT '#undef WSAENAMETOOLONG' *) - (*$HPPEMIT '#undef WSAEHOSTDOWN' *) - (*$HPPEMIT '#undef WSAEHOSTUNREACH' *) - (*$HPPEMIT '#undef WSAENOTEMPTY' *) - (*$HPPEMIT '#undef WSAEPROCLIM' *) - (*$HPPEMIT '#undef WSAEUSERS' *) - (*$HPPEMIT '#undef WSAEDQUOT' *) - (*$HPPEMIT '#undef WSAESTALE' *) - (*$HPPEMIT '#undef WSAEREMOTE' *) - (*$HPPEMIT '#undef WSASYSNOTREADY' *) - (*$HPPEMIT '#undef WSAVERNOTSUPPORTED' *) - (*$HPPEMIT '#undef WSANOTINITIALISED' *) - (*$HPPEMIT '#undef WSAEDISCON' *) - (*$HPPEMIT '#undef WSAENOMORE' *) - (*$HPPEMIT '#undef WSAECANCELLED' *) - (*$HPPEMIT '#undef WSAEEINVALIDPROCTABLE' *) - (*$HPPEMIT '#undef WSAEINVALIDPROVIDER' *) - (*$HPPEMIT '#undef WSAEPROVIDERFAILEDINIT' *) - (*$HPPEMIT '#undef WSASYSCALLFAILURE' *) - (*$HPPEMIT '#undef WSASERVICE_NOT_FOUND' *) - (*$HPPEMIT '#undef WSATYPE_NOT_FOUND' *) - (*$HPPEMIT '#undef WSA_E_NO_MORE' *) - (*$HPPEMIT '#undef WSA_E_CANCELLED' *) - (*$HPPEMIT '#undef WSAEREFUSED' *) - (*$HPPEMIT '#undef WSAHOST_NOT_FOUND' *) - (*$HPPEMIT '#undef HOST_NOT_FOUND' *) - (*$HPPEMIT '#undef WSATRY_AGAIN' *) - (*$HPPEMIT '#undef TRY_AGAIN' *) - (*$HPPEMIT '#undef WSANO_RECOVERY' *) - (*$HPPEMIT '#undef NO_RECOVERY' *) - (*$HPPEMIT '#undef WSANO_DATA' *) - (*$HPPEMIT '#undef NO_DATA' *) - (*$HPPEMIT '#undef WSANO_ADDRESS' *) - (*$HPPEMIT '#undef ENAMETOOLONG' *) - (*$HPPEMIT '#undef ENOTEMPTY' *) - (*$HPPEMIT '#undef FD_CLR' *) - (*$HPPEMIT '#undef FD_ISSET' *) - (*$HPPEMIT '#undef FD_SET' *) - (*$HPPEMIT '#undef FD_ZERO' *) - (*$HPPEMIT '#undef NO_ADDRESS' *) - (*$HPPEMIT '#undef ADDR_ANY' *) - (*$HPPEMIT '#undef SO_GROUP_ID' *) - (*$HPPEMIT '#undef SO_GROUP_PRIORITY' *) - (*$HPPEMIT '#undef SO_MAX_MSG_SIZE' *) - (*$HPPEMIT '#undef SO_PROTOCOL_INFOA' *) - (*$HPPEMIT '#undef SO_PROTOCOL_INFOW' *) - (*$HPPEMIT '#undef SO_PROTOCOL_INFO' *) - (*$HPPEMIT '#undef PVD_CONFIG' *) - (*$HPPEMIT '#undef AF_INET6' *) - (*$HPPEMIT '#undef PF_INET6' *) -{$ENDIF} - -interface - -uses - SyncObjs, SysUtils, Classes, - Windows; - -function InitSocketInterface(stack: String): Boolean; -function DestroySocketInterface: Boolean; - -const -{$IFDEF WINSOCK1} - WinsockLevel = $0101; -{$ELSE} - WinsockLevel = $0202; -{$ENDIF} - -type - u_short = Word; - u_int = Integer; - u_long = Longint; - pu_long = ^u_long; - pu_short = ^u_short; -{$IFDEF FPC} - TSocket = ptruint; -{$ELSE} - TSocket = u_int; -{$ENDIF} - TAddrFamily = integer; - - TMemory = pointer; - -const - {$IFDEF WINSOCK1} - DLLStackName = 'wsock32.dll'; - {$ELSE} - DLLStackName = 'ws2_32.dll'; - {$ENDIF} - DLLwship6 = 'wship6.dll'; - - cLocalhost = '127.0.0.1'; - cAnyHost = '0.0.0.0'; - cBroadcast = '255.255.255.255'; - c6Localhost = '::1'; - c6AnyHost = '::0'; - c6Broadcast = 'ffff::1'; - cAnyPort = '0'; - - -const - FD_SETSIZE = 64; -type - PFDSet = ^TFDSet; - TFDSet = record - fd_count: u_int; - fd_array: array[0..FD_SETSIZE-1] of TSocket; - end; - -const - FIONREAD = $4004667f; - FIONBIO = $8004667e; - FIOASYNC = $8004667d; - -type - PTimeVal = ^TTimeVal; - TTimeVal = record - tv_sec: Longint; - tv_usec: Longint; - end; - -const - IPPROTO_IP = 0; { Dummy } - IPPROTO_ICMP = 1; { Internet Control Message Protocol } - IPPROTO_IGMP = 2; { Internet Group Management Protocol} - IPPROTO_TCP = 6; { TCP } - IPPROTO_UDP = 17; { User Datagram Protocol } - IPPROTO_IPV6 = 41; - IPPROTO_ICMPV6 = 58; - IPPROTO_RM = 113; - - IPPROTO_RAW = 255; - IPPROTO_MAX = 256; - -type - - PInAddr = ^TInAddr; - TInAddr = record - case integer of - 0: (S_bytes: packed array [0..3] of byte); - 1: (S_addr: u_long); - end; - - PSockAddrIn = ^TSockAddrIn; - TSockAddrIn = record - case Integer of - 0: (sin_family: u_short; - sin_port: u_short; - sin_addr: TInAddr; - sin_zero: array[0..7] of byte); - 1: (sa_family: u_short; - sa_data: array[0..13] of byte) - end; - - TIP_mreq = record - imr_multiaddr: TInAddr; { IP multicast address of group } - imr_interface: TInAddr; { local IP address of interface } - end; - - PInAddr6 = ^TInAddr6; - TInAddr6 = record - case integer of - 0: (S6_addr: packed array [0..15] of byte); - 1: (u6_addr8: packed array [0..15] of byte); - 2: (u6_addr16: packed array [0..7] of word); - 3: (u6_addr32: packed array [0..3] of integer); - end; - - PSockAddrIn6 = ^TSockAddrIn6; - TSockAddrIn6 = record - sin6_family: u_short; // AF_INET6 - sin6_port: u_short; // Transport level port number - sin6_flowinfo: u_long; // IPv6 flow information - sin6_addr: TInAddr6; // IPv6 address - sin6_scope_id: u_long; // Scope Id: IF number for link-local - // SITE id for site-local - end; - - TIPv6_mreq = record - ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. - ipv6mr_interface: integer; // Interface index. - padding: integer; - end; - - PHostEnt = ^THostEnt; - THostEnt = record - h_name: PAnsiChar; - h_aliases: ^PAnsiChar; - h_addrtype: Smallint; - h_length: Smallint; - case integer of - 0: (h_addr_list: ^PAnsiChar); - 1: (h_addr: ^PInAddr); - end; - - PNetEnt = ^TNetEnt; - TNetEnt = record - n_name: PAnsiChar; - n_aliases: ^PAnsiChar; - n_addrtype: Smallint; - n_net: u_long; - end; - - PServEnt = ^TServEnt; - TServEnt = record - s_name: PAnsiChar; - s_aliases: ^PAnsiChar; -{$ifdef WIN64} - s_proto: PAnsiChar; - s_port: Smallint; -{$else} - s_port: Smallint; - s_proto: PAnsiChar; -{$endif} - end; - - PProtoEnt = ^TProtoEnt; - TProtoEnt = record - p_name: PAnsiChar; - p_aliases: ^PAnsichar; - p_proto: Smallint; - end; - -const - INADDR_ANY = $00000000; - INADDR_LOOPBACK = $7F000001; - INADDR_BROADCAST = $FFFFFFFF; - INADDR_NONE = $FFFFFFFF; - ADDR_ANY = INADDR_ANY; - INVALID_SOCKET = TSocket(NOT(0)); - SOCKET_ERROR = -1; - -Const - {$IFDEF WINSOCK1} - IP_OPTIONS = 1; - IP_MULTICAST_IF = 2; { set/get IP multicast interface } - IP_MULTICAST_TTL = 3; { set/get IP multicast timetolive } - IP_MULTICAST_LOOP = 4; { set/get IP multicast loopback } - IP_ADD_MEMBERSHIP = 5; { add an IP group membership } - IP_DROP_MEMBERSHIP = 6; { drop an IP group membership } - IP_TTL = 7; { set/get IP Time To Live } - IP_TOS = 8; { set/get IP Type Of Service } - IP_DONTFRAGMENT = 9; { set/get IP Don't Fragment flag } - {$ELSE} - IP_OPTIONS = 1; - IP_HDRINCL = 2; - IP_TOS = 3; { set/get IP Type Of Service } - IP_TTL = 4; { set/get IP Time To Live } - IP_MULTICAST_IF = 9; { set/get IP multicast interface } - IP_MULTICAST_TTL = 10; { set/get IP multicast timetolive } - IP_MULTICAST_LOOP = 11; { set/get IP multicast loopback } - IP_ADD_MEMBERSHIP = 12; { add an IP group membership } - IP_DROP_MEMBERSHIP = 13; { drop an IP group membership } - IP_DONTFRAGMENT = 14; { set/get IP Don't Fragment flag } - {$ENDIF} - - IP_DEFAULT_MULTICAST_TTL = 1; { normally limit m'casts to 1 hop } - IP_DEFAULT_MULTICAST_LOOP = 1; { normally hear sends if a member } - IP_MAX_MEMBERSHIPS = 20; { per socket; must fit in one mbuf } - - SOL_SOCKET = $ffff; {options for socket level } -{ Option flags per-socket. } - SO_DEBUG = $0001; { turn on debugging info recording } - SO_ACCEPTCONN = $0002; { socket has had listen() } - SO_REUSEADDR = $0004; { allow local address reuse } - SO_KEEPALIVE = $0008; { keep connections alive } - SO_DONTROUTE = $0010; { just use interface addresses } - SO_BROADCAST = $0020; { permit sending of broadcast msgs } - SO_USELOOPBACK = $0040; { bypass hardware when possible } - SO_LINGER = $0080; { linger on close if data present } - SO_OOBINLINE = $0100; { leave received OOB data in line } - SO_DONTLINGER = $ff7f; -{ Additional options. } - SO_SNDBUF = $1001; { send buffer size } - SO_RCVBUF = $1002; { receive buffer size } - SO_SNDLOWAT = $1003; { send low-water mark } - SO_RCVLOWAT = $1004; { receive low-water mark } - SO_SNDTIMEO = $1005; { send timeout } - SO_RCVTIMEO = $1006; { receive timeout } - SO_ERROR = $1007; { get error status and clear } - SO_TYPE = $1008; { get socket type } -{ WinSock 2 extension -- new options } - SO_GROUP_ID = $2001; { ID of a socket group} - SO_GROUP_PRIORITY = $2002; { the relative priority within a group} - SO_MAX_MSG_SIZE = $2003; { maximum message size } - SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure } - SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure } - SO_PROTOCOL_INFO = SO_PROTOCOL_INFOA; - PVD_CONFIG = $3001; {configuration info for service provider } -{ Option for opening sockets for synchronous access. } - SO_OPENTYPE = $7008; - SO_SYNCHRONOUS_ALERT = $10; - SO_SYNCHRONOUS_NONALERT = $20; -{ Other NT-specific options. } - SO_MAXDG = $7009; - SO_MAXPATHDG = $700A; - SO_UPDATE_ACCEPT_CONTEXT = $700B; - SO_CONNECT_TIME = $700C; - - SOMAXCONN = $7fffffff; - - IPV6_UNICAST_HOPS = 8; // ??? - IPV6_MULTICAST_IF = 9; // set/get IP multicast i/f - IPV6_MULTICAST_HOPS = 10; // set/get IP multicast ttl - IPV6_MULTICAST_LOOP = 11; // set/get IP multicast loopback - IPV6_JOIN_GROUP = 12; // add an IP group membership - IPV6_LEAVE_GROUP = 13; // drop an IP group membership - - MSG_NOSIGNAL = 0; - - // getnameinfo constants - NI_MAXHOST = 1025; - NI_MAXSERV = 32; - NI_NOFQDN = $1; - NI_NUMERICHOST = $2; - NI_NAMEREQD = $4; - NI_NUMERICSERV = $8; - NI_DGRAM = $10; - - -const - SOCK_STREAM = 1; { stream socket } - SOCK_DGRAM = 2; { datagram socket } - SOCK_RAW = 3; { raw-protocol interface } - SOCK_RDM = 4; { reliably-delivered message } - SOCK_SEQPACKET = 5; { sequenced packet stream } - -{ TCP options. } - TCP_NODELAY = $0001; - -{ Address families. } - - AF_UNSPEC = 0; { unspecified } - AF_INET = 2; { internetwork: UDP, TCP, etc. } - AF_INET6 = 23; { Internetwork Version 6 } - AF_MAX = 24; - -{ Protocol families, same as address families for now. } - PF_UNSPEC = AF_UNSPEC; - PF_INET = AF_INET; - PF_INET6 = AF_INET6; - PF_MAX = AF_MAX; - -type - { Structure used by kernel to store most addresses. } - PSockAddr = ^TSockAddr; - TSockAddr = TSockAddrIn; - - { Structure used by kernel to pass protocol information in raw sockets. } - PSockProto = ^TSockProto; - TSockProto = record - sp_family: u_short; - sp_protocol: u_short; - end; - -type - PAddrInfo = ^TAddrInfo; - TAddrInfo = record - ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST. - ai_family: integer; // PF_xxx. - ai_socktype: integer; // SOCK_xxx. - ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6. - ai_addrlen: u_int; // Length of ai_addr. - ai_canonname: PAnsiChar; // Canonical name for nodename. - ai_addr: PSockAddr; // Binary address. - ai_next: PAddrInfo; // Next structure in linked list. - end; - -const - // Flags used in "hints" argument to getaddrinfo(). - AI_PASSIVE = $1; // Socket address will be used in bind() call. - AI_CANONNAME = $2; // Return canonical name in first ai_canonname. - AI_NUMERICHOST = $4; // Nodename must be a numeric address string. - -type -{ Structure used for manipulating linger option. } - PLinger = ^TLinger; - TLinger = record - l_onoff: u_short; - l_linger: u_short; - end; - -const - - MSG_OOB = $01; // Process out-of-band data. - MSG_PEEK = $02; // Peek at incoming messages. - -const - -{ All Windows Sockets error constants are biased by WSABASEERR from the "normal" } - WSABASEERR = 10000; - -{ Windows Sockets definitions of regular Microsoft C error constants } - - WSAEINTR = (WSABASEERR+4); - WSAEBADF = (WSABASEERR+9); - WSAEACCES = (WSABASEERR+13); - WSAEFAULT = (WSABASEERR+14); - WSAEINVAL = (WSABASEERR+22); - WSAEMFILE = (WSABASEERR+24); - -{ Windows Sockets definitions of regular Berkeley error constants } - - WSAEWOULDBLOCK = (WSABASEERR+35); - WSAEINPROGRESS = (WSABASEERR+36); - WSAEALREADY = (WSABASEERR+37); - WSAENOTSOCK = (WSABASEERR+38); - WSAEDESTADDRREQ = (WSABASEERR+39); - WSAEMSGSIZE = (WSABASEERR+40); - WSAEPROTOTYPE = (WSABASEERR+41); - WSAENOPROTOOPT = (WSABASEERR+42); - WSAEPROTONOSUPPORT = (WSABASEERR+43); - WSAESOCKTNOSUPPORT = (WSABASEERR+44); - WSAEOPNOTSUPP = (WSABASEERR+45); - WSAEPFNOSUPPORT = (WSABASEERR+46); - WSAEAFNOSUPPORT = (WSABASEERR+47); - WSAEADDRINUSE = (WSABASEERR+48); - WSAEADDRNOTAVAIL = (WSABASEERR+49); - WSAENETDOWN = (WSABASEERR+50); - WSAENETUNREACH = (WSABASEERR+51); - WSAENETRESET = (WSABASEERR+52); - WSAECONNABORTED = (WSABASEERR+53); - WSAECONNRESET = (WSABASEERR+54); - WSAENOBUFS = (WSABASEERR+55); - WSAEISCONN = (WSABASEERR+56); - WSAENOTCONN = (WSABASEERR+57); - WSAESHUTDOWN = (WSABASEERR+58); - WSAETOOMANYREFS = (WSABASEERR+59); - WSAETIMEDOUT = (WSABASEERR+60); - WSAECONNREFUSED = (WSABASEERR+61); - WSAELOOP = (WSABASEERR+62); - WSAENAMETOOLONG = (WSABASEERR+63); - WSAEHOSTDOWN = (WSABASEERR+64); - WSAEHOSTUNREACH = (WSABASEERR+65); - WSAENOTEMPTY = (WSABASEERR+66); - WSAEPROCLIM = (WSABASEERR+67); - WSAEUSERS = (WSABASEERR+68); - WSAEDQUOT = (WSABASEERR+69); - WSAESTALE = (WSABASEERR+70); - WSAEREMOTE = (WSABASEERR+71); - -{ Extended Windows Sockets error constant definitions } - - WSASYSNOTREADY = (WSABASEERR+91); - WSAVERNOTSUPPORTED = (WSABASEERR+92); - WSANOTINITIALISED = (WSABASEERR+93); - WSAEDISCON = (WSABASEERR+101); - WSAENOMORE = (WSABASEERR+102); - WSAECANCELLED = (WSABASEERR+103); - WSAEEINVALIDPROCTABLE = (WSABASEERR+104); - WSAEINVALIDPROVIDER = (WSABASEERR+105); - WSAEPROVIDERFAILEDINIT = (WSABASEERR+106); - WSASYSCALLFAILURE = (WSABASEERR+107); - WSASERVICE_NOT_FOUND = (WSABASEERR+108); - WSATYPE_NOT_FOUND = (WSABASEERR+109); - WSA_E_NO_MORE = (WSABASEERR+110); - WSA_E_CANCELLED = (WSABASEERR+111); - WSAEREFUSED = (WSABASEERR+112); - -{ Error return codes from gethostbyname() and gethostbyaddr() - (when using the resolver). Note that these errors are - retrieved via WSAGetLastError() and must therefore follow - the rules for avoiding clashes with error numbers from - specific implementations or language run-time systems. - For this reason the codes are based at WSABASEERR+1001. - Note also that [WSA]NO_ADDRESS is defined only for - compatibility purposes. } - -{ Authoritative Answer: Host not found } - WSAHOST_NOT_FOUND = (WSABASEERR+1001); - HOST_NOT_FOUND = WSAHOST_NOT_FOUND; -{ Non-Authoritative: Host not found, or SERVERFAIL } - WSATRY_AGAIN = (WSABASEERR+1002); - TRY_AGAIN = WSATRY_AGAIN; -{ Non recoverable errors, FORMERR, REFUSED, NOTIMP } - WSANO_RECOVERY = (WSABASEERR+1003); - NO_RECOVERY = WSANO_RECOVERY; -{ Valid name, no data record of requested type } - WSANO_DATA = (WSABASEERR+1004); - NO_DATA = WSANO_DATA; -{ no address, look for MX record } - WSANO_ADDRESS = WSANO_DATA; - NO_ADDRESS = WSANO_ADDRESS; - - EWOULDBLOCK = WSAEWOULDBLOCK; - EINPROGRESS = WSAEINPROGRESS; - EALREADY = WSAEALREADY; - ENOTSOCK = WSAENOTSOCK; - EDESTADDRREQ = WSAEDESTADDRREQ; - EMSGSIZE = WSAEMSGSIZE; - EPROTOTYPE = WSAEPROTOTYPE; - ENOPROTOOPT = WSAENOPROTOOPT; - EPROTONOSUPPORT = WSAEPROTONOSUPPORT; - ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT; - EOPNOTSUPP = WSAEOPNOTSUPP; - EPFNOSUPPORT = WSAEPFNOSUPPORT; - EAFNOSUPPORT = WSAEAFNOSUPPORT; - EADDRINUSE = WSAEADDRINUSE; - EADDRNOTAVAIL = WSAEADDRNOTAVAIL; - ENETDOWN = WSAENETDOWN; - ENETUNREACH = WSAENETUNREACH; - ENETRESET = WSAENETRESET; - ECONNABORTED = WSAECONNABORTED; - ECONNRESET = WSAECONNRESET; - ENOBUFS = WSAENOBUFS; - EISCONN = WSAEISCONN; - ENOTCONN = WSAENOTCONN; - ESHUTDOWN = WSAESHUTDOWN; - ETOOMANYREFS = WSAETOOMANYREFS; - ETIMEDOUT = WSAETIMEDOUT; - ECONNREFUSED = WSAECONNREFUSED; - ELOOP = WSAELOOP; - ENAMETOOLONG = WSAENAMETOOLONG; - EHOSTDOWN = WSAEHOSTDOWN; - EHOSTUNREACH = WSAEHOSTUNREACH; - ENOTEMPTY = WSAENOTEMPTY; - EPROCLIM = WSAEPROCLIM; - EUSERS = WSAEUSERS; - EDQUOT = WSAEDQUOT; - ESTALE = WSAESTALE; - EREMOTE = WSAEREMOTE; - - EAI_ADDRFAMILY = 1; // Address family for nodename not supported. - EAI_AGAIN = 2; // Temporary failure in name resolution. - EAI_BADFLAGS = 3; // Invalid value for ai_flags. - EAI_FAIL = 4; // Non-recoverable failure in name resolution. - EAI_FAMILY = 5; // Address family ai_family not supported. - EAI_MEMORY = 6; // Memory allocation failure. - EAI_NODATA = 7; // No address associated with nodename. - EAI_NONAME = 8; // Nodename nor servname provided, or not known. - EAI_SERVICE = 9; // Servname not supported for ai_socktype. - EAI_SOCKTYPE = 10; // Socket type ai_socktype not supported. - EAI_SYSTEM = 11; // System error returned in errno. - -const - WSADESCRIPTION_LEN = 256; - WSASYS_STATUS_LEN = 128; -type - PWSAData = ^TWSAData; - TWSAData = record - wVersion: Word; - wHighVersion: Word; -{$ifdef win64} - iMaxSockets : Word; - iMaxUdpDg : Word; - lpVendorInfo : PAnsiChar; - szDescription : array[0..WSADESCRIPTION_LEN] of AnsiChar; - szSystemStatus : array[0..WSASYS_STATUS_LEN] of AnsiChar; -{$else} - szDescription: array[0..WSADESCRIPTION_LEN] of AnsiChar; - szSystemStatus: array[0..WSASYS_STATUS_LEN] of AnsiChar; - iMaxSockets: Word; - iMaxUdpDg: Word; - lpVendorInfo: PAnsiChar; -{$endif} - end; - - function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; - function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; - function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; - function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; - function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; - function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; - procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); - procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); -var - in6addr_any, in6addr_loopback : TInAddr6; - -procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); -function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; -procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); -procedure FD_ZERO(var FDSet: TFDSet); - -{=============================================================================} - -type - TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer; - stdcall; - TWSACleanup = function: Integer; - stdcall; - TWSAGetLastError = function: Integer; - stdcall; - TGetServByName = function(name, proto: PAnsiChar): PServEnt; - stdcall; - TGetServByPort = function(port: Integer; proto: PAnsiChar): PServEnt; - stdcall; - TGetProtoByName = function(name: PAnsiChar): PProtoEnt; - stdcall; - TGetProtoByNumber = function(proto: Integer): PProtoEnt; - stdcall; - TGetHostByName = function(name: PAnsiChar): PHostEnt; - stdcall; - TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt; - stdcall; - TGetHostName = function(name: PAnsiChar; len: Integer): Integer; - stdcall; - TShutdown = function(s: TSocket; how: Integer): Integer; - stdcall; - TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar; - optlen: Integer): Integer; - stdcall; - TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar; - var optlen: Integer): Integer; - stdcall; - TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; - tolen: Integer): Integer; - stdcall; - TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer; - stdcall; - TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer; - stdcall; - TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; - var fromlen: Integer): Integer; - stdcall; - Tntohs = function(netshort: u_short): u_short; - stdcall; - Tntohl = function(netlong: u_long): u_long; - stdcall; - TListen = function(s: TSocket; backlog: Integer): Integer; - stdcall; - TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: Integer): Integer; - stdcall; - TInet_ntoa = function(inaddr: TInAddr): PAnsiChar; - stdcall; - TInet_addr = function(cp: PAnsiChar): u_long; - stdcall; - Thtons = function(hostshort: u_short): u_short; - stdcall; - Thtonl = function(hostlong: u_long): u_long; - stdcall; - TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; - stdcall; - TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; - stdcall; - TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer; - stdcall; - TCloseSocket = function(s: TSocket): Integer; - stdcall; - TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; - stdcall; - TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; - stdcall; - TTSocket = function(af, Struc, Protocol: Integer): TSocket; - stdcall; - TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; - timeout: PTimeVal): Longint; - stdcall; - - TGetAddrInfo = function(NodeName: PAnsiChar; ServName: PAnsiChar; Hints: PAddrInfo; - var Addrinfo: PAddrInfo): integer; - stdcall; - TFreeAddrInfo = procedure(ai: PAddrInfo); - stdcall; - TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PAnsiChar; - hostlen: DWORD; serv: PAnsiChar; servlen: DWORD; flags: integer): integer; - stdcall; - - T__WSAFDIsSet = function (s: TSocket; var FDSet: TFDSet): Bool; - stdcall; - - TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; - cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; - lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; - lpCompletionRoutine: pointer): u_int; - stdcall; - -var - WSAStartup: TWSAStartup = nil; - WSACleanup: TWSACleanup = nil; - WSAGetLastError: TWSAGetLastError = nil; - GetServByName: TGetServByName = nil; - GetServByPort: TGetServByPort = nil; - GetProtoByName: TGetProtoByName = nil; - GetProtoByNumber: TGetProtoByNumber = nil; - GetHostByName: TGetHostByName = nil; - GetHostByAddr: TGetHostByAddr = nil; - ssGetHostName: TGetHostName = nil; - Shutdown: TShutdown = nil; - SetSockOpt: TSetSockOpt = nil; - GetSockOpt: TGetSockOpt = nil; - ssSendTo: TSendTo = nil; - ssSend: TSend = nil; - ssRecv: TRecv = nil; - ssRecvFrom: TRecvFrom = nil; - ntohs: Tntohs = nil; - ntohl: Tntohl = nil; - Listen: TListen = nil; - IoctlSocket: TIoctlSocket = nil; - Inet_ntoa: TInet_ntoa = nil; - Inet_addr: TInet_addr = nil; - htons: Thtons = nil; - htonl: Thtonl = nil; - ssGetSockName: TGetSockName = nil; - ssGetPeerName: TGetPeerName = nil; - ssConnect: TConnect = nil; - CloseSocket: TCloseSocket = nil; - ssBind: TBind = nil; - ssAccept: TAccept = nil; - Socket: TTSocket = nil; - Select: TSelect = nil; - - GetAddrInfo: TGetAddrInfo = nil; - FreeAddrInfo: TFreeAddrInfo = nil; - GetNameInfo: TGetNameInfo = nil; - - __WSAFDIsSet: T__WSAFDIsSet = nil; - - WSAIoctl: TWSAIoctl = nil; - -var - SynSockCS: SyncObjs.TCriticalSection; - SockEnhancedApi: Boolean; - SockWship6Api: Boolean; - -type - TVarSin = packed record - case integer of - 0: (AddressFamily: u_short); - 1: ( - case sin_family: u_short of - AF_INET: (sin_port: u_short; - sin_addr: TInAddr; - sin_zero: array[0..7] of byte); - AF_INET6: (sin6_port: u_short; - sin6_flowinfo: u_long; - sin6_addr: TInAddr6; - sin6_scope_id: u_long); - ); - end; - -function SizeOfVarSin(sin: TVarSin): integer; - -function Bind(s: TSocket; const addr: TVarSin): Integer; -function Connect(s: TSocket; const name: TVarSin): Integer; -function GetSockName(s: TSocket; var name: TVarSin): Integer; -function GetPeerName(s: TSocket; var name: TVarSin): Integer; -function GetHostName: AnsiString; -function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; -function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; -function Accept(s: TSocket; var addr: TVarSin): TSocket; - -function IsNewApi(Family: integer): Boolean; -function SetVarSin(var Sin: TVarSin; IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -function GetSinIP(Sin: TVarSin): AnsiString; -function GetSinPort(Sin: TVarSin): Integer; -procedure ResolveNameToIP(Name: AnsiString; Family, SockProtocol, SockType: integer; const IPList: TStrings); -function ResolveIPToName(IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString; -function ResolvePort(Port: AnsiString; Family, SockProtocol, SockType: integer): Word; - -{==============================================================================} -implementation - -var - SynSockCount: Integer = 0; - LibHandle: THandle = 0; - Libwship6Handle: THandle = 0; - -function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and - (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); -end; - -function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and - (a^.u6_addr32[2] = 0) and - (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and - (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); -end; - -function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); -end; - -function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); -end; - -function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; -begin - Result := (a^.u6_addr8[0] = $FF); -end; - -function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; -begin - Result := (CompareMem( a, b, sizeof(TInAddr6))); -end; - -procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); -begin - FillChar(a^, sizeof(TInAddr6), 0); -end; - -procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); -begin - FillChar(a^, sizeof(TInAddr6), 0); - a^.u6_addr8[15] := 1; -end; - -{=============================================================================} -procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); -var - I: Integer; -begin - I := 0; - while I < FDSet.fd_count do - begin - if FDSet.fd_array[I] = Socket then - begin - while I < FDSet.fd_count - 1 do - begin - FDSet.fd_array[I] := FDSet.fd_array[I + 1]; - Inc(I); - end; - Dec(FDSet.fd_count); - Break; - end; - Inc(I); - end; -end; - -function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; -begin - Result := __WSAFDIsSet(Socket, FDSet); -end; - -procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); -begin - if FDSet.fd_count < FD_SETSIZE then - begin - FDSet.fd_array[FDSet.fd_count] := Socket; - Inc(FDSet.fd_count); - end; -end; - -procedure FD_ZERO(var FDSet: TFDSet); -begin - FDSet.fd_count := 0; -end; - -{=============================================================================} - -function SizeOfVarSin(sin: TVarSin): integer; -begin - case sin.sin_family of - AF_INET: - Result := SizeOf(TSockAddrIn); - AF_INET6: - Result := SizeOf(TSockAddrIn6); - else - Result := 0; - end; -end; - -{=============================================================================} - -function Bind(s: TSocket; const addr: TVarSin): Integer; -begin - Result := ssBind(s, @addr, SizeOfVarSin(addr)); -end; - -function Connect(s: TSocket; const name: TVarSin): Integer; -begin - Result := ssConnect(s, @name, SizeOfVarSin(name)); -end; - -function GetSockName(s: TSocket; var name: TVarSin): Integer; -var - len: integer; -begin - len := SizeOf(name); - FillChar(name, len, 0); - Result := ssGetSockName(s, @name, Len); -end; - -function GetPeerName(s: TSocket; var name: TVarSin): Integer; -var - len: integer; -begin - len := SizeOf(name); - FillChar(name, len, 0); - Result := ssGetPeerName(s, @name, Len); -end; - -function GetHostName: AnsiString; -var - s: AnsiString; -begin - Result := ''; - setlength(s, 255); - ssGetHostName(pAnsichar(s), Length(s) - 1); - Result := PAnsichar(s); -end; - -function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -begin - Result := ssSend(s, Buf^, len, flags); -end; - -function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -begin - Result := ssRecv(s, Buf^, len, flags); -end; - -function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; -begin - Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto)); -end; - -function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; -var - x: integer; -begin - x := SizeOf(from); - Result := ssRecvFrom(s, Buf^, len, flags, @from, x); -end; - -function Accept(s: TSocket; var addr: TVarSin): TSocket; -var - x: integer; -begin - x := SizeOf(addr); - Result := ssAccept(s, @addr, x); -end; - -{=============================================================================} -function IsNewApi(Family: integer): Boolean; -begin - Result := SockEnhancedApi; - if not Result then - Result := (Family = AF_INET6) and SockWship6Api; -end; - -function SetVarSin(var Sin: TVarSin; IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -type - pu_long = ^u_long; -var - ProtoEnt: PProtoEnt; - ServEnt: PServEnt; - HostEnt: PHostEnt; - r: integer; - Hints1, Hints2: TAddrInfo; - Sin1, Sin2: TVarSin; - TwoPass: boolean; - - function GetAddr(const IP, port: AnsiString; Hints: TAddrInfo; var Sin: TVarSin): integer; - var - Addr: PAddrInfo; - begin - Addr := nil; - try - FillChar(Sin, Sizeof(Sin), 0); - if Hints.ai_socktype = SOCK_RAW then - begin - Hints.ai_socktype := 0; - Hints.ai_protocol := 0; - Result := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr); - end - else - begin - if (IP = cAnyHost) or (IP = c6AnyHost) then - begin - Hints.ai_flags := AI_PASSIVE; - Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); - end - else - if (IP = cLocalhost) or (IP = c6Localhost) then - begin - Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); - end - else - begin - Result := synsock.GetAddrInfo(PAnsiChar(IP), PAnsiChar(Port), @Hints, Addr); - end; - end; - if Result = 0 then - if (Addr <> nil) then - Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen); - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; - -begin - Result := 0; - FillChar(Sin, Sizeof(Sin), 0); - if not IsNewApi(family) then - begin - SynSockCS.Enter; - try - Sin.sin_family := AF_INET; - ProtoEnt := synsock.GetProtoByNumber(SockProtocol); - ServEnt := nil; - if (ProtoEnt <> nil) and (StrToIntDef(string(Port),-1) =-1) then - ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name); - if ServEnt = nil then - Sin.sin_port := synsock.htons(StrToIntDef(string(Port), 0)) - else - Sin.sin_port := ServEnt^.s_port; - if IP = cBroadcast then - Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) - else - begin - Sin.sin_addr.s_addr := synsock.inet_addr(PAnsiChar(IP)); - if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then - begin - HostEnt := synsock.GetHostByName(PAnsiChar(IP)); - Result := synsock.WSAGetLastError; - if HostEnt <> nil then - Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); - end; - end; - finally - SynSockCS.Leave; - end; - end - else - begin - FillChar(Hints1, Sizeof(Hints1), 0); - FillChar(Hints2, Sizeof(Hints2), 0); - TwoPass := False; - if Family = AF_UNSPEC then - begin - if PreferIP4 then - begin - Hints1.ai_family := AF_INET; - Hints2.ai_family := AF_INET6; - TwoPass := True; - end - else - begin - Hints2.ai_family := AF_INET; - Hints1.ai_family := AF_INET6; - TwoPass := True; - end; - end - else - Hints1.ai_family := Family; - - Hints1.ai_socktype := SockType; - Hints1.ai_protocol := SockProtocol; - Hints2.ai_socktype := Hints1.ai_socktype; - Hints2.ai_protocol := Hints1.ai_protocol; - - r := GetAddr(IP, Port, Hints1, Sin1); - Result := r; - sin := sin1; - if r <> 0 then - if TwoPass then - begin - r := GetAddr(IP, Port, Hints2, Sin2); - Result := r; - if r = 0 then - sin := sin2; - end; - end; -end; - -function GetSinIP(Sin: TVarSin): AnsiString; -var - p: PAnsiChar; - host, serv: AnsiString; - hostlen, servlen: integer; - r: integer; -begin - Result := ''; - if not IsNewApi(Sin.AddressFamily) then - begin - p := synsock.inet_ntoa(Sin.sin_addr); - if p <> nil then - Result := p; - end - else - begin - hostlen := NI_MAXHOST; - servlen := NI_MAXSERV; - setlength(host, hostlen); - setlength(serv, servlen); - r := getnameinfo(@sin, SizeOfVarSin(sin), PAnsiChar(host), hostlen, - PAnsiChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); - if r = 0 then - Result := PAnsiChar(host); - end; -end; - -function GetSinPort(Sin: TVarSin): Integer; -begin - if (Sin.sin_family = AF_INET6) then - Result := synsock.ntohs(Sin.sin6_port) - else - Result := synsock.ntohs(Sin.sin_port); -end; - -procedure ResolveNameToIP(Name: AnsiString; Family, SockProtocol, SockType: integer; const IPList: TStrings); -type - TaPInAddr = array[0..250] of PInAddr; - PaPInAddr = ^TaPInAddr; -var - Hints: TAddrInfo; - Addr: PAddrInfo; - AddrNext: PAddrInfo; - r: integer; - host, serv: AnsiString; - hostlen, servlen: integer; - RemoteHost: PHostEnt; - IP: u_long; - PAdrPtr: PaPInAddr; - i: Integer; - s: String; - InAddr: TInAddr; -begin - IPList.Clear; - if not IsNewApi(Family) then - begin - IP := synsock.inet_addr(PAnsiChar(Name)); - if IP = u_long(INADDR_NONE) then - begin - SynSockCS.Enter; - try - RemoteHost := synsock.GetHostByName(PAnsiChar(Name)); - if RemoteHost <> nil then - begin - PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); - i := 0; - while PAdrPtr^[i] <> nil do - begin - InAddr := PAdrPtr^[i]^; - s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1], - InAddr.S_bytes[2], InAddr.S_bytes[3]]); - IPList.Add(s); - Inc(i); - end; - end; - finally - SynSockCS.Leave; - end; - end - else - IPList.Add(string(Name)); - end - else - begin - Addr := nil; - try - FillChar(Hints, Sizeof(Hints), 0); - Hints.ai_family := AF_UNSPEC; - Hints.ai_socktype := SockType; - Hints.ai_protocol := SockProtocol; - Hints.ai_flags := 0; - r := synsock.GetAddrInfo(PAnsiChar(Name), nil, @Hints, Addr); - if r = 0 then - begin - AddrNext := Addr; - while not(AddrNext = nil) do - begin - if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET)) - or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then - begin - hostlen := NI_MAXHOST; - servlen := NI_MAXSERV; - setlength(host, hostlen); - setlength(serv, servlen); - r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen, - PAnsiChar(host), hostlen, PAnsiChar(serv), servlen, - NI_NUMERICHOST + NI_NUMERICSERV); - if r = 0 then - begin - host := PAnsiChar(host); - IPList.Add(string(host)); - end; - end; - AddrNext := AddrNext^.ai_next; - end; - end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; - if IPList.Count = 0 then - IPList.Add(cAnyHost); -end; - -function ResolvePort(Port: AnsiString; Family, SockProtocol, SockType: integer): Word; -var - ProtoEnt: PProtoEnt; - ServEnt: PServEnt; - Hints: TAddrInfo; - Addr: PAddrInfo; - r: integer; -begin - Result := 0; - if not IsNewApi(Family) then - begin - SynSockCS.Enter; - try - ProtoEnt := synsock.GetProtoByNumber(SockProtocol); - ServEnt := nil; - if ProtoEnt <> nil then - ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name); - if ServEnt = nil then - Result := StrToIntDef(string(Port), 0) - else - Result := synsock.htons(ServEnt^.s_port); - finally - SynSockCS.Leave; - end; - end - else - begin - Addr := nil; - try - FillChar(Hints, Sizeof(Hints), 0); - Hints.ai_family := AF_UNSPEC; - Hints.ai_socktype := SockType; - Hints.ai_protocol := Sockprotocol; - Hints.ai_flags := AI_PASSIVE; - r := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); - if (r = 0) and Assigned(Addr) then - begin - if Addr^.ai_family = AF_INET then - Result := synsock.htons(Addr^.ai_addr^.sin_port); - if Addr^.ai_family = AF_INET6 then - Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port); - end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; -end; - -function ResolveIPToName(IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString; -var - Hints: TAddrInfo; - Addr: PAddrInfo; - r: integer; - host, serv: AnsiString; - hostlen, servlen: integer; - RemoteHost: PHostEnt; - IPn: u_long; -begin - Result := IP; - if not IsNewApi(Family) then - begin - IPn := synsock.inet_addr(PAnsiChar(IP)); - if IPn <> u_long(INADDR_NONE) then - begin - SynSockCS.Enter; - try - RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET); - if RemoteHost <> nil then - Result := RemoteHost^.h_name; - finally - SynSockCS.Leave; - end; - end; - end - else - begin - Addr := nil; - try - FillChar(Hints, Sizeof(Hints), 0); - Hints.ai_family := AF_UNSPEC; - Hints.ai_socktype := SockType; - Hints.ai_protocol := SockProtocol; - Hints.ai_flags := 0; - r := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr); - if (r = 0) and Assigned(Addr)then - begin - hostlen := NI_MAXHOST; - servlen := NI_MAXSERV; - setlength(host, hostlen); - setlength(serv, servlen); - r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen, - PAnsiChar(host), hostlen, PAnsiChar(serv), servlen, - NI_NUMERICSERV); - if r = 0 then - Result := PAnsiChar(host); - end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; -end; - -{=============================================================================} - -function InitSocketInterface(stack: String): Boolean; -begin - Result := False; - SockEnhancedApi := False; - if stack = '' then - stack := DLLStackName; - SynSockCS.Enter; - try - if SynSockCount = 0 then - begin - SockEnhancedApi := False; - SockWship6Api := False; - LibHandle := LoadLibrary(PChar(Stack)); - if LibHandle <> 0 then - begin - WSAIoctl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAIoctl'))); - __WSAFDIsSet := GetProcAddress(LibHandle, PAnsiChar(AnsiString('__WSAFDIsSet'))); - CloseSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('closesocket'))); - IoctlSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ioctlsocket'))); - WSAGetLastError := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAGetLastError'))); - WSAStartup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAStartup'))); - WSACleanup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSACleanup'))); - ssAccept := GetProcAddress(LibHandle, PAnsiChar(AnsiString('accept'))); - ssBind := GetProcAddress(LibHandle, PAnsiChar(AnsiString('bind'))); - ssConnect := GetProcAddress(LibHandle, PAnsiChar(AnsiString('connect'))); - ssGetPeerName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getpeername'))); - ssGetSockName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockname'))); - GetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockopt'))); - Htonl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htonl'))); - Htons := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htons'))); - Inet_Addr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_addr'))); - Inet_Ntoa := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_ntoa'))); - Listen := GetProcAddress(LibHandle, PAnsiChar(AnsiString('listen'))); - Ntohl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohl'))); - Ntohs := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohs'))); - ssRecv := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recv'))); - ssRecvFrom := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recvfrom'))); - Select := GetProcAddress(LibHandle, PAnsiChar(AnsiString('select'))); - ssSend := GetProcAddress(LibHandle, PAnsiChar(AnsiString('send'))); - ssSendTo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('sendto'))); - SetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('setsockopt'))); - ShutDown := GetProcAddress(LibHandle, PAnsiChar(AnsiString('shutdown'))); - Socket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('socket'))); - GetHostByAddr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyaddr'))); - GetHostByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyname'))); - GetProtoByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobyname'))); - GetProtoByNumber := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobynumber'))); - GetServByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyname'))); - GetServByPort := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyport'))); - ssGetHostName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostname'))); - -{$IFNDEF FORCEOLDAPI} - GetAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getaddrinfo'))); - FreeAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('freeaddrinfo'))); - GetNameInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getnameinfo'))); - SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) - and Assigned(GetNameInfo); - if not SockEnhancedApi then - begin - LibWship6Handle := LoadLibrary(PChar(DLLWship6)); - if LibWship6Handle <> 0 then - begin - GetAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getaddrinfo'))); - FreeAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('freeaddrinfo'))); - GetNameInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getnameinfo'))); - SockWship6Api := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) - and Assigned(GetNameInfo); - end; - end; -{$ENDIF} - Result := True; - end; - end - else Result := True; - if Result then - Inc(SynSockCount); - finally - SynSockCS.Leave; - end; -end; - -function DestroySocketInterface: Boolean; -begin - SynSockCS.Enter; - try - Dec(SynSockCount); - if SynSockCount < 0 then - SynSockCount := 0; - if SynSockCount = 0 then - begin - if LibHandle <> 0 then - begin - FreeLibrary(libHandle); - LibHandle := 0; - end; - if LibWship6Handle <> 0 then - begin - FreeLibrary(LibWship6Handle); - LibWship6Handle := 0; - end; - end; - finally - SynSockCS.Leave; - end; - Result := True; -end; - -initialization -begin - SynSockCS := SyncObjs.TCriticalSection.Create; - SET_IN6_IF_ADDR_ANY (@in6addr_any); - SET_LOOPBACK_ADDR6 (@in6addr_loopback); -end; - -finalization -begin - SynSockCS.Free; -end; \ No newline at end of file diff --git a/addons/synapse/synachar.pas b/addons/synapse/synachar.pas deleted file mode 100644 index af889f0..0000000 --- a/addons/synapse/synachar.pas +++ /dev/null @@ -1,2035 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 005.002.002 | -|==============================================================================| -| Content: Charset conversion support | -|==============================================================================| -| Copyright (c)1999-2004, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2004. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{: @abstract(Charset conversion support) -This unit contains a routines for lot of charset conversions. - -It using built-in conversion tables or external Iconv library. Iconv is used - when needed conversion is known by Iconv library. When Iconv library is not - found or Iconv not know requested conversion, then are internal routines used - for conversion. (You can disable Iconv support from your program too!) - -Internal routines knows all major charsets for Europe or America. For East-Asian - charsets you must use Iconv library! -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit synachar; - -interface - -uses -{$IFNDEF WIN32} - {$IFNDEF FPC} - Libc, - {$ELSE} - {$IFDEF FPC_USE_LIBC} - Libc, - {$ENDIF} - {$ENDIF} -{$ELSE} - Windows, -{$ENDIF} - SysUtils, - synautil, synacode, synaicnv; - -type - {:Type with all supported charsets.} - TMimeChar = (ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5, - ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10, ISO_8859_13, - ISO_8859_14, ISO_8859_15, CP1250, CP1251, CP1252, CP1253, CP1254, CP1255, - CP1256, CP1257, CP1258, KOI8_R, CP895, CP852, UCS_2, UCS_4, UTF_8, UTF_7, - UTF_7mod, UCS_2LE, UCS_4LE, - //next is supported by Iconv only... - UTF_16, UTF_16LE, UTF_32, UTF_32LE, C99, JAVA, ISO_8859_16, KOI8_U, KOI8_RU, - CP862, CP866, MAC, MACCE, MACICE, MACCRO, MACRO, MACCYR, MACUK, MACGR, MACTU, - MACHEB, MACAR, MACTH, ROMAN8, NEXTSTEP, ARMASCII, GEORGIAN_AC, GEORGIAN_PS, - KOI8_T, MULELAO, CP1133, TIS620, CP874, VISCII, TCVN, ISO_IR_14, JIS_X0201, - JIS_X0208, JIS_X0212, GB1988_80, GB2312_80, ISO_IR_165, ISO_IR_149, EUC_JP, - SHIFT_JIS, CP932, ISO_2022_JP, ISO_2022_JP1, ISO_2022_JP2, GB2312, CP936, - GB18030, ISO_2022_CN, ISO_2022_CNE, HZ, EUC_TW, BIG5, CP950, BIG5_HKSCS, - EUC_KR, CP949, CP1361, ISO_2022_KR, CP737, CP775, CP853, CP855, CP857, - CP858, CP860, CP861, CP863, CP864, CP865, CP869, CP1125); - - {:Set of any charsets.} - TMimeSetChar = set of TMimeChar; - -const - {:Set of charsets supported by Iconv library only.} - IconvOnlyChars: set of TMimeChar = [UTF_16, UTF_16LE, UTF_32, UTF_32LE, - C99, JAVA, ISO_8859_16, KOI8_U, KOI8_RU, CP862, CP866, MAC, MACCE, MACICE, - MACCRO, MACRO, MACCYR, MACUK, MACGR, MACTU, MACHEB, MACAR, MACTH, ROMAN8, - NEXTSTEP, ARMASCII, GEORGIAN_AC, GEORGIAN_PS, KOI8_T, MULELAO, CP1133, - TIS620, CP874, VISCII, TCVN, ISO_IR_14, JIS_X0201, JIS_X0208, JIS_X0212, - GB1988_80, GB2312_80, ISO_IR_165, ISO_IR_149, EUC_JP, SHIFT_JIS, CP932, - ISO_2022_JP, ISO_2022_JP1, ISO_2022_JP2, GB2312, CP936, GB18030, - ISO_2022_CN, ISO_2022_CNE, HZ, EUC_TW, BIG5, CP950, BIG5_HKSCS, EUC_KR, - CP949, CP1361, ISO_2022_KR, CP737, CP775, CP853, CP855, CP857, CP858, - CP860, CP861, CP863, CP864, CP865, CP869, CP1125]; - - {:Set of charsets supported by internal routines only.} - NoIconvChars: set of TMimeChar = [CP895, UTF_7mod]; - - {:null character replace table. (Usable for disable charater replacing.)} - Replace_None: array[0..0] of Word = - (0); - - {:Character replace table for remove Czech diakritics.} - Replace_Czech: array[0..59] of Word = - ( - $00E1, $0061, - $010D, $0063, - $010F, $0064, - $010E, $0044, - $00E9, $0065, - $011B, $0065, - $00ED, $0069, - $0148, $006E, - $00F3, $006F, - $0159, $0072, - $0161, $0073, - $0165, $0074, - $00FA, $0075, - $016F, $0075, - $00FD, $0079, - $017E, $007A, - $00C1, $0041, - $010C, $0043, - $00C9, $0045, - $011A, $0045, - $00CD, $0049, - $0147, $004E, - $00D3, $004F, - $0158, $0052, - $0160, $0053, - $0164, $0054, - $00DA, $0055, - $016E, $0055, - $00DD, $0059, - $017D, $005A - ); - -var - {:By this you can generally disable/enable Iconv support.} - DisableIconv: Boolean = False; - - {:Default set of charsets for @link(IdealCharsetCoding) function.} - IdealCharsets: TMimeSetChar = - [ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5, - ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10, - KOI8_R, KOI8_U - {$IFNDEF CIL} //error URW778 ??? :-O - , GB2312, EUC_KR, ISO_2022_JP, EUC_TW - {$ENDIF} - ]; - -{==============================================================================} -{:Convert Value from one charset to another. See: @link(CharsetConversionEx)} -function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar; - CharTo: TMimeChar): AnsiString; - -{:Convert Value from one charset to another with additional character conversion. -see: @link(Replace_None) and @link(Replace_Czech)} -function CharsetConversionEx(const Value: AnsiString; CharFrom: TMimeChar; - CharTo: TMimeChar; const TransformTable: array of Word): AnsiString; - -{:Convert Value from one charset to another with additional character conversion. - This funtion is similar to @link(CharsetConversionEx), but you can disable - transliteration of unconvertible characters.} -function CharsetConversionTrans(Value: AnsiString; CharFrom: TMimeChar; - CharTo: TMimeChar; const TransformTable: array of Word; Translit: Boolean): AnsiString; - -{:Returns charset used by operating system.} -function GetCurCP: TMimeChar; - -{:Returns charset used by operating system as OEM charset. (in Windows DOS box, - for example)} -function GetCurOEMCP: TMimeChar; - -{:Converting string with charset name to TMimeChar.} -function GetCPFromID(Value: AnsiString): TMimeChar; - -{:Converting TMimeChar to string with name of charset.} -function GetIDFromCP(Value: TMimeChar): AnsiString; - -{:return @true when value need to be converted. (It is not 7-bit ASCII)} -function NeedCharsetConversion(const Value: AnsiString): Boolean; - -{:Finding best target charset from set of TMimeChars with minimal count of - unconvertible characters.} -function IdealCharsetCoding(const Value: AnsiString; CharFrom: TMimeChar; - CharTo: TMimeSetChar): TMimeChar; - -{:Return BOM (Byte Order Mark) for given unicode charset.} -function GetBOM(Value: TMimeChar): AnsiString; - -{:Convert binary string with unicode content to WideString.} -function StringToWide(const Value: AnsiString): WideString; - -{:Convert WideString to binary string with unicode content.} -function WideToString(const Value: WideString): AnsiString; - -{==============================================================================} -implementation - -//character transcoding tables X to UCS-2 -{ -//dummy table -$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, -$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, -$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, -$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, -$00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, -$00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, -$00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, -$00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, -$00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, -$00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, -$00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, -$00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, -$00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, -$00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, -$00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, -$00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF -} - -const - -{Latin-1 - Danish, Dutch, English, Faeroese, Finnish, French, German, Icelandic, - Irish, Italian, Norwegian, Portuguese, Spanish and Swedish. -} - CharISO_8859_1: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, - $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, - $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, - $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, - $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, - $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, - $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF - ); - -{Latin-2 - Albanian, Czech, English, German, Hungarian, Polish, Rumanian, - Serbo-Croatian, Slovak, Slovene and Swedish. -} - CharISO_8859_2: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $0104, $02D8, $0141, $00A4, $013D, $015A, $00A7, - $00A8, $0160, $015E, $0164, $0179, $00AD, $017D, $017B, - $00B0, $0105, $02DB, $0142, $00B4, $013E, $015B, $02C7, - $00B8, $0161, $015F, $0165, $017A, $02DD, $017E, $017C, - $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7, - $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E, - $0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7, - $0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF, - $0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7, - $010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F, - $0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7, - $0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9 - ); - -{Latin-3 - Afrikaans, Catalan, English, Esperanto, French, Galician, - German, Italian, Maltese and Turkish. -} - CharISO_8859_3: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $0126, $02D8, $00A3, $00A4, $FFFD, $0124, $00A7, - $00A8, $0130, $015E, $011E, $0134, $00AD, $FFFD, $017B, - $00B0, $0127, $00B2, $00B3, $00B4, $00B5, $0125, $00B7, - $00B8, $0131, $015F, $011F, $0135, $00BD, $FFFD, $017C, - $00C0, $00C1, $00C2, $FFFD, $00C4, $010A, $0108, $00C7, - $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $FFFD, $00D1, $00D2, $00D3, $00D4, $0120, $00D6, $00D7, - $011C, $00D9, $00DA, $00DB, $00DC, $016C, $015C, $00DF, - $00E0, $00E1, $00E2, $FFFD, $00E4, $010B, $0109, $00E7, - $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, - $FFFD, $00F1, $00F2, $00F3, $00F4, $0121, $00F6, $00F7, - $011D, $00F9, $00FA, $00FB, $00FC, $016D, $015D, $02D9 - ); - -{Latin-4 - Danish, English, Estonian, Finnish, German, Greenlandic, - Lappish, Latvian, Lithuanian, Norwegian and Swedish. -} - CharISO_8859_4: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $0104, $0138, $0156, $00A4, $0128, $013B, $00A7, - $00A8, $0160, $0112, $0122, $0166, $00AD, $017D, $00AF, - $00B0, $0105, $02DB, $0157, $00B4, $0129, $013C, $02C7, - $00B8, $0161, $0113, $0123, $0167, $014A, $017E, $014B, - $0100, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $012E, - $010C, $00C9, $0118, $00CB, $0116, $00CD, $00CE, $012A, - $0110, $0145, $014C, $0136, $00D4, $00D5, $00D6, $00D7, - $00D8, $0172, $00DA, $00DB, $00DC, $0168, $016A, $00DF, - $0101, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $012F, - $010D, $00E9, $0119, $00EB, $0117, $00ED, $00EE, $012B, - $0111, $0146, $014D, $0137, $00F4, $00F5, $00F6, $00F7, - $00F8, $0173, $00FA, $00FB, $00FC, $0169, $016B, $02D9 - ); - -{CYRILLIC - Bulgarian, Bielorussian, English, Macedonian, Russian, - Serbo-Croatian and Ukrainian. -} - CharISO_8859_5: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $0401, $0402, $0403, $0404, $0405, $0406, $0407, - $0408, $0409, $040A, $040B, $040C, $00AD, $040E, $040F, - $0410, $0411, $0412, $0413, $0414, $0415, $0416, $0417, - $0418, $0419, $041A, $041B, $041C, $041D, $041E, $041F, - $0420, $0421, $0422, $0423, $0424, $0425, $0426, $0427, - $0428, $0429, $042A, $042B, $042C, $042D, $042E, $042F, - $0430, $0431, $0432, $0433, $0434, $0435, $0436, $0437, - $0438, $0439, $043A, $043B, $043C, $043D, $043E, $043F, - $0440, $0441, $0442, $0443, $0444, $0445, $0446, $0447, - $0448, $0449, $044A, $044B, $044C, $044D, $044E, $044F, - $2116, $0451, $0452, $0453, $0454, $0455, $0456, $0457, - $0458, $0459, $045A, $045B, $045C, $00A7, $045E, $045F - ); - -{ARABIC -} - CharISO_8859_6: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $FFFD, $FFFD, $FFFD, $00A4, $FFFD, $FFFD, $FFFD, - $FFFD, $FFFD, $FFFD, $FFFD, $060C, $00AD, $FFFD, $FFFD, - $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, - $FFFD, $FFFD, $FFFD, $061B, $FFFD, $FFFD, $FFFD, $061F, - $FFFD, $0621, $0622, $0623, $0624, $0625, $0626, $0627, - $0628, $0629, $062A, $062B, $062C, $062D, $062E, $062F, - $0630, $0631, $0632, $0633, $0634, $0635, $0636, $0637, - $0638, $0639, $063A, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, - $0640, $0641, $0642, $0643, $0644, $0645, $0646, $0647, - $0648, $0649, $064A, $064B, $064C, $064D, $064E, $064F, - $0650, $0651, $0652, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, - $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD - ); - -{GREEK -} - CharISO_8859_7: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $2018, $2019, $00A3, $FFFD, $FFFD, $00A6, $00A7, - $00A8, $00A9, $FFFD, $00AB, $00AC, $00AD, $FFFD, $2015, - $00B0, $00B1, $00B2, $00B3, $0384, $0385, $0386, $00B7, - $0388, $0389, $038A, $00BB, $038C, $00BD, $038E, $038F, - $0390, $0391, $0392, $0393, $0394, $0395, $0396, $0397, - $0398, $0399, $039A, $039B, $039C, $039D, $039E, $039F, - $03A0, $03A1, $FFFD, $03A3, $03A4, $03A5, $03A6, $03A7, - $03A8, $03A9, $03AA, $03AB, $03AC, $03AD, $03AE, $03AF, - $03B0, $03B1, $03B2, $03B3, $03B4, $03B5, $03B6, $03B7, - $03B8, $03B9, $03BA, $03BB, $03BC, $03BD, $03BE, $03BF, - $03C0, $03C1, $03C2, $03C3, $03C4, $03C5, $03C6, $03C7, - $03C8, $03C9, $03CA, $03CB, $03CC, $03CD, $03CE, $FFFD - ); - -{HEBREW -} - CharISO_8859_8: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $FFFD, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $00D7, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00B8, $00B9, $00F7, $00BB, $00BC, $00BD, $00BE, $FFFD, - $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, - $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, - $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, - $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $2017, - $05D0, $05D1, $05D2, $05D3, $05D4, $05D5, $05D6, $05D7, - $05D8, $05D9, $05DA, $05DB, $05DC, $05DD, $05DE, $05DF, - $05E0, $05E1, $05E2, $05E3, $05E4, $05E5, $05E6, $05E7, - $05E8, $05E9, $05EA, $FFFD, $FFFD, $200E, $200F, $FFFD - ); - -{Latin-5 - English, Finnish, French, German, Irish, Italian, Norwegian, - Portuguese, Spanish, Swedish and Turkish. -} - CharISO_8859_9: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $0104, $02D8, $0141, $00A4, $013D, $015A, $00A7, - $00A8, $0160, $015E, $0164, $0179, $00AD, $017D, $017B, - $00B0, $0105, $02DB, $0142, $00B4, $013E, $015B, $02C7, - $00B8, $0161, $015F, $0165, $017A, $02DD, $017E, $017C, - $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7, - $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E, - $011E, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, - $00D8, $00D9, $00DA, $00DB, $00DC, $0130, $015E, $00DF, - $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, - $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, - $011F, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $0131, $015F, $00FF - ); - -{Latin-6 - Danish, English, Estonian, Faeroese, Finnish, German, Greenlandic, - Icelandic, Lappish, Latvian, Lithuanian, Norwegian and Swedish. -} - CharISO_8859_10: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $0104, $0112, $0122, $012A, $0128, $0136, $00A7, - $013B, $0110, $0160, $0166, $017D, $00AD, $016A, $014A, - $00B0, $0105, $0113, $0123, $012B, $0129, $0137, $00B7, - $013C, $0111, $0161, $0167, $017E, $2015, $016B, $014B, - $0100, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $012E, - $010C, $00C9, $0118, $00CB, $0116, $00CD, $00CE, $00CF, - $00D0, $0145, $014C, $00D3, $00D4, $00D5, $00D6, $0168, - $00D8, $0172, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, - $0101, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $012F, - $010D, $00E9, $0119, $00EB, $0117, $00ED, $00EE, $00EF, - $00F0, $0146, $014D, $00F3, $00F4, $00F5, $00F6, $0169, - $00F8, $0173, $00FA, $00FB, $00FC, $00FD, $00FE, $0138 - ); - - CharISO_8859_13: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $201D, $00A2, $00A3, $00A4, $201E, $00A6, $00A7, - $00D8, $00A9, $0156, $00AB, $00AC, $00AD, $00AE, $00C6, - $00B0, $00B1, $00B2, $00B3, $201C, $00B5, $00B6, $00B7, - $00F8, $00B9, $0157, $00BB, $00BC, $00BD, $00BE, $00E6, - $0104, $012E, $0100, $0106, $00C4, $00C5, $0118, $0112, - $010C, $00C9, $0179, $0116, $0122, $0136, $012A, $013B, - $0160, $0143, $0145, $00D3, $014C, $00D5, $00D6, $00D7, - $0172, $0141, $015A, $016A, $00DC, $017B, $017D, $00DF, - $0105, $012F, $0101, $0107, $00E4, $00E5, $0119, $0113, - $010D, $00E9, $017A, $0117, $0123, $0137, $012B, $013C, - $0161, $0144, $0146, $00F3, $014D, $00F5, $00F6, $00F7, - $0173, $0142, $015B, $016B, $00FC, $017C, $017E, $2019 - ); - - CharISO_8859_14: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $1E02, $1E03, $00A3, $010A, $010B, $1E0A, $00A7, - $1E80, $00A9, $1E82, $1E0B, $1EF2, $00AD, $00AE, $0178, - $1E1E, $1E1F, $0120, $0121, $1E40, $1E41, $00B6, $1E56, - $1E81, $1E57, $1E83, $1E60, $1EF3, $1E84, $1E85, $1E61, - $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, - $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $0174, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $1E6A, - $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $0176, $00DF, - $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, - $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, - $0175, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $1E6B, - $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $0177, $00FF - ); - - CharISO_8859_15: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $00A1, $00A2, $00A3, $20AC, $00A5, $0160, $00A7, - $0161, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $017D, $00B5, $00B6, $00B7, - $017E, $00B9, $00BA, $00BB, $0152, $0153, $0178, $00BF, - $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, - $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, - $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, - $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, - $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, - $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF - ); - -{Eastern European -} - CharCP_1250: array[128..255] of Word = - ( - $20AC, $FFFD, $201A, $FFFD, $201E, $2026, $2020, $2021, - $FFFD, $2030, $0160, $2039, $015A, $0164, $017D, $0179, - $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $FFFD, $2122, $0161, $203A, $015B, $0165, $017E, $017A, - $00A0, $02C7, $02D8, $0141, $00A4, $0104, $00A6, $00A7, - $00A8, $00A9, $015E, $00AB, $00AC, $00AD, $00AE, $017B, - $00B0, $00B1, $02DB, $0142, $00B4, $00B5, $00B6, $00B7, - $00B8, $0105, $015F, $00BB, $013D, $02DD, $013E, $017C, - $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7, - $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E, - $0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7, - $0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF, - $0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7, - $010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F, - $0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7, - $0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9 - ); - -{Cyrillic -} - CharCP_1251: array[128..255] of Word = - ( - $0402, $0403, $201A, $0453, $201E, $2026, $2020, $2021, - $20AC, $2030, $0409, $2039, $040A, $040C, $040B, $040F, - $0452, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $FFFD, $2122, $0459, $203A, $045A, $045C, $045B, $045F, - $00A0, $040E, $045E, $0408, $00A4, $0490, $00A6, $00A7, - $0401, $00A9, $0404, $00AB, $00AC, $00AD, $00AE, $0407, - $00B0, $00B1, $0406, $0456, $0491, $00B5, $00B6, $00B7, - $0451, $2116, $0454, $00BB, $0458, $0405, $0455, $0457, - $0410, $0411, $0412, $0413, $0414, $0415, $0416, $0417, - $0418, $0419, $041A, $041B, $041C, $041D, $041E, $041F, - $0420, $0421, $0422, $0423, $0424, $0425, $0426, $0427, - $0428, $0429, $042A, $042B, $042C, $042D, $042E, $042F, - $0430, $0431, $0432, $0433, $0434, $0435, $0436, $0437, - $0438, $0439, $043A, $043B, $043C, $043D, $043E, $043F, - $0440, $0441, $0442, $0443, $0444, $0445, $0446, $0447, - $0448, $0449, $044A, $044B, $044C, $044D, $044E, $044F - ); - -{Latin-1 (US, Western Europe) -} - CharCP_1252: array[128..255] of Word = - ( - $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, - $02C6, $2030, $0160, $2039, $0152, $FFFD, $017D, $FFFD, - $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $02DC, $2122, $0161, $203A, $0153, $FFFD, $017E, $0178, - $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, - $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, - $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, - $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, - $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, - $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, - $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF - ); - -{Greek -} - CharCP_1253: array[128..255] of Word = - ( - $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, - $FFFD, $2030, $FFFD, $2039, $FFFD, $FFFD, $FFFD, $FFFD, - $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $FFFD, $2122, $FFFD, $203A, $FFFD, $FFFD, $FFFD, $FFFD, - $00A0, $0385, $0386, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $FFFD, $00AB, $00AC, $00AD, $00AE, $2015, - $00B0, $00B1, $00B2, $00B3, $0384, $00B5, $00B6, $00B7, - $0388, $0389, $038A, $00BB, $038C, $00BD, $038E, $038F, - $0390, $0391, $0392, $0393, $0394, $0395, $0396, $0397, - $0398, $0399, $039A, $039B, $039C, $039D, $039E, $039F, - $03A0, $03A1, $FFFD, $03A3, $03A4, $03A5, $03A6, $03A7, - $03A8, $03A9, $03AA, $03AB, $03AC, $03AD, $03AE, $03AF, - $03B0, $03B1, $03B2, $03B3, $03B4, $03B5, $03B6, $03B7, - $03B8, $03B9, $03BA, $03BB, $03BC, $03BD, $03BE, $03BF, - $03C0, $03C1, $03C2, $03C3, $03C4, $03C5, $03C6, $03C7, - $03C8, $03C9, $03CA, $03CB, $03CC, $03CD, $03CE, $FFFD - ); - -{Turkish -} - CharCP_1254: array[128..255] of Word = - ( - $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, - $02C6, $2030, $0160, $2039, $0152, $FFFD, $FFFD, $FFFD, - $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $02DC, $2122, $0161, $203A, $0153, $FFFD, $FFFD, $0178, - $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, - $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, - $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $011E, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, - $00D8, $00D9, $00DA, $00DB, $00DC, $0130, $015E, $00DF, - $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, - $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, - $011F, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $0131, $015F, $00FF - ); - -{Hebrew -} - CharCP_1255: array[128..255] of Word = - ( - $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, - $02C6, $2030, $FFFD, $2039, $FFFD, $FFFD, $FFFD, $FFFD, - $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $02DC, $2122, $FFFD, $203A, $FFFD, $FFFD, $FFFD, $FFFD, - $00A0, $00A1, $00A2, $00A3, $20AA, $00A5, $00A6, $00A7, - $00A8, $00A9, $00D7, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00B8, $00B9, $00F7, $00BB, $00BC, $00BD, $00BE, $00BF, - $05B0, $05B1, $05B2, $05B3, $05B4, $05B5, $05B6, $05B7, - $05B8, $05B9, $FFFD, $05BB, $05BC, $05BD, $05BE, $05BF, - $05C0, $05C1, $05C2, $05C3, $05F0, $05F1, $05F2, $05F3, - $05F4, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, - $05D0, $05D1, $05D2, $05D3, $05D4, $05D5, $05D6, $05D7, - $05D8, $05D9, $05DA, $05DB, $05DC, $05DD, $05DE, $05DF, - $05E0, $05E1, $05E2, $05E3, $05E4, $05E5, $05E6, $05E7, - $05E8, $05E9, $05EA, $FFFD, $FFFD, $200E, $200F, $FFFD - ); - -{Arabic -} - CharCP_1256: array[128..255] of Word = - ( - $20AC, $067E, $201A, $0192, $201E, $2026, $2020, $2021, - $02C6, $2030, $0679, $2039, $0152, $0686, $0698, $0688, - $06AF, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $06A9, $2122, $0691, $203A, $0153, $200C, $200D, $06BA, - $00A0, $060C, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $06BE, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00B8, $00B9, $061B, $00BB, $00BC, $00BD, $00BE, $061F, - $06C1, $0621, $0622, $0623, $0624, $0625, $0626, $0627, - $0628, $0629, $062A, $062B, $062C, $062D, $062E, $062F, - $0630, $0631, $0632, $0633, $0634, $0635, $0636, $00D7, - $0637, $0638, $0639, $063A, $0640, $0641, $0642, $0643, - $00E0, $0644, $00E2, $0645, $0646, $0647, $0648, $00E7, - $00E8, $00E9, $00EA, $00EB, $0649, $064A, $00EE, $00EF, - $064B, $064C, $064D, $064E, $00F4, $064F, $0650, $00F7, - $0651, $00F9, $0652, $00FB, $00FC, $200E, $200F, $06D2 - ); - -{Baltic -} - CharCP_1257: array[128..255] of Word = - ( - $20AC, $FFFD, $201A, $FFFD, $201E, $2026, $2020, $2021, - $FFFD, $2030, $FFFD, $2039, $FFFD, $00A8, $02C7, $00B8, - $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $FFFD, $2122, $FFFD, $203A, $FFFD, $00AF, $02DB, $FFFD, - $00A0, $FFFD, $00A2, $00A3, $00A4, $FFFD, $00A6, $00A7, - $00D8, $00A9, $0156, $00AB, $00AC, $00AD, $00AE, $00C6, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00F8, $00B9, $0157, $00BB, $00BC, $00BD, $00BE, $00E6, - $0104, $012E, $0100, $0106, $00C4, $00C5, $0118, $0112, - $010C, $00C9, $0179, $0116, $0122, $0136, $012A, $013B, - $0160, $0143, $0145, $00D3, $014C, $00D5, $00D6, $00D7, - $0172, $0141, $015A, $016A, $00DC, $017B, $017D, $00DF, - $0105, $012F, $0101, $0107, $00E4, $00E5, $0119, $0113, - $010D, $00E9, $017A, $0117, $0123, $0137, $012B, $013C, - $0161, $0144, $0146, $00F3, $014D, $00F5, $00F6, $00F7, - $0173, $0142, $015B, $016B, $00FC, $017C, $017E, $02D9 - ); - -{Vietnamese -} - CharCP_1258: array[128..255] of Word = - ( - $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, - $02C6, $2030, $FFFD, $2039, $0152, $FFFD, $FFFD, $FFFD, - $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $02DC, $2122, $FFFD, $203A, $0153, $FFFD, $FFFD, $0178, - $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, - $00C0, $00C1, $00C2, $0102, $00C4, $00C5, $00C6, $00C7, - $00C8, $00C9, $00CA, $00CB, $0300, $00CD, $00CE, $00CF, - $0110, $00D1, $0309, $00D3, $00D4, $01A0, $00D6, $00D7, - $00D8, $00D9, $00DA, $00DB, $00DC, $01AF, $0303, $00DF, - $00E0, $00E1, $00E2, $0103, $00E4, $00E5, $00E6, $00E7, - $00E8, $00E9, $00EA, $00EB, $0301, $00ED, $00EE, $00EF, - $0111, $00F1, $0323, $00F3, $00F4, $01A1, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $01B0, $20AB, $00FF - ); - -{Cyrillic -} - CharKOI8_R: array[128..255] of Word = - ( - $2500, $2502, $250C, $2510, $2514, $2518, $251C, $2524, - $252C, $2534, $253C, $2580, $2584, $2588, $258C, $2590, - $2591, $2592, $2593, $2320, $25A0, $2219, $221A, $2248, - $2264, $2265, $00A0, $2321, $00B0, $00B2, $00B7, $00F7, - $2550, $2551, $2552, $0451, $2553, $2554, $2555, $2556, - $2557, $2558, $2559, $255A, $255B, $255C, $255D, $255E, - $255F, $2560, $2561, $0401, $2562, $2563, $2564, $2565, - $2566, $2567, $2568, $2569, $256A, $256B, $256C, $00A9, - $044E, $0430, $0431, $0446, $0434, $0435, $0444, $0433, - $0445, $0438, $0439, $043A, $043B, $043C, $043D, $043E, - $043F, $044F, $0440, $0441, $0442, $0443, $0436, $0432, - $044C, $044B, $0437, $0448, $044D, $0449, $0447, $044A, - $042E, $0410, $0411, $0426, $0414, $0415, $0424, $0413, - $0425, $0418, $0419, $041A, $041B, $041C, $041D, $041E, - $041F, $042F, $0420, $0421, $0422, $0423, $0416, $0412, - $042C, $042B, $0417, $0428, $042D, $0429, $0427, $042A - ); - -{Czech (Kamenicky) -} - CharCP_895: array[128..255] of Word = - ( - $010C, $00FC, $00E9, $010F, $00E4, $010E, $0164, $010D, - $011B, $011A, $0139, $00CD, $013E, $013A, $00C4, $00C1, - $00C9, $017E, $017D, $00F4, $00F6, $00D3, $016F, $00DA, - $00FD, $00D6, $00DC, $0160, $013D, $00DD, $0158, $0165, - $00E1, $00ED, $00F3, $00FA, $0148, $0147, $016E, $00D4, - $0161, $0159, $0155, $0154, $00BC, $00A7, $00AB, $00BB, - $2591, $2592, $2593, $2502, $2524, $2561, $2562, $2556, - $2555, $2563, $2551, $2557, $255D, $255C, $255B, $2510, - $2514, $2534, $252C, $251C, $2500, $253C, $255E, $255F, - $255A, $2554, $2569, $2566, $2560, $2550, $256C, $2567, - $2568, $2564, $2565, $2559, $2558, $2552, $2553, $256B, - $256A, $2518, $250C, $2588, $2584, $258C, $2590, $2580, - $03B1, $03B2, $0393, $03C0, $03A3, $03C3, $03BC, $03C4, - $03A6, $0398, $03A9, $03B4, $221E, $2205, $03B5, $2229, - $2261, $00B1, $2265, $2264, $2320, $2321, $00F7, $2248, - $2218, $00B7, $2219, $221A, $207F, $00B2, $25A0, $00A0 - ); - -{Eastern European -} - CharCP_852: array[128..255] of Word = - ( - $00C7, $00FC, $00E9, $00E2, $00E4, $016F, $0107, $00E7, - $0142, $00EB, $0150, $0151, $00EE, $0179, $00C4, $0106, - $00C9, $0139, $013A, $00F4, $00F6, $013D, $013E, $015A, - $015B, $00D6, $00DC, $0164, $0165, $0141, $00D7, $010D, - $00E1, $00ED, $00F3, $00FA, $0104, $0105, $017D, $017E, - $0118, $0119, $00AC, $017A, $010C, $015F, $00AB, $00BB, - $2591, $2592, $2593, $2502, $2524, $00C1, $00C2, $011A, - $015E, $2563, $2551, $2557, $255D, $017B, $017C, $2510, - $2514, $2534, $252C, $251C, $2500, $253C, $0102, $0103, - $255A, $2554, $2569, $2566, $2560, $2550, $256C, $00A4, - $0111, $0110, $010E, $00CB, $010F, $0147, $00CD, $00CE, - $011B, $2518, $250C, $2588, $2584, $0162, $016E, $2580, - $00D3, $00DF, $00D4, $0143, $0144, $0148, $0160, $0161, - $0154, $00DA, $0155, $0170, $00FD, $00DD, $0163, $00B4, - $00AD, $02DD, $02DB, $02C7, $02D8, $00A7, $00F7, $00B8, - $00B0, $00A8, $02D9, $0171, $0158, $0159, $25A0, $00A0 - ); - -{==============================================================================} -type - TIconvChar = record - Charset: TMimeChar; - CharName: string; - end; - TIconvArr = array [0..112] of TIconvChar; - -const - NotFoundChar = '_'; - -var - SetTwo: set of TMimeChar = [UCS_2, UCS_2LE, UTF_7, UTF_7mod]; - SetFour: set of TMimeChar = [UCS_4, UCS_4LE, UTF_8]; - SetLE: set of TMimeChar = [UCS_2LE, UCS_4LE]; - - IconvArr: TIconvArr; - -{==============================================================================} -function FindIconvID(const Value, Charname: string): Boolean; -var - s: string; -begin - Result := True; - //exact match - if Value = Charname then - Exit; - //Value is on begin of charname - s := Value + ' '; - if s = Copy(Charname, 1, Length(s)) then - Exit; - //Value is on end of charname - s := ' ' + Value; - if s = Copy(Charname, Length(Charname) - Length(s) + 1, Length(s)) then - Exit; - //value is somewhere inside charname - if Pos( s + ' ', Charname) > 0 then - Exit; - Result := False; -end; - -function GetCPFromIconvID(Value: AnsiString): TMimeChar; -var - n: integer; -begin - Result := ISO_8859_1; - Value := UpperCase(Value); - for n := 0 to High(IconvArr) do - if FindIconvID(Value, IconvArr[n].Charname) then - begin - Result := IconvArr[n].Charset; - Break; - end; -end; - -{==============================================================================} -function GetIconvIDFromCP(Value: TMimeChar): AnsiString; -var - n: integer; -begin - Result := 'ISO-8859-1'; - for n := 0 to High(IconvArr) do - if IconvArr[n].Charset = Value then - begin - Result := Separateleft(IconvArr[n].Charname, ' '); - Break; - end; -end; - -{==============================================================================} -function ReplaceUnicode(Value: Word; const TransformTable: array of Word): Word; -var - n: integer; -begin - if High(TransformTable) <> 0 then - for n := 0 to High(TransformTable) do - if not odd(n) then - if TransformTable[n] = Value then - begin - Value := TransformTable[n+1]; - break; - end; - Result := Value; -end; - -{==============================================================================} -procedure CopyArray(const SourceTable: array of Word; - var TargetTable: array of Word); -var - n: Integer; -begin - for n := 0 to 127 do - TargetTable[n] := SourceTable[n]; -end; - -{==============================================================================} -procedure GetArray(CharSet: TMimeChar; var Result: array of Word); -begin - case CharSet of - ISO_8859_2: - CopyArray(CharISO_8859_2, Result); - ISO_8859_3: - CopyArray(CharISO_8859_3, Result); - ISO_8859_4: - CopyArray(CharISO_8859_4, Result); - ISO_8859_5: - CopyArray(CharISO_8859_5, Result); - ISO_8859_6: - CopyArray(CharISO_8859_6, Result); - ISO_8859_7: - CopyArray(CharISO_8859_7, Result); - ISO_8859_8: - CopyArray(CharISO_8859_8, Result); - ISO_8859_9: - CopyArray(CharISO_8859_9, Result); - ISO_8859_10: - CopyArray(CharISO_8859_10, Result); - ISO_8859_13: - CopyArray(CharISO_8859_13, Result); - ISO_8859_14: - CopyArray(CharISO_8859_14, Result); - ISO_8859_15: - CopyArray(CharISO_8859_15, Result); - CP1250: - CopyArray(CharCP_1250, Result); - CP1251: - CopyArray(CharCP_1251, Result); - CP1252: - CopyArray(CharCP_1252, Result); - CP1253: - CopyArray(CharCP_1253, Result); - CP1254: - CopyArray(CharCP_1254, Result); - CP1255: - CopyArray(CharCP_1255, Result); - CP1256: - CopyArray(CharCP_1256, Result); - CP1257: - CopyArray(CharCP_1257, Result); - CP1258: - CopyArray(CharCP_1258, Result); - KOI8_R: - CopyArray(CharKOI8_R, Result); - CP895: - CopyArray(CharCP_895, Result); - CP852: - CopyArray(CharCP_852, Result); - else - CopyArray(CharISO_8859_1, Result); - end; -end; - -{==============================================================================} -procedure ReadMulti(const Value: AnsiString; var Index: Integer; mb: Byte; - var b1, b2, b3, b4: Byte; le: boolean); -Begin - b1 := 0; - b2 := 0; - b3 := 0; - b4 := 0; - if Index < 0 then - Index := 1; - if mb > 4 then - mb := 1; - if (Index + mb - 1) <= Length(Value) then - begin - if le then - Case mb Of - 1: - b1 := Ord(Value[Index]); - 2: - Begin - b1 := Ord(Value[Index]); - b2 := Ord(Value[Index + 1]); - End; - 3: - Begin - b1 := Ord(Value[Index]); - b2 := Ord(Value[Index + 1]); - b3 := Ord(Value[Index + 2]); - End; - 4: - Begin - b1 := Ord(Value[Index]); - b2 := Ord(Value[Index + 1]); - b3 := Ord(Value[Index + 2]); - b4 := Ord(Value[Index + 3]); - End; - end - else - Case mb Of - 1: - b1 := Ord(Value[Index]); - 2: - Begin - b2 := Ord(Value[Index]); - b1 := Ord(Value[Index + 1]); - End; - 3: - Begin - b3 := Ord(Value[Index]); - b2 := Ord(Value[Index + 1]); - b1 := Ord(Value[Index + 2]); - End; - 4: - Begin - b4 := Ord(Value[Index]); - b3 := Ord(Value[Index + 1]); - b2 := Ord(Value[Index + 2]); - b1 := Ord(Value[Index + 3]); - End; - end; - end; - Inc(Index, mb); -end; - -{==============================================================================} -function WriteMulti(b1, b2, b3, b4: Byte; mb: Byte; le: boolean): AnsiString; -begin - if mb > 4 then - mb := 1; - SetLength(Result, mb); - if le then - case mb Of - 1: - Result[1] := AnsiChar(b1); - 2: - begin - Result[1] := AnsiChar(b1); - Result[2] := AnsiChar(b2); - end; - 3: - begin - Result[1] := AnsiChar(b1); - Result[2] := AnsiChar(b2); - Result[3] := AnsiChar(b3); - end; - 4: - begin - Result[1] := AnsiChar(b1); - Result[2] := AnsiChar(b2); - Result[3] := AnsiChar(b3); - Result[4] := AnsiChar(b4); - end; - end - else - case mb Of - 1: - Result[1] := AnsiChar(b1); - 2: - begin - Result[2] := AnsiChar(b1); - Result[1] := AnsiChar(b2); - end; - 3: - begin - Result[3] := AnsiChar(b1); - Result[2] := AnsiChar(b2); - Result[1] := AnsiChar(b3); - end; - 4: - begin - Result[4] := AnsiChar(b1); - Result[3] := AnsiChar(b2); - Result[2] := AnsiChar(b3); - Result[1] := AnsiChar(b4); - end; - end; -end; - -{==============================================================================} -function UTF8toUCS4(const Value: AnsiString): AnsiString; -var - n, x, ul, m: Integer; - s: AnsiString; - w1, w2: Word; -begin - Result := ''; - n := 1; - while Length(Value) >= n do - begin - x := Ord(Value[n]); - Inc(n); - if x < 128 then - Result := Result + WriteMulti(x, 0, 0, 0, 4, false) - else - begin - m := 0; - if (x and $E0) = $C0 then - m := $1F; - if (x and $F0) = $E0 then - m := $0F; - if (x and $F8) = $F0 then - m := $07; - if (x and $FC) = $F8 then - m := $03; - if (x and $FE) = $FC then - m := $01; - ul := x and m; - s := IntToBin(ul, 0); - while Length(Value) >= n do - begin - x := Ord(Value[n]); - Inc(n); - if (x and $C0) = $80 then - s := s + IntToBin(x and $3F, 6) - else - begin - Dec(n); - Break; - end; - end; - ul := BinToInt(s); - w1 := ul div 65536; - w2 := ul mod 65536; - Result := Result + WriteMulti(Lo(w2), Hi(w2), Lo(w1), Hi(w1), 4, false); - end; - end; -end; - -{==============================================================================} -function UCS4toUTF8(const Value: AnsiString): AnsiString; -var - s, l, k: AnsiString; - b1, b2, b3, b4: Byte; - n, m, x, y: Integer; - b: Byte; -begin - Result := ''; - n := 1; - while Length(Value) >= n do - begin - ReadMulti(Value, n, 4, b1, b2, b3, b4, false); - if (b2 = 0) and (b3 = 0) and (b4 = 0) and (b1 < 128) then - Result := Result + AnsiChar(b1) - else - begin - x := (b1 + 256 * b2) + (b3 + 256 * b4) * 65536; - l := IntToBin(x, 0); - y := Length(l) div 6; - s := ''; - for m := 1 to y do - begin - k := Copy(l, Length(l) - 5, 6); - l := Copy(l, 1, Length(l) - 6); - b := BinToInt(k) or $80; - s := AnsiChar(b) + s; - end; - b := BinToInt(l); - case y of - 5: - b := b or $FC; - 4: - b := b or $F8; - 3: - b := b or $F0; - 2: - b := b or $E0; - 1: - b := b or $C0; - end; - s := AnsiChar(b) + s; - Result := Result + s; - end; - end; -end; - -{==============================================================================} -function UTF7toUCS2(const Value: AnsiString; Modified: Boolean): AnsiString; -var - n, i: Integer; - c: AnsiChar; - s, t: AnsiString; - shift: AnsiChar; - table: String; -begin - Result := ''; - n := 1; - if modified then - begin - shift := '&'; - table := TableBase64mod; - end - else - begin - shift := '+'; - table := TableBase64; - end; - while Length(Value) >= n do - begin - c := Value[n]; - Inc(n); - if c <> shift then - Result := Result + WriteMulti(Ord(c), 0, 0, 0, 2, false) - else - begin - s := ''; - while Length(Value) >= n do - begin - c := Value[n]; - Inc(n); - if c = '-' then - Break; - if (c = '=') or (Pos(c, table) < 1) then - begin - Dec(n); - Break; - end; - s := s + c; - end; - if s = '' then - s := WriteMulti(Ord(shift), 0, 0, 0, 2, false) - else - begin - if modified then - t := DecodeBase64mod(s) - else - t := DecodeBase64(s); - if not odd(length(t)) then - s := t - else - begin //ill-formed sequence - t := s; - s := WriteMulti(Ord(shift), 0, 0, 0, 2, false); - for i := 1 to length(t) do - s := s + WriteMulti(Ord(t[i]), 0, 0, 0, 2, false); - end; - end; - Result := Result + s; - end; - end; -end; - -{==============================================================================} -function UCS2toUTF7(const Value: AnsiString; Modified: Boolean): AnsiString; -var - s: AnsiString; - b1, b2, b3, b4: Byte; - n, m: Integer; - shift: AnsiChar; -begin - Result := ''; - n := 1; - if modified then - shift := '&' - else - shift := '+'; - while Length(Value) >= n do - begin - ReadMulti(Value, n, 2, b1, b2, b3, b4, false); - if (b2 = 0) and (b1 < 128) then - if AnsiChar(b1) = shift then - Result := Result + shift + '-' - else - Result := Result + AnsiChar(b1) - else - begin - s := AnsiChar(b2) + AnsiChar(b1); - while Length(Value) >= n do - begin - ReadMulti(Value, n, 2, b1, b2, b3, b4, false); - if (b2 = 0) and (b1 < 128) then - begin - Dec(n, 2); - Break; - end; - s := s + AnsiChar(b2) + AnsiChar(b1); - end; - if modified then - s := EncodeBase64mod(s) - else - s := EncodeBase64(s); - m := Pos('=', s); - if m > 0 then - s := Copy(s, 1, m - 1); - Result := Result + shift + s + '-'; - end; - end; -end; - -{==============================================================================} -function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar; - CharTo: TMimeChar): AnsiString; -begin - Result := CharsetConversionEx(Value, CharFrom, CharTo, Replace_None); -end; - -{==============================================================================} -function CharsetConversionEx(const Value: AnsiString; CharFrom: TMimeChar; - CharTo: TMimeChar; const TransformTable: array of Word): AnsiString; -begin - Result := CharsetConversionTrans(Value, CharFrom, CharTo, TransformTable, True); -end; - -{==============================================================================} - -function InternalToUcs(const Value: AnsiString; Charfrom: TMimeChar): AnsiString; -var - uni: Word; - n: Integer; - b1, b2, b3, b4: Byte; - SourceTable: array[128..255] of Word; - mbf: Byte; - lef: Boolean; - s: AnsiString; -begin - if CharFrom = UTF_8 then - s := UTF8toUCS4(Value) - else - if CharFrom = UTF_7 then - s := UTF7toUCS2(Value, False) - else - if CharFrom = UTF_7mod then - s := UTF7toUCS2(Value, True) - else - s := Value; - GetArray(CharFrom, SourceTable); - mbf := 1; - if CharFrom in SetTwo then - mbf := 2; - if CharFrom in SetFour then - mbf := 4; - lef := CharFrom in SetLe; - Result := ''; - n := 1; - while Length(s) >= n do - begin - ReadMulti(s, n, mbf, b1, b2, b3, b4, lef); - //handle BOM - if (b3 = 0) and (b4 = 0) then - begin - if (b1 = $FE) and (b2 = $FF) then - begin - lef := not lef; - continue; - end; - if (b1 = $FF) and (b2 = $FE) then - continue; - end; - if mbf = 1 then - if b1 > 127 then - begin - uni := SourceTable[b1]; - b1 := Lo(uni); - b2 := Hi(uni); - end; - Result := Result + WriteMulti(b1, b2, b3, b4, 2, False); - end; -end; - -function CharsetConversionTrans(Value: AnsiString; CharFrom: TMimeChar; - CharTo: TMimeChar; const TransformTable: array of Word; Translit: Boolean): AnsiString; -var - uni: Word; - n, m: Integer; - b: Byte; - b1, b2, b3, b4: Byte; - TargetTable: array[128..255] of Word; - mbt: Byte; - let: Boolean; - ucsstring, s, t: AnsiString; - cd: iconv_t; - f: Boolean; - NotNeedTransform: Boolean; - FromID, ToID: string; -begin - NotNeedTransform := (High(TransformTable) = 0); - if (CharFrom = CharTo) and NotNeedTransform then - begin - Result := Value; - Exit; - end; - FromID := GetIDFromCP(CharFrom); - ToID := GetIDFromCP(CharTo); - cd := Iconv_t(-1); - //do two-pass conversion. Transform to UCS-2 first. - if not DisableIconv then - cd := SynaIconvOpenIgnore('UCS-2BE', FromID); - try - if cd <> iconv_t(-1) then - SynaIconv(cd, Value, ucsstring) - else - ucsstring := InternalToUcs(Value, CharFrom); - finally - SynaIconvClose(cd); - end; - //here we allways have ucstring with UCS-2 encoding - //second pass... from UCS-2 to target encoding. - if not DisableIconv then - if translit then - cd := SynaIconvOpenTranslit(ToID, 'UCS-2BE') - else - cd := SynaIconvOpenIgnore(ToID, 'UCS-2BE'); - try - if (cd <> iconv_t(-1)) and NotNeedTransform then - begin - if CharTo = UTF_7 then - ucsstring := ucsstring + #0 + '-'; - //when transformtable is not needed and Iconv know target charset, - //do it fast by one call. - SynaIconv(cd, ucsstring, Result); - if CharTo = UTF_7 then - Delete(Result, Length(Result), 1); - end - else - begin - GetArray(CharTo, TargetTable); - mbt := 1; - if CharTo in SetTwo then - mbt := 2; - if CharTo in SetFour then - mbt := 4; - let := CharTo in SetLe; - b3 := 0; - b4 := 0; - Result := ''; - for n:= 0 to (Length(ucsstring) div 2) - 1 do - begin - s := Copy(ucsstring, n * 2 + 1, 2); - b2 := Ord(s[1]); - b1 := Ord(s[2]); - uni := b2 * 256 + b1; - if not NotNeedTransform then - begin - uni := ReplaceUnicode(uni, TransformTable); - b1 := Lo(uni); - b2 := Hi(uni); - s[1] := AnsiChar(b2); - s[2] := AnsiChar(b1); - end; - if cd <> iconv_t(-1) then - begin - if CharTo = UTF_7 then - s := s + #0 + '-'; - SynaIconv(cd, s, t); - if CharTo = UTF_7 then - Delete(t, Length(t), 1); - Result := Result + t; - end - else - begin - f := True; - if mbt = 1 then - if uni > 127 then - begin - f := False; - b := 0; - for m := 128 to 255 do - if TargetTable[m] = uni then - begin - b := m; - f := True; - Break; - end; - b1 := b; - b2 := 0; - end - else - b1 := Lo(uni); - if not f then - if translit then - begin - b1 := Ord(NotFoundChar); - b2 := 0; - f := True; - end; - if f then - Result := Result + WriteMulti(b1, b2, b3, b4, mbt, let) - end; - end; - if cd = iconv_t(-1) then - begin - if CharTo = UTF_7 then - Result := UCS2toUTF7(Result, false); - if CharTo = UTF_7mod then - Result := UCS2toUTF7(Result, true); - if CharTo = UTF_8 then - Result := UCS4toUTF8(Result); - end; - end; - finally - SynaIconvClose(cd); - end; -end; - -{==============================================================================} -{$IFNDEF WIN32} - -function GetCurCP: TMimeChar; -begin - {$IFNDEF FPC} - Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME)); - {$ELSE} - {$IFDEF FPC_USE_LIBC} - Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME)); - {$ELSE} - //How to get system codepage without LIBC? - Result := UTF_8; - {$ENDIF} - {$ENDIF} -end; - -function GetCurOEMCP: TMimeChar; -begin - Result := GetCurCP; -end; - -{$ELSE} - -function CPToMimeChar(Value: Integer): TMimeChar; -begin - case Value of - 437, 850, 20127: - Result := ISO_8859_1; //I know, it is not ideal! - 737: - Result := CP737; - 775: - Result := CP775; - 852: - Result := CP852; - 855: - Result := CP855; - 857: - Result := CP857; - 858: - Result := CP858; - 860: - Result := CP860; - 861: - Result := CP861; - 862: - Result := CP862; - 863: - Result := CP863; - 864: - Result := CP864; - 865: - Result := CP865; - 866: - Result := CP866; - 869: - Result := CP869; - 874: - Result := ISO_8859_15; - 895: - Result := CP895; - 932: - Result := CP932; - 936: - Result := CP936; - 949: - Result := CP949; - 950: - Result := CP950; - 1200: - Result := UCS_2LE; - 1201: - Result := UCS_2; - 1250: - Result := CP1250; - 1251: - Result := CP1251; - 1253: - Result := CP1253; - 1254: - Result := CP1254; - 1255: - Result := CP1255; - 1256: - Result := CP1256; - 1257: - Result := CP1257; - 1258: - Result := CP1258; - 1361: - Result := CP1361; - 10000: - Result := MAC; - 10004: - Result := MACAR; - 10005: - Result := MACHEB; - 10006: - Result := MACGR; - 10007: - Result := MACCYR; - 10010: - Result := MACRO; - 10017: - Result := MACUK; - 10021: - Result := MACTH; - 10029: - Result := MACCE; - 10079: - Result := MACICE; - 10081: - Result := MACTU; - 10082: - Result := MACCRO; - 12000: - Result := UCS_4LE; - 12001: - Result := UCS_4; - 20866: - Result := KOI8_R; - 20932: - Result := JIS_X0208; - 20936: - Result := GB2312; - 21866: - Result := KOI8_U; - 28591: - Result := ISO_8859_1; - 28592: - Result := ISO_8859_2; - 28593: - Result := ISO_8859_3; - 28594: - Result := ISO_8859_4; - 28595: - Result := ISO_8859_5; - 28596, 708: - Result := ISO_8859_6; - 28597: - Result := ISO_8859_7; - 28598, 38598: - Result := ISO_8859_8; - 28599: - Result := ISO_8859_9; - 28605: - Result := ISO_8859_15; - 50220: - Result := ISO_2022_JP; //? ISO 2022 Japanese with no halfwidth Katakana - 50221: - Result := ISO_2022_JP1;//? Japanese with halfwidth Katakana - 50222: - Result := ISO_2022_JP2;//? Japanese JIS X 0201-1989 - 50225: - Result := ISO_2022_KR; - 50227: - Result := ISO_2022_CN;//? ISO 2022 Simplified Chinese - 50229: - Result := ISO_2022_CNE;//? ISO 2022 Traditional Chinese - 51932: - Result := EUC_JP; - 51936: - Result := GB2312; - 51949: - Result := EUC_KR; - 52936: - Result := HZ; - 54936: - Result := GB18030; - 65000: - Result := UTF_7; - 65001: - Result := UTF_8; - 0: - Result := UCS_2LE; - else - Result := CP1252; - end; -end; - -function GetCurCP: TMimeChar; -begin - Result := CPToMimeChar(GetACP); -end; - -function GetCurOEMCP: TMimeChar; -begin - Result := CPToMimeChar(GetOEMCP); -end; -{$ENDIF} - -{==============================================================================} -function NeedCharsetConversion(const Value: AnsiString): Boolean; -var - n: Integer; -begin - Result := False; - for n := 1 to Length(Value) do - if (Ord(Value[n]) > 127) or (Ord(Value[n]) = 0) then - begin - Result := True; - Break; - end; -end; - -{==============================================================================} -function IdealCharsetCoding(const Value: AnsiString; CharFrom: TMimeChar; - CharTo: TMimeSetChar): TMimeChar; -var - n: Integer; - max: Integer; - s, t, u: AnsiString; - CharSet: TMimeChar; -begin - Result := ISO_8859_1; - s := Copy(Value, 1, 1024); //max first 1KB for next procedure - max := 0; - for n := Ord(Low(TMimeChar)) to Ord(High(TMimeChar)) do - begin - CharSet := TMimeChar(n); - if CharSet in CharTo then - begin - t := CharsetConversionTrans(s, CharFrom, CharSet, Replace_None, False); - u := CharsetConversionTrans(t, CharSet, CharFrom, Replace_None, False); - if s = u then - begin - Result := CharSet; - Exit; - end; - if Length(u) > max then - begin - Result := CharSet; - max := Length(u); - end; - end; - end; -end; - -{==============================================================================} -function GetBOM(Value: TMimeChar): AnsiString; -begin - Result := ''; - case Value of - UCS_2: - Result := #$fe + #$ff; - UCS_4: - Result := #$00 + #$00 + #$fe + #$ff; - UCS_2LE: - Result := #$ff + #$fe; - UCS_4LE: - Result := #$ff + #$fe + #$00 + #$00; - UTF_8: - Result := #$ef + #$bb + #$bf; - end; -end; - -{==============================================================================} -function GetCPFromID(Value: AnsiString): TMimeChar; -begin - Value := UpperCase(Value); - if (Pos('KAMENICKY', Value) > 0) or (Pos('895', Value) > 0) then - Result := CP895 - else - if Pos('MUTF-7', Value) > 0 then - Result := UTF_7mod - else - Result := GetCPFromIconvID(Value); -end; - -{==============================================================================} -function GetIDFromCP(Value: TMimeChar): AnsiString; -begin - case Value of - CP895: - Result := 'CP-895'; - UTF_7mod: - Result := 'mUTF-7'; - else - Result := GetIconvIDFromCP(Value); - end; -end; - -{==============================================================================} -function StringToWide(const Value: AnsiString): WideString; -var - n: integer; - x, y: integer; -begin - SetLength(Result, Length(Value) div 2); - for n := 1 to Length(Value) div 2 do - begin - x := Ord(Value[((n-1) * 2) + 1]); - y := Ord(Value[((n-1) * 2) + 2]); - Result[n] := WideChar(x * 256 + y); - end; -end; - -{==============================================================================} -function WideToString(const Value: WideString): AnsiString; -var - n: integer; - x: integer; -begin - SetLength(Result, Length(Value) * 2); - for n := 1 to Length(Value) do - begin - x := Ord(Value[n]); - Result[((n-1) * 2) + 1] := AnsiChar(x div 256); - Result[((n-1) * 2) + 2] := AnsiChar(x mod 256); - end; -end; - -{==============================================================================} -initialization -begin - IconvArr[0].Charset := ISO_8859_1; - IconvArr[0].Charname := 'ISO-8859-1 CP819 IBM819 ISO-IR-100 ISO8859-1 ISO_8859-1 ISO_8859-1:1987 L1 LATIN1 CSISOLATIN1'; - IconvArr[1].Charset := UTF_8; - IconvArr[1].Charname := 'UTF-8'; - IconvArr[2].Charset := UCS_2; - IconvArr[2].Charname := 'ISO-10646-UCS-2 UCS-2 CSUNICODE'; - IconvArr[3].Charset := UCS_2; - IconvArr[3].Charname := 'UCS-2BE UNICODE-1-1 UNICODEBIG CSUNICODE11'; - IconvArr[4].Charset := UCS_2LE; - IconvArr[4].Charname := 'UCS-2LE UNICODELITTLE'; - IconvArr[5].Charset := UCS_4; - IconvArr[5].Charname := 'ISO-10646-UCS-4 UCS-4 CSUCS4'; - IconvArr[6].Charset := UCS_4; - IconvArr[6].Charname := 'UCS-4BE'; - IconvArr[7].Charset := UCS_2LE; - IconvArr[7].Charname := 'UCS-4LE'; - IconvArr[8].Charset := UTF_16; - IconvArr[8].Charname := 'UTF-16'; - IconvArr[9].Charset := UTF_16; - IconvArr[9].Charname := 'UTF-16BE'; - IconvArr[10].Charset := UTF_16LE; - IconvArr[10].Charname := 'UTF-16LE'; - IconvArr[11].Charset := UTF_32; - IconvArr[11].Charname := 'UTF-32'; - IconvArr[12].Charset := UTF_32; - IconvArr[12].Charname := 'UTF-32BE'; - IconvArr[13].Charset := UTF_32; - IconvArr[13].Charname := 'UTF-32LE'; - IconvArr[14].Charset := UTF_7; - IconvArr[14].Charname := 'UNICODE-1-1-UTF-7 UTF-7 CSUNICODE11UTF7'; - IconvArr[15].Charset := C99; - IconvArr[15].Charname := 'C99'; - IconvArr[16].Charset := JAVA; - IconvArr[16].Charname := 'JAVA'; - IconvArr[17].Charset := ISO_8859_1; - IconvArr[17].Charname := 'US-ASCII ANSI_X3.4-1968 ANSI_X3.4-1986 ASCII CP367 IBM367 ISO-IR-6 ISO646-US ISO_646.IRV:1991 US CSASCII'; - IconvArr[18].Charset := ISO_8859_2; - IconvArr[18].Charname := 'ISO-8859-2 ISO-IR-101 ISO8859-2 ISO_8859-2 ISO_8859-2:1987 L2 LATIN2 CSISOLATIN2'; - IconvArr[19].Charset := ISO_8859_3; - IconvArr[19].Charname := 'ISO-8859-3 ISO-IR-109 ISO8859-3 ISO_8859-3 ISO_8859-3:1988 L3 LATIN3 CSISOLATIN3'; - IconvArr[20].Charset := ISO_8859_4; - IconvArr[20].Charname := 'ISO-8859-4 ISO-IR-110 ISO8859-4 ISO_8859-4 ISO_8859-4:1988 L4 LATIN4 CSISOLATIN4'; - IconvArr[21].Charset := ISO_8859_5; - IconvArr[21].Charname := 'ISO-8859-5 CYRILLIC ISO-IR-144 ISO8859-5 ISO_8859-5 ISO_8859-5:1988 CSISOLATINCYRILLIC'; - IconvArr[22].Charset := ISO_8859_6; - IconvArr[22].Charname := 'ISO-8859-6 ARABIC ASMO-708 ECMA-114 ISO-IR-127 ISO8859-6 ISO_8859-6 ISO_8859-6:1987 CSISOLATINARABIC'; - IconvArr[23].Charset := ISO_8859_7; - IconvArr[23].Charname := 'ISO-8859-7 ECMA-118 ELOT_928 GREEK GREEK8 ISO-IR-126 ISO8859-7 ISO_8859-7 ISO_8859-7:1987 CSISOLATINGREEK'; - IconvArr[24].Charset := ISO_8859_8; - IconvArr[24].Charname := 'ISO-8859-8 HEBREW ISO_8859-8 ISO-IR-138 ISO8859-8 ISO_8859-8:1988 CSISOLATINHEBREW ISO-8859-8-I'; - IconvArr[25].Charset := ISO_8859_9; - IconvArr[25].Charname := 'ISO-8859-9 ISO-IR-148 ISO8859-9 ISO_8859-9 ISO_8859-9:1989 L5 LATIN5 CSISOLATIN5'; - IconvArr[26].Charset := ISO_8859_10; - IconvArr[26].Charname := 'ISO-8859-10 ISO-IR-157 ISO8859-10 ISO_8859-10 ISO_8859-10:1992 L6 LATIN6 CSISOLATIN6'; - IconvArr[27].Charset := ISO_8859_13; - IconvArr[27].Charname := 'ISO-8859-13 ISO-IR-179 ISO8859-13 ISO_8859-13 L7 LATIN7'; - IconvArr[28].Charset := ISO_8859_14; - IconvArr[28].Charname := 'ISO-8859-14 ISO-CELTIC ISO-IR-199 ISO8859-14 ISO_8859-14 ISO_8859-14:1998 L8 LATIN8'; - IconvArr[29].Charset := ISO_8859_15; - IconvArr[29].Charname := 'ISO-8859-15 ISO-IR-203 ISO8859-15 ISO_8859-15 ISO_8859-15:1998'; - IconvArr[30].Charset := ISO_8859_16; - IconvArr[30].Charname := 'ISO-8859-16 ISO-IR-226 ISO8859-16 ISO_8859-16 ISO_8859-16:2000'; - IconvArr[31].Charset := KOI8_R; - IconvArr[31].Charname := 'KOI8-R CSKOI8R'; - IconvArr[32].Charset := KOI8_U; - IconvArr[32].Charname := 'KOI8-U'; - IconvArr[33].Charset := KOI8_RU; - IconvArr[33].Charname := 'KOI8-RU'; - IconvArr[34].Charset := CP1250; - IconvArr[34].Charname := 'WINDOWS-1250 CP1250 MS-EE'; - IconvArr[35].Charset := CP1251; - IconvArr[35].Charname := 'WINDOWS-1251 CP1251 MS-CYRL'; - IconvArr[36].Charset := CP1252; - IconvArr[36].Charname := 'WINDOWS-1252 CP1252 MS-ANSI'; - IconvArr[37].Charset := CP1253; - IconvArr[37].Charname := 'WINDOWS-1253 CP1253 MS-GREEK'; - IconvArr[38].Charset := CP1254; - IconvArr[38].Charname := 'WINDOWS-1254 CP1254 MS-TURK'; - IconvArr[39].Charset := CP1255; - IconvArr[39].Charname := 'WINDOWS-1255 CP1255 MS-HEBR'; - IconvArr[40].Charset := CP1256; - IconvArr[40].Charname := 'WINDOWS-1256 CP1256 MS-ARAB'; - IconvArr[41].Charset := CP1257; - IconvArr[41].Charname := 'WINDOWS-1257 CP1257 WINBALTRIM'; - IconvArr[42].Charset := CP1258; - IconvArr[42].Charname := 'WINDOWS-1258 CP1258'; - IconvArr[43].Charset := ISO_8859_1; - IconvArr[43].Charname := '850 CP850 IBM850 CSPC850MULTILINGUAL'; - IconvArr[44].Charset := CP862; - IconvArr[44].Charname := '862 CP862 IBM862 CSPC862LATINHEBREW'; - IconvArr[45].Charset := CP866; - IconvArr[45].Charname := '866 CP866 IBM866 CSIBM866'; - IconvArr[46].Charset := MAC; - IconvArr[46].Charname := 'MAC MACINTOSH MACROMAN CSMACINTOSH'; - IconvArr[47].Charset := MACCE; - IconvArr[47].Charname := 'MACCENTRALEUROPE'; - IconvArr[48].Charset := MACICE; - IconvArr[48].Charname := 'MACICELAND'; - IconvArr[49].Charset := MACCRO; - IconvArr[49].Charname := 'MACCROATIAN'; - IconvArr[50].Charset := MACRO; - IconvArr[50].Charname := 'MACROMANIA'; - IconvArr[51].Charset := MACCYR; - IconvArr[51].Charname := 'MACCYRILLIC'; - IconvArr[52].Charset := MACUK; - IconvArr[52].Charname := 'MACUKRAINE'; - IconvArr[53].Charset := MACGR; - IconvArr[53].Charname := 'MACGREEK'; - IconvArr[54].Charset := MACTU; - IconvArr[54].Charname := 'MACTURKISH'; - IconvArr[55].Charset := MACHEB; - IconvArr[55].Charname := 'MACHEBREW'; - IconvArr[56].Charset := MACAR; - IconvArr[56].Charname := 'MACARABIC'; - IconvArr[57].Charset := MACTH; - IconvArr[57].Charname := 'MACTHAI'; - IconvArr[58].Charset := ROMAN8; - IconvArr[58].Charname := 'HP-ROMAN8 R8 ROMAN8 CSHPROMAN8'; - IconvArr[59].Charset := NEXTSTEP; - IconvArr[59].Charname := 'NEXTSTEP'; - IconvArr[60].Charset := ARMASCII; - IconvArr[60].Charname := 'ARMSCII-8'; - IconvArr[61].Charset := GEORGIAN_AC; - IconvArr[61].Charname := 'GEORGIAN-ACADEMY'; - IconvArr[62].Charset := GEORGIAN_PS; - IconvArr[62].Charname := 'GEORGIAN-PS'; - IconvArr[63].Charset := KOI8_T; - IconvArr[63].Charname := 'KOI8-T'; - IconvArr[64].Charset := MULELAO; - IconvArr[64].Charname := 'MULELAO-1'; - IconvArr[65].Charset := CP1133; - IconvArr[65].Charname := 'CP1133 IBM-CP1133'; - IconvArr[66].Charset := TIS620; - IconvArr[66].Charname := 'TIS-620 ISO-IR-166 TIS620 TIS620-0 TIS620.2529-1 TIS620.2533-0 TIS620.2533-1'; - IconvArr[67].Charset := CP874; - IconvArr[67].Charname := 'CP874 WINDOWS-874'; - IconvArr[68].Charset := VISCII; - IconvArr[68].Charname := 'VISCII VISCII1.1-1 CSVISCII'; - IconvArr[69].Charset := TCVN; - IconvArr[69].Charname := 'TCVN TCVN-5712 TCVN5712-1 TCVN5712-1:1993'; - IconvArr[70].Charset := ISO_IR_14; - IconvArr[70].Charname := 'ISO-IR-14 ISO646-JP JIS_C6220-1969-RO JP CSISO14JISC6220RO'; - IconvArr[71].Charset := JIS_X0201; - IconvArr[71].Charname := 'JISX0201-1976 JIS_X0201 X0201 CSHALFWIDTHKATAKANA'; - IconvArr[72].Charset := JIS_X0208; - IconvArr[72].Charname := 'ISO-IR-87 JIS0208 JIS_C6226-1983 JIS_X0208 JIS_X0208-1983 JIS_X0208-1990 X0208 CSISO87JISX0208'; - IconvArr[73].Charset := JIS_X0212; - IconvArr[73].Charname := 'ISO-IR-159 JIS_X0212 JIS_X0212-1990 JIS_X0212.1990-0 X0212 CSISO159JISX02121990'; - IconvArr[74].Charset := GB1988_80; - IconvArr[74].Charname := 'CN GB_1988-80 ISO-IR-57 ISO646-CN CSISO57GB1988'; - IconvArr[75].Charset := GB2312_80; - IconvArr[75].Charname := 'CHINESE GB_2312-80 ISO-IR-58 CSISO58GB231280'; - IconvArr[76].Charset := ISO_IR_165; - IconvArr[76].Charname := 'CN-GB-ISOIR165 ISO-IR-165'; - IconvArr[77].Charset := ISO_IR_149; - IconvArr[77].Charname := 'ISO-IR-149 KOREAN KSC_5601 KS_C_5601-1987 KS_C_5601-1989 CSKSC56011987'; - IconvArr[78].Charset := EUC_JP; - IconvArr[78].Charname := 'EUC-JP EUCJP EXTENDED_UNIX_CODE_PACKED_FORMAT_FOR_JAPANESE CSEUCPKDFMTJAPANESE'; - IconvArr[79].Charset := SHIFT_JIS; - IconvArr[79].Charname := 'SHIFT-JIS MS_KANJI SHIFT_JIS SJIS CSSHIFTJIS'; - IconvArr[80].Charset := CP932; - IconvArr[80].Charname := 'CP932'; - IconvArr[81].Charset := ISO_2022_JP; - IconvArr[81].Charname := 'ISO-2022-JP CSISO2022JP'; - IconvArr[82].Charset := ISO_2022_JP1; - IconvArr[82].Charname := 'ISO-2022-JP-1'; - IconvArr[83].Charset := ISO_2022_JP2; - IconvArr[83].Charname := 'ISO-2022-JP-2 CSISO2022JP2'; - IconvArr[84].Charset := GB2312; - IconvArr[84].Charname := 'CN-GB EUC-CN EUCCN GB2312 CSGB2312'; - IconvArr[85].Charset := CP936; - IconvArr[85].Charname := 'CP936 GBK'; - IconvArr[86].Charset := GB18030; - IconvArr[86].Charname := 'GB18030'; - IconvArr[87].Charset := ISO_2022_CN; - IconvArr[87].Charname := 'ISO-2022-CN CSISO2022CN'; - IconvArr[88].Charset := ISO_2022_CNE; - IconvArr[88].Charname := 'ISO-2022-CN-EXT'; - IconvArr[89].Charset := HZ; - IconvArr[89].Charname := 'HZ HZ-GB-2312'; - IconvArr[90].Charset := EUC_TW; - IconvArr[90].Charname := 'EUC-TW EUCTW CSEUCTW'; - IconvArr[91].Charset := BIG5; - IconvArr[91].Charname := 'BIG5 BIG-5 BIG-FIVE BIGFIVE CN-BIG5 CSBIG5'; - IconvArr[92].Charset := CP950; - IconvArr[92].Charname := 'CP950'; - IconvArr[93].Charset := BIG5_HKSCS; - IconvArr[93].Charname := 'BIG5-HKSCS BIG5HKSCS'; - IconvArr[94].Charset := EUC_KR; - IconvArr[94].Charname := 'EUC-KR EUCKR CSEUCKR'; - IconvArr[95].Charset := CP949; - IconvArr[95].Charname := 'CP949 UHC'; - IconvArr[96].Charset := CP1361; - IconvArr[96].Charname := 'CP1361 JOHAB'; - IconvArr[97].Charset := ISO_2022_KR; - IconvArr[97].Charname := 'ISO-2022-KR CSISO2022KR'; - IconvArr[98].Charset := ISO_8859_1; - IconvArr[98].Charname := '437 CP437 IBM437 CSPC8CODEPAGE437'; - IconvArr[99].Charset := CP737; - IconvArr[99].Charname := 'CP737'; - IconvArr[100].Charset := CP775; - IconvArr[100].Charname := 'CP775 IBM775 CSPC775BALTIC'; - IconvArr[101].Charset := CP852; - IconvArr[101].Charname := '852 CP852 IBM852 CSPCP852'; - IconvArr[102].Charset := CP853; - IconvArr[102].Charname := 'CP853'; - IconvArr[103].Charset := CP855; - IconvArr[103].Charname := '855 CP855 IBM855 CSIBM855'; - IconvArr[104].Charset := CP857; - IconvArr[104].Charname := '857 CP857 IBM857 CSIBM857'; - IconvArr[105].Charset := CP858; - IconvArr[105].Charname := 'CP858'; - IconvArr[106].Charset := CP860; - IconvArr[106].Charname := '860 CP860 IBM860 CSIBM860'; - IconvArr[107].Charset := CP861; - IconvArr[107].Charname := '861 CP-IS CP861 IBM861 CSIBM861'; - IconvArr[108].Charset := CP863; - IconvArr[108].Charname := '863 CP863 IBM863 CSIBM863'; - IconvArr[109].Charset := CP864; - IconvArr[109].Charname := 'CP864 IBM864 CSIBM864'; - IconvArr[110].Charset := CP865; - IconvArr[110].Charname := '865 CP865 IBM865 CSIBM865'; - IconvArr[111].Charset := CP869; - IconvArr[111].Charname := '869 CP-GR CP869 IBM869 CSIBM869'; - IconvArr[112].Charset := CP1125; - IconvArr[112].Charname := 'CP1125'; -end; - -end. diff --git a/addons/synapse/synacode.pas b/addons/synapse/synacode.pas deleted file mode 100644 index 18c9040..0000000 --- a/addons/synapse/synacode.pas +++ /dev/null @@ -1,1460 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.002.001 | -|==============================================================================| -| Content: Coding and decoding support | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(Various encoding and decoding support)} -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$R-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} - {$WARN SUSPICIOUS_TYPECAST OFF} -{$ENDIF} - -unit synacode; - -interface - -uses - SysUtils; - -type - TSpecials = set of AnsiChar; - -const - - SpecialChar: TSpecials = - ['=', '(', ')', '[', ']', '<', '>', ':', ';', ',', '@', '/', '?', '\', - '"', '_']; - NonAsciiChar: TSpecials = - [#0..#31, #127..#255]; - URLFullSpecialChar: TSpecials = - [';', '/', '?', ':', '@', '=', '&', '#', '+']; - URLSpecialChar: TSpecials = - [#$00..#$20, '_', '<', '>', '"', '%', '{', '}', '|', '\', '^', '~', '[', ']', - '`', #$7F..#$FF]; - TableBase64 = - 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/='; - TableBase64mod = - 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+,='; - TableUU = - '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_'; - TableXX = - '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'; - ReTablebase64 = - #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$3E +#$40 - +#$40 +#$40 +#$3F +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C - +#$3D +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$01 +#$02 +#$03 - +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C +#$0D +#$0E +#$0F - +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$40 +#$40 - +#$40 +#$40 +#$40 +#$40 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 - +#$22 +#$23 +#$24 +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D - +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; - ReTableUU = - #$01 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C - +#$0D +#$0E +#$0F +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 - +#$19 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 - +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D +#$2E +#$2F +#$30 - +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C - +#$3D +#$3E +#$3F +#$00 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 - +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 - +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; - ReTableXX = - #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$40 - +#$01 +#$40 +#$40 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A - +#$0B +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$0C +#$0D +#$0E +#$0F - +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$1A +#$1B - +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 +#$25 +#$40 +#$40 - +#$40 +#$40 +#$40 +#$40 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D - +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 - +#$3A +#$3B +#$3C +#$3D +#$3E +#$3F +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; - -{:Decodes triplet encoding with a given character delimiter. It is used for - decoding quoted-printable or URL encoding.} -function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString; - -{:Decodes a string from quoted printable form. (also decodes triplet sequences - like '=7F')} -function DecodeQuotedPrintable(const Value: AnsiString): AnsiString; - -{:Decodes a string of URL encoding. (also decodes triplet sequences like '%7F')} -function DecodeURL(const Value: AnsiString): AnsiString; - -{:Performs triplet encoding with a given character delimiter. Used for encoding - quoted-printable or URL encoding.} -function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; - Specials: TSpecials): AnsiString; - -{:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar) - are encoded.} -function EncodeQuotedPrintable(const Value: AnsiString): AnsiString; - -{:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar) and - @link(SpecialChar) are encoded.} -function EncodeSafeQuotedPrintable(const Value: AnsiString): AnsiString; - -{:Encodes a string to URL format. Used for encoding data from a form field in - HTTP, etc. (Encodes all critical characters including characters used as URL - delimiters ('/',':', etc.)} -function EncodeURLElement(const Value: AnsiString): AnsiString; - -{:Encodes a string to URL format. Used to encode critical characters in all - URLs.} -function EncodeURL(const Value: AnsiString): AnsiString; - -{:Decode 4to3 encoding with given table. If some element is not found in table, - first item from table is used. This is good for buggy coded items by Microsoft - Outlook. This software sometimes using wrong table for UUcode, where is used - ' ' instead '`'.} -function Decode4to3(const Value, Table: AnsiString): AnsiString; - -{:Decode 4to3 encoding with given REVERSE table. Using this function with -reverse table is much faster then @link(Decode4to3). This function is used -internally for Base64, UU or XX decoding.} -function Decode4to3Ex(const Value, Table: AnsiString): AnsiString; - -{:Encode by system 3to4 (used by Base64, UU coding, etc) by given table.} -function Encode3to4(const Value, Table: AnsiString): AnsiString; - -{:Decode string from base64 format.} -function DecodeBase64(const Value: AnsiString): AnsiString; - -{:Encodes a string to base64 format.} -function EncodeBase64(const Value: AnsiString): AnsiString; - -{:Decode string from modified base64 format. (used in IMAP, for example.)} -function DecodeBase64mod(const Value: AnsiString): AnsiString; - -{:Encodes a string to modified base64 format. (used in IMAP, for example.)} -function EncodeBase64mod(const Value: AnsiString): AnsiString; - -{:Decodes a string from UUcode format.} -function DecodeUU(const Value: AnsiString): AnsiString; - -{:encode UUcode. it encode only datas, you must also add header and footer for - proper encode.} -function EncodeUU(const Value: AnsiString): AnsiString; - -{:Decodes a string from XXcode format.} -function DecodeXX(const Value: AnsiString): AnsiString; - -{:decode line with Yenc code. This code is sometimes used in newsgroups.} -function DecodeYEnc(const Value: AnsiString): AnsiString; - -{:Returns a new CRC32 value after adding a new byte of data.} -function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; - -{:return CRC32 from a value string.} -function Crc32(const Value: AnsiString): Integer; - -{:Returns a new CRC16 value after adding a new byte of data.} -function UpdateCrc16(Value: Byte; Crc16: Word): Word; - -{:return CRC16 from a value string.} -function Crc16(const Value: AnsiString): Word; - -{:Returns a binary string with a RSA-MD5 hashing of "Value" string.} -function MD5(const Value: AnsiString): AnsiString; - -{:Returns a binary string with HMAC-MD5 hash.} -function HMAC_MD5(Text, Key: AnsiString): AnsiString; - -{:Returns a binary string with a RSA-MD5 hashing of string what is constructed - by repeating "value" until length is "Len".} -function MD5LongHash(const Value: AnsiString; Len: integer): AnsiString; - -{:Returns a binary string with a SHA-1 hashing of "Value" string.} -function SHA1(const Value: AnsiString): AnsiString; - -{:Returns a binary string with HMAC-SHA1 hash.} -function HMAC_SHA1(Text, Key: AnsiString): AnsiString; - -{:Returns a binary string with a SHA-1 hashing of string what is constructed - by repeating "value" until length is "Len".} -function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString; - -{:Returns a binary string with a RSA-MD4 hashing of "Value" string.} -function MD4(const Value: AnsiString): AnsiString; - -implementation - -const - - Crc32Tab: array[0..255] of Integer = ( - Integer($00000000), Integer($77073096), Integer($EE0E612C), Integer($990951BA), - Integer($076DC419), Integer($706AF48F), Integer($E963A535), Integer($9E6495A3), - Integer($0EDB8832), Integer($79DCB8A4), Integer($E0D5E91E), Integer($97D2D988), - Integer($09B64C2B), Integer($7EB17CBD), Integer($E7B82D07), Integer($90BF1D91), - Integer($1DB71064), Integer($6AB020F2), Integer($F3B97148), Integer($84BE41DE), - Integer($1ADAD47D), Integer($6DDDE4EB), Integer($F4D4B551), Integer($83D385C7), - Integer($136C9856), Integer($646BA8C0), Integer($FD62F97A), Integer($8A65C9EC), - Integer($14015C4F), Integer($63066CD9), Integer($FA0F3D63), Integer($8D080DF5), - Integer($3B6E20C8), Integer($4C69105E), Integer($D56041E4), Integer($A2677172), - Integer($3C03E4D1), Integer($4B04D447), Integer($D20D85FD), Integer($A50AB56B), - Integer($35B5A8FA), Integer($42B2986C), Integer($DBBBC9D6), Integer($ACBCF940), - Integer($32D86CE3), Integer($45DF5C75), Integer($DCD60DCF), Integer($ABD13D59), - Integer($26D930AC), Integer($51DE003A), Integer($C8D75180), Integer($BFD06116), - Integer($21B4F4B5), Integer($56B3C423), Integer($CFBA9599), Integer($B8BDA50F), - Integer($2802B89E), Integer($5F058808), Integer($C60CD9B2), Integer($B10BE924), - Integer($2F6F7C87), Integer($58684C11), Integer($C1611DAB), Integer($B6662D3D), - Integer($76DC4190), Integer($01DB7106), Integer($98D220BC), Integer($EFD5102A), - Integer($71B18589), Integer($06B6B51F), Integer($9FBFE4A5), Integer($E8B8D433), - Integer($7807C9A2), Integer($0F00F934), Integer($9609A88E), Integer($E10E9818), - Integer($7F6A0DBB), Integer($086D3D2D), Integer($91646C97), Integer($E6635C01), - Integer($6B6B51F4), Integer($1C6C6162), Integer($856530D8), Integer($F262004E), - Integer($6C0695ED), Integer($1B01A57B), Integer($8208F4C1), Integer($F50FC457), - Integer($65B0D9C6), Integer($12B7E950), Integer($8BBEB8EA), Integer($FCB9887C), - Integer($62DD1DDF), Integer($15DA2D49), Integer($8CD37CF3), Integer($FBD44C65), - Integer($4DB26158), Integer($3AB551CE), Integer($A3BC0074), Integer($D4BB30E2), - Integer($4ADFA541), Integer($3DD895D7), Integer($A4D1C46D), Integer($D3D6F4FB), - Integer($4369E96A), Integer($346ED9FC), Integer($AD678846), Integer($DA60B8D0), - Integer($44042D73), Integer($33031DE5), Integer($AA0A4C5F), Integer($DD0D7CC9), - Integer($5005713C), Integer($270241AA), Integer($BE0B1010), Integer($C90C2086), - Integer($5768B525), Integer($206F85B3), Integer($B966D409), Integer($CE61E49F), - Integer($5EDEF90E), Integer($29D9C998), Integer($B0D09822), Integer($C7D7A8B4), - Integer($59B33D17), Integer($2EB40D81), Integer($B7BD5C3B), Integer($C0BA6CAD), - Integer($EDB88320), Integer($9ABFB3B6), Integer($03B6E20C), Integer($74B1D29A), - Integer($EAD54739), Integer($9DD277AF), Integer($04DB2615), Integer($73DC1683), - Integer($E3630B12), Integer($94643B84), Integer($0D6D6A3E), Integer($7A6A5AA8), - Integer($E40ECF0B), Integer($9309FF9D), Integer($0A00AE27), Integer($7D079EB1), - Integer($F00F9344), Integer($8708A3D2), Integer($1E01F268), Integer($6906C2FE), - Integer($F762575D), Integer($806567CB), Integer($196C3671), Integer($6E6B06E7), - Integer($FED41B76), Integer($89D32BE0), Integer($10DA7A5A), Integer($67DD4ACC), - Integer($F9B9DF6F), Integer($8EBEEFF9), Integer($17B7BE43), Integer($60B08ED5), - Integer($D6D6A3E8), Integer($A1D1937E), Integer($38D8C2C4), Integer($4FDFF252), - Integer($D1BB67F1), Integer($A6BC5767), Integer($3FB506DD), Integer($48B2364B), - Integer($D80D2BDA), Integer($AF0A1B4C), Integer($36034AF6), Integer($41047A60), - Integer($DF60EFC3), Integer($A867DF55), Integer($316E8EEF), Integer($4669BE79), - Integer($CB61B38C), Integer($BC66831A), Integer($256FD2A0), Integer($5268E236), - Integer($CC0C7795), Integer($BB0B4703), Integer($220216B9), Integer($5505262F), - Integer($C5BA3BBE), Integer($B2BD0B28), Integer($2BB45A92), Integer($5CB36A04), - Integer($C2D7FFA7), Integer($B5D0CF31), Integer($2CD99E8B), Integer($5BDEAE1D), - Integer($9B64C2B0), Integer($EC63F226), Integer($756AA39C), Integer($026D930A), - Integer($9C0906A9), Integer($EB0E363F), Integer($72076785), Integer($05005713), - Integer($95BF4A82), Integer($E2B87A14), Integer($7BB12BAE), Integer($0CB61B38), - Integer($92D28E9B), Integer($E5D5BE0D), Integer($7CDCEFB7), Integer($0BDBDF21), - Integer($86D3D2D4), Integer($F1D4E242), Integer($68DDB3F8), Integer($1FDA836E), - Integer($81BE16CD), Integer($F6B9265B), Integer($6FB077E1), Integer($18B74777), - Integer($88085AE6), Integer($FF0F6A70), Integer($66063BCA), Integer($11010B5C), - Integer($8F659EFF), Integer($F862AE69), Integer($616BFFD3), Integer($166CCF45), - Integer($A00AE278), Integer($D70DD2EE), Integer($4E048354), Integer($3903B3C2), - Integer($A7672661), Integer($D06016F7), Integer($4969474D), Integer($3E6E77DB), - Integer($AED16A4A), Integer($D9D65ADC), Integer($40DF0B66), Integer($37D83BF0), - Integer($A9BCAE53), Integer($DEBB9EC5), Integer($47B2CF7F), Integer($30B5FFE9), - Integer($BDBDF21C), Integer($CABAC28A), Integer($53B39330), Integer($24B4A3A6), - Integer($BAD03605), Integer($CDD70693), Integer($54DE5729), Integer($23D967BF), - Integer($B3667A2E), Integer($C4614AB8), Integer($5D681B02), Integer($2A6F2B94), - Integer($B40BBE37), Integer($C30C8EA1), Integer($5A05DF1B), Integer($2D02EF8D) - ); - - Crc16Tab: array[0..255] of Word = ( - $0000, $1189, $2312, $329B, $4624, $57AD, $6536, $74BF, - $8C48, $9DC1, $AF5A, $BED3, $CA6C, $DBE5, $E97E, $F8F7, - $1081, $0108, $3393, $221A, $56A5, $472C, $75B7, $643E, - $9CC9, $8D40, $BFDB, $AE52, $DAED, $CB64, $F9FF, $E876, - $2102, $308B, $0210, $1399, $6726, $76AF, $4434, $55BD, - $AD4A, $BCC3, $8E58, $9FD1, $EB6E, $FAE7, $C87C, $D9F5, - $3183, $200A, $1291, $0318, $77A7, $662E, $54B5, $453C, - $BDCB, $AC42, $9ED9, $8F50, $FBEF, $EA66, $D8FD, $C974, - $4204, $538D, $6116, $709F, $0420, $15A9, $2732, $36BB, - $CE4C, $DFC5, $ED5E, $FCD7, $8868, $99E1, $AB7A, $BAF3, - $5285, $430C, $7197, $601E, $14A1, $0528, $37B3, $263A, - $DECD, $CF44, $FDDF, $EC56, $98E9, $8960, $BBFB, $AA72, - $6306, $728F, $4014, $519D, $2522, $34AB, $0630, $17B9, - $EF4E, $FEC7, $CC5C, $DDD5, $A96A, $B8E3, $8A78, $9BF1, - $7387, $620E, $5095, $411C, $35A3, $242A, $16B1, $0738, - $FFCF, $EE46, $DCDD, $CD54, $B9EB, $A862, $9AF9, $8B70, - $8408, $9581, $A71A, $B693, $C22C, $D3A5, $E13E, $F0B7, - $0840, $19C9, $2B52, $3ADB, $4E64, $5FED, $6D76, $7CFF, - $9489, $8500, $B79B, $A612, $D2AD, $C324, $F1BF, $E036, - $18C1, $0948, $3BD3, $2A5A, $5EE5, $4F6C, $7DF7, $6C7E, - $A50A, $B483, $8618, $9791, $E32E, $F2A7, $C03C, $D1B5, - $2942, $38CB, $0A50, $1BD9, $6F66, $7EEF, $4C74, $5DFD, - $B58B, $A402, $9699, $8710, $F3AF, $E226, $D0BD, $C134, - $39C3, $284A, $1AD1, $0B58, $7FE7, $6E6E, $5CF5, $4D7C, - $C60C, $D785, $E51E, $F497, $8028, $91A1, $A33A, $B2B3, - $4A44, $5BCD, $6956, $78DF, $0C60, $1DE9, $2F72, $3EFB, - $D68D, $C704, $F59F, $E416, $90A9, $8120, $B3BB, $A232, - $5AC5, $4B4C, $79D7, $685E, $1CE1, $0D68, $3FF3, $2E7A, - $E70E, $F687, $C41C, $D595, $A12A, $B0A3, $8238, $93B1, - $6B46, $7ACF, $4854, $59DD, $2D62, $3CEB, $0E70, $1FF9, - $F78F, $E606, $D49D, $C514, $B1AB, $A022, $92B9, $8330, - $7BC7, $6A4E, $58D5, $495C, $3DE3, $2C6A, $1EF1, $0F78 - ); - -procedure ArrByteToLong(var ArByte: Array of byte; var ArLong: Array of Integer); -{$IFDEF CIL} -var - n: integer; -{$ENDIF} -begin - if (High(ArByte) + 1) > ((High(ArLong) + 1) * 4) then - Exit; - {$IFDEF CIL} - for n := 0 to ((high(ArByte) + 1) div 4) - 1 do - ArLong[n] := ArByte[n * 4 + 0] - + (ArByte[n * 4 + 1] shl 8) - + (ArByte[n * 4 + 2] shl 16) - + (ArByte[n * 4 + 3] shl 24); - {$ELSE} - Move(ArByte[0], ArLong[0], High(ArByte) + 1); - {$ENDIF} -end; - -procedure ArrLongToByte(var ArLong: Array of Integer; var ArByte: Array of byte); -{$IFDEF CIL} -var - n: integer; -{$ENDIF} -begin - if (High(ArByte) + 1) < ((High(ArLong) + 1) * 4) then - Exit; - {$IFDEF CIL} - for n := 0 to high(ArLong) do - begin - ArByte[n * 4 + 0] := ArLong[n] and $000000FF; - ArByte[n * 4 + 1] := (ArLong[n] shr 8) and $000000FF; - ArByte[n * 4 + 2] := (ArLong[n] shr 16) and $000000FF; - ArByte[n * 4 + 3] := (ArLong[n] shr 24) and $000000FF; - end; - {$ELSE} - Move(ArLong[0], ArByte[0], High(ArByte) + 1); - {$ENDIF} -end; - -type - TMDCtx = record - State: array[0..3] of Integer; - Count: array[0..1] of Integer; - BufAnsiChar: array[0..63] of Byte; - BufLong: array[0..15] of Integer; - end; - TSHA1Ctx= record - Hi, Lo: integer; - Buffer: array[0..63] of byte; - Index: integer; - Hash: array[0..4] of Integer; - HashByte: array[0..19] of byte; - end; - - TMDTransform = procedure(var Buf: array of LongInt; const Data: array of LongInt); - -{==============================================================================} - -function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString; -var - x, l, lv: Integer; - c: AnsiChar; - b: Byte; - bad: Boolean; -begin - lv := Length(Value); - SetLength(Result, lv); - x := 1; - l := 1; - while x <= lv do - begin - c := Value[x]; - Inc(x); - if c <> Delimiter then - begin - Result[l] := c; - Inc(l); - end - else - if x < lv then - begin - Case Value[x] Of - #13: - if (Value[x + 1] = #10) then - Inc(x, 2) - else - Inc(x); - #10: - if (Value[x + 1] = #13) then - Inc(x, 2) - else - Inc(x); - else - begin - bad := False; - Case Value[x] Of - '0'..'9': b := (Byte(Value[x]) - 48) Shl 4; - 'a'..'f', 'A'..'F': b := ((Byte(Value[x]) And 7) + 9) shl 4; - else - begin - b := 0; - bad := True; - end; - end; - Case Value[x + 1] Of - '0'..'9': b := b Or (Byte(Value[x + 1]) - 48); - 'a'..'f', 'A'..'F': b := b Or ((Byte(Value[x + 1]) And 7) + 9); - else - bad := True; - end; - if bad then - begin - Result[l] := c; - Inc(l); - end - else - begin - Inc(x, 2); - Result[l] := AnsiChar(b); - Inc(l); - end; - end; - end; - end - else - break; - end; - Dec(l); - SetLength(Result, l); -end; - -{==============================================================================} - -function DecodeQuotedPrintable(const Value: AnsiString): AnsiString; -begin - Result := DecodeTriplet(Value, '='); -end; - -{==============================================================================} - -function DecodeURL(const Value: AnsiString): AnsiString; -begin - Result := DecodeTriplet(Value, '%'); -end; - -{==============================================================================} - -function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; - Specials: TSpecials): AnsiString; -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 EncodeQuotedPrintable(const Value: AnsiString): AnsiString; -begin - Result := EncodeTriplet(Value, '=', ['='] + NonAsciiChar); -end; - -{==============================================================================} - -function EncodeSafeQuotedPrintable(const Value: AnsiString): AnsiString; -begin - Result := EncodeTriplet(Value, '=', SpecialChar + NonAsciiChar); -end; - -{==============================================================================} - -function EncodeURLElement(const Value: AnsiString): AnsiString; -begin - Result := EncodeTriplet(Value, '%', URLSpecialChar + URLFullSpecialChar); -end; - -{==============================================================================} - -function EncodeURL(const Value: AnsiString): AnsiString; -begin - Result := EncodeTriplet(Value, '%', URLSpecialChar); -end; - -{==============================================================================} - -function Decode4to3(const Value, Table: AnsiString): AnsiString; -var - x, y, n, l: Integer; - d: array[0..3] of Byte; -begin - SetLength(Result, Length(Value)); - x := 1; - l := 1; - while x <= Length(Value) do - begin - for n := 0 to 3 do - begin - if x > Length(Value) then - d[n] := 64 - else - begin - y := Pos(Value[x], Table); - if y < 1 then - y := 1; - d[n] := y - 1; - end; - Inc(x); - end; - Result[l] := AnsiChar((D[0] and $3F) shl 2 + (D[1] and $30) shr 4); - Inc(l); - if d[2] <> 64 then - begin - Result[l] := AnsiChar((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2); - Inc(l); - if d[3] <> 64 then - begin - Result[l] := AnsiChar((D[2] and $03) shl 6 + (D[3] and $3F)); - Inc(l); - end; - end; - end; - Dec(l); - SetLength(Result, l); -end; - -{==============================================================================} -function Decode4to3Ex(const Value, Table: AnsiString): AnsiString; -var - x, y, lv: Integer; - d: integer; - dl: integer; - c: byte; - p: integer; -begin - lv := Length(Value); - SetLength(Result, lv); - x := 1; - dl := 4; - d := 0; - p := 1; - while x <= lv do - begin - y := Ord(Value[x]); - if y in [33..127] then - c := Ord(Table[y - 32]) - else - c := 64; - Inc(x); - if c > 63 then - continue; - d := (d shl 6) or c; - dec(dl); - if dl <> 0 then - continue; - Result[p] := AnsiChar((d shr 16) and $ff); - inc(p); - Result[p] := AnsiChar((d shr 8) and $ff); - inc(p); - Result[p] := AnsiChar(d and $ff); - inc(p); - d := 0; - dl := 4; - end; - case dl of - 1: - begin - d := d shr 2; - Result[p] := AnsiChar((d shr 8) and $ff); - inc(p); - Result[p] := AnsiChar(d and $ff); - inc(p); - end; - 2: - begin - d := d shr 4; - Result[p] := AnsiChar(d and $ff); - inc(p); - end; - end; - SetLength(Result, p - 1); -end; - -{==============================================================================} - -function Encode3to4(const Value, Table: AnsiString): AnsiString; -var - c: Byte; - n, l: Integer; - Count: Integer; - DOut: array[0..3] of Byte; -begin - setlength(Result, ((Length(Value) + 2) div 3) * 4); - l := 1; - Count := 1; - while Count <= Length(Value) do - begin - c := Ord(Value[Count]); - Inc(Count); - DOut[0] := (c and $FC) shr 2; - DOut[1] := (c and $03) shl 4; - if Count <= Length(Value) then - begin - c := Ord(Value[Count]); - Inc(Count); - DOut[1] := DOut[1] + (c and $F0) shr 4; - DOut[2] := (c and $0F) shl 2; - if Count <= Length(Value) then - begin - c := Ord(Value[Count]); - Inc(Count); - DOut[2] := DOut[2] + (c and $C0) shr 6; - DOut[3] := (c and $3F); - end - else - begin - DOut[3] := $40; - end; - end - else - begin - DOut[2] := $40; - DOut[3] := $40; - end; - for n := 0 to 3 do - begin - if (DOut[n] + 1) <= Length(Table) then - begin - Result[l] := Table[DOut[n] + 1]; - Inc(l); - end; - end; - end; - SetLength(Result, l - 1); -end; - -{==============================================================================} - -function DecodeBase64(const Value: AnsiString): AnsiString; -begin - Result := Decode4to3Ex(Value, ReTableBase64); -end; - -{==============================================================================} - -function EncodeBase64(const Value: AnsiString): AnsiString; -begin - Result := Encode3to4(Value, TableBase64); -end; - -{==============================================================================} - -function DecodeBase64mod(const Value: AnsiString): AnsiString; -begin - Result := Decode4to3(Value, TableBase64mod); -end; - -{==============================================================================} - -function EncodeBase64mod(const Value: AnsiString): AnsiString; -begin - Result := Encode3to4(Value, TableBase64mod); -end; - -{==============================================================================} - -function DecodeUU(const Value: AnsiString): AnsiString; -var - s: AnsiString; - uut: AnsiString; - x: Integer; -begin - Result := ''; - uut := TableUU; - s := trim(UpperCase(Value)); - if s = '' then Exit; - if Pos('BEGIN', s) = 1 then - Exit; - if Pos('END', s) = 1 then - Exit; - if Pos('TABLE', s) = 1 then - Exit; //ignore Table yet (set custom UUT) - //begin decoding - x := Pos(Value[1], uut) - 1; - case (x mod 3) of - 0: x :=(x div 3)* 4; - 1: x :=((x div 3) * 4) + 2; - 2: x :=((x div 3) * 4) + 3; - end; - //x - lenght UU line - s := Copy(Value, 2, x); - if s = '' then - Exit; - s := s + StringOfChar(' ', x - length(s)); - Result := Decode4to3(s, uut); -end; - -{==============================================================================} - -function EncodeUU(const Value: AnsiString): AnsiString; -begin - Result := ''; - if Length(Value) < Length(TableUU) then - Result := TableUU[Length(Value) + 1] + Encode3to4(Value, TableUU); -end; - -{==============================================================================} - -function DecodeXX(const Value: AnsiString): AnsiString; -var - s: AnsiString; - x: Integer; -begin - Result := ''; - s := trim(UpperCase(Value)); - if s = '' then - Exit; - if Pos('BEGIN', s) = 1 then - Exit; - if Pos('END', s) = 1 then - Exit; - //begin decoding - x := Pos(Value[1], TableXX) - 1; - case (x mod 3) of - 0: x :=(x div 3)* 4; - 1: x :=((x div 3) * 4) + 2; - 2: x :=((x div 3) * 4) + 3; - end; - //x - lenght XX line - s := Copy(Value, 2, x); - if s = '' then - Exit; - s := s + StringOfChar(' ', x - length(s)); - Result := Decode4to3(s, TableXX); -end; - -{==============================================================================} - -function DecodeYEnc(const Value: AnsiString): AnsiString; -var - C : Byte; - i: integer; -begin - Result := ''; - i := 1; - while i <= Length(Value) do - begin - c := Ord(Value[i]); - Inc(i); - if c = Ord('=') then - begin - c := Ord(Value[i]); - Inc(i); - Dec(c, 64); - end; - Dec(C, 42); - Result := Result + AnsiChar(C); - end; -end; - -{==============================================================================} - -function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; -begin - Result := (Crc32 shr 8) - xor crc32tab[Byte(Value xor (Crc32 and Integer($000000FF)))]; -end; - -{==============================================================================} - -function Crc32(const Value: AnsiString): Integer; -var - n: Integer; -begin - Result := Integer($FFFFFFFF); - for n := 1 to Length(Value) do - Result := UpdateCrc32(Ord(Value[n]), Result); - Result := not Result; -end; - -{==============================================================================} - -function UpdateCrc16(Value: Byte; Crc16: Word): Word; -begin - Result := ((Crc16 shr 8) and $00FF) xor - crc16tab[Byte(Crc16 xor (Word(Value)) and $00FF)]; -end; - -{==============================================================================} - -function Crc16(const Value: AnsiString): Word; -var - n: Integer; -begin - Result := $FFFF; - for n := 1 to Length(Value) do - Result := UpdateCrc16(Ord(Value[n]), Result); -end; - -{==============================================================================} - -procedure MDInit(var MDContext: TMDCtx); -var - n: integer; -begin - MDContext.Count[0] := 0; - MDContext.Count[1] := 0; - for n := 0 to high(MDContext.BufAnsiChar) do - MDContext.BufAnsiChar[n] := 0; - for n := 0 to high(MDContext.BufLong) do - MDContext.BufLong[n] := 0; - MDContext.State[0] := Integer($67452301); - MDContext.State[1] := Integer($EFCDAB89); - MDContext.State[2] := Integer($98BADCFE); - MDContext.State[3] := Integer($10325476); -end; - -procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt); -var - A, B, C, D: LongInt; - - procedure Round1(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); - begin - Inc(W, (Z xor (X and (Y xor Z))) + Data); - W := (W shl S) or (W shr (32 - S)); - Inc(W, X); - end; - - procedure Round2(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); - begin - Inc(W, (Y xor (Z and (X xor Y))) + Data); - W := (W shl S) or (W shr (32 - S)); - Inc(W, X); - end; - - procedure Round3(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); - begin - Inc(W, (X xor Y xor Z) + Data); - W := (W shl S) or (W shr (32 - S)); - Inc(W, X); - end; - - procedure Round4(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); - begin - Inc(W, (Y xor (X or not Z)) + Data); - W := (W shl S) or (W shr (32 - S)); - Inc(W, X); - end; -begin - A := Buf[0]; - B := Buf[1]; - C := Buf[2]; - D := Buf[3]; - - Round1(A, B, C, D, Data[0] + Longint($D76AA478), 7); - Round1(D, A, B, C, Data[1] + Longint($E8C7B756), 12); - Round1(C, D, A, B, Data[2] + Longint($242070DB), 17); - Round1(B, C, D, A, Data[3] + Longint($C1BDCEEE), 22); - Round1(A, B, C, D, Data[4] + Longint($F57C0FAF), 7); - Round1(D, A, B, C, Data[5] + Longint($4787C62A), 12); - Round1(C, D, A, B, Data[6] + Longint($A8304613), 17); - Round1(B, C, D, A, Data[7] + Longint($FD469501), 22); - Round1(A, B, C, D, Data[8] + Longint($698098D8), 7); - Round1(D, A, B, C, Data[9] + Longint($8B44F7AF), 12); - Round1(C, D, A, B, Data[10] + Longint($FFFF5BB1), 17); - Round1(B, C, D, A, Data[11] + Longint($895CD7BE), 22); - Round1(A, B, C, D, Data[12] + Longint($6B901122), 7); - Round1(D, A, B, C, Data[13] + Longint($FD987193), 12); - Round1(C, D, A, B, Data[14] + Longint($A679438E), 17); - Round1(B, C, D, A, Data[15] + Longint($49B40821), 22); - - Round2(A, B, C, D, Data[1] + Longint($F61E2562), 5); - Round2(D, A, B, C, Data[6] + Longint($C040B340), 9); - Round2(C, D, A, B, Data[11] + Longint($265E5A51), 14); - Round2(B, C, D, A, Data[0] + Longint($E9B6C7AA), 20); - Round2(A, B, C, D, Data[5] + Longint($D62F105D), 5); - Round2(D, A, B, C, Data[10] + Longint($02441453), 9); - Round2(C, D, A, B, Data[15] + Longint($D8A1E681), 14); - Round2(B, C, D, A, Data[4] + Longint($E7D3FBC8), 20); - Round2(A, B, C, D, Data[9] + Longint($21E1CDE6), 5); - Round2(D, A, B, C, Data[14] + Longint($C33707D6), 9); - Round2(C, D, A, B, Data[3] + Longint($F4D50D87), 14); - Round2(B, C, D, A, Data[8] + Longint($455A14ED), 20); - Round2(A, B, C, D, Data[13] + Longint($A9E3E905), 5); - Round2(D, A, B, C, Data[2] + Longint($FCEFA3F8), 9); - Round2(C, D, A, B, Data[7] + Longint($676F02D9), 14); - Round2(B, C, D, A, Data[12] + Longint($8D2A4C8A), 20); - - Round3(A, B, C, D, Data[5] + Longint($FFFA3942), 4); - Round3(D, A, B, C, Data[8] + Longint($8771F681), 11); - Round3(C, D, A, B, Data[11] + Longint($6D9D6122), 16); - Round3(B, C, D, A, Data[14] + Longint($FDE5380C), 23); - Round3(A, B, C, D, Data[1] + Longint($A4BEEA44), 4); - Round3(D, A, B, C, Data[4] + Longint($4BDECFA9), 11); - Round3(C, D, A, B, Data[7] + Longint($F6BB4B60), 16); - Round3(B, C, D, A, Data[10] + Longint($BEBFBC70), 23); - Round3(A, B, C, D, Data[13] + Longint($289B7EC6), 4); - Round3(D, A, B, C, Data[0] + Longint($EAA127FA), 11); - Round3(C, D, A, B, Data[3] + Longint($D4EF3085), 16); - Round3(B, C, D, A, Data[6] + Longint($04881D05), 23); - Round3(A, B, C, D, Data[9] + Longint($D9D4D039), 4); - Round3(D, A, B, C, Data[12] + Longint($E6DB99E5), 11); - Round3(C, D, A, B, Data[15] + Longint($1FA27CF8), 16); - Round3(B, C, D, A, Data[2] + Longint($C4AC5665), 23); - - Round4(A, B, C, D, Data[0] + Longint($F4292244), 6); - Round4(D, A, B, C, Data[7] + Longint($432AFF97), 10); - Round4(C, D, A, B, Data[14] + Longint($AB9423A7), 15); - Round4(B, C, D, A, Data[5] + Longint($FC93A039), 21); - Round4(A, B, C, D, Data[12] + Longint($655B59C3), 6); - Round4(D, A, B, C, Data[3] + Longint($8F0CCC92), 10); - Round4(C, D, A, B, Data[10] + Longint($FFEFF47D), 15); - Round4(B, C, D, A, Data[1] + Longint($85845DD1), 21); - Round4(A, B, C, D, Data[8] + Longint($6FA87E4F), 6); - Round4(D, A, B, C, Data[15] + Longint($FE2CE6E0), 10); - Round4(C, D, A, B, Data[6] + Longint($A3014314), 15); - Round4(B, C, D, A, Data[13] + Longint($4E0811A1), 21); - Round4(A, B, C, D, Data[4] + Longint($F7537E82), 6); - Round4(D, A, B, C, Data[11] + Longint($BD3AF235), 10); - Round4(C, D, A, B, Data[2] + Longint($2AD7D2BB), 15); - Round4(B, C, D, A, Data[9] + Longint($EB86D391), 21); - - Inc(Buf[0], A); - Inc(Buf[1], B); - Inc(Buf[2], C); - Inc(Buf[3], D); -end; - -//fixed by James McAdams -procedure MDUpdate(var MDContext: TMDCtx; const Data: AnsiString; transform: TMDTransform); -var - Index, partLen, InputLen, I: integer; -{$IFDEF CIL} - n: integer; -{$ENDIF} -begin - InputLen := Length(Data); - with MDContext do - begin - Index := (Count[0] shr 3) and $3F; - Inc(Count[0], InputLen shl 3); - if Count[0] < (InputLen shl 3) then - Inc(Count[1]); - Inc(Count[1], InputLen shr 29); - partLen := 64 - Index; - if InputLen >= partLen then - begin - ArrLongToByte(BufLong, BufAnsiChar); - {$IFDEF CIL} - for n := 1 to partLen do - BufAnsiChar[index - 1 + n] := Ord(Data[n]); - {$ELSE} - Move(Data[1], BufAnsiChar[Index], partLen); - {$ENDIF} - ArrByteToLong(BufAnsiChar, BufLong); - Transform(State, Buflong); - I := partLen; - while I + 63 < InputLen do - begin - ArrLongToByte(BufLong, BufAnsiChar); - {$IFDEF CIL} - for n := 1 to 64 do - BufAnsiChar[n - 1] := Ord(Data[i + n]); - {$ELSE} - Move(Data[I+1], BufAnsiChar, 64); - {$ENDIF} - ArrByteToLong(BufAnsiChar, BufLong); - Transform(State, Buflong); - inc(I, 64); - end; - Index := 0; - end - else - I := 0; - ArrLongToByte(BufLong, BufAnsiChar); - {$IFDEF CIL} - for n := 1 to InputLen-I do - BufAnsiChar[Index + n - 1] := Ord(Data[i + n]); - {$ELSE} - Move(Data[I+1], BufAnsiChar[Index], InputLen-I); - {$ENDIF} - ArrByteToLong(BufAnsiChar, BufLong); - end -end; - -function MDFinal(var MDContext: TMDCtx; transform: TMDTransform): AnsiString; -var - Cnt: Word; - P: Byte; - digest: array[0..15] of Byte; - i: Integer; - n: integer; -begin - for I := 0 to 15 do - Digest[I] := I + 1; - with MDContext do - begin - Cnt := (Count[0] shr 3) and $3F; - P := Cnt; - BufAnsiChar[P] := $80; - Inc(P); - Cnt := 64 - 1 - Cnt; - if Cnt < 8 then - begin - for n := 0 to cnt - 1 do - BufAnsiChar[P + n] := 0; - ArrByteToLong(BufAnsiChar, BufLong); -// FillChar(BufAnsiChar[P], Cnt, #0); - Transform(State, BufLong); - ArrLongToByte(BufLong, BufAnsiChar); - for n := 0 to 55 do - BufAnsiChar[n] := 0; - ArrByteToLong(BufAnsiChar, BufLong); -// FillChar(BufAnsiChar, 56, #0); - end - else - begin - for n := 0 to Cnt - 8 - 1 do - BufAnsiChar[p + n] := 0; - ArrByteToLong(BufAnsiChar, BufLong); -// FillChar(BufAnsiChar[P], Cnt - 8, #0); - end; - BufLong[14] := Count[0]; - BufLong[15] := Count[1]; - Transform(State, BufLong); - ArrLongToByte(State, Digest); -// Move(State, Digest, 16); - Result := ''; - for i := 0 to 15 do - Result := Result + AnsiChar(digest[i]); - end; -// FillChar(MD5Context, SizeOf(TMD5Ctx), #0) -end; - -{==============================================================================} - -function MD5(const Value: AnsiString): AnsiString; -var - MDContext: TMDCtx; -begin - MDInit(MDContext); - MDUpdate(MDContext, Value, @MD5Transform); - Result := MDFinal(MDContext, @MD5Transform); -end; - -{==============================================================================} - -function HMAC_MD5(Text, Key: AnsiString): AnsiString; -var - ipad, opad, s: AnsiString; - n: Integer; - MDContext: TMDCtx; -begin - if Length(Key) > 64 then - Key := md5(Key); - ipad := StringOfChar(#$36, 64); - opad := StringOfChar(#$5C, 64); - for n := 1 to Length(Key) do - begin - ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n])); - opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n])); - end; - MDInit(MDContext); - MDUpdate(MDContext, ipad, @MD5Transform); - MDUpdate(MDContext, Text, @MD5Transform); - s := MDFinal(MDContext, @MD5Transform); - MDInit(MDContext); - MDUpdate(MDContext, opad, @MD5Transform); - MDUpdate(MDContext, s, @MD5Transform); - Result := MDFinal(MDContext, @MD5Transform); -end; - -{==============================================================================} - -function MD5LongHash(const Value: AnsiString; Len: integer): AnsiString; -var - cnt, rest: integer; - l: integer; - n: integer; - MDContext: TMDCtx; -begin - l := length(Value); - cnt := Len div l; - rest := Len mod l; - MDInit(MDContext); - for n := 1 to cnt do - MDUpdate(MDContext, Value, @MD5Transform); - if rest > 0 then - MDUpdate(MDContext, Copy(Value, 1, rest), @MD5Transform); - Result := MDFinal(MDContext, @MD5Transform); -end; - -{==============================================================================} -// SHA1 is based on sources by Dave Barton (davebarton@bigfoot.com) - -procedure SHA1init( var SHA1Context: TSHA1Ctx ); -var - n: integer; -begin - SHA1Context.Hi := 0; - SHA1Context.Lo := 0; - SHA1Context.Index := 0; - for n := 0 to High(SHA1Context.Buffer) do - SHA1Context.Buffer[n] := 0; - for n := 0 to High(SHA1Context.HashByte) do - SHA1Context.HashByte[n] := 0; -// FillChar(SHA1Context, SizeOf(TSHA1Ctx), #0); - SHA1Context.Hash[0] := integer($67452301); - SHA1Context.Hash[1] := integer($EFCDAB89); - SHA1Context.Hash[2] := integer($98BADCFE); - SHA1Context.Hash[3] := integer($10325476); - SHA1Context.Hash[4] := integer($C3D2E1F0); -end; - -//****************************************************************************** -function RB(A: integer): integer; -begin - Result := (A shr 24) or ((A shr 8) and $FF00) or ((A shl 8) and $FF0000) or (A shl 24); -end; - -procedure SHA1Compress(var Data: TSHA1Ctx); -var - A, B, C, D, E, T: integer; - W: array[0..79] of integer; - i: integer; - n: integer; - - function F1(x, y, z: integer): integer; - begin - Result := z xor (x and (y xor z)); - end; - function F2(x, y, z: integer): integer; - begin - Result := x xor y xor z; - end; - function F3(x, y, z: integer): integer; - begin - Result := (x and y) or (z and (x or y)); - end; - function LRot32(X: integer; c: integer): integer; - begin - result := (x shl c) or (x shr (32 - c)); - end; -begin - ArrByteToLong(Data.Buffer, W); -// Move(Data.Buffer, W, Sizeof(Data.Buffer)); - for i := 0 to 15 do - W[i] := RB(W[i]); - for i := 16 to 79 do - W[i] := LRot32(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16], 1); - A := Data.Hash[0]; - B := Data.Hash[1]; - C := Data.Hash[2]; - D := Data.Hash[3]; - E := Data.Hash[4]; - for i := 0 to 19 do - begin - T := LRot32(A, 5) + F1(B, C, D) + E + W[i] + integer($5A827999); - E := D; - D := C; - C := LRot32(B, 30); - B := A; - A := T; - end; - for i := 20 to 39 do - begin - T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($6ED9EBA1); - E := D; - D := C; - C := LRot32(B, 30); - B := A; - A := T; - end; - for i := 40 to 59 do - begin - T := LRot32(A, 5) + F3(B, C, D) + E + W[i] + integer($8F1BBCDC); - E := D; - D := C; - C := LRot32(B, 30); - B := A; - A := T; - end; - for i := 60 to 79 do - begin - T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($CA62C1D6); - E := D; - D := C; - C := LRot32(B, 30); - B := A; - A := T; - end; - Data.Hash[0] := Data.Hash[0] + A; - Data.Hash[1] := Data.Hash[1] + B; - Data.Hash[2] := Data.Hash[2] + C; - Data.Hash[3] := Data.Hash[3] + D; - Data.Hash[4] := Data.Hash[4] + E; - for n := 0 to high(w) do - w[n] := 0; -// FillChar(W, Sizeof(W), 0); - for n := 0 to high(Data.Buffer) do - Data.Buffer[n] := 0; -// FillChar(Data.Buffer, Sizeof(Data.Buffer), 0); -end; - -//****************************************************************************** -procedure SHA1Update(var Context: TSHA1Ctx; const Data: AnsiString); -var - Len: integer; - n: integer; - i, k: integer; -begin - Len := Length(data); - for k := 0 to 7 do - begin - i := Context.Lo; - Inc(Context.Lo, Len); - if Context.Lo < i then - Inc(Context.Hi); - end; - for n := 1 to len do - begin - Context.Buffer[Context.Index] := byte(Data[n]); - Inc(Context.Index); - if Context.Index = 64 then - begin - Context.Index := 0; - SHA1Compress(Context); - end; - end; -end; - -//****************************************************************************** -function SHA1Final(var Context: TSHA1Ctx): AnsiString; -type - Pinteger = ^integer; -var - i: integer; - procedure ItoArr(var Ar: Array of byte; I, value: Integer); - begin - Ar[i + 0] := Value and $000000FF; - Ar[i + 1] := (Value shr 8) and $000000FF; - Ar[i + 2] := (Value shr 16) and $000000FF; - Ar[i + 3] := (Value shr 24) and $000000FF; - end; -begin - Context.Buffer[Context.Index] := $80; - if Context.Index >= 56 then - SHA1Compress(Context); - ItoArr(Context.Buffer, 56, RB(Context.Hi)); - ItoArr(Context.Buffer, 60, RB(Context.Lo)); -// Pinteger(@Context.Buffer[56])^ := RB(Context.Hi); -// Pinteger(@Context.Buffer[60])^ := RB(Context.Lo); - SHA1Compress(Context); - Context.Hash[0] := RB(Context.Hash[0]); - Context.Hash[1] := RB(Context.Hash[1]); - Context.Hash[2] := RB(Context.Hash[2]); - Context.Hash[3] := RB(Context.Hash[3]); - Context.Hash[4] := RB(Context.Hash[4]); - ArrLongToByte(Context.Hash, Context.HashByte); - Result := ''; - for i := 0 to 19 do - Result := Result + AnsiChar(Context.HashByte[i]); -end; - -function SHA1(const Value: AnsiString): AnsiString; -var - SHA1Context: TSHA1Ctx; -begin - SHA1Init(SHA1Context); - SHA1Update(SHA1Context, Value); - Result := SHA1Final(SHA1Context); -end; - -{==============================================================================} - -function HMAC_SHA1(Text, Key: AnsiString): AnsiString; -var - ipad, opad, s: AnsiString; - n: Integer; - SHA1Context: TSHA1Ctx; -begin - if Length(Key) > 64 then - Key := SHA1(Key); - ipad := StringOfChar(#$36, 64); - opad := StringOfChar(#$5C, 64); - for n := 1 to Length(Key) do - begin - ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n])); - opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n])); - end; - SHA1Init(SHA1Context); - SHA1Update(SHA1Context, ipad); - SHA1Update(SHA1Context, Text); - s := SHA1Final(SHA1Context); - SHA1Init(SHA1Context); - SHA1Update(SHA1Context, opad); - SHA1Update(SHA1Context, s); - Result := SHA1Final(SHA1Context); -end; - -{==============================================================================} - -function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString; -var - cnt, rest: integer; - l: integer; - n: integer; - SHA1Context: TSHA1Ctx; -begin - l := length(Value); - cnt := Len div l; - rest := Len mod l; - SHA1Init(SHA1Context); - for n := 1 to cnt do - SHA1Update(SHA1Context, Value); - if rest > 0 then - SHA1Update(SHA1Context, Copy(Value, 1, rest)); - Result := SHA1Final(SHA1Context); -end; - -{==============================================================================} - -procedure MD4Transform(var Buf: array of LongInt; const Data: array of LongInt); -var - A, B, C, D: LongInt; - function LRot32(a, b: longint): longint; - begin - Result:= (a shl b) or (a shr (32 - b)); - end; -begin - A := Buf[0]; - B := Buf[1]; - C := Buf[2]; - D := Buf[3]; - - A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 0], 3); - D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 1], 7); - C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 2], 11); - B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 3], 19); - A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 4], 3); - D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 5], 7); - C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 6], 11); - B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 7], 19); - A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 8], 3); - D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 9], 7); - C:= LRot32(C + (B xor (D and (A xor B))) + Data[10], 11); - B:= LRot32(B + (A xor (C and (D xor A))) + Data[11], 19); - A:= LRot32(A + (D xor (B and (C xor D))) + Data[12], 3); - D:= LRot32(D + (C xor (A and (B xor C))) + Data[13], 7); - C:= LRot32(C + (B xor (D and (A xor B))) + Data[14], 11); - B:= LRot32(B + (A xor (C and (D xor A))) + Data[15], 19); - - A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 0] + longint($5a827999), 3); - D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 4] + longint($5a827999), 5); - C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 8] + longint($5a827999), 9); - B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[12] + longint($5a827999), 13); - A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 1] + longint($5a827999), 3); - D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 5] + longint($5a827999), 5); - C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 9] + longint($5a827999), 9); - B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[13] + longint($5a827999), 13); - A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 2] + longint($5a827999), 3); - D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 6] + longint($5a827999), 5); - C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[10] + longint($5a827999), 9); - B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[14] + longint($5a827999), 13); - A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 3] + longint($5a827999), 3); - D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 7] + longint($5a827999), 5); - C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[11] + longint($5a827999), 9); - B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[15] + longint($5a827999), 13); - - A:= LRot32(A + (B xor C xor D) + Data[ 0] + longint($6ed9eba1), 3); - D:= LRot32(D + (A xor B xor C) + Data[ 8] + longint($6ed9eba1), 9); - C:= LRot32(C + (D xor A xor B) + Data[ 4] + longint($6ed9eba1), 11); - B:= LRot32(B + (C xor D xor A) + Data[12] + longint($6ed9eba1), 15); - A:= LRot32(A + (B xor C xor D) + Data[ 2] + longint($6ed9eba1), 3); - D:= LRot32(D + (A xor B xor C) + Data[10] + longint($6ed9eba1), 9); - C:= LRot32(C + (D xor A xor B) + Data[ 6] + longint($6ed9eba1), 11); - B:= LRot32(B + (C xor D xor A) + Data[14] + longint($6ed9eba1), 15); - A:= LRot32(A + (B xor C xor D) + Data[ 1] + longint($6ed9eba1), 3); - D:= LRot32(D + (A xor B xor C) + Data[ 9] + longint($6ed9eba1), 9); - C:= LRot32(C + (D xor A xor B) + Data[ 5] + longint($6ed9eba1), 11); - B:= LRot32(B + (C xor D xor A) + Data[13] + longint($6ed9eba1), 15); - A:= LRot32(A + (B xor C xor D) + Data[ 3] + longint($6ed9eba1), 3); - D:= LRot32(D + (A xor B xor C) + Data[11] + longint($6ed9eba1), 9); - C:= LRot32(C + (D xor A xor B) + Data[ 7] + longint($6ed9eba1), 11); - B:= LRot32(B + (C xor D xor A) + Data[15] + longint($6ed9eba1), 15); - - Inc(Buf[0], A); - Inc(Buf[1], B); - Inc(Buf[2], C); - Inc(Buf[3], D); -end; - -{==============================================================================} - -function MD4(const Value: AnsiString): AnsiString; -var - MDContext: TMDCtx; -begin - MDInit(MDContext); - MDUpdate(MDContext, Value, @MD4Transform); - Result := MDFinal(MDContext, @MD4Transform); -end; - -{==============================================================================} - - -end. diff --git a/addons/synapse/synacrypt.pas b/addons/synapse/synacrypt.pas deleted file mode 100644 index dc43b9b..0000000 --- a/addons/synapse/synacrypt.pas +++ /dev/null @@ -1,1228 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.000.001 | -|==============================================================================| -| Content: Encryption support | -|==============================================================================| -| Copyright (c)2007-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)2007-2010. | -| All Rights Reserved. | -| Based on work of David Barton and Eric Young | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(Encryption support) - -Implemented are DES and 3DES encryption/decryption by ECB, CBC, CFB-8bit, - CFB-block, OFB and CTR methods. -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$R-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit synacrypt; - -interface - -uses - SysUtils, Classes, synautil; - -type - {:@abstract(Implementation of common routines for 64-bit block ciphers) - - Do not use this class directly, use descendants only!} - TSynaBlockCipher= class(TObject) - protected - procedure InitKey(Key: AnsiString); virtual; - private - IV, CV: AnsiString; - procedure IncCounter; - public - {:Sets the IV to Value and performs a reset} - procedure SetIV(const Value: AnsiString); virtual; - {:Returns the current chaining information, not the actual IV} - function GetIV: AnsiString; virtual; - {:Reset any stored chaining information} - procedure Reset; virtual; - {:Encrypt a 64-bit block of data using the ECB method of encryption} - function EncryptECB(const InData: AnsiString): AnsiString; virtual; - {:Decrypt a 64-bit block of data using the ECB method of decryption} - function DecryptECB(const InData: AnsiString): AnsiString; virtual; - {:Encrypt data using the CBC method of encryption} - function EncryptCBC(const Indata: AnsiString): AnsiString; virtual; - {:Decrypt data using the CBC method of decryption} - function DecryptCBC(const Indata: AnsiString): AnsiString; virtual; - {:Encrypt data using the CFB (8 bit) method of encryption} - function EncryptCFB8bit(const Indata: AnsiString): AnsiString; virtual; - {:Decrypt data using the CFB (8 bit) method of decryption} - function DecryptCFB8bit(const Indata: AnsiString): AnsiString; virtual; - {:Encrypt data using the CFB (block) method of encryption} - function EncryptCFBblock(const Indata: AnsiString): AnsiString; virtual; - {:Decrypt data using the CFB (block) method of decryption} - function DecryptCFBblock(const Indata: AnsiString): AnsiString; virtual; - {:Encrypt data using the OFB method of encryption} - function EncryptOFB(const Indata: AnsiString): AnsiString; virtual; - {:Decrypt data using the OFB method of decryption} - function DecryptOFB(const Indata: AnsiString): AnsiString; virtual; - {:Encrypt data using the CTR method of encryption} - function EncryptCTR(const Indata: AnsiString): AnsiString; virtual; - {:Decrypt data using the CTR method of decryption} - function DecryptCTR(const Indata: AnsiString): AnsiString; virtual; - {:Create a encryptor/decryptor instance and initialize it by the Key.} - constructor Create(Key: AnsiString); - end; - - {:@abstract(Datatype for holding one DES key data) - - This data type is used internally.} - TDesKeyData = array[0..31] of integer; - - {:@abstract(Implementation of common routines for DES encryption) - - Do not use this class directly, use descendants only!} - TSynaCustomDes = class(TSynaBlockcipher) - protected - procedure DoInit(KeyB: AnsiString; var KeyData: TDesKeyData); - function EncryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; - function DecryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; - end; - - {:@abstract(Implementation of DES encryption)} - TSynaDes= class(TSynaCustomDes) - protected - KeyData: TDesKeyData; - procedure InitKey(Key: AnsiString); override; - public - {:Encrypt a 64-bit block of data using the ECB method of encryption} - function EncryptECB(const InData: AnsiString): AnsiString; override; - {:Decrypt a 64-bit block of data using the ECB method of decryption} - function DecryptECB(const InData: AnsiString): AnsiString; override; - end; - - {:@abstract(Implementation of 3DES encryption)} - TSyna3Des= class(TSynaCustomDes) - protected - KeyData: array[0..2] of TDesKeyData; - procedure InitKey(Key: AnsiString); override; - public - {:Encrypt a 64-bit block of data using the ECB method of encryption} - function EncryptECB(const InData: AnsiString): AnsiString; override; - {:Decrypt a 64-bit block of data using the ECB method of decryption} - function DecryptECB(const InData: AnsiString): AnsiString; override; - end; - -{:Call internal test of all DES encryptions. Returns @true if all is OK.} -function TestDes: boolean; -{:Call internal test of all 3DES encryptions. Returns @true if all is OK.} -function Test3Des: boolean; - -{==============================================================================} -implementation - -const - shifts2: array[0..15]of byte= - (0,0,1,1,1,1,1,1,0,1,1,1,1,1,1,0); - - des_skb: array[0..7,0..63]of integer=( - ( - (* for C bits (numbered as per FIPS 46) 1 2 3 4 5 6 *) - integer($00000000),integer($00000010),integer($20000000),integer($20000010), - integer($00010000),integer($00010010),integer($20010000),integer($20010010), - integer($00000800),integer($00000810),integer($20000800),integer($20000810), - integer($00010800),integer($00010810),integer($20010800),integer($20010810), - integer($00000020),integer($00000030),integer($20000020),integer($20000030), - integer($00010020),integer($00010030),integer($20010020),integer($20010030), - integer($00000820),integer($00000830),integer($20000820),integer($20000830), - integer($00010820),integer($00010830),integer($20010820),integer($20010830), - integer($00080000),integer($00080010),integer($20080000),integer($20080010), - integer($00090000),integer($00090010),integer($20090000),integer($20090010), - integer($00080800),integer($00080810),integer($20080800),integer($20080810), - integer($00090800),integer($00090810),integer($20090800),integer($20090810), - integer($00080020),integer($00080030),integer($20080020),integer($20080030), - integer($00090020),integer($00090030),integer($20090020),integer($20090030), - integer($00080820),integer($00080830),integer($20080820),integer($20080830), - integer($00090820),integer($00090830),integer($20090820),integer($20090830) - ),( - (* for C bits (numbered as per FIPS 46) 7 8 10 11 12 13 *) - integer($00000000),integer($02000000),integer($00002000),integer($02002000), - integer($00200000),integer($02200000),integer($00202000),integer($02202000), - integer($00000004),integer($02000004),integer($00002004),integer($02002004), - integer($00200004),integer($02200004),integer($00202004),integer($02202004), - integer($00000400),integer($02000400),integer($00002400),integer($02002400), - integer($00200400),integer($02200400),integer($00202400),integer($02202400), - integer($00000404),integer($02000404),integer($00002404),integer($02002404), - integer($00200404),integer($02200404),integer($00202404),integer($02202404), - integer($10000000),integer($12000000),integer($10002000),integer($12002000), - integer($10200000),integer($12200000),integer($10202000),integer($12202000), - integer($10000004),integer($12000004),integer($10002004),integer($12002004), - integer($10200004),integer($12200004),integer($10202004),integer($12202004), - integer($10000400),integer($12000400),integer($10002400),integer($12002400), - integer($10200400),integer($12200400),integer($10202400),integer($12202400), - integer($10000404),integer($12000404),integer($10002404),integer($12002404), - integer($10200404),integer($12200404),integer($10202404),integer($12202404) - ),( - (* for C bits (numbered as per FIPS 46) 14 15 16 17 19 20 *) - integer($00000000),integer($00000001),integer($00040000),integer($00040001), - integer($01000000),integer($01000001),integer($01040000),integer($01040001), - integer($00000002),integer($00000003),integer($00040002),integer($00040003), - integer($01000002),integer($01000003),integer($01040002),integer($01040003), - integer($00000200),integer($00000201),integer($00040200),integer($00040201), - integer($01000200),integer($01000201),integer($01040200),integer($01040201), - integer($00000202),integer($00000203),integer($00040202),integer($00040203), - integer($01000202),integer($01000203),integer($01040202),integer($01040203), - integer($08000000),integer($08000001),integer($08040000),integer($08040001), - integer($09000000),integer($09000001),integer($09040000),integer($09040001), - integer($08000002),integer($08000003),integer($08040002),integer($08040003), - integer($09000002),integer($09000003),integer($09040002),integer($09040003), - integer($08000200),integer($08000201),integer($08040200),integer($08040201), - integer($09000200),integer($09000201),integer($09040200),integer($09040201), - integer($08000202),integer($08000203),integer($08040202),integer($08040203), - integer($09000202),integer($09000203),integer($09040202),integer($09040203) - ),( - (* for C bits (numbered as per FIPS 46) 21 23 24 26 27 28 *) - integer($00000000),integer($00100000),integer($00000100),integer($00100100), - integer($00000008),integer($00100008),integer($00000108),integer($00100108), - integer($00001000),integer($00101000),integer($00001100),integer($00101100), - integer($00001008),integer($00101008),integer($00001108),integer($00101108), - integer($04000000),integer($04100000),integer($04000100),integer($04100100), - integer($04000008),integer($04100008),integer($04000108),integer($04100108), - integer($04001000),integer($04101000),integer($04001100),integer($04101100), - integer($04001008),integer($04101008),integer($04001108),integer($04101108), - integer($00020000),integer($00120000),integer($00020100),integer($00120100), - integer($00020008),integer($00120008),integer($00020108),integer($00120108), - integer($00021000),integer($00121000),integer($00021100),integer($00121100), - integer($00021008),integer($00121008),integer($00021108),integer($00121108), - integer($04020000),integer($04120000),integer($04020100),integer($04120100), - integer($04020008),integer($04120008),integer($04020108),integer($04120108), - integer($04021000),integer($04121000),integer($04021100),integer($04121100), - integer($04021008),integer($04121008),integer($04021108),integer($04121108) - ),( - (* for D bits (numbered as per FIPS 46) 1 2 3 4 5 6 *) - integer($00000000),integer($10000000),integer($00010000),integer($10010000), - integer($00000004),integer($10000004),integer($00010004),integer($10010004), - integer($20000000),integer($30000000),integer($20010000),integer($30010000), - integer($20000004),integer($30000004),integer($20010004),integer($30010004), - integer($00100000),integer($10100000),integer($00110000),integer($10110000), - integer($00100004),integer($10100004),integer($00110004),integer($10110004), - integer($20100000),integer($30100000),integer($20110000),integer($30110000), - integer($20100004),integer($30100004),integer($20110004),integer($30110004), - integer($00001000),integer($10001000),integer($00011000),integer($10011000), - integer($00001004),integer($10001004),integer($00011004),integer($10011004), - integer($20001000),integer($30001000),integer($20011000),integer($30011000), - integer($20001004),integer($30001004),integer($20011004),integer($30011004), - integer($00101000),integer($10101000),integer($00111000),integer($10111000), - integer($00101004),integer($10101004),integer($00111004),integer($10111004), - integer($20101000),integer($30101000),integer($20111000),integer($30111000), - integer($20101004),integer($30101004),integer($20111004),integer($30111004) - ),( - (* for D bits (numbered as per FIPS 46) 8 9 11 12 13 14 *) - integer($00000000),integer($08000000),integer($00000008),integer($08000008), - integer($00000400),integer($08000400),integer($00000408),integer($08000408), - integer($00020000),integer($08020000),integer($00020008),integer($08020008), - integer($00020400),integer($08020400),integer($00020408),integer($08020408), - integer($00000001),integer($08000001),integer($00000009),integer($08000009), - integer($00000401),integer($08000401),integer($00000409),integer($08000409), - integer($00020001),integer($08020001),integer($00020009),integer($08020009), - integer($00020401),integer($08020401),integer($00020409),integer($08020409), - integer($02000000),integer($0A000000),integer($02000008),integer($0A000008), - integer($02000400),integer($0A000400),integer($02000408),integer($0A000408), - integer($02020000),integer($0A020000),integer($02020008),integer($0A020008), - integer($02020400),integer($0A020400),integer($02020408),integer($0A020408), - integer($02000001),integer($0A000001),integer($02000009),integer($0A000009), - integer($02000401),integer($0A000401),integer($02000409),integer($0A000409), - integer($02020001),integer($0A020001),integer($02020009),integer($0A020009), - integer($02020401),integer($0A020401),integer($02020409),integer($0A020409) - ),( - (* for D bits (numbered as per FIPS 46) 16 17 18 19 20 21 *) - integer($00000000),integer($00000100),integer($00080000),integer($00080100), - integer($01000000),integer($01000100),integer($01080000),integer($01080100), - integer($00000010),integer($00000110),integer($00080010),integer($00080110), - integer($01000010),integer($01000110),integer($01080010),integer($01080110), - integer($00200000),integer($00200100),integer($00280000),integer($00280100), - integer($01200000),integer($01200100),integer($01280000),integer($01280100), - integer($00200010),integer($00200110),integer($00280010),integer($00280110), - integer($01200010),integer($01200110),integer($01280010),integer($01280110), - integer($00000200),integer($00000300),integer($00080200),integer($00080300), - integer($01000200),integer($01000300),integer($01080200),integer($01080300), - integer($00000210),integer($00000310),integer($00080210),integer($00080310), - integer($01000210),integer($01000310),integer($01080210),integer($01080310), - integer($00200200),integer($00200300),integer($00280200),integer($00280300), - integer($01200200),integer($01200300),integer($01280200),integer($01280300), - integer($00200210),integer($00200310),integer($00280210),integer($00280310), - integer($01200210),integer($01200310),integer($01280210),integer($01280310) - ),( - (* for D bits (numbered as per FIPS 46) 22 23 24 25 27 28 *) - integer($00000000),integer($04000000),integer($00040000),integer($04040000), - integer($00000002),integer($04000002),integer($00040002),integer($04040002), - integer($00002000),integer($04002000),integer($00042000),integer($04042000), - integer($00002002),integer($04002002),integer($00042002),integer($04042002), - integer($00000020),integer($04000020),integer($00040020),integer($04040020), - integer($00000022),integer($04000022),integer($00040022),integer($04040022), - integer($00002020),integer($04002020),integer($00042020),integer($04042020), - integer($00002022),integer($04002022),integer($00042022),integer($04042022), - integer($00000800),integer($04000800),integer($00040800),integer($04040800), - integer($00000802),integer($04000802),integer($00040802),integer($04040802), - integer($00002800),integer($04002800),integer($00042800),integer($04042800), - integer($00002802),integer($04002802),integer($00042802),integer($04042802), - integer($00000820),integer($04000820),integer($00040820),integer($04040820), - integer($00000822),integer($04000822),integer($00040822),integer($04040822), - integer($00002820),integer($04002820),integer($00042820),integer($04042820), - integer($00002822),integer($04002822),integer($00042822),integer($04042822) - )); - - des_sptrans: array[0..7,0..63] of integer=( - ( - (* nibble 0 *) - integer($02080800), integer($00080000), integer($02000002), integer($02080802), - integer($02000000), integer($00080802), integer($00080002), integer($02000002), - integer($00080802), integer($02080800), integer($02080000), integer($00000802), - integer($02000802), integer($02000000), integer($00000000), integer($00080002), - integer($00080000), integer($00000002), integer($02000800), integer($00080800), - integer($02080802), integer($02080000), integer($00000802), integer($02000800), - integer($00000002), integer($00000800), integer($00080800), integer($02080002), - integer($00000800), integer($02000802), integer($02080002), integer($00000000), - integer($00000000), integer($02080802), integer($02000800), integer($00080002), - integer($02080800), integer($00080000), integer($00000802), integer($02000800), - integer($02080002), integer($00000800), integer($00080800), integer($02000002), - integer($00080802), integer($00000002), integer($02000002), integer($02080000), - integer($02080802), integer($00080800), integer($02080000), integer($02000802), - integer($02000000), integer($00000802), integer($00080002), integer($00000000), - integer($00080000), integer($02000000), integer($02000802), integer($02080800), - integer($00000002), integer($02080002), integer($00000800), integer($00080802) - ),( - (* nibble 1 *) - integer($40108010), integer($00000000), integer($00108000), integer($40100000), - integer($40000010), integer($00008010), integer($40008000), integer($00108000), - integer($00008000), integer($40100010), integer($00000010), integer($40008000), - integer($00100010), integer($40108000), integer($40100000), integer($00000010), - integer($00100000), integer($40008010), integer($40100010), integer($00008000), - integer($00108010), integer($40000000), integer($00000000), integer($00100010), - integer($40008010), integer($00108010), integer($40108000), integer($40000010), - integer($40000000), integer($00100000), integer($00008010), integer($40108010), - integer($00100010), integer($40108000), integer($40008000), integer($00108010), - integer($40108010), integer($00100010), integer($40000010), integer($00000000), - integer($40000000), integer($00008010), integer($00100000), integer($40100010), - integer($00008000), integer($40000000), integer($00108010), integer($40008010), - integer($40108000), integer($00008000), integer($00000000), integer($40000010), - integer($00000010), integer($40108010), integer($00108000), integer($40100000), - integer($40100010), integer($00100000), integer($00008010), integer($40008000), - integer($40008010), integer($00000010), integer($40100000), integer($00108000) - ),( - (* nibble 2 *) - integer($04000001), integer($04040100), integer($00000100), integer($04000101), - integer($00040001), integer($04000000), integer($04000101), integer($00040100), - integer($04000100), integer($00040000), integer($04040000), integer($00000001), - integer($04040101), integer($00000101), integer($00000001), integer($04040001), - integer($00000000), integer($00040001), integer($04040100), integer($00000100), - integer($00000101), integer($04040101), integer($00040000), integer($04000001), - integer($04040001), integer($04000100), integer($00040101), integer($04040000), - integer($00040100), integer($00000000), integer($04000000), integer($00040101), - integer($04040100), integer($00000100), integer($00000001), integer($00040000), - integer($00000101), integer($00040001), integer($04040000), integer($04000101), - integer($00000000), integer($04040100), integer($00040100), integer($04040001), - integer($00040001), integer($04000000), integer($04040101), integer($00000001), - integer($00040101), integer($04000001), integer($04000000), integer($04040101), - integer($00040000), integer($04000100), integer($04000101), integer($00040100), - integer($04000100), integer($00000000), integer($04040001), integer($00000101), - integer($04000001), integer($00040101), integer($00000100), integer($04040000) - ),( - (* nibble 3 *) - integer($00401008), integer($10001000), integer($00000008), integer($10401008), - integer($00000000), integer($10400000), integer($10001008), integer($00400008), - integer($10401000), integer($10000008), integer($10000000), integer($00001008), - integer($10000008), integer($00401008), integer($00400000), integer($10000000), - integer($10400008), integer($00401000), integer($00001000), integer($00000008), - integer($00401000), integer($10001008), integer($10400000), integer($00001000), - integer($00001008), integer($00000000), integer($00400008), integer($10401000), - integer($10001000), integer($10400008), integer($10401008), integer($00400000), - integer($10400008), integer($00001008), integer($00400000), integer($10000008), - integer($00401000), integer($10001000), integer($00000008), integer($10400000), - integer($10001008), integer($00000000), integer($00001000), integer($00400008), - integer($00000000), integer($10400008), integer($10401000), integer($00001000), - integer($10000000), integer($10401008), integer($00401008), integer($00400000), - integer($10401008), integer($00000008), integer($10001000), integer($00401008), - integer($00400008), integer($00401000), integer($10400000), integer($10001008), - integer($00001008), integer($10000000), integer($10000008), integer($10401000) - ),( - (* nibble 4 *) - integer($08000000), integer($00010000), integer($00000400), integer($08010420), - integer($08010020), integer($08000400), integer($00010420), integer($08010000), - integer($00010000), integer($00000020), integer($08000020), integer($00010400), - integer($08000420), integer($08010020), integer($08010400), integer($00000000), - integer($00010400), integer($08000000), integer($00010020), integer($00000420), - integer($08000400), integer($00010420), integer($00000000), integer($08000020), - integer($00000020), integer($08000420), integer($08010420), integer($00010020), - integer($08010000), integer($00000400), integer($00000420), integer($08010400), - integer($08010400), integer($08000420), integer($00010020), integer($08010000), - integer($00010000), integer($00000020), integer($08000020), integer($08000400), - integer($08000000), integer($00010400), integer($08010420), integer($00000000), - integer($00010420), integer($08000000), integer($00000400), integer($00010020), - integer($08000420), integer($00000400), integer($00000000), integer($08010420), - integer($08010020), integer($08010400), integer($00000420), integer($00010000), - integer($00010400), integer($08010020), integer($08000400), integer($00000420), - integer($00000020), integer($00010420), integer($08010000), integer($08000020) - ),( - (* nibble 5 *) - integer($80000040), integer($00200040), integer($00000000), integer($80202000), - integer($00200040), integer($00002000), integer($80002040), integer($00200000), - integer($00002040), integer($80202040), integer($00202000), integer($80000000), - integer($80002000), integer($80000040), integer($80200000), integer($00202040), - integer($00200000), integer($80002040), integer($80200040), integer($00000000), - integer($00002000), integer($00000040), integer($80202000), integer($80200040), - integer($80202040), integer($80200000), integer($80000000), integer($00002040), - integer($00000040), integer($00202000), integer($00202040), integer($80002000), - integer($00002040), integer($80000000), integer($80002000), integer($00202040), - integer($80202000), integer($00200040), integer($00000000), integer($80002000), - integer($80000000), integer($00002000), integer($80200040), integer($00200000), - integer($00200040), integer($80202040), integer($00202000), integer($00000040), - integer($80202040), integer($00202000), integer($00200000), integer($80002040), - integer($80000040), integer($80200000), integer($00202040), integer($00000000), - integer($00002000), integer($80000040), integer($80002040), integer($80202000), - integer($80200000), integer($00002040), integer($00000040), integer($80200040) - ),( - (* nibble 6 *) - integer($00004000), integer($00000200), integer($01000200), integer($01000004), - integer($01004204), integer($00004004), integer($00004200), integer($00000000), - integer($01000000), integer($01000204), integer($00000204), integer($01004000), - integer($00000004), integer($01004200), integer($01004000), integer($00000204), - integer($01000204), integer($00004000), integer($00004004), integer($01004204), - integer($00000000), integer($01000200), integer($01000004), integer($00004200), - integer($01004004), integer($00004204), integer($01004200), integer($00000004), - integer($00004204), integer($01004004), integer($00000200), integer($01000000), - integer($00004204), integer($01004000), integer($01004004), integer($00000204), - integer($00004000), integer($00000200), integer($01000000), integer($01004004), - integer($01000204), integer($00004204), integer($00004200), integer($00000000), - integer($00000200), integer($01000004), integer($00000004), integer($01000200), - integer($00000000), integer($01000204), integer($01000200), integer($00004200), - integer($00000204), integer($00004000), integer($01004204), integer($01000000), - integer($01004200), integer($00000004), integer($00004004), integer($01004204), - integer($01000004), integer($01004200), integer($01004000), integer($00004004) - ),( - (* nibble 7 *) - integer($20800080), integer($20820000), integer($00020080), integer($00000000), - integer($20020000), integer($00800080), integer($20800000), integer($20820080), - integer($00000080), integer($20000000), integer($00820000), integer($00020080), - integer($00820080), integer($20020080), integer($20000080), integer($20800000), - integer($00020000), integer($00820080), integer($00800080), integer($20020000), - integer($20820080), integer($20000080), integer($00000000), integer($00820000), - integer($20000000), integer($00800000), integer($20020080), integer($20800080), - integer($00800000), integer($00020000), integer($20820000), integer($00000080), - integer($00800000), integer($00020000), integer($20000080), integer($20820080), - integer($00020080), integer($20000000), integer($00000000), integer($00820000), - integer($20800080), integer($20020080), integer($20020000), integer($00800080), - integer($20820000), integer($00000080), integer($00800080), integer($20020000), - integer($20820080), integer($00800000), integer($20800000), integer($20000080), - integer($00820000), integer($00020080), integer($20020080), integer($20800000), - integer($00000080), integer($20820000), integer($00820080), integer($00000000), - integer($20000000), integer($20800080), integer($00020000), integer($00820080) - )); - -{==============================================================================} - -function XorString(Indata1, Indata2: AnsiString): AnsiString; -var - i: integer; -begin - Indata2 := PadString(Indata2, length(Indata1), #0); - Result := ''; - for i := 1 to length(Indata1) do - Result := Result + AnsiChar(ord(Indata1[i]) xor ord(Indata2[i])); -end; - -procedure hperm_op(var a, t: integer; n, m: integer); -begin - t:= ((a shl (16 - n)) xor a) and m; - a:= a xor t xor (t shr (16 - n)); -end; - -procedure perm_op(var a, b, t: integer; n, m: integer); -begin - t:= ((a shr n) xor b) and m; - b:= b xor t; - a:= a xor (t shl n); -end; - -{==============================================================================} -procedure TSynaBlockCipher.IncCounter; -var - i: integer; -begin - Inc(CV[8]); - i:= 7; - while (i> 0) and (CV[i + 1] = #0) do - begin - Inc(CV[i]); - Dec(i); - end; -end; - -procedure TSynaBlockCipher.Reset; -begin - CV := IV; -end; - -procedure TSynaBlockCipher.InitKey(Key: AnsiString); -begin -end; - -procedure TSynaBlockCipher.SetIV(const Value: AnsiString); -begin - IV := PadString(Value, 8, #0); - Reset; -end; - -function TSynaBlockCipher.GetIV: AnsiString; -begin - Result := CV; -end; - -function TSynaBlockCipher.EncryptECB(const InData: AnsiString): AnsiString; -begin - Result := InData; -end; - -function TSynaBlockCipher.DecryptECB(const InData: AnsiString): AnsiString; -begin - Result := InData; -end; - -function TSynaBlockCipher.EncryptCBC(const Indata: AnsiString): AnsiString; -var - i: integer; - s: ansistring; - l: integer; -begin - Result := ''; - l := Length(InData); - for i:= 1 to (l div 8) do - begin - s := copy(Indata, (i - 1) * 8 + 1, 8); - s := XorString(s, CV); - s := EncryptECB(s); - CV := s; - Result := Result + s; - end; - if (l mod 8)<> 0 then - begin - CV := EncryptECB(CV); - s := copy(Indata, (l div 8) * 8 + 1, l mod 8); - s := XorString(s, CV); - Result := Result + s; - end; -end; - -function TSynaBlockCipher.DecryptCBC(const Indata: AnsiString): AnsiString; -var - i: integer; - s, temp: ansistring; - l: integer; -begin - Result := ''; - l := Length(InData); - for i:= 1 to (l div 8) do - begin - s := copy(Indata, (i - 1) * 8 + 1, 8); - temp := s; - s := DecryptECB(s); - s := XorString(s, CV); - Result := Result + s; - CV := Temp; - end; - if (l mod 8)<> 0 then - begin - CV := EncryptECB(CV); - s := copy(Indata, (l div 8) * 8 + 1, l mod 8); - s := XorString(s, CV); - Result := Result + s; - end; -end; - -function TSynaBlockCipher.EncryptCFB8bit(const Indata: AnsiString): AnsiString; -var - i: integer; - Temp: AnsiString; - c: AnsiChar; -begin - Result := ''; - for i:= 1 to Length(Indata) do - begin - Temp := EncryptECB(CV); - c := AnsiChar(ord(InData[i]) xor ord(temp[1])); - Result := Result + c; - Delete(CV, 1, 1); - CV := CV + c; - end; -end; - -function TSynaBlockCipher.DecryptCFB8bit(const Indata: AnsiString): AnsiString; -var - i: integer; - Temp: AnsiString; - c: AnsiChar; -begin - Result := ''; - for i:= 1 to length(Indata) do - begin - c:= Indata[i]; - Temp := EncryptECB(CV); - Result := Result + AnsiChar(ord(InData[i]) xor ord(temp[1])); - Delete(CV, 1, 1); - CV := CV + c; - end; -end; - -function TSynaBlockCipher.EncryptCFBblock(const Indata: AnsiString): AnsiString; -var - i: integer; - s: AnsiString; - l: integer; -begin - Result := ''; - l := Length(InData); - for i:= 1 to (l div 8) do - begin - CV := EncryptECB(CV); - s := copy(Indata, (i - 1) * 8 + 1, 8); - s := XorString(s, CV); - Result := Result + s; - CV := s; - end; - if (l mod 8)<> 0 then - begin - CV := EncryptECB(CV); - s := copy(Indata, (l div 8) * 8 + 1, l mod 8); - s := XorString(s, CV); - Result := Result + s; - end; -end; - -function TSynaBlockCipher.DecryptCFBblock(const Indata: AnsiString): AnsiString; -var - i: integer; - S, Temp: AnsiString; - l: integer; -begin - Result := ''; - l := Length(InData); - for i:= 1 to (l div 8) do - begin - s := copy(Indata, (i - 1) * 8 + 1, 8); - Temp := s; - CV := EncryptECB(CV); - s := XorString(s, CV); - Result := result + s; - CV := temp; - end; - if (l mod 8)<> 0 then - begin - CV := EncryptECB(CV); - s := copy(Indata, (l div 8) * 8 + 1, l mod 8); - s := XorString(s, CV); - Result := Result + s; - end; -end; - -function TSynaBlockCipher.EncryptOFB(const Indata: AnsiString): AnsiString; -var - i: integer; - s: AnsiString; - l: integer; -begin - Result := ''; - l := Length(InData); - for i:= 1 to (l div 8) do - begin - CV := EncryptECB(CV); - s := copy(Indata, (i - 1) * 8 + 1, 8); - s := XorString(s, CV); - Result := Result + s; - end; - if (l mod 8)<> 0 then - begin - CV := EncryptECB(CV); - s := copy(Indata, (l div 8) * 8 + 1, l mod 8); - s := XorString(s, CV); - Result := Result + s; - end; -end; - -function TSynaBlockCipher.DecryptOFB(const Indata: AnsiString): AnsiString; -var - i: integer; - s: AnsiString; - l: integer; -begin - Result := ''; - l := Length(InData); - for i:= 1 to (l div 8) do - begin - Cv := EncryptECB(CV); - s := copy(Indata, (i - 1) * 8 + 1, 8); - s := XorString(s, CV); - Result := Result + s; - end; - if (l mod 8)<> 0 then - begin - CV := EncryptECB(CV); - s := copy(Indata, (l div 8) * 8 + 1, l mod 8); - s := XorString(s, CV); - Result := Result + s; - end; -end; - -function TSynaBlockCipher.EncryptCTR(const Indata: AnsiString): AnsiString; -var - temp: AnsiString; - i: integer; - s: AnsiString; - l: integer; -begin - Result := ''; - l := Length(InData); - for i:= 1 to (l div 8) do - begin - temp := EncryptECB(CV); - IncCounter; - s := copy(Indata, (i - 1) * 8 + 1, 8); - s := XorString(s, temp); - Result := Result + s; - end; - if (l mod 8)<> 0 then - begin - temp := EncryptECB(CV); - IncCounter; - s := copy(Indata, (l div 8) * 8 + 1, l mod 8); - s := XorString(s, temp); - Result := Result + s; - end; -end; - -function TSynaBlockCipher.DecryptCTR(const Indata: AnsiString): AnsiString; -var - temp: AnsiString; - s: AnsiString; - i: integer; - l: integer; -begin - Result := ''; - l := Length(InData); - for i:= 1 to (l div 8) do - begin - temp := EncryptECB(CV); - IncCounter; - s := copy(Indata, (i - 1) * 8 + 1, 8); - s := XorString(s, temp); - Result := Result + s; - end; - if (l mod 8)<> 0 then - begin - temp := EncryptECB(CV); - IncCounter; - s := copy(Indata, (l div 8) * 8 + 1, l mod 8); - s := XorString(s, temp); - Result := Result + s; - end; -end; - -constructor TSynaBlockCipher.Create(Key: AnsiString); -begin - inherited Create; - InitKey(Key); - IV := StringOfChar(#0, 8); - IV := EncryptECB(IV); - Reset; -end; - -{==============================================================================} - -procedure TSynaCustomDes.DoInit(KeyB: AnsiString; var KeyData: TDesKeyData); -var - c, d, t, s, t2, i: integer; -begin - KeyB := PadString(KeyB, 8, #0); - c:= ord(KeyB[1]) or (ord(KeyB[2]) shl 8) or (ord(KeyB[3]) shl 16) or (ord(KeyB[4]) shl 24); - d:= ord(KeyB[5]) or (ord(KeyB[6]) shl 8) or (ord(KeyB[7]) shl 16) or (ord(KeyB[8]) shl 24); - perm_op(d,c,t,4,integer($0f0f0f0f)); - hperm_op(c,t,integer(-2),integer($cccc0000)); - hperm_op(d,t,integer(-2),integer($cccc0000)); - perm_op(d,c,t,1,integer($55555555)); - perm_op(c,d,t,8,integer($00ff00ff)); - perm_op(d,c,t,1,integer($55555555)); - d:= ((d and $ff) shl 16) or (d and $ff00) or ((d and $ff0000) shr 16) or - ((c and integer($f0000000)) shr 4); - c:= c and $fffffff; - for i:= 0 to 15 do - begin - if shifts2[i]<> 0 then - begin - c:= ((c shr 2) or (c shl 26)); - d:= ((d shr 2) or (d shl 26)); - end - else - begin - c:= ((c shr 1) or (c shl 27)); - d:= ((d shr 1) or (d shl 27)); - end; - c:= c and $fffffff; - d:= d and $fffffff; - s:= des_skb[0,c and $3f] or - des_skb[1,((c shr 6) and $03) or ((c shr 7) and $3c)] or - des_skb[2,((c shr 13) and $0f) or ((c shr 14) and $30)] or - des_skb[3,((c shr 20) and $01) or ((c shr 21) and $06) or ((c shr 22) and $38)]; - t:= des_skb[4,d and $3f] or - des_skb[5,((d shr 7) and $03) or ((d shr 8) and $3c)] or - des_skb[6, (d shr 15) and $3f ] or - des_skb[7,((d shr 21) and $0f) or ((d shr 22) and $30)]; - t2:= ((t shl 16) or (s and $ffff)); - KeyData[(i shl 1)]:= ((t2 shl 2) or (t2 shr 30)); - t2:= ((s shr 16) or (t and integer($ffff0000))); - KeyData[(i shl 1)+1]:= ((t2 shl 6) or (t2 shr 26)); - end; -end; - -function TSynaCustomDes.EncryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; -var - l, r, t, u: integer; - i: longint; -begin - r := Swapbytes(DecodeLongint(Indata, 1)); - l := swapbytes(DecodeLongint(Indata, 5)); - t:= ((l shr 4) xor r) and $0f0f0f0f; - r:= r xor t; - l:= l xor (t shl 4); - t:= ((r shr 16) xor l) and $0000ffff; - l:= l xor t; - r:= r xor (t shl 16); - t:= ((l shr 2) xor r) and $33333333; - r:= r xor t; - l:= l xor (t shl 2); - t:= ((r shr 8) xor l) and $00ff00ff; - l:= l xor t; - r:= r xor (t shl 8); - t:= ((l shr 1) xor r) and $55555555; - r:= r xor t; - l:= l xor (t shl 1); - r:= (r shr 29) or (r shl 3); - l:= (l shr 29) or (l shl 3); - i:= 0; - while i< 32 do - begin - u:= r xor KeyData[i ]; - t:= r xor KeyData[i+1]; - t:= (t shr 4) or (t shl 28); - l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - u:= l xor KeyData[i+2]; - t:= l xor KeyData[i+3]; - t:= (t shr 4) or (t shl 28); - r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - u:= r xor KeyData[i+4]; - t:= r xor KeyData[i+5]; - t:= (t shr 4) or (t shl 28); - l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - u:= l xor KeyData[i+6]; - t:= l xor KeyData[i+7]; - t:= (t shr 4) or (t shl 28); - r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - Inc(i,8); - end; - r:= (r shr 3) or (r shl 29); - l:= (l shr 3) or (l shl 29); - t:= ((r shr 1) xor l) and $55555555; - l:= l xor t; - r:= r xor (t shl 1); - t:= ((l shr 8) xor r) and $00ff00ff; - r:= r xor t; - l:= l xor (t shl 8); - t:= ((r shr 2) xor l) and $33333333; - l:= l xor t; - r:= r xor (t shl 2); - t:= ((l shr 16) xor r) and $0000ffff; - r:= r xor t; - l:= l xor (t shl 16); - t:= ((r shr 4) xor l) and $0f0f0f0f; - l:= l xor t; - r:= r xor (t shl 4); - Result := CodeLongInt(Swapbytes(l)) + CodeLongInt(Swapbytes(r)); -end; - -function TSynaCustomDes.DecryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; -var - l, r, t, u: integer; - i: longint; -begin - r := Swapbytes(DecodeLongint(Indata, 1)); - l := Swapbytes(DecodeLongint(Indata, 5)); - t:= ((l shr 4) xor r) and $0f0f0f0f; - r:= r xor t; - l:= l xor (t shl 4); - t:= ((r shr 16) xor l) and $0000ffff; - l:= l xor t; - r:= r xor (t shl 16); - t:= ((l shr 2) xor r) and $33333333; - r:= r xor t; - l:= l xor (t shl 2); - t:= ((r shr 8) xor l) and $00ff00ff; - l:= l xor t; - r:= r xor (t shl 8); - t:= ((l shr 1) xor r) and $55555555; - r:= r xor t; - l:= l xor (t shl 1); - r:= (r shr 29) or (r shl 3); - l:= (l shr 29) or (l shl 3); - i:= 30; - while i> 0 do - begin - u:= r xor KeyData[i ]; - t:= r xor KeyData[i+1]; - t:= (t shr 4) or (t shl 28); - l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - u:= l xor KeyData[i-2]; - t:= l xor KeyData[i-1]; - t:= (t shr 4) or (t shl 28); - r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - u:= r xor KeyData[i-4]; - t:= r xor KeyData[i-3]; - t:= (t shr 4) or (t shl 28); - l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - u:= l xor KeyData[i-6]; - t:= l xor KeyData[i-5]; - t:= (t shr 4) or (t shl 28); - r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - Dec(i,8); - end; - r:= (r shr 3) or (r shl 29); - l:= (l shr 3) or (l shl 29); - t:= ((r shr 1) xor l) and $55555555; - l:= l xor t; - r:= r xor (t shl 1); - t:= ((l shr 8) xor r) and $00ff00ff; - r:= r xor t; - l:= l xor (t shl 8); - t:= ((r shr 2) xor l) and $33333333; - l:= l xor t; - r:= r xor (t shl 2); - t:= ((l shr 16) xor r) and $0000ffff; - r:= r xor t; - l:= l xor (t shl 16); - t:= ((r shr 4) xor l) and $0f0f0f0f; - l:= l xor t; - r:= r xor (t shl 4); - Result := CodeLongInt(Swapbytes(l)) + CodeLongInt(Swapbytes(r)); -end; - -{==============================================================================} - -procedure TSynaDes.InitKey(Key: AnsiString); -begin - Key := PadString(Key, 8, #0); - DoInit(Key,KeyData); -end; - -function TSynaDes.EncryptECB(const InData: AnsiString): AnsiString; -begin - Result := EncryptBlock(InData,KeyData); -end; - -function TSynaDes.DecryptECB(const InData: AnsiString): AnsiString; -begin - Result := DecryptBlock(Indata,KeyData); -end; - -{==============================================================================} - -procedure TSyna3Des.InitKey(Key: AnsiString); -var - Size: integer; - n: integer; -begin - Size := length(Key); - key := PadString(key, 3 * 8, #0); - DoInit(Copy(key, 1, 8),KeyData[0]); - DoInit(Copy(key, 9, 8),KeyData[1]); - if Size > 16 then - DoInit(Copy(key, 17, 8),KeyData[2]) - else - for n := 0 to high(KeyData[0]) do - KeyData[2][n] := Keydata[0][n]; -end; - -function TSyna3Des.EncryptECB(const InData: AnsiString): AnsiString; -begin - Result := EncryptBlock(Indata,KeyData[0]); - Result := DecryptBlock(Result,KeyData[1]); - Result := EncryptBlock(Result,KeyData[2]); -end; - -function TSyna3Des.DecryptECB(const InData: AnsiString): AnsiString; -begin - Result := DecryptBlock(InData,KeyData[2]); - Result := EncryptBlock(Result,KeyData[1]); - Result := DecryptBlock(Result,KeyData[0]); -end; - -{==============================================================================} - -function TestDes: boolean; -var - des: TSynaDes; - s, t: string; -const - key = '01234567'; - data1= '01234567'; - data2= '0123456789abcdefghij'; -begin - //ECB - des := TSynaDes.Create(key); - try - s := des.EncryptECB(data1); - t := strtohex(s); - result := t = 'c50ad028c6da9800'; - s := des.DecryptECB(s); - result := result and (data1 = s); - finally - des.free; - end; - //CBC - des := TSynaDes.Create(key); - try - s := des.EncryptCBC(data2); - t := strtohex(s); - result := result and (t = 'eec50f6353115ad6dee90a22ed1b6a88a0926e35'); - des.Reset; - s := des.DecryptCBC(s); - result := result and (data2 = s); - finally - des.free; - end; - //CFB-8bit - des := TSynaDes.Create(key); - try - s := des.EncryptCFB8bit(data2); - t := strtohex(s); - result := result and (t = 'eb6aa12c2f0ff634b4dfb6da6cb2af8f9c5c1452'); - des.Reset; - s := des.DecryptCFB8bit(s); - result := result and (data2 = s); - finally - des.free; - end; - //CFB-block - des := TSynaDes.Create(key); - try - s := des.EncryptCFBblock(data2); - t := strtohex(s); - result := result and (t = 'ebdbbaa7f9286cdec28605e07f9b7f3be1053257'); - des.Reset; - s := des.DecryptCFBblock(s); - result := result and (data2 = s); - finally - des.free; - end; - //OFB - des := TSynaDes.Create(key); - try - s := des.EncryptOFB(data2); - t := strtohex(s); - result := result and (t = 'ebdbbaa7f9286cdee0b8b3798c4c34baac87dbdc'); - des.Reset; - s := des.DecryptOFB(s); - result := result and (data2 = s); - finally - des.free; - end; - //CTR - des := TSynaDes.Create(key); - try - s := des.EncryptCTR(data2); - t := strtohex(s); - result := result and (t = 'ebdbbaa7f9286cde0dd20b45f3afd9aa1b91b87e'); - des.Reset; - s := des.DecryptCTR(s); - result := result and (data2 = s); - finally - des.free; - end; -end; - -function Test3Des: boolean; -var - des: TSyna3Des; - s, t: string; -const - key = '0123456789abcdefghijklmn'; - data1= '01234567'; - data2= '0123456789abcdefghij'; -begin - //ECB - des := TSyna3Des.Create(key); - try - s := des.EncryptECB(data1); - t := strtohex(s); - result := t = 'e0dee91008dc460c'; - s := des.DecryptECB(s); - result := result and (data1 = s); - finally - des.free; - end; - //CBC - des := TSyna3Des.Create(key); - try - s := des.EncryptCBC(data2); - t := strtohex(s); - result := result and (t = 'ee844a2a4f49c01b91a1599b8eba29128c1ad87a'); - des.Reset; - s := des.DecryptCBC(s); - result := result and (data2 = s); - finally - des.free; - end; - //CFB-8bit - des := TSyna3Des.Create(key); - try - s := des.EncryptCFB8bit(data2); - t := strtohex(s); - result := result and (t = '935bbf5210c32cfa1faf61f91e8dc02dfa0ff1e8'); - des.Reset; - s := des.DecryptCFB8bit(s); - result := result and (data2 = s); - finally - des.free; - end; - //CFB-block - des := TSyna3Des.Create(key); - try - s := des.EncryptCFBblock(data2); - t := strtohex(s); - result := result and (t = '93754e3d54828fbf4bd81f1739419e8d2cfe1671'); - des.Reset; - s := des.DecryptCFBblock(s); - result := result and (data2 = s); - finally - des.free; - end; - //OFB - des := TSyna3Des.Create(key); - try - s := des.EncryptOFB(data2); - t := strtohex(s); - result := result and (t = '93754e3d54828fbf04ef0a5efc926ebdf2d95f20'); - des.Reset; - s := des.DecryptOFB(s); - result := result and (data2 = s); - finally - des.free; - end; - //CTR - des := TSyna3Des.Create(key); - try - s := des.EncryptCTR(data2); - t := strtohex(s); - result := result and (t = '93754e3d54828fbf1c51a121d2c93f989e70b3ad'); - des.Reset; - s := des.DecryptCTR(s); - result := result and (data2 = s); - finally - des.free; - end; -end; - -{==============================================================================} - -end. diff --git a/addons/synapse/synadbg.pas b/addons/synapse/synadbg.pas deleted file mode 100644 index a8e7f26..0000000 --- a/addons/synapse/synadbg.pas +++ /dev/null @@ -1,156 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.001 | -|==============================================================================| -| Content: Socket debug tools | -|==============================================================================| -| Copyright (c)2008-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)2008-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(Socket debug tools) - -Routines for help with debugging of events on the Sockets. -} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit synadbg; - -interface - -uses - blcksock, synsock, synautil, classes, sysutils; - -type - TSynaDebug = class(TObject) - class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); - class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer); - end; - -procedure AppendToLog(const value: Ansistring); - -var - LogFile: string; - -implementation - -procedure AppendToLog(const value: Ansistring); -var - st: TFileStream; - s: string; - h, m, ss, ms: word; - dt: Tdatetime; -begin - if fileexists(LogFile) then - st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite) - else - st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite); - try - st.Position := st.Size; - dt := now; - decodetime(dt, h, m, ss, ms); - s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value; - WriteStrToStream(st, s); - finally - st.free; - end; -end; - -class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); -var - s: string; -begin - case Reason of - HR_ResolvingBegin: - s := 'HR_ResolvingBegin'; - HR_ResolvingEnd: - s := 'HR_ResolvingEnd'; - HR_SocketCreate: - s := 'HR_SocketCreate'; - HR_SocketClose: - s := 'HR_SocketClose'; - HR_Bind: - s := 'HR_Bind'; - HR_Connect: - s := 'HR_Connect'; - HR_CanRead: - s := 'HR_CanRead'; - HR_CanWrite: - s := 'HR_CanWrite'; - HR_Listen: - s := 'HR_Listen'; - HR_Accept: - s := 'HR_Accept'; - HR_ReadCount: - s := 'HR_ReadCount'; - HR_WriteCount: - s := 'HR_WriteCount'; - HR_Wait: - s := 'HR_Wait'; - HR_Error: - s := 'HR_Error'; - else - s := '-unknown-'; - end; - s := inttohex(integer(Sender), 8) + s + ': ' + value + CRLF; - AppendToLog(s); -end; - -class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer); -var - s, d: Ansistring; -begin - setlength(s, len); - move(Buffer^, pointer(s)^, len); - if writing then - d := '-> ' - else - d := '<- '; - s :=inttohex(integer(Sender), 8) + d + s + CRLF; - AppendToLog(s); -end; - -initialization -begin - Logfile := changefileext(paramstr(0), '.slog'); -end; - -end. diff --git a/addons/synapse/synafpc.pas b/addons/synapse/synafpc.pas deleted file mode 100644 index cd39e70..0000000 --- a/addons/synapse/synafpc.pas +++ /dev/null @@ -1,137 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.002 | -|==============================================================================| -| Content: Utils for FreePascal compatibility | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2003-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@exclude} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -unit synafpc; - -interface - -uses -{$IFDEF FPC} - dynlibs, sysutils; -{$ELSE} - {$IFDEF MSWINDOWS} - Windows; - {$ELSE} - SysUtils; - {$ENDIF} -{$ENDIF} - -{$IFDEF FPC} -type - TLibHandle = dynlibs.TLibHandle; - -function LoadLibrary(ModuleName: PChar): TLibHandle; -function FreeLibrary(Module: TLibHandle): LongBool; -function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; -function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; -{$ELSE} -type - {$IFDEF CIL} - TLibHandle = Integer; - {$ELSE} - TLibHandle = HModule; - {$ENDIF} - {$IFDEF VER100} - LongWord = DWord; - {$ENDIF} -{$ENDIF} - -procedure Sleep(milliseconds: Cardinal); - - -implementation - -{==============================================================================} -{$IFDEF FPC} -function LoadLibrary(ModuleName: PChar): TLibHandle; -begin - Result := dynlibs.LoadLibrary(Modulename); -end; - -function FreeLibrary(Module: TLibHandle): LongBool; -begin - Result := dynlibs.UnloadLibrary(Module); -end; - -function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; -begin - Result := dynlibs.GetProcedureAddress(Module, Proc); -end; - -function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; -begin - Result := 0; -end; - -{$ELSE} -{$ENDIF} - -procedure Sleep(milliseconds: Cardinal); -begin -{$IFDEF MSWINDOWS} - {$IFDEF FPC} - sysutils.sleep(milliseconds); - {$ELSE} - windows.sleep(milliseconds); - {$ENDIF} -{$ELSE} - sysutils.sleep(milliseconds); -{$ENDIF} - -end; - -end. diff --git a/addons/synapse/synaicnv.pas b/addons/synapse/synaicnv.pas deleted file mode 100644 index 3dd79c5..0000000 --- a/addons/synapse/synaicnv.pas +++ /dev/null @@ -1,363 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.001 | -|==============================================================================| -| Content: ICONV support for Win32, Linux and .NET | -|==============================================================================| -| Copyright (c)2004-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2004-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -{:@abstract(LibIconv support) - -This unit is Pascal interface to LibIconv library for charset translations. -LibIconv is loaded dynamicly on-demand. If this library is not found in system, -requested LibIconv function just return errorcode. -} -unit synaicnv; - -interface - -uses -{$IFDEF CIL} - System.Runtime.InteropServices, - System.Text, -{$ENDIF} - synafpc, -{$IFNDEF MSWINDOWS} - {$IFNDEF FPC} - Libc, - {$ENDIF} - SysUtils; -{$ELSE} - Windows; -{$ENDIF} - - -const - {$IFNDEF MSWINDOWS} - DLLIconvName = 'libiconv.so'; - {$ELSE} - DLLIconvName = 'iconv.dll'; - {$ENDIF} - -type - size_t = Cardinal; -{$IFDEF CIL} - iconv_t = IntPtr; -{$ELSE} - iconv_t = Pointer; -{$ENDIF} - argptr = iconv_t; - -var - iconvLibHandle: TLibHandle = 0; - -function SynaIconvOpen(const tocode, fromcode: Ansistring): iconv_t; -function SynaIconvOpenTranslit(const tocode, fromcode: Ansistring): iconv_t; -function SynaIconvOpenIgnore(const tocode, fromcode: Ansistring): iconv_t; -function SynaIconv(cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer; -function SynaIconvClose(var cd: iconv_t): integer; -function SynaIconvCtl(cd: iconv_t; request: integer; argument: argptr): integer; - -function IsIconvloaded: Boolean; -function InitIconvInterface: Boolean; -function DestroyIconvInterface: Boolean; - -const - ICONV_TRIVIALP = 0; // int *argument - ICONV_GET_TRANSLITERATE = 1; // int *argument - ICONV_SET_TRANSLITERATE = 2; // const int *argument - ICONV_GET_DISCARD_ILSEQ = 3; // int *argument - ICONV_SET_DISCARD_ILSEQ = 4; // const int *argument - - -implementation - -uses SyncObjs; - -{$IFDEF CIL} - [DllImport(DLLIconvName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'libiconv_open')] - function _iconv_open(tocode: string; fromcode: string): iconv_t; external; - - [DllImport(DLLIconvName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'libiconv')] - function _iconv(cd: iconv_t; var inbuf: IntPtr; var inbytesleft: size_t; - var outbuf: IntPtr; var outbytesleft: size_t): size_t; external; - - [DllImport(DLLIconvName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'libiconv_close')] - function _iconv_close(cd: iconv_t): integer; external; - - [DllImport(DLLIconvName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'libiconvctl')] - function _iconvctl(cd: iconv_t; request: integer; argument: argptr): integer; external; - -{$ELSE} -type - Ticonv_open = function(tocode: pAnsichar; fromcode: pAnsichar): iconv_t; cdecl; - Ticonv = function(cd: iconv_t; var inbuf: pointer; var inbytesleft: size_t; - var outbuf: pointer; var outbytesleft: size_t): size_t; cdecl; - Ticonv_close = function(cd: iconv_t): integer; cdecl; - Ticonvctl = function(cd: iconv_t; request: integer; argument: argptr): integer; cdecl; -var - _iconv_open: Ticonv_open = nil; - _iconv: Ticonv = nil; - _iconv_close: Ticonv_close = nil; - _iconvctl: Ticonvctl = nil; -{$ENDIF} - - -var - IconvCS: TCriticalSection; - Iconvloaded: boolean = false; - -function SynaIconvOpen (const tocode, fromcode: Ansistring): iconv_t; -begin -{$IFDEF CIL} - try - Result := _iconv_open(tocode, fromcode); - except - on Exception do - Result := iconv_t(-1); - end; -{$ELSE} - if InitIconvInterface and Assigned(_iconv_open) then - Result := _iconv_open(PAnsiChar(tocode), PAnsiChar(fromcode)) - else - Result := iconv_t(-1); -{$ENDIF} -end; - -function SynaIconvOpenTranslit (const tocode, fromcode: Ansistring): iconv_t; -begin - Result := SynaIconvOpen(tocode + '//IGNORE//TRANSLIT', fromcode); -end; - -function SynaIconvOpenIgnore (const tocode, fromcode: Ansistring): iconv_t; -begin - Result := SynaIconvOpen(tocode + '//IGNORE', fromcode); -end; - -function SynaIconv (cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer; -var -{$IFDEF CIL} - ib, ob: IntPtr; - ibsave, obsave: IntPtr; - l: integer; -{$ELSE} - ib, ob: Pointer; -{$ENDIF} - ix, ox: size_t; -begin -{$IFDEF CIL} - l := Length(inbuf) * 4; - ibsave := IntPtr.Zero; - obsave := IntPtr.Zero; - try - ibsave := Marshal.StringToHGlobalAnsi(inbuf); - obsave := Marshal.AllocHGlobal(l); - ib := ibsave; - ob := obsave; - ix := Length(inbuf); - ox := l; - _iconv(cd, ib, ix, ob, ox); - Outbuf := Marshal.PtrToStringAnsi(obsave, l); - setlength(Outbuf, l - ox); - Result := Length(inbuf) - ix; - finally - Marshal.FreeCoTaskMem(ibsave); - Marshal.FreeHGlobal(obsave); - end; -{$ELSE} - if InitIconvInterface and Assigned(_iconv) then - begin - setlength(Outbuf, Length(inbuf) * 4); - ib := Pointer(inbuf); - ob := Pointer(Outbuf); - ix := Length(inbuf); - ox := Length(Outbuf); - _iconv(cd, ib, ix, ob, ox); - setlength(Outbuf, cardinal(Length(Outbuf)) - ox); - Result := Cardinal(Length(inbuf)) - ix; - end - else - begin - Outbuf := ''; - Result := 0; - end; -{$ENDIF} -end; - -function SynaIconvClose(var cd: iconv_t): integer; -begin - if cd = iconv_t(-1) then - begin - Result := 0; - Exit; - end; -{$IFDEF CIL} - try; - Result := _iconv_close(cd) - except - on Exception do - Result := -1; - end; - cd := iconv_t(-1); -{$ELSE} - if InitIconvInterface and Assigned(_iconv_close) then - Result := _iconv_close(cd) - else - Result := -1; - cd := iconv_t(-1); -{$ENDIF} -end; - -function SynaIconvCtl (cd: iconv_t; request: integer; argument: argptr): integer; -begin -{$IFDEF CIL} - Result := _iconvctl(cd, request, argument) -{$ELSE} - if InitIconvInterface and Assigned(_iconvctl) then - Result := _iconvctl(cd, request, argument) - else - Result := 0; -{$ENDIF} -end; - -function InitIconvInterface: Boolean; -begin - IconvCS.Enter; - try - if not IsIconvloaded then - begin -{$IFDEF CIL} - IconvLibHandle := 1; -{$ELSE} - IconvLibHandle := LoadLibrary(PChar(DLLIconvName)); -{$ENDIF} - if (IconvLibHandle <> 0) then - begin -{$IFNDEF CIL} - _iconv_open := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_open'))); - _iconv := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv'))); - _iconv_close := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_close'))); - _iconvctl := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconvctl'))); -{$ENDIF} - Result := True; - Iconvloaded := True; - end - else - begin - //load failed! - if IconvLibHandle <> 0 then - begin -{$IFNDEF CIL} - FreeLibrary(IconvLibHandle); -{$ENDIF} - IconvLibHandle := 0; - end; - Result := False; - end; - end - else - //loaded before... - Result := true; - finally - IconvCS.Leave; - end; -end; - -function DestroyIconvInterface: Boolean; -begin - IconvCS.Enter; - try - Iconvloaded := false; - if IconvLibHandle <> 0 then - begin -{$IFNDEF CIL} - FreeLibrary(IconvLibHandle); -{$ENDIF} - IconvLibHandle := 0; - end; -{$IFNDEF CIL} - _iconv_open := nil; - _iconv := nil; - _iconv_close := nil; - _iconvctl := nil; -{$ENDIF} - finally - IconvCS.Leave; - end; - Result := True; -end; - -function IsIconvloaded: Boolean; -begin - Result := IconvLoaded; -end; - - initialization -begin - IconvCS:= TCriticalSection.Create; -end; - -finalization -begin -{$IFNDEF CIL} - DestroyIconvInterface; -{$ENDIF} - IconvCS.Free; -end; - -end. diff --git a/addons/synapse/synaip.pas b/addons/synapse/synaip.pas deleted file mode 100644 index 82a7da4..0000000 --- a/addons/synapse/synaip.pas +++ /dev/null @@ -1,422 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.002.001 | -|==============================================================================| -| Content: IP address support procedures and functions | -|==============================================================================| -| Copyright (c)2006-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 2006-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(IP adress support procedures and functions)} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$R-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} - {$WARN SUSPICIOUS_TYPECAST OFF} -{$ENDIF} - -unit synaip; - -interface - -uses - SysUtils, SynaUtil; - -type -{:binary form of IPv6 adress (for string conversion routines)} - TIp6Bytes = array [0..15] of Byte; -{:binary form of IPv6 adress (for string conversion routines)} - TIp6Words = array [0..7] of Word; - -{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!} -function IsIP(const Value: string): Boolean; - -{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!} -function IsIP6(const Value: string): Boolean; - -{:Returns a string with the "Host" ip address converted to binary form.} -function IPToID(Host: string): Ansistring; - -{:Convert IPv6 address from their string form to binary byte array.} -function StrToIp6(value: string): TIp6Bytes; - -{:Convert IPv6 address from binary byte array to string form.} -function Ip6ToStr(value: TIp6Bytes): string; - -{:Convert IPv4 address from their string form to binary.} -function StrToIp(value: string): integer; - -{:Convert IPv4 address from binary to string form.} -function IpToStr(value: integer): string; - -{:Convert IPv4 address to reverse form.} -function ReverseIP(Value: AnsiString): AnsiString; - -{:Convert IPv6 address to reverse form.} -function ReverseIP6(Value: AnsiString): AnsiString; - -{:Expand short form of IPv6 address to long form.} -function ExpandIP6(Value: AnsiString): AnsiString; - - -implementation - -{==============================================================================} - -function IsIP(const Value: string): Boolean; -var - TempIP: string; - function ByteIsOk(const Value: string): Boolean; - var - x, n: integer; - begin - x := StrToIntDef(Value, -1); - Result := (x >= 0) and (x < 256); - // X may be in correct range, but value still may not be correct value! - // i.e. "$80" - if Result then - for n := 1 to length(Value) do - if not (AnsiChar(Value[n]) in ['0'..'9']) then - begin - Result := False; - Break; - end; - end; -begin - TempIP := Value; - Result := False; - if not ByteIsOk(Fetch(TempIP, '.')) then - Exit; - if not ByteIsOk(Fetch(TempIP, '.')) then - Exit; - if not ByteIsOk(Fetch(TempIP, '.')) then - Exit; - if ByteIsOk(TempIP) then - Result := True; -end; - -{==============================================================================} - -function IsIP6(const Value: string): Boolean; -var - TempIP: string; - s,t: string; - x: integer; - partcount: integer; - zerocount: integer; - First: Boolean; -begin - TempIP := Value; - Result := False; - if Value = '::' then - begin - Result := True; - Exit; - end; - partcount := 0; - zerocount := 0; - First := True; - while tempIP <> '' do - begin - s := fetch(TempIP, ':'); - if not(First) and (s = '') then - Inc(zerocount); - First := False; - if zerocount > 1 then - break; - Inc(partCount); - if s = '' then - Continue; - if partCount > 8 then - break; - if tempIP = '' then - begin - t := SeparateRight(s, '%'); - s := SeparateLeft(s, '%'); - x := StrToIntDef('$' + t, -1); - if (x < 0) or (x > $ffff) then - break; - end; - x := StrToIntDef('$' + s, -1); - if (x < 0) or (x > $ffff) then - break; - if tempIP = '' then - if not((PartCount = 1) and (ZeroCount = 0)) then - Result := True; - end; -end; - -{==============================================================================} -function IPToID(Host: string): Ansistring; -var - s: string; - i, x: Integer; -begin - Result := ''; - for x := 0 to 3 do - begin - s := Fetch(Host, '.'); - i := StrToIntDef(s, 0); - Result := Result + AnsiChar(i); - end; -end; - -{==============================================================================} - -function StrToIp(value: string): integer; -var - s: string; - i, x: Integer; -begin - Result := 0; - for x := 0 to 3 do - begin - s := Fetch(value, '.'); - i := StrToIntDef(s, 0); - Result := (256 * Result) + i; - end; -end; - -{==============================================================================} - -function IpToStr(value: integer): string; -var - x1, x2: word; - y1, y2: byte; -begin - Result := ''; - x1 := value shr 16; - x2 := value and $FFFF; - y1 := x1 div $100; - y2 := x1 mod $100; - Result := inttostr(y1) + '.' + inttostr(y2) + '.'; - y1 := x2 div $100; - y2 := x2 mod $100; - Result := Result + inttostr(y1) + '.' + inttostr(y2); -end; - -{==============================================================================} - -function ExpandIP6(Value: AnsiString): AnsiString; -var - n: integer; - s: ansistring; - x: integer; -begin - Result := ''; - if value = '' then - exit; - x := countofchar(value, ':'); - if x > 7 then - exit; - if value[1] = ':' then - value := '0' + value; - if value[length(value)] = ':' then - value := value + '0'; - x := 8 - x; - s := ''; - for n := 1 to x do - s := s + ':0'; - s := s + ':'; - Result := replacestring(value, '::', s); -end; -{==============================================================================} - -function StrToIp6(Value: string): TIp6Bytes; -var - IPv6: TIp6Words; - Index: Integer; - n: integer; - b1, b2: byte; - s: string; - x: integer; -begin - for n := 0 to 15 do - Result[n] := 0; - for n := 0 to 7 do - Ipv6[n] := 0; - Index := 0; - Value := ExpandIP6(value); - if value = '' then - exit; - while Value <> '' do - begin - if Index > 7 then - Exit; - s := fetch(value, ':'); - if s = '@' then - break; - if s = '' then - begin - IPv6[Index] := 0; - end - else - begin - x := StrToIntDef('$' + s, -1); - if (x > 65535) or (x < 0) then - Exit; - IPv6[Index] := x; - end; - Inc(Index); - end; - for n := 0 to 7 do - begin - b1 := ipv6[n] div 256; - b2 := ipv6[n] mod 256; - Result[n * 2] := b1; - Result[(n * 2) + 1] := b2; - end; -end; - -{==============================================================================} -//based on routine by the Free Pascal development team -function Ip6ToStr(value: TIp6Bytes): string; -var - i, x: byte; - zr1,zr2: set of byte; - zc1,zc2: byte; - have_skipped: boolean; - ip6w: TIp6words; -begin - zr1 := []; - zr2 := []; - zc1 := 0; - zc2 := 0; - for i := 0 to 7 do - begin - x := i * 2; - ip6w[i] := value[x] * 256 + value[x + 1]; - if ip6w[i] = 0 then - begin - include(zr2, i); - inc(zc2); - end - else - begin - if zc1 < zc2 then - begin - zc1 := zc2; - zr1 := zr2; - zc2 := 0; - zr2 := []; - end; - end; - end; - if zc1 < zc2 then - begin - zr1 := zr2; - end; - SetLength(Result, 8*5-1); - SetLength(Result, 0); - have_skipped := false; - for i := 0 to 7 do - begin - if not(i in zr1) then - begin - if have_skipped then - begin - if Result = '' then - Result := '::' - else - Result := Result + ':'; - have_skipped := false; - end; - Result := Result + IntToHex(Ip6w[i], 1) + ':'; - end - else - begin - have_skipped := true; - end; - end; - if have_skipped then - if Result = '' then - Result := '::0' - else - Result := Result + ':'; - - if Result = '' then - Result := '::0'; - if not (7 in zr1) then - SetLength(Result, Length(Result)-1); - Result := LowerCase(result); -end; - -{==============================================================================} -function ReverseIP(Value: AnsiString): AnsiString; -var - x: Integer; -begin - Result := ''; - repeat - x := LastDelimiter('.', Value); - Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x); - Delete(Value, x, Length(Value) - x + 1); - until x < 1; - if Length(Result) > 0 then - if Result[1] = '.' then - Delete(Result, 1, 1); -end; - -{==============================================================================} -function ReverseIP6(Value: AnsiString): AnsiString; -var - ip6: TIp6bytes; - n: integer; - x, y: integer; -begin - ip6 := StrToIP6(Value); - x := ip6[15] div 16; - y := ip6[15] mod 16; - Result := IntToHex(y, 1) + '.' + IntToHex(x, 1); - for n := 14 downto 0 do - begin - x := ip6[n] div 16; - y := ip6[n] mod 16; - Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1); - end; -end; - -{==============================================================================} -end. diff --git a/addons/synapse/synamisc.pas b/addons/synapse/synamisc.pas deleted file mode 100644 index 22a3274..0000000 --- a/addons/synapse/synamisc.pas +++ /dev/null @@ -1,404 +0,0 @@ -{==============================================================================| -| 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. diff --git a/addons/synapse/synaser.pas b/addons/synapse/synaser.pas deleted file mode 100644 index 6082b70..0000000 --- a/addons/synapse/synaser.pas +++ /dev/null @@ -1,2339 +0,0 @@ -{==============================================================================| -| 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. \ No newline at end of file diff --git a/addons/synapse/synautil.pas b/addons/synapse/synautil.pas deleted file mode 100644 index db7f483..0000000 --- a/addons/synapse/synautil.pas +++ /dev/null @@ -1,1820 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 004.014.000 | -|==============================================================================| -| Content: support 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) 1999-2010. | -| Portions created by Hernan Sanchez are Copyright (c) 2000. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Hernan Sanchez (hernan.sanchez@iname.com) | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(Support procedures and functions)} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$R-} -{$H+} - -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} - {$WARN SUSPICIOUS_TYPECAST OFF} -{$ENDIF} - -unit synautil; - -interface - -uses -{$IFDEF MSWINDOWS} - Windows, -{$ELSE} - {$IFDEF FPC} - UnixUtil, Unix, BaseUnix, - {$ELSE} - Libc, - {$ENDIF} -{$ENDIF} -{$IFDEF CIL} - System.IO, -{$ENDIF} - SysUtils, Classes, SynaFpc; - -{$IFDEF VER100} -type - int64 = integer; -{$ENDIF} - -{:Return your timezone bias from UTC time in minutes.} -function TimeZoneBias: integer; - -{:Return your timezone bias from UTC time in string representation like "+0200".} -function TimeZone: string; - -{:Returns current time in format defined in RFC-822. Useful for SMTP messages, - but other protocols use this time format as well. Results contains the timezone - specification. Four digit year is used to break any Y2K concerns. (Example - 'Fri, 15 Oct 1999 21:14:56 +0200')} -function Rfc822DateTime(t: TDateTime): string; - -{:Returns date and time in format defined in C compilers in format "mmm dd hh:nn:ss"} -function CDateTime(t: TDateTime): string; - -{:Returns date and time in format defined in format 'yymmdd hhnnss'} -function SimpleDateTime(t: TDateTime): string; - -{:Returns date and time in format defined in ANSI C compilers in format - "ddd mmm d hh:nn:ss yyyy" } -function AnsiCDateTime(t: TDateTime): string; - -{:Decode three-letter string with name of month to their month number. If string - not match any month name, then is returned 0. For parsing are used predefined - names for English, French and German and names from system locale too.} -function GetMonthNumber(Value: String): integer; - -{:Return decoded time from given string. Time must be witch separator ':'. You - can use "hh:mm" or "hh:mm:ss".} -function GetTimeFromStr(Value: string): TDateTime; - -{:Decode string in format "m-d-y" to TDateTime type.} -function GetDateMDYFromStr(Value: string): TDateTime; - -{:Decode various string representations of date and time to Tdatetime type. - This function do all timezone corrections too! This function can decode lot of - formats like: - @longcode(# - ddd, d mmm yyyy hh:mm:ss - ddd, d mmm yy hh:mm:ss - ddd, mmm d yyyy hh:mm:ss - ddd mmm dd hh:mm:ss yyyy #) - -and more with lot of modifications, include: -@longcode(# -Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 -Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 -Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format -#) -Timezone corrections known lot of symbolic timezone names (like CEST, EDT, etc.) -or numeric representation (like +0200). By convention defined in RFC timezone - +0000 is GMT and -0000 is current your system timezone.} -function DecodeRfcDateTime(Value: string): TDateTime; - -{:Return current system date and time in UTC timezone.} -function GetUTTime: TDateTime; - -{:Set Newdt as current system date and time in UTC timezone. This function work - only if you have administrator rights!} -function SetUTTime(Newdt: TDateTime): Boolean; - -{:Return current value of system timer with precizion 1 millisecond. Good for - measure time difference.} -function GetTick: LongWord; - -{:Return difference between two timestamps. It working fine only for differences - smaller then maxint. (difference must be smaller then 24 days.)} -function TickDelta(TickOld, TickNew: LongWord): LongWord; - -{:Return two characters, which ordinal values represents the value in byte - format. (High-endian)} -function CodeInt(Value: Word): Ansistring; - -{:Decodes two characters located at "Index" offset position of the "Value" - string to Word values.} -function DecodeInt(const Value: Ansistring; Index: Integer): Word; - -{:Return four characters, which ordinal values represents the value in byte - format. (High-endian)} -function CodeLongInt(Value: LongInt): Ansistring; - -{:Decodes four characters located at "Index" offset position of the "Value" - string to LongInt values.} -function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt; - -{:Dump binary buffer stored in a string to a result string.} -function DumpStr(const Buffer: Ansistring): string; - -{:Dump binary buffer stored in a string to a result string. All bytes with code - of character is written as character, not as hexadecimal value.} -function DumpExStr(const Buffer: Ansistring): string; - -{:Dump binary buffer stored in a string to a file with DumpFile filename.} -procedure Dump(const Buffer: AnsiString; DumpFile: string); - -{:Dump binary buffer stored in a string to a file with DumpFile filename. All - bytes with code of character is written as character, not as hexadecimal value.} -procedure DumpEx(const Buffer: AnsiString; DumpFile: string); - -{:Like TrimLeft, but remove only spaces, not control characters!} -function TrimSPLeft(const S: string): string; - -{:Like TrimRight, but remove only spaces, not control characters!} -function TrimSPRight(const S: string): string; - -{:Like Trim, but remove only spaces, not control characters!} -function TrimSP(const S: string): string; - -{:Returns a portion of the "Value" string located to the left of the "Delimiter" - string. If a delimiter is not found, results is original string.} -function SeparateLeft(const Value, Delimiter: string): string; - -{:Returns the portion of the "Value" string located to the right of the - "Delimiter" string. If a delimiter is not found, results is original string.} -function SeparateRight(const Value, Delimiter: string): string; - -{:Returns parameter value from string in format: - parameter1="value1"; parameter2=value2} -function GetParameter(const Value, Parameter: string): string; - -{:parse value string with elements differed by Delimiter into stringlist.} -procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings); - -{:parse value string with elements differed by ';' into stringlist.} -procedure ParseParameters(Value: string; const Parameters: TStrings); - -{:Index of string in stringlist with same beginning as Value is returned.} -function IndexByBegin(Value: string; const List: TStrings): integer; - -{:Returns only the e-mail portion of an address from the full address format. - i.e. returns 'nobody@@somewhere.com' from '"someone" '} -function GetEmailAddr(const Value: string): string; - -{:Returns only the description part from a full address format. i.e. returns - 'someone' from '"someone" '} -function GetEmailDesc(Value: string): string; - -{:Returns a string with hexadecimal digits representing the corresponding values - of the bytes found in "Value" string.} -function StrToHex(const Value: Ansistring): string; - -{:Returns a string of binary "Digits" representing "Value".} -function IntToBin(Value: Integer; Digits: Byte): string; - -{:Returns an integer equivalent of the binary string in "Value". - (i.e. ('10001010') returns 138)} -function BinToInt(const Value: string): Integer; - -{:Parses a URL to its various components.} -function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path, - Para: string): string; - -{:Replaces all "Search" string values found within "Value" string, with the - "Replace" string value.} -function ReplaceString(Value, Search, Replace: AnsiString): AnsiString; - -{:It is like RPos, but search is from specified possition.} -function RPosEx(const Sub, Value: string; From: integer): Integer; - -{:It is like POS function, but from right side of Value string.} -function RPos(const Sub, Value: String): Integer; - -{:Like @link(fetch), but working with binary strings, not with text.} -function FetchBin(var Value: string; const Delimiter: string): string; - -{:Fetch string from left of Value string.} -function Fetch(var Value: string; const Delimiter: string): string; - -{:Fetch string from left of Value string. This function ignore delimitesr inside - quotations.} -function FetchEx(var Value: string; const Delimiter, Quotation: string): string; - -{:If string is binary string (contains non-printable characters), then is - returned true.} -function IsBinaryString(const Value: AnsiString): Boolean; - -{:return position of string terminator in string. If terminator found, then is - returned in terminator parameter. - Possible line terminators are: CRLF, LFCR, CR, LF} -function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer; - -{:Delete empty strings from end of stringlist.} -Procedure StringsTrim(const value: TStrings); - -{:Like Pos function, buf from given string possition.} -function PosFrom(const SubStr, Value: String; From: integer): integer; - -{$IFNDEF CIL} -{:Increase pointer by value.} -function IncPoint(const p: pointer; Value: integer): pointer; -{$ENDIF} - -{:Get string between PairBegin and PairEnd. This function respect nesting. - For example: - @longcode(# - Value is: 'Hi! (hello(yes!))' - pairbegin is: '(' - pairend is: ')' - In this case result is: 'hello(yes!)'#)} -function GetBetween(const PairBegin, PairEnd, Value: string): string; - -{:Return count of Chr in Value string.} -function CountOfChar(const Value: string; Chr: char): integer; - -{:Remove quotation from Value string. If Value is not quoted, then return same - string without any modification. } -function UnquoteStr(const Value: string; Quote: Char): string; - -{:Quote Value string. If Value contains some Quote chars, then it is doubled.} -function QuoteStr(const Value: string; Quote: Char): string; - -{:Convert lines in stringlist from 'name: value' form to 'name=value' form.} -procedure HeadersToList(const Value: TStrings); - -{:Convert lines in stringlist from 'name=value' form to 'name: value' form.} -procedure ListToHeaders(const Value: TStrings); - -{:swap bytes in integer.} -function SwapBytes(Value: integer): integer; - -{:read string with requested length form stream.} -function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString; - -{:write string to stream.} -procedure WriteStrToStream(const Stream: TStream; Value: AnsiString); - -{:Return filename of new temporary file in Dir (if empty, then default temporary - directory is used) and with optional filename prefix.} -function GetTempFile(const Dir, prefix: AnsiString): AnsiString; - -{:Return padded string. If length is greater, string is truncated. If length is - smaller, string is padded by Pad character.} -function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString; - -{:Read header from "Value" stringlist beginning at "Index" position. If header - is Splitted into multiple lines, then this procedure de-split it into one line.} -function NormalizeHeader(Value: TStrings; var Index: Integer): string; - -var - {:can be used for your own months strings for @link(getmonthnumber)} - CustomMonthNames: array[1..12] of string; - -implementation - -{==============================================================================} - -const - MyDayNames: array[1..7] of AnsiString = - ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'); -var - MyMonthNames: array[0..6, 1..12] of String = - ( - ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //rewrited by system locales - 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'), - ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //English - 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'), - ('jan', 'fйv', 'mar', 'avr', 'mai', 'jun', //French - 'jul', 'aoы', 'sep', 'oct', 'nov', 'dйc'), - ('jan', 'fev', 'mar', 'avr', 'mai', 'jun', //French#2 - 'jul', 'aou', 'sep', 'oct', 'nov', 'dec'), - ('Jan', 'Feb', 'Mar', 'Apr', 'Mai', 'Jun', //German - 'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'), - ('Jan', 'Feb', 'Mдr', 'Apr', 'Mai', 'Jun', //German#2 - 'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'), - ('Led', 'Ъno', 'Bшe', 'Dub', 'Kvм', 'Иen', //Czech - 'Иec', 'Srp', 'Zбш', 'Шнj', 'Lis', 'Pro') - ); - - -{==============================================================================} - -function TimeZoneBias: integer; -{$IFNDEF MSWINDOWS} -{$IFNDEF FPC} -var - t: TTime_T; - UT: TUnixTime; -begin - __time(@T); - localtime_r(@T, UT); - Result := ut.__tm_gmtoff div 60; -{$ELSE} -begin - Result := TZSeconds div 60; -{$ENDIF} -{$ELSE} -var - zoneinfo: TTimeZoneInformation; - bias: Integer; -begin - case GetTimeZoneInformation(Zoneinfo) of - 2: - bias := zoneinfo.Bias + zoneinfo.DaylightBias; - 1: - bias := zoneinfo.Bias + zoneinfo.StandardBias; - else - bias := zoneinfo.Bias; - end; - Result := bias * (-1); -{$ENDIF} -end; - -{==============================================================================} - -function TimeZone: string; -var - bias: Integer; - h, m: Integer; -begin - bias := TimeZoneBias; - if bias >= 0 then - Result := '+' - else - Result := '-'; - bias := Abs(bias); - h := bias div 60; - m := bias mod 60; - Result := Result + Format('%.2d%.2d', [h, m]); -end; - -{==============================================================================} - -function Rfc822DateTime(t: TDateTime): string; -var - wYear, wMonth, wDay: word; -begin - DecodeDate(t, wYear, wMonth, wDay); - Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay, - MyMonthNames[1, wMonth], FormatDateTime('yyyy hh":"nn":"ss', t), TimeZone]); -end; - -{==============================================================================} - -function CDateTime(t: TDateTime): string; -var - wYear, wMonth, wDay: word; -begin - DecodeDate(t, wYear, wMonth, wDay); - Result:= Format('%s %2d %s', [MyMonthNames[1, wMonth], wDay, - FormatDateTime('hh":"nn":"ss', t)]); -end; - -{==============================================================================} - -function SimpleDateTime(t: TDateTime): string; -begin - Result := FormatDateTime('yymmdd hhnnss', t); -end; - -{==============================================================================} - -function AnsiCDateTime(t: TDateTime): string; -var - wYear, wMonth, wDay: word; -begin - DecodeDate(t, wYear, wMonth, wDay); - Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[1, wMonth], - wDay, FormatDateTime('hh":"nn":"ss yyyy ', t)]); -end; - -{==============================================================================} - -function DecodeTimeZone(Value: string; var Zone: integer): Boolean; -var - x: integer; - zh, zm: integer; - s: string; -begin - Result := false; - s := Value; - if (Pos('+', s) = 1) or (Pos('-',s) = 1) then - begin - if s = '-0000' then - Zone := TimeZoneBias - else - if Length(s) > 4 then - begin - zh := StrToIntdef(s[2] + s[3], 0); - zm := StrToIntdef(s[4] + s[5], 0); - zone := zh * 60 + zm; - if s[1] = '-' then - zone := zone * (-1); - end; - Result := True; - end - else - begin - x := 32767; - if s = 'NZDT' then x := 13; - if s = 'IDLE' then x := 12; - if s = 'NZST' then x := 12; - if s = 'NZT' then x := 12; - if s = 'EADT' then x := 11; - if s = 'GST' then x := 10; - if s = 'JST' then x := 9; - if s = 'CCT' then x := 8; - if s = 'WADT' then x := 8; - if s = 'WAST' then x := 7; - if s = 'ZP6' then x := 6; - if s = 'ZP5' then x := 5; - if s = 'ZP4' then x := 4; - if s = 'BT' then x := 3; - if s = 'EET' then x := 2; - if s = 'MEST' then x := 2; - if s = 'MESZ' then x := 2; - if s = 'SST' then x := 2; - if s = 'FST' then x := 2; - if s = 'CEST' then x := 2; - if s = 'CET' then x := 1; - if s = 'FWT' then x := 1; - if s = 'MET' then x := 1; - if s = 'MEWT' then x := 1; - if s = 'SWT' then x := 1; - if s = 'UT' then x := 0; - if s = 'UTC' then x := 0; - if s = 'GMT' then x := 0; - if s = 'WET' then x := 0; - if s = 'WAT' then x := -1; - if s = 'BST' then x := -1; - if s = 'AT' then x := -2; - if s = 'ADT' then x := -3; - if s = 'AST' then x := -4; - if s = 'EDT' then x := -4; - if s = 'EST' then x := -5; - if s = 'CDT' then x := -5; - if s = 'CST' then x := -6; - if s = 'MDT' then x := -6; - if s = 'MST' then x := -7; - if s = 'PDT' then x := -7; - if s = 'PST' then x := -8; - if s = 'YDT' then x := -8; - if s = 'YST' then x := -9; - if s = 'HDT' then x := -9; - if s = 'AHST' then x := -10; - if s = 'CAT' then x := -10; - if s = 'HST' then x := -10; - if s = 'EAST' then x := -10; - if s = 'NT' then x := -11; - if s = 'IDLW' then x := -12; - if x <> 32767 then - begin - zone := x * 60; - Result := True; - end; - end; -end; - -{==============================================================================} - -function GetMonthNumber(Value: String): integer; -var - n: integer; - function TestMonth(Value: String; Index: Integer): Boolean; - var - n: integer; - begin - Result := False; - for n := 0 to 6 do - if Value = AnsiUppercase(MyMonthNames[n, Index]) then - begin - Result := True; - Break; - end; - end; -begin - Result := 0; - Value := AnsiUppercase(Value); - for n := 1 to 12 do - if TestMonth(Value, n) or (Value = AnsiUppercase(CustomMonthNames[n])) then - begin - Result := n; - Break; - end; -end; - -{==============================================================================} - -function GetTimeFromStr(Value: string): TDateTime; -var - x: integer; -begin - x := rpos(':', Value); - if (x > 0) and ((Length(Value) - x) > 2) then - Value := Copy(Value, 1, x + 2); - Value := ReplaceString(Value, ':', TimeSeparator); - Result := -1; - try - Result := StrToTime(Value); - except - on Exception do ; - end; -end; - -{==============================================================================} - -function GetDateMDYFromStr(Value: string): TDateTime; -var - wYear, wMonth, wDay: word; - s: string; -begin - Result := 0; - s := Fetch(Value, '-'); - wMonth := StrToIntDef(s, 12); - s := Fetch(Value, '-'); - wDay := StrToIntDef(s, 30); - wYear := StrToIntDef(Value, 1899); - if wYear < 1000 then - if (wYear > 99) then - wYear := wYear + 1900 - else - if wYear > 50 then - wYear := wYear + 1900 - else - wYear := wYear + 2000; - try - Result := EncodeDate(wYear, wMonth, wDay); - except - on Exception do ; - end; -end; - -{==============================================================================} - -function DecodeRfcDateTime(Value: string): TDateTime; -var - day, month, year: Word; - zone: integer; - x, y: integer; - s: string; - t: TDateTime; -begin -// ddd, d mmm yyyy hh:mm:ss -// ddd, d mmm yy hh:mm:ss -// ddd, mmm d yyyy hh:mm:ss -// ddd mmm dd hh:mm:ss yyyy -// Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 -// Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 -// Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format - - Result := 0; - if Value = '' then - Exit; - day := 0; - month := 0; - year := 0; - zone := 0; - Value := ReplaceString(Value, ' -', ' #'); - Value := ReplaceString(Value, '-', ' '); - Value := ReplaceString(Value, ' #', ' -'); - while Value <> '' do - begin - s := Fetch(Value, ' '); - s := uppercase(s); - // timezone - if DecodetimeZone(s, x) then - begin - zone := x; - continue; - end; - x := StrToIntDef(s, 0); - // day or year - if x > 0 then - if (x < 32) and (day = 0) then - begin - day := x; - continue; - end - else - begin - if (year = 0) and ((month > 0) or (x > 12)) then - begin - year := x; - if year < 32 then - year := year + 2000; - if year < 1000 then - year := year + 1900; - continue; - end; - end; - // time - if rpos(':', s) > Pos(':', s) then - begin - t := GetTimeFromStr(s); - if t <> -1 then - Result := t; - continue; - end; - //timezone daylight saving time - if s = 'DST' then - begin - zone := zone + 60; - continue; - end; - // month - y := GetMonthNumber(s); - if (y > 0) and (month = 0) then - month := y; - end; - if year = 0 then - year := 1980; - if month < 1 then - month := 1; - if month > 12 then - month := 12; - if day < 1 then - day := 1; - x := MonthDays[IsLeapYear(year), month]; - if day > x then - day := x; - Result := Result + Encodedate(year, month, day); - zone := zone - TimeZoneBias; - x := zone div 1440; - Result := Result - x; - zone := zone mod 1440; - t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0); - if zone < 0 then - t := 0 - t; - Result := Result - t; -end; - -{==============================================================================} - -function GetUTTime: TDateTime; -{$IFDEF MSWINDOWS} -{$IFNDEF FPC} -var - st: TSystemTime; -begin - GetSystemTime(st); - result := SystemTimeToDateTime(st); -{$ELSE} -var - st: SysUtils.TSystemTime; - stw: Windows.TSystemTime; -begin - GetSystemTime(stw); - st.Year := stw.wYear; - st.Month := stw.wMonth; - st.Day := stw.wDay; - st.Hour := stw.wHour; - st.Minute := stw.wMinute; - st.Second := stw.wSecond; - st.Millisecond := stw.wMilliseconds; - result := SystemTimeToDateTime(st); -{$ENDIF} -{$ELSE} -{$IFNDEF FPC} -var - TV: TTimeVal; -begin - gettimeofday(TV, nil); - Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; -{$ELSE} -var - TV: TimeVal; -begin - fpgettimeofday(@TV, nil); - Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; -{$ENDIF} -{$ENDIF} -end; - -{==============================================================================} - -function SetUTTime(Newdt: TDateTime): Boolean; -{$IFDEF MSWINDOWS} -{$IFNDEF FPC} -var - st: TSystemTime; -begin - DateTimeToSystemTime(newdt,st); - Result := SetSystemTime(st); -{$ELSE} -var - st: SysUtils.TSystemTime; - stw: Windows.TSystemTime; -begin - DateTimeToSystemTime(newdt,st); - stw.wYear := st.Year; - stw.wMonth := st.Month; - stw.wDay := st.Day; - stw.wHour := st.Hour; - stw.wMinute := st.Minute; - stw.wSecond := st.Second; - stw.wMilliseconds := st.Millisecond; - Result := SetSystemTime(stw); -{$ENDIF} -{$ELSE} -{$IFNDEF FPC} -var - TV: TTimeVal; - d: double; - TZ: Ttimezone; - PZ: PTimeZone; -begin - TZ.tz_minuteswest := 0; - TZ.tz_dsttime := 0; - PZ := @TZ; - gettimeofday(TV, PZ); - d := (newdt - UnixDateDelta) * 86400; - TV.tv_sec := trunc(d); - TV.tv_usec := trunc(frac(d) * 1000000); - Result := settimeofday(TV, TZ) <> -1; -{$ELSE} -var - TV: TimeVal; - d: double; -begin - d := (newdt - UnixDateDelta) * 86400; - TV.tv_sec := trunc(d); - TV.tv_usec := trunc(frac(d) * 1000000); - Result := fpsettimeofday(@TV, nil) <> -1; -{$ENDIF} -{$ENDIF} -end; - -{==============================================================================} - -{$IFNDEF MSWINDOWS} -function GetTick: LongWord; -var - Stamp: TTimeStamp; -begin - Stamp := DateTimeToTimeStamp(Now); - Result := Stamp.Time; -end; -{$ELSE} -function GetTick: LongWord; -var - tick, freq: TLargeInteger; -{$IFDEF VER100} - x: TLargeInteger; -{$ENDIF} -begin - if Windows.QueryPerformanceFrequency(freq) then - begin - Windows.QueryPerformanceCounter(tick); -{$IFDEF VER100} - x.QuadPart := (tick.QuadPart / freq.QuadPart) * 1000; - Result := x.LowPart; -{$ELSE} - Result := Trunc((tick / freq) * 1000) and High(LongWord) -{$ENDIF} - end - else - Result := Windows.GetTickCount; -end; -{$ENDIF} - -{==============================================================================} - -function TickDelta(TickOld, TickNew: LongWord): LongWord; -begin -//if DWord is signed type (older Deplhi), -// then it not work properly on differencies larger then maxint! - Result := 0; - if TickOld <> TickNew then - begin - if TickNew < TickOld then - begin - TickNew := TickNew + LongWord(MaxInt) + 1; - TickOld := TickOld + LongWord(MaxInt) + 1; - end; - Result := TickNew - TickOld; - if TickNew < TickOld then - if Result > 0 then - Result := 0 - Result; - end; -end; - -{==============================================================================} - -function CodeInt(Value: Word): Ansistring; -begin - setlength(result, 2); - result[1] := AnsiChar(Value div 256); - result[2] := AnsiChar(Value mod 256); -// Result := AnsiChar(Value div 256) + AnsiChar(Value mod 256) -end; - -{==============================================================================} - -function DecodeInt(const Value: Ansistring; Index: Integer): Word; -var - x, y: Byte; -begin - if Length(Value) > Index then - x := Ord(Value[Index]) - else - x := 0; - if Length(Value) >= (Index + 1) then - y := Ord(Value[Index + 1]) - else - y := 0; - Result := x * 256 + y; -end; - -{==============================================================================} - -function CodeLongInt(Value: Longint): Ansistring; -var - x, y: word; -begin - // this is fix for negative numbers on systems where longint = integer - x := (Value shr 16) and integer($ffff); - y := Value and integer($ffff); - setlength(result, 4); - result[1] := AnsiChar(x div 256); - result[2] := AnsiChar(x mod 256); - result[3] := AnsiChar(y div 256); - result[4] := AnsiChar(y mod 256); -end; - -{==============================================================================} - -function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt; -var - x, y: Byte; - xl, yl: Byte; -begin - if Length(Value) > Index then - x := Ord(Value[Index]) - else - x := 0; - if Length(Value) >= (Index + 1) then - y := Ord(Value[Index + 1]) - else - y := 0; - if Length(Value) >= (Index + 2) then - xl := Ord(Value[Index + 2]) - else - xl := 0; - if Length(Value) >= (Index + 3) then - yl := Ord(Value[Index + 3]) - else - yl := 0; - Result := ((x * 256 + y) * 65536) + (xl * 256 + yl); -end; - -{==============================================================================} - -function DumpStr(const Buffer: Ansistring): string; -var - n: Integer; -begin - Result := ''; - for n := 1 to Length(Buffer) do - Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2); -end; - -{==============================================================================} - -function DumpExStr(const Buffer: Ansistring): string; -var - n: Integer; - x: Byte; -begin - Result := ''; - for n := 1 to Length(Buffer) do - begin - x := Ord(Buffer[n]); - if x in [65..90, 97..122] then - Result := Result + ' +''' + char(x) + '''' - else - Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2); - end; -end; - -{==============================================================================} - -procedure Dump(const Buffer: AnsiString; DumpFile: string); -var - f: Text; -begin - AssignFile(f, DumpFile); - if FileExists(DumpFile) then - DeleteFile(DumpFile); - Rewrite(f); - try - Writeln(f, DumpStr(Buffer)); - finally - CloseFile(f); - end; -end; - -{==============================================================================} - -procedure DumpEx(const Buffer: AnsiString; DumpFile: string); -var - f: Text; -begin - AssignFile(f, DumpFile); - if FileExists(DumpFile) then - DeleteFile(DumpFile); - Rewrite(f); - try - Writeln(f, DumpExStr(Buffer)); - finally - CloseFile(f); - end; -end; - -{==============================================================================} - -function TrimSPLeft(const S: string): string; -var - I, L: Integer; -begin - Result := ''; - if S = '' then - Exit; - L := Length(S); - I := 1; - while (I <= L) and (S[I] = ' ') do - Inc(I); - Result := Copy(S, I, Maxint); -end; - -{==============================================================================} - -function TrimSPRight(const S: string): string; -var - I: Integer; -begin - Result := ''; - if S = '' then - Exit; - I := Length(S); - while (I > 0) and (S[I] = ' ') do - Dec(I); - Result := Copy(S, 1, I); -end; - -{==============================================================================} - -function TrimSP(const S: string): string; -begin - Result := TrimSPLeft(s); - Result := TrimSPRight(Result); -end; - -{==============================================================================} - -function SeparateLeft(const Value, Delimiter: string): string; -var - x: Integer; -begin - x := Pos(Delimiter, Value); - if x < 1 then - Result := Value - else - Result := Copy(Value, 1, x - 1); -end; - -{==============================================================================} - -function SeparateRight(const Value, Delimiter: string): string; -var - x: Integer; -begin - x := Pos(Delimiter, Value); - if x > 0 then - x := x + Length(Delimiter) - 1; - Result := Copy(Value, x + 1, Length(Value) - x); -end; - -{==============================================================================} - -function GetParameter(const Value, Parameter: string): string; -var - s: string; - v: string; -begin - Result := ''; - v := Value; - while v <> '' do - begin - s := Trim(FetchEx(v, ';', '"')); - if Pos(Uppercase(parameter), Uppercase(s)) = 1 then - begin - Delete(s, 1, Length(Parameter)); - s := Trim(s); - if s = '' then - Break; - if s[1] = '=' then - begin - Result := Trim(SeparateRight(s, '=')); - Result := UnquoteStr(Result, '"'); - break; - end; - end; - end; -end; - -{==============================================================================} - -procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings); -var - s: string; -begin - Parameters.Clear; - while Value <> '' do - begin - s := Trim(FetchEx(Value, Delimiter, '"')); - Parameters.Add(s); - end; -end; - -{==============================================================================} - -procedure ParseParameters(Value: string; const Parameters: TStrings); -begin - ParseParametersEx(Value, ';', Parameters); -end; - -{==============================================================================} - -function IndexByBegin(Value: string; const List: TStrings): integer; -var - n: integer; - s: string; -begin - Result := -1; - Value := uppercase(Value); - for n := 0 to List.Count -1 do - begin - s := UpperCase(List[n]); - if Pos(Value, s) = 1 then - begin - Result := n; - Break; - end; - end; -end; - -{==============================================================================} - -function GetEmailAddr(const Value: string): string; -var - s: string; -begin - s := SeparateRight(Value, '<'); - s := SeparateLeft(s, '>'); - Result := Trim(s); -end; - -{==============================================================================} - -function GetEmailDesc(Value: string): string; -var - s: string; -begin - Value := Trim(Value); - s := SeparateRight(Value, '"'); - if s <> Value then - s := SeparateLeft(s, '"') - else - begin - s := SeparateLeft(Value, '<'); - if s = Value then - begin - s := SeparateRight(Value, '('); - if s <> Value then - s := SeparateLeft(s, ')') - else - s := ''; - end; - end; - Result := Trim(s); -end; - -{==============================================================================} - -function StrToHex(const Value: Ansistring): string; -var - n: Integer; -begin - Result := ''; - for n := 1 to Length(Value) do - Result := Result + IntToHex(Byte(Value[n]), 2); - Result := LowerCase(Result); -end; - -{==============================================================================} - -function IntToBin(Value: Integer; Digits: Byte): string; -var - x, y, n: Integer; -begin - Result := ''; - x := Value; - repeat - y := x mod 2; - x := x div 2; - if y > 0 then - Result := '1' + Result - else - Result := '0' + Result; - until x = 0; - x := Length(Result); - for n := x to Digits - 1 do - Result := '0' + Result; -end; - -{==============================================================================} - -function BinToInt(const Value: string): Integer; -var - n: Integer; -begin - Result := 0; - for n := 1 to Length(Value) do - begin - if Value[n] = '0' then - Result := Result * 2 - else - if Value[n] = '1' then - Result := Result * 2 + 1 - else - Break; - end; -end; - -{==============================================================================} - -function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path, - Para: string): string; -var - x, y: Integer; - sURL: string; - s: string; - s1, s2: string; -begin - Prot := 'http'; - User := ''; - Pass := ''; - Port := '80'; - Para := ''; - - x := Pos('://', URL); - if x > 0 then - begin - Prot := SeparateLeft(URL, '://'); - sURL := SeparateRight(URL, '://'); - end - else - sURL := URL; - if UpperCase(Prot) = 'HTTPS' then - Port := '443'; - if UpperCase(Prot) = 'FTP' then - Port := '21'; - x := Pos('@', sURL); - y := Pos('/', sURL); - if (x > 0) and ((x < y) or (y < 1))then - begin - s := SeparateLeft(sURL, '@'); - sURL := SeparateRight(sURL, '@'); - x := Pos(':', s); - if x > 0 then - begin - User := SeparateLeft(s, ':'); - Pass := SeparateRight(s, ':'); - end - else - User := s; - end; - x := Pos('/', sURL); - if x > 0 then - begin - s1 := SeparateLeft(sURL, '/'); - s2 := SeparateRight(sURL, '/'); - end - else - begin - s1 := sURL; - s2 := ''; - end; - if Pos('[', s1) = 1 then - begin - Host := Separateleft(s1, ']'); - Delete(Host, 1, 1); - s1 := SeparateRight(s1, ']'); - if Pos(':', s1) = 1 then - Port := SeparateRight(s1, ':'); - end - else - begin - x := Pos(':', s1); - if x > 0 then - begin - Host := SeparateLeft(s1, ':'); - Port := SeparateRight(s1, ':'); - end - else - Host := s1; - end; - Result := '/' + s2; - x := Pos('?', s2); - if x > 0 then - begin - Path := '/' + SeparateLeft(s2, '?'); - Para := SeparateRight(s2, '?'); - end - else - Path := '/' + s2; - if Host = '' then - Host := 'localhost'; -end; - -{==============================================================================} - -function ReplaceString(Value, Search, Replace: AnsiString): AnsiString; -var - x, l, ls, lr: Integer; -begin - if (Value = '') or (Search = '') then - begin - Result := Value; - Exit; - end; - ls := Length(Search); - lr := Length(Replace); - Result := ''; - x := Pos(Search, Value); - while x > 0 do - begin - {$IFNDEF CIL} - l := Length(Result); - SetLength(Result, l + x - 1); - Move(Pointer(Value)^, Pointer(@Result[l + 1])^, x - 1); - {$ELSE} - Result:=Result+Copy(Value,1,x-1); - {$ENDIF} - {$IFNDEF CIL} - l := Length(Result); - SetLength(Result, l + lr); - Move(Pointer(Replace)^, Pointer(@Result[l + 1])^, lr); - {$ELSE} - Result:=Result+Replace; - {$ENDIF} - Delete(Value, 1, x - 1 + ls); - x := Pos(Search, Value); - end; - Result := Result + Value; -end; - -{==============================================================================} - -function RPosEx(const Sub, Value: string; From: integer): Integer; -var - n: Integer; - l: Integer; -begin - result := 0; - l := Length(Sub); - for n := From - l + 1 downto 1 do - begin - if Copy(Value, n, l) = Sub then - begin - result := n; - break; - end; - end; -end; - -{==============================================================================} - -function RPos(const Sub, Value: String): Integer; -begin - Result := RPosEx(Sub, Value, Length(Value)); -end; - -{==============================================================================} - -function FetchBin(var Value: string; const Delimiter: string): string; -var - s: string; -begin - Result := SeparateLeft(Value, Delimiter); - s := SeparateRight(Value, Delimiter); - if s = Value then - Value := '' - else - Value := s; -end; - -{==============================================================================} - -function Fetch(var Value: string; const Delimiter: string): string; -begin - Result := FetchBin(Value, Delimiter); - Result := TrimSP(Result); - Value := TrimSP(Value); -end; - -{==============================================================================} - -function FetchEx(var Value: string; const Delimiter, Quotation: string): string; -var - b: Boolean; -begin - Result := ''; - b := False; - while Length(Value) > 0 do - begin - if b then - begin - if Pos(Quotation, Value) = 1 then - b := False; - Result := Result + Value[1]; - Delete(Value, 1, 1); - end - else - begin - if Pos(Delimiter, Value) = 1 then - begin - Delete(Value, 1, Length(delimiter)); - break; - end; - b := Pos(Quotation, Value) = 1; - Result := Result + Value[1]; - Delete(Value, 1, 1); - end; - end; -end; - -{==============================================================================} - -function IsBinaryString(const Value: AnsiString): Boolean; -var - n: integer; -begin - Result := False; - for n := 1 to Length(Value) do - if Value[n] in [#0..#8, #10..#31] then - //ignore null-terminated strings - if not ((n = Length(value)) and (Value[n] = AnsiChar(#0))) then - begin - Result := True; - Break; - end; -end; - -{==============================================================================} - -function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer; -var - n, l: integer; -begin - Result := -1; - Terminator := ''; - l := length(value); - for n := 1 to l do - if value[n] in [#$0d, #$0a] then - begin - Result := n; - Terminator := Value[n]; - if n <> l then - case value[n] of - #$0d: - if value[n + 1] = #$0a then - Terminator := #$0d + #$0a; - #$0a: - if value[n + 1] = #$0d then - Terminator := #$0a + #$0d; - end; - Break; - end; -end; - -{==============================================================================} - -Procedure StringsTrim(const Value: TStrings); -var - n: integer; -begin - for n := Value.Count - 1 downto 0 do - if Value[n] = '' then - Value.Delete(n) - else - Break; -end; - -{==============================================================================} - -function PosFrom(const SubStr, Value: String; From: integer): integer; -var - ls,lv: integer; -begin - Result := 0; - ls := Length(SubStr); - lv := Length(Value); - if (ls = 0) or (lv = 0) then - Exit; - if From < 1 then - From := 1; - while (ls + from - 1) <= (lv) do - begin - {$IFNDEF CIL} - if CompareMem(@SubStr[1],@Value[from],ls) then - {$ELSE} - if SubStr = copy(Value, from, ls) then - {$ENDIF} - begin - result := from; - break; - end - else - inc(from); - end; -end; - -{==============================================================================} - -{$IFNDEF CIL} -function IncPoint(const p: pointer; Value: integer): pointer; -begin - Result := PAnsiChar(p) + Value; -end; -{$ENDIF} - -{==============================================================================} -//improved by 'DoggyDawg' -function GetBetween(const PairBegin, PairEnd, Value: string): string; -var - n: integer; - x: integer; - s: string; - lenBegin: integer; - lenEnd: integer; - str: string; - max: integer; -begin - lenBegin := Length(PairBegin); - lenEnd := Length(PairEnd); - n := Length(Value); - if (Value = PairBegin + PairEnd) then - begin - Result := '';//nothing between - exit; - end; - if (n < lenBegin + lenEnd) then - begin - Result := Value; - exit; - end; - s := SeparateRight(Value, PairBegin); - if (s = Value) then - begin - Result := Value; - exit; - end; - n := Pos(PairEnd, s); - if (n = 0) then - begin - Result := Value; - exit; - end; - Result := ''; - x := 1; - max := Length(s) - lenEnd + 1; - for n := 1 to max do - begin - str := copy(s, n, lenEnd); - if (str = PairEnd) then - begin - Dec(x); - if (x <= 0) then - Break; - end; - str := copy(s, n, lenBegin); - if (str = PairBegin) then - Inc(x); - Result := Result + s[n]; - end; -end; - -{==============================================================================} - -function CountOfChar(const Value: string; Chr: char): integer; -var - n: integer; -begin - Result := 0; - for n := 1 to Length(Value) do - if Value[n] = chr then - Inc(Result); -end; - -{==============================================================================} -// ! do not use AnsiExtractQuotedStr, it's very buggy and can crash application! -function UnquoteStr(const Value: string; Quote: Char): string; -var - n: integer; - inq, dq: Boolean; - c, cn: char; -begin - Result := ''; - if Value = '' then - Exit; - if Value = Quote + Quote then - Exit; - inq := False; - dq := False; - for n := 1 to Length(Value) do - begin - c := Value[n]; - if n <> Length(Value) then - cn := Value[n + 1] - else - cn := #0; - if c = quote then - if dq then - dq := False - else - if not inq then - inq := True - else - if cn = quote then - begin - Result := Result + Quote; - dq := True; - end - else - inq := False - else - Result := Result + c; - end; -end; - -{==============================================================================} - -function QuoteStr(const Value: string; Quote: Char): string; -var - n: integer; -begin - Result := ''; - for n := 1 to length(value) do - begin - Result := result + Value[n]; - if value[n] = Quote then - Result := Result + Quote; - end; - Result := Quote + Result + Quote; -end; - -{==============================================================================} - -procedure HeadersToList(const Value: TStrings); -var - n, x, y: integer; - s: string; -begin - for n := 0 to Value.Count -1 do - begin - s := Value[n]; - x := Pos(':', s); - if x > 0 then - begin - y:= Pos('=',s); - if not ((y > 0) and (y < x)) then - begin - s[x] := '='; - Value[n] := s; - end; - end; - end; -end; - -{==============================================================================} - -procedure ListToHeaders(const Value: TStrings); -var - n, x: integer; - s: string; -begin - for n := 0 to Value.Count -1 do - begin - s := Value[n]; - x := Pos('=', s); - if x > 0 then - begin - s[x] := ':'; - Value[n] := s; - end; - end; -end; - -{==============================================================================} - -function SwapBytes(Value: integer): integer; -var - s: AnsiString; - x, y, xl, yl: Byte; -begin - s := CodeLongInt(Value); - x := Ord(s[4]); - y := Ord(s[3]); - xl := Ord(s[2]); - yl := Ord(s[1]); - Result := ((x * 256 + y) * 65536) + (xl * 256 + yl); -end; - -{==============================================================================} - -function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString; -var - x: integer; -{$IFDEF CIL} - buf: Array of Byte; -{$ENDIF} -begin -{$IFDEF CIL} - Setlength(buf, Len); - x := Stream.read(buf, Len); - SetLength(buf, x); - Result := StringOf(Buf); -{$ELSE} - Setlength(Result, Len); - x := Stream.read(PAnsiChar(Result)^, Len); - SetLength(Result, x); -{$ENDIF} -end; - -{==============================================================================} - -procedure WriteStrToStream(const Stream: TStream; Value: AnsiString); -{$IFDEF CIL} -var - buf: Array of Byte; -{$ENDIF} -begin -{$IFDEF CIL} - buf := BytesOf(Value); - Stream.Write(buf,length(Value)); -{$ELSE} - Stream.Write(PAnsiChar(Value)^, Length(Value)); -{$ENDIF} -end; - -{==============================================================================} -function GetTempFile(const Dir, prefix: AnsiString): AnsiString; -{$IFNDEF FPC} -{$IFDEF MSWINDOWS} -var - Path: AnsiString; - x: integer; -{$ENDIF} -{$ENDIF} -begin -{$IFDEF FPC} - Result := GetTempFileName(Dir, Prefix); -{$ELSE} - {$IFNDEF MSWINDOWS} - Result := tempnam(Pointer(Dir), Pointer(prefix)); - {$ELSE} - {$IFDEF CIL} - Result := System.IO.Path.GetTempFileName; - {$ELSE} - if Dir = '' then - begin - SetLength(Path, MAX_PATH); - x := GetTempPath(Length(Path), PChar(Path)); - SetLength(Path, x); - end - else - Path := Dir; - x := Length(Path); - if Path[x] <> '\' then - Path := Path + '\'; - SetLength(Result, MAX_PATH + 1); - GetTempFileName(PChar(Path), PChar(Prefix), 0, PChar(Result)); - Result := PChar(Result); - SetFileattributes(PChar(Result), GetFileAttributes(PChar(Result)) or FILE_ATTRIBUTE_TEMPORARY); - {$ENDIF} - {$ENDIF} -{$ENDIF} -end; - -{==============================================================================} - -function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString; -begin - if length(value) >= len then - Result := Copy(value, 1, len) - else - Result := Value + StringOfChar(Pad, len - length(value)); -end; - -{==============================================================================} - -function NormalizeHeader(Value: TStrings; var Index: Integer): string; -var - s, t: string; - n: Integer; -begin - s := Value[Index]; - Inc(Index); - if s <> '' then - while (Value.Count - 1) > Index do - begin - t := Value[Index]; - if t = '' then - Break; - for n := 1 to Length(t) do - if t[n] = #9 then - t[n] := ' '; - if not(AnsiChar(t[1]) in [' ', '"', ':', '=']) then - Break - else - begin - s := s + ' ' + Trim(t); - Inc(Index); - end; - end; - Result := TrimRight(s); -end; - -{==============================================================================} -var - n: integer; -begin - for n := 1 to 12 do - begin - CustomMonthNames[n] := ShortMonthNames[n]; - MyMonthNames[0, n] := ShortMonthNames[n]; - end; -end. diff --git a/addons/synapse/synsock.pas b/addons/synapse/synsock.pas deleted file mode 100644 index c1cad2e..0000000 --- a/addons/synapse/synsock.pas +++ /dev/null @@ -1,77 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 005.002.000 | -|==============================================================================| -| Content: Socket Independent Platform Layer | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2001-20010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@exclude} - -unit synsock; - -{$MINENUMSIZE 4} - -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -{$IFDEF CIL} - {$I ssdotnet.pas} -{$ELSE} - {$IFDEF MSWINDOWS} - {$I sswin32.pas} - {$ELSE} - {$IFDEF WINCE} - {$I sswin32.pas} //not complete yet! - {$ELSE} - {$IFDEF FPC} - {$I ssfpc.pas} - {$ELSE} - {$I sslinux.pas} - {$ENDIF} - {$ENDIF} - {$ENDIF} -{$ENDIF} - -end. - diff --git a/addons/synapse/tlntsend.pas b/addons/synapse/tlntsend.pas deleted file mode 100644 index 557266c..0000000 --- a/addons/synapse/tlntsend.pas +++ /dev/null @@ -1,364 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.003.001 | -|==============================================================================| -| Content: TELNET and SSH2 client | -|==============================================================================| -| Copyright (c)1999-2010, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2002-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(Telnet script client) - -Used RFC: RFC-854 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit tlntsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil; - -const - cTelnetProtocol = '23'; - cSSHProtocol = '22'; - - TLNT_EOR = #239; - TLNT_SE = #240; - TLNT_NOP = #241; - TLNT_DATA_MARK = #242; - TLNT_BREAK = #243; - TLNT_IP = #244; - TLNT_AO = #245; - TLNT_AYT = #246; - TLNT_EC = #247; - TLNT_EL = #248; - TLNT_GA = #249; - TLNT_SB = #250; - TLNT_WILL = #251; - TLNT_WONT = #252; - TLNT_DO = #253; - TLNT_DONT = #254; - TLNT_IAC = #255; - -type - {:@abstract(State of telnet protocol). Used internaly by TTelnetSend.} - TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT, - tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC); - - {:@abstract(Class with implementation of Telnet/SSH script client.) - - Note: Are you missing properties for specify server address and port? Look to - parent @link(TSynaClient) too!} - TTelnetSend = class(TSynaClient) - private - FSock: TTCPBlockSocket; - FBuffer: Ansistring; - FState: TTelnetState; - FSessionLog: Ansistring; - FSubNeg: Ansistring; - FSubType: Ansichar; - FTermType: Ansistring; - function Connect: Boolean; - function Negotiate(const Buf: Ansistring): Ansistring; - procedure FilterHook(Sender: TObject; var Value: AnsiString); - public - constructor Create; - destructor Destroy; override; - - {:Connects to Telnet server.} - function Login: Boolean; - - {:Connects to SSH2 server and login by Username and Password properties. - - You must use some of SSL plugins with SSH support. For exammple CryptLib.} - function SSHLogin: Boolean; - - {:Logout from telnet server.} - procedure Logout; - - {:Send this data to telnet server.} - procedure Send(const Value: string); - - {:Reading data from telnet server until Value is readed. If it is not readed - until timeout, result is @false. Otherwise result is @true.} - function WaitFor(const Value: string): Boolean; - - {:Read data terminated by terminator from telnet server.} - function RecvTerminated(const Terminator: string): string; - - {:Read string from telnet server.} - function RecvString: string; - published - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TTCPBlockSocket read FSock; - - {:all readed datas in this session (from connect) is stored in this large - string.} - property SessionLog: Ansistring read FSessionLog write FSessionLog; - - {:Terminal type indentification. By default is 'SYNAPSE'.} - property TermType: Ansistring read FTermType write FTermType; - end; - -implementation - -constructor TTelnetSend.Create; -begin - inherited Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FSock.OnReadFilter := FilterHook; - FTimeout := 60000; - FTargetPort := cTelnetProtocol; - FSubNeg := ''; - FSubType := #0; - FTermType := 'SYNAPSE'; -end; - -destructor TTelnetSend.Destroy; -begin - FSock.Free; - inherited Destroy; -end; - -function TTelnetSend.Connect: Boolean; -begin - // Do not call this function! It is calling by LOGIN method! - FBuffer := ''; - FSessionLog := ''; - FState := tsDATA; - FSock.CloseSocket; - FSock.LineBuffer := ''; - FSock.Bind(FIPInterface, cAnyPort); - FSock.Connect(FTargetHost, FTargetPort); - Result := FSock.LastError = 0; -end; - -function TTelnetSend.RecvTerminated(const Terminator: string): string; -begin - Result := FSock.RecvTerminated(FTimeout, Terminator); -end; - -function TTelnetSend.RecvString: string; -begin - Result := FSock.RecvTerminated(FTimeout, CRLF); -end; - -function TTelnetSend.WaitFor(const Value: string): Boolean; -begin - Result := FSock.RecvTerminated(FTimeout, Value) <> ''; -end; - -procedure TTelnetSend.FilterHook(Sender: TObject; var Value: AnsiString); -begin - Value := Negotiate(Value); - FSessionLog := FSessionLog + Value; -end; - -function TTelnetSend.Negotiate(const Buf: Ansistring): Ansistring; -var - n: integer; - c: Ansichar; - Reply: Ansistring; - SubReply: Ansistring; -begin - Result := ''; - for n := 1 to Length(Buf) do - begin - c := Buf[n]; - Reply := ''; - case FState of - tsData: - if c = TLNT_IAC then - FState := tsIAC - else - Result := Result + c; - - tsIAC: - case c of - TLNT_IAC: - begin - FState := tsData; - Result := Result + TLNT_IAC; - end; - TLNT_WILL: - FState := tsIAC_WILL; - TLNT_WONT: - FState := tsIAC_WONT; - TLNT_DONT: - FState := tsIAC_DONT; - TLNT_DO: - FState := tsIAC_DO; - TLNT_EOR: - FState := tsDATA; - TLNT_SB: - begin - FState := tsIAC_SB; - FSubType := #0; - FSubNeg := ''; - end; - else - FState := tsData; - end; - - tsIAC_WILL: - begin - case c of - #3: //suppress GA - Reply := TLNT_DO; - else - Reply := TLNT_DONT; - end; - FState := tsData; - end; - - tsIAC_WONT: - begin - Reply := TLNT_DONT; - FState := tsData; - end; - - tsIAC_DO: - begin - case c of - #24: //termtype - Reply := TLNT_WILL; - else - Reply := TLNT_WONT; - end; - FState := tsData; - end; - - tsIAC_DONT: - begin - Reply := TLNT_WONT; - FState := tsData; - end; - - tsIAC_SB: - begin - FSubType := c; - FState := tsIAC_SBDATA; - end; - - tsIAC_SBDATA: - begin - if c = TLNT_IAC then - FState := tsSBDATA_IAC - else - FSubNeg := FSubNeg + c; - end; - - tsSBDATA_IAC: - case c of - TLNT_IAC: - begin - FState := tsIAC_SBDATA; - FSubNeg := FSubNeg + c; - end; - TLNT_SE: - begin - SubReply := ''; - case FSubType of - #24: //termtype - begin - if (FSubNeg <> '') and (FSubNeg[1] = #1) then - SubReply := #0 + FTermType; - end; - end; - Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE); - FState := tsDATA; - end; - else - FState := tsDATA; - end; - - else - FState := tsData; - end; - if Reply <> '' then - Sock.SendString(TLNT_IAC + Reply + c); - end; - -end; - -procedure TTelnetSend.Send(const Value: string); -begin - Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC)); -end; - -function TTelnetSend.Login: Boolean; -begin - Result := False; - if not Connect then - Exit; - Result := True; -end; - -function TTelnetSend.SSHLogin: Boolean; -begin - Result := False; - if Connect then - begin - FSock.SSL.SSLType := LT_SSHv2; - FSock.SSL.Username := FUsername; - FSock.SSL.Password := FPassword; - FSock.SSLDoConnect; - Result := FSock.LastError = 0; - end; -end; - -procedure TTelnetSend.Logout; -begin - FSock.CloseSocket; -end; - - -end. diff --git a/demos/calendar_demo/CelendarAPI.dpr b/demos/calendar_demo/CelendarAPI.dpr deleted file mode 100644 index 6590eac..0000000 --- a/demos/calendar_demo/CelendarAPI.dpr +++ /dev/null @@ -1,22 +0,0 @@ -program CelendarAPI; - -uses - Forms, - main in 'main.pas' {Form1}, - GCalendar in '..\GCalendar.pas', - GDataCommon in '..\GDataCommon.pas', - GHelper in '..\GHelper.pas', - GoogleLogin in '..\GoogleLogin.pas', - GData in '..\GData.pas', - newevent in 'newevent.pas' {Form2}, - NativeXml in '..\..\Utils\NativeXml.pas'; - -{$R *.res} - -begin - Application.Initialize; - Application.MainFormOnTaskbar := True; - Application.CreateForm(TForm1, Form1); - Application.CreateForm(TForm2, Form2); - Application.Run; -end. diff --git a/demos/calendar_demo/CelendarAPI.dproj b/demos/calendar_demo/CelendarAPI.dproj deleted file mode 100644 index 2d106c9..0000000 --- a/demos/calendar_demo/CelendarAPI.dproj +++ /dev/null @@ -1,115 +0,0 @@ -п»ї - - {9F62CA46-D0D3-4082-A250-5A01F95A583F} - 12.0 - CelendarAPI.dpr - Debug - DCC32 - - - true - - - true - Base - true - - - true - Base - true - - - CelendarAPI.exe - 00400000 - WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias) - x86 - false - false - false - false - false - - - false - RELEASE;$(DCC_Define) - 0 - false - - - DEBUG;$(DCC_Define) - - - - MainSource - - -

Form1
- - - - - - - -
Form2
- - - - Base - - - Cfg_2 - Base - - - Cfg_1 - Base - - - - - Delphi.Personality.12 - - - - - CelendarAPI.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 - - - - - 12 - - diff --git a/demos/calendar_demo/CelendarAPI.res b/demos/calendar_demo/CelendarAPI.res deleted file mode 100644 index fc1937e..0000000 Binary files a/demos/calendar_demo/CelendarAPI.res and /dev/null differ diff --git a/demos/calendar_demo/main.dfm b/demos/calendar_demo/main.dfm deleted file mode 100644 index 76a82ec..0000000 --- a/demos/calendar_demo/main.dfm +++ /dev/null @@ -1,282 +0,0 @@ -object Form1: TForm1 - Left = 0 - Top = 0 - Caption = #1057#1086#1073#1099#1090#1080#1103' '#1074' '#1082#1072#1083#1077#1085#1076#1072#1088#1077 - ClientHeight = 322 - ClientWidth = 500 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - PixelsPerInch = 96 - TextHeight = 13 - object Label1: TLabel - Left = 8 - Top = 8 - Width = 25 - Height = 13 - Caption = 'Login' - end - object Label2: TLabel - Left = 8 - Top = 32 - Width = 46 - Height = 13 - Caption = 'Password' - end - object Label3: TLabel - Left = 8 - Top = 56 - Width = 58 - Height = 13 - Caption = #1057#1086#1089#1090#1086#1103#1085#1080#1077':' - end - object Label4: TLabel - Left = 72 - Top = 56 - Width = 82 - Height = 13 - Caption = #1053#1077#1090' '#1089#1086#1077#1076#1080#1085#1077#1085#1080#1103 - end - object Label5: TLabel - Left = 8 - Top = 80 - Width = 149 - Height = 13 - Caption = #1042#1089#1077' '#1082#1072#1083#1077#1085#1076#1072#1088#1080' '#1087#1086#1083#1100#1079#1086#1074#1072#1090#1077#1083#1103 - end - object Label6: TLabel - Left = 407 - Top = 80 - Width = 28 - Height = 13 - Caption = #1042#1089#1077#1075#1086 - end - object Label7: TLabel - Left = 448 - Top = 80 - Width = 6 - Height = 13 - Caption = '0' - end - object Label8: TLabel - Left = 27 - Top = 102 - Width = 112 - Height = 13 - Caption = #1057#1086#1073#1099#1090#1080#1103' '#1074' '#1082#1072#1083#1077#1085#1076#1072#1088#1077 - end - object Label9: TLabel - Left = 244 - Top = 8 - Width = 246 - Height = 38 - Alignment = taCenter - Caption = #1055#1088#1080#1084#1077#1088' '#1088#1072#1073#1086#1090#1099' '#1089' '#1089#1086#1073#1099#1090#1080#1103#1084#1080' '#13#10#1074' '#1082#1072#1083#1077#1085#1076#1072#1088#1103#1093 - Font.Charset = DEFAULT_CHARSET - Font.Color = clRed - Font.Height = -16 - Font.Name = 'Tahoma' - Font.Style = [fsBold] - ParentFont = False - end - object Edit1: TEdit - Left = 60 - Top = 5 - Width = 97 - Height = 21 - TabOrder = 0 - end - object Edit2: TEdit - Left = 60 - Top = 29 - Width = 97 - Height = 21 - TabOrder = 1 - end - object Button1: TButton - Left = 163 - Top = 16 - Width = 75 - Height = 25 - Caption = 'Login' - TabOrder = 2 - OnClick = Button1Click - end - object ComboBox1: TComboBox - Left = 163 - Top = 77 - Width = 238 - Height = 21 - Style = csDropDownList - TabOrder = 3 - OnChange = ComboBox1Change - end - object ComboBox2: TComboBox - Left = 163 - Top = 99 - Width = 238 - Height = 21 - Style = csDropDownList - TabOrder = 4 - OnChange = ComboBox2Change - end - object GroupBox1: TGroupBox - Left = 0 - Top = 126 - Width = 500 - Height = 196 - Align = alBottom - Caption = #1048#1085#1092#1086#1088#1084#1072#1094#1080#1103' '#1087#1086' '#1089#1086#1073#1099#1090#1080#1102 - TabOrder = 5 - object Label11: TLabel - Left = 12 - Top = 20 - Width = 46 - Height = 13 - Caption = #1057#1086#1079#1076#1072#1085#1086' ' - end - object Label12: TLabel - Left = 72 - Top = 21 - Width = 37 - Height = 13 - Caption = 'Label12' - end - object Label13: TLabel - Left = 12 - Top = 39 - Width = 48 - Height = 13 - Caption = #1048#1079#1084#1077#1085#1077#1085#1086 - end - object Label14: TLabel - Left = 72 - Top = 40 - Width = 37 - Height = 13 - Caption = 'Label14' - end - object Label15: TLabel - Left = 12 - Top = 63 - Width = 53 - Height = 13 - Caption = #1047#1072#1075#1086#1083#1086#1074#1086#1082 - end - object Label17: TLabel - Left = 12 - Top = 117 - Width = 87 - Height = 13 - Caption = #1053#1072#1095#1072#1083#1086' '#1089#1086#1073#1099#1090#1080#1103':' - end - object Label18: TLabel - Left = 208 - Top = 117 - Width = 81 - Height = 13 - Caption = #1050#1086#1085#1077#1094' '#1089#1086#1073#1099#1090#1080#1103':' - end - object Label21: TLabel - Left = 12 - Top = 145 - Width = 111 - Height = 13 - Caption = #1052#1077#1090#1086#1076#1099' '#1086#1087#1086#1074#1077#1097#1077#1085#1080#1103':' - end - object Label16: TLabel - Left = 12 - Top = 90 - Width = 49 - Height = 13 - Caption = #1054#1087#1080#1089#1072#1085#1080#1077 - end - object CheckBox1: TCheckBox - Left = 136 - Top = 141 - Width = 45 - Height = 17 - Caption = 'SMS' - TabOrder = 0 - end - object CheckBox2: TCheckBox - Left = 187 - Top = 141 - Width = 48 - Height = 17 - Caption = 'E-mail' - TabOrder = 1 - end - object CheckBox3: TCheckBox - Left = 241 - Top = 141 - Width = 124 - Height = 17 - Caption = #1042#1089#1087#1083#1099#1074#1072#1102#1097#1077#1077' '#1086#1082#1085#1086 - TabOrder = 2 - end - object Edit4: TEdit - Left = 105 - Top = 59 - Width = 344 - Height = 21 - TabOrder = 3 - end - object Edit5: TEdit - Left = 105 - Top = 86 - Width = 344 - Height = 21 - TabOrder = 4 - end - object DateTimePicker1: TDateTimePicker - Left = 105 - Top = 113 - Width = 97 - Height = 21 - Date = 40264.649768275460000000 - Time = 40264.649768275460000000 - TabOrder = 5 - end - object DateTimePicker4: TDateTimePicker - Left = 301 - Top = 113 - Width = 97 - Height = 21 - Date = 40264.649768275460000000 - Time = 40264.649768275460000000 - TabOrder = 6 - end - object Button2: TButton - Left = 87 - Top = 164 - Width = 130 - Height = 25 - Caption = #1057#1086#1093#1088#1072#1085#1080#1090#1100' '#1080#1079#1084#1077#1085#1077#1085#1080#1103 - TabOrder = 7 - OnClick = Button2Click - end - object Button3: TButton - Left = 223 - Top = 164 - Width = 133 - Height = 25 - Caption = #1059#1076#1072#1083#1080#1090#1100' '#1101#1090#1086' '#1089#1086#1073#1099#1090#1080#1077 - TabOrder = 8 - OnClick = Button3Click - end - end - object Button4: TButton - Left = 407 - Top = 99 - Width = 75 - Height = 21 - Caption = #1053#1086#1074#1086#1077 - TabOrder = 6 - OnClick = Button4Click - end -end diff --git a/demos/calendar_demo/main.pas b/demos/calendar_demo/main.pas deleted file mode 100644 index 3a0d119..0000000 --- a/demos/calendar_demo/main.pas +++ /dev/null @@ -1,167 +0,0 @@ -unit main; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, ComCtrls, GCalendar,GDataCommon,Math, IdBaseComponent, - IdComponent, IdTCPConnection, IdTCPClient, IdHTTP; - -type - TForm1 = class(TForm) - Label1: TLabel; - Edit1: TEdit; - Label2: TLabel; - Edit2: TEdit; - Button1: TButton; - Label3: TLabel; - Label4: TLabel; - Label5: TLabel; - ComboBox1: TComboBox; - Label6: TLabel; - Label7: TLabel; - Label8: TLabel; - ComboBox2: TComboBox; - GroupBox1: TGroupBox; - Label11: TLabel; - Label12: TLabel; - Label13: TLabel; - Label14: TLabel; - Label15: TLabel; - Label17: TLabel; - Label18: TLabel; - Label21: TLabel; - CheckBox1: TCheckBox; - CheckBox2: TCheckBox; - CheckBox3: TCheckBox; - Edit4: TEdit; - Label16: TLabel; - Edit5: TEdit; - DateTimePicker1: TDateTimePicker; - DateTimePicker4: TDateTimePicker; - Button2: TButton; - Button3: TButton; - Button4: TButton; - Label9: TLabel; - procedure Button1Click(Sender: TObject); - procedure ComboBox1Change(Sender: TObject); - procedure ComboBox2Change(Sender: TObject); - procedure Button2Click(Sender: TObject); - procedure Button3Click(Sender: TObject); - procedure Button4Click(Sender: TObject); - private - { Private declarations } - public - MyCelendars: TGoogleCalendar; - Event: TCelenrarEvent; - end; - -var - Form1: TForm1; - -implementation - -uses newevent; - -{$R *.dfm} - -procedure TForm1.Button1Click(Sender: TObject); -var i:integer; -begin -MyCelendars:=TGoogleCalendar.Create(Edit1.Text,Edit2.Text); -if MyCelendars.Login then - begin - label4.Caption:='Подключен'; - MyCelendars.RetriveCelendars(true); //получаем список календарей на чтение/запись - label7.Caption:=IntToStr(MyCelendars.AllCelendars.Count); - ComboBox1.Items.Clear; - for I := 0 to MyCelendars.AllCelendars.Count - 1 do - ComboBox1.Items.Add(MyCelendars.AllCelendars[i].title); - end -else - label4.Caption:='Нет соединения'; -end; - -procedure TForm1.Button2Click(Sender: TObject); -var Rem: TgdReminder; -begin - Event.title:=Edit4.Text; - Event.Description:=Edit5.Text; - Event.When.startTime:=Trunc(DateTimePicker1.Date); - Event.When.endTime:=Trunc(DateTimePicker4.Date); - Event.Reminders.Clear; - if CheckBox1.Checked then - begin - Rem:=TgdReminder.Create(nil); - Rem.Period:=tpMinutes; - Rem.PeriodValue:=10; - Rem.Method:=tmSMS; - Event.Reminders.Add(Rem); - end; - if CheckBox2.Checked then - begin - Rem:=TgdReminder.Create(nil); - Rem.Period:=tpMinutes; - Rem.PeriodValue:=10; - Rem.Method:=tmEmail; - Event.Reminders.Add(Rem); - end; - if CheckBox3.Checked then - begin - Rem:=TgdReminder.Create(nil); - Rem.Period:=tpMinutes; - Rem.PeriodValue:=10; - Rem.Method:=tmAlert; - Event.Reminders.Add(Rem); - end; - if Event.Update then - ShowMessage('Мероприятие обновлено') - else - ShowMessage('Во время обновления произошла ошибка'); -end; - -procedure TForm1.Button3Click(Sender: TObject); -begin -Event.DeleteThis; -ComboBox1Change(self); -end; - -procedure TForm1.Button4Click(Sender: TObject); -begin -Form2.ShowModal; -end; - -procedure TForm1.ComboBox1Change(Sender: TObject); -var i,count:integer; -begin - ComboBox2.Items.Clear; - count:=MyCelendars.AllCelendars[ComboBox1.ItemIndex].RetrieveEvents; - for I := 0 to Count - 1 do - ComboBox2.Items.Add(MyCelendars.AllCelendars[ComboBox1.ItemIndex].Event[i].title); -end; - -procedure TForm1.ComboBox2Change(Sender: TObject); -var i:integer; -begin -CheckBox1.Checked:=false; -CheckBox2.Checked:=false; -CheckBox3.Checked:=false; - Event:=TCelenrarEvent.Create(); - Event:=MyCelendars.AllCelendars[ComboBox1.ItemIndex].Event[ComboBox2.ItemIndex]; - label12.Caption:=DateTimeToStr(Event.PublishedTime); - label14.Caption:=DateTimeToStr(Event.UpdateTime); - Edit4.Text:=Event.title; - Edit5.Text:=Event.Description; - DateTimePicker1.Date:=Event.When.startTime; - DateTimePicker4.Date:=Event.When.endTime; - for i:=0 to Event.Reminders.Count-1 do - begin - case Event.Reminders[i].Method of - tmAlert:CheckBox3.Checked:=true; - tmEmail:CheckBox2.Checked:=true; - tmSMS:CheckBox1.Checked:=true; - end; - end; -end; - -end. diff --git a/demos/calendar_demo/newevent.dfm b/demos/calendar_demo/newevent.dfm deleted file mode 100644 index ba57b17..0000000 --- a/demos/calendar_demo/newevent.dfm +++ /dev/null @@ -1,126 +0,0 @@ -object Form2: TForm2 - Left = 0 - Top = 0 - Caption = #1053#1086#1074#1086#1077' '#1089#1086#1073#1099#1090#1080#1077 - ClientHeight = 146 - ClientWidth = 450 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - PixelsPerInch = 96 - TextHeight = 13 - object GroupBox1: TGroupBox - Left = 0 - Top = 0 - Width = 450 - Height = 146 - Align = alClient - Caption = #1048#1085#1092#1086#1088#1084#1072#1094#1080#1103' '#1087#1086' '#1089#1086#1073#1099#1090#1080#1102 - TabOrder = 0 - ExplicitHeight = 174 - object Label15: TLabel - Left = 8 - Top = 19 - Width = 53 - Height = 13 - Caption = #1047#1072#1075#1086#1083#1086#1074#1086#1082 - end - object Label17: TLabel - Left = 8 - Top = 73 - Width = 87 - Height = 13 - Caption = #1053#1072#1095#1072#1083#1086' '#1089#1086#1073#1099#1090#1080#1103':' - end - object Label18: TLabel - Left = 204 - Top = 73 - Width = 81 - Height = 13 - Caption = #1050#1086#1085#1077#1094' '#1089#1086#1073#1099#1090#1080#1103':' - end - object Label21: TLabel - Left = 8 - Top = 96 - Width = 111 - Height = 13 - Caption = #1052#1077#1090#1086#1076#1099' '#1086#1087#1086#1074#1077#1097#1077#1085#1080#1103':' - end - object Label16: TLabel - Left = 8 - Top = 46 - Width = 49 - Height = 13 - Caption = #1054#1087#1080#1089#1072#1085#1080#1077 - end - object CheckBox1: TCheckBox - Left = 132 - Top = 94 - Width = 45 - Height = 17 - Caption = 'SMS' - TabOrder = 0 - end - object CheckBox2: TCheckBox - Left = 183 - Top = 94 - Width = 48 - Height = 17 - Caption = 'E-mail' - TabOrder = 1 - end - object CheckBox3: TCheckBox - Left = 237 - Top = 94 - Width = 124 - Height = 17 - Caption = #1042#1089#1087#1083#1099#1074#1072#1102#1097#1077#1077' '#1086#1082#1085#1086 - TabOrder = 2 - end - object Edit4: TEdit - Left = 101 - Top = 15 - Width = 344 - Height = 21 - TabOrder = 3 - end - object Edit5: TEdit - Left = 101 - Top = 42 - Width = 344 - Height = 21 - TabOrder = 4 - end - object DateTimePicker1: TDateTimePicker - Left = 101 - Top = 69 - Width = 97 - Height = 21 - Date = 40264.649768275460000000 - Time = 40264.649768275460000000 - TabOrder = 5 - end - object DateTimePicker4: TDateTimePicker - Left = 297 - Top = 69 - Width = 97 - Height = 21 - Date = 40264.649768275460000000 - Time = 40264.649768275460000000 - TabOrder = 6 - end - object Button3: TButton - Left = 170 - Top = 117 - Width = 100 - Height = 25 - Caption = #1044#1086#1073#1072#1074#1080#1090#1100 - TabOrder = 7 - OnClick = Button3Click - end - end -end diff --git a/demos/calendar_demo/newevent.pas b/demos/calendar_demo/newevent.pas deleted file mode 100644 index 5c6cf1e..0000000 --- a/demos/calendar_demo/newevent.pas +++ /dev/null @@ -1,81 +0,0 @@ -unit newevent; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, ComCtrls,GCalendar,GDataCommon; - -type - TForm2 = class(TForm) - GroupBox1: TGroupBox; - Label15: TLabel; - Label17: TLabel; - Label18: TLabel; - Label21: TLabel; - Label16: TLabel; - CheckBox1: TCheckBox; - CheckBox2: TCheckBox; - CheckBox3: TCheckBox; - Edit4: TEdit; - Edit5: TEdit; - DateTimePicker1: TDateTimePicker; - DateTimePicker4: TDateTimePicker; - Button3: TButton; - procedure Button3Click(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - Form2: TForm2; - -implementation - -uses main; - -{$R *.dfm} - -procedure TForm2.Button3Click(Sender: TObject); -var Event: TCelenrarEvent; - Rem: TgdReminder; -begin - Event:=TCelenrarEvent.Create; - Event.title:=Edit4.Text; - Event.Description:=Edit5.Text; - Event.When.startTime:=Trunc(DateTimePicker1.Date); - Event.When.endTime:=Trunc(DateTimePicker4.Date); - Event.Reminders.Clear; - if CheckBox1.Checked then - begin - Rem:=TgdReminder.Create(nil); - Rem.Period:=tpMinutes; - Rem.PeriodValue:=10; - Rem.Method:=tmSMS; - Event.Reminders.Add(Rem); - end; - if CheckBox2.Checked then - begin - Rem:=TgdReminder.Create(nil); - Rem.Period:=tpMinutes; - Rem.PeriodValue:=10; - Rem.Method:=tmEmail; - Event.Reminders.Add(Rem); - end; - if CheckBox3.Checked then - begin - Rem:=TgdReminder.Create(nil); - Rem.Period:=tpMinutes; - Rem.PeriodValue:=10; - Rem.Method:=tmAlert; - Event.Reminders.Add(Rem); - end; - Form1.MyCelendars.AllCelendars[Form1.ComboBox1.ItemIndex].AddSingleEvent(Event); - ModalResult:=mrOk; - Form1.ComboBox1Change(self); - Hide; -end; - -end. diff --git a/demos/contacts_demo/NewContact.dfm b/demos/contacts_demo/NewContact.dfm deleted file mode 100644 index 53d42d1..0000000 --- a/demos/contacts_demo/NewContact.dfm +++ /dev/null @@ -1,117 +0,0 @@ -object fNewContact: TfNewContact - Left = 0 - Top = 0 - Caption = #1053#1086#1074#1099#1081' '#1082#1086#1085#1090#1072#1082#1090 - ClientHeight = 251 - ClientWidth = 182 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - Position = poMainFormCenter - PixelsPerInch = 96 - TextHeight = 13 - object Label1: TLabel - Left = 8 - Top = 12 - Width = 44 - Height = 13 - Caption = #1060#1072#1084#1080#1083#1080#1103 - end - object Label2: TLabel - Left = 8 - Top = 39 - Width = 19 - Height = 13 - Caption = #1048#1084#1103 - end - object Label3: TLabel - Left = 8 - Top = 66 - Width = 49 - Height = 13 - Caption = #1054#1090#1095#1077#1089#1090#1074#1086 - end - object Label4: TLabel - Left = 8 - Top = 96 - Width = 80 - Height = 13 - Caption = #1054#1089#1085#1086#1074#1085#1086#1081' E-mail' - end - object Label5: TLabel - Left = 8 - Top = 138 - Width = 44 - Height = 13 - Caption = #1058#1077#1083#1077#1092#1086#1085 - end - object Label6: TLabel - Left = 8 - Top = 179 - Width = 80 - Height = 13 - Caption = #1044#1077#1085#1100' '#1088#1086#1078#1076#1077#1085#1080#1103 - end - object Edit1: TEdit - Left = 58 - Top = 8 - Width = 121 - Height = 21 - TabOrder = 0 - Text = 'Edit1' - end - object Edit2: TEdit - Left = 58 - Top = 35 - Width = 121 - Height = 21 - TabOrder = 1 - Text = 'Edit2' - end - object Edit3: TEdit - Left = 58 - Top = 62 - Width = 121 - Height = 21 - TabOrder = 2 - Text = 'Edit3' - end - object Edit4: TEdit - Left = 7 - Top = 111 - Width = 171 - Height = 21 - TabOrder = 3 - Text = 'Edit4' - end - object Edit5: TEdit - Left = 8 - Top = 152 - Width = 170 - Height = 21 - TabOrder = 4 - Text = 'Edit5' - end - object Button1: TButton - Left = 52 - Top = 221 - Width = 75 - Height = 25 - Caption = #1044#1086#1073#1072#1074#1080#1090#1100 - TabOrder = 5 - OnClick = Button1Click - end - object DateTimePicker1: TDateTimePicker - Left = 8 - Top = 194 - Width = 170 - Height = 21 - Date = 40364.981393449070000000 - Time = 40364.981393449070000000 - TabOrder = 6 - end -end diff --git a/demos/contacts_demo/NewContact.pas b/demos/contacts_demo/NewContact.pas deleted file mode 100644 index 8cb392e..0000000 --- a/demos/contacts_demo/NewContact.pas +++ /dev/null @@ -1,58 +0,0 @@ -unit NewContact; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, GContacts, ComCtrls, GDataCommon,main; - -type - TfNewContact = class(TForm) - Label1: TLabel; - Label2: TLabel; - Label3: TLabel; - Edit1: TEdit; - Edit2: TEdit; - Edit3: TEdit; - Label4: TLabel; - Edit4: TEdit; - Label5: TLabel; - Edit5: TEdit; - Label6: TLabel; - Button1: TButton; - DateTimePicker1: TDateTimePicker; - procedure Button1Click(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - fNewContact: TfNewContact; - -implementation - -{$R *.dfm} - -procedure TfNewContact.Button1Click(Sender: TObject); -var NewContact: TContact; - Phone: TgdPhoneNumber; -begin - NewContact:=TContact.Create(); - NewContact.TagName.FamilyName.Value:=Edit1.Text; - NewContact.TagName.GivenName.Value:=Edit2.Text; - NewContact.TagName.AdditionalName.Value:=Edit3.Text; - NewContact.TagName.FullName.Value:=Edit1.Text+' '+Edit2.Text+' '+Edit3.Text; - NewContact.PrimaryEmail:=Edit4.Text; - NewContact.TagBirthDay.Date:=DateTimePicker1.Date; - Phone:=TgdPhoneNumber.Create(); - Phone.Rel:=tp_Home; - Phone.Text:=Edit5.Text; - NewContact.Phones.Add(Phone); - Contact.AddContact(NewContact); - Hide; - -end; - -end. diff --git a/demos/contacts_demo/Profile.dfm b/demos/contacts_demo/Profile.dfm deleted file mode 100644 index a52731c..0000000 --- a/demos/contacts_demo/Profile.dfm +++ /dev/null @@ -1,69 +0,0 @@ -object ProfileForm: TProfileForm - Left = 0 - Top = 0 - BorderStyle = bsSizeToolWin - Caption = #1044#1072#1085#1085#1099#1077' '#1086' '#1087#1088#1086#1092#1080#1083#1077' Google' - ClientHeight = 87 - ClientWidth = 297 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - Position = poMainFormCenter - PixelsPerInch = 96 - TextHeight = 13 - object Label1: TLabel - Left = 8 - Top = 9 - Width = 30 - Height = 13 - Caption = #1051#1086#1075#1080#1085 - end - object Label2: TLabel - Left = 154 - Top = 9 - Width = 37 - Height = 13 - Caption = #1055#1072#1088#1086#1083#1100 - end - object Label3: TLabel - Left = 8 - Top = 36 - Width = 94 - Height = 13 - Caption = #1040#1076#1088#1077#1089' '#1087#1086#1095#1090#1099' GMail' - end - object Edit1: TEdit - Left = 44 - Top = 5 - Width = 97 - Height = 21 - TabOrder = 0 - end - object Edit2: TEdit - Left = 197 - Top = 5 - Width = 97 - Height = 21 - TabOrder = 1 - end - object Edit3: TEdit - Left = 116 - Top = 32 - Width = 178 - Height = 21 - TabOrder = 2 - end - object Button1: TButton - Left = 104 - Top = 58 - Width = 75 - Height = 25 - Caption = #1057#1086#1093#1088#1072#1085#1080#1090#1100 - TabOrder = 3 - OnClick = Button1Click - end -end diff --git a/demos/contacts_demo/Profile.pas b/demos/contacts_demo/Profile.pas deleted file mode 100644 index ec4a8b9..0000000 --- a/demos/contacts_demo/Profile.pas +++ /dev/null @@ -1,64 +0,0 @@ -п»їunit Profile; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls,GoogleLogin,GContacts; - -type - TProfileForm = class(TForm) - Label1: TLabel; - Edit1: TEdit; - Label2: TLabel; - Edit2: TEdit; - Label3: TLabel; - Edit3: TEdit; - Button1: TButton; - procedure Button1Click(Sender: TObject); - private - { Private declarations } - public - procedure Authorize (const LoginResult: TLoginResult; Result: TResultRec); - end; - -var - ProfileForm: TProfileForm; - -implementation - -uses main; - -{$R *.dfm} - -procedure TProfileForm.Authorize(const LoginResult: TLoginResult; - Result: TResultRec); -begin - if LoginResult=lrOk then - begin - Contact:=TGoogleContact.Create(self); - Contact.Gmail:=GmailContact; - Contact.Auth:=Result.Auth; - end; - Form3.ToolButton2.Enabled:=LoginResult=lrOk; -end; - -procedure TProfileForm.Button1Click(Sender: TObject); -begin - Loginer:=TGoogleLogin.Create(self); - Loginer.Email:=Edit1.Text; - Loginer.Password:=Edit2.Text; - Loginer.Service:=cp; - Loginer.OnAutorization:=Authorize; - GmailContact:=Edit3.Text; - - Loginer.Login(); - - - - - - Hide; -end; - -end. diff --git a/demos/contacts_demo/contacts.dpr b/demos/contacts_demo/contacts.dpr deleted file mode 100644 index 2572140..0000000 --- a/demos/contacts_demo/contacts.dpr +++ /dev/null @@ -1,31 +0,0 @@ -program contacts; - -uses - Forms, - main in 'main.pas' {Form3}, - Profile in 'Profile.pas' {ProfileForm}, - GoogleLogin in '..\..\source\GoogleLogin.pas', - GContacts in '..\..\source\GContacts.pas', - GHelper in '..\..\source\GHelper.pas', - NativeXml in '..\..\addons\nativexml\NativeXml.pas', - GDataCommon in '..\..\source\GDataCommon.pas', - uLanguage in '..\..\source\uLanguage.pas', - uLog in 'uLog.pas' {fLog}, - uQueryForm in 'uQueryForm.pas' {fQuery}, - uUpdate in 'uUpdate.pas' {fUpdateContact}, - NewContact in 'NewContact.pas' {fNewContact}, - GConsts in '..\..\source\GConsts.pas'; - -{$R *.res} - -begin - Application.Initialize; - Application.MainFormOnTaskbar := True; - Application.CreateForm(TForm3, Form3); - Application.CreateForm(TProfileForm, ProfileForm); - Application.CreateForm(TfLog, fLog); - Application.CreateForm(TfQuery, fQuery); - Application.CreateForm(TfUpdateContact, fUpdateContact); - Application.CreateForm(TfNewContact, fNewContact); - Application.Run; -end. diff --git a/demos/contacts_demo/contacts.dproj b/demos/contacts_demo/contacts.dproj deleted file mode 100644 index 28a2412..0000000 --- a/demos/contacts_demo/contacts.dproj +++ /dev/null @@ -1,144 +0,0 @@ -п»ї - - {901BDCD7-6F86-4C0E-98C9-DB2281620CAE} - 12.0 - contacts.dpr - Debug - DCC32 - - - true - - - true - Base - true - - - true - Base - true - - - contacts.exe - 00400000 - WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias) - x86 - false - false - false - false - false - - - false - RELEASE;$(DCC_Define) - 0 - false - - - DEBUG;$(DCC_Define) - - - - MainSource - - -
Form3
- - -
ProfileForm
- - - - - - - - -
fLog
- - -
fQuery
- - -
fUpdateContact
- - -
fNewContact
- - - - - - - - - - - - - - - - - - - Base - - - Cfg_2 - Base - - - Cfg_1 - Base - - - - - Delphi.Personality.12 - - - - - contacts.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 - - - - True - - 12 - - diff --git a/demos/contacts_demo/contacts.res b/demos/contacts_demo/contacts.res deleted file mode 100644 index fc1937e..0000000 Binary files a/demos/contacts_demo/contacts.res and /dev/null differ diff --git a/demos/contacts_demo/contacts_project.tvsconfig b/demos/contacts_demo/contacts_project.tvsconfig deleted file mode 100644 index 862e03a..0000000 --- a/demos/contacts_demo/contacts_project.tvsconfig +++ /dev/null @@ -1,9 +0,0 @@ - - - \ No newline at end of file diff --git a/demos/contacts_demo/form_google_login.dfm b/demos/contacts_demo/form_google_login.dfm deleted file mode 100644 index 4af4b7f..0000000 --- a/demos/contacts_demo/form_google_login.dfm +++ /dev/null @@ -1,847 +0,0 @@ -object FormGogle: TFormGogle - Left = 0 - Top = 0 - BorderIcons = [biSystemMenu] - BorderStyle = bsSingle - ClientHeight = 211 - ClientWidth = 320 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - Position = poDesktopCenter - OnCreate = FormCreate - PixelsPerInch = 96 - TextHeight = 13 - object ButtonOK: TsSpeedButton - Left = 69 - Top = 175 - Width = 88 - Height = 25 - Caption = 'Ok' - Glyph.Data = { - 36030000424D3603000000000000360000002800000010000000100000000100 - 1800000000000003000000000000000000000000000000000000C8C8C8C8C8C8 - C8C8C8C8C8C87CA37C327E32037305047706047706037305327E327CA37CC8C8 - C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8AEBBAE25782508810C12A41A14AD1E14 - AD1E14AD1E14AD1E12A41A08810C257825AEBBAEC8C8C8C8C8C8C8C8C8AEBBAE - 0E700F119B1A19B22619B22619B22619B22619B22619B22619B22619B226119B - 1A0E700FAEBBAEC8C8C8C8C8C8257825159E201EB72D1EB72D1EB72D1EB72D1E - B72D1EB72D1EB72D1EB72D1EB72D1EB72D159E20257825C8C8C87CA37C0D8714 - 23BC3523BC3523BC3523BC3523BC3523BC3523BC3523BC3523BC3523BC3523BC - 3523BC350D87147CA37C327E322BBE4129C23E29C23E29C23E29C23E29C23E29 - C23E29C23E29C23E29C23E29C23E29C23E29C23E2BBE41327E3213831D32CB4B - 2EC7452EC7452EC7452EC7452EC7452EC7452EC7452EC7452EC7452EC7452EC7 - 452EC74535CE5013831D1A8C2633CC4D33CC4D33CC4D33CC4D33CC4D33CC4D33 - CC4D33CC4D33CC4D33CC4D33CC4D33CC4D33CC4D33CC4D1A8C261A8C2644DD66 - 39D25539D25539D25539D25539D25539D25539D25539D25539D25539D25539D2 - 5539D25544DD661A8C2613831D4FE8773ED75D3ED75D3ED75D3ED75D3ED75D3E - D75D3ED75D3ED75D3ED75D3ED75D3ED75D3ED75D4FE87713831D327E3256E780 - 43DC6543DC6543DC6543DC6543DC6543DC6543DC6543DC6543DC6543DC6543DC - 6543DC6556E780327E327CA37C2B9F3E5BEE8649E26D49E26D49E26D49E26D49 - E26D49E26D49E26D49E26D49E26D49E26D5BEE862B9F3E7CA37CC8C8C8257825 - 56CF7960F08C4EE7754EE7754EE7754EE7754EE7754EE7754EE7754EE77560F0 - 8C56CF79257825C8C8C8C8C8C8AEBBAE1475175ECF8176F7A65AEE8553EC7D53 - EC7D53EC7D53EC7D5AEE8576F7A65ECF81147517AEBBAEC8C8C8C8C8C8C8C8C8 - AEBBAE257825379F4A82ECB08BFCBD87FBB987FBB98BFCBD82ECB0379F4A2578 - 25AEBBAEC8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C87CA37C327E321D832727 - 8C34278C341D8327327E327CA37CC8C8C8C8C8C8C8C8C8C8C8C8} - OnClick = ButtonOKClick - SkinData.SkinSection = 'SPEEDBUTTON' - end - object ButtonCancel: TsSpeedButton - Left = 163 - Top = 175 - Width = 88 - Height = 25 - Hint = '\\\\\\\\' - Caption = 'Cancel' - Glyph.Data = { - 36030000424D3603000000000000360000002800000010000000100000000100 - 1800000000000003000000000000000000000000000000000000C8C8C8C8C8C8 - C8C8C8C8C8C87C7CB53232A300009C00009D00009D00009B3232A37C7CB5C8C8 - C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8AEAEC12525A00000A30000B10000B400 - 00B20000B10000B00000AC0000A02525A0AEAEC1C8C8C8C8C8C8C8C8C8AEAEC1 - 0C0C9C0000B20000BC0000BB0000BA0000B80000B70000B60000B50000B40000 - AB0C0C9BAEAEC1C8C8C8C8C8C82525A00000B70000C40000C30000C10000C000 - 00BF0000BE0000BC0000BB0000BA0000B90000AE2525A0C8C8C87C7CB50000AC - 0000CD0000CB0000CA0000C90000C70000C60000C40000C30000C20000C00000 - BF0000BE0000A57C7CB53232A30E12D30000D50000D30000D20000D00000CF00 - 00CD0000CC0000CA0000C90000C70000C60000C50E12C53232A3181FAB0709E1 - 0000DD0000DB0000DA0000D80000D70000D50000D30000D20000D00000CF0000 - CD0000CC0F13D1181FAB242EB10000E70000E50000E40000E20000E00000DF00 - 00DD0000DB0000DA0000D80000D70000D50000D40000D2242EB1242FB1242FF4 - 0000EE0000EC0000EB0000E90000E70000E60000E40000E20000E10000DF0000 - DD0000DC242FE4242FB11B23AB3F52FB0000F70000F60000F40000F20000F000 - 00EF0000ED0000EB0000E90000E80000E60000E43F52EF1B23AB3232A36D8DF2 - 0000FF0000FE0000FD0000FB0000FA0000F80000F60000F40000F20000F10000 - EF0000ED6D8DEF3232A37C7CB53647BE3F52FF0000FF0000FF0000FF0000FF00 - 00FF0000FE0000FD0000FC0000FA0000F83F52FA3647BE7C7CB5C8C8C82525A0 - 6481DF3647FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF3647 - FF6481DF2525A0C8C8C8C8C8C8AEAEC11518A06481DF5B76FF1218FF0000FF00 - 00FF0000FF0000FF1218FF5B76FF6481DF1518A0AEAEC1C8C8C8C8C8C8C8C8C8 - AEAEC12525A03647BE7FA5F27699FF6D8DFF6D8DFF7699FF7FA5F23647BE2525 - A0AEAEC1C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C87C7CB53232A31B23AB24 - 2FB1242FB11B23AB3232A37C7CB5C8C8C8C8C8C8C8C8C8C8C8C8} - OnClick = ButtonCancelClick - SkinData.SkinSection = 'SPEEDBUTTON' - end - object sPanel1: TsPanel - Left = 0 - Top = 0 - Width = 320 - Height = 164 - Align = alTop - TabOrder = 0 - SkinData.SkinSection = 'PANEL' - object sBevel1: TsBevel - Left = 12 - Top = 13 - Width = 293 - Height = 140 - Shape = bsFrame - end - object sLabel1: TsLabel - Left = 24 - Top = 73 - Width = 28 - Height = 13 - Caption = 'Email:' - end - object sLabel2: TsLabel - Left = 24 - Top = 100 - Width = 50 - Height = 13 - Caption = 'Password:' - end - object Image1: TImage - Left = 97 - Top = 22 - Width = 125 - Height = 43 - Picture.Data = { - 0B54504E4747726170686963B6520000424DB652000000000000360000002800 - 0000780000002C00000001002000000000008052000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000FDFDFD00FFFFFF03F8F8 - F80DF3F3F318F1F1F11AF2F2F21AF5F5F513FBFBFB08FFFFFF01FFFFFF000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000FCFCFC0029352800F0F1F017E8E8E853E2E2E28FDDDD - DDBED9D9D8D1D7D7D7D4D8D8D8D3DBDBDBCADEDEDEACE3E3E37CEAEAEA43F3F3 - F30EEAEAEA00FFFFFF0000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000EFEFEF00F4F4F406E7E7E759DADADAC8CBCBCCF9BDBDBFFFB4B5 - B7FFB1B3B5FFB3B5B7FFB7B8BAFFBCBDBFFFC1C1C3FFC9C9C9FFD3D3D3F2DDDD - DDB5E8E8E84FF5F5F507F0F0F000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000EFEEEF00F8F7F805E3E3E376CFCFD1F1B4B4B5FFA29C9CFF9E8F89FFA587 - 7BFFAF8877FFB38D7CFFB59587FFBDA89EFFC3BAB7FFC5C4C3FFC5C6C6FFC6C6 - C6FFD3D3D3F0E2E2E288F0F0F010EAEAEA000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000F2F2 - F200D3D3D300E7E7E756CFD0D1F0AA9F9BFF946D5CFF924F30FF9E4922FFB34C - 1DFFC4521DFFC5531FFFBF5321FDBD5829FDBA6138FFB8785AFFC0A294FFC4BF - BDFFBFBFC1FFCBCACBFAE1E0E195F3F3F30CEDEDED0000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000ECEC - EC00F5F5F50DDCDDDDBBB79D91FF9D512EFF9A3E13FFA54113FFB54B1AFBC758 - 25D7D76B399CDC6F3C6CDB6D3A58DA6B3857D66A376BCF6837A3BE5B2DE2AF6C - 4DFEB19E96FFB4B3B5FFCCCBCCF7E5E5E569BABABA00F1F1F100000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000E9EA - EB00EEF5F82CD3BBB0E4B65A2FFFAD4515FFAA4516FFB45427F8C9744C8BDC8D - 671EF4C7B204D8571C00FFFFFF00FFFFFF00F4100000FFCBAF05E88C6032CB66 - 36B7A1532FFF988279FFB3B3B5FFD8D8D8CBF1F1F019ECECEC00000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000E8DC - D500EBE5E236D98B68EBC6511BFFAF4717FFA24B23FFC8A492D5F1F1F11AE7DD - D800000000000000000000000000000000000000000000000000E68F6700F0A0 - 7B2CCA693CDF894628FF988D89FFCDCDCEF7E9E9E94CE6E6E600000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000EDC6 - B200EFD1C136E78A5FE9D16330FF9F4014FF9A664EFFD9D8D8D2F5F7F814EEEE - EF00000000000000000000000000000000000000000000000000EBE4E000EFF5 - F71AE19E7ED6A4481DFF7F5B4AFFC1C1C2FFE4E5E56ADADADA00F2F2F2000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000EFB2 - 9000EFB29019EF9D73D7D9784BFF933E17FF927366FFD1D2D3EDEBEBEA44E5E5 - E4000000000000000000000000000000000000000000F0F0F000FEFEFE05E3E7 - E976DAA891F9B54F1FFF763E25FFB9B4B2FFE6E7E76FD7D7D700F2F2F2000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000F1BF - 9D00F1C09F0BF1AB81B9E38D60FF984620FF85695DFFBBBCBDFFDADADAC7EAEA - EA40F8F8F70AFFFFFF00FCFCFC00FFFFFF00E9E9E900F4F4F40CE3E4E475CFCE - CFF0C98465FFB34A18FF793819FFBBB1ADFBEBEDEE57E4E3E400F4F4F4000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000FDFEFD00FFFFFF01F4F4F410EBEBEB36E2E2 - E246DAD9DA48D3D3D34ACFD0D04BCFCFCF4BD1D0D04AD5D5D549DBDBDB48E1E1 - E146E7E7E743EDEDED31F5F5F512FFFFFF02FDFDFD0000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000FFFFFF00FFFFFF00FFFFFF03FFFFFF03FFFFFF01FFFFFF00000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000FFFFFF00FFFFFF00FFFF - FF02FFFFFF02FFFFFF00FFFFFF0000000000000000000000000000000000F3D6 - BF00EC690E00F1B28463ED9C69F8BA6136FF825541FFAAA8AAFFBEBEBFFFD2D2 - D2E9DFDFDFB8E4E4E474E8E8E854EBEBEB49E9E9E954DFDFDFA8C8CBCBF6B29B - 90FFBF592AFFAA4415FF813D1EFFC4B8B2D4F7FDFF21EBEBEB00000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000FFFFFF00FFFFFF00FFFFFF02FFFFFF05FFFF - FF05FFFFFF01FFFFFF0000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000FAFAFA00FFFFFF01EDEDED24E4E4E47CDADADAC3D0D0D0EBC5C5 - C5F8BCBCBEF8B8B7B9F9B7B7B9F9B9B9BBF9BDBCBEF9C2C2C3F9C7C7C7F8CCCC - CCF7D1D1D1F7D6D5D6E7DADADAC6E1E1E1A3E7E7E76CEBEBEB39F1F1F115A0A0 - A000FFFFFF0000000000000000000000000000000000EEEEEE00F6F6F60AEBEB - EB30E6E6E665E3E3E396E1E1E1A6E2E2E2A7E4E4E492E7E7E75EEDEDED2AF5F5 - F507F3F3F3000000000000000000000000000000000000000000000000000000 - 00000000000000000000F0F0F000F5F5F508ECECEC30E7E7E766E4E4E394E1E1 - E1A5E2E2E2A5E4E4E493E7E7E762ECECEC2EF5F5F509EFEFEF00FFFFFF000000 - 0000F1BE9300F1C39A0EF0A7709DE58B59FDA85732FFA08175FFBCBABBFFC0C1 - C3FFC6C7C7FFCDCECEFFD2D2D2FCD2D2D2F8CCCCCDFBBCBCBEFFA8938AFFAC58 - 32FFB84917FFA14014FF935033F9CEBEB86F00000000FAFAFA01F0F0F019EEEE - ED2DEEEEEE35EEEEEE36EEEEEE34EDEDED2BEFEFEF1BF7F7F704F5F5F5000000 - 000000000000F3F3F300F5F6F508EBEBEB34E6E6E675E1E1E1A3DEDEDEB3DEDE - DFB3E1E1E1A1E6E6E679EAEAEA33F5F5F50AEDEDED0000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000EBEBEB00F1F1F10FE5E5E56DD6D6D6D7C4C5C6FDB2B2B5FFA4A2A4FF9C98 - 98FF9A9290FF9B918DFFA29691FFAB9F9BFFB6ACA9FFBFB9B7FFC4C0C1FFC7C6 - C6FFC7C8C8FFC4C5C6FFBFBFC0FFBEBEBFFFC5C5C5FCD0D0D1F2DFDFDFBBECEC - EC2AE6E6E6000000000000000000F3F3F300FAFAFA04EAEAEA40DFDFDFA6D2D2 - D2E9C8C7C7FBC4C4C4FFC6C6C6FFCACAC9FFCDCDCDFFD0D0D0FBD7D7D7E4E0E0 - E09CEAEBEA34FBFBFB03F3F3F300000000000000000000000000000000000000 - 0000F3F3F300FEFEFE03E9E9E938DEDEDEA0D3D3D3E9C8C7C8FCC4C3C3FFC7C5 - C5FFCBCACAFFCDCDCDFFD0D0D0FBD7D7D7E9E0E0E0A4EAEAEA37FBFBFB02F3F3 - F30000000000F2B28100F1BB8B15F1A77789E08456EAB86037FFB07A61FFC2AD - A4FFCDC7C5FFCDCBCBFFC7C7C7FFB5B5B7FFA3A1A2FF9C7B6EFFA34E28FFB147 - 16FFB34818FF9F4115FFA7694CA9ECF0F110E7E3E200EDEDED34E1E1E1C9D6D6 - D6EBD4D3D4F0D4D4D4F0D5D5D5EFD8D8D8EAE0E0E0D6EAEAEA6BFBFBFB03F2F2 - F200FFFFFF00ECECEC2BE0E0E098D2D2D2EAC5C4C4FDBCBBBBFFB8B7B7FFB8B7 - B8FFBCBCBCFFC6C5C6FED3D3D3EAE0E0E0A1ECECEC2F00000000F4F4F4000000 - 0000000000000000000000000000000000000000000000000000FFFFFF00E4E4 - E400EDEDED1FDFDFDFA3CACACBF9AFAEAFFF9A8D89FF8E7063FF855540FF8547 - 2BFF8C4524FF964722FF9E4B23FFA54F27FFAB552EFFAF5D36FFB46744FFBA7A - 5CFFC1917BFFBFA294FFB1A39DFFA19E9EFF9E9C9FFFA8A7AAFFC8C7C8FFE5E5 - E588B4B4B400F3F3F300EEEEEE00F3F3F30AE4E4E477D3D3D3E8BDBCBCFFAAAA - ABFFA0A0A8FF9FA0B0FFA7A9BDFFB8BAC8FFC9CACFFFCBCBCAFFC4C3C2FFC5C5 - C5FFD5D5D5E2E6E6E66CF6F6F609F1F1F100000000000000000000000000EFEF - EF00F3F3F309E5E5E56ED4D3D3E3BEBCBCFFAAAAABFFA1A6A9FFA0ADB2FFA8B9 - BEFFB8C6CAFFC9CECFFFCDCBCBFFC4C3C2FFC5C4C5FFD4D4D4E2E4E4E468F6F6 - F608F0F0F00000000000F3C5A500F3D4B906F0A97F3BE4865793CD6838CCC062 - 36F0BD6A43FCBE7959FFB78067FFA07562FF925C44FF9B431AFFAF4616FFB74A - 19FFAF4718FFAC5832CCBD897127AE6B4C00EAE8EA00EDECED60D4D3D5FCB3B1 - B4FFA8A6A9FFABA8ABFFB6B4B7FFC8C7C9FFDAD9DAFFE9E8E9BAF5F5F50CABAB - AB00E9E9E946D9D9D9D2C2C1C1FFA7A7A9FF8F8F9AFF7E8091FF7E7F91FF8687 - 98FF9D9EA6FFB4B3B5FFC0C0BFFFCECECEFFE1E1E1CFEDEDED30EAEAEA000000 - 00000000000000000000000000000000000000000000F9F9F900E2E2E200EEEE - EE26DCDDDDB9C0C1C1FFA3938DFF92614BFF8C4321FF923B13FF9E3F13FFAC44 - 14FFB94C1AFBC3531EE1CA5C29BFD1693994D0612E74CF5C286DD0653375D16C - 3D90CF6838BEC35F31E6A7552EFF834C33FF6E4D3FFF7B6760FFB4B0AEFFE2E3 - E3A3FFFFFF02F1F1F100FAFAFA06E3E3E37ECDCDCCF7A4A4ACFF6C7098FF3C45 - 91FF263497FF202FA6FE2534B1F33242BCEF4855C2FC6570BEFF9CA0BDFFB3B3 - B7FFB7B6B6FFCECDCEF4E4E4E47CF9F9F907EFEFEF0000000000F1F1F100FBFB - FB05E4E4E47ACFCDCDF7A6ACAEFF6E919BFF3E8598FF2888A1FF2192AFFE259E - BCF330A8C7EE43AFCBFB61B0C5FF9AB8C0FFB3B5B8FFB7B5B6FFCCCCCCF4E3E3 - E37EF7F7F708EEEEEE000000000000000000FEBE9C00FFDDC702F6AF8A17E47D - 4C3CD9632D54D77F5785CB8A6CF4B15023FFA54214FFAD4617FFB84A18FFB74B - 1AFFB6572CBDC68B7132FFFFFF00ECE9E500369B320084C3826B74AA72FB5C83 - 5BFF527251FF547554FF60875FFF749E73FFB1C9B0EDE0E7E051C4D3C400EAEB - EB3DD8D8D7DEB2B2B7FF73769BFF37418BFF1C2985FF101E84FF0F1D89FF1422 - 8FFF273395FF4C549EFF979BBCFFD1D1D5FFE2E2E1FFECECEC87DEDEDE00F3F3 - F3000000000000000000000000000000000000000000EAEAEA00EFEFEF15DEDF - DFB0BFBDBCFFA27D6CFF994924FF9D3F13FFA74315FFB34917FFBF4F1CFBCA5C - 2ACAD46A396FDE7F5327E9956B0CFFDBC602F9AE8400FFFFFF00FF7D2B00FFF0 - E402FDA4780AEFB99E50DE865DECAF4E20FF732E0DFF592811FFA2948EFFE4E5 - E5A5FFFFFF02B9B8B800E7E7E75CCFCFCEF0898DACFF2E3B99FF061798FF0113 - A0FF1222B0E32335C2863246D1493348DC3E3145DB69243AD2B92336B9FA4E57 - 9EFF91929FFFAEADAEFFCFCECFF1E7E7E75D9A9A9B00F2F2F200D0D0D000E7E7 - E753D1CFCFED8CA7AFFF318BA2FF0783A2FF0189ABFF0F99BCE320ABCD892DBB - DC4B2EC1E73D25C1E76415B7DEB314A1C4F84790A3FF8F9CA0FFAEADAEFFCECD - CEF3E6E6E66200000000F2F2F2000000000000000000FFFFFF00FFFFFF00FBFF - FF07F5FFFF18EAEFF16AE1AD95F5D46330FFBA4D1AFFB24817FFB44D1EFDBD64 - 3CABCE907423BD603500F9FFFF00EBEFEB0061BB5D0078C5754B2DA027F10D78 - 08FF065D02FF065A02FF347D32FF469145C5398D397C77B6781FFAF5FA16DEDD - DCBDABACBAFF444EA0FF091A9AFF00139DFF0116A6FF0319B3FF081FC0FA0F26 - C8EA182DC9E01226BDE11828AEEE6C73C2FAD4D5E6ABF4F3F039EDECEB00F3F3 - F30000000000000000000000000000000000F2F2F200FFFFFF01E4E5E57EC8C6 - C6FCA97761FFA44519FFAA4415FFB24918FFB74A18FFBD5221EFCA6D417FDB8F - 6C1AFFFFFF00FAF5F70000000000000000000000000000000000000000000000 - 0000F2F4F400F2F6F738EEB191ECDB7443FF9D4218FF6C2E13FFA3948DFFE3E5 - E5A5FFFFFF01F0F0F01ADCDCDACB8C91B8FF1828A7FF0015A6FF0215A7FF2938 - B5E96F7ACF50FFFFFF02C1C6ED0000000000485CF4007788FB13465AEC911E31 - BFFC293381FF828391FFB5B4B5FFD9D9D9D2EEEEEE20EAEAEA00F1F1F114DCDA - DAC391B2BBFF1A93B1FF008FB3FF0290B4FF2AA2C0F067BFD651FFFFFF02BBE6 - F300000000002BD7FD0068EAFF1027CFF48606A3C9FA227288FF808D91FFB4B2 - B3FFD9D8D8D7EEEEEE24EAEAEA0000000000ECECEC00F6F6F608EAEAEA50E2E2 - E2B7D9D9DADCD4CECCF3E18A63FFD86530FFB44A19FFA1451BFFBF927DF6E4DB - D755DCCAC300000000000000000000000000C2E4C000C9E8C71B66C861D729A2 - 23FF0A7304FF176813FFA6B8A5FFEEECED6EE0E1DF00D5D6D400E8E7E66BBEBF - C9FB3D49AEFF0116ABFF0218B1FF0218B7FF051BC0FD172BCDCE3549DD653C51 - E72D4A5FEF204357EA223446D2353542C1734D57C7808791DC137680D7000000 - 000000000000000000000000000000000000E6E5E600EBECED31D5D4D5E0B688 - 74FFAE4A1BFFB24817FFB44918FFB24817FFB55325E0C779555DE8BFAD06DAA0 - 8600000000000000000000000000000000000000000000000000000000000000 - 0000F0EEEC00F0F0EE25EEB191DCE58152FFAC4A1CFF763214FFA5948DFFE3E4 - E5A562605E00EBE9E667AFB2CCFB2535B6FF0016B3FF0115AAFF2130AAFF999E - D297FFFFFF07EFEFF2000000000000000000000000007687FD008594FF16485C - EFBD1C2DACFF2B326FFF919198FFC8C7C8FBE6E6E670D7D7D700EBE7E65EB2C9 - CFF828A3C2FF019BC1FF0293B8FF1E96B3FF94C7D59AFFFFFF0AE9F1F2000000 - 000000000000000000004FEBFE0064F5FF121DD5F5B20295B7FF256474FF8E93 - 96FFC6C5C6FCE4E4E475B0B0B000EAEAEA00EEEEEE18E1E1E196CFCFD0EFBCBD - BEFFB2B3B6FFB8B1AFFFDC8158FFD76A37FFA64518FF92583EFFBEBCBCFFDDDE - DEBFEEEEEE28E3E3E300FFFFFF0000000000CBE6C800CEE7CC1680D67BD440B6 - 39FF0D7B06FF21681EFFB6BEB6FCEBEAEB5FE6E6E600F6F6F313DADADBC2646E - C0FF0419B9FF0319B9FF0218B6FF0A1DB7FB303FC69E5D6ADA22FFFFFF00C8CF - F7000000000000000000D2D4F200C9CBF002737BD61EA9AFE5167C83D9000000 - 0000000000000000000000000000F2F2F200FFFFFF01E1E3E590C5A698FFB852 - 23FFB84918FFB54919FFAD4616FFB0572EEBC2806150FFFFFF00E2CDC3000000 - 000000000000000000000000000000000000F0F0F000F1F1F10EECECEC40EAEA - EA52E8E9E83DEAEAEA67ECB397F0E47F50FFAC4A1CFF773213FFA4938CFFE1E2 - E3A8FFFFFF0CD8D8DEAD525FC9FF0118C1FF0218B3FF05179DFF757BBBE7F4F2 - EF37E1E0E70000000000000000000000000000000000FFFFFF001431FB008292 - FC6F3D52E1FD0D1B84FF474B70FFB2B3B3FFDCDCDCBBFFFCFB14DADEDFA657B9 - D2FF01A7D0FF039CC2FF0489AAFF6EAEBEE4F0ECEC30DCE3E500000000000000 - 00000000000000000000FFFFFA0008E2FE0044EDFF540CC6E9F7017290FF4267 - 72FFB0B0B1FFDBDBDBC3F5F6F512F3F3F30DDFE0E0A0C5C6C7FEA6A09FFF9585 - 7FFF9A7C71FFBA907EFFE59B78FFEA9166FFBC5B2EFF955F47FFB4B3B5FFC2C2 - C3FFDBDBDBC0ECECEC2ADEDEDE00F6F6F600CAE4C800CDE5CB1681D47CD441B5 - 3AFF0C7706FF21611EFFB6BCB6FCEBEAEB5EE5E5E400F3F2E93DA6ABD5F1152A - C6FF0219C1FF0318B5FF0B1EABFF5660C0B7B6BBE1158E96D400000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000EBEBEC00EEF2F529D7CCC8DCC36B43FFC04D - 17FFB84B19FFAB4516FFA75029FEC89A868DFFFFFF06E9DFDB00000000000000 - 000000000000000000000000000000000000EAEAEA00EDEDED62E2E2E2F3D5D5 - D5F9D0D0D0F4CFCFD0F7E0A285FFE17442FFAA481AFF763214FF9D8C85FFDADC - DCCDF8F7EF48A7AEDEE1182FD1FF041BC4FF0014A5FF2A369AFFC0C2D4B7FFFF - FF0AF2F2EF0000000000000000000000000000000000000000007F8FF800A0AC - F845576AF4F51C2EB1FF121B63FF8B8C98FFD5D5D4E4F7F0EE4FAAD6E2D717B7 - DFFF02A9D2FF008FB3FF2789A3FFBCCFD4B7FFFFFF0AF1EFEE00000000000000 - 00000000000000000000000000006FEBF7008CF0F83E21DAF9F20299BEFF0E58 - 6BFF869296FFD4D3D3EEEFEFEF37E5E6E661CAC9C9F7A48779FF905033FF8A3C - 18FF9A4017FFC45F30EAEB9870BBF1A880BBE28456E9B35C34FEA5887BFFACAB - ACFFBEBEBFFFDCDCDCB9EFEFEF18EAEAEA00C9E4C700CCE5CB1680D47BD440B5 - 39FF0C7606FF21601EFFB6BDB5FCEBEAEB5ED8D8DF00E4E3E66B6472D8FD061E - CEFF041ABBFF0215A4FF4C56B2EFCBCDE24A9599C600FFFFFF00000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000F4F4F400DFE1E100E5EAEB5ED2A18AFDC7521CFFBF4E - 19FFB04717FF9E4218FFB98871D5EDEBED26E6DFDF0000000000000000000000 - 0000000000000000000000000000D9967800D1300001EBE2DE49E3E3E2EDCECF - D0FFC1C1C3FFBDBDBFFFD69070FFDF6F3BFFB14D1EFF7A3414FF9F8D86FFDADB - DCFBF0EFEDDA818DE3FB172FDAFF071DBCFF001294FF5F67A5FFE6E5E37D9B9D - 9800F2F1F2000000000000000000000000000000000000000000A9B2F300BCC3 - F4436B7CF7F42A3ECDFF031073FF595D7FFFCFD0CFF9F2EDECA072D2EBEF02BA - E8FF03A3CBFF0081A2FF5B9AAAFFE4E3E38200000600F0F1F100000000000000 - 0000000000000000000000000000ADE9F100BCEDF13F39DDFAF403AFD9FF0065 - 7EFF55767FFFCDCCCCFAECEDED7CDBDBDBC7B78B77FFA3471CFF9E3F13FF9F41 - 15FFB2603ACDD1896741F3C9B00DF4D0B30DF1A88037DD7C4EB3A8562FFF8A6C - 5FFFA09FA0FFC6C6C7FDE4E4E4787A7A7A00CCE7CB00CBE7CB1680D47BD440B5 - 39FF0C7606FF21601DFFB6BDB5FCEBEAEB5E828BD600C4C8E7964256E1FF1027 - D0FF0217ADFF18279AFFAEB0CED4FFFFF829FCFCFE04FFFFFF00FFFFFF000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000EFEFEF00FFFFFF03E1D7D298D3784DFFCA5018FFB94B - 19FFA04013FFA15E40FFD7CAC58600000000F7FEFF0000000000000000000000 - 0000000000000000000000000000E1AA8D00E6BBA412DB876078D8906EEBC98A - 6DFFC0866CFFCD967EFFE59A78FFEB946AFFD16B3CFF9D4218FFB08B7BFDE6E6 - E5B2E2E4EE8E7282EBF92A40DEFF071DB2FF071789FF9599B8FCEEEEEA58E4E5 - E400000000000000000000000000000000000000000000000000A6AEEC00D0D3 - F0617484F4FB3145D7FF031487FF383F75FFC6C6C8FDE7ECEDCD4DD4F5F701BD - EBFF039AC0FF077895FF92B1B9FDEEEAE95CE4E3E300F7F4F500000000000000 - 0000000000000000000000000000B4E4EC00CAE9EE4940D9F9F602B8E4FF0076 - 94FF326A78FFC2C5C6FFECEEEFEFD6B7A9FBBC5525FFB24716FFA34114FFAE67 - 48FCD8BFB560C1937F00F4F1F300FFFFFF00EB9B7400F2AC8929D47446DA893F - 1DFF786055FFAFAFAFFFDADADACDF2F2F218DBE9DB00CBE7CB1680D47BD440B5 - 39FF0C7606FF21601DFFB6BDB5FCEBEAEB5D0000C400B0B7ECA8455AE9FF162C - CBFF00139AFF4F589EFFD8D9DAFAE2E2E2D1E1E1E1B1E6E6E679EDEDED2FF9F9 - F905F5F5F5000000000000000000000000000000000000000000000000000000 - 00000000000000000000EEF0F000F3FFFF13E0BCABCBD5602AFFC8511AFFAE46 - 17FF933D15FFB79383F1EEF3F53EE7E7E7000000000000000000000000000000 - 0000000000000000000000000000EEC8B000F7FFFF00E28A6112E381535EDE7A - 4CBFDB7546D9E38559DEEDA079D6EFA781D6E8885AD6C95E2DD5AD5831D0C083 - 6653A2AFFB2C6B7BF5EA3B4FE2FF091CA9FF132083FFB3B5C4F9F1F0ED4BE8E8 - E8000000000000000000000000000000000000000000F5F6F5004555E200CED1 - ED856D7CF0FF2D42D8FF041692FF242C74FFBFBFC5F8D0EBEF7B28D5FCE204BF - EDFF0192B5FF11748CFFB0C0C4FAF0EDEC4DE7E7E70000000000000000000000 - 00000000000000000000FEF9F80068CFE800CBE7ED7A38D3F7FF02B8E5FF0180 - A0FF1D677AFFBBC2C5FFECEAE9FFD98E6BFFC95119FFAF4717FF96431CFFC3A8 - 9BDCF5FEFF26EEF1F2000000000000000000F0ECE600F3F9F611E99B74C8B659 - 2DFF663018FF918783FFD2D3D4EDECECEC30DFE8DE00CCE6CC1680D47CD440B5 - 39FF0C7606FF21601DFFB6BDB5FCEBEAEB5E2941E3009BA5F2A05265EEFF192D - C4FF05168FFF8489AEFFE3E4DEFFDBDBD9FFCFCFCEFFCFCFCFFED8D8D8E4E1E1 - E19CE9E9E951F2F2F212FFFFFF02FBFBFB000000000000000000000000000000 - 00000000000000000000EDEBEC00EFFBFF27DFA48ADED85920FFC2501BFFA040 - 14FF8F4B2BFFCEC3BED6F6FBFE1DEDEDED000000000000000000000000000000 - 00000000000000000000000000000000000000000000FEF8EC00FFFFFF00F3B2 - 9211F5A5831CF1AF9220EDAA871AEFB08D1AEE99701AE47E4E1AC361341BC06B - 3A118293F91E6B7EFADB4659E5FF0A1CA3FF222D81FFBFC0C8F8EFEFED47E9E8 - E8000000000000000000000000000000000000000000F0F1F100FFFFF206C3C7 - E7AE5669EBFF2238D3FF031596FF212B7BFFC1C1CAE5C5F1F44B1EDCFED206C3 - EFFF018CAEFF1F7388FFBDC5C7F9EFEDEC4CE8E8E80000000000000000000000 - 00000000000000000000EEEFF000FFFFED03BDE0E9A624CCF5FF02B5E0FF0183 - A5FF1B6D82FFBEC9CCF2F0DFD8C1E58559F9CF5D28FF9F3F14FF975C42FFD6D0 - CEB9FFFFFF08EEEFEF000000000000000000ECEDED00ECF3F626E9AF92DDD06B - 3CFF7C3210FF785B4FFFCECDCDF0EBEBEB35DEE6DD00CCE5CB1680D47CD440B5 - 39FF0C7606FF21601DFFB6BDB5FCEBEAEB5E99A3ED008895F887586BF2FF1B2E - C0FF12218EFF858BB4FFA5A9D7FFA7ACD7FFBEC0D2FFCFCECEFFC9C9C8FFCACA - CAFFD2D2D2F3DCDCDCC9E5E5E578EDEDED2AFDFDFD04F6F6F600FFFFFF000000 - 00000000000000000000ECE2DF00EEEAEA36DE8D67E8D8591FFFBB4D1AFF933A - 11FF96654FFFDAD8D7B0FFFFFF09F1F1F1000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000A0AE - F800A2B0F7117385FDC24F62ECFF0F21A3FF2F3880FFC2C3C7FBEBEBEA52E6E6 - E6000000000000000000000000000000000000000000EAEAEA00F7F5EA2FAEB4 - E0E2394FE4FF142ACAFF011396FF343E8BFFCBCBD4B6D6FFFD1925E6FEBA07CB - F3FF018BAEFF2C7386FFC0C4C6FBEAE9E953E5E5E50000000000000000000000 - 00000000000000000000ECEBEB00FEEEEA26A9D7E3DA12C4F0FF04AED8FF0083 - A3FF2D7C90FFC6D0D4BBF5C0A641EC956BECD26B3CFF913A11FF9E7969FFE0E1 - E2B6FFFFFF06F1F1F10000000000F8F8F900E1E2E200E6E8E952E5A88BF8D569 - 37FF8F3A13FF744834FFCECCCBEBEEEFEF2EDFE8DE00CEE6CC1681D57CD441B6 - 3AFF0D7606FF21601DFFB5BDB5FCEBEAEB5D9DA7EF008594FB685A6DF6FC1E31 - BFFF1E2B8DFFA4A7BEFE8086D4BC2338CEC2384AC7F46974C5FFAAADCDFFC6C7 - CCFFC7C7C5FFC0BFBFFFC6C6C6FDD4D4D4DFE1E1E199EAEAEA25E5E5E5000000 - 00000000000000000000EAD6CD00ECDED736DD7D50E8D85B21FFB44A19FF8836 - 10FFA28375FFE0E2E29EFFFFFF03F3F3F3000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000E1E9 - F700FFFFE2017386FE955A6EF4FF182AACFF2F387DFFBBBBBFFFE5E5E477BABA - BB00F1F1F100000000000000000000000000F2F2F20028211400E7E6E279828C - DBFF1E35DCFF0A20BFFF001193FF565DA0FCE2E1E46D00B9DA0024F0FE8D0BD8 - F8FF0292B6FF2C7182FFB9BCBEFFE5E4E47BA1A1A200F1F1F100000000000000 - 000000000000F3F3F300AFAAA500EAE5E2717FCCE0FE06BDEAFF04A7CFFF0080 - A0FF4F92A3FEDDE1E375F4B28D25EFA37AE5D5774BFF8B3A15FF9D8479FFDEE0 - E0B9FEFEFD08F0F0F00000000000EFEFEE00FEFFFF08E0DDDDA1DE8E69FFCF5C - 25FF943B12FF7E4D35FFD4D1D0C9F7F9FA16DDEADC00CEE8CE1682D67ED441B6 - 3AFF0D7606FF21601DFFB6BDB5FDEBEAEB61A9B2EF00798AFD415F72FAF42639 - C3FF222C86FFB9B9BEFFEBEBE77C5369FA0F4257E65A243AD5BF2538C4F34F5D - BDFF979CC1FFAAAAB2FFA6A5A6FFAEADAEFFC7C7C8FFE2E2E2A6F9F9F90AF0F0 - F0000000000000000000ECC8B900ECCFC227E48153DEDA652FFFAE4819FF8034 - 11FFA9948AFFE3E5E690B9BAB900F4F4F4000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00006B7FFD008193FD57687CFBF62A3DC2FF252F7BFFA8A8AEFFDADADAC9F0F0 - F01DE8E8E8000000000000000000FFFFFF00DEDEDF00EDEDEB34CECFD6DA4556 - D4FF0C24D2FF041AB4FF071792FF797EB5CDFFFFF8206DF4F70043FAFD4F15E9 - FDF303A5CBFF1F6D82FFA6ABADFFDAD9D9CAEFEFEF20E8E8E800000000000000 - 000000000000E6E6E600EEECEC2DD2D7D8D543BEDDFF01B5E2FF039DC4FF0680 - 9EFF73A9B8D3FFF8F823F2C4A50DF1AC83BBDE8559FF90421DFF978278FFD4D5 - D6E3ECECEC36E4E4E400F4F4F400FFFFFF00E6EAEB57D4C3BBF0D46A39FFC551 - 1AFF943B11FF926048FFDDD9D87B72504200D0E8CF00D1E8D11682D67FD442B6 - 3CFF0D7707FF21601EFFB7BEB6FFECEBEC71C1C7EB008596FB206A7DFCD93649 - D2FF212C85FFAAAAB0FFDCDCDCC5F3F3F218D8D8E1006D7FF60F4558E94D3145 - D9A8293ABFF82D3996FF55597FFF81828DFFB3B3B5FFDEDEDEC1F7F7F713F0F0 - F0000000000000000000EFC9B700EFCBBA19EC9A74D3E17B4BFFAC4A1CFF7933 - 12FFA99891FFE2E3E49AFFFFFF01F4F4F4000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000094A4FB00A1B0FB127387FDBB485BE1FF1D2B8CFF90929FFFC6C6C5FDDFDF - DFA8EEEEEE2AFDFDFD05D6D6D600FFFFFF04EBEBEB3BDEDDDAC59196C6FF1027 - CDFF051CC7FF0116AAFF2937A1F6B1B5D3682632920072FCFD007FFFFC0F28F8 - FFB409C8E8FF0F7893FF8E9B9FFFC6C4C5FEDEDEDEABEDEDED2EFEFEFE04EEEF - EE00FFFFFF03ECECEC33DEDBDABB98BFCAFF11B3DCFF03ADD7FF0194B8FF228D - A9F5A1C6CF6300043700EF834000F3B0836AEA9666FBA8532BFF937A6EFFC4C5 - C6FFDCDCDCC1E8E8E855EBEBEB43E4E4E473D3D4D5E1C3927BFFCC531CFFB94B - 18FF933C13FFB4907FF2EFF1F34EDAD8D700D1E8CF00D4E9D11684D67FD443B6 - 3CFF0D7706FF20601EFFB7BEB7FFECEBEC72DFE0E400FFFFF2027688FE8D4D60 - E9FF212F97FF8F91A1FFCACAC9FBE1E1E191F1F1F11BFFFFFF01FFFFFF03E9EA - EC639DA4DCF5182BBCFF03127EFF121C61FF696D96FEDEDEE17A6D6C8A00F2F2 - F2000000000000000000EECEBC00EDD1BF0EEEAC8BC4E78C61FFAF4E22FF7632 - 12FFA5958FFFDFE1E1AEFFFFFF08F2F2F2000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000CFD7F9003B56FE008798FC456075F8E52C3DBCFF646A9BFFBABABAFFC7C7 - C8FED8D8D8DDE0E0E0ACE3E3E396DEDEDEABD4D3D3E4B3B3BDFF3746BEFF011A - CAFF031ABDFF081AA7F94F59B488FFFFFF0FDADCEB00D7FAFE0002FDFE0050FF - FF3C1CEAFBE005A1C4FF5D909DFFBBB9BAFFC8C7C7FED8D8D8DEE0E0E0AAE3E3 - E395DFDFE0A9D5D3D4E0B6BBBEFF3DABC7FF01AEDAFF03A5CDFF0891B5FB3A9D - B683FFF8F60AC2DBE200F2BA9000F3C49D15F0A473B9CF7446FFA3735CFFC1C1 - C1FFC9CACAFFD4D4D4FAD5D5D5F6C8CACBFDB4A6A1FFBB5E33FFBF4D18FFA642 - 14FF965131FFC4BAB6FFDDDEDED6E8E8E86EF9F5FA07D5E9D41585D682D443B7 - 3DFF0D7707FF205F1DFFB5BCB5FDEBEAEB63E3E3E300798BFD008B9AFD2B6176 - F9D52C3FC1FF676E9EFFBEBDBDFFCBCBCBFBDADADACFDFDFDFA8DDDDDDB4D3D3 - CFEA959BC7FF1D34D7FF051AACFF03117FFF565D9BBCF5F5F11BD6D7E0000000 - 00000000000000000000F1D3C000F2FFFF02F1B18F8FEB976EFFB6572AFF7430 - 11FF9B8B85FFDADBDCD3F2F2F21CEDEDED000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000B4C1FB00FFFFFA027588FE61495FEDE93040B6FF9397BAFFC9C8 - C8FFC9C9C7FFCBCBCAFFCBCBCAFFC7C6C4FFB1B1B7FF555FB4FF081EC7FF041C - C9FF081BB9FB2735B499858BCB0F626AC000FFFFFF0000000000BAFEFD00FFFF - FB0145F9FF5C14D4F2E6179CBCFF8FB2BCFFC9C8C8FFCAC8C8FFCBCBCBFFCBCB - CBFFC7C5C5FFB4B6B9FF5BA6BBFF07ACD5FF02AED9FF07A1C8FD27A1C0A17CC0 - D0136ABACD0000000000F3D5B600F0965F00F3B78C30E99464C6C36A40FEC4A1 - 92FFD4D3D2FFD0D2D3FFC7C8CAFFBAADA8FFB46D4BFFC0501CFFB64A18FF9E4E - 29FFAD978EFFC2C3C5FFCECFCFFFE2E2E2EFEFEFEF40D8EBD71389D784D444B8 - 3EFF0E7807FF215F1DFFB5BBB5FCEBEAEB60E3E3E3000000FF00FFFFD8007C8D - FD544A5FECE73646B7FFA1A4BFFFCBCBC9FFC9C9C7FFC9C8C8FFC5C4C2FFAAAB - B6FF4251C0FF0B23D3FF051ABAFF1A28A3E0767DBB4100006500FFFFFF000000 - 00000000000000000000F8F2E200EFA37700F0B18B5AEFA177FDC46539FF7731 - 10FF8D7B72FFCFD0D1F3EAEAEA42E4E4E4000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000096A6FD00BCC9FF036D81FD4F3E54E6CD2F41C3FD7680 - C4FFB1B4CEFFC5C7D0FFBFC0CCFF9BA0C3FF515EC1FF192ECFFF0F27D5FF0E24 - CBEE2635C386767ED0123843BE000000000000000000000000000000000085FE - FE00CAFFFF033CEEFF4815C9EEC71BA8CBFD6FB6C8FFB0CAD1FFC6CFD2FFC0CA - CDFF9DBDC6FF4FAEC9FF0AB0DBFF04B7E5FF0CB1DBF129AED08E77C5D81743B3 - CC00000000000000000000000000F5F0E400E84D0400F1AF8722E382568FCB6B - 3FE3CB8566FED5A792FFD19C83FFCE7B53FFDB7748FFE07949FFCF6231FFBD6F - 4AFFB88872FFB58F7DFFD3C6C0FCE8E7E7A9F1F0F11CE0ECDE148CD987D446B9 - 3FFF0E7808FF1F5F1CFFB4BBB5FFEBEAEB70E1E1E10000000000C3CAF900FFFF - FB036D80FD4F3B51E4D1384AC3FE8991C9FFB6B9CFFFB9BBCCFF969BC3FF4958 - C2FF142BD2FF0B23D0FF1225BEE04D57BF59FFFFFF01BABEE100000000000000 - 0000000000000000000000000000F0BC9900F1BF9C29F1AC82DED77B4EFF8538 - 14FF7B5E52FFBEBEBFFFE1E1E192FFFFFF03F3F3F30000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000FBFBFB00FBFBFB02FCFCFC05F4F4F40000000000000000000000 - 0000000000000000000000000000CED6FF00000000007385FC1F4256E873273B - D2C52F41C9E74657CEF84556D1FF3346D5FE3046E0F43248E5DF2D43DDA7384A - D5458E96DF067783DD0000000000000000000000000000000000000000000000 - 0000ACFEFF0000A4FE0051EAFF1B27CDF27016B7DEC423B1D4E63CB8D7F736BA - DAFF1AB8DFFE0BBFECF50DC3F2DF1EC3ECAD3BC1E34D83D0E30773CEE5000000 - 00000000000000000000000000000000000000000000F7C3A900FFDDCA04EA8F - 6630DA72426ADC7A4BA2E27F4FC3EA8F62CDEE9D74CDED9A71CDE78456CDD96A - 37CDC55725CDB04D1FCDB26744C8C3876B5CFFFFFF00E4EDE4118FD98ACD47BA - 41FF0E7A08FF1E5E1BFFB2BAB2FFEAE9EA73E0E0E0000000000000000000BED2 - FF00FFFFFF006F80FC243D52E57F293DD2CF394BCFEE4354D4FC3448D8FF3449 - E3F82F45E3E32A3FD8A84050CF38FFFFF901A6AFE40000000000000000000000 - 0000000000000000000000000000F5D4BB00F8F0E203F2B3889BE89466FFA34B - 23FF6B402CFFA6A3A4FFD3D3D4E5EBEBEB3CE2E2E200F6F6F600000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000F1F1F100F8F8F803EAEAEA6BE5E5E5A1E9E9E948FBFBFB03F4F4F4000000 - 00000000000000000000000000000000000000000000A8B2FF00C3CAFF016B7B - FA104D60EC303C51E8564257EA6D4F63F1686273F24B6F80EF247483E6080000 - D300FFFFFF000000000000000000000000000000000000000000000000000000 - 000000000000000000009DFAFF00B8FFFF0159E6FF0F46D5F62E30CDF35329CF - F76B2ED5FB693DD8FC4D49D6FA246DDAF109FFFFFF00FFFFFF00000000000000 - 000000000000000000000000000000000000000000000000000000000000FFFF - FF00FFFFFF00FED9C205F7B5910CF4B39011F0AF8B12EFAD8912F0A58212F097 - 6F12EC8A5F12E0815812BF643913BF7B5A0FFFC1FF00E6EEE60E8FDA8BC749BB - 42FF0F7B09FF1D5D1AFFB0B8B0FFEAE9EA73DFDFDF0000000000000000000000 - 00000000000095A9FF00AABCFF026578F8165669F03E465AF0615266F36C6072 - F454697AEE297C8CEA090000AF00E4E9FF000000000000000000000000000000 - 000000000000000000000000000000000000F2AC7B00F2B98F3CF0A372E9CA6D - 40FF74361AFF887C77FFBCBCBDFFDDDCDDB8F0F0F018EAEAEA00000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000F2F4F500F4F7F81CE0E2E3D2CCCCCDFFD5D4D5E9E6E6E663FFFFFF03F0F0 - F000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000CAE6C800F0EFF00A8FD98BBC4ABC - 45FF107C0AFF1A5C17FFACB4ACFFE9E7E974DDDCDD0000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000F4CEAE00F6E3CE06F2AB7794E68C - 59FF9D4A24FF725041FFA4A2A3FFC6C6C7FCE1E1E195F2F2F213E8E8E800FFFF - FF0000000000000000000000000000000000000000000000000000000000F4F4 - F400FFFFFF00E4D2CB5AC8B0A6F4ACA7A6FFB4B3B5FFD3D3D3E9E7E7E7560000 - 0000F2F2F2000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000D0E8CD00FFF3FF0994DB90BA4DBE - 47FF117E0AFF165A14FFA7B1A8FFE8E7E97DD7D6D70000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000F3B07E00F4B98A23EF9F - 68C7D47747FF854021FF897770FFADADAFFFC7C6C7FBDEDEDEB1EBEBEB37FBFB - FB06F3F3F30000000000000000000000000000000000FFFFFF00FFFFFF00F2F2 - F215E5E5E66FD2CECDE3A46C54FF815542FF969191FFB8B8B9FFDCDCDCD3EFEF - EF1EECECEC000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000DCECDB00FFF9FF099CDD98BA50C0 - 4AFF13800DFF155912FFA3AEA3FFE6E5E686CECECE0000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000F3CAA700EC843B00F1AE - 7937ED9A64D2C96D40FF884A2EFF9B8D89FFB1B1B3FFBFBFC0FFD3D3D3E5E0E0 - E0A2E8E8E865EDEDED32EEEFEE1BEFEFEF1AEEEEEE23EBEBEB47E4E3E480D9D9 - D9C5C7C8C9F8B0A8A6FFA36347FF7A310FFF6F4C3DFFB1ACAAFFDEDEDED2EFEF - EF1FECECEC000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000E7EEE700FFFCFF09A2DE9FB953C2 - 4DFF15830EFF10570EFF9CA89CFFE5E3E590B7B7B700FBFBFB00000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000F2D0AF00EC82 - 3E00F1AE7C36ED9A67C5CB6F41FE975436FFA58F86FFB7B6B7FFBABBBCFFC3C3 - C4FFCDCDCDFCD3D3D3E9D6D6D6DBD7D7D7DAD4D4D4E0CECECFF2C4C5C6FEB5B6 - B7FFA59690FFA66142FFB54A18FFA24215FF7B310FFF946651F9DCD3CF6A5805 - 0000F2F2F2000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000EFEFEF00F0F0F00FF0EBF05EADDCAADF50C2 - 4AFF15850FFF0B5608FF919F91FFE1DFE1A6FFFFFF06EFEFEF00000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000F6FF - F100EB783600F1B78B22ED9D6E99D7784AF0B05B34FFA97862FFBBABA3FFC1BF - BEFFC2C4C6FFC2C3C5FFC1C2C3FFC0C1C3FFBDBEC0FFB8B6B8FFAFA39FFFA77D - 69FFAB552CFFBF4D19FFCB521BFFC4501BFEAE4D20E1A05A3981B98F7D11AF7C - 6500000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000E9EAE900EEEDEE4BE4E1E4F5A3CCA1FF3EB8 - 37FF12850CFF085405FF849484FFDAD8D9E5EDEDED32E8E8E800000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000FFFFFF00F3BB9500F6CFB009F2A57C4AE48455A8CB6738E9B65B30FDB56F - 4FFFB98871FFBA9482FFBA9989FFB79382FFB58772FFB37356FFB5582DFFC250 - 1CFFD25920FED95C24F5D8662FD7D56E3F8CD27D562FDAB09603D59575000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000A5D8A3006BC76803CCE3CA43E0E3E0E4A9D0A6FF4BBD - 45FF1F9319FF085E04FF849A83FFDEDCDEF9EBEBEB5BE3E3E400000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000F1A77D00F7C4A40AEE936731E17B4C71CC5D - 2AAABA4F1DC4B55325DBB25327E5B05124ECB55021E5C05422DBCE5A25C7D862 - 2BAEE0723E85E1764445E3946C1FF9F0E805F4DCCD0000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000090CF8B0093D08F1358BC53736FCA6AD984D77FFF77D5 - 71FF42B63AFF0F8109FF589456FFD7DFD7ADF4F2F517EBEBEB00000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000FFFFFF00FFFFFF00FCCF - B804E69E7C0FDE987624D789632ED0805834D586602EDA8D6A24E4A58512EDC1 - A705FFFFFF01FCFAF60000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000007AC574007BDB710078CE72096CD3663D73DA6D8A71D7 - 6BA154C54CA024A11D9F2B8B279F6CA96B65BDD9B809A9CCA300000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FFFFFF000037000063D35C0270D6 - 6C0597D991057AD573049CDB98057EB87C08A6C9A102A6C9A000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000} - Transparent = True - end - object sLabel3: TsLabel - Left = 24 - Top = 128 - Width = 35 - Height = 13 - Caption = 'Status:' - end - object LabelStatus: TsLabel - Left = 88 - Top = 128 - Width = 167 - Height = 13 - Caption = 'Please input email and password...' - end - object EditGoogleEmail: TsEdit - Left = 88 - Top = 71 - Width = 200 - Height = 19 - Ctl3D = False - ParentCtl3D = False - TabOrder = 0 - OnChange = EditGoogleEmailChange - SkinData.SkinSection = 'EDIT' - BoundLabel.Indent = 0 - BoundLabel.Font.Charset = DEFAULT_CHARSET - BoundLabel.Font.Color = clWindowText - BoundLabel.Font.Height = -11 - BoundLabel.Font.Name = 'Tahoma' - BoundLabel.Font.Style = [] - BoundLabel.Layout = sclLeft - BoundLabel.MaxWidth = 0 - BoundLabel.UseSkinColor = True - end - object EditGooglePassword: TsEdit - Left = 88 - Top = 98 - Width = 200 - Height = 19 - Ctl3D = False - ParentCtl3D = False - TabOrder = 1 - OnChange = EditGoogleEmailChange - SkinData.SkinSection = 'EDIT' - BoundLabel.Indent = 0 - BoundLabel.Font.Charset = DEFAULT_CHARSET - BoundLabel.Font.Color = clWindowText - BoundLabel.Font.Height = -11 - BoundLabel.Font.Name = 'Tahoma' - BoundLabel.Font.Style = [] - BoundLabel.Layout = sclLeft - BoundLabel.MaxWidth = 0 - BoundLabel.UseSkinColor = True - end - end -end diff --git a/demos/contacts_demo/main.dfm b/demos/contacts_demo/main.dfm deleted file mode 100644 index 2f81fb7..0000000 --- a/demos/contacts_demo/main.dfm +++ /dev/null @@ -1,2589 +0,0 @@ -object Form3: TForm3 - Left = 0 - Top = 0 - Caption = 'Google Contacts API' - ClientHeight = 351 - ClientWidth = 671 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - Menu = MainMenu1 - OldCreateOrder = False - PixelsPerInch = 96 - TextHeight = 13 - object Splitter1: TSplitter - Left = 217 - Top = 38 - Height = 294 - ExplicitLeft = 244 - ExplicitTop = 108 - ExplicitHeight = 100 - end - object StatusBar1: TStatusBar - Left = 0 - Top = 332 - Width = 671 - Height = 19 - Panels = < - item - Text = #1043#1088#1091#1087#1087 - Width = 50 - end - item - Width = 50 - end - item - Text = #1050#1086#1085#1090#1072#1082#1090#1086#1074 - Width = 70 - end - item - Width = 60 - end - item - Text = #1042#1088#1077#1084#1103' '#1087#1086#1083#1091#1095#1077#1085#1080#1103' '#1076#1072#1085#1085#1099#1093 - Width = 150 - end - item - Width = 50 - end> - end - object ToolBar1: TToolBar - Left = 0 - Top = 0 - Width = 671 - Height = 38 - AutoSize = True - ButtonHeight = 38 - ButtonWidth = 173 - Caption = 'ToolBar1' - DrawingStyle = dsGradient - Images = ImageList1 - List = True - ParentShowHint = False - ShowCaptions = True - AllowTextButtons = True - ShowHint = True - TabOrder = 1 - object ToolButton1: TToolButton - Left = 0 - Top = 0 - Hint = 'Login' - AutoSize = True - Caption = 'Login' - ImageIndex = 0 - OnClick = ToolButton1Click - end - object ToolButton2: TToolButton - Left = 40 - Top = 0 - Hint = #1055#1086#1083#1091#1095#1080#1090#1100' '#1082#1086#1085#1090#1072#1082#1090#1099 - AutoSize = True - Caption = #1055#1086#1083#1091#1095#1080#1090#1100' '#1082#1086#1085#1090#1072#1082#1090#1099 - Enabled = False - ImageIndex = 1 - OnClick = ToolButton2Click - end - object ToolButton3: TToolButton - Left = 80 - Top = 0 - Hint = #1044#1086#1073#1072#1074#1080#1090#1100' '#1092#1086#1090#1086 - AutoSize = True - Caption = #1044#1086#1073#1072#1074#1080#1090#1100' '#1092#1086#1090#1086 - Enabled = False - ImageIndex = 2 - OnClick = ToolButton3Click - end - object ToolButton4: TToolButton - Left = 120 - Top = 0 - Hint = #1059#1076#1072#1083#1080#1090#1100' '#1092#1086#1090#1086 - AutoSize = True - Caption = 'Delete Photo' - Enabled = False - ImageIndex = 4 - OnClick = ToolButton4Click - end - object ToolButton7: TToolButton - Left = 160 - Top = 0 - Hint = #1056#1077#1076#1072#1082#1090#1080#1088#1086#1074#1072#1090#1100' '#1082#1086#1085#1090#1072#1082#1090 - Caption = #1056#1077#1076#1072#1082#1090#1080#1088#1086#1074#1072#1090#1100' '#1082#1086#1085#1090#1072#1082#1090 - Enabled = False - ImageIndex = 6 - OnClick = ToolButton7Click - end - object ToolButton6: TToolButton - Left = 200 - Top = 0 - Hint = #1044#1086#1073#1072#1074#1080#1090#1100' '#1085#1086#1074#1099#1081' '#1082#1086#1085#1090#1072#1082#1090 - Caption = #1044#1086#1073#1072#1074#1080#1090#1100' '#1085#1086#1074#1099#1081' '#1082#1086#1085#1090#1072#1082#1090 - Enabled = False - ImageIndex = 3 - OnClick = ToolButton6Click - end - object ToolButton10: TToolButton - Left = 240 - Top = 0 - Hint = #1044#1086#1073#1072#1074#1080#1090#1100' '#1075#1088#1091#1087#1087#1091' '#1082#1086#1085#1090#1072#1082#1090#1086#1074 - Caption = 'ToolButton10' - Enabled = False - ImageIndex = 9 - OnClick = ToolButton10Click - end - object ToolButton11: TToolButton - Left = 280 - Top = 0 - Hint = #1056#1077#1076#1072#1082#1090#1080#1088#1086#1074#1072#1090#1100' '#1075#1088#1091#1087#1087#1091 - Caption = 'ToolButton11' - Enabled = False - ImageIndex = 10 - OnClick = ToolButton11Click - end - object ToolButton12: TToolButton - Left = 320 - Top = 0 - Hint = #1059#1076#1072#1083#1080#1090#1100' '#1075#1088#1091#1087#1087#1091' '#1082#1086#1085#1090#1072#1082#1090#1086#1074 - Caption = 'ToolButton12' - Enabled = False - ImageIndex = 11 - OnClick = ToolButton12Click - end - object ToolButton8: TToolButton - Left = 360 - Top = 0 - Hint = #1057#1086#1093#1088#1072#1085#1080#1090#1100' '#1082#1086#1085#1090#1072#1082#1090#1099' '#1074' '#1092#1072#1081#1083 - Caption = 'ToolButton8' - Enabled = False - ImageIndex = 8 - OnClick = ToolButton8Click - end - object ToolButton9: TToolButton - Left = 400 - Top = 0 - Hint = #1047#1072#1075#1088#1091#1079#1080#1090#1100' '#1082#1086#1085#1090#1072#1082#1090#1099' '#1080#1079' '#1092#1072#1081#1083#1072 - Caption = 'ToolButton9' - Enabled = False - ImageIndex = 7 - OnClick = ToolButton9Click - end - object ToolButton5: TToolButton - AlignWithMargins = True - Left = 440 - Top = 0 - Hint = #1059#1076#1072#1083#1080#1090#1100' '#1082#1086#1085#1090#1072#1082#1090 - AutoSize = True - Caption = #1059#1076#1072#1083#1080#1090#1100' '#1082#1086#1085#1090#1072#1082#1090 - Enabled = False - ImageIndex = 5 - OnClick = ToolButton5Click - end - end - object Panel1: TPanel - Left = 0 - Top = 38 - Width = 217 - Height = 294 - Align = alLeft - BevelOuter = bvNone - TabOrder = 2 - object Label5: TLabel - Left = 0 - Top = 0 - Width = 217 - Height = 13 - Align = alTop - Caption = #1043#1088#1091#1087#1087#1072':' - ExplicitWidth = 40 - end - object ComboBox1: TComboBox - Left = 0 - Top = 13 - Width = 217 - Height = 21 - Align = alTop - Style = csDropDownList - TabOrder = 0 - OnChange = ComboBox1Change - end - object GroupBox1: TGroupBox - Left = 0 - Top = 34 - Width = 217 - Height = 260 - Align = alClient - Caption = #1050#1086#1085#1090#1072#1082#1090#1099 - TabOrder = 1 - object ListBox1: TListBox - Left = 2 - Top = 15 - Width = 213 - Height = 243 - Align = alClient - ItemHeight = 13 - TabOrder = 0 - OnClick = ListBox1Click - end - end - end - object Panel2: TPanel - Left = 220 - Top = 38 - Width = 451 - Height = 294 - Align = alClient - BevelOuter = bvNone - TabOrder = 3 - object Label1: TLabel - Left = 12 - Top = 6 - Width = 35 - Height = 13 - Caption = #1060'.'#1048'.'#1054'.' - end - object Label2: TLabel - Left = 91 - Top = 6 - Width = 12 - Height = 13 - Caption = '---' - end - object Label3: TLabel - Left = 12 - Top = 25 - Width = 57 - Height = 13 - Caption = #1044#1086#1083#1078#1085#1086#1089#1090#1100 - end - object Label4: TLabel - Left = 91 - Top = 25 - Width = 12 - Height = 13 - Caption = '---' - end - object Label6: TLabel - Left = 12 - Top = 68 - Width = 28 - Height = 13 - Caption = 'E-mail' - end - object Label7: TLabel - Left = 255 - Top = 67 - Width = 12 - Height = 13 - Caption = '---' - end - object Label8: TLabel - Left = 12 - Top = 95 - Width = 73 - Height = 13 - Caption = #1058#1077#1083#1077#1092#1086#1085'/'#1060#1072#1082#1089 - end - object Label9: TLabel - Left = 255 - Top = 94 - Width = 12 - Height = 13 - Caption = '---' - end - object Label10: TLabel - Left = 12 - Top = 120 - Width = 37 - Height = 13 - Caption = #1040#1076#1088#1077#1089#1072 - end - object Label11: TLabel - Left = 12 - Top = 183 - Width = 74 - Height = 13 - Caption = #1057#1087#1080#1089#1086#1082' '#1089#1072#1081#1090#1086#1074 - end - object Label12: TLabel - Left = 13 - Top = 210 - Width = 72 - Height = 13 - Caption = #1050#1088#1091#1075' '#1086#1073#1097#1077#1085#1080#1103 - end - object Label13: TLabel - Left = 256 - Top = 209 - Width = 12 - Height = 13 - Caption = '---' - end - object Label14: TLabel - Left = 13 - Top = 237 - Width = 47 - Height = 13 - Caption = #1054#1073#1097#1077#1085#1080#1077 - end - object Label15: TLabel - Left = 12 - Top = 264 - Width = 37 - Height = 13 - Caption = #1044#1088#1091#1075#1086#1077 - end - object Image1: TImage - Left = 340 - Top = 6 - Width = 105 - Height = 105 - end - object Label17: TLabel - Left = 384 - Top = 183 - Width = 12 - Height = 13 - Caption = '---' - end - object Label18: TLabel - Left = 256 - Top = 236 - Width = 12 - Height = 13 - Caption = '---' - end - object Label19: TLabel - Left = 255 - Top = 263 - Width = 12 - Height = 13 - Caption = '---' - end - object Label16: TLabel - Left = 12 - Top = 44 - Width = 80 - Height = 13 - Caption = #1044#1077#1085#1100' '#1088#1086#1078#1076#1077#1085#1080#1103 - end - object Label20: TLabel - Left = 103 - Top = 44 - Width = 12 - Height = 13 - Caption = '---' - end - object ComboBox2: TComboBox - Left = 91 - Top = 64 - Width = 158 - Height = 21 - Style = csDropDownList - TabOrder = 0 - OnChange = ComboBox2Change - end - object ComboBox3: TComboBox - Left = 91 - Top = 91 - Width = 158 - Height = 21 - Style = csDropDownList - TabOrder = 1 - OnChange = ComboBox3Change - end - object ListBox2: TListBox - Left = 12 - Top = 139 - Width = 433 - Height = 34 - ItemHeight = 13 - TabOrder = 2 - end - object ComboBox4: TComboBox - Left = 92 - Top = 179 - Width = 286 - Height = 21 - Style = csDropDownList - TabOrder = 3 - OnChange = ComboBox4Change - end - object ComboBox5: TComboBox - Left = 92 - Top = 206 - Width = 158 - Height = 21 - Style = csDropDownList - TabOrder = 4 - OnChange = ComboBox5Change - end - object ComboBox6: TComboBox - Left = 92 - Top = 233 - Width = 158 - Height = 21 - Style = csDropDownList - TabOrder = 5 - OnChange = ComboBox6Change - end - object ComboBox7: TComboBox - Left = 92 - Top = 260 - Width = 157 - Height = 21 - Style = csDropDownList - TabOrder = 6 - OnChange = ComboBox7Change - end - end - object MainMenu1: TMainMenu - Left = 152 - Top = 176 - object N1: TMenuItem - Caption = #1060#1072#1081#1083 - end - end - object ImageList1: TImageList - Height = 32 - Width = 32 - Left = 96 - Top = 236 - Bitmap = { - 494C01010C001C00840120002000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 - 0000000000003600000028000000800000008000000001002000000000000000 - 0100000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000002B2E33FF34363BFF3436 - 3BFF2D2F34FF838487FF828487FF828387FF828386FF818386FF818386FF8082 - 85FF808285FF808285FF808284FF808184FF7F8184FF7F8184FF7F8083FF7F80 - 83FF7E8083FF7E7F82FF7E7F82FF7D7F82FF7C7E81FF7C7E81FF7C7D80FF1F22 - 27FF24272CFF23262BFF111419FF000000000000000000000000000000000000 - 000000000000000000000000000000000000D7BAAD8B91401AFE8C3812FF8A33 - 11FF853903FF893618FF88351DFFC49D97A00000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000FDFCFB07C59A86AA91401AFF8D3A14FF8B38 - 0FFF853703FF883316FF88351EFED3B7B2780000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000D7BAAD8B91401AFE8C3812FF8A33 - 11FF853903FF893618FF88351DFFC49D96A0ECEDEE53838486FF848487FF8485 - 87FF707274FFCFCFD08700000000000000000000000000000000000000000000 - 000000000000000000000000000000000000717376C345464AFF45464AFF4546 - 4AFF393A3EFFC0C0C1FFC3C3C4FFC3C3C4FFC3C3C4FFC3C3C4FFC3C3C4FFC3C3 - C4FFC3C3C4FFC3C3C4FFC3C3C4FFC3C3C4FFC3C3C4FFC3C3C4FFC3C3C4FFC3C3 - C4FFC3C3C4FFC3C3C4FFC3C3C4FFC3C3C4FFC3C3C4FFC3C3C4FFBFBFC0FF2C2E - 32FF33363AFF323539FF313438FF9A9C9D8C0000000000000000000000000000 - 0000FEFEFE018F3B0FFF954514FF974713FF984813FF994913FF994913FF9645 - 14FF8A4105FF934216FF903E17FFAF6804FFB36E00FFA86006FFC59F9C9F0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000F8F2F0298E3A0CFF954514FF974713FF984813FF994913FF984813FF994C - 10FF8B4305FF924115FF8F3D17FFB77300FFB46F00FF97490DFFEFE5E43A0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000FEFEFE018F3B0FFF954514FF974713FF984813FF994913FF994913FF9645 - 14FF8A4105FF934216FF99877FFFECECECFFFFFFFFFFE3E3E4FFDCDCDAFFE1E1 - DEFFE9EAEAFFFFFFFFFFFDFDFDFF6F7072FD0000000000000000000000000000 - 000000000000000000000000000000000000585B5FD24A4B4FFF47484CFF4748 - 4CFF3A3C40FFC4C4C5FFC8C8C9FFC8C8C9FFC8C8C9FFC8C8C9FFC8C8C9FFC8C8 - C9FFC8C8C9FFC8C8C9FFC8C8C9FFC8C8C9FFC8C8C9FFC8C8C9FFC8C8C9FFC8C8 - C9FFC8C8C9FFC8C8C9FFC8C8C9FFC8C8C9FFC8C8C9FFC8C8C9FFC3C3C4FF2C2F - 33FF35373BFF33363AFF323539FF77797C9F000000000000000000000000903C - 10FF984813FF9B4C13FF9E4F11FFA05210FFA15310FFA2540FFFA2540FFFA152 - 10FF8E4601FF9C4D12FF984813FFA96008FFB57000FFB26C00FFCE912AFF9956 - 52DE000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000F9F4F21F9342 - 14FF984813FF9C4D12FF9F5011FFA15310FFA15310FFA2540FFFA15310FFA153 - 10FF8F4801FF9C4D12FF984813FFB87400FFB57000FFB57103FFBD7B11FFF8F3 - F234000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000903C - 10FF984813FF9B4C13FF9E4F11FFA05210FFA15310FFA2540FFFA2540FFFA152 - 10FF8E4601FFA2A6AAFFFFFFFFFFC2C3C0FF0D0F57FF1A2093FF1A2090FF1A20 - 90FF1A2090FF0E1588FFE4E5E6FFFFFFFFFF9A9B9DFF00000000000000000000 - 0000000000000000000000000000000000005B5D60D2505155FF494A4EFF494A - 4EFF3B3D41FFC9C9CAFFCCCCCDFFCCCCCDFFCCCCCDFFCCCCCDFFCCCCCDFFCCCC - CDFFCCCCCDFFCCCCCDFFCCCCCDFFCCCCCDFFCCCCCDFFCCCCCDFFCCCCCDFFCCCC - CDFFCCCCCDFFCCCCCDFFCCCCCDFFCCCCCDFFCCCCCDFFCCCCCDFFC9C9CAFF2C2F - 33FF36383CFF35373BFF33363AFF787A7D9F00000000EADAD26D954C0AFF9B4C - 13FFA05210FFA4560FFFA75A0DFFAA5D0CFFAB5F0BFFAC600BFFAB5F0BFFAA5E - 0BFF985100FFA5580EFFA15310FFAB6109FFB77200FFB57000FFD1952FFF9F54 - 0AFF000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000A05A36EC984813FF9C4D - 12FFA05210FFA4570EFFA75A0DFFAA5E0CFFAB5F0BFFAC600BFFAB5F0BFFAA5D - 0CFF9E5300FF57667BFFA55109FFB97500FFB67100FFB36E00FFD1952FFF964F - 3BED000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000EADAD26D954C0AFF9B4C - 13FFA05210FFA4560FFFA75A0DFFAA5D0CFFAB5F0BFFAC600BFFAB5F0BFFAA5E - 0CFFACAFB4FFFAFAFAFF37386BFF1A2199FF1A2198FF1A2199FF1A219AFF1A21 - 9AFF1A2199FF1A2197FF1A2194FF13198EFFF5F6F6FFABACADFF000000000000 - 0000000000000000000000000000000000005C5F63D256575AFF4C4D50FF4C4D - 50FF3C3E42FFCDCDCEFFD0D0D1FFD0D0D1FFD0D0D1FFD0D0D1FFD0D0D1FFD0D0 - D1FFD0D0D1FFD0D0D1FFD0D0D1FFD0D0D1FFD0D0D1FFD0D0D1FFD0D0D1FFD0D0 - D1FFD0D0D1FFD0D0D1FFD0D0D1FFD0D0D1FFD0D0D1FFD0D0D1FFCDCDCEFF2D30 - 34FF37393DFF36383CFF35373BFF787A7D9FFEFEFE098B4305FFA0570BFFA356 - 0FFFA85C0CFFAC610AFFB06508FFB36907FFB46A06FFB56B06FFB46A06FFB369 - 07FFAA6500FFAD620AFFA95D0CFFB26A05FFB97400FFB77200FFD1952FFFA156 - 07FF000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000D4B5A59D8B4305FF9E4E12FFA457 - 0EFFA95D0CFFAD620AFFB06608FFB36907FFB46A06FFB56B06FFB46A06FFB369 - 07FFA05A00FF9DD9FFFF4C8CD2FF158AE7FFC27200FFB67100FFD19630FFA25F - 45E6000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FEFEFE098B4305FFA0570BFFA356 - 0FFFA85C0CFFAC610AFFB06508FFB36907FFB46A06FFB56B06FFB46A06FFB6AC - 9DFFFFFFFFFF303167FF1B229CFF1B229DFF272B83FF1B229FFF1B22A0FF1B22 - A0FF1B229FFF131997FF1B229DFF1A219AFF0E1490FFFDFDFDFF636466FF0000 - 000000000000000000000000000000000000606165D25C5D5FFF4E4F52FF4E4F - 52FF3E3F44FFD2D2D3FFD4D4D5FFD4D4D5FFD4D4D5FFD4D4D5FFD4D4D5FFD4D4 - D5FFD4D4D5FFD4D4D5FFD4D4D5FFD4D4D5FFD4D4D5FFD4D4D5FFD4D4D5FFD4D4 - D5FFD4D4D5FFD4D4D5FFD4D4D5FFD4D4D5FFD4D4D5FFD4D4D5FFD1D1D2FF2D31 - 35FF383B3FFF37393DFF36383CFF797B7D9F964410FF8E4602FFA65D0AFFAB5F - 0BFFB06508FFB56B06FFB97004FFBB7303FFBD7502FFBE7702FFBD7602FFBC74 - 03FFB97004FFB66C06FFB16708FFBB7501FFBB7600FFB97400FFD19630FF9948 - 01FF000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000914406FF8E4602FFA5570FFFAB60 - 0AFFB16608FFB56B06FFB97004FFBC7403FFBD7602FFBE7702FFBD7602FFBC74 - 03FFB06901FFB66D0BFFA3D3F8FF0BA7ECFF1A8AEAFFC27100FFD29731FFC092 - 7DB8000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000964410FF8E4602FFA65D0AFFAB5F - 0BFFB06508FFB56B06FFB97004FFBB7303FFBD7502FFBE7702FFBD7500FFF7F8 - F8FF9B9C9BFF1B229FFF1B22A0FFE1E0E1FFF0F0F0FF1E2282FF1B22A5FF1B22 - A5FF10169BFFD5D5D6FFD9D9D5FF1B22A0FF1B229DFFABAED2FFFFFFFFFF0000 - 000000000000000000000000000000000000616466D2616265FF505154FF5051 - 54FF3F4145FFD6D6D7FFD8D8D9FFD8D8D9FFD8D8D9FFD8D8D9FFD8D8D9FFD8D8 - D9FFD8D8D9FFD8D8D9FFD8D8D9FFD8D8D9FFD8D8D9FFD8D8D9FFD8D8D9FFD8D8 - D9FFD8D8D9FFD8D8D9FFD8D8D9FFD8D8D9FFD8D8D9FFD8D8D9FFD5D5D7FF2E31 - 35FF393C40FF383A3EFF37393DFF7A7C7E9FA65F27F4934C00FFAD6606FFB267 - 08FFB86F05FFBD7502FFC17A00FFC37E05FFC58008FFC5800AFFC58009FFC47E - 06FFC27C00FFBE7702FFB97004FFBF7A00FFBC7700FFBB7600FFD29630FF9A4B - 15FF000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000974803FF934C00FFAC600BFFB369 - 07FFB97004FFBD7602FFC27B00FFC37E05FFC58009FFC5800AFFC58009FFC37E - 05FFC27B00FFBD7602FF519FF6FF00AAF3FF0BA6ECFF1A8AEAFFDD9624FFECDD - D562000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000A65F27F4934C00FFAD6606FFB267 - 08FFB86F05FFBD7502FFC17A00FFC37E05FFC58008FFC5800AFFC5A265FFFFFF - FFFF0F0F4CFF1B22A2FF5B5B80FFFAFAFAFFF9F9F9FFF6F6F6FF1D2185FF0F15 - A1FFE3E3E3FFDBDBDCFFD2D2D3FFB4B4B6FF1B22A1FF1A219DFFF7F7F7FF7373 - 76FF00000000000000000000000000000000636568D367686AFF525356FF5253 - 56FF414346FFDADADBFFDCDCDDFFDCDCDDFFDCDCDDFFDCDCDDFFDCDCDDFFDCDC - DDFFDCDCDDFFDCDCDDFFDCDCDDFFDCDCDDFFDCDCDDFFDCDCDDFFDCDCDDFFDCDC - DDFFDCDCDDFFDCDCDDFFDCDCDDFFDCDCDDFFDCDCDDFFDCDCDDFFDADADBFF2F32 - 36FF3B3D41FF393B3FFF383A3EFF7A7C7F9FEEDFD25C9D5700FFB37102FFB970 - 04FFBF7701FFC37E05FFC8830DFFCA8713FFCC8916FFCC8A18FFCC8917FFCB87 - 13FFC8840EFFC57F08FFC07900FFC27F07FFBE7900FFBC7700FFD1952EFFE6CD - BD7ECFE4D6572A8947FF268845FF298947FF298846FF296E2AFF298441FF227C - 37FF498F57EA000000000000000000000000A75B15FC9D5700FFB36907FFBA71 - 04FFC07801FFC47F07FFC8830EFFCB8713FFCC8917FFCC8A18FFCC8917FFCA87 - 13FFC8830DFFC47E06FFBF7700FF5AA4F6FF00AAF3FF0CA6EBFF1A8AEAFF0000 - 0000AED2B98920833FFF268745FF298947FF2A9453FF296D2AFF298340FF2689 - 45FF78AB81C6000000000000000000000000EEDFD25C9D5700FFB37102FFB970 - 04FFBF7701FFC37E05FFC8830DFFCA8713FFCC8916FFCC8A18FFC9CDD5FFA7A7 - A8FF191E87FF1B22A6FF1B23AFFF5D5D88FFFDFDFDFFFDFDFDFFF8F8F8FFEFEF - F0FFE8E8E8FFDFDFE0FFBABABEFF1B22A8FF1B22A5FF1B22A2FFEBEBE5FFA7A6 - A9FF498F57EA00000000000000000000000065676AD36C6D6FFF545558FF5455 - 58FF424447FFDFDFE0FFE1E1E2FFE1E1E2FFE1E1E2FFE1E1E2FFE1E1E2FFE1E1 - E2FFE1E1E2FFE1E1E2FFE1E1E2FFE1E1E2FFE1E1E2FFE1E1E2FFE1E1E2FFE1E1 - E2FFE1E1E2FFE1E1E2FFE1E1E2FFE1E1E2FFE1E1E2FFE1E1E2FFDFDFE0FF2F32 - 36FF3C3E42FF3A3C40FF393B3FFF7A7C7F9F00000000A86300FFB77500FFBF77 - 01FFC47F07FFC98510FFCF8F1CFFD39422FFD39523FFD29426FFD19326FFD090 - 21FFCD8C1BFFCA8713FFC8830CFFC8850EFFC27F07FFC27F09FFBD7801FF2290 - 4FFF298F4DFF29914FFF299250FF299250FF29914EFF297B39FF298C4AFF2886 - 44FF32AC6CFF31AB6AFF248541FF00000000F2E6DA4BA86300FFB97402FFC078 - 01FFC58008FFC98511FFD0901EFFD39522FFD39524FFD29426FFD19326FFD090 - 21FFCD8B1AFFCA8612FFCB8A13FFC7830CFF64A9F6FF00ABF2FF0DA6EBFF1A8A - EBFF2A9044FF299250FF299250FF299250FF2A9756FF297D3BFF298C4AFF2B8F - 4DFF32AC6CFF36AF70FF1D712BFF0000000000000000A86300FFB77500FFBF77 - 01FFC47F07FFC98510FFCF8F1CFFD39422FFD39523FFD29426FFD8DADDFF8384 - 82FF1B23ACFF1B22ABFF1B22AEFF1B23B7FF5E5E88FFFDFDFDFFFDFDFDFFF4F4 - F4FFEBEBECFFC4C4C9FF1B22B0FF1B22ADFF1B22A9FF1B22A6FFC4C5D6FFE9E9 - EAFF32AC6CFF31AB6AFF248541FF00000000676A6DD3727375FF56575AFF5657 - 5AFF434549FFE4E4E4FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5 - E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5 - E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5E5FFE3E3E3FF3032 - 37FF3D3F43FF3B3D41FF3A3C40FF7B7D7F9F00000000B26C02FFB36F00FFC37D - 04FFCA8713FFD59924FFD59924FFD79820FFD69824FFD59823FFD59823FFD598 - 23FFD49724FFCF8E1EFFD1921CFFCC8C15FFC8850EFFD29631FFB76304FF2996 - 54FF299857FF299A58FF299B59FF299B59FF299958FF298745FF299453FF288F - 4CFF34AE6EFF33AC6CFF44BA7FFF8AB5919A00000000B26E00FFBB7800FFC47F - 06FFD2941FFFD59924FFD59824FFD79820FFD59824FFD59823FFD59823FFD598 - 23FFD39525FFCE8D1CFFD0911BFFCB8B13FFC7830BFF6EB0F7FF00AAF2FF0EA5 - EBFF1A8AEBFF2A9B4FFF299B59FF299B59FF299958FF298B49FF299452FF2A92 - 50FF34AE6EFF32AB6BFF45BB80FF0000000000000000B26C02FFB36F00FFC37D - 04FFCA8713FFD59924FFD59924FFD79820FFD69824FFD59823FFDFE0E2FF7B7D - 7CFF1B23B0FF1B22AFFF1B22B3FF1B22B6FF0E15B1FFFDFDFDFFFDFDFDFFF7F7 - F7FFEDEDEDFF1D218BFF1B22B5FF1B22B2FF1B22AEFF1B22A9FFB4B4CEFFEFEF - F0FF34AE6EFF33AC6CFF44BA7FFF8AB5919A696A6FD377787AFF58595CFF5859 - 5CFF45464AFFE8E8E8FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9 - E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9 - E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFE8E8E8FF3033 - 37FF3D3F43FF3C3E42FF3B3D41FF7C7D809F00000000F0E0CA74BC7900FFC781 - 0BFFD69A26FFD59924FFFDEAD0FFCFDAE8FFF8E2C2FFE3CBA7FFD69923FFD598 - 23FFD59823FFD59823FFD59823FFD1921CFFD0932AFFC8860DFF219C5DFF299E - 5DFF29A15FFF29A362FF29A462FF29A462FF29A361FF299352FF299D5BFF2897 - 55FF36AF70FF35AE6EFF44BA7FFF73AC80A600000000B86D02FFBC7900FFC883 - 0EFFD59925FFD59823FFF6ECDDFFE1E5E7FFF3DBB8FFCAA875FFD59823FFD598 - 23FFD59823FFD59823FFD49722FFD0911BFFD19631FFC07A08FF79B7F6FF00AA - F3FF0EA5EAFF1A8AEBFF2AA55AFF29A362FF29A261FF299755FF299C5AFF2A9A - 59FF36AF70FF34AE6DFF45BB80FF0000000000000000F0E0CA74BC7900FFC781 - 0BFFD69A26FFD59924FFFDEAD0FFCFDAE8FFF8E2C2FFE3CBA7FFDADEE4FF8485 - 86FF1B21A8FF1B22B3FF1B22B7FF0E16B0FFFEFEFEFFFDFDFDFFFDFDFDFFF6F6 - F6FFEDEDEDFFE4E4E4FF1D218CFF1B22B5FF1B22B1FF1B22ACFFD7D7D2FFC8C9 - CAFF36AF70FF35AE6EFF44BA7FFF73AC80A66B6E70D37C7D80FF5A5B5EFF5A5B - 5EFF46484BFFECECEDFFEDEDEEFFEDEDEEFFEDEDEEFFEDEDEEFFEDEDEEFFEDED - EEFFEDEDEEFFEDEDEEFFEDEDEEFFEDEDEEFFEDEDEEFFEDEDEEFFEDEDEEFFEDED - EEFFEDEDEEFFEDEDEEFFEDEDEEFFEDEDEEFFEDEDEEFFEDEDEEFFECECEDFF3133 - 38FF3F4044FF3D3F43FF3C3E42FF7C7D819F0000000000000000BF7500FFC481 - 06FFD59824FFD3951CFF85AEDCFF81A9DBFF79A4D7FF84AAD5FFF5DDBCFFD699 - 23FFD59823FFD59823FFD59823FFD2962BFFD2931DFF329A55FF29A160FF29A6 - 65FF29AA68FF29AB6AFF29AD6CFF29AD6CFF29AB6AFF29A261FF29A463FF289E - 5DFF38B172FF36B070FF45BB80FFBEDAC67A0000000000000000C17D00FFCA86 - 13FFD59A25FFDEA947FF84ADDCFF80A8DBFF78A3D6FFC7D8E9FFF3DDBEFFD598 - 23FFD59823FFD59823FFD59823FFD19530FFCC8B13FF219F61FF28A260FF81BE - F7FF00AAF3FF0FA5EAFF1A8AEBFF2AAE63FF29AB6AFF29A160FF29A462FF2FA6 - 65FF38B172FF36AF70FF43B97EFF000000000000000000000000BF7500FFC481 - 06FFD59824FFD3951CFF85AEDCFF81A9DBFF79A4D7FF84AAD5FFE2DDD5FFF2F2 - F2FF141557FF1B22B6FF0F16B0FFFDFDFDFFFDFDFDFFFDFDFDFFD9D9DEFF5A5A - 85FFEBEBEBFFE1E1E2FFD9D9D9FF1D218CFF1B22B4FF1B22AFFFDADADAFF918A - 90FF38B172FF36B070FF45BB80FFBEDAC67A6E6F73D3818284FF5C5D60FF5C5D - 60FF47494CFFF0F0F1FFF1F1F2FFF1F1F2FFF1F1F2FFF1F1F2FFF1F1F2FFF1F1 - F2FFF1F1F2FFF1F1F2FFF1F1F2FFF1F1F2FFF1F1F2FFF1F1F2FFF1F1F2FFF1F1 - F2FFF1F1F2FFF1F1F2FFF1F1F2FFF1F1F2FFF1F1F2FFF1F1F2FFF0F0F1FF3134 - 38FF404145FF3E4044FF3D3F43FF7C7D819F000000000000000000000000CA88 - 13FFD09122FFD7971BFF85AEDCFF81A9DBFF79A4D7FF719FD3FF6395CBFFF1DB - BCFFD59823FFD59823FFD39729FFD38F1BFF329A61FF29A362FF29A968FF29AE - 6DFF29B06FFF29B170FF29B171FF29B170FF29B170FF29B06FFF29AC6BFF2DAB - 6AFF3AB274FF38B172FF44BA7FFFF8FBF924000000000000000000000000C882 - 06FFD29327FFD6A546FF84ADDCFF80A8DBFF78A3D6FF6F9DD2FFAFC8DFFFCBA8 - 72FFD59823FFD59823FFD59824FFD68813FF39A266FF29A463FF29AA69FF28AF - 6DFF86C5F7FF00AAF2FF10A4EAFF1A8AEBFF2AB368FF29AE6DFF29AB6AFF3AB3 - 74FF39B274FF37B171FF3CB477FF00000000000000000000000000000000CA88 - 13FFD09122FFD7971BFF85AEDCFF81A9DBFF79A4D7FF719FD3FF6496CCFFFFFF - FFFF585A70FF1B22BAFF161759FFFFFFFFFFFDFDFDFFDAD9DCFF1B23CDFF1B24 - D4FF565681FFDEDEDEFFD5D5D6FF131AB7FF1B22B6FF3036B3FFFFFFFFFF45A7 - 75FF3AB274FF38B172FF44BA7FFFF8FBF924707275D3868789FF5E5F62FF5E5F - 62FF484A4DFFF5F5F5FFF6F6F6FFF6F6F6FFF6F6F6FFF6F6F6FFF6F6F6FFF6F6 - F6FFF6F6F6FFF6F6F6FFF6F6F6FFF6F6F6FFF6F6F6FFF6F6F6FFF6F6F6FFF6F6 - F6FFF6F6F6FFF6F6F6FFF6F6F6FFF6F6F6FFF6F6F6FFF6F6F6FFF5F5F5FF3234 - 38FF404246FF3F4145FF3D3F43FF7D7E819F0000000000000000000000000000 - 000000000000C0A66BFF6592C0FF6492C0FF7AA4D8FF719FD3FF6899CEFFF4E7 - D2FFD3951EFFD59824FFF1DFBF7525914EFF329758FF29AA68FF29B06FFF29B1 - 70FF29B372FF28B473FF28B474FF28B474FF28B373FF29B271FF29B170FF3EB6 - 78FF3CB476FF39B273FF3CB477FF000000000000000000000000000000000000 - 0000F8F4ED41AEA583FF6693C1FF6794C3FF78A3D6FF6F9DD2FF6698CEFFF7DD - B9FFD69823FFD69928FFFDFBF71829914FFF40A165FF29AA69FF29B06FFF29B1 - 71FF28B371FF88CDF8FF00AAF2FF11A4E9FF1A8AEBFF2AB469FF29B070FF3DB5 - 78FF3BB476FF3BB476FF38B172FF000000000000000000000000000000000000 - 000000000000C0A66BFF6592C0FF6492C0FF7AA4D8FF719FD3FF6899CEFFEAE7 - E4FFE1E1E2FF11124CFF1B23BFFF16175AFFDAD9DBFF1B23CFFF1B23D2FF1B23 - D2FF1B24D5FF52537EFF121ABEFF1B23BDFF1A21B8FFC5C5C7FFB2B2B4FF3EB5 - 79FF3CB476FF39B273FF3CB477FF00000000727477D38B8C8EFF616264FF6162 - 64FF4A4C4FFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFA - FAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFA - FAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFF3234 - 38FF414347FF404246FF3E4044FF7D7F829F0000000000000000000000000000 - 0000A6C8E4FF9CC1E1FF89B3D9FF82ADD6FF6693C1FF729FD4FF6899CEFF578F - CAFFDEC090EC000000000000000049AD76EB289D5AFF29AF6EFF29B170FF46BA - 80FF44BA7FFF44BA7FFF44BA7FFF45BA7FFF2BB677FF28B474FF28B272FF3FB7 - 7AFF3EB678FF42B97DFF2BA663FF00000000000000000000000000000000FEFE - FE14A4C5E3FF9ABFE0FF88B3D9FF77A3CFFF6693C1FF6F9DD2FF6698CEFF76A1 - CCFFF0DFC0850000000000000000219B57FF329E5EFF29B06FFF27B170FF46BA - 80FF44BA7FFF43BA7DFF87D3F9FF00AAF3FF12A4E9FF1A8AEBFF2CB56BFF3FB7 - 7AFF3DB578FF45BA80FF39A365F4000000000000000000000000000000000000 - 0000A6C8E4FF9CC1E1FF89B3D9FF82ADD6FF6693C1FF729FD4FF6899CEFF578E - C9FFF6F6F6FF818284FF131357FF1B23C5FF1B23CCFF1B23D1FF1B23D7FF1B23 - D5FF1B23CFFF1B23CBFF1B23C3FF1B23BEFFADADA9FFFFFFFFFF24B370FF3FB7 - 7AFF3EB678FF42B97DFF2BA663FF00000000747678D3909193FF636466FF6364 - 66FF666669FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF4546 - 4AFF424347FF414246FF3F4145FF7D7F829F000000000000000000000000A9CA - E4FFA6C8E4FF9CC1E1FF8FB8DCFF84AFD7FF7EAAD4FF6693C1FF6999CFFF598F - C8FF0000000000000000000000000000000029A664FF28B170FF46BA80FF44BA - 7FFF95D3AEFF92D3AFFF45A86FFF44BA7FFF44BA7FFF44BA7FFF43BA7EFF41B8 - 7CFF3FB77AFF40B77BFFFEFEFE0600000000000000000000000000000000AFCE - E6FFA4C5E3FF9ABFE0FF8BB4DAFF83AED7FF7EAAD4FF6592C0FF6698CEFF9BBB - DEC4000000000000000000000000EFF8F44128A665FF29B170FF44BA7FFF42BA - 7EFFA0DAB6FF8ED0ABFF39AA6BFF82D8FAFF00AAF3FF13A3E9FF1A8AEBFF44BB - 74FF3FB77AFF3EB679FF0000000000000000000000000000000000000000A9CA - E4FFA6C8E4FF9CC1E1FF8FB8DCFF84AFD7FF7EAAD4FF6693C1FF6999CFFF598F - C8FF00000000F9F9F9FFC0C1C2FF323360FF1B24D1FF1B23D0FF1B23D3FF1B23 - D2FF1B23CEFF1B23C9FF222AC1FFAEAEAFFFFFFFFFFF63B78DFF43BA7EFF41B8 - 7CFF3FB77AFF40B77BFFFEFEFE060000000077787BD3959697FF656668FF6566 - 68FF656668FF656667FF656669FF656668FF646567FF636466FF626365FF6061 - 64FF5F6063FF5E5F61FF5C5D60FF5B5C5EFF595A5DFF57585BFF55565AFF5455 - 58FF525357FF505155FF4F5053FF4D4E51FF4B4C50FF494A4EFF46474BFF4546 - 4AFF434448FF414347FF404246FF7E80839F0000000000000000FCFDFE1EB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF79A6D2FF6592C0FF88AE - D7D7000000000000000000000000000000005FC392DA29B170FF45BA7FFF5BC2 - 8BFF84ACDCFF7DA6D9FF88AFDBFF97D6B4FF44BA7FFF44BA7FFF44BA7FFF43BA - 7EFF43B97DFFAEE0C69A00000000000000000000000000000000C0D8EBC6AECD - E6FFA4C5E3FF9ABFE0FF8DB6DBFF83AED7FF7DAAD4FF78A5D1FF6695C7FFF7FA - FC24000000000000000000000000000000001CAB66FF29B271FF44BA7FFFA5DA - BEFF82ABDBFF7BA5D8FFC4D9EDFF7EC398FF7ADBFBFF00AAF2FF13A3E8FF1A8A - EBFF45BB75FFFBFDFC1100000000000000000000000000000000FCFDFE1EB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF79A6D2FF6592C0FF88AE - D7D70000000000000000E3E3E4FFFFFFFFFFA4A5A7FF757576FF595B79FF5E61 - 9FFF85868AFFA2A3A3FFFFFFFFFFCFCFD0FF43BA7FFF44BA7FFF44BA7FFF43BA - 7EFF43B97DFFAEE0C69A0000000000000000797B7DD3999A9BFF67686AFF6768 - 6AFF67686AFF666769FF656669FF656668FF646567FF636466FF626365FF6162 - 64FF5F6063FF5E5F62FF5C5D60FF5A5B5EFF595A5DFF57585BFF56575AFF5455 - 58FF525357FF505155FF4E4F53FF4D4E51FF4B4C50FF494A4EFF47484CFF4546 - 4AFF444549FF424347FF404246FF7F81849F0000000000000000ACCBE5FFB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF79A6D2FF74A2D0FFDFEA - F56A00000000000000000000000000000000000000007CD0A8C127B574FF5FBE - 9AFF83ACDCFF7DA6D9FF73A0D4FF6093CCFF7DC29AFF44BA7FFF44BA7FFF45BA - 80FFF8FCFA1A0000000000000000000000000000000000000000B9D3E9FFAECD - E6FFA4C5E3FF9ABFE0FF8DB6DBFF83AED7FF7DAAD4FF78A5D1FF709FCDFF0000 - 0000000000000000000000000000000000000000000022B06EFF28B575FF87B5 - D6FF82ABDBFF7BA5D8FF719ED3FF93B7DCFF42A96CFF6EDEFBFF00AAF3FFB8B0 - ABFFB4B5B6FF0000000000000000000000000000000000000000ACCBE5FFB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF79A6D2FF74A2D0FFDFEA - F56A000000000000000000000000FDFDFD1ADCDDDDFFF0F1F1FFFEFEFEFFFFFF - FFFFF1F1F1FFCDCBC9FF8EACCFFF6093CCFF7DC29AFF44BA7FFF44BA7FFF45BA - 80FFF8FCFA1A0000000000000000000000007C7D7FD39E9EA0FF696A6CFF696A - 6CFF696A6CFF696A6CFF696A6CFF696A6BFF67686AFF66676AFF646568FF6363 - 66FF616264FF606164FF5F6063FF5D5E61FF5B5C5FFF595A5DFF58595CFF5657 - 5AFF545559FF525357FF515255FF4F5052FF4C4D51FF4A4B4FFF48494DFF4647 - 4BFF44464AFF434448FF414347FF8082859F0000000000000000BBD4EAFFB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF79A6D2FF73A1CFFF0F0E - 0FFF000000000000000000000000000000000000000000000000EEF3FA5C84B4 - D4FF6491C0FF6A97C5FF73A0D4FF699ACFFFAFDDCAFF46BB80FF5CC999D60000 - 0000000000000000000000000000000000000000000000000000B7D2E9FFAECD - E6FFA4C5E3FF9ABFE0FF8DB6DBFF83AED7FF7DAAD4FF78A5D1FF73A2D1FF0A0A - 0BFF000000000000000000000000000000000000000000000000C2D8EEC081AB - D4FF6693C1FF749FD1FF719ED3FF6798CEFF99D8B2FF45BB7CFF7BDBF3FFD2D3 - D3FFACACADFFAEB0B1FF00000000000000000000000000000000BBD4EAFFB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF79A6D2FF73A1CFFF0F0E - 0FFF000000000000000000000000000000000000000000000000EDF3F95C82B3 - D3FF6491C0FF6A97C5FF73A0D4FF699ACFFFAFDDCAFF46BB80FF5CC999D60000 - 0000000000000000000000000000000000007D7F82D3A2A2A4FF6B6C6EFF6B6C - 6EFF6E6F71FF35383BFF3C3F43FF444649FF4B4E51FF2F3236FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF4E4F52FF4A4B4FFF494A4EFF4748 - 4CFF45464AFF434549FF424347FF8183869F0000000000000000B9D3E9FFB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF79A6D2FF73A1CFFF6792 - BEFF0D0E0FFF0000000000000000000000000000000000000000A5C7E4FF99BE - DFFF87B1D8FF80ABD5FF6592C0FF699ACFFF5B8ECBFF00000000000000000000 - 00000000000000000000000000000000000000000000CDDFEF97B7D2E9FFAECD - E6FFA4C5E3FF9ABFE0FF8DB6DBFF83AED7FF7DAAD4FF78A5D1FF72A1CFFF2734 - 41FF010102FF00000000000000000000000000000000E3EDF67CA4C5E3FF97BD - DFFF86B1D8FF75A2CEFF6895C4FF6798CEFF72ACC0FF0000000000000000CACB - CBFFD5D6D1FF7F85EAFF7D82EAFF000000000000000000000000B9D3E9FFB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF79A6D2FF73A1CFFF6792 - BEFF0D0E0FFF0000000000000000000000000000000000000000A5C7E4FF99BE - DFFF87B1D8FF80ABD5FF6592C0FF699ACFFF5B8ECBFF00000000000000000000 - 000000000000000000000000000000000000808284D3A6A6A8FF6D6E70FF6D6E - 70FF494C4FFF34373BFF3C3F43FF444649FF4B4E51FFD1D1D2FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFBCBDBEFFBFBFC0FFBEBE - BFFFBDBEBFFFD9D9DAFFFFFFFFFFFFFFFFFF2F3236FF4C4D50FF4A4B4EFF4849 - 4DFF46474BFF444549FF434448FF8284869F00000000F5F8FB37B9D3E9FFB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF79A6D2FF74A4D2FF6D9D - CDFF111213FFE5E5E54A000000000000000000000000B1CEE7FFA5C7E4FF99BE - DFFF88B2D9FF80ACD5FF7AA7D3FF6795C5FFA3C1E0BA00000000000000000000 - 00000000000000000000000000000000000000000000A5C5E2E7B7D2E9FFAECD - E6FFA4C5E3FF9ABFE0FF8DB6DBFF83AED7FF7DAAD4FF78A5D1FF729FCDFF71A2 - D4FF111113FF00000000000000000000000000000000AFCDE6FFA4C5E3FF96BD - DFFF86B0D8FF7FABD5FF7AA7D3FF6798CEFFFCFDFE0F00000000000000000000 - 00009CB5F5FFA2BEF4FF7D81EAFF7A7EE9FF00000000F5F8FB37B9D3E9FFB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF79A6D2FF74A4D2FF6D9D - CDFF111213FFE5E5E54A000000000000000000000000B1CEE7FFA5C7E4FF99BE - DFFF88B2D9FF80ACD5FF7AA7D3FF6795C5FFA3C1E0BA00000000000000000000 - 000000000000000000000000000000000000828487D3AAABACFF6F7072FF6F70 - 72FF494C4FFF34373BFF3C3F43FF444649FF4B4E51FFD5D6D7FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF535457FF5A5B5EFF5859 - 5CFF56575AFF9A9C9EFFFFFFFFFFFFFFFFFF2F3135FF4C4D51FF4A4B4FFF4849 - 4DFF46474BFF44464AFF434448FF8384879F00000000EFF4F942B9D3E9FFB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF79A6D2FF242E39FF719B - C7FF121315FF050608FF0000000000000000F6F9FC40B0CEE7FFA5C7E4FF99BE - DFFF8AB3DAFF80ACD5FF7AA7D2FF74A2D0FFF6F9FC3600000000000000000000 - 00000000000000000000000000000000000000000000A5C5E2EEB7D2E9FFAECD - E6FFA4C5E3FF9ABFE0FF8DB6DBFF83AED7FF7DAAD4FF78A5D1FF0F0E0FFF75A6 - D8FF121315FF636465CC0000000000000000AECCE5E8AFCDE6FFA4C5E3FF96BD - DFFF87B2D9FF7FABD5FF79A6D2FF6C9AC8FF0000000000000000000000000000 - 000000000000B1D6F8FF8594ECFF0000000000000000EFF4F942B9D3E9FFB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF79A6D2FF242E39FF719B - C7FF121315FF050608FF0000000000000000F6F9FC40B0CEE7FFA5C7E4FF99BE - DFFF8AB3DAFF80ACD5FF7AA7D2FF74A2D0FFF6F9FC3600000000000000000000 - 000000000000000000000000000000000000858689D3AEAFB0FF717274FF7172 - 74FF4A4C50FF34373BFF3C3F43FF444649FF4B4E51FFD5D6D7FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF545558FF5B5C5FFF595A - 5DFF57585BFF9A9C9EFFFFFFFFFFFFFFFFFF2F3136FF4D4E51FF4B4C50FF494A - 4EFF47484CFF45464AFF434549FF8485879F00000000F9FBFD1AB9D3E9FFB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF79A6D2FF131418FF1416 - 1AFF131417FF121314FF0000000000000000A3C4E2FFB0CEE7FFA5C7E4FF99BE - DFFF8AB3DAFF80ACD5FF7AA7D2FF73A1CFFF040405FF00000000000000000000 - 00000000000000000000000000000000000000000000BDD5E9C8B7D2E9FFAECD - E6FFA4C5E3FF9ABFE0FF8DB6DBFF83AED7FF7DAAD4FF78A5D1FF17191DFF1416 - 1AFF131417FF090B0DFF0000000000000000BAD4E9FFAFCDE6FFA4C5E3FF96BD - DFFF87B2D9FF7FABD5FF79A6D2FF74A3D2FF171818F800000000000000000000 - 00000000000000000000000000000000000000000000F9FBFD1AB9D3E9FFB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF79A6D2FF131418FF1416 - 1AFF131417FF121314FF0000000000000000A3C4E2FFB0CEE7FFA5C7E4FF99BE - DFFF8AB3DAFF80ACD5FF7AA7D2FF73A1CFFF040405FF00000000000000000000 - 00000000000000000000000000000000000087898AD3B2B3B4FF747576FF7374 - 76FF4B4D50FF34373BFF3C3F43FF444649FF4B4E51FFD5D6D7FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF555659FF5B5C5FFF5A5B - 5EFF58595CFF9A9C9EFFFFFFFFFFFFFFFFFF2F3236FF4D4E52FF4B4C50FF494A - 4EFF47484CFF45464AFF434549FF8486889F0000000000000000BBD4EAFFB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF7BA9D6FF34363AFF1517 - 1CFF131519FF121316FF0000000000000000B8D3E9FFB0CEE7FFA5C7E4FF99BE - DFFF8AB3DAFF80ACD5FF7AA7D2FF73A1CFFF527497FF0D0D0FFD000000000000 - 00000000000000000000000000000000000000000000E9F1F869B7D2E9FFAECD - E6FFA4C5E3FF9ABFE0FF8DB6DBFF83AED7FF7DAAD4FF78A6D2FF23262BFF1517 - 1CFF131518FF101113FF0000000000000000BAD4EAFFAFCDE6FFA4C5E3FF96BD - DFFF87B2D9FF7FABD5FF79A6D2FF72A1CFFF15181DFFCACACB6F000000000000 - 0000000000000000000000000000000000000000000000000000BBD4EAFFB0CE - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF7BA9D6FF34363AFF1517 - 1CFF131519FF121316FF0000000000000000B8D3E9FFB0CEE7FFA5C7E4FF99BE - DFFF8AB3DAFF80ACD5FF7AA7D2FF73A1CFFF527497FF0D0D0FFD000000000000 - 000000000000000000000000000000000000898A8CD3B6B7B8FF767778FF7576 - 78FF4C4E51FF34373BFF3C3F43FF444649FF4B4E51FFD5D6D7FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF55565AFF5C5D60FF5A5B - 5EFF58595CFF9A9C9EFFFFFFFFFFFFFFFFFF2F3236FF4E4F52FF4C4D50FF4A4B - 4EFF48494DFF45464AFF444549FF8587899F0000000000000000A5C5E3FFB1CF - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF576E85FF2C2E32FF171A - 1FFF14161AFF131417FF0000000000000000BBD5EAFFB0CEE7FFA5C7E4FF99BE - DFFF8AB3DAFF80ACD5FF7AA7D2FF668FB6FF6E9ECFFF111213FF000000000000 - 00000000000000000000000000000000000000000000FEFEFE01B8D3E9FFAFCE - E6FFA4C5E3FF9ABFE0FF8DB6DBFF83AED7FF7DAAD4FF313335FF23262BFF1518 - 1DFF14161AFF121316FF0000000000000000BAD4E9FFAFCDE6FFA4C5E3FF96BD - DFFF87B2D9FF7FABD5FF79A6D2FF6E99C4FF6F9FD1FF101113FF000000000000 - 0000000000000000000000000000000000000000000000000000A5C5E3FFB1CF - E6FFA6C8E4FF9CC1E1FF90B8DCFF84AFD7FF7EAAD4FF576E85FF2C2E32FF171A - 1FFF14161AFF131417FF0000000000000000BBD5EAFFB0CEE7FFA5C7E4FF99BE - DFFF8AB3DAFF80ACD5FF7AA7D2FF668FB6FF6E9ECFFF111213FF000000000000 - 0000000000000000000000000000000000008B8C8ED3BBBABCFF78797BFF7879 - 7AFF4D4F52FF34373BFF3C3F43FF444649FF4B4E51FFD5D6D7FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF56575AFF5D5E61FF5B5C - 5FFF58595CFF9A9C9EFFFFFFFFFFFFFFFFFF2F3236FF4E4F53FF4C4D51FF4A4B - 4FFF48494DFF46474BFF444549FF86878A9F000000000000000095AFCDFF5A62 - 6CFF686F78FF7C8C9EFF95B1D2FF95B3D5FF7EAAD4FF42464CFF34363BFF1C1F - 24FF14171BFF131418FF0000000000000000B9D4E9FFB0CEE7FFA5C7E4FF99BE - DFFF8AB3DAFF80ACD5FF7AA7D2FF40566DFF435E7AFF121316FFDCDCDC460000 - 0000000000000000000000000000000000000000000000000000849BB3FF5B62 - 6BFF69717AFF8396ACFF97B4D5FF91B1D4FF7CAAD4FF3A3A3DFF4E4F54FF191C - 21FF14171BFF101214FF0000000000000000BAD4EAFFAFCDE6FFA4C5E3FF96BD - DFFF87B2D9FF7FABD5FF79A6D2FF101012FF202832FF121315FF000000000000 - 000000000000000000000000000000000000000000000000000095AFCDFF5A62 - 6CFF686F78FF7C8C9EFF95B1D2FF95B3D5FF7EAAD4FF42464CFF34363BFF1C1F - 24FF14171BFF131418FF0000000000000000B9D4E9FFB0CEE7FFA5C7E4FF99BE - DFFF8AB3DAFF80ACD5FF7AA7D2FF40566DFF435E7AFF121316FFDCDCDC460000 - 0000000000000000000000000000000000008E9091D3BFBFC0FF7A7B7CFF7A7B - 7CFF4D5053FF34373BFF3C3F43FF444649FF4B4E51FFD5D6D7FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF56575BFF5D5E61FF5B5C - 5FFF595A5DFF9A9C9EFFFFFFFFFFFFFFFFFF2F3236FF4E4F53FF4C4D51FF4A4B - 4FFF48494DFF46474BFF44464AFF86878A9F0000000000000000383A3EFF4C4E - 51FF797A7CFFA6A7A8FF818384FF848587FF56585BFF414347FF3D3F43FF1E21 - 26FF14171BFF131417FF0000000000000000ABCAE5FFB0CEE7FFA5C7E4FF99BE - DFFF8AB3DAFF80ACD5FF7AA7D2FF1D1D20FF14171BFF131417FF494A4CDC0000 - 00000000000000000000000000000000000000000000DADBDC623C3E42FF4E50 - 53FF7F8083FFA6A7A8FF808183FF7B7D7FFF515356FF404246FF3E4043FF1B1E - 23FF14171BFF080A0DFF0000000000000000BBD4EAFFAFCDE6FFA4C5E3FF96BD - DFFF87B2D9FF7FABD5FF79A6D2FF26292DFF14161BFF131417FFEDEDED2B0000 - 0000000000000000000000000000000000000000000000000000383A3EFF4C4E - 51FF797A7CFFA6A7A8FF818384FF848587FF56585BFF414347FF3D3F43FF1E21 - 26FF14171BFF131417FF0000000000000000ABCAE5FFB0CEE7FFA5C7E4FF99BE - DFFF8AB3DAFF80ACD5FF7AA7D2FF1D1D20FF14171BFF131417FF494A4CDC0000 - 000000000000000000000000000000000000909093D3C2C2C3FF7C7D7EFF7B7C - 7DFF4E5053FF34373BFF3C3F43FF444649FF4B4E51FFD5D6D7FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF57585BFF5D5E61FF5B5C - 5FFF595A5DFF9A9C9EFFFFFFFFFFFFFFFFFF2F3236FF4E4F53FF4C4D51FF4A4B - 4FFF48494DFF46474BFF44464AFF86888B9F00000000000000006F7274D7494B - 4EFF595B5EFF67696BFF6B6D6FFF636467FF65676AFF484A4EFF2E3035FF1C1F - 24FF14171BFFCDCDCE72000000000000000094BADDFFB0CEE7FFA5C7E4FF99BE - DFFF8AB3DAFF80ACD5FF7EADDBFF3A3C40FF15181DFF131619FF17181BFE0000 - 0000000000000000000000000000000000000000000000000000303236FF4C4E - 51FF5C5D60FF696B6DFF6A6C6EFF66686AFF5E6063FF414347FF2A2C31FF191C - 21FF14171BFF000000000000000000000000A7C7E3FFAFCDE6FFA4C5E3FF96BD - DFFF87B2D9FF7FABD5FF6A8EB0FF23262BFF15181CFF131519FFB3B4B4510000 - 00000000000000000000000000000000000000000000000000006F7274D7494B - 4EFF595B5EFF67696BFF6B6D6FFF636467FF65676AFF484A4EFF2E3035FF1C1F - 24FF14171BFFCDCDCE72000000000000000094BADDFFB0CEE7FFA5C7E4FF99BE - DFFF8AB3DAFF80ACD5FF7EADDBFF3A3C40FF15181DFF131619FF17181BFE0000 - 000000000000000000000000000000000000929395D3C7C7C8FF7E7F80FF7D7E - 7FFF4E5053FF34373BFF3C3F43FF444649FF4B4E51FFD5D6D7FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF57585BFF5D5E61FF5B5C - 5FFF595A5DFF9A9C9EFFFFFFFFFFFFFFFFFF2F3236FF4E4F53FF4C4D51FF4A4B - 4FFF48494DFF46474BFF77787BFF86888B9D000000000000000000000000F9F9 - F91A4C4E51FF57595CFF595B5EFF535558FF47494DFF383A3EFF282B30FF4446 - 4BE500000000000000000000000000000000A9C7E8FF728396FF798A9CFF8DA6 - C2FF98B6D8FF85ADD5FF7299BFFF393B3FFF1B1E23FF14161AFF2C2D30F20000 - 000000000000000000000000000000000000000000000000000000000000CACB - CC7C505255FF585A5DFF595B5EFF515356FF45474BFF35383CFF25282DFF9D9E - A09600000000000000000000000000000000A1BEE1FF718194FF7A8A9DFF92AD - CCFF96B5D7FF80ABD5FF49525DFF47484CFF181B20FF13161AFFBEBEBF4B0000 - 000000000000000000000000000000000000000000000000000000000000F9F9 - F91A4C4E51FF57595CFF595B5EFF535558FF47494DFF383A3EFF282B30FF4446 - 4BE500000000000000000000000000000000A9C7E8FF728396FF798A9CFF8DA6 - C2FF98B6D8FF85ADD5FF7299BFFF393B3FFF1B1E23FF14161AFF2C2D30F20000 - 000000000000000000000000000000000000959697D3C9CACAFF7E7F80FF7D7E - 7FFF4E5053FF34373BFF3C3F43FF444649FF4B4E51FFD5D6D7FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF222428FF2C2F33FF2C2F - 33FF2C2E32FF959699FFFFFFFFFFFFFFFFFF2F3236FF4E4F53FF4C4D51FF4A4B - 4FFF48494DFF6B6C6FFFABACADFB000000000000000000000000000000000000 - 0000000000000000000098999BB644464AFF3A3C40FF727376CB000000000000 - 000000000000000000000000000000000000303337FF4A4C50FF6C6D70FF9C9D - 9EFF7E8081FF6E7073FF45474AFF3C3E41FF1D2025FF14161BFFC4C5C6710000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000FBFBFB0A7A7B7ED5424448FF393C40FF9D9DA0A2000000000000 - 00000000000000000000000000000000000036393DFF4D4F52FF717274FFA1A2 - A2FF7F8182FF646669FF434548FF3C3E42FF1A1D22FF14161AFF000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000098999BB644464AFF3A3C40FF727376CB000000000000 - 000000000000000000000000000000000000303337FF4A4C50FF6C6D70FF9C9D - 9EFF7E8081FF6E7073FF45474AFF3C3E41FF1D2025FF14161BFFC4C5C6710000 - 00000000000000000000000000000000000097989AD3CCCCCDFF7C7D7EFF7B7C - 7DFF4E5053FF34373BFF3C3F43FF444649FF4B4E51FFD5D6D7FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF2F3236FF4E4F53FF4C4D51FF4A4B - 4FFF606064FFB2B3B5FC00000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000044464AFF585A5DFF6567 - 6AFF646668FF56585BFF4F5255FF2D3034FF1A1D22FF0B0D11FF000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FDFDFD07484A4EFF5A5C5FFF6668 - 6BFF636467FF585A5DFF484A4EFF2A2C31FF181B20FF1C1F23F9000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000044464AFF585A5DFF6567 - 6AFF646668FF56585BFF4F5255FF2D3034FF1A1D22FF0B0D11FF000000000000 - 0000000000000000000000000000000000009A9A9CD3CFCFCFFFCFCFD0FFCFCF - D0FFBCBDBEFFB2B3B5FFB6B6B8FFB9BABBFFBCBDBEFFF0F0F0FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFB3B4B6FFC0C0C1FFBFBFC1FFBEBE - C0FFBABBBCFC0000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000C5C6C77A4D4F - 52FF515356FF46484CFF383A3EFF1E2127FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000008C8D8FC75153 - 56FF505255FF44464AFF35383CFF1E2227FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000C5C6C77A4D4F - 52FF515356FF46484CFF383A3EFF1E2127FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000AFADAE8C201D1EFD161314FF131012FF151213FF100C0DFF191517FF6562 - 63C7F5F5F5170000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000006FA9C1FFD5DBE180000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000FCFCFC03FAFAFA05FAFAFA05FEFEFE01000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000E9E9E931110F12FF1F1B1DFF201C - 1EFF201C1FFF201C1FFF201C1FFF201C1EFF1B1618FF1C181AFF1D191BFF1C18 - 1AFF1B1718FF191517FF110D0FFF000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000FDFD - FD45000000000000000000000000FEFEFE0182C3DCFF8AE3FBFF79BED8FF0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000F9F9F912E6E6E764E1E1E25CFEFEFE0500000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000F5F5 - F50ADCDCDC23C2C2C43DAEAEB451A8A8B057A8A8B057B3B3B74CCACACA35E5E5 - E51AFBFBFB040000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000D3D3D35A1F1B1DFF151113FF0E0606FF5C99DBFF2369 - A5FF241A1AFF231F23FF231F23FF231F22FF1E1A1DFF211D20FF201C1FFF1F1B - 1DFF1D191BFF1C1819FF242022FF161313FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000E3E3E41EF5F5 - F5FFF5F5F5FFFCFCFC6100000000DFDFE02383C3DCFF8AE3FBFF88E2FBFF81E1 - FCFF000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000008D8E - 90FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF5F5F5FF67686AFF0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FEFEFE01D3D3D32C8E8EA071504E - 88B1262387DC120D8CF2070290FD060193FE060193FE09048EFB18138BEC322F - 86D062618C9EA5A5AE5AE6E6E619000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000120E10FF201C1FFF221E21FF1D181AFF1C1719FFADE3FFFF5D99 - DBFF198BEEFF24303EFF262226FF262225FF262225FF242024FF231F22FF221E - 21FF201C1FFF1E1A1DFF242022FF433E41FFB5B4B56700000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000D6E1E972FCFCFC03DDDEDE24F5F5 - F5FFF5F5F5FFF5F5F5FFF5F5F5FFBDBEBF9183C4DCFF8CE4FCFF89E3FBFF87E1 - FBFF85E3FEFF0000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000A9AAACF1FFFFFFFFD7D8 - D8FF9D9EADFF10136DFF13198AFF111789FF1B218CFFDADAE0FFF7F7F7FFFFFF - FFFFB8B8B9A60000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000D9D9D9267271938E1F1C89E306009BFF0600 - A3FF0600A2FF0400A0FF02009DFF02009CFF02009DFF02009EFF0600A1FF0600 - A3FF0600A2FF060194FE353287CD9595A56AEFEFEF1000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000181416FF1C181BFF231F21FF252124FF262023FF251F22FF4E585DFF00B6 - F5FF00B0F5FF198BEDFF273341FF2A2529FF2E292DFF282427FF262225FF2521 - 24FF231F22FF211D1FFF252023FF433E41FFD4D3D35400000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000A9CEDEBE72D3F2FF6AC7E4FF59AAC4FF4E99B1FFF5F5 - F5FFF6F6F6FFDEDEDEFFF5F5F5FFD5D6D6FF7AB9D2FF8DE4FCFF8AE3FBFF88E2 - FBFF86E1FBFF83E0FBFFFDFDFD08000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000A3A4A6FFFFFFFFFFADADB2FF191E - 82FF1A2194FF1A2195FF1A2196FF1A2196FF1A2195FF1A2093FF161C8FFFF6F5 - EEFFFFFFFFFF98989AD600000000000000000000000000000000000000000000 - 000000000000FEFEFE01A3A3AE5C282589DA0600A1FF0600A2FF02009BFF0000 - 9AFF0000A1FF0612ABFF0F1FB1FF1425B5FF1424B4FF0E1BAEFF020CA7FF0000 - 9EFF00009AFF04009DFF0600A4FF060099FF4A488AB7CDCDCE32000000000000 - 000000000000000000000000000000000000000000000000000000000000DDDC - DD4C1D191BFF2A2528FF252124FF272327FF272024FF2D272AFF272124FF3F95 - F1FF00B5F5FF00B0F6FF198BECFF2B3745FF2E282CFF2C272BFF292529FF2723 - 27FF252125FF231F23FF252023FF433E41FFEBEAEB2100000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000008BE2FDFF74D6F6FF6AC7E4FF59AAC4FF4E99B1FFF5F5 - F5FFF3F3F3FFF1F2F2FFF0F0F1FFB0B1B2FF7ABAD2FF8EE5FCFF8CE4FCFF8AE3 - FBFF87E2FBFF84E0FBFF82DFFBFFDBE4E9680000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000E1E1E2A1FFFFFFFF7D7D94FF1A229DFF1B22 - 9BFF1B229CFF1B229DFF1B229DFF1B229DFF1B229DFF1B229BFF1A2199FF1A21 - 96FFF1F1EDFFFFFFFFFFFCFCFC21000000000000000000000000000000000000 - 0000FBFBFB0481819C7E0A0595FA0600A3FF040099FF0206A2FF122EBDFF3158 - D6FF507AE6FF658EEEFF7299F2FF799EF2FF7B9FF2FF7699F0FF6A8DEAFF5274 - DFFF2F4DCBFF0C1EB1FF00009DFF04009CFF0600A4FF24218CDEB7B7BE480000 - 0000000000000000000000000000000000000000000000000000000000009290 - 91A9231F22FF2E292DFF282427FF2A262AFFB6B7B7FF352E32FF2D262AFFB7B8 - B8FF3D94F1FF00B4F5FF00B0F6FF198BECFF2E3948FF312B2FFF2E282CFF2B26 - 2AFF282428FF252125FF262225FF3F3A3DFF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000E2DAC0FFA7E0EBFF6AC7E4FF59AAC4FF4E99B1FFF5F5 - F5FFF6F6F6FFF3F3F3FFD7D8D8FFCDCECEFF7CBAD2FF90E5FCFF8DE4FCFF8AE3 - FBFF88E2FBFF85E1FBFF83E0FBFF80DFFBFFA2D2E5DE00000000000000000000 - 000000000000000000000000000000000000D4D4D5FFD3D3D4FFD3D3D3FFD2D2 - D3FFD1D1D2FFD0D0D1FFD0D0D1FFCECFD0FFCECECFFFCDCDCEFFCBCCCDFFCBCB - CBFFC9CACAFFC8C8C9FFC7C8C9FFF5F5F6FF9F9F9DFF1A2195FF1B229EFF1B22 - A0FF1B22A2FF1B22A3FF1B22A3FF1B22A3FF1B22A3FF1B22A1FF1B229FFF1B22 - 9DFF1B229AFFEDEDECFFA4A4A6FFAAABABFF0000000000000000000000000000 - 000082829E7D06009BFF06009EFF0204A0FF1137C6FF326BE9FF4F86F5FF5489 - F4FF4980F1FF3B75EEFF306CECFF2D6AEBFF2F69EAFF386EEAFF4879ECFF5C87 - EEFF6892F1FF5E88ECFF375DD8FF0C21B3FF00009BFF0600A3FF1A1590EABFBF - C54000000000000000000000000000000000000000000000000000000000EEEE - EE31282428FF2E2A2EFF2B272BFF2F292DFFC2C3C3FF4A4246FF322B2FFFC2C3 - C3FFC2C3C3FF4199F6FF00B4F5FF00B0F6FF198BECFF313B4BFF322C30FF2F29 - 2DFF2B272BFF282427FF2A2529FF363235FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000F9FEFFFFA8E6F9FF6AC7E4FF59AAC4FF4E99B1FFF2F3 - F3FFF0F0F0FFF0F1F0FFE0E1E1FFCFD0D0FF7DBCD3FF91E6FCFF8EE5FCFF8CE4 - FCFF8AE3FBFF87E1FBFF84E0FBFF82DFFBFFACE6FCFF75DAF9FF000000000000 - 000000000000000000000000000000000000E7E7E8FFE8E8E8FFE9E9EAFFEAEA - EBFFEBEBECFFECECEDFFEDEDEEFFEDEDEFFFEEEEEFFFEFEFEFFFEFEFF0FFEFEF - F0FFEFEFF0FFEFEFF0FFD2D2D4FFFFFFFFFF0F0F4CFF1B22A1FF1B22A4FF1B22 - A6FF1B22A7FF1B22A9FF1B22A9FF1B22A9FF1B22A8FF1B22A6FF1B22A4FF1B22 - A2FF1B229FFF3036A3FFFFFFFFFFCFCFD0FF000000000000000000000000A9A9 - B656090498FB06009DFF041AB0FF1557E6FF2E76F8FF2E72F3FF1963F0FF0458 - EEFF0053ECFF0051EBFF0050EAFF004FE9FF004FE8FF004DE7FF004CE6FF004D - E6FF0E54E6FF2D65E7FF497BECFF4476EBFF1A41CCFF0206A1FF0600A2FF2926 - 8ED9E1E1E11E0000000000000000000000000000000000000000000000000000 - 0000322C30FF332D31FF2F292DFF332C30FFCECECEFF8B8689FF3D3539FFCECE - CEFFCECECEFFF4F5F5FF439BFAFF00B4F5FF00B0F5FF198BECFF323D4CFF332D - 31FF2F2A2EFF2B262AFF332F32FF282428FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000F9FEFFFFA8E6F9FF6AC7E4FF59AAC4FF4E99B1FFEEEF - EFFFECEDEDFFE8E8E9FFD7D8D8FFCCCDCDFF7EBCD3FF93E7FCFF90E5FCFF8DE4 - FCFF8BE3FBFF88E2FBFF86E1FBFF83E0FBFFACE6FCFF7DE0FFFF000000000000 - 000000000000000000000000000000000000EAEAEAFFEDF0F6FFAF6E21FFB06E - 21FFAF6D23FFAE6D24FF9C4B0BFF8F4600FFAE6100FFB76B00FFBE7400FFC27A - 00FFC47D02FFC47E03FFCBCFD5FF929393FF1A2198FF1B22A6FF1B22A9FF1B22 - ABFF1B22ADFF1B22AEFF1B22AEFF1B22AEFF1B22ADFF1B22ABFF1B22A9FF1B22 - A6FF1B22A3FF1B229FFFF2F2F3FF737476FF0000000000000000E4E4E41B2623 - 91DC06009FFF0624B9FF095FF2FF1468F7FF0B60F3FF0059F1FF0058F1FF0058 - F0FF0058EFFF0057EEFF0056EDFF0055ECFF0054EBFF0054EAFF0053E9FF0052 - E8FF004EE6FF004CE6FF004FE6FF1F5EE7FF316CECFF184CD9FF040CA5FF0600 - A2FF6563989CFEFEFE0100000000000000000000000000000000000000000000 - 0000342E32FF3D363AFF322C30FF373034FFD9D9D9FF868284FF2F292EFF3532 - 35FFACADAEFFD5D5D6FFF6F7F7FF449AF9FF00B4F5FF00B0F6FF198AECFF323E - 4CFF332C30FF2E282CFF413D40FF1E1A1DFF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000F9FEFFFFA8E6F9FF6AC7E4FF59AAC4FF4E99B1FFEBEB - EBFFECECECFFA9AAABFFD3D4D4FFC1C2C3FF7FBCD3FF94E7FCFF91E6FCFF8FE5 - FCFF8CE4FCFF8AE3FBFF87E2FBFF84E0FBFFADE6FCFF7EE1FFFF000000000000 - 000000000000000000000000000000000000ECECEDFFF0F2F7FFB4762EFFB476 - 2CFFB5762CFFB4752EFFAF6D27FFA15B00FFB97004FFC27B01FFC8830EFFCC8A - 17FFCE8D1DFFCF8F1FFFEEEEEEFF7F8085FF1B22A9FF0D0E4FFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFCFFF5F5F2FFEBEBE8FFE1E1DFFFD7D7D4FFCBCB - CAFF161DA9FF1B22A4FFE7E6E1FF909193FF00000000000000008181A47E0600 - A0FF0923B7FF0F64F5FF0C64F7FF085FF3FF045EF3FF005BF3FF0055F2FF0054 - F1FF005AF1FF0059F0FF0058EFFF0057EEFF0056EDFF0056ECFF0055ECFF0051 - EAFF0050E9FF004DE8FF004EE7FF004FE6FF0852E6FF165CEAFF0845D9FF0409 - A4FF0C0797F8C9C9CE3600000000000000000000000000000000000000000000 - 0000373236F7423C3FFF352E32FF3B3438FFF8F8F9FF5B5356FF4F474AFF2621 - 25FFDCDCDDFFDBDBDCFFDBDBDCFF767073FF479CF9FF00B4F4FF00B0F6FF198A - ECFF303D4CFF302B2FFF423D40FFADACAD950000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000F9FEFFFFA8E6F9FF6AC7E4FF59AAC4FF4E99B1FFE7E8 - E8FFE5E5E5FFA1A2A4FFBCBDBEFFB1B2B2FF7FBDD3FF96E8FCFF93E7FCFF90E5 - FCFF8DE4FCFF8BE3FBFF88E2FBFF86E1FBFFADE7FCFF7FE2FFFF000000000000 - 000000000000000000000000000000000000EEEEEFFFF2F5FAFFB77A33FFB77A - 32FFB77A30FFB77930FFB77933FFB06C00FFC17901FFC98510FFD59924FFD698 - 23FFD59824FFD59823FFF9F8F9FF6A6B7BFF1B22ABFF0D0D49FFFEFEFEFFFEFE - FEFFFEFEFEFFFDFDFDFFF8F8F8FFEEEEEFFFE4E4E5FFDADADBFFD0D0D1FFC5C5 - C7FF161DAEFF1B22A7FFE1E1DBFFABACADFF00000000F1F1F10E2A2794D80811 - ACFF1562EFFF1469F7FF1164F4FF0F63F4FF005BF4FF0E61F4FFA2BFFAFF7EA6 - F8FF0053F2FF0059F2FF005BF1FF0059F1FF0059F0FF0058EFFF0051EDFF0B57 - EDFFB1C6F8FFA6BEF7FF0E55EAFF004BE8FF0051E8FF0050E7FF0255EBFF043A - CFFF0600A4FF706EA09100000000000000000000000000000000000000000000 - 0000000000004B4448FF3C3539FF40393CFFE2E2E3FFD9D9DAFFAFCDEFFFA2BF - E3FFEBEAE8FFE1E1E2FFE1E1E2FFDFDFE0FF554D51FF4C9EF9FF00B4F5FF00B0 - F6FF198BECFF3B4958FF2B262AFF000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000F9FEFFFFA8E6F9FF6AC7E4FF59AAC4FF4E99B1FFE3E4 - E4FFE3E4E4FFD3D4D4FFBEBFBFFF87898CFF8FD6E9FF97E8FCFF94E7FCFF91E6 - FCFF8FE5FCFF8CE4FCFF8AE3FBFF87E2FBFFAEE7FCFF81E2FFFF000000000000 - 000000000000000000000000000000000000F0F0F1FFF4F7FBFFBA7E36FFBA7E - 38FFBA7E37FFBA7D34FFB97C33FFBB7300FFC47F07FFD69A26FFD8A33FFF8FB5 - E2FFFBEEDBFFCEAA72FFF1F1F1FF74757AFF1B22B0FF0D0D49FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFEFFF5F5F4FFECECE9FFE1E1DFFFD7D7D5FFCCCC - CBFF161DB1FF1B22ABFFDADAD5FF99999BFF00000000C0C0C93F04019BFE154D - D9FF1B70FAFF1869F4FF1668F4FF025FF3FF2F74F5FFC7D9FCFFFFFFFFFFFFFF - FFFF97B8FAFF0259F3FF0058F3FF005CF3FF005BF2FF0052F1FF1B61F1FFC1D3 - FBFFFFFFFFFFFFFFFFFFCCD9FBFF356EEEFF004DEAFF0053E9FF0052E8FF0255 - EBFF041FBCFF2F2A96D5F5F5F50A000000000000000000000000000000000000 - 000000000000DFDEDF55514B4EFF423B3FFFFBFBFBFFF2F1F1FF84ADDCFF80A8 - DBFF78A3D7FF7CA4D4FFE7E7E8FFE7E7E8FF746D70FF534B4EFF52A1FAFF00B3 - F4FF00B0F5FF198AECFFF5FBFE28000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000E0F7FEFFAAE6F9FF6AC7E4FF59AAC4FF4E99B1FFDFE0 - E0FFDDDEDEFFDEDFDFFFBFC0C1FFA1F2FFFF9BEAFDFF98E9FCFF96E8FCFF93E7 - FCFF90E5FCFF8DE4FCFF8BE3FBFF88E2FBFFAFE7FCFF82E3FEFF000000000000 - 000000000000000000000000000000000000F3F3F3FFF6F9FEFFBD8138FFBD82 - 3BFFBD823CFFBC813AFFBC8037FFBB7F36FFC58101FFD29322FFBAC2C4FF81AA - DBFF78A3D7FF6A99CEFFDDDEE0FF7C7D7DFF1B21ACFF1B23BBFF1B24BFFF1B24 - C4FF1B24C8FF1B24CBFF1B24CCFF1B24CBFF1B24C9FF1B24C5FF1B24C1FF1B23 - BCFF1B22B2FF1B22ADFFE7E7E8FF88888AFF000000008F8FAF700C1DB8FF2270 - F6FF1F6EF6FF1D6CF5FF0F65F4FF528BF7FFECF2FEFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFB7CDFCFF1864F4FF0058F3FF0054F2FF2E6FF4FFD3E0FCFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFF3F7FEFF3F77F0FF004FEBFF0054EBFF0056 - ECFF0245DCFF0E0E9FF6D7D7DB28000000000000000000000000000000000000 - 00000000000000000000EFEFEF384C4549FF4F484CFFA1C1E2FF84ADDCFF80A8 - DBFF78A3D7FF709ED3FF6395CCFFEDEDEEFFFCFCFDFF554D51FF4A4347FF59A5 - FBFF00B3F4FF00B0F6FF1A8AECFFF5FAFE290000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000080DEF9FF75D7F6FF6AC7E4FF59AAC4FF4E99B1FFDDDE - DEFFDEDFDFFFDFE0E0FFABACAEFFA2F2FFFF9CEBFDFF99EAFCFF97E8FCFF94E7 - FCFF91E6FCFF8FE5FCFF8CE4FCFF8AE3FBFFAFE8FCFF83E3FEFF000000000000 - 000000000000000000000000000000000000F5F5F5FFF8FBFFFFC0853DFFC086 - 3CFFC0863EFFBF8540FFBF843EFFBE833AFFBD8138FFCA8622FF799BB8FF6794 - C2FF78A3D7FF6D9CD1FFBAC9DAFFFFFFFFFF11124CFF1B22B8FF1B23BDFF1B23 - C2FF1B23C5FF1B23CAFF1B23CBFF1B23CAFF1B23C8FF1B23C3FF1B23BEFF1B23 - BAFF1B22B5FF2D33B2FFFFFFFFFFD7D7D8FF000000007474A28B1A47D9FF2878 - FBFF2370F5FF226FF5FF196AF5FF4F88F7FFD5E2FCFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFD2E0FCFF2A70F5FF3E7CF6FFE3ECFDFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFACC5FBFF246AF1FF0054EDFF0056ECFF0056 - ECFF0256EDFF041DB7FFBEBEC941000000000000000000000000000000000000 - 000000000000000000000000000000000000585257F876A1CEFF6693C1FF719C - CCFF78A3D7FF709ED3FF6899CEFFF0F2F3FFF5F5F6FF564E52FF6E676AE70000 - 0000579FF0FF00B2F4FF00B0F6FF198AECFFF4FAFE2A00000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000006AB5D3FF6AC7E4FF59AAC4FF4E99B1FFDFE0 - E0FFE2E2E2FFD9DADAFF86878AFFA8F4FFFF9DEBFDFF9BEAFDFF98E9FCFF96E8 - FCFF93E7FCFF90E5FCFF8DE4FCFF8BE3FBFFB0E8FCFF84E4FEFF000000000000 - 000000000000000000000000000000000000F7F7F7FFFAFEFFFFC38A44FFC389 - 41FFC38940FFC28942FFC28843FFC08741FFC18337FFA5C7E4FF96BDDFFF86B1 - D8FF6492C0FF6D9CD2FF5F93CBFFFBFBFBFF6C6C6BFF1B23BCFF1B23C0FF1B23 - C5FF1B23CBFF1B23CFFF1B23D1FF1B23CFFF1B23CCFF1B23C7FF1B23C1FF1B23 - BBFF1B22B6FFBFC0BFFFBCBDBEFFE2E2E3FF000000007275A48E2764EFFF2B79 - F9FF2973F6FF2572F6FF2370F5FF397DF6FF5189F6FFB9CDFAFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFE7EFFEFFEEF4FEFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFDFEFFFF9AB9F9FF3F7DF5FF1461F1FF0058F0FF0058EFFF0057 - EEFF005BF2FF0436CEFFB9B9C646000000000000000000000000000000000000 - 0000000000000000000000000000AECBE5DCA2C4E3FF97BDDEFF88B3D9FF6592 - C1FF6592C0FF709ED2FF6899CEFF588EC8FFFCFCFCFF00000000000000000000 - 0000000000005BA2F0FF00B2F4FF00B0F6FF3B98E8FFF3F9FC2C000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000008FB6C9DB6AC7E4FF59AAC4FF4E99B1FFE0E1 - E1FFE3E4E4FFD3D4D4FFB2B3B4FFB0F5FFFF9FECFDFF9CEBFDFF99EAFCFF97E8 - FCFF94E7FCFF91E6FCFF8FE5FCFF8DE4FCFFB0E8FCFF85E4FEFF000000000000 - 000000000000000000000000000000000000F9F9F9FFFDFFFFFFC78E49FFC88E - 48FFC78D45FFC58C44FFC48B45FFC38B46FFAED1F2FFA5C7E4FF96BCDEFF85B0 - D7FF7DAAD4FF6895C3FF5C96D3FFD4BCA0FFFFFFFFFF55576FFF1B24C9FF1B23 - C7FF1B23CCFF1B23D2FF1B23D6FF1B23D4FF1B23CEFF1B23C9FF1B23C3FF1B23 - BDFFB4B5B0FFFFFFFFFFDEDEDFFFE3E3E4FF00000000767FAB8D2F74FAFF2F7A - F7FF2D76F6FF2B75F6FF2974F6FF2471F6FF4383F7FF4984F5FF9DBAF8FFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFAFBFEFF86ABF7FF3C7CF5FF1464F4FF005AF3FF005BF2FF005AF1FF0059 - F1FF005CF3FF0246E0FFBABBC745000000000000000000000000000000000000 - 0000000000000000000000000000ABCAE5FFA2C4E3FF97BDDFFF87B2D9FF82AE - D6FF7EABD5FF6693C1FF6899CEFF5F93CAFF0000000000000000000000000000 - 0000000000000000000061A8F1FFAED7E5FFB8B8B9FFD1D2D2FFF1F1F3350000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000008FB6C8DB6AC7E4FF59AAC4FF4E99B1FFE2E3 - E3FFE4E5E5FFA6A6A8FFC9CBCBFFB7F8FFFFA0ECFDFF9DEBFDFF9BEAFDFF98E9 - FCFF96E8FCFF93E7FCFF90E5FCFF8DE4FCFFB1E8FCFF86E4FEFF000000000000 - 000000000000000000000000000000000000FBFBFBFFFCFFFFFFD09C60FFCE98 - 5DFFCA9355FFC98F48FFC88E45FFCA8A3DFFB2CEE7FFA5C7E4FF96BCDEFF85B0 - D8FF7DAAD4FF76A4D1FF6494C5FFB5782EFFE8ECF2FFFFFFFFFF6A6B73FF1A21 - B6FF1B23CCFF1B23D2FF1B23D6FF1B23D3FF1B23CEFF1B23C9FF1821C3FFA9A9 - A1FFFFFFFFFFA79D92FFE8E8E9FFE4E4E5FF000000007884AF8D337BFEFF337C - F7FF3179F6FF2F79F6FF2E77F6FF2B75F6FF2471F6FF397EF7FF3177F5FF7CA3 - F6FFEFF3FDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE6ED - FDFF6494F5FF226CF4FF0F64F4FF045EF3FF085FF3FF045EF3FF025DF3FF005C - F2FF005DF5FF024EE7FFBABCC845000000000000000000000000000000000000 - 00000000000000000000B1CEE7FFABCAE5FFA2C4E3FF97BDDFFF8BB4DAFF82AE - D6FF7DAAD4FF79A6D2FF6695C5FF5C91C9FF0000000000000000000000000000 - 0000000000000000000000000000B6B5B4FFE0E1E1FFB7B7B7FF7F83EDFFECEC - FB5A000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000008EB6C8DB6AC7E4FF59AAC4FF4E99B1FFE3E4 - E4FFE8E9E8FFB8B9BAFFC9CACBFFBDF9FFFFA1EDFDFF9FECFDFF9CEBFDFF99EA - FCFF97E8FCFF94E7FCFF91E6FCFF8FE5FCFFB2E8FCFF88E5FEFF000000000000 - 000000000000000000000000000000000000FBFBFBFFFCFFFFFFD4A165FFD19D - 61FFCE995DFFCB9559FFC89155FFA4AEB3FFB2CEE7FFA5C7E4FF96BCDEFF85B0 - D8FF7DAAD4FF76A4D1FF1D252EFFBC7E34FFB4762EFFE4E2E2FFFFFFFFFFA6A6 - A8FF606171FF141997FF171FD6FF151ED3FF1C24CBFF8C8E96FFDBDBDCFFFFFF - FFFFA99077FF934A00FFE9E9EAFFE5E5E6FF000000007986B18C387EFEFF377F - F7FF357CF7FF337CF7FF327AF6FF3079F6FF2E78F6FF2975F6FF2974F6FF1466 - F3FFBDD0FAFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFC1D3 - FBFF0F64F3FF0660F4FF1164F4FF1164F4FF0E62F4FF0C61F4FF0860F4FF065E - F3FF0260F7FF0251EBFFBDBFCB42000000000000000000000000000000000000 - 000000000000FEFEFE0CB3CFE8FFABCAE5FFA2C4E3FF97BDDFFF8BB5DAFF82AE - D6FF7DAAD4FF78A6D2FF709FCCFF8BB1D8D10000000000000000000000000000 - 000000000000000000000000000000000000B5B6B7FF8EA0F0FF8C9BEEFF7F82 - EAFFE5E6FA5D0000000000000000000000000000000000000000000000000000 - 00000000000000000000000000008EB6C8DB6AC7E4FF59AAC4FF4E99B1FFE5E6 - E6FFE4E5E5FFE6E7E7FFC9CBCBFFC4FBFFFFA3EEFDFFA0ECFDFF9DEBFDFF9BEA - FDFF99E9FCFF96E8FCFF93E7FCFF91E6FCFFB2E9FCFF8AE6FEFF000000000000 - 000000000000000000000000000000000000FBFBFBFFFCFFFFFFD09A53FFD5A1 - 5FFFD5A265FFD29E62FFD09B60FF9CC2E5FFB2CEE7FFA5C7E4FF96BCDEFF85B0 - D8FF7DAAD4FF76A4D1FF6F9ECEFF0F1112FFB57730FFB3742BFFB06E21FFE4E8 - ECFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFBFBFBFFC0C5CDFF9549 - 00FF954D00FF944B00FFEAEAEBFFE6E6E7FF000000008994B979397EFCFF3C83 - F7FF3A80F7FF387FF7FF367DF7FF337CF7FF337BF6FF2874F6FF2F78F6FFB9D0 - FCFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFCADAFCFF3076F6FF0660F4FF1567F4FF1266F4FF1164F4FF0F63F4FF0C62 - F4FF0963F7FF0952E5FBD2D3DA2D000000000000000000000000000000000000 - 00000000000098BDDEFFB3CFE8FFABCAE5FFA2C4E3FF97BDDFFF8BB5DAFF82AE - D6FF7DAAD4FF78A6D2FF73A1CFFF1B1C1EF80000000000000000000000000000 - 00000000000000000000000000000000000000000000B2DDF9FF97A9F1FF8088 - EBFF000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000008EB6C8DB6AC7E4FF59AAC4FF4E99B1FFE6E7 - E7FFE7E8E8FFEBECECFFAFB0B1FFCAFBFFFFA4EEFDFFA1EDFDFF9FECFDFF9CEB - FDFF99EAFCFF97E8FCFF94E7FCFF91E6FCFFB3E9FCFF8BE6FFFF000000000000 - 000000000000000000000000000000000000FBFBFBFFFCFFFFFFD6A25FFFD5A0 - 5AFFD49F59FFD4A05DFFD49F5CFF9AC2E8FFB2CEE7FFA5C7E4FF96BCDEFF85B0 - D8FF7DAAD4FF79A8D6FF75A1CFFF121314FFB97B33FFB4752EFFB17228FFAF6E - 23FFAA671BFFAB6D2BFFB48758FFB28453FFA25F13FF9D560AFF995209FF964F - 05FF954D01FF954D00FFEBEBECFFE7E7E8FF00000000B7BBCC483674F4FF4287 - F9FF3E83F7FF3B82F7FF3A80F7FF397FF7FF2D77F7FF4184F7FFCCDCFCFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFE1EBFDFF4C87F7FF0460F4FF1869F4FF1667F4FF1466F4FF1265 - F4FF1167FAFF245BD3E2F2F2F20D000000000000000000000000000000000000 - 000000000000B3CFE7FFB3CFE8FFABCAE5FFA2C4E3FF97BDDFFF8BB5DAFF82AE - D6FF7DAAD4FF78A6D2FF73A1CFFF161B1FFF060607FF00000000000000000000 - 0000000000000000000000000000000000000000000000000000C5D3F79C0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000008EB6C8DB6AC7E4FF59AAC4FF4E99B1FFE8E9 - E9FFE9EAEAFFECECECFF8F9092FFCEFDFFFFA5EFFDFFA3EEFDFFA0ECFDFF9DEB - FDFF9BEAFDFF98E9FCFF96E8FCFF93E7FCFFB3E9FCFF8BE6FFFF000000000000 - 000000000000000000000000000000000000FBFBFBFFFDFFFFFFD39A4DFFD198 - 4CFFCE9448FFCC9248FFCB9047FF96BEE3FFB2CEE7FFA5C7E4FF96BCDEFF85B0 - D8FF7DAAD4FF7BABDAFF14161BFF131417FF4E3821FFB47630FFB1732BFFAF6F - 25FFAD6C21FFA9671DFFA6631AFFA25F16FFA15C12FF9F590EFF9B540AFF964F - 06FF944B02FF944C00FFECECEDFFE8E8E9FF00000000EDEDEE12396AD9E9488D - FDFF4285F7FF4184F7FF3F83F7FF327CF7FF548FF7FFDCE7FDFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFACC3F7FFA1BAF6FFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFF1F6FEFF6A9BF8FF1166F5FF1969F5FF1969F5FF1668 - F4FF1569FDFF5E7ABFA400000000000000000000000000000000000000000000 - 000000000000BCD5EAFFB3CFE8FFABCAE5FFA2C4E3FF97BDDFFF8BB5DAFF82AE - D6FF7DAAD4FF78A6D2FF73A1CFFF6F9FCFFF101113FFFDFDFD0F000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000008EB6C8DB6AC7E4FF59AAC4FF4E99B1FFE9EA - EAFFEAEBEBFFE4E3E3FF98999BFFD1FDFFFFA6EFFDFFA4EEFDFFA1EDFDFF9FEC - FDFF9CEBFDFF99EAFCFF97E8FCFF94E7FCFFB4E9FCFF8DE7FFFF000000000000 - 000000000000000000000000000000000000FBFBFBFFFDFFFFFFD2994CFFD096 - 4AFFCE9449FFCD9248FFCA8F46FFA2B2BAFFB2CEE7FFA5C7E4FF96BCDEFF85B0 - D8FF7DAAD4FF2A292BFF1A1D22FF131619FF2C231AFFB5772EFFB2732CFFAF6F - 28FFAD6C22FFAA691DFFA7641AFFA35F17FFA05C13FF9F590EFF9C560AFF9851 - 06FF964F03FF944C00FFECEDEDFFE8E8E9FF00000000000000007188C196468A - FFFF4789F7FF4486F7FF4184F7FF659AF8FFEFF5FFFFFFFFFFFFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFA5BDF6FF407DF2FF3A7BF2FF93B0F4FFFAFBFEFFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF6A9AF7FF226FF5FF1B6BF5FF1D6E - F7FF1561F5FFBABFCF4500000000000000000000000000000000000000000000 - 000000000000BDD6EAFFB3CFE8FFABCAE5FFA2C4E3FF97BDDFFF8BB5DAFF82AE - D6FF7DAAD4FF78A6D2FF5D81A5FF6E9DCDFF0F0E0EFF060709FF000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000008DB6C8DB6AC7E4FF59AAC4FF4E99B1FFEBEC - ECFFECEDEDFFB2B2B4FFC5C7C7FFD4FEFFFFA8F0FDFFA6EFFDFFA3EEFDFFA0ED - FDFF9EEBFDFF9BEAFDFF99E9FCFF96E8FCFFB4E9FCFF8FE8FFFF000000000000 - 000000000000000000000000000000000000FBFBFBFFFDFFFFFFD2994AFFD097 - 4AFFCE944AFFCC9248FFCB8F47FFC39C6CFF7E93ABFF8093A9FF92ADCCFF93B4 - D8FF7CAAD4FF4E5053FF1D2025FF14161AFF2E261EFFBF8544FFBC813FFFB87C - 34FFB5772FFFB07126FFAA681BFFA46015FFA05C13FF9E580FFF9D570BFF9A54 - 06FF964E00FF934B00FFEDEDEEFFE9E9E9FF0000000000000000DADBE1253771 - EAF44F92FCFF4789F7FF498BF8FF73A0F6FFC4D3F7FFFFFFFFFFFFFFFFFFFFFF - FFFFFCFCFEFF96B2F4FF588DF4FF4787F7FF4084F7FF538BF4FF7CA0F2FFEFF2 - FCFFFFFFFFFFFFFFFFFFFFFFFFFFABC0F5FF6394F4FF337AF6FF216EF5FF2272 - FEFF4B74CEBCFEFEFE0100000000000000000000000000000000000000000000 - 000000000000BCD5EAFFB3CFE8FFABCAE5FFA2C4E3FF97BDDFFF8BB5DAFF82AE - D6FF7DAAD4FF78A6D2FF212A33FF75A8DCFF131316FF111214FF000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000008DB6C8DB6AC7E4FF59AAC4FF4E99B1FFECED - EDFFF0F0F0FFBCBCBDFFCFCFD0FFD5FFFFFFA9F1FDFFA7EFFDFFA4EEFDFFA2ED - FDFF9FECFDFF9CEBFDFF9AEAFCFF97E9FCFFB5E9FCFF8FE8FEFF000000000000 - 000000000000000000000000000000000000FCFCFCFFFEFFFFFFCB9552FFCB95 - 52FFCA9350FFC9914DFFCC9149FF55483AFF45474BFF616265FF909193FF7B7C - 7EFF5C5F61FF393C40FF212429FF14171BFF93673BFFBA803AFFB87C38FFB478 - 34FFB1732EFFAD6F28FFAA6A1FFFA66417FFA46320FFA56324FFA15D11FF9D59 - 0FFF9E5A14FF9F5B16FFEDEDEEFFE9E9EAFF0000000000000000000000008E9E - C7744487FFFF5191F9FF498BF7FF4D8DF7FF6294F5FF96B2F3FFF7F9FDFFFBFB - FEFF85A6F2FF568DF5FF4889F7FF377FF7FF377EF7FF3F84F7FF528CF6FF6390 - F1FFE2E9FBFFF7F8FDFF84A5F2FF5288F4FF397EF7FF2572F6FF2A77F9FF2166 - EDF4D2D5DD2D0000000000000000000000000000000000000000000000000000 - 000000000000B4D0E7FFB3CFE8FFABCAE5FFA2C4E3FF97BDDFFF8BB5DAFF82AE - D6FF7DAAD4FF78A6D2FF121314FF14171BFF131518FF121315FF000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000008DB6C8DB6AC7E4FF59ABC5FF4E9AB2FFEEEE - EEFFEFF0F0FFF0F0F0FFD1D2D3FFD7FFFFFFABF1FEFFA8F0FDFFA5EFFDFFA3EE - FDFFA0EDFDFF9DEBFDFF9BEAFDFF99E9FCFFB6EAFCFF91E9FEFF000000000000 - 000000000000000000000000000000000000FCFCFCFFFEFFFFFFC8914EFFC58E - 4AFFC38C48FFC28945FFC08741FFBD843FFF534C43FF535558FF606265FF5B5D - 60FF494B4FFF3A3C40FF1D1F24FF31271EFFAE6C30FFB97E42FFB97E42FFB67A - 3FFFB3763BFFB17237FFAD6E32FFAA6A2EFFA7672BFFA66528FFA56426FFA563 - 25FFA2601EFF9F5C16FFEDEEEFFFE9EAEAFF000000000000000000000000FEFE - FE016686CEA64C8FFFFF5392F9FF4B8CF8FF4F8FF9FF538DF6FF6C94F0FF6B94 - F0FF4B87F6FF478AF8FF3F84F7FF4084F7FF3F83F7FF3A80F7FF3B82F7FF4585 - F7FF4D82F0FF5987EFFF4281F5FF387FF7FF2B76F6FF317BF8FF226EFDFFA2B0 - CC5D000000000000000000000000000000000000000000000000000000000000 - 0000000000009EC1E0FFB3CFE8FFABCAE5FFA2C4E3FF97BDDFFF8BB5DAFF82AE - D6FF7DAAD4FF7DADDBFF35373BFF15181DFF14161AFF131417FFE2E2E31F0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000008DB6C8DB6AC7E4FF5DB2CDFF55A5BFFFF0F0 - F0FFE2E2E2FFB3B4B5FFA1A1A3FFD8FFFFFFACF2FEFFA9F0FDFFA7EFFDFFA4EE - FDFFA2EDFDFF9FECFDFF9CEBFDFF99EAFCFFB6EBFCFF92E9FEFF000000000000 - 000000000000000000000000000000000000FCFCFCFFFEFFFFFFCA9350FFC891 - 4DFFC58E4AFFC38C47FFC18944FFC08741FFBD843EFFBF833AFF7F6443FF4044 - 4BFF323840FF5A4431FFB37232FFB06F31FFAE6C30FFAC6A2FFFAA672DFFAD6C - 32FFB77C40FFB3763BFFB07236FFAE6F33FFAA6B2FFFA7672BFFA66528FFA564 - 27FFA56325FFA46223FFEDEEEFFFEAEAEAFF0000000000000000000000000000 - 0000F8F8F8076286D2AB4C90FFFF5695FAFF4F8FF8FF4F8FF9FF4889F7FF3F84 - F6FF498CF8FF4588F7FF4587F7FF4486F7FF4285F7FF4184F7FF3E83F7FF3C82 - F7FF377EF7FF357CF6FF397FF7FF357CF6FF3780FBFF2572FDFD94A7CF6C0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000095BBDDFFB3CFE8FFABCAE5FFA2C4E3FF97BDDFFF8BB5DAFF82AE - D6FF7DAAD4FF404A54FF2B2D32FF181B20FF14171BFF131418FFE1E1E1200000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000008DB6C8DB6AC7E4FF5FB6D2FF5BB0CDFFF1F1 - F1FFF2F3F3FFF3F4F4FFF4F5F5FFBEFAFFFFABF2FEFFABF1FEFFA8F0FDFFA6EF - FDFFA3EEFDFFA0EDFDFF9EEBFDFF9BEAFDFFB7EBFCFF94E9FEFF000000000000 - 000000000000000000000000000000000000FCFCFCFFFDFFFFFFCA924EFFC890 - 4BFFC58D47FFC38A44FFC18841FFC0853EFFBE833BFFBB8039FFB97E35FFB77C - 32FFB6792FFFB4742DFFB06E2CFFAE6B2BFFAC682AFFAA6629FFA86327FFA55F - 26FFA35D25FFA15A24FF9F5A23FFAB692DFFAC6B2DFFA8672AFFA56326FFA462 - 23FFA36121FFA36020FFEDEEEFFFEAEAEAFF0000000000000000000000000000 - 000000000000FCFCFC037F99CD873F84FFFD5798FFFF5594F9FF5090F8FF4F8F - F8FF4D8DF8FF4C8CF7FF498AF7FF478AF7FF4688F7FF4587F7FF4386F7FF4184 - F7FF3F83F7FF3E83F7FF3F84F8FF3983FFFF3677EEE3B0BCD24F000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000A1C0E3FF869DB6FF728294FF8093A9FF96B3D4FF97B5D6FF8BAF - D4FF7CAAD4FF3A393BFF323438FF1D2025FF15171CFF131518FFE4E5E51E0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000080A8BDD569C5E3FF5FB6D2FF5CB1CDFFCCE2 - E9FFF7F6F5FFF5F5F5FFF6F6F6FFF9F8F8FFB6F4FEFFC2F6FFFFA9F1FDFFA7EF - FDFFA4EEFDFFA2EDFDFF9FECFDFF9CEBFDFFB7EBFCFF94EAFEFF000000000000 - 000000000000000000000000000000000000FCFCFCFFFBFBFBFFFBFBFBFFFCFC - FCFFFCFCFCFFFCFCFCFFFDFDFDFFFDFDFDFFFDFDFDFFFDFDFDFFFEFEFEFFFEFE - FEFFFEFEFEFFFEFEFEFFFDFDFDFFFDFDFDFFFDFDFDFFFCFCFCFFFCFCFCFFFCFC - FCFFFBFBFBFFFBFBFBFFFBFBFBFFFAFAFAFFFAFAFAFFFAFAFAFFF8F8F9FFF5F5 - F6FFF3F3F3FFF0F0F0FFEDEDEEFFEAEAEAFF0000000000000000000000000000 - 0000000000000000000000000000C0C8D83F5885DBC04589FEFF5595FCFF5795 - FBFF5493F9FF5190F8FF4E8EF8FF4D8DF8FF4B8CF7FF498AF7FF488AF7FF478A - F8FF468AFBFF4087FFFF3479F6F66F95DA98E4E6EB1B00000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000003F4145FF434549FF5B5D60FF8D8F90FF7D7E80FF969798FF7071 - 74FF4F5051FF424448FF3E4044FF202328FF15181CFF131519FF000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000EDF0F24688D2E9FF5FB6D2FF5CB1CDFF5CB0 - CCFF5BB0CBFF54ACC8FF98CCDCFFFFFDFBFFF9FAFAFFFFFCFBFFB2F2FEFFAFF1 - FDFFA6EFFDFFA3EEFDFFA0EDFDFF9EEBFDFFB8EBFDFF96EAFEFF000000000000 - 000000000000000000000000000000000000EEEEEEFFEEEEEEFFEDEDEDFFEDEE - EEFFEDEEEEFFEDEDEDFFECEDEDFFEDEDEDFFECECEDFFECECECFFECECECFFECEC - ECFFEBEBEBFFEBEBEBFFEAEAEBFFEAEAEAFFEAEAEAFFE9E9E9FFE8E8E9FFE8E8 - E8FFE7E7E8FFE6E6E7FFE5E5E6FFE4E4E4FFE3E3E3FFE1E1E2FFDFDFE0FFDDDD - DEFFD9DADBFFD8D8D8FFD4D5D6FFD1D1D2FF0000000000000000000000000000 - 00000000000000000000000000000000000000000000B8C5DD476C99EBA24986 - EFE24387F9FF4C8DF8FF4F8FF8FF4F8FF8FF4D8DF8FF488AF7FF4287F9FF3980 - F8FA4883EAD380A1DA85D7DEEB28000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000A4A6A8A3434549FF535558FF626466FF6F7072FF6C6D70FF7C7D - 7FFF5F6264FF45474BFF2E3135FF1E2126FF15171CFF0F1113FF000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FDFDFE078EC9DDCE94CDDFFFA3D4 - E3FF66B5CEFF56ADC9FF5AAEC9FF59ADC9FF58ACC8FF69B5CDFFFFFFFFFFFFFE - FDFFB1EFFCFFA4EEFDFFA2EDFDFF9FECFDFFB9ECFDFF97EBFEFF000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000DFE5 - F120AEC7EE5289B1F57E74A5F89B73A4F89F72A3F89F78A8FA9493B3E972BCCE - ED44ECF0F7130000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000EAEAEB404C4E51FF57595CFF5F6164FF5E6063FF5557 - 5AFF494B4EFF3D4044FF2C2E33FF1B1E23FF2F3135F100000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000F5F9FB14A7D0DFA382C1D6FF6DB7CEFF56AAC4FF57AA - C4FF50A6C1FFEAF3F6FFB5EFFBFFA0EDFDFFB9ECFDFF9CEDFFFF000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000C4C5C67B494B4DFF4E5053FF484A - 4DFF3E4044FF313439FF32353AF6000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000FEFEFE01D5E8EE6C72B6CCF34AA2BEFF9CD9E9FF9DEEFFFF000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000FEFEFE01FDFDFE02FCFCFD03FBFBFC04FAFAFB05F9F9FB06F8F8 - FA07F7F7F908F7F7F908F7F7F908F7F7F908F8F8FA07F9F9FA06FAFAFB05FAFA - FB05FBFBFC04FCFCFD03FEFEFE01FEFEFE010000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000E9E9E929615E5FC91F1B - 1DFF1A1618FF1C181AFF0C0809FF161314FF1C1819FFA7A6A68A00000000C6C6 - C7A87C7D7FFF88898BFF7C7C7FFF757678FFF0F0F03300000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000E9E9E929615E5FC91F1B - 1DFF1A1618FF1C181AFF0C0809FF161314FF1C1819FFA7A6A68A00000000C6C6 - C7A87C7D7FFF88898BFF7C7C7FFF757678FFF0F0F03300000000000000000000 - 000000000000000000000000000000000000000000000000000000000000FEFE - FE01FDFDFE02FAFAFC05F8F8F907F6F6F709F2F2F40DDBDBE424B1B2CC4E999B - BD669092B86F9092B86F9092B86FA0A2C15FB0B1CB4FC6C7D839D3D3E02CEAEA - EC15F4F4F50BF6F6F709F8F8F907FAFAFB05FCFCFD03FDFDFE02FEFEFE010000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000006D6A6CC11D191BFF1F1B1EFF201C1EFF201C1FFF201C - 1FFF201C1EFF2A2529FF151213FF1E1A1CFF191517FF9C9D9FFFFFFFFFFFFEFE - FEFFDBDBDCFFDEDBDFFFE2E0E3FFF1F2F1FFFFFFFFFFCACACBFFD5D5D6800000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000006D6A6CC11D191BFF1F1B1EFF201C1EFF201C1FFF201C - 1FFF201C1EFF2A2529FF151213FF1E1A1CFF191517FF9C9D9FFFFFFFFFFFFEFE - FEFFDBDBDCFFDEDBDFFFE2E0E3FFF1F2F1FFFFFFFFFFCACACBFFD5D5D6800000 - 0000000000000000000000000000000000000000000000000000FDFDFE02FAFA - FC05F2F3F50DD0D1D82F8D92C0724E59B5B10E1E9FF1001199FF001198FF0011 - 97FF001197FF001197FF001197FF001198FF001198FF001199FF021298FD0011 - 99FF202EA4DF4551B2BA767EBF89A5A8BF5AD0D1D92FEFF0F410FAFAFC05FCFC - FD03FEFEFE010000000000000000000000000000000000000000000000000000 - 00001D191BFD1F1B1EFF151113FF141012FF221E21FF231F22FF231F22FF231F - 22FF231F22FF272326FF191517FF1B1719FFDDDDDEFFF5F5F5FFA2AB9EFF2068 - 20FF298340FF298240FF298240FF29813FFF297F3DFFEFEBEFFFFFFFFFFF6263 - 66FF000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000F9F9F912E6E6E764E1E1E25CFEFEFE0500000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00001D191BFD1F1B1EFF151113FF141012FF221E21FF231F22FF231F22FF231F - 22FF231F22FF272326FF191517FF1B1719FFDDDDDEFFF5F5F5FFA2AB9EFF2068 - 20FF298340FF298240FF298240FF29813FFF297F3DFFEFEBEFFFFFFFFFFF6263 - 66FF0000000000000000000000000000000000000000FEFEFE01FAFAFC05F3F3 - F40C8991C0763043AFCF0F26A6FB041BA0FF00179EFF00179EFF00179EFF0017 - 9EFF00179EFF00179EFF00179EFF00179EFF00179EFF00179FFF454599E40F24 - A1F700179EFF00179EFF0018A0FF0A21A3F52D40AFD25A66ACA5C1C5DA3EF4F4 - F60BFBFBFD04FDFDFE0200000000000000000000000000000000FAFAFA0C201C - 1EFF211D1FFF211C1FFF1D181AFF1C1619FF494749FF262225FF262226FF2622 - 26FF262226FF242025FF151113FFEEEEEFFFB8B9BAFF1A3E00FF298745FF2989 - 47FF298A48FF278B48FF298A48FF298947FF298745FF298543FFA0C2A9FFFFFF - FFFF626366FF0000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000008D8E - 90FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF5F5F5FF67686AFF0000 - 0000000000000000000000000000000000000000000000000000FAFAFA0C201C - 1EFF211D1FFF211C1FFF1D181AFF1C1619FF494749FF262225FF262226FF2622 - 26FF262226FF242025FF151113FFEEEEEFFFB8B9BAFF1A3E00FF298745FF2989 - 47FF288D4BFF288D4BFF288C4AFF298947FF298745FF298543FFA0C2A9FFFFFF - FFFF626366FF00000000000000000000000000000000FDFDFE02ECEEF4136077 - C4A01638B4FF2947B7FF2D49B8FF203FB3FF0426AAFF0023A8FF0023A8FF0023 - A8FF0023A8FF0023A8FF0023A8FF0023A8FF0023AAFF0425A8FFA43F1AFF452F - 6EFF0023A9FF0023A8FF0023A8FF0023A8FF0023A9FF0023ABFF072BB2F84E67 - C4B1DADCE425FAFAFC05FEFEFE010000000000000000FEFEFE01171315FF2420 - 23FF231F22FF252023FF262023FF241E21FF5C5A5CFF282327FF2A262AFF2A26 - 2AFF2A262AFF292529FFBCBDBEFFCFD0D1FF1E4100FF298D4BFF298F4DFF2991 - 4FFF1F762FFFE4E1E6FF299250FF299250FF298F4DFF298D4BFF298947FFA7C8 - B1FFFFFFFFFFE6E6E76800000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000A9AAACF1FFFFFFFFD7D8 - D8FFA1AA9BFF1E5F18FF227C37FF217A35FF2B7E3CFFDBDFDDFFF7F7F7FFFFFF - FFFFB8B8B9A600000000000000000000000000000000FEFEFE01171315FF2420 - 23FF231F22FF252023FF262023FF241E21FF5C5A5CFF282327FF2A262AFF2A26 - 2AFF2A262AFF292529FFBCBDBEFFCFD0D1FF1E4100FF298D4BFF298F4DFF2992 - 50FF9CA991FFDADADAFFD8D8D8FF269350FF298F4DFF298D4BFF298947FFA7C8 - B1FFFFFFFFFFE6E6E768000000000000000000000000FCFCFD03E9E9EC164868 - BFB9385BC5FF3759C3FF3357C3FF3154C1FF1E45BCFF0430B4FF002CB3FF002C - B3FF002CB3FF002CB3FF002CB3FF002CB3FF002EB6FF273698FFBA4308FF923E - 2DFF012FB6FF002CB3FF002CB3FF002CB3FF002CB3FF002CB3FF002DB5FF0030 - B9FF5773C3A8E2E4EA1DFDFDFE020000000000000000161315FF1D191CFF2521 - 24FF262225FF2D2A2DFF2E272BFF2C2629FF747173FF9B9B9BFF302A2EFF302A - 2EFF302A2EFF4C484CFFFFFFFFFF3C5D26FF29904EFF299453FF299856FF217A - 34FFE4E4E4FFE3E3E3FF307836FF299958FF299856FF299453FF29914FFF298D - 4BFFEEEBEEFFB7B7B9FF00000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000A3A4A6FFFFFFFFFFADB0AFFF2774 - 30FF298543FF298744FF298745FF298745FF298644FF298442FF25803CFFF5EF - F4FFFFFFFFFF98989AD6000000000000000000000000161315FF1D191CFF2521 - 24FF262225FF2D2A2DFF2E272BFF2C2629FF747173FF9B9B9BFF302A2EFF302A - 2EFF302A2EFF4C484CFFFFFFFFFF3C5D26FF29904EFF299453FF299856FF2999 - 58FFA2AF96FFE3E3E3FFE0E0E0FF269B59FF299856FF299453FF29914FFF298D - 4BFFEEEBEEFFB7B7B9FF000000000000000000000000FDFDFE02F6F6F7097D92 - BE823765CEFF416BCFFF3C68CEFF3966CDFF3663CCFF2A59C9FF0C42C2FF023B - BFFF0039BFFF0039BFFF0039BFFF0039C0FF0342C5FF7A6B8FFFBA4308FFBE4E - 17FF4C76D4FF003AC0FF0039BFFF0039BFFF0039BFFF0039BFFF0039BFFF003A - C0FF0847C9F7ACB3C153FCFCFE030000000000000000201C20FF231F22FF2723 - 27FF282428FF2E2A2EFF2F282CFF342D31FF8B898AFFB7B8B8FF322B2FFF362F - 33FF352E32FFCBCCCDFFA6A7A9FF266F2AFF299856FF299C5AFF267E3AFFEDED - EDFFEDEDEDFFEBEBECFFEAEAEBFF29A361FF299F5EFF299C5AFF299856FF2993 - 51FF389559FFFFFFFFFFFCFCFC15000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000E1E1E2A1FFFFFFFF818F7AFF298D4BFF298C - 4AFF298E4CFF405A1DFFE0DCE0FFDEDADEFF1D7F37FF298C4AFF298A48FF2987 - 45FFF1EDF0FFFFFFFFFFFCFCFC210000000000000000201C20FF231F22FF2723 - 27FF282428FF2E2A2EFF2F282CFF342D31FF8B898AFFB7B8B8FF322B2FFF362F - 33FF352E32FFCBCCCDFFA6A7A9FF266F2AFF299856FF299C5AFF299F5EFF29A2 - 60FFA8B49BFFEAEAEBFFE8E8E8FF26A461FF299F5EFF299C5AFF299856FF2993 - 51FF389559FFFFFFFFFFFCFCFC150000000000000000FEFEFE01F9FAFB06C8D1 - E0372B69D7FF4D7EDBFF4275D8FF3F73D8FF3C71D7FF3A6FD6FF3169D5FF1D5A - D0FF0449CCFF0045CBFF0045CBFF0046CCFF1F64D7FFBCB7C7FFBA4308FFD07F - 56FFA0BCEDFF064DCEFF0045CBFF0045CBFF0045CBFF0045CBFF0045CBFF0046 - CCFF125BD4EDB6BDCA49FCFCFE0300000000000000001C171BFF292529FF2B27 - 2BFF2C272BFF3D383BFFC9CBCAFF443D41FF9F9E9FFFC2C3C3FFC8C9C9FF3D36 - 3AFF3C3539FFF4F4F4FF818684FF299C5BFF299F5DFF2D8240FFF3F3F3FFF5F5 - F5FFF5F5F5FFF3F3F4FFF0F0F0FF98A789FF29A766FF29A362FF299F5DFF299A - 58FF289452FFF7F7F7FF909193E600000000D4D4D5FFD3D3D4FFD3D3D3FFD2D2 - D3FFD1D1D2FFD0D0D1FFD0D0D1FFCECFD0FFCECECFFFCDCDCEFFCBCCCDFFCBCB - CBFFC9CACAFFC8C8C9FFC7C8C9FFF5F5F6FF9E9CA3FF288744FF29914FFF2994 - 52FF299755FF415F21FFDFDFE0FFDDDDDDFF1D8740FF299452FF299250FF298E - 4CFF298A48FFEDECEDFFA4A4A6FFAAABABFF000000001C171BFF292529FF2B27 - 2BFF2C272BFF3D383BFFC9CBCAFF443D41FF9F9E9FFFC2C3C3FFC8C9C9FF3D36 - 3AFF3C3539FFF4F4F4FF818684FF299C5BFF27A15EFF209F5AFF20A25EFF20A6 - 62FFAAB7A0FFF3F3F3FFEFEFEFFF1CA963FF20A35FFF219F5BFF219B57FF299A - 58FF289452FFF7F7F7FF909193E6000000000000000000000000FCFDFE03F9FA - FB065090E4BA5C93E7FF4B86E4FF4783E3FF4382E3FF4180E2FF3E7DE2FF3B7C - E2FF3476E1FF1E68DDFF085ADAFF0159DBFF5F9DEBFFF6F9FCFFC86B3CFFE8C0 - ADFFD5E5F9FF2B76E1FF105FDBFF0155D9FF0054D9FF0054D9FF0054D9FF0057 - DBFF4B87D3B4E7EDF718FDFDFE020000000000000000494749E6332C30FF2F2A - 2EFF312B2FFF4B4549FFCECECEFF524A4DFFA5A3A5FFCECECEFFCCCCCCFF8F8A - 8CFF3E373BFFFFFFFFFF4B6339FF29A05EFF1E7029FFF6F6F6FFFBFBFBFFFDFD - FDFF1EAD68FFFFFFFFFFF7F7F7FFF2F2F1FF22AE6AFF29AB6AFF29A664FF29A0 - 5FFF299A58FFE5E4E6FF7A7B7DFF00000000E7E7E8FFE8E8E8FFE9E9EAFFEAEA - EBFFEBEBECFFECECEDFFEDEDEEFFEDEDEFFFEEEEEFFFEFEFEFFFEFEFF0FFEFEF - F0FFEFEFF0FFEFEFF0FFD2D2D4FFFFFFFFFF1C3F00FF299453FF299957FF299C - 5AFF299F5DFF426023FFE7E7E8FFE5E5E5FF1D8E47FF299D5CFF299A58FF2996 - 54FF29914FFF3D955AFFFFFFFFFFCFCFD0FF00000000494749E6332C30FF2F2A - 2EFF312B2FFF4B4549FFCECECEFF524A4DFFA5A3A5FFCECECEFFCCCCCCFF8F8A - 8CFF3E373BFFFFFFFFFF4B6339FF29A05EFF56723BFFF7F7F7FFFBFBFBFFFDFD - FDFFFDFDFDFFFBFBFBFFF7F7F7FFF1F1F1FFEAEAEBFFE3E3E3FFDCDCDCFF29A2 - 61FF299A58FFE5E4E6FF7A7B7DFF00000000000000000000000000000000FDFD - FE02AECBF1594690EDF1649EEFFF4C90EDFF498EEDFF478CECFF448AECFF4289 - EBFF3E87EBFF3C85EBFF2F7FEAFF1476E9FFBBD9F9FFFAF2E8FFE5B58CFFF7E9 - DEFFF3F8FEFF4994EEFF1F74E8FF0D68E6FF0060E5FF0060E5FF0061E5FF0069 - E7FFAAC8EA55FBFCFD04FEFEFE010000000000000000F8F8F8183B3438FF322C - 30FF342D31FF5A5558FFD9D9D9FF332B2FFF2A2529FFBBBCBDFFF6F7F6FFD5D5 - D6FF4A4246FFFFFFFFFF415D2DFF29A564FF29B070FFF6F7F4FFFFFFFFFF25B6 - 74FF28B373FF183900FFFDFDFDFFF7F7F7FFFCF8FDFF29B06FFF29AD6CFF29A6 - 64FF299F5EFFDEDDDEFF818284FF00000000EAEAEAFFEDF0F6FFAF6E21FFB06E - 21FFAF6D23FFAE6D24FF9C4B0BFF8F4600FFAE6100FFB76B00FFBE7400FFC27A - 00FFC47D02FFC47E03FFCBCFD5FF929195FF288C49FF299C5AFF29A05FFF29A4 - 62FF29A765FF436224FFF0F0F0FFEDEDEDFF1C944EFF29A563FF29A260FF299D - 5CFF299857FF299250FFF2F2F3FF737476FF00000000F8F8F8183B3438FF322C - 30FF342D31FF5A5558FFD9D9D9FF332B2FFF2A2529FFBBBCBDFFF6F7F6FFD5D5 - D6FF4A4246FFFFFFFFFF415D2DFF29A564FF58733DFFFDFDFDFFFDFDFDFFFDFD - FDFFFDFDFDFFFDFDFDFFFDFDFDFFF6F6F6FFEFEFEFFFE7E7E7FFDFDFE0FF29A8 - 66FF299F5EFFDEDDDEFF818284FF000000000000000000000000000000000000 - 0000F5F9FD0B6AAFF4986AADF8FF62A5F7FF509CF6FF4E9BF6FF4B99F6FF4998 - F6FF4696F6FF4A98F6FF3090F5FF5BACF7FFFDF9F4FFE1A86AFFD37D22FFE5B2 - 7CFFFEFEFDFF77B9F9FF2E8BF4FF2482F4FF006EF2FF006EF2FF0376F3FC5CAB - F2A3FDFDFE02FEFEFE01000000000000000000000000000000003E373BFF433C - 40FF373034FF4C4649FFDEDEDEFF5E5659FF3F383CFF545153FFDBDBDCFFDBDB - DCFFD9D9DAFFFCFCFCFF647163FF29AB6AFF29B06FFF1F4600FF28B777FF28B5 - 75FF28B676FF28BA7AFFBECAB5FFFBFBFBFFF3F3F3FF739266FF29B06FFF29AB - 6AFF29A462FFE9E9E9FF838487FF00000000ECECEDFFF0F2F7FFB4762EFFB476 - 2CFFB5762CFFB4752EFFAF6D27FFA15B00FFB97004FFC27B01FFC8830EFFCC8A - 17FFCE8D1DFFCF8F1FFFEEEEEEFF7F8284FF29A05FFF193A00FFFBF9FCFFFFFD - FFFFFFFFFFFFFFFFFFFFF8F8F8FFF4F4F4FFF7F5F8FFF0EFF2FFE9E8EBFFE2E0 - E3FF24A05CFF299957FFE6E1E5FF909193FF00000000000000003E373BFF433C - 40FF373034FF4C4649FFDEDEDEFF5E5659FF3F383CFF545153FFDBDBDCFFDBDB - DCFFD9D9DAFFFCFCFCFF647163FF29AB6AFF395717FF7D8F64FF7D8F64FF7E90 - 65FFD3DACCFFFDFDFDFFFDFDFDFF798C60FF798B60FF75875DFF728459FF29AD - 6CFF29A462FFE9E9E9FF838487FF000000000000000000000000000000000000 - 000000000000E4EFFB203EA2FDE779BAFDFF5BA9FDFF54A6FDFF51A4FDFF4FA3 - FDFF57A7FDFF6AB3FDFF35A1FDFFCDE8FEFFFEFCFAFFEBC49AFFD48129FFE3AE - 75FFFEFEFDFF99D2FEFF43A0FDFF54A6FDFF1C89FCFF1688FCFF33A1FBCCD4E8 - FA2C000000000000000000000000000000000000000000000000949294B24B44 - 48FF3B3438FF383034FFDADADBFFDEDDDDFF93B8E5FFD5E0ECFFE0E0E1FFE1E1 - E2FFE1E1E2FFE3E3E3FF737277FF29AF6DFF29B271FF28B474FF28B676FF27B7 - 77FF27B879FF27B979FF26833FFFFFFFFFFFF4F4F5FFECECECFF1DA55FFF29B0 - 6FFF20A660FFFFFFFFFFECECEC5900000000EEEEEFFFF2F5FAFFB77A33FFB77A - 32FFB77A30FFB77930FFB77933FFB06C00FFC17901FFC98510FFD59924FFD698 - 23FFD59824FFD59823FFF9F8F9FF6C776BFF29A462FF193C00FFFAFAFAFFFDFD - FDFFFDFDFDFFFDFDFDFFFDFDFDFFFBFBFBFFF5F5F5FFEEEEEFFFE7E7E7FFDFDF - E0FF24A663FF299F5DFFE1DADFFFABACADFF0000000000000000949294B24B44 - 48FF3B3438FF383034FFDADADBFFDEDDDDFF93B8E5FFD5E0ECFFE0E0E1FFE1E1 - E2FFE1E1E2FFE3E3E3FF737277FF29AF6DFF29B271FF28B474FF28B676FF27B7 - 78FFB3C0A7FFFEFEFEFFFDFDFDFF23BA79FF28B676FF28B474FF29B271FF29B0 - 6FFF20A660FFFFFFFFFFECECEC59000000000000000000000000000000000000 - 00000000000000000000C2E4FD4049B1FFDA84C6FFFF74BDFFFF69B8FFFF75BE - FFFF89C9FFFF5BBAFFFFCFECFEFFEDF4FAFFD0E3F2FFB7D4EBFFBCC8CEFFE1ED - F7FFFFFFFFFFAFE0FFFF44ACFFFF8DCAFFFF4FAEFFFD42AFFFD2DFEFFD220000 - 000000000000000000000000000000000000000000000000000000000000312A - 2EFF4C4649FF443C40FFE7E7E7FF7FABDBFF82ABDBFF7DA6D9FF75A1D5FFECEC - ECFFE7E7E8FFE3E4E4FFFFFFFFFF1D4000FF29B372FF28B575FF27B777FF27B9 - 7AFF26BA7BFF26BB7CFF26BA7BFF163700FFF4F4F4FFECECECFFE5E5E6FF29B2 - 72FFC4C0C3FFF6F6F6FF0000000000000000F0F0F1FFF4F7FBFFBA7E36FFBA7E - 38FFBA7E37FFBA7D34FFB97C33FFBB7300FFC47F07FFD69A26FFD8A33FFF8FB5 - E2FFFBEEDBFFCEAA72FFF1F1F1FF747779FF29AB6AFF193B00FFFFFFFFFFFFFF - FFFFFFFFFFFFFFFFFFFFFDFDFDFFFDFDFDFFFFFFFFFFFAF9FBFFF1F0F4FFE9E8 - EBFF24AB68FF29A462FFDAD5D9FF99999BFF000000000000000000000000312A - 2EFF4C4649FF443C40FFE7E7E7FF7FABDBFF82ABDBFF7DA6D9FF75A1D5FFECEC - ECFFE7E7E8FFE3E4E4FFFFFFFFFF1D4000FF29B372FF28B575FF27B777FF27B9 - 7AFFB3C0A7FFFEFEFEFFFDFDFDFF23BC7CFF27B777FF28B575FF28B372FF29B1 - 70FFC4C0C3FFF6F6F6FF00000000000000000000000000000000000000000000 - 00000000000000000000FBFDFE04C2E6FD414BB6FFE78BCDFFFF98D2FFFF99D3 - FFFF65C3FFFFACDFFEFFC6DCEDFF99C2E1FF81B4DCFF7EB3DBFF80B5DEFF8FBE - E2FFDFECF6FFACE1FEFF42B2FFFF8CCFFFFFA2DBFFBCDAEEFD35000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000393235FF484044FFFFFFFFFF86B0DDFF82ABDBFF7DA6D9FF75A1D5FF6D9C - D1FFF4F2F1FFEDEDEEFFF5F5F5FF68686DFF269552FF28B676FF27B879FF26BA - 7BFF26BC7EFF25BD7FFF26BC7EFF26BC7DFF5A7643FFECECEEFF24B877FF28B1 - 70FFFFFFFFFFA4A5A6F10000000000000000F3F3F3FFF6F9FEFFBD8138FFBD82 - 3BFFBD823CFFBC813AFFBC8037FFBB7F36FFC58101FFD29322FFBAC2C4FF81AA - DBFF78A3D7FF6A99CEFFDDDEE0FF7C7B7FFF29A766FF29B676FF29B878FF28BA - 7BFF28BC7CFF456326FFFEFEFEFFFDFDFDFF19A661FF28BA7BFF28B879FF29B7 - 77FF29AF6EFF29A766FFE7E7E8FF88888AFF0000000000000000000000000000 - 0000393235FF484044FFFFFFFFFF86B0DDFF82ABDBFF7DA6D9FF75A1D5FF6D9C - D1FFF4F2F1FFEDEDEEFFF5F5F5FF68686DFF269552FF28B676FF27B879FF26BB - 7CFFB3C0A7FFFDFDFDFFFDFDFDFF22BE7EFF27B879FF28B676FF28B473FF28B1 - 70FFFFFFFFFFA4A5A6F100000000000000000000000000000000000000000000 - 000000000000000000000000000000000000E0F3FE227CCDFD8E65C4FEDE4FBE - FEFC9DD0EDFF93B5D1FF6E9CC0FF6995B7FF6A94B5FF7098B7FF78A4C7FF7EAE - D4F7B0CEE6B097D5F89B8FCFF797D9EEFB52FDFEFE0200000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000FDFDFD07504C53FF6592C0FF6492C0FF7EA7DAFF75A1D5FF6D9C - D1FF6597CDFFF3F3F4FFC8C5C7FFFFFFFFFF6C6C73FF27A766FF27B979FF26BB - 7CFF25BE7FFF24C082FF25BE7FFF26BB7CFF27BE80FF27BB7BFF20B570FFDADB - DBFFBBBBBCFF000000000000000000000000F5F5F5FFF8FBFFFFC0853DFFC086 - 3CFFC0863EFFBF8540FFBF843EFFBE833AFFBD8138FFCA8622FF799BB8FF6794 - C2FF78A3D7FF6D9CD1FFBAC9DAFFFFFFFFFF1E3F00FF29B271FF28B474FF27B6 - 77FF27B879FF456326FFFEFEFEFFFDFDFDFF19A35EFF27B777FF28B575FF29B3 - 72FF29B06FFF3AAD73FFFFFFFFFFD7D7D8FF0000000000000000000000000000 - 000000000000FDFDFD07504C53FF6592C0FF6492C0FF7EA7DAFF75A1D5FF6D9C - D1FF6597CDFFF3F3F4FFC8C5C7FFFFFFFFFF6C6C73FF27A766FF27B979FF26BC - 7DFF274400FF294600FF294500FF26BF81FF27B979FF27B677FF20B570FFDADB - DBFFBBBBBCFF0000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000FCFDFE03D1E8F83E92C2 - E0C07EA4C2FF628BAAFF628BABFF6A97B9FF6F9DC2FF71A1C5FF72A1C6FF76A3 - C7F7BAD1E37CF3F9FC12FEFEFE01000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000A9C9E4FF9EC2E1FF8AB4DAFF84AFD7FF6693C1FF6D99CBFF6D9C - D1FF6597CDFFE0E8F1FFABA7A9F3F6F6F6AFFFFFFFFF6B6A6FFF1F4800FF26BE - 80FF26BD7EFF25BE7FFF26BD7EFF26BB7CFF27B979FF73A791FFF3F3F3FFD1D1 - D2FF00000000000000000000000000000000F7F7F7FFFAFEFFFFC38A44FFC389 - 41FFC38940FFC28942FFC28843FFC08741FFC18337FFA5C7E4FF96BDDFFF86B1 - D8FF6492C0FF6D9CD2FF5F93CBFFFBFBFBFF6A6970FF29B575FF28B575FF27B8 - 78FF26BA7AFF456326FFFDFDFDFFFDFDFDFF18A560FF27B879FF27B676FF28B4 - 73FF29B170FFBFBEC0FFBCBDBEFFE2E2E3FF0000000000000000000000000000 - 000000000000A9C9E4FF9EC2E1FF8AB4DAFF84AFD7FF6693C1FF6D99CBFF6D9C - D1FF6597CDFFE0E8F1FFABA7A9F3F6F6F6AFFFFFFFFF6B6A6FFF1F4800FF26BE - 80FF26BD7EFF25BE7FFF26BD7EFF26BB7CFF27B979FF73A791FFF3F3F3FFD1D1 - D2FF000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000B3CCDF866893B3FC6F9DC1FF74A4C9FF78A9D0FF7BADD5FF7CAED6FF7BAC - D4FF7AAACFF9BAD1E37D00000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000A8C8E4EDA7C9E4FF9EC2E1FF93BADDFF86B0D8FF80ACD5FF6C99C5FF6998 - CAFF6597CDFFBCD1E8C30000000000000000FDFDFD2EF3F3F3FFFFFFFFFF7E7D - 81FF70716EFF5C7E64FF699584FF8B838AFFCCCDCEFFFFFFFFFFB1B2B3FF0000 - 000000000000000000000000000000000000F9F9F9FFFDFFFFFFC78E49FFC88E - 48FFC78D45FFC58C44FFC48B45FFC38B46FFAED1F2FFA5C7E4FF96BCDEFF85B0 - D7FF7DAAD4FF6895C3FF5C96D3FFD4BCA0FFFFFFFFFF596A56FF28BD7DFF27B8 - 79FF26BB7CFF466428FFFFFFFFFFFFFFFFFF18A560FF27B97AFF27B777FF28B4 - 74FFB4AFB3FFFFFFFFFFDEDEDFFFE3E3E4FF0000000000000000000000000000 - 0000A8C8E4EDA7C9E4FF9EC2E1FF93BADDFF86B0D8FF80ACD5FF6C99C5FF6998 - CAFF6597CDFFBCD1E8C30000000000000000FDFDFD2EF3F3F3FFFFFFFFFF7E7D - 81FF70716EFF5C7E64FF699584FF8B838AFFCCCDCEFFFFFFFFFFB1B2B3FF0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000D3E3EF50739FC1F876A6CBFF7BADD3FF80B3DBFF83B7E0FF84B8E2FF82B6 - DFFF7EB1D8FF83B0D3EBF2F7FB18000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000AFCDE6FFA7C9E4FF9EC2E1FF93BADDFF85B0D8FF80ACD5FF7BA8D3FF6E9B - C9FF6597CDFF0000000000000000000000000000000000000000F6F6F687E0E0 - E0FFF7F7F7FFFFFFFFFFFDFDFDFFE6E6E6FFC2C3C4FFFEFEFE03000000000000 - 000000000000000000000000000000000000FBFBFBFFFCFFFFFFD09C60FFCE98 - 5DFFCA9355FFC98F48FFC88E45FFCA8A3DFFB2CEE7FFA5C7E4FF96BCDEFF85B0 - D8FF7DAAD4FF76A4D1FF6494C5FFB5782EFFE8ECF2FFFFFFFFFF6B7070FF26A8 - 67FF26BB7CFF25BE80FF25C082FF25BF80FF26BC7CFF27B97AFF25B776FFA8A0 - A5FFFFFFFFFFA79D92FFE8E8E9FFE4E4E5FF0000000000000000000000000000 - 0000AFCDE6FFA7C9E4FF9EC2E1FF93BADDFF85B0D8FF80ACD5FF7BA8D3FF6E9B - C9FF6597CDFF0000000000000000000000000000000000000000F6F6F687E0E0 - E0FFF7F7F7FFFFFFFFFFFDFDFDFFE6E6E6FFC2C3C4FFFEFEFE03000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000F6F8 - FA0F8EADC5C478A6C9FF7FB0D6FF84B7DFFF89BEE7FF8BC1EAFF8CC2ECFF8BC0 - EAFF87BAE3FF82B4DAFFBFD8EB7E000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000A3C3 - E2FFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF76A4 - D1FF6593C1FF0000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FBFBFBFFFCFFFFFFD4A165FFD19D - 61FFCE995DFFCB9559FFC89155FFA4AEB3FFB2CEE7FFA5C7E4FF96BCDEFF85B0 - D8FF7DAAD4FF76A4D1FF1D252EFFBC7E34FFB4762EFFE4E2E2FFFFFFFFFFA6A6 - A8FF636D5FFF218842FF22C180FF21BF7CFF27B97BFF8D9493FFDBDBDCFFFFFF - FFFFA99077FF934A00FFE9E9EAFFE5E5E6FF000000000000000000000000A3C3 - E2FFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF76A4 - D1FF6593C1FF0000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000B9C1 - C66478A3C3FB7EADD0FF86B7DDFF8ABEE6FF8FC5EDFF91C7F0FF91C8F1FF90C6 - EFFF8CC0E8FF88BAE0FFA5C7E1B5F8FBFD0D0000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000BAD4 - EAFFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF76A4 - D1FF72A1D0FFF6F6F61700000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FBFBFBFFFCFFFFFFD09A53FFD5A1 - 5FFFD5A265FFD29E62FFD09B60FF9CC2E5FFB2CEE7FFA5C7E4FF96BCDEFF85B0 - D8FF7DAAD4FF76A4D1FF6F9ECEFF0F1112FFB57730FFB3742BFFB06E21FFE4E8 - ECFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFBFBFBFFC0C5CDFF9549 - 00FF954D00FF944B00FFEAEAEBFFE6E6E7FF000000000000000000000000BAD4 - EAFFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF76A4 - D1FF72A1D0FFF6F6F61700000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000EAECEE1F757B - 81BA7EAACDFF85B4D8FF8DBEE5FF92C4ECFF95C9F2FF96CBF5FF96CBF5FF96CA - F3FF92C5EDFF8EBFE6FF9CC1E0D0EDF4F9260000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000FEFEFE0AB8D2 - E9FFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF76A4 - D1FF71A0CEFF101011FFFEFEFE04000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FBFBFBFFFCFFFFFFD6A25FFFD5A0 - 5AFFD49F59FFD4A05DFFD49F5CFF9AC2E8FFB2CEE7FFA5C7E4FF96BCDEFF85B0 - D8FF7DAAD4FF79A8D6FF75A1CFFF121314FFB97B33FFB4752EFFB17228FFAF6E - 23FFAA671BFFAB6D2BFFB48758FFB28453FFA25F13FF9D560AFF995209FF964F - 05FF954D01FF954D00FFEBEBECFFE7E7E8FF0000000000000000FEFEFE0AB8D2 - E9FFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF76A4 - D1FF71A0CEFF101011FFFEFEFE04000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000BDBFC0565462 - 6CF183AFD1FF8BB9DEFF92C3E9FF96C8EFFF99CCF4FF9ACDF5FF9ACDF5FF99CC - F4FF96C8EFFF92C2E9FF9BC2E1D9E9F2F82F0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000E0ECF586B8D2 - E9FFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF76A4 - D1FF71A0CEFF435E79FF101011FF000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FBFBFBFFFDFFFFFFD39A4DFFD198 - 4CFFCE9448FFCC9248FFCB9047FF96BEE3FFB2CEE7FFA5C7E4FF96BCDEFF85B0 - D8FF7DAAD4FF7BABDAFF14161BFF131417FF4E3821FFB47630FFB1732BFFAF6F - 25FFAD6C21FFA9671DFFA6631AFFA25F16FFA15C12FF9F590EFF9B540AFF964F - 06FF944B02FF944C00FFECECEDFFE8E8E9FF0000000000000000E0ECF586B8D2 - E9FFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF76A4 - D1FF71A0CEFF435E79FF101011FF000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000696969BA434C - 52FF88B3D3FF90BDE0FF95C3E6FF9BCBF1FF9DCEF4FF9DCFF5FF9DCFF5FF9DCE - F4FF9ACBEFFF96C5E9FFA0C6E3D5EAF2F72B0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000C0D7EAC7B8D2 - E9FFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF76A4 - D1FF729CC8FF71A3D5FF111213FFF4F4F42A0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FBFBFBFFFDFFFFFFD2994CFFD096 - 4AFFCE9449FFCD9248FFCA8F46FFA2B2BAFFB2CEE7FFA5C7E4FF96BCDEFF85B0 - D8FF7DAAD4FF2A292BFF1A1D22FF131619FF2C231AFFB5772EFFB2732CFFAF6F - 28FFAD6C22FFAA691DFFA7641AFFA35F17FFA05C13FF9F590EFF9C560AFF9851 - 06FF964F03FF944C00FFECEDEDFFE8E8E9FF0000000000000000C0D7EAC7B8D2 - E9FFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF76A4 - D1FF729CC8FF71A3D5FF111213FFF4F4F42A0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000F7F7F80A3A3A3AF53334 - 35FF62798AFF677F92FF86ABC7FF9ECDF2FFA0CFF5FFA0CFF5FFA0CFF5FF9FCF - F4FF9CCBEFFF98C6E9FFA7C9E4CBEFF4F8210000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000C3D9EBC3B8D2 - E9FFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF76A4 - D1FF131317FF4E6E8EFF121315FF0B0C0DFF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FBFBFBFFFDFFFFFFD2994AFFD097 - 4AFFCE944AFFCC9248FFCB8F47FFC39C6CFF7E93ABFF8093A9FF92ADCCFF93B4 - D8FF7CAAD4FF4E5053FF1D2025FF14161AFF2E261EFFBF8544FFBC813FFFB87C - 34FFB5772FFFB07126FFAA681BFFA46015FFA05C13FF9E580FFF9D570BFF9A54 - 06FF964E00FF934B00FFEDEDEEFFE9E9E9FF0000000000000000C3D9EBC3B8D2 - E9FFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF76A4 - D1FF131317FF4E6E8EFF121315FF0B0C0DFF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000D3D3D438323232FF3232 - 32FF323232FF393939FF708A9DFFA2CFF2FFA3D1F4FFA3D1F4FFA3D1F4FFA3D0 - F4FFA0CDEFFF9CC7E9FFB0CEE6BAF7F9FB100000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000DFEBF487B8D2 - E9FFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF7AA9 - D8FF181B1FFF14161AFF131417FF0F1013FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FCFCFCFFFEFFFFFFCB9552FFCB95 - 52FFCA9350FFC9914DFFCC9149FF55483AFF45474BFF616265FF909193FF7B7C - 7EFF5C5F61FF393C40FF212429FF14171BFF93673BFFBA803AFFB87C38FFB478 - 34FFB1732EFFAD6F28FFAA6A1FFFA66417FFA46320FFA56324FFA15D11FF9D59 - 0FFF9E5A14FF9F5B16FFEDEDEEFFE9E9EAFF0000000000000000DFEBF487B8D2 - E9FFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF7AA9 - D8FF181B1FFF14161AFF131417FF0F1013FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000C7C8C946323232FF3232 - 32FF323232FF555555FF586671FFA0C9EAFFA6D2F4FFA6D2F4FFA6D2F4FFA5D0 - F2FFA2CDEEFF9EC7E7FFBAD1E39BFDFEFE020000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000F7FAFC28BAD4 - EAFFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF2C31 - 38FF191C21FF15171CFF131518FF121316FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FCFCFCFFFEFFFFFFC8914EFFC58E - 4AFFC38C48FFC28945FFC08741FFBD843FFF534C43FF535558FF606265FF5B5D - 60FF494B4FFF3A3C40FF1D1F24FF31271EFFAE6C30FFB97E42FFB97E42FFB67A - 3FFFB3763BFFB17237FFAD6E32FFAA6A2EFFA7672BFFA66528FFA56426FFA563 - 25FFA2601EFF9F5C16FFEDEEEFFFE9EAEAFF0000000000000000F7FAFC28BAD4 - EAFFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF2C31 - 38FF191C21FF15171CFF131518FF121316FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000D1D1D13A313131FF3030 - 30FF303030FF494949FF848586FF636F79FF6F8596FF708798FF60717EFF5663 - 6DFF5C6B76FF667988FFA1ACB599E1E4E62F0000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000ADCC - E6FFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF393B - 3FFF3A3C40FF15181DFF14161AFF131417FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FCFCFCFFFEFFFFFFCA9350FFC891 - 4DFFC58E4AFFC38C47FFC18944FFC08741FFBD843EFFBF833AFF7F6443FF4044 - 4BFF323840FF5A4431FFB37232FFB06F31FFAE6C30FFAC6A2FFFAA672DFFAD6C - 32FFB77C40FFB3763BFFB07236FFAE6F33FFAA6B2FFFA7672BFFA66528FFA564 - 27FFA56325FFA46223FFEDEEEFFFEAEAEAFF000000000000000000000000ADCC - E6FFAFCDE6FFA7C9E4FF9EC2E1FF93BADDFF86B1D8FF80ACD5FF7BA8D3FF393B - 3FFF3A3C40FF15181DFF14161AFF131417FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000EFEFF013313131FD2828 - 28FF262626FF262626FF676767FF7C7C7CFF565656FF333333FF373737FF4545 - 45FF4C4C4CFF4E4E4EFF434343FB5D5D5DC90000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000A4C1 - E3FF788A9FFF77899CFF8BA3BEFF98B6D8FF95B2D3FF82ACD5FF7DAAD6FF5051 - 54FF58595CFF171A1FFF14161BFF131417FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FCFCFCFFFDFFFFFFCA924EFFC890 - 4BFFC58D47FFC38A44FFC18841FFC0853EFFBE833BFFBB8039FFB97E35FFB77C - 32FFB6792FFFB4742DFFB06E2CFFAE6B2BFFAC682AFFAA6629FFA86327FFA55F - 26FFA35D25FFA15A24FF9F5A23FFAB692DFFAC6B2DFFA8672AFFA56326FFA462 - 23FFA36121FFA36020FFEDEEEFFFEAEAEAFF000000000000000000000000A4C1 - E3FF788A9FFF77899CFF8BA3BEFF98B6D8FF95B2D3FF82ACD5FF7DAAD6FF5051 - 54FF58595CFF171A1FFF14161BFF131417FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000006C6C6CB62A2A - 2AFF181818FF161616FF161616FF161616FF181818FF2C2C2CFF525252FF6565 - 65FF777777FF717171FF4D4D4DE2C6C7C84B0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000F4F4F434393B - 3FFF4B4D50FF747578FF919394FF848586FF8C8D8FFF5E5F61FF484849FF3C3E - 42FF414347FF191C21FF14171BFF0F1113FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FCFCFCFFFBFBFBFFFBFBFBFFFCFC - FCFFFCFCFCFFFCFCFCFFFDFDFDFFFDFDFDFFFDFDFDFFFDFDFDFFFEFEFEFFFEFE - FEFFFEFEFEFFFEFEFEFFFDFDFDFFFDFDFDFFFDFDFDFFFCFCFCFFFCFCFCFFFCFC - FCFFFBFBFBFFFBFBFBFFFBFBFBFFFAFAFAFFFAFAFAFFFAFAFAFFF8F8F9FFF5F5 - F6FFF3F3F3FFF0F0F0FFEDEDEEFFEAEAEAFF0000000000000000F4F4F434393B - 3FFF4B4D50FF747578FF919394FF848586FF8C8D8FFF5E5F61FF484849FF3C3E - 42FF414347FF191C21FF14171BFF0F1113FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000BCBCBD533F3F - 3FED262626FF171717FF101010FF111111FF2C2C2CFF4C4C4CFF656565FF7474 - 74FF6E6E6EFF515151ECC3C4C54EFAFBFB070000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000003537 - 3BFF494B4FFF595B5EFF686A6CFF717274FF747678FF6C6E71FF55575AFF3A3C - 40FF2B2E32FF181B20FF14161BFFC1C2C37E0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000EEEEEEFFEEEEEEFFEDEDEDFFEDEE - EEFFEDEEEEFFEDEDEDFFECEDEDFFEDEDEDFFECECEDFFECECECFFECECECFFECEC - ECFFEBEBEBFFEBEBEBFFEAEAEBFFEAEAEAFFEAEAEAFFE9E9E9FFE8E8E9FFE8E8 - E8FFE7E7E8FFE6E6E7FFE5E5E6FFE4E4E4FFE3E3E3FFE1E1E2FFDFDFE0FFDDDD - DEFFD9DADBFFD8D8D8FFD4D5D6FFD1D1D2FF0000000000000000000000003537 - 3BFF494B4FFF595B5EFF686A6CFF717274FF747678FF6C6E71FF55575AFF3A3C - 40FF2B2E32FF181B20FF14161BFFC1C2C37E0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000FDFDFD02C3C3 - C34B585858CF3A3A3AF5333333FF383838FF464646FF4E4E4EFF545454FD5E5E - 5EE58586869AE0E1E12800000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000424448FF505255FF5B5D60FF606164FF5C5D60FF515356FF424448FF383B - 3FFF212328FF101317FFD9D9DA4E000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000424448FF505255FF5B5D60FF606164FF5C5D60FF515356FF424448FF383B - 3FFF212328FF101317FFD9D9DA4E000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000E1E1E125BCBCBC537F7F7F9F676767BC5A5A5ACD6E6E6EB49C9C9C7BCECF - CF3FF9F9FA070000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000005B5D60F44E5053FF4C4E51FF44464AFF393B3FFF292B - 30FFD8D8D9520000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000005B5D60F44E5053FF4C4E51FF44464AFF393B3FFF292B - 30FFD8D8D9520000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000424D3E000000000000003E000000 - 2800000080000000800000000100010000000000000800000000000000000000 - 000000000000000000000000FFFFFF0000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000080000001FF00FFFFFE00FFFFFF0003FF - 00000000F0001FFFF0001FFFF00000FF00000000E0000FFFC0000FFFE000007F - 0000000080000FFF80000FFF8000003F0000000000000FFF00000FFF0000001F - 0000000000000FFF00000FFF0000001F0000000000000FFF00000FFF0000000F - 0000000000000007000010070000000700000000800000010000000180000001 - 0000000080000000800000018000000000000000800000008000000180000000 - 00000000C0000000C0000001C000000000000000E0000000E0000001E0000000 - 00000000F8000001F0000001F800000100000000F0060001E0060001F0000001 - 00000000E00F0001E00E0003E008000100000000C00F0003C00F0003C00C0003 - 00000000C00F8007C01F8007C00E000700000000C00FC01FC00FC003C00FC01F - 00000000C007C07F80078061C007C07F000000008003807F800780708003807F - 000000008003007F800300F98003007F000000008003007F8003007F8003007F - 00000000C003003F8003003FC003003F00000000C003003F8003003FC003003F - 00000000C003001FC003003FC003001F00000000C003001F8003001FC003001F - 00000000C003001FC007001FC003001F00000000E00F001FE00F001FE00F001F - 00000001FC3F001FF83F003FFC3F001F00000003FFFF803FFFFF003FFFFF803F - 00000007FFFFC0FFFFFFC0FFFFFFC0FFFFFFFFFFFFFFFFFFFFF007FFFFFF3FFF - FFFFFFFFFFFC3FFFFF0001FFFFEE1FFFFFFFF87FFFE007FFFC0000FFFFC20FFF - FFFFE01FFF0001FFF800007FFF0007FFFFFF8007FE00007FF000007FFC0001FF - FFFF0003F800003FE000007FFC0000FFFFFE0001F000001FE00000FFFC00007F - 00000000F000000FE00000FFFC00003F00000000E0000007F00000FFFC00003F - 00000000C0000003F00000FFFC00003F00000000C0000003F00000FFFC00003F - 0000000080000003F80001FFFC00003F0000000080000001F80001FFFC00003F - 0000000080000001FC0000FFFC00003F0000000080000001FF00107FFE00003F - 0000000080000001FE00783FFE00003F0000000080000001FE00FC1FFE00003F - 0000000080000001FC00FE0FFE00003F0000000080000001F800FF07FE00003F - 0000000080000001F800FF8FFE00003F0000000080000001F8007FDFFE00003F - 0000000080000003F8003FFFFE00003F00000000C0000003F8003FFFFE00003F - 00000000C0000003F8003FFFFE00003F00000000E0000007F8003FFFFE00003F - 00000000E000000FF8001FFFFE00003F00000000F000001FF8001FFFFE00003F - 00000000F800003FF8001FFFFE00003F00000000FE00007FF8003FFFFE00003F - 00000000FF8001FFF8003FFFFF00003FFFFFFFFFFFE007FFFC007FFFFFFC003F - FFFFFFFFFFFFFFFFFF01FFFFFFFFF03FF80000FFFF80207FFFFFFFFFFF80207F - E000001FFC00001FFFFFFFFFFC00001FC0000007F000000FFFFFF87FF000000F - 80000003C0000007FFFFE01FC00000078000000180000003FFFF800780000003 - 8000000180000003FFFF0003800000038000000180000001FFFE000180000001 - 80000001800000010000000080000001C0000001800000010000000080000001 - E0000001800000010000000080000001F0000003C000000100000000C0000001 - F800000FC000000100000000C0000001FC00001FE000000300000000E0000003 - FC00003FF000000300000000F0000003FF00007FF800000700000000F8000007 - FF8001FFF800000F00000000F800000FFFF003FFF003001F00000000F003001F - FFF001FFF007C03F00000000F007C03FFFE001FFE007FFFF00000000E007FFFF - FFE000FFE003FFFF00000000E003FFFFFFC000FFC001FFFF00000000C001FFFF - FFC000FFC001FFFF00000000C001FFFFFFC000FFC000FFFF00000000C000FFFF - FF8000FFC000FFFF00000000C000FFFFFF8000FFC000FFFF00000000C000FFFF - FF8000FFC000FFFF00000000C000FFFFFF8000FFE000FFFF00000000E000FFFF - FF8000FFE000FFFF00000000E000FFFFFFC000FFC000FFFF00000000C000FFFF - FFC000FFE000FFFF00000000E000FFFFFFC003FFF001FFFFFFFFFFFFF001FFFF - FFF007FFFC07FFFFFFFFFFFFFC07FFFF00000000000000000000000000000000 - 000000000000} - end - object OpenPictureDialog1: TOpenPictureDialog - Left = 40 - Top = 104 - end - object SaveDialog1: TSaveDialog - DefaultExt = 'xml' - Filter = 'XML Files|*.xml' - Left = 152 - Top = 104 - end - object OpenDialog1: TOpenDialog - DefaultExt = 'xml' - Filter = 'XML Files|*.xml' - Left = 40 - Top = 172 - end -end diff --git a/demos/contacts_demo/main.pas b/demos/contacts_demo/main.pas deleted file mode 100644 index 3e890f6..0000000 --- a/demos/contacts_demo/main.pas +++ /dev/null @@ -1,451 +0,0 @@ -unit main; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, GoogleLogin, StdCtrls, GHelper,GContacts,Generics.Collections,NativeXml, - ExtCtrls, ComCtrls, ToolWin, Menus, ImgList,JPEG, ExtDlgs,TypInfo; - -type - TForm3 = class(TForm) - MainMenu1: TMainMenu; - N1: TMenuItem; - StatusBar1: TStatusBar; - ToolBar1: TToolBar; - ToolButton1: TToolButton; - ToolButton2: TToolButton; - Panel1: TPanel; - Splitter1: TSplitter; - Label5: TLabel; - ComboBox1: TComboBox; - GroupBox1: TGroupBox; - ListBox1: TListBox; - ImageList1: TImageList; - Panel2: TPanel; - Label1: TLabel; - Label2: TLabel; - Label3: TLabel; - Label4: TLabel; - Label6: TLabel; - ComboBox2: TComboBox; - Label7: TLabel; - Label8: TLabel; - ComboBox3: TComboBox; - Label9: TLabel; - Label10: TLabel; - ListBox2: TListBox; - Label11: TLabel; - ComboBox4: TComboBox; - Label12: TLabel; - ComboBox5: TComboBox; - Label13: TLabel; - Label14: TLabel; - ComboBox6: TComboBox; - Label15: TLabel; - ComboBox7: TComboBox; - Image1: TImage; - Label17: TLabel; - Label18: TLabel; - Label19: TLabel; - ToolButton3: TToolButton; - OpenPictureDialog1: TOpenPictureDialog; - ToolButton4: TToolButton; - ToolButton5: TToolButton; - ToolButton6: TToolButton; - ToolButton7: TToolButton; - ToolButton8: TToolButton; - ToolButton9: TToolButton; - SaveDialog1: TSaveDialog; - OpenDialog1: TOpenDialog; - Label16: TLabel; - Label20: TLabel; - ToolButton10: TToolButton; - ToolButton11: TToolButton; - ToolButton12: TToolButton; - procedure ComboBox1Change(Sender: TObject); - procedure ToolButton1Click(Sender: TObject); - procedure ToolButton2Click(Sender: TObject); - procedure ListBox1Click(Sender: TObject); - procedure ComboBox2Change(Sender: TObject); - procedure ComboBox3Change(Sender: TObject); - procedure ComboBox4Change(Sender: TObject); - procedure ComboBox5Change(Sender: TObject); - procedure ComboBox6Change(Sender: TObject); - procedure ComboBox7Change(Sender: TObject); - procedure ToolButton3Click(Sender: TObject); - procedure ToolButton4Click(Sender: TObject); - procedure ToolButton8Click(Sender: TObject); - procedure ToolButton9Click(Sender: TObject); - procedure ToolButton7Click(Sender: TObject); - procedure ToolButton6Click(Sender: TObject); - procedure ToolButton5Click(Sender: TObject); - procedure ToolButton10Click(Sender: TObject); - procedure ToolButton11Click(Sender: TObject); - procedure ToolButton12Click(Sender: TObject); - private - //TOnRetriveXML - procedure RetriveXML (const FromURL:string); - //TOnBeginParse - procedure BeginParse (const What: TParseElement; Total, Number: integer); - //OnEndParse - procedure EndParse(const What: TParseElement; Element: TObject); - //OnReadData - procedure ReadData(const TotalBytes:int64; ReadBytes: int64); - public - procedure RetriveMyContacts; - end; - -var - Form3: TForm3; - Contact: TGoogleContact; - Loginer: TGoogleLogin; - GmailContact: string; - List:TList; - Selected: TContact; - -implementation - -uses Profile, uLog, uQueryForm, uUpdate, NewContact; - -{$R *.dfm} - -procedure TForm3.BeginParse(const What: TParseElement; Total, Number: integer); -begin - case What of - T_Contact: fLog.Memo1.Lines.Add('Парсим контакт №'+IntToStr(Number)+' всего контактов '+IntToStr(Total)); - T_Group: fLog.Memo1.Lines.Add('Парсим группу №'+IntToStr(Number)+' всего групп '+IntToStr(Total)); - end; -end; - -procedure TForm3.ComboBox1Change(Sender: TObject); -var i:integer; -begin - if ComboBox1.ItemIndex>0 then - begin - ListBox1.Items.Clear; - List:=TList.Create; - List:=Contact.ContactsByGroup[ComboBox1.Items[ComboBox1.ItemIndex]]; - for i:=0 to List.Count - 1 do - begin - if List[i].TagTitle.Value='' then - if List[i].PrimaryEmail<>'' then - ListBox1.Items.Add(List[i].PrimaryEmail) - else - ListBox1.Items.Add('NoName Contact') - else - ListBox1.Items.Add(List[i].ContactName) - end; - end - else - begin - ListBox1.Items.Clear; - for i:=0 to Contact.Contacts.Count - 1 do - begin - if Contact.Contacts[i].TagTitle.Value='' then - if Contact.Contacts[i].PrimaryEmail<>'' then - ListBox1.Items.Add(Contact.Contacts[i].PrimaryEmail) - else - ListBox1.Items.Add('NoName Contact') - else - ListBox1.Items.Add(Contact.Contacts[i].TagTitle.Value) - end; - end; - -end; - -procedure TForm3.ComboBox2Change(Sender: TObject); -begin - Label7.Caption:=Selected.Emails[ComboBox2.ItemIndex].RelToString; -end; - -procedure TForm3.ComboBox3Change(Sender: TObject); -begin - Label9.Caption:=Selected.Phones[ComboBox3.ItemIndex].RelToString -end; - -procedure TForm3.ComboBox4Change(Sender: TObject); -begin - label17.Caption:=Selected.WebSites[ComboBox4.ItemIndex].RelToString; -end; - -procedure TForm3.ComboBox5Change(Sender: TObject); -begin - label13.Caption:=Selected.Relations[ComboBox5.ItemIndex].RelToString; -end; - -procedure TForm3.ComboBox6Change(Sender: TObject); -begin - Label18.Caption:=Selected.IMs[ComboBox6.ItemIndex].ImProtocolToString; -end; - -procedure TForm3.ComboBox7Change(Sender: TObject); -begin - label19.Caption:=Selected.UserFields[ComboBox7.ItemIndex].Value -end; - -procedure TForm3.EndParse(const What: TParseElement; Element: TObject); -begin - case What of - T_Group: fLog.Memo1.Lines.Add('Получена группа '+ (Element as TContactGroup).Title); - T_Contact:fLog.Memo1.Lines.Add('Получен контакт '+ (Element as TContact).ContactName); - end; -end; - -procedure TForm3.ListBox1Click(Sender: TObject); -var i:integer; -begin -try - Selected:=TContact.Create(); - if ComboBox1.ItemIndex=0 then - Selected:=Contact.Contacts[ListBox1.ItemIndex] - else - Selected:=Contact.ContactByGroupIndex[ComboBox1.Items[ComboBox1.ItemIndex],ListBox1.ItemIndex]; - - - Image1.Picture.Assign(Contact.RetriveContactPhoto(Selected, - ExtractFilePath(Application.ExeName)+'noimage.jpg')); - label2.Caption:=Selected.TagName.FullNameString; - label4.Caption:=Selected.TagOrganization.OrgName.Value+' ' - +Selected.TagOrganization.OrgTitle.Value; - Label20.Caption:=Selected.TagBirthDay.ServerDate; - - ComboBox2.Items.Clear; - for I := 0 to Selected.Emails.Count-1 do - ComboBox2.Items.Add(Selected.Emails[i].Address); - if ComboBox2.Items.Count>0 then - begin - ComboBox2.ItemIndex:=0; - ComboBox2Change(self); - end - else - Label7.Caption:='---'; - - ComboBox3.Items.Clear; - for I := 0 to Selected.Phones.Count - 1 do - ComboBox3.Items.Add(Selected.Phones[i].Text); - if ComboBox3.Items.Count>0 then - begin - ComboBox3.ItemIndex:=0; - ComboBox3Change(self); - end - else - Label9.Caption:='---'; - - ComboBox4.Items.Clear; - for I := 0 to Selected.WebSites.Count - 1 do - ComboBox4.Items.Add(Selected.WebSites[i].Href); - if ComboBox4.Items.Count>0 then - begin - ComboBox4.ItemIndex:=0; - ComboBox4Change(self); - end - else - label17.Caption:='---'; - - ComboBox5.Items.Clear; - for I := 0 to Selected.Relations.Count - 1 do - ComboBox5.Items.Add(Selected.Relations[i].Value); - - if ComboBox5.Items.Count>0 then - begin - ComboBox5.ItemIndex:=0; - ComboBox5Change(self); - end - else - label13.Caption:='---'; - - ComboBox6.Items.Clear; - for I := 0 to Selected.IMs.Count - 1 do - ComboBox6.Items.Add(Selected.IMs[i].Address); - if ComboBox6.Items.Count>0 then - begin - ComboBox6.ItemIndex:=0; - ComboBox6Change(self); - end - else - Label18.Caption:='---'; - - ComboBox7.Items.Clear; - for I := 0 to Selected.UserFields.Count - 1 do - ComboBox7.Items.Add(Selected.UserFields[i].Key); - if ComboBox7.Items.Count>0 then - begin - ComboBox7.ItemIndex:=0; - ComboBox7Change(self); - end - else - label19.Caption:='---'; - - ListBox2.Items.Clear; - for I := 0 to Selected.PostalAddreses.Count - 1 do - ListBox2.Items.Add(Selected.PostalAddreses[i].FormattedAddress.Value) - -except - -end; -end; - -procedure TForm3.ReadData(const TotalBytes:int64; ReadBytes: int64); -begin - fLog.Memo1.Lines.Add('Прочитано '+IntToStr(ReadBytes)+' из '+IntToStr(TotalBytes)) -end; - -procedure TForm3.RetriveMyContacts; -var iCounterPerSec: TLargeInteger; - T1, T2: TLargeInteger; //значение счётчика ДО и ПОСЛЕ операции -begin -// if Loginer.LastResult=lrOk then -// begin - //затачиваем события - Contact.OnRetriveXML:=RetriveXML; - Contact.OnBeginParse:=BeginParse; - Contact.OnEndParse:=EndParse; - Contact.OnReadData:=ReadData; - fLog.Show; - //засекаем время - QueryPerformanceFrequency(iCounterPerSec); - QueryPerformanceCounter(T1); - StatusBar1.Panels[1].Text:=IntToStr(Contact.RetriveGroups); - StatusBar1.Panels[3].Text:=IntToStr(Contact.RetriveContacts); - //показываем затраченное на загрузку время - QueryPerformanceCounter(T2); - StatusBar1.Panels[5].Text:=(FormatFloat('0.0000', (T2 - T1) / iCounterPerSec) + ' сек.'); - - - ListBox1.Items.Clear; - ListBox1.Items.Assign(Contact.ContactsNames); - - ComboBox1.Items.Assign(Contact.GroupsNames); - ComboBox1.Items.Insert(0,'Все'); - ComboBox1.ItemIndex:=0; - - - Form3.ToolButton3.Enabled:=true; - Form3.ToolButton4.Enabled:=true; - Form3.ToolButton5.Enabled:=true; - Form3.ToolButton6.Enabled:=true; - Form3.ToolButton7.Enabled:=true; - Form3.ToolButton8.Enabled:=true; - Form3.ToolButton9.Enabled:=true; - Form3.ToolButton10.Enabled:=true; - Form3.ToolButton11.Enabled:=true; - Form3.ToolButton12.Enabled:=true; - // end; -end; - -procedure TForm3.RetriveXML(const FromURL: string); -begin - fLog.Memo1.Lines.Add('Получаем данные с URL '+FromURL) -end; - -procedure TForm3.ToolButton10Click(Sender: TObject); -var S: string; -begin - if InputQuery('Введите название группы','Название группы',S) then - if Contact.AddContactGroup(S,Contact.Gmail) then - begin - ComboBox1.Clear; - ComboBox1.Items.Assign(Contact.GroupsNames); - ComboBox1.Items.Insert(0,'Все'); - end; -end; - -procedure TForm3.ToolButton11Click(Sender: TObject); -var S:string; -begin - if ComboBox1.ItemIndex>0 then - begin - if InputQuery('Новое название группы','Новое название',S) then - begin - Contact.Groups[ComboBox1.ItemIndex-1].Title:=S; - Contact.UpdateContactGroup(ComboBox1.ItemIndex-1); - ComboBox1.Items.Assign(Contact.GroupsNames); - ComboBox1.Items.Insert(0,'Все'); - end; - end; -end; - -procedure TForm3.ToolButton12Click(Sender: TObject); -begin - if ComboBox1.ItemIndex>0 then - begin - if Contact.DeleteContactGroup(Contact.Groups[ComboBox1.ItemIndex-1])then - begin - ComboBox1.Items.Assign(Contact.GroupsNames); - ComboBox1.Items.Insert(0,'Все'); - end - else - ShowMessage('Группа НЕ удалена'); - end; -end; - -procedure TForm3.ToolButton1Click(Sender: TObject); -begin - ProfileForm.Show; -end; - -procedure TForm3.ToolButton2Click(Sender: TObject); -begin - fQuery.ShowModal; -end; - -procedure TForm3.ToolButton3Click(Sender: TObject); -begin - if OpenPictureDialog1.Execute then - Contact.UpdatePhoto(ListBox1.ItemIndex,OpenPictureDialog1.FileName); -end; - -procedure TForm3.ToolButton4Click(Sender: TObject); -begin - Contact.DeletePhoto(ListBox1.ItemIndex); -end; - -procedure TForm3.ToolButton5Click(Sender: TObject); -begin - if Contact.DeleteContact(ListBox1.ItemIndex) then - begin - ShowMessage('Контакт удален. Контактов осталось '+IntToStr(Contact.Contacts.Count)); - ListBox1.Items.Delete(ListBox1.ItemIndex); - end - else - ShowMessage('Удаление контакта не удалось'); -end; - -procedure TForm3.ToolButton6Click(Sender: TObject); -begin -fNewContact.Show -end; - -procedure TForm3.ToolButton7Click(Sender: TObject); -begin - fUpdateContact.Edit1.Text:=Selected.TagName.FamilyName.Value; - fUpdateContact.Edit2.Text:=Selected.TagName.GivenName.Value; - fUpdateContact.Edit3.Text:=Selected.TagName.AdditionalName.Value; - fUpdateContact.Edit4.Text:=Selected.PrimaryEmail; - fUpdateContact.DateTimePicker1.Date:=Selected.TagBirthDay.Date; - fUpdateContact.ShowModal; -end; - -procedure TForm3.ToolButton8Click(Sender: TObject); -begin - if SaveDialog1.Execute then - Contact.SaveContactsToFile(SaveDialog1.FileName); -end; - -procedure TForm3.ToolButton9Click(Sender: TObject); -var i:integer; -begin - if OpenDialog1.Execute then - if Length(OpenDialog1.FileName)>0 then - begin - Contact:=TGoogleContact.Create(self); - Contact.LoadContactsFromFile(OpenDialog1.FileName); - for I := 0 to Contact.Contacts.Count - 1 do - ListBox1.Items.Add(Contact.Contacts[i].ContactName); - ComboBox1.Items.Add('Все'); - ComboBox1.ItemIndex:=0; - end; -end; - -end. diff --git a/demos/contacts_demo/noimage.jpg b/demos/contacts_demo/noimage.jpg deleted file mode 100644 index fcbb65a..0000000 Binary files a/demos/contacts_demo/noimage.jpg and /dev/null differ diff --git a/demos/contacts_demo/photo.jpg b/demos/contacts_demo/photo.jpg deleted file mode 100644 index 4e0cd68..0000000 Binary files a/demos/contacts_demo/photo.jpg and /dev/null differ diff --git a/demos/contacts_demo/uLog.dfm b/demos/contacts_demo/uLog.dfm deleted file mode 100644 index 95f64c8..0000000 --- a/demos/contacts_demo/uLog.dfm +++ /dev/null @@ -1,28 +0,0 @@ -object fLog: TfLog - Left = 0 - Top = 0 - Caption = 'Log' - ClientHeight = 250 - ClientWidth = 432 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - Position = poMainFormCenter - OnShow = FormShow - PixelsPerInch = 96 - TextHeight = 13 - object Memo1: TMemo - Left = 0 - Top = 0 - Width = 432 - Height = 250 - Align = alClient - Lines.Strings = ( - 'Memo1') - TabOrder = 0 - end -end diff --git a/demos/contacts_demo/uLog.pas b/demos/contacts_demo/uLog.pas deleted file mode 100644 index 4881698..0000000 --- a/demos/contacts_demo/uLog.pas +++ /dev/null @@ -1,31 +0,0 @@ -unit uLog; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls; - -type - TfLog = class(TForm) - Memo1: TMemo; - procedure FormShow(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - fLog: TfLog; - -implementation - -{$R *.dfm} - -procedure TfLog.FormShow(Sender: TObject); -begin - Memo1.Clear; -end; - -end. diff --git a/demos/contacts_demo/uQueryForm.dfm b/demos/contacts_demo/uQueryForm.dfm deleted file mode 100644 index 8151ce1..0000000 --- a/demos/contacts_demo/uQueryForm.dfm +++ /dev/null @@ -1,128 +0,0 @@ -object fQuery: TfQuery - Left = 0 - Top = 0 - Caption = #1055#1072#1088#1072#1084#1077#1090#1088#1099' '#1079#1072#1075#1088#1091#1079#1082#1080' '#1082#1086#1085#1090#1072#1082#1090#1086#1074 - ClientHeight = 175 - ClientWidth = 338 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - Position = poMainFormCenter - OnHide = FormHide - PixelsPerInch = 96 - TextHeight = 13 - object Label1: TLabel - Left = 8 - Top = 13 - Width = 218 - Height = 13 - Caption = #1050#1086#1083#1080#1095#1077#1089#1090#1074#1086' '#1082#1086#1085#1090#1072#1082#1090#1086#1074' '#1074' '#1086#1076#1085#1086#1084' '#1076#1086#1082#1091#1084#1077#1085#1090#1077 - end - object Label2: TLabel - Left = 8 - Top = 36 - Width = 214 - Height = 13 - Caption = #1048#1085#1076#1077#1082#1089' '#1087#1077#1088#1074#1086#1075#1086' '#1074#1086#1079#1074#1088#1072#1097#1072#1077#1084#1086#1075#1086' '#1082#1086#1085#1090#1072#1082#1090#1072 - end - object Label4: TLabel - Left = 8 - Top = 78 - Width = 57 - Height = 13 - Caption = #1085#1077' '#1087#1086#1079#1076#1085#1077#1077 - end - object Label5: TLabel - Left = 8 - Top = 101 - Width = 163 - Height = 13 - Caption = #1055#1086#1088#1103#1076#1086#1082' '#1089#1086#1088#1090#1080#1088#1086#1074#1082#1072' '#1082#1086#1085#1090#1072#1082#1090#1086#1074 - end - object Edit1: TEdit - Left = 248 - Top = 9 - Width = 37 - Height = 21 - TabOrder = 0 - Text = '0' - end - object UpDown1: TUpDown - Left = 285 - Top = 9 - Width = 16 - Height = 21 - Associate = Edit1 - Max = 10000 - TabOrder = 1 - end - object Edit2: TEdit - Left = 248 - Top = 32 - Width = 37 - Height = 21 - TabOrder = 2 - Text = '1' - end - object UpDown2: TUpDown - Left = 285 - Top = 32 - Width = 16 - Height = 21 - Associate = Edit2 - Min = 1 - Position = 1 - TabOrder = 3 - end - object DateTimePicker1: TDateTimePicker - Left = 71 - Top = 74 - Width = 82 - Height = 21 - Date = 40363.856958194450000000 - Time = 40363.856958194450000000 - TabOrder = 4 - end - object ComboBox1: TComboBox - Left = 177 - Top = 97 - Width = 140 - Height = 21 - Style = csDropDownList - ItemIndex = 0 - TabOrder = 5 - Text = #1055#1086' '#1074#1086#1079#1088#1072#1089#1090#1072#1085#1080#1102 - Items.Strings = ( - #1055#1086' '#1074#1086#1079#1088#1072#1089#1090#1072#1085#1080#1102 - #1055#1086' '#1091#1073#1099#1074#1072#1085#1080#1102) - end - object Button1: TButton - Left = 128 - Top = 147 - Width = 75 - Height = 25 - Caption = #1055#1088#1080#1085#1103#1090#1100 - TabOrder = 6 - OnClick = Button1Click - end - object CheckBox1: TCheckBox - Left = 8 - Top = 124 - Width = 306 - Height = 17 - Caption = #1055#1086#1082#1072#1079#1099#1074#1072#1090#1100' '#1091#1076#1072#1083#1077#1085#1085#1099#1077' '#1082#1086#1085#1090#1072#1082#1090#1099 - TabOrder = 7 - end - object CheckBox2: TCheckBox - Left = 8 - Top = 55 - Width = 329 - Height = 17 - Caption = #1047#1072#1075#1088#1091#1078#1072#1090#1100' '#1090#1086#1083#1100#1082#1086' '#1090#1077' '#1082#1086#1085#1090#1072#1082#1090#1099' '#1091' '#1082#1086#1090#1086#1088#1099#1093' '#1076#1072#1090#1072' '#1086#1073#1085#1086#1074#1083#1077#1085#1080#1103 - TabOrder = 8 - end -end diff --git a/demos/contacts_demo/uQueryForm.pas b/demos/contacts_demo/uQueryForm.pas deleted file mode 100644 index d5f2593..0000000 --- a/demos/contacts_demo/uQueryForm.pas +++ /dev/null @@ -1,58 +0,0 @@ -unit uQueryForm; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, ComCtrls, StdCtrls, main,GContacts; - -type - TfQuery = class(TForm) - Label1: TLabel; - Edit1: TEdit; - UpDown1: TUpDown; - Label2: TLabel; - Edit2: TEdit; - UpDown2: TUpDown; - Label4: TLabel; - DateTimePicker1: TDateTimePicker; - Label5: TLabel; - ComboBox1: TComboBox; - Button1: TButton; - CheckBox1: TCheckBox; - CheckBox2: TCheckBox; - procedure Button1Click(Sender: TObject); - procedure FormHide(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - fQuery: TfQuery; - -implementation - -{$R *.dfm} - -procedure TfQuery.Button1Click(Sender: TObject); -begin - Contact.MaximumResults:=StrToIntDef(Edit1.Text,0); - Contact.StartIndex:=StrToIntDef(Edit2.Text,0); - if CheckBox2.Checked then - Contact.UpdatesMin:=DateTimePicker1.DateTime; - Contact.SortOrder:=TSortOrder(ComboBox1.ItemIndex); - Contact.ShowDeleted:=CheckBox1.Checked; - Contact.Contacts.Clear; - ModalResult:=mrOk; - Hide; -end; - -procedure TfQuery.FormHide(Sender: TObject); -begin - - Form3.RetriveMyContacts; -end; - -end. diff --git a/demos/contacts_demo/uUpdate.dfm b/demos/contacts_demo/uUpdate.dfm deleted file mode 100644 index f18e619..0000000 --- a/demos/contacts_demo/uUpdate.dfm +++ /dev/null @@ -1,102 +0,0 @@ -object fUpdateContact: TfUpdateContact - Left = 0 - Top = 0 - Caption = #1056#1077#1076#1072#1082#1090#1080#1088#1086#1074#1072#1085#1080#1077' '#1082#1086#1085#1090#1072#1082#1090#1072 - ClientHeight = 160 - ClientWidth = 219 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - Position = poMainFormCenter - PixelsPerInch = 96 - TextHeight = 13 - object Label2: TLabel - Left = 40 - Top = 7 - Width = 44 - Height = 13 - Caption = #1060#1072#1084#1080#1083#1080#1103 - end - object Label3: TLabel - Left = 65 - Top = 33 - Width = 19 - Height = 13 - Caption = #1048#1084#1103 - end - object Label4: TLabel - Left = 35 - Top = 58 - Width = 49 - Height = 13 - Caption = #1054#1090#1095#1077#1089#1090#1074#1086 - end - object Label1: TLabel - Left = 8 - Top = 83 - Width = 76 - Height = 13 - Caption = #1054#1089#1085#1086#1074#1085#1086#1081' Email' - end - object Label5: TLabel - Left = 8 - Top = 108 - Width = 80 - Height = 13 - Caption = #1044#1077#1085#1100' '#1088#1086#1078#1076#1077#1085#1080#1103 - end - object Edit1: TEdit - Left = 90 - Top = 4 - Width = 121 - Height = 21 - TabOrder = 0 - Text = 'Edit1' - end - object Edit2: TEdit - Left = 90 - Top = 29 - Width = 121 - Height = 21 - TabOrder = 1 - Text = 'Edit2' - end - object Edit3: TEdit - Left = 90 - Top = 54 - Width = 121 - Height = 21 - TabOrder = 2 - Text = 'Edit3' - end - object Edit4: TEdit - Left = 90 - Top = 79 - Width = 121 - Height = 21 - TabOrder = 3 - Text = 'Edit4' - end - object Button1: TButton - Left = 73 - Top = 131 - Width = 75 - Height = 25 - Caption = #1055#1088#1080#1085#1103#1090#1100 - TabOrder = 4 - OnClick = Button1Click - end - object DateTimePicker1: TDateTimePicker - Left = 90 - Top = 104 - Width = 121 - Height = 21 - Date = 40365.742072534730000000 - Time = 40365.742072534730000000 - TabOrder = 5 - end -end diff --git a/demos/contacts_demo/uUpdate.pas b/demos/contacts_demo/uUpdate.pas deleted file mode 100644 index fb90efa..0000000 --- a/demos/contacts_demo/uUpdate.pas +++ /dev/null @@ -1,52 +0,0 @@ -unit uUpdate; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls,main, ComCtrls; - -type - TfUpdateContact = class(TForm) - Label2: TLabel; - Label3: TLabel; - Label4: TLabel; - Edit1: TEdit; - Edit2: TEdit; - Edit3: TEdit; - Label1: TLabel; - Edit4: TEdit; - Button1: TButton; - Label5: TLabel; - DateTimePicker1: TDateTimePicker; - procedure Button1Click(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - fUpdateContact: TfUpdateContact; - -implementation - -{$R *.dfm} - -procedure TfUpdateContact.Button1Click(Sender: TObject); -begin - Selected.TagName.FamilyName.Value:=Edit1.Text; - Selected.TagName.GivenName.Value:=Edit2.Text; - Selected.TagName.AdditionalName.Value:=Edit3.Text; - Selected.TagName.FullName.Value:=Edit1.Text+' '+Edit2.Text+' '+Edit3.Text; - Selected.PrimaryEmail:=Edit4.Text; - Selected.TagBirthDay.Date:=DateTimePicker1.DateTime; - Selected.TagBirthDay.ShotrFormat:=true; - Contact.UpdateContact(Selected); - ModalResult:=mrOk; - Form3.ListBox1.Items[Form3.ListBox1.ItemIndex]:=Selected.ContactName; - - Hide; -end; - -end. diff --git a/demos/feedburner_demo/feedburner.dpr b/demos/feedburner_demo/feedburner.dpr deleted file mode 100644 index d28edc1..0000000 --- a/demos/feedburner_demo/feedburner.dpr +++ /dev/null @@ -1,18 +0,0 @@ -program feedburner; - -uses - Forms, - main in 'main.pas' {Form6}, - NativeXml in '..\..\addons\nativexml\NativeXml.pas', - GFeedBurner in '..\..\source\GFeedBurner.pas', - uTimeLine in 'uTimeLine.pas' {fTimeLine}; - -{$R *.res} - -begin - Application.Initialize; - Application.MainFormOnTaskbar := True; - Application.CreateForm(TForm6, Form6); - Application.CreateForm(TfTimeLine, fTimeLine); - Application.Run; -end. diff --git a/demos/feedburner_demo/feedburner.dproj b/demos/feedburner_demo/feedburner.dproj deleted file mode 100644 index 793d9a7..0000000 --- a/demos/feedburner_demo/feedburner.dproj +++ /dev/null @@ -1,111 +0,0 @@ - - - {ADD34622-DD90-4EAA-BCFD-3E8B8A871EFF} - 12.0 - feedburner.dpr - Debug - DCC32 - - - true - - - true - Base - true - - - true - Base - true - - - WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias) - feedburner.exe - 00400000 - x86 - - - false - RELEASE;$(DCC_Define) - 0 - false - - - DEBUG;$(DCC_Define) - - - - MainSource - - -
Form6
- - - - -
fTimeLine
- - - Base - - - Cfg_2 - Base - - - Cfg_1 - Base - - - - - Delphi.Personality.12 - - - - - feedburner.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 - - - False - - 12 - - diff --git a/demos/feedburner_demo/feedburner.res b/demos/feedburner_demo/feedburner.res deleted file mode 100644 index fc1937e..0000000 Binary files a/demos/feedburner_demo/feedburner.res and /dev/null differ diff --git a/demos/feedburner_demo/main.dfm b/demos/feedburner_demo/main.dfm deleted file mode 100644 index 3857801..0000000 --- a/demos/feedburner_demo/main.dfm +++ /dev/null @@ -1,1041 +0,0 @@ -object Form6: TForm6 - Left = 0 - Top = 0 - Caption = 'Form6' - ClientHeight = 512 - ClientWidth = 721 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - OnShow = FormShow - PixelsPerInch = 96 - TextHeight = 13 - object Ribbon1: TRibbon - Left = 0 - Top = 0 - Width = 721 - Height = 143 - ActionManager = ActionManager1 - Caption = 'FeedBurner' - Tabs = < - item - Caption = 'FeedBurner' - Page = RibbonPage1 - end> - DesignSize = ( - 721 - 143) - StyleName = 'Ribbon - Luna' - object RibbonPage1: TRibbonPage - Left = 0 - Top = 50 - Width = 720 - Height = 93 - Caption = 'FeedBurner' - Index = 0 - object RibbonGroup1: TRibbonGroup - Left = 4 - Top = 3 - Width = 144 - Height = 86 - ActionManager = ActionManager1 - Caption = #1052#1077#1090#1086#1076' API' - GroupIndex = 0 - end - object RibbonGroup2: TRibbonGroup - Left = 150 - Top = 3 - Width = 158 - Height = 86 - ActionManager = ActionManager1 - Caption = #1055#1072#1088#1072#1084#1077#1090#1088#1099 - GroupIndex = 1 - object RibbonSpinEdit1: TRibbonSpinEdit - Left = 116 - Top = 46 - Width = 38 - Height = 22 - MaxValue = 10 - MinValue = 1 - TabOrder = 0 - Value = 1 - OnChange = RibbonSpinEdit1Change - end - end - object RibbonGroup3: TRibbonGroup - Left = 310 - Top = 3 - Width = 92 - Height = 86 - ActionManager = ActionManager1 - Caption = #1057#1073#1086#1088' '#1089#1090#1072#1090#1080#1089#1090#1080#1082#1080 - GroupIndex = 2 - end - end - end - object PageControl1: TPageControl - Left = 0 - Top = 143 - Width = 721 - Height = 369 - ActivePage = TabSheet1 - Align = alClient - TabOrder = 1 - TabPosition = tpBottom - object TabSheet1: TTabSheet - Caption = #1057#1090#1072#1090#1080#1089#1090#1080#1082#1072 - object Panel1: TPanel - Left = 0 - Top = 0 - Width = 713 - Height = 37 - Align = alTop - TabOrder = 0 - object CheckBox1: TCheckBox - Left = 6 - Top = 10 - Width = 87 - Height = 17 - Caption = #1055#1086#1076#1087#1080#1089#1095#1080#1082#1080 - Checked = True - State = cbChecked - TabOrder = 0 - end - object CheckBox2: TCheckBox - Left = 96 - Top = 10 - Width = 121 - Height = 17 - Caption = #1054#1093#1074#1072#1090' '#1072#1091#1076#1080#1090#1086#1088#1080#1080 - Checked = True - State = cbChecked - TabOrder = 1 - end - object CheckBox3: TCheckBox - Left = 214 - Top = 10 - Width = 127 - Height = 17 - Caption = #1050#1083#1080#1082#1080' '#1087#1086' '#1101#1083#1077#1084#1077#1085#1090#1072#1084 - Checked = True - State = cbChecked - TabOrder = 2 - end - object CheckBox4: TCheckBox - Left = 344 - Top = 10 - Width = 81 - Height = 17 - Caption = #1055#1088#1086#1089#1084#1086#1090#1088#1099 - Checked = True - State = cbChecked - TabOrder = 3 - end - end - object Chart1: TChart - Left = 0 - Top = 37 - Width = 713 - Height = 306 - Title.Text.Strings = ( - #1057#1090#1072#1090#1080#1089#1090#1080#1082#1072) - Zoom.Animated = True - Align = alClient - TabOrder = 1 - ColorPaletteIndex = 11 - object circulation_graph: TBarSeries - BarPen.Color = 13770496 - Marks.Arrow.Visible = True - Marks.Callout.Brush.Color = clBlack - Marks.Callout.Arrow.Visible = True - Marks.Callout.Length = 8 - Marks.DrawEvery = 3 - Marks.Style = smsValue - Marks.Visible = False - Title = #1055#1086#1076#1087#1080#1089#1095#1080#1082#1080 - Gradient.Direction = gdTopBottom - XValues.DateTime = True - XValues.Name = 'X' - XValues.Order = loAscending - YValues.Name = 'Bar' - YValues.Order = loNone - end - object reach_graph: TBarSeries - BarPen.Color = 66272 - Marks.Arrow.Visible = True - Marks.Callout.Brush.Color = clBlack - Marks.Callout.Arrow.Visible = True - Marks.Callout.Length = 8 - Marks.DrawEvery = 3 - Marks.Style = smsValue - Marks.Visible = False - Title = #1054#1093#1074#1072#1090' '#1072#1091#1076#1080#1090#1086#1088#1080#1080 - Gradient.Direction = gdTopBottom - XValues.DateTime = True - XValues.Name = 'X' - XValues.Order = loAscending - YValues.Name = 'Bar' - YValues.Order = loNone - end - object clicks_graph: TBarSeries - BarPen.Color = 157214 - Marks.Arrow.Visible = True - Marks.Callout.Brush.Color = clBlack - Marks.Callout.Arrow.Visible = True - Marks.Callout.Length = 8 - Marks.DrawEvery = 3 - Marks.Style = smsValue - Marks.Visible = False - Title = #1050#1083#1080#1082#1080' '#1087#1086' '#1101#1083#1077#1084#1077#1085#1090#1072#1084 - Gradient.Direction = gdTopBottom - XValues.DateTime = True - XValues.Name = 'X' - XValues.Order = loAscending - YValues.Name = 'Bar' - YValues.Order = loNone - end - object views_graph: TLineSeries - Marks.Arrow.Visible = True - Marks.Callout.Brush.Color = clBlack - Marks.Callout.Arrow.Visible = True - Marks.DrawEvery = 3 - Marks.Style = smsValue - Marks.Visible = False - Title = #1055#1088#1086#1089#1084#1086#1090#1088#1099 - LinePen.Color = 8310248 - Pointer.InflateMargins = True - Pointer.Style = psRectangle - Pointer.Visible = False - TreatNulls = tnIgnore - XValues.DateTime = True - XValues.Name = 'X' - XValues.Order = loAscending - YValues.Name = 'Y' - YValues.Order = loNone - end - end - end - object TabSheet2: TTabSheet - Caption = #1051#1086#1075 - ImageIndex = 1 - object Memo1: TMemo - Left = 0 - Top = 0 - Width = 713 - Height = 343 - Align = alClient - Lines.Strings = ( - 'Memo1') - TabOrder = 0 - end - end - end - object FeedBurner1: TFeedBurner - APIMethod = toGetFeedData - FeedURL = 'http://feeds.feedburner.com/myDelphi' - SilentAPI = True - MaxThreads = 10 - TimeLine = <> - OnAPIRequestError = FeedBurner1APIRequestError - OnThreadStart = FeedBurner1ThreadStart - OnThreadEnd = FeedBurner1ThreadEnd - OnDone = FeedBurner1Done - Left = 228 - Top = 378 - end - object ActionManager1: TActionManager - ActionBars = < - item - Items = < - item - Action = getfeeddata_act - Caption = '&GetFeedData' - CommandStyle = csRadioButton - CommandProperties.Width = -1 - end - item - Action = getitemdata_act - Caption = 'G&etItemData' - CommandStyle = csRadioButton - CommandProperties.Width = -1 - end - item - Action = GetResyndicationData_act - Caption = 'Ge&tResyndicationData' - CommandStyle = csRadioButton - CommandProperties.Width = -1 - end> - ActionBar = RibbonGroup1 - end - item - Items = < - item - Action = Action1 - ImageIndex = 0 - end - item - Action = silentapi_act - Caption = #1053#1077' '#1087#1086#1082#1072#1079#1099#1074#1072#1090#1100' '#1086#1096#1080#1073#1082#1080 - CommandStyle = csCheckBox - CommandProperties.Width = -1 - end - item - Caption = #1050#1086#1083#1080#1095#1077#1089#1090#1074#1086' '#1087#1086#1090#1086#1082#1086#1074 - CommandStyle = csControl - CommandProperties.Width = 150 - CommandProperties.ContainedControl = RibbonSpinEdit1 - CommandProperties.LabelWidth = 110 - end> - ActionBar = RibbonGroup2 - end - item - Items = < - item - Action = start_act - ImageIndex = 1 - CommandProperties.ButtonSize = bsLarge - end - item - Action = stop_act - ImageIndex = 2 - CommandProperties.ButtonSize = bsLarge - end> - ActionBar = RibbonGroup3 - end> - LargeImages = Images_32x32 - Images = Images_16x16 - Left = 322 - Top = 378 - StyleName = 'Ribbon - Luna' - object silentapi_act: TAction - Category = #1057#1082#1086#1088#1086#1089#1090#1100 - Caption = #1054#1073#1088#1072#1073#1086#1090#1082#1072' '#1086#1096#1080#1073#1086#1082 - OnExecute = silentapi_actExecute - end - object getfeeddata_act: TAction - Category = #1052#1077#1090#1086#1076 - Caption = 'GetFeedData' - GroupIndex = 1 - OnExecute = getfeeddata_actExecute - end - object getitemdata_act: TAction - Category = #1052#1077#1090#1086#1076 - Caption = 'GetItemData' - GroupIndex = 1 - OnExecute = getitemdata_actExecute - end - object GetResyndicationData_act: TAction - Category = #1052#1077#1090#1086#1076 - Caption = 'GetResyndicationData' - GroupIndex = 1 - OnExecute = GetResyndicationData_actExecute - end - object Action1: TAction - Caption = #1042#1088#1077#1084#1077#1085#1085#1086#1081' '#1080#1085#1090#1077#1088#1074#1072#1083 - ImageIndex = 0 - OnExecute = Action1Execute - end - object start_act: TAction - Category = #1057#1073#1086#1088' '#1089#1090#1072#1090#1080#1089#1090#1080#1082#1080 - Caption = #1055#1091#1089#1082 - ImageIndex = 1 - OnExecute = start_actExecute - end - object stop_act: TAction - Category = #1057#1073#1086#1088' '#1089#1090#1072#1090#1080#1089#1090#1080#1082#1080 - Caption = #1057#1090#1086#1087 - ImageIndex = 2 - OnExecute = stop_actExecute - end - end - object Images_16x16: TImageList - ColorDepth = cd32Bit - Left = 426 - Top = 376 - Bitmap = { - 494C010103002C00740010001000FFFFFFFF2110FFFFFFFFFFFFFFFF424D3600 - 0000000000003600000028000000400000001000000001002000000000000010 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000010303030406060607050505060404040502020203000000010000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000001414 - 1415202020232F2F2F38424242714545458F424242824141415F2626262D2020 - 2023040404050000000000000000000000000000000000000000000000000000 - 000002020203141414171717171A1717171A15151518131313150C0C0C0D0404 - 0405000000010000000000000000000000000000000000000000000000000000 - 000001010102070707080C0C0C0D0B0B0B0C0909090A06060607020202030000 - 0001000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000067676787FEFEFEFFFEFEFEFFF7F4F2FFFCFBFBFFFFFFFFFFC1C1C1E00808 - 0809000000000000000000000000000000000000000000000000000000000000 - 00000000000107070708161616192B2A2A351F1E1E241717171A1717171A1414 - 1416010101020000000000000000000000000000000000000000000000000000 - 000003030304151515181717171A1717171A1717171A1717171A141414160C0C - 0C0D030303040000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000001010102F5F5 - F5FCFEFCFAFFC49B50FFBFA262FFEAE1CAFFC5AA67FFB7904CFFEFDEB9FFFFFF - FFFF4A4A4A590000000000000000000000000000000000000000000000000000 - 00003C333143A92903FBDE7316FFF3AD2EFFF7C33BFFF3B232FFAF723CC30F0F - 0F10000000010000000000000000000000000000000000000000000000000000 - 0000000000012626282F3C3D44613D3E49663D3F48652D2E313C1717171A1717 - 171A0A0A0A0B0000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000F7F7F7FDEBD9 - BDFFAE9044FFD4CB5AFFE6E766FFEBEE69FFE9EB68FFDDD960FFBEAA4DFFB085 - 44FFFEFEFEFF3030303700000000000000000000000000000000000000008546 - 37AEC24507FFEC9028FFEE9715FFF4B015FFF8C217FFF9C618FFF7BD16FFEFA0 - 3AFF161716180000000000000000000000000000000000000000000000002B2B - 33380807AAFD0F28E9FF0E27EAFF0E27EAFF0E27EAFF0E27EAFF0E27EAFF3536 - 3F4B020202030000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000007F7F7FA3F6F2ECFF9D7C - 25FFC1B52CFFDCD878FFD9DB33FFDBDF34FFDADD34FFD5D432FFC8C12EFFB39D - 37FFBC955BFFF9F9F9FF0000000000000000000000000000000064493F73BE3E - 06FFEB8624FFEB8918FFEF9A1AFFF3AF1BFFF6BD1BFFF7BE19FFF4B21DFF3CE9 - A3FE46E898FF00000000000000000000000000000000000000003534434A0A0B - B7FF152FEBFF132DEBFF5063F0FF6370D9ED6871E2FD6877EFFF1830EAFF0E27 - EAFF424770750000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000F3F3F3FF97641EFFAE91 - 13FFBEA811FFC3AF16FFD3C651FFCDBE15FFCBBC14FFC7B513FFC1AC12FFB79D - 12FF976F17FFF3F3F3FF46464652000000000000000000000000B53000FEEC8F - 32FFEB8720FFEC8B1FFFEE981FFFF1A820FFF3B220FFF3B426FF5EECB5FE2DEC - A7FF2DE795FF38463E49000000000000000000000000000000000600ACFF1D37 - EDFF1B35EDFF3346C9D8030303040000000000000000413F62721315C0FF1830 - EAFF0E27EAFF19191B1C00000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000F0F0F10ECECECFF956312FFB389 - 08FFBA9107FFBD9507FFD0B55AFFC7A633FFC19B08FFBE9708FFBB9207FFB78E - 07FFA4750EFFCDB08FFFAEAEAED700000000000000001918171AC74907FFEF96 - 34FFED8E26FFEE8F25FFEE9425FFEF9C25FFF0A52BFF87EDBFFE39EEB1FF31EA - A2FF2AE894FF4BAB7DB900000000000000000000000043426D7E141DCFFF2741 - EEFF223DECFD0000000000000000000000000000000000000000403F62703033 - CEFF112BEBFF3142C0CF00000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000003C3C3C45F1ECE9FFAE8047FFB577 - 04FFB77903FFB97B03FFBA7C03FFD1AC6DFFBC861EFFB97C03FFB87A03FFB779 - 03FFB88A43FFB89273FFF2F2F2FD00000000000000005A493F63DF7C25FFF2AB - 55FFF0962EFFEF952CFFEF952AFFEF9629FFB9E9C4FE5BF1C1FF3AEDAEFF34EB - A4FF2EE99AFF3ED38FE60000000000000000000000002F2A9EC93345E6FF3E57 - F1FF49507B7F0000000000000000000000000000000000000000000000000700 - BAFE1630EBFF152FEBFF00000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000031313137F6F2F0FFA96E3CFFC284 - 3BFFC38437FFBE761CFFBE7A25FFC78C45FFB76902FFBB6E0BFFBF7A25FFC484 - 3AFFB87B3EFFC5A189FFE7E7E7F8000000000000000057473E5EE6933DFFF6BD - 70FFF2A23AFFF19C33FFF09A31FFF0982FFF1F201F22479650C473E3ACFF48EE - B2FF34EBA4FF4BB388C00000000000000000000000002B26A5CF5F6FEEFF6479 - F4FF3A3B494C0000000000000000000000000000000000000000000000001B14 - B4E81B31E9FF1B35ECFF00000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000001FFFFFFFFB07C5FFFCD95 - 68FFD19767FFCF9769FFDCB595FFD09767FFD19867FFD19867FFD19767FFD097 - 68FFC28F6BFFEAD8CCFF909090AF00000000000000000D0D0D0EDF8423FFF8C9 - 85FFF7C377FFF4A73EFFF3A339FFF29F36FF29729FD243A0DCE5343B3D404667 - 597B32BB7AF335423D440000000000000000000000003F3C8CA47076E7FF6F85 - F6FF535D9398000000000F0F0F103A3A4B4F0C0C0C0D00000000000000000700 - C3FE233EEEFF213BEEFF00000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000F9F9F9FEBA8970FFD6B1 - 99FFDDB597FFDDB99EFFDEB597FFDEB597FFDEB597FFDEB597FFDEB597FFDAB3 - 98FFC4A08EFFFEFEFEFF12121213000000000000000000000000BA620DF3FCE0 - B5FFFACB83FFF9C87EFFF5AF47FFF4A93EFF27759ED43EB7F6FF3BB2F5FF38AE - F5FF50779095101010110000000000000000000000000D0D0D0E100AC8FF798E - F7FF6981F6FF070707080700C4FF3653F2FF3450F2FF000000003A3A4F551215 - D1FF2A46F0FF4C56939A00000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000033333339FBFBFBFFCCAC - 9EFFE6CEBFFFE9D0BEFFEAD0BEFFEAD0BEFFEAD0BEFFEAD0BEFFE8CFBEFFE5D3 - C9FFEADAD4FFD5D5D5ED000000000000000000000000000000002A28252CECB9 - 65FFFBD9A0FFFACF89FFFACD85FFF8B957FF267A9ED748C4F9FF44C0F8FF41BB - F7FF3EB7F6FF4D9CC8D0000000000000000000000000000000003D3992B08087 - EAFF8195F8FF5A72EEF80903C0FF4F6AF4FF3E5AEEFA3636464B1416CCFF4D65 - F3FF536AF3FF0303030400000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000969696B5F8F8 - F8FFC59D8FFFEFE3DCFFF1E4DCFFE6D5CAFFF2E4DCFFF0E4DCFFEBDED8FFE4D1 - CCFFF6F6F6FE0000000000000000000000000000000000000000000000003D3A - 3441F0CA86FCFCE5BBFFFBD38DFFF8BE59FF24809FDC51D1FBFF4ECDFAFF4BC9 - F9FF52C7F9FF0B0B0B0C00000000000000000000000000000000000000003531 - 92BB9097EAFF5E6FEBFF5257D8FF8094F8FF56619FA76A6CDAFF7389F7FF7F91 - F6FE1B1B1D1E0000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000007373 - 7389F7F7F7FFEBDFDDFFCAA399FFEDE2DFFFC9A59AFFD3B2AAFFF7F7F7FFDEDE - DEF4000000000000000000000000000000000000000000000000000000000000 - 000000000000786C527FD7BF90DCF9D48EFD21829EDF5BDDFDFF57D9FCFF6BDB - FCFF212425260000000000000000000000000000000000000000000000000000 - 000000000000333194C4838DE8FF899DF9FF46497D916E7CD5E75963989E0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000008585859CEEEEEEFDF7F7F7FFF6F6F6FFB7B7B7D82828282B0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000001F869FE1CAF6FFFF70ABB8B90404 - 0405000000000000000000000000000000000000000000000000000000000000 - 0000000000001C19ABE29FABF3FF899EF9FF0707070800000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000424D3E000000000000003E000000 - 2800000040000000100000000100010000000000800000000000000000000000 - 000000000000000000000000FFFFFF00FFFFF01FFFFF0000E007F007F00F0000 - F00FF007F0070000C007F007F0070000C003E007E00700008003C007C0070000 - 8001C003C18300000001800387C300000001800387E300000001800387E30000 - 00018003846300008001C003804300008003C003C0030000C007E003E0070000 - E00FF807F81F0000F81FFF0FF87F000000000000000000000000000000000000 - 000000000000} - end - object Images_32x32: TImageList - ColorDepth = cd32Bit - Height = 32 - Width = 32 - Left = 570 - Top = 376 - Bitmap = { - 494C010103002C00740020002000FFFFFFFF2110FFFFFFFFFFFFFFFF424D3600 - 0000000000003600000028000000800000002000000001002000000000000040 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000001020202030303 - 0304060606070606060706060607050505060404040504040405030303040202 - 0203000000010000000100000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000001070707080B0B0B0C0E0E0E0F101010111515 - 15171F1F1F232626262F2A2A2A352B2B2B372B2B2B382A2A2A362424242C1E1E - 1E2216161619111111120F0F0F100B0B0B0C0707070800000001000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000001010102040404050808 - 08090C0C0C0D0E0E0E0F0E0E0E0F0E0E0E0F0D0D0D0E0C0C0C0D0909090A0707 - 0708050505060404040501010102000000010000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000010101 - 0102020202030303030402020203020202030101010201010102000000010000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000004040405141414151B1B1B1D20202023232323272F2F - 2F383F3F3F5942424271434343814545458F4444448F42424282424242734141 - 415F323232412626262D25252529202020231717171904040405000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000020202030A0A0A0B1414 - 14171717171A1717171A1717171A1717171A1616161915151518141414161313 - 13150F0F0F110C0C0C0D08080809040404050101010200000001000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000001010102040404050707 - 07080B0B0B0C0C0C0C0D0C0C0C0D0B0B0B0C0A0A0A0B0909090A070707080606 - 0607040404050202020300000001000000010000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000101010114B4B - 4B5F7E7E7EA8B9B9B9DAE1E1E1F4EDEDEDFBEBEBEBFADEDEDEF1ADADADD27474 - 749C3F3F3F4F0808080900000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000001010102070707081010 - 1012161616191717171A1717171A1717171A1717171A1717171A1717171A1717 - 171A16161619141414170F0F0F110909090A0303030400000001000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000001020202030A0A0A0B1111 - 1113141414161414141714141417141414171313131513131315101010120F0F - 0F100C0C0C0D0909090A05050506030303040101010200000001000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000001212121367676787D6D6D6EDFEFE - FEFFFFFFFFFFFEFEFEFFF9F6F5FFF7F4F2FFF7F4F2FFFCFBFBFFFFFFFFFFFFFF - FFFFFCFCFCFFC1C1C1E05858586F080808090000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000001040404050707 - 07080D0D0D0E161616192423232A2B2A2A35282727301F1E1E241717171A1717 - 171A1717171A1717171A16161619141414160606060701010102000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000001030303040E0E0E0F1515 - 15181717171A1717171A1717171A1717171A1717171A1717171A1717171A1717 - 171A1515151814141416101010120C0C0C0D0707070803030304000000010000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000143434352C7C7C7E4FEFEFEFFFFFFFFFFFEFE - FCFFFAECC7FFE8CE97FFDCC5A2FFE6D0AAFFDBBC84FFD5B57BFFEDD5A1FFFDF3 - D8FFFFFFFFFFFFFFFFFFFDFDFDFFADADADD12F2F2F3600000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000030303042825 - 242C59433F7E724137AC8B432EC29C4B29CE9D532DC98F5534BC775039AE694F - 3F912927273014141417131313150F0F0F110505050601010102000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000102020203070707080E0E - 0E0F14141417161616191717171A1717171A1717171A1717171A1717171A1717 - 171A1717171A1717171A16161619141414160C0C0C0D05050506010101020000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000010101026262627EF5F5F5FCFFFFFFFFFEFCFAFFE6CE9DFFC49B - 50FFB79253FFBFA262FFC4A969FFEAE1CAFFCFBA8AFFC5AA67FFBC9D5FFFB790 - 4CFFCBA45FFFEFDEB9FFFFFFFFFFFFFFFFFFE4E4E4F44A4A4A59000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000080808093C3331438D3E2DC4A929 - 03FBC24606FFDE7316FFEF9A23FFF3AD2EFFF6BC36FFF7C33BFFF6BF36FFF3B2 - 32FFE78F28FBAF723CC33B3733470F0F0F100202020300000001000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000010F0F0F102626 - 282F38383E543C3D4461404158753D3E49663E3F49663D3F486538393F532D2E - 313C1919191D1717171A1717171A1717171A141414170A0A0A0B020202030000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000165656582FAFAFAFEFFFFFFFFF3E7D3FFBB914FFFAD8B4BFFC2AA - 5CFFD1C168FFDBD06FFFE0D874FFDED38BFFDCD272FFDFD773FFD9CD6EFFCEBC - 65FFBDA258FFAB8544FFC8A368FFFAF5ECFFFFFFFFFFF1F1F1FA4A4A4A5A0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000003030304724B3F8E9D2E15E7B63403FFD762 - 0CFFEC9228FFF09E26FFF2A921FFF5B21CFFF7BD19FFF9C518FFFACB1DFFFACC - 22FFF9C82CFFF5B736FFD48938E7775F46860303030400000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000404040532323C4439367EB02929 - 9AD31320C8F50C1FDBFF0D24E4FF0D26E8FF0E27EAFF0E27E8FE1C32D5EC2C3D - BED43E4683A43A3B495714141416111111130D0D0D0E06060607010101020000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00004C4C4C5DF7F7F7FDFEFEFEFFEBD9BDFFA57937FFAE9044FFC3B150FFD4CB - 5AFFDFDC62FFE6E766FFE9EC68FFEBEE69FFEBEE69FFE9EB68FFE5E565FFDDD9 - 60FFD0C558FFBEAA4DFFA78740FFB08544FFF6EDDEFFFEFEFEFFE4E4E4F43030 - 3037000000000000000000000000000000000000000000000000000000000000 - 000000000000000000001E1C1C20854637AEAB2600FFC24507FFE9811BFFEC90 - 28FFEC8F16FFEE9715FFF1A515FFF4B015FFF7BB17FFF8C217FFF9C618FFF9C6 - 18FFF8C217FFF7BD16FFF5B528FFEFA03AFF6E8258A616171618000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000030303042B2B33382E2A8CC80807AAFD0D1ED6FF0F28 - E9FF0F28EAFF0E27EAFF0E27EAFF0E27EAFF0E27EAFF0E27EAFF0E27EAFF0E27 - EAFF0E27EAFF0E27EAFF3A46A6B835363F4B0505050602020203000000010000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000001C1C - 1C1FDADADAEFFCFCFCFFEDDFC9FFAB8549FFB0974AFFBDAB3DFFCDC256FFD5D2 - 48FFDEE04CFFE3E74EFFE5EB4FFFE6EC50FFE6EC50FFE5EA4FFFE2E64EFFDDDE - 4BFFD5D147FFC9BE42FFB8A43BFFA98B44FFB48C50FFF8F3EAFFFCFCFCFFB2B2 - B2D40909090A0000000000000000000000000000000000000000000000000000 - 00000000000000000001844938AAA92904FAC44709FFE57A1CFFEB8822FFEB87 - 18FFED9016FFEE9916FFF1A717FFF4B018FFF6BB19FFF8C119FFF9C418FFF9C3 - 17FFF8BD16FFF6B716FFF4AE1BFFB3C55BFD53DD94F74F826191000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000003636444D252094D8080BB5FF1024DDFF122BEBFF112A - EAFF102AEAFF1029EAFF172FEAFF2D43ECFF495CEEFF3348EDFF112AEAFF0E27 - EAFF0E27EAFF0E27EAFF0E27EAFF2336D2E4383A4A5103030304000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000007F7F - 7FA3F9F9F9FFF6F2ECFFA57734FF9D7C25FFB6A234FFC1B52CFFCAC23DFFDCD8 - 78FFD4D332FFD9DB33FFDBDE34FFDBDF34FFDBDF34FFDADD34FFD8DA33FFD5D4 - 32FFCFCC30FFC8C12EFFBEB02CFFB39D37FF977325FFBC955BFFF9F9F9FFF9F9 - F9FF5D5D5D740000000000000000000000000000000000000000000000000000 - 00000303030464493F73AF2800FFBE3E06FFEA8424FFEB8624FFEA8419FFEB89 - 18FFED9119FFEF9A1AFFF1A71BFFF3AF1BFFF5B91CFFF6BD1BFFF7C01AFFF7BE - 19FFF6B818FFF4B21DFFABCC67FD3CE9A3FE38EBA5FF46E898FF35423A450000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000010101023534434A0C07A2F70A0BB7FF152EE8FF152FEBFF142EEBFF132D - EBFF253CECFF5063F0FF707FE9F76370D9ED5661DBF46871E2FD848DECFF6877 - EFFF3E52EEFF1830EAFF0E27EAFF0E27EAFF192FDFF242477075000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000021212124E8E8 - E8F9F7F7F7FFC9A878FF926A1CFFA78C1BFFB6A31BFFBFB01BFFC5B91CFFD3C9 - 5AFFD6CF5EFFCEC81EFFD2CD1FFFD3CE1FFFD3CE1FFFD2CD1FFFCFC91EFFCCC4 - 1EFFC8BE1DFFC4B71CFFBEAE1BFFB39E1BFFA2841BFF90631BFFE1CDB1FFF7F7 - F7FFC4C4C4E40808080900000000000000000000000000000000000000000000 - 0000262322289D4225D1B83502FFDC6F1EFFEB8927FFEB841DFFEB851BFFEB8A - 1BFFED921CFFEE9A1CFFF0A41DFFF2AD1EFFF3B51EFFF5B91DFFF6BC1DFFF5B9 - 1BFFF4B621FFD0C95DFE4AEBADFE2CEDACFF29EA9EFF4CEBA4FF4CA274B21010 - 1011000000000000000000000000000000000000000000000000000000000000 - 0000212125272D2993CA0906B1FF1527DCFF1933ECFF1731ECFF1731ECFF162F - EBFF223AE8FB3D4CB3BF393B4E5133343F433637464B424267772222A7DF2021 - C0FF4752DEFF6070F0FF1129EAFF0E27EAFF0E27EAFF1C32DBEE2A2A31340000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000068686882F3F3 - F3FFF0EBE4FF97641EFF9C7716FFAE9113FFB9A012FFBEA811FFC2AD12FFC3AF - 16FFDACE71FFD3C651FFCABB14FFCDBE15FFCCBE15FFCBBC14FFCABA13FFC7B5 - 13FFC4B113FFC1AC12FFBDA611FFB79D12FFAA8C14FF976F17FFAC8044FFF3F3 - F3FFF3F3F3FF4646465200000000000000000000000000000000000000000000 - 00006B4B3F7DB53000FECD5611FFEC8F32FFEB8721FFEB8720FFEC881EFFEC8B - 1FFFED911FFFEE981FFFEFA120FFF1A820FFF2AE20FFF3B220FFF3B31FFFF3B4 - 26FFC9D074FE5EECB5FE32EEB1FF2DECA7FF28E99BFF2DE795FF51DB97EF3846 - 3E49000000000000000000000000000000000000000000000000000000000000 - 00003B3983A80600ACFF1422D4FF1D37EDFF1C36EDFF1B35EDFF1A34EBFE3346 - C9D83436444603030304000000000000000000000000000000000D0D0D0E413F - 62721610A5ED1315C0FF5160E9FF1830EAFF0F28EAFF0E27EAFF3745B4C01919 - 1B1C000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000001A4A4A4CEF0F0 - F0FFD2B896FF8E5E16FFA47B11FFB28F0DFFB9990CFFBC9D0CFFBEA00CFFC0A4 - 0CFFC8AF35FFD7C563FFCFB948FFC6AB0DFFC7AD0DFFC6AB0DFFC4A90DFFC2A6 - 0DFFC0A30CFFBD9F0CFFBB9C0CFFB7970CFFAF8B0EFF9F7512FF8F5A15FFE8DC - CDFFF0F0F0FF7C7C7C9F00000000000000000000000000000000000000000000 - 0000A04927CEB93300FFE3802AFFEE9231FFEC8A23FFEC8A23FFEC8B22FFEC8D - 21FFED9121FFEE9622FFEF9D22FFF0A322FFF1A922FFF1AB22FFF2AF28FFE0C7 - 66FE72EDBBFE3CEFB8FF34EDADFF2FEBA4FF2AE99AFF26E792FF4FE99FFE4773 - 5D7A000000000000000000000000000000000000000000000000000000001A1A - 1D1E0F09ACF50804B5FF233BEAFF203AEDFF1F39EDFF1D38EDFF3347CEDC3536 - 4446000000000000000000000000000000000000000000000000000000000101 - 01024141616D1610A8ED2829C8FF3547E9FF1029EAFF0F28EAFF172EE1F63E41 - 5D62000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000F0F0F10DBDBDBF8ECEC - ECFFB3895AFF956312FFA87A0CFFB38908FFB88E07FFBA9107FFBB9307FFBD95 - 07FFBD9608FFD0B55AFFCFB149FFC7A633FFC19B08FFC19B08FFC09908FFBE97 - 08FFBC9507FFBB9207FFB99007FFB78E07FFB18709FFA4750EFF8F5B14FFCDB0 - 8FFFECECECFFAEAEAED700000001000000000000000000000000000000001918 - 171ABD3800FFC74907FFF2A450FFEF9634FFEE8E27FFED8E26FFED8E25FFEE8F - 25FFED9124FFEE9425FFEE9924FFEF9C25FFEFA024FFF0A52BFFD7CB7BFE87ED - BFFE3EEFB6FF39EEB1FF34ECA9FF31EAA2FF2CE99AFF2AE894FF4AEAA0FF4BAB - 7DB9000000000000000000000000000000000000000000000000000000004342 - 6D7E0600B4FF141DCFFF3B53F0FF2741EEFF223DEEFF223DECFD3B3D4F520000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000001010102403F62700600B4FF3033CEFF152EEBFF112BEBFF112AEBFF3142 - C0CF000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000002B2B2B30E7E7E7FFE3DF - DDFFA7774AFF986110FFAA7509FFB48105FFB78404FFB88504FFB98704FFBA88 - 04FFBB8905FFBE8F16FFD2B265FFC79E36FFC39930FFBC8B05FFBC8A05FFBB89 - 05FFBA8704FFB98604FFB78504FFB68304FFB37E06FFA7710BFF945D16FFC09E - 7DFFF5F4F4FFD9D9D9F608080809000000000000000000000000000000003F37 - 3244BF3B00FFD46213FFF4B76FFFF09B3AFFEE922BFFEE912AFFEE9129FFEE92 - 28FFEE9227FFEE9327FFEE9626FFEE9827FFEF9E2DFFE3BB68FE95EDC4FE50F0 - BDFF3DEEB3FF39EEAEFF35ECA8FF32EBA3FF2EE99CFF2BE896FF3CE99BFF46C3 - 87D4000000000000000000000000000000000000000000000000070707083B38 - 8DAE0701B9FF2030DDFF4C62F2FF2F49EFFF2540EEFF3C4FC7D4050505060000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000C0C0C0D201BA8E00E08BAFF162AE3FF142DEBFF132CEBFF152E - E7FB121213140000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000003C3C3C45F5F5F5FFF1EC - E9FFC09F84FFAE8047FFAD7315FFB57704FFB77903FFB77903FFB87A03FFB97B - 03FFB97C03FFBA7C03FFC5963FFFD1AC6DFFD0AB69FFBC861EFFBA7C03FFB97C - 03FFB97B03FFB87A03FFB77903FFB77903FFB37504FFB88A43FFB9946BFFB892 - 73FFFDFDFCFFF2F2F2FD15151516000000000000000000000000000000005A49 - 3F63C23F00FFDF7C25FFF6C384FFF2AB55FFF0972FFFF0962EFFEF952CFFEF95 - 2CFFEF942BFFEF952AFFEF962AFFEF9629FFD2A745FEB9E9C4FE95F6D7FF5BF1 - C1FF3EEEB3FF3AEDAEFF36ECA9FF34EBA4FF31EA9FFF2EE99AFF33E899FF3ED3 - 8FE60000000000000000000000000000000000000000000000001B1B1E1F2F2A - 9EC90F0BC2FF3345E6FF596FF3FF3E57F1FF2944EFFF49507B7F000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000413F6A7A0700BAFE0E16D1FF1630EBFF162FEBFF152F - EBFF393C4F520000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000003E3E3E47FFFFFFFFF2ED - E9FFD5BEAEFFC09971FFB27423FFB97511FFB9740AFFB77102FFB87102FFB872 - 02FFB97202FFB97202FFC18933FFD4AC76FFDBB98AFFC38C39FFB97202FFB872 - 02FFB87202FFB87102FFB77102FFB77102FFB46F09FFBA8748FFD9C2AEFFD8C4 - B6FFFDFDFCFFF4F4F4FE1616161700000000000000000000000000000000624D - 416CC44500FFE48B35FFF7C78BFFF4B768FFF2A13DFFF19B32FFF09830FFF098 - 2FFFEF972EFFEF972DFFEF962CFFEF962BFFA49D35F150BB57F58FE7B6FFA3F6 - D9FF78F3CAFF49EEB5FF38EDABFF36ECA7FF33EAA2FF31EA9EFF34EA9CFF42CC - 90DE000000000000000000000000000000000000000000000000212125272A25 - A4D11B18C8FF4659EBFF5F75F3FF546AF3FF2E49EDFC3E405356000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000003737474D110AB7F40C0ECCFF1831EAFF1832ECFF1731 - ECFF4247696E0000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000031313137FEFEFEFFF6F2 - F0FFA66F49FFA96E3CFFBB7D3DFFC2843BFFC4853BFFC38437FFC17D2BFFBE76 - 1CFFBB6E0CFFBE7A25FFC68940FFC78C45FFC48A43FFB76902FFB96A02FFBB6E - 0BFFBD7419FFBF7A25FFC28031FFC4843AFFC1833CFFB87B3EFFA16535FFC5A1 - 89FFFEFEFEFFE7E7E7F80C0C0C0D000000000000000000000000000000005747 - 3E5EC74A01FFE6933DFFF8CE95FFF6BD70FFF5B45EFFF2A23AFFF29E34FFF19C - 33FFF19B32FFF09A31FFF09930FFF0982FFF8E7A60951F201F224F6D4F844796 - 50C45BC983F673E3ACFF60EEBAFF48EEB2FF37ECA8FF34EBA4FF38EBA2FF4BB3 - 88C0000000000000000000000000000000000000000000000000202023252B26 - A5CF1E1BCBFF5F6FEEFF667BF4FF6479F4FF465DE9F63A3B494C000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000002F303B3E1B14B4E80C0CCBFF1B31E9FF1B35EDFF1B35 - ECFF44496F750000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000015151517F2F2F2FCFFFF - FFFFB07A58FFB17C56FFC08652FFC78B50FFCA8C50FFCA8C50FFCA8C50FFCA8D - 50FFCB925AFFD7A97EFFD5A576FFCB925AFFC58039FFC78542FFCA8B4CFFCA8D - 50FFCA8D50FFCA8C50FFCA8C50FFCA8C50FFC68A51FFBD8453FFA97350FFCDA9 - 90FFFFFFFFFFC3C3C3E200000001000000000000000000000000000000003E37 - 3242C64C00FFE69136FFFAD4A1FFF7C277FFF6BE71FFF5B257FFF2A238FFF2A1 - 37FFF29F35FFF19E34FFF19C33FFF09B32FF83765DA34F666C88434E51592225 - 24274251475C468655AD37BB65FC4AD691FF50EDB3FF3EEDACFF39ECA7FF4F8C - 739300000000000000000000000000000000000000000000000018181A1B312C - A0C51612C9FF6A76ECFF6B81F5FF697EF5FF546CF1FD3F435558000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000032333F431710B8ED0D0ECDFF1D36EAFF1E39EDFF1D37 - EDFF414562660000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000001BDBDBDDDFFFF - FFFFCDA892FFB07C5FFFC5916AFFCD9568FFD09768FFD19767FFD19867FFCF97 - 69FFDEB89AFFDCB595FFD09A6EFFD09767FFD19867FFD19867FFD19867FFD198 - 67FFD19867FFD19767FFD19767FFD09768FFCB9469FFC28F6BFFA87254FFEAD8 - CCFFFFFFFFFF909090AF00000000000000000000000000000000000000000D0D - 0D0EC05308F6DF8423FFFAD9A8FFF8C985FFF8C479FFF7C377FFF5B457FFF4A7 - 3EFFF3A439FFF3A339FFF2A137FFF29F36FF7D7460A529729FD237ACF4FF43A0 - DCE54E6B7D81343B3D40262A292E4667597B35945DCB32BB7AF34CB68EC93542 - 3D44000000000000000000000000000000000000000000000000030303043F3C - 8CA40700C5FF7076E7FF6F85F5FF6F85F6FF6379F4FF535D9398000000000000 - 0000000000000F0F0F102C2C34363A3A4B4F2C2D35370C0C0C0D000000000000 - 000000000000000000003F3E5F6A0700C3FE1319D5FF233EEEFF223CEEFF213B - EEFF2E2F383A0000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000007D7D7D96FFFF - FFFFF3E8E2FFA66C4EFFC99F84FFD2A382FFD6A581FFD7A680FFD6A47DFFE1C2 - AAFFDCB69AFFD6A47DFFD8A680FFD8A680FFD8A680FFD8A680FFD8A680FFD8A6 - 80FFD8A680FFD8A680FFD7A580FFD6A581FFD0A282FFC69D84FFB17A5EFFFEFE - FEFFFEFEFEFF5858586600000000000000000000000000000000000000000000 - 00009D602FBFD47316FFFAD7A0FFFAD193FFF8C87EFFF8C77CFFF8C476FFF6B6 - 59FFF4A83DFFF4A73CFFF3A53AFFF3A439FF77705F9929729DD23CB2F5FF39B0 - F5FF38ABF2FD42A2DDE65085A2AA43535A5E222526283845424B1F2121230808 - 0809000000000000000000000000000000000000000000000000000000004141 - 5F690700C5FF5D5FE0FF738AF6FF748AF6FF6F85F5FF5267D9E3080808090000 - 000025252A2C3F3C92AA2727B9E02939DEF93E52D3E14E5AA0A7070707080000 - 00000000000000000000363299B90700C5FF1E2EE2FF2641EFFF2540EEFF2C44 - E2F30C0C0C0D0000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000033333339F9F9 - F9FEFEFEFEFFBA8970FFCBA996FFD6B199FFDBB497FFDDB597FFDCB79CFFDDB9 - 9EFFDEB596FFDEB597FFDEB597FFDEB597FFDEB597FFDEB597FFDEB597FFDEB5 - 97FFDEB597FFDEB597FFDDB597FFDAB398FFD4B099FFC4A08EFFD4B2A2FFFEFE - FEFFE0E0E0F41212121300000000000000000000000000000000000000000000 - 000050453B57BA620DF3F5C272FFFCE0B5FFFACC85FFFACB83FFF9C981FFF9C8 - 7EFFF7BA5FFFF5AF47FFF5AA3FFFF4A93EFF716C5D8F27759ED443BAF6FF3EB7 - F6FF3CB4F6FF3BB2F5FF39B0F5FF38AEF5FF42A2DDE65077909531393A3D1010 - 1011000000000000000000000000000000000000000000000000000000000D0D - 0D0E1913B7EA100AC8FF92A1F6FF798EF7FF788DF7FF6981F6FF51577D820707 - 07083E3B889F0700C4FF2433E0FF3653F2FF3551F2FF3450F2FF3F4154570000 - 0000010101023A3A4F550700C4FF1215D1FF2B46F0FF2A46F0FF314CEFFE4C56 - 939A000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000A2A2 - A2C2FDFDFDFFF0E4DFFFB27E66FFD9BEAEFFDFC1ADFFE2C3ACFFE3C3ABFFE4C3 - ABFFE5C3ABFFE5C3ABFFE5C3ABFFE5C3ABFFE5C3ABFFE5C3ABFFE5C3ABFFE5C3 - ABFFE4C3ABFFE4C3ABFFE2C2ACFFDEC1ADFFD8BDAEFFBB8A73FFFBFAF9FFFDFD - FDFF7B7B7B930000000000000000000000000000000000000000000000000000 - 000016161517976631BCDF9C3CFFFCE4BBFFFBD89EFFFACE87FFFACD85FFFACB - 83FFF9C97EFFF9C372FFF6B450FFF5AD41FF6E6B5C8926789FD74BC1F8FF42BC - F7FF40BAF6FF3FB8F6FF3DB6F6FF3CB4F5FF3AB1F5FF39B0F5FF42A3DDE74F8D - B3BA191B1B1C0000000000000000000000000000000000000000000000000000 - 0000413F75880801BFFD5F65E2FF8497F8FF7C91F7FF7A90F7FF5B70DDE74043 - 53562B26A5CF0700C1FF3147E9FF3956F3FF3855F2FF3753F2FF363844460000 - 000028282E312B26A5CF0E0CC9FF273BE7FF334EF0FF435CF2FF455BDAE73637 - 4446000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000003333 - 3339EFEFEFFBFBFBFBFFD5B6A9FFCCAC9EFFE4CFC3FFE6CEBFFFE8D0BEFFE9D0 - BEFFEAD0BEFFEAD0BEFFEAD0BEFFEAD0BEFFEAD0BEFFEAD0BEFFEAD0BEFFEAD0 - BEFFE9D0BEFFE8CFBEFFE5CEBFFFE5D3C9FFC7A191FFEADAD4FFFBFBFBFFD5D5 - D5ED171717180000000000000000000000000000000000000000000000000000 - 0000000000002A28252CB4761DE8ECB965FFFDEDCFFFFBD9A0FFFAD08AFFFACF - 89FFFACE86FFFACD85FFFACB82FFF8B957FF6563567B267A9ED756CAFAFF48C4 - F9FF46C2F8FF44C0F8FF42BDF7FF41BBF7FF3FB9F6FF3EB7F6FF3DB5F6FF4D9C - C8D0010101020000000000000000000000000000000000000000000000000000 - 0000151516173D3992B01813C5FF8087EAFF8D9FF8FF8195F8FF7A90F7FF5A72 - EEF8100CC1FB0903C0FF566FF4FF4F6AF4FF4460F3FF3E5AEEFA19191B1C3636 - 464B1D18B3E71416CCFF3950ECFF4D65F3FF5D74F3FF536AF3FF4C537D820303 - 0304000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00007272728AF9F9F9FFFAFAFAFFD1AFA3FFCFB0A3FFE9D9D0FFEBDACFFFEDDB - CFFFEEDBCEFFEEDCCEFFEFDCCEFFEFDBCEFFEFDCCEFFEFDCCEFFEEDCCEFFEEDB - CEFFEDDBCFFFEBDACFFFE8D9D0FFCEADA1FFE4D2CCFFFAFAFAFFF4F4F4FD5050 - 505C000000000000000000000000000000000000000000000000000000000000 - 000000000000000000005A514363B98326E9FBDBA0FFFDEED4FFFBD89AFFFAD2 - 8CFFFAD18AFFFACF89FFFACD83FFF8BC58FF61605474267C9FD960D1FAFF4CCA - F9FF4AC8F9FF49C6F9FF47C3F8FF46C1F8FF43BEF7FF43BDF7FF47B8EEF7485B - 6467000000000000000000000000000000000000000000000000000000000000 - 00000000000025252A2C1D18ACE42321C6FFA1AEF6FFA5B3FAFF8C9FF9FF657C - F5FF0903BCFF1C1CC8FF748BF7FF778CF7FF6981F6FF5568CED742418AA32521 - B5EA2F3FE0FF4F64F0FF657BF5FF6980F5FF657CF5FF5666BDC5101111120000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000005050506969696B5F8F8F8FFF8F8F8FFD4B5ABFFC59D8FFFEDE1DBFFEFE3 - DCFFF0E4DCFFF1E4DCFFF1E4DBFFE6D5CAFFEAD9CFFFF2E4DCFFF1E4DCFFF0E4 - DCFFEFE3DCFFEBDED8FFC79E90FFE4D1CCFFF8F8F8FFF6F6F6FE7676768C0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000003D3A3441AD8738D3F0CA86FCFDF1D9FFFCE5 - BBFFFBD797FFFBD38DFFFACF85FFF8BE59FF5A594F6A24809FDC6EDAFCFF51D1 - FBFF4FCFFAFF4ECDFAFF4CCBFAFF4BC9F9FF4BC7F9FF52C7F9FF568093960B0B - 0B0C000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000027262C2F353192BB1D1CC1FF9097EAFFCED6FCFF5E6F - EBFF0600B4FF5257D8FF748BF7FF8094F8FF7289F7FF56619FA70600B4FF6A6C - DAFF677EF6FF7389F7FF7C90F7FF7F91F6FE606AA1A71B1B1D1E000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000B0B0B0C949494B3F7F7F7FFF7F7F7FFEBE0DDFFC49A8DFFCFAC - A1FFEEE4DFFFF2E8E3FFE8DBD4FFF2EBE6FFE8DCD4FFF1E7E1FFF2E8E3FFECE1 - DCFFCEAAA0FFCEAAA0FFF3EFEEFFF7F7F7FFF4F4F4FE7A7A7A90010101020000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000002B29262D7F6D4594EBC475FBFDEA - C5FFFDF0D9FFFDE6BFFFFCD796FFFAC15DFF53534B6023809DDC79E0FDFF55D7 - FCFF53D5FBFF52D3FBFF50D0FAFF4FCFFAFF5DD0FAFF5BB2D1D7191B1B1C0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000011C1C1F203E3C7E9C3030A1D1606AC6DC3B49 - D8FC0600AFFF6A71DFFF8196F8FF8498F8FF7087F6FE4B508A9B0701B0FFA2A1 - E4FF9CABF9FFAAB7FAFF8F9FEEF45E6794981616171800000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000505050673737389EBEBEBFBF7F7F7FFF7F7F7FFEBDF - DDFFCCA79EFFCAA399FFD8C2B9FFEDE2DFFFECE1DEFFC9A59AFFCDA89FFFD3B2 - AAFFF1ECEBFFF7F7F7FFF7F7F7FFDEDEDEF45A5A5A6600000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000001B1B1A1C786C - 527FB69C6AB9D7BF90DCF0D8ABF3F9D48EFD4C4C455721829EDF94EAFEFF5BDD - FDFF57DBFDFF57D9FCFF5DD9FCFF6BDBFCFF61A1B5B821242526000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000001717191A3331 - 94C4130FB2FF838DE8FF8A9DF9FF899DF9FF6A7FE1E946497D9136359CCA6E7C - D5E77281CCD25963989E27272C2D000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000003636363BA6A6A6C3F3F3F3FEF7F7 - F7FFF7F7F7FFF6F6F6FFF1EEEDFFF0ECEAFFF0ECEAFFF4F4F3FFF7F7F7FFF7F7 - F7FFF7F7F7FFEDEDEDFC919191AD232323250000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000E0E0E0F302F2C3244433F494C4C4753383B3A411F849FE1A8EFFEFF62E2 - FEFF61E0FDFF7EE5FEFF77DFF9FB65A3B2B51E21212200000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000028282C2F2420 - 97D92A29B9FF93A0F2FF8DA0FAFF8C9FF9FF6477CAD03031383B1D1E20213335 - 3C3E232427280606060700000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000003838383D8585 - 859CC3C3C3E3EEEEEEFDF6F6F6FFF7F7F7FFF7F7F7FFF6F6F6FFEBEBEBFCB7B7 - B7D87B7B7B8C2828282B00000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000002F3333371F869FE1D2F8FFFFCAF6 - FFFFA7DEE9E970ABB8B939424546040404050000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000002E2E35381C19 - ABE22123C5FF9FABF3FF98AAFAFF899EF9FF5D6AA3A907070708000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000011B1B1B1D3939393E4848484F4646464D34343439151515160000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000002C2F2E322F7F91C66EA1AAAD5973 - 7979353C3D3F1212121300000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000000C0C0C0D4343 - 6A7624239FDC515ABEE36E87EFF6647AD5DC33353D3E00000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000424D3E000000000000003E000000 - 2800000080000000200000000100010000000000000200000000000000000000 - 000000000000000000000000FFFFFF00FFFFFFFFFF8003FFFFFFFFFF00000000 - FC00003FFF8000FFFFC01FFF00000000FC00003FFF80003FFF8000FF00000000 - FFC003FFFF80003FFF00003F00000000FF0000FFFF80003FFF00001F00000000 - FC00007FFFC0003FFF00001F00000000F800003FFF00003FFF80001F00000000 - F000001FFE00007FFF00001F00000000F000000FFC00003FFC00001F00000000 - E0000007F800003FFC00003F00000000E0000007F000001FF000003F00000000 - C0000003F000000FF000001F00000000C0000003F000000FF003C00F00000000 - 80000003F000000FE00FE00F0000000080000001E000000FE01FF00F00000000 - 80000001E000000FC01FF8070000000080000001E000000FC03FFC0700000000 - 80000001E000000FC03FFC070000000080000001E000000FC03FFC0700000000 - 80000001E000000FC03FFC070000000080000003E000000FC0383C0700000000 - C0000003F000000FE0101C0700000000C0000003F000000FE000100F00000000 - E0000007F0000007F000100F00000000E0000007F8000007F000000F00000000 - F000000FFC00000FF800001F00000000F000001FFE00000FFC00003F00000000 - F800001FFF00001FFC00007F00000000FC00007FFFC0003FFFC001FF00000000 - FF0000FFFFF0007FFFC003FF00000000FFC003FFFFFF00FFFFC03FFF00000000 - FFF01FFFFFFF03FFFFC07FFF0000000000000000000000000000000000000000 - 000000000000} - end -end diff --git a/demos/feedburner_demo/main.pas b/demos/feedburner_demo/main.pas deleted file mode 100644 index 9b4c93d..0000000 --- a/demos/feedburner_demo/main.pas +++ /dev/null @@ -1,180 +0,0 @@ -unit main; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, GFeedBurner, StdCtrls, ComCtrls, ToolWin, ActnMan, ActnCtrls, Ribbon, - ImgList, RibbonLunaStyleActnCtrls, ActnList, RibbonActnCtrls, ExtCtrls, - TeEngine, Series, TeeProcs, Chart; - -type - TForm6 = class(TForm) - FeedBurner1: TFeedBurner; - ActionManager1: TActionManager; - Images_16x16: TImageList; - Ribbon1: TRibbon; - RibbonPage1: TRibbonPage; - RibbonGroup1: TRibbonGroup; - silentapi_act: TAction; - RibbonGroup2: TRibbonGroup; - getfeeddata_act: TAction; - getitemdata_act: TAction; - GetResyndicationData_act: TAction; - Images_32x32: TImageList; - RibbonSpinEdit1: TRibbonSpinEdit; - Action1: TAction; - RibbonGroup3: TRibbonGroup; - start_act: TAction; - stop_act: TAction; - PageControl1: TPageControl; - TabSheet1: TTabSheet; - TabSheet2: TTabSheet; - Memo1: TMemo; - Panel1: TPanel; - CheckBox1: TCheckBox; - CheckBox2: TCheckBox; - CheckBox3: TCheckBox; - CheckBox4: TCheckBox; - Chart1: TChart; - circulation_graph: TBarSeries; - reach_graph: TBarSeries; - clicks_graph: TBarSeries; - views_graph: TLineSeries; - procedure silentapi_actExecute(Sender: TObject); - procedure getfeeddata_actExecute(Sender: TObject); - procedure getitemdata_actExecute(Sender: TObject); - procedure GetResyndicationData_actExecute(Sender: TObject); - procedure RibbonSpinEdit1Change(Sender: TObject); - procedure Action1Execute(Sender: TObject); - procedure start_actExecute(Sender: TObject); - procedure stop_actExecute(Sender: TObject); - procedure FeedBurner1ThreadStart(ThreadIdx: Integer; Actives: Byte); - procedure FeedBurner1ThreadEnd(ThreadIdx: Integer; Actives: Byte); - procedure FeedBurner1APIRequestError(const Code: Integer; Error: string); - procedure FeedBurner1Done(Sender: TObject); - procedure FormShow(Sender: TObject); - private - function GetViewsCount(Date: TDate):integer; - public - end; - -var - Form6: TForm6; - -implementation - -uses uTimeLine; - -{$R *.dfm} - -procedure TForm6.Action1Execute(Sender: TObject); -begin - fTimeLine.ShowModal; -end; - -procedure TForm6.FeedBurner1APIRequestError(const Code: Integer; Error: string); -begin -Memo1.Lines.Add('Ошибка '+IntToStr(Code)+' '+Error); -end; - -procedure TForm6.FeedBurner1Done(Sender: TObject); -var i,idx:integer; -begin - circulation_graph.Active:=CheckBox1.Checked; - reach_graph.Active:=CheckBox2.Checked; - clicks_graph.Active:=CheckBox3.Checked; - views_graph.Active:=CheckBox4.Checked; - for I := 0 to FeedBurner1.Dates.Count - 1 do - begin - idx:=FeedBurner1.FeedData.IndexOf(FeedBurner1.Dates[i]); - if idx>=0 then - begin - if circulation_graph.Active then - circulation_graph.AddXY(FeedBurner1.Dates[i],FeedBurner1.FeedData.Items[idx].Circulation); - if reach_graph.Active then - reach_graph.AddXY(FeedBurner1.Dates[i],FeedBurner1.FeedData.Items[idx].Reach); - if clicks_graph.Active then - clicks_graph.AddXY(FeedBurner1.Dates[i],FeedBurner1.FeedData.Items[idx].Hits); - if views_graph.Active then - views_graph.AddXY(FeedBurner1.Dates[i],GetViewsCount(FeedBurner1.Dates[i])); - end; - end; -end; - -procedure TForm6.FeedBurner1ThreadEnd(ThreadIdx: Integer; Actives: Byte); -begin -Memo1.Lines.Add('Поток '+IntToStr(ThreadIdx)+' завершил работу. Всего активных потоков '+IntToStr(Actives)) -end; - -procedure TForm6.FeedBurner1ThreadStart(ThreadIdx: Integer; Actives: Byte); -begin - Memo1.Lines.Add('Стартовал поток '+IntToStr(ThreadIdx)+' Всего активных потоков '+IntToStr(Actives)) -end; - -procedure TForm6.FormShow(Sender: TObject); -begin - case FeedBurner1.APIMethod of - toGetFeedData: getfeeddata_act.Checked:=true; - toGetItemData: getitemdata_act.Checked:=true; - toGetResyndicationData: GetResyndicationData_act.Checked:=true; - end; - RibbonSpinEdit1.Value:=FeedBurner1.MaxThreads; - silentapi_act.Checked:=FeedBurner1.SilentAPI; -end; - -procedure TForm6.getfeeddata_actExecute(Sender: TObject); -begin - getfeeddata_act.Checked:=not getfeeddata_act.Checked; - FeedBurner1.APIMethod:=toGetFeedData; -end; - -procedure TForm6.getitemdata_actExecute(Sender: TObject); -begin - getitemdata_act.Checked:=not getitemdata_act.Checked; - FeedBurner1.APIMethod:=toGetItemData; -end; - -procedure TForm6.GetResyndicationData_actExecute(Sender: TObject); -begin - GetResyndicationData_act.Checked:=not GetResyndicationData_act.Checked; - FeedBurner1.APIMethod:=toGetResyndicationData; -end; - -function TForm6.GetViewsCount(Date: TDate): integer; -var Entry: TBasicEntry; - i,idx:integer; -begin - Result:=0; - idx:=FeedBurner1.FeedData.IndexOf(Date); - if idx>=0 then - begin - Entry:=FeedBurner1.FeedData.Items[idx]; - for i:= 0 to Entry.FeedItems.Count - 1 do - Result:=Result+Entry.FeedItems[i].ItemViews; - end; -end; - -procedure TForm6.RibbonSpinEdit1Change(Sender: TObject); -begin - FeedBurner1.MaxThreads:=RibbonSpinEdit1.Value -end; - -procedure TForm6.silentapi_actExecute(Sender: TObject); -begin - silentapi_act.Checked:=not silentapi_act.Checked; - FeedBurner1.SilentAPI:=silentapi_act.Checked; -end; - -procedure TForm6.start_actExecute(Sender: TObject); -begin - Memo1.Lines.Clear; - FeedBurner1.Start; -end; - -procedure TForm6.stop_actExecute(Sender: TObject); -begin - FeedBurner1.Stop; -end; - -end. diff --git a/demos/gmail_demo/Unit2.dfm b/demos/gmail_demo/Unit2.dfm deleted file mode 100644 index e88348e..0000000 --- a/demos/gmail_demo/Unit2.dfm +++ /dev/null @@ -1,205 +0,0 @@ -object Form2: TForm2 - Left = 0 - Top = 0 - Caption = 'Form2' - ClientHeight = 305 - ClientWidth = 616 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - PixelsPerInch = 96 - TextHeight = 13 - object Label7: TLabel - Left = 8 - Top = 97 - Width = 68 - Height = 13 - Caption = #1057#1086#1076#1077#1088#1078#1080#1084#1086#1077':' - end - object Label8: TLabel - Left = 327 - Top = 97 - Width = 111 - Height = 13 - Caption = #1060#1072#1081#1083#1099' '#1076#1083#1103' '#1086#1090#1087#1088#1072#1074#1082#1080':' - end - object Label1: TLabel - Left = 8 - Top = 11 - Width = 40 - Height = 13 - Caption = #1054#1090' '#1082#1086#1075#1086 - end - object lbl1: TLabel - Left = 216 - Top = 12 - Width = 145 - Height = 13 - Caption = '('#1085#1072#1087#1088#1080#1084#1077#1088', pupki@gmail.com)' - end - object lbl2: TLabel - Left = 8 - Top = 38 - Width = 25 - Height = 13 - Caption = #1050#1086#1084#1091 - end - object lbl3: TLabel - Left = 215 - Top = 38 - Width = 160 - Height = 13 - Caption = '('#1053#1072#1087#1088#1080#1084#1077#1088', Sidorov@yandex.ru)' - end - object lbl4: TLabel - Left = 8 - Top = 66 - Width = 83 - Height = 13 - Caption = #1058#1077#1084#1072' '#1089#1086#1086#1073#1097#1077#1085#1080#1103 - end - object lbl5: TLabel - Left = 373 - Top = 11 - Width = 30 - Height = 13 - Caption = #1051#1086#1075#1080#1085 - end - object lbl6: TLabel - Left = 491 - Top = 12 - Width = 37 - Height = 13 - Caption = #1055#1072#1088#1086#1083#1100 - end - object Memo1: TMemo - Left = 8 - Top = 116 - Width = 313 - Height = 85 - TabOrder = 0 - end - object Button1: TButton - Left = 44 - Top = 207 - Width = 110 - Height = 25 - Caption = #1044#1086#1073#1072#1074#1080#1090#1100' '#1082#1072#1082' '#1090#1077#1082#1089#1090 - TabOrder = 1 - OnClick = Button1Click - end - object Button2: TButton - Left = 160 - Top = 207 - Width = 112 - Height = 25 - Caption = #1044#1086#1073#1072#1074#1080#1090#1100' '#1082#1072#1082' HTML' - TabOrder = 2 - OnClick = Button2Click - end - object ListBox2: TListBox - Left = 327 - Top = 116 - Width = 282 - Height = 85 - ItemHeight = 13 - TabOrder = 3 - end - object Button3: TButton - Left = 268 - Top = 255 - Width = 75 - Height = 25 - Caption = #1054#1090#1087#1088#1072#1074#1080#1090#1100 - TabOrder = 4 - OnClick = Button3Click - end - object Edit1: TEdit - Left = 54 - Top = 8 - Width = 155 - Height = 21 - TabOrder = 5 - end - object Edit2: TEdit - Left = 54 - Top = 35 - Width = 155 - Height = 21 - TabOrder = 6 - end - object Edit3: TEdit - Left = 97 - Top = 62 - Width = 512 - Height = 21 - TabOrder = 7 - Text = #1058#1077#1084#1072' '#1089#1086#1086#1073#1097#1077#1085#1080#1103 - end - object btn1: TButton - Left = 366 - Top = 207 - Width = 89 - Height = 25 - Caption = #1044#1086#1073#1072#1074#1080#1090#1100' '#1092#1072#1081#1083 - TabOrder = 8 - OnClick = btn1Click - end - object btn2: TButton - Left = 461 - Top = 207 - Width = 118 - Height = 25 - Caption = #1059#1076#1072#1083#1080#1090#1100' '#1074#1099#1073#1088#1072#1085#1085#1099#1081 - TabOrder = 9 - OnClick = btn2Click - end - object Edit4: TEdit - Left = 409 - Top = 8 - Width = 76 - Height = 21 - TabOrder = 10 - end - object Edit5: TEdit - Left = 534 - Top = 8 - Width = 75 - Height = 21 - TabOrder = 11 - end - object chk1: TCheckBox - Left = 8 - Top = 238 - Width = 405 - Height = 17 - Caption = #1054#1095#1080#1089#1090#1080#1090#1100' '#1087#1086#1083#1103' '#1082#1086#1084#1087#1086#1085#1077#1085#1090#1072' '#1087#1086#1089#1083#1077' '#1086#1090#1087#1088#1072#1082#1080' '#1089#1086#1086#1073#1097#1077#1085#1080#1103 - TabOrder = 12 - end - object StatusBar1: TStatusBar - Left = 0 - Top = 286 - Width = 616 - Height = 19 - Panels = < - item - Width = 200 - end> - end - object OpenDialog1: TOpenDialog - Left = 449 - Top = 140 - end - object GMailSMTP1: TGMailSMTP - Host = 'smtp.gmail.com' - Port = 587 - Mailer = 'MyMegaMailer' - OnStatus = GMailSMTP1Status - Left = 48 - Top = 120 - end -end diff --git a/demos/gmail_demo/Unit2.pas b/demos/gmail_demo/Unit2.pas deleted file mode 100644 index 40b7003..0000000 --- a/demos/gmail_demo/Unit2.pas +++ /dev/null @@ -1,112 +0,0 @@ -unit Unit2; - -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/gmail_demo/gmail.dproj b/demos/gmail_demo/gmail.dproj deleted file mode 100644 index b64f351..0000000 --- a/demos/gmail_demo/gmail.dproj +++ /dev/null @@ -1,106 +0,0 @@ -п»ї - - {67A670C9-D500-4E45-9A81-C79D2A08C264} - 12.0 - gmail.dpr - Debug - DCC32 - - - true - - - true - Base - true - - - true - Base - true - - - gmail.exe - 00400000 - WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias) - x86 - false - false - false - false - false - - - false - RELEASE;$(DCC_Define) - 0 - false - - - DEBUG;$(DCC_Define) - - - - MainSource - - -
Form2
- - - Base - - - Cfg_2 - Base - - - Cfg_1 - Base - - - - - Delphi.Personality.12 - - - - - gmail.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 - - - - - 12 - - diff --git a/demos/gmail_demo/libeay32.dll b/demos/gmail_demo/libeay32.dll deleted file mode 100644 index bc6ea14..0000000 Binary files a/demos/gmail_demo/libeay32.dll and /dev/null differ diff --git a/demos/gmail_demo/ssleay32.dll b/demos/gmail_demo/ssleay32.dll deleted file mode 100644 index 208793f..0000000 Binary files a/demos/gmail_demo/ssleay32.dll and /dev/null differ diff --git a/demos/googlelogin_demo/Demo.dpr b/demos/googlelogin_demo/Demo.dpr deleted file mode 100644 index 0039e8f..0000000 --- a/demos/googlelogin_demo/Demo.dpr +++ /dev/null @@ -1,15 +0,0 @@ -program Demo; - -uses - Forms, - main in 'main.pas' {Form11}, - uGoogleLogin in '..\..\packages\googleLogin_pack\uGoogleLogin.pas'; - -{$R *.res} - -begin - Application.Initialize; - Application.MainFormOnTaskbar := True; - Application.CreateForm(TForm11, Form11); - Application.Run; -end. diff --git a/demos/googlelogin_demo/Demo.dproj b/demos/googlelogin_demo/Demo.dproj deleted file mode 100644 index bb66e61..0000000 --- a/demos/googlelogin_demo/Demo.dproj +++ /dev/null @@ -1,108 +0,0 @@ -п»ї - - {A9DD61E1-1C1A-4F97-801D-FA2DE517335B} - 12.2 - Demo.dpr - Debug - DCC32 - True - Win32 - Application - VCL - - - true - - - true - Base - true - - - true - Base - true - - - vcl;rtl;vclx;vclimg;vclactnband;dbrtl;vcldb;vcldbx;bdertl;vcltouch;xmlrtl;dsnap;dsnapcon;TeeUI;TeeDB;Tee;vclib;ibxpress;adortl;IndyCore;IndySystem;IndyProtocols;inet;intrawebdb_100_140;Intraweb_100_140;VclSmp;vclie;websnap;webdsnap;inetdb;inetdbbde;inetdbxpress;soaprtl;vclribbon;dbexpress;DbxCommonDriver;DataSnapIndy10ServerTransport;DataSnapProviderClient;DbxClientDriver;DataSnapServer;DBXInterBaseDriver;DBXMySQLDriver;dbxcds;DBXFirebirdDriver;DBXSybaseASEDriver;DBXSybaseASADriver;DBXOracleDriver;DBXMSSQLDriver;DBXInformixDriver;DBXDb2Driver;WDSearchStat;CompThread;Package1 - 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 - - -
Form11
- - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - - - Delphi.Personality.12 - - - - - - False - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 1049 - 1251 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - - Demo.dpr - - - - True - - - 12 - - diff --git a/demos/googlelogin_demo/Demo.res b/demos/googlelogin_demo/Demo.res deleted file mode 100644 index fc1937e..0000000 Binary files a/demos/googlelogin_demo/Demo.res and /dev/null differ diff --git a/demos/googlelogin_demo/main.dfm b/demos/googlelogin_demo/main.dfm deleted file mode 100644 index 758006e..0000000 --- a/demos/googlelogin_demo/main.dfm +++ /dev/null @@ -1,228 +0,0 @@ -object Form11: TForm11 - Left = 0 - Top = 0 - Caption = 'Google Login' - ClientHeight = 353 - ClientWidth = 600 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - PixelsPerInch = 96 - TextHeight = 13 - object Label1: TLabel - Left = 8 - Top = 31 - Width = 24 - Height = 13 - Caption = 'Email' - end - object Label2: TLabel - Left = 175 - Top = 30 - Width = 46 - Height = 13 - Caption = 'Password' - end - object Label4: TLabel - Left = 8 - Top = 8 - Width = 152 - Height = 13 - Caption = #1057#1074#1077#1076#1077#1085#1080#1103' '#1086#1073' '#1072#1082#1082#1072#1091#1085#1090#1077' Google' - end - object Label3: TLabel - Left = 8 - Top = 108 - Width = 53 - Height = 13 - Caption = #1056#1077#1079#1091#1083#1100#1090#1072#1090 - end - object Label5: TLabel - Left = 8 - Top = 60 - Width = 36 - Height = 13 - Caption = #1057#1077#1088#1074#1080#1089 - end - object Label6: TLabel - Left = 8 - Top = 134 - Width = 27 - Height = 13 - Caption = 'AUTH' - end - object Label7: TLabel - Left = 8 - Top = 161 - Width = 61 - Height = 13 - Caption = 'TLoginResult' - end - object Label9: TLabel - Left = 8 - 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 = 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 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 - Top = 27 - Width = 121 - Height = 21 - TabOrder = 0 - Text = 'GoLabApi@gmail.com' - end - object PassEdit: TEdit - Left = 227 - Top = 27 - Width = 121 - Height = 21 - TabOrder = 1 - Text = '123456789her' - end - object Button1: TButton - 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 = 64 - Top = 57 - Width = 284 - Height = 21 - Style = csDropDownList - ItemIndex = 0 - TabOrder = 3 - Text = #1051#1102#1073#1086#1081 - Items.Strings = ( - #1051#1102#1073#1086#1081 - 'Google Analytics Data APIs' - 'Google Apps Provisioning APIs' - 'Google Base Data API' - 'Google Sites Data API' - 'Blogger Data API' - 'Book Search Data API' - 'Calendar Data API' - 'Google Code Search Data API' - 'Contacts Data API' - 'Documents List Data API' - 'Finance Data API' - 'Gmail Atom feed' - 'Health Data API' - 'Maps Data APIs' - 'Picasa Web Albums Data API' - 'Sidewiki Data API' - 'Spreadsheets Data API' - 'Webmaster Tools API' - 'YouTube Data API') - end - object AuthEdit: TEdit - Left = 84 - Top = 131 - Width = 264 - Height = 21 - TabOrder = 4 - end - object ResultEdit: TEdit - Left = 84 - Top = 104 - Width = 264 - Height = 21 - TabOrder = 5 - end - object Button2: TButton - 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' Destroy' - TabOrder = 6 - OnClick = Button2Click - end - object Edit1: TEdit - Left = 84 - Top = 158 - Width = 264 - Height = 21 - TabOrder = 7 - end - object ProgressBar1: TProgressBar - Left = 8 - Top = 234 - Width = 339 - Height = 17 - TabOrder = 8 - end - object Memo1: TMemo - Left = 8 - Top = 276 - Width = 339 - Height = 70 - TabOrder = 9 - end - object edtCaptcha: TEdit - Left = 361 - Top = 295 - Width = 224 - Height = 21 - TabOrder = 10 - end - object Button3: TButton - Left = 361 - Top = 322 - Width = 224 - Height = 25 - 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 = 'My-Application' - AccountType = atNone - Left = 172 - Top = 184 - end -end diff --git a/demos/googlelogin_demo/main.pas b/demos/googlelogin_demo/main.pas deleted file mode 100644 index 0725e3f..0000000 --- a/demos/googlelogin_demo/main.pas +++ /dev/null @@ -1,129 +0,0 @@ -п»їunit main; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, uGoogleLogin,TypInfo, ComCtrls, ExtCtrls; - -type - TForm11 = class(TForm) - Label1: TLabel; - Label2: TLabel; - EmailEdit: TEdit; - PassEdit: TEdit; - Button1: TButton; - Label4: TLabel; - Label3: TLabel; - Label5: TLabel; - ComboBox1: TComboBox; - Label6: TLabel; - AuthEdit: TEdit; - ResultEdit: TEdit; - Button2: TButton; - Edit1: TEdit; - Label7: TLabel; - ProgressBar1: TProgressBar; - Memo1: TMemo; - Label9: TLabel; - Label10: TLabel; - imgCaptcha: TImage; - edtCaptcha: TEdit; - Button3: TButton; - Label11: TLabel; - Label12: TLabel; - GoogleLogin1: TGoogleLogin; - procedure Button1Click(Sender: TObject); - procedure GoogleLogin1Autorization(const LoginResult: TLoginResult; - Result: TResultRec); - procedure GoogleLogin1Error(const ErrorStr: string); - procedure Button2Click(Sender: TObject); - procedure GoogleLogin1Disconnect(const ResultStr: string); - procedure GoogleLogin1ProgressAutorization(const Progress, MaxProgress: Integer); - procedure GoogleLogin1AutorizCaptcha(PicCaptcha: TPicture); - procedure Button3Click(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - Form11: TForm11; - -implementation - -{$R *.dfm} - - -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); -Memo1.Clear;//очистка лога -GoogleLogin1.Login(); -end; - -procedure TForm11.Button2Click(Sender: TObject); -begin - GoogleLogin1.Destroy; -end; - -procedure TForm11.Button3Click(Sender: TObject); -begin - 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); -var - temp:string; -begin - ResultEdit.Text:=Result.LoginStr; - AuthEdit.Text:=Result.Auth; - temp:=GetEnumName(TypeInfo(TLoginResult),Integer(LoginResult)); - Edit1.Text:=temp; - if LoginResult =lrOk then - ShowMessage('РњС‹ РІ гугле!!!!!!!!!') - else - ShowMessage('РњС‹ РќР• РІ гугле!!!!!!!!!'); - -end; - -procedure TForm11.GoogleLogin1AutorizCaptcha(PicCaptcha: TPicture); -begin - imgCaptcha .Picture:=PicCaptcha; -end; - -procedure TForm11.GoogleLogin1Disconnect(const ResultStr: string); -begin - ShowMessage('Disconnect'); -end; - -procedure TForm11.GoogleLogin1Error(const ErrorStr: string); -begin - ShowMessage(ErrorStr); -end; - -procedure TForm11.GoogleLogin1ProgressAutorization(const Progress, MaxProgress: Integer); -begin - ProgressBar1.Position:=Progress; - ProgressBar1.Max:=MaxProgress; - Memo1.Lines.Add('////////'); - Memo1.Lines.Add('Progress '+IntToStr(Progress)); - Memo1.Lines.Add('MaxProgress '+IntToStr(MaxProgress)); -end; - -end. diff --git a/demos/translate_demo/main.dfm b/demos/translate_demo/main.dfm deleted file mode 100644 index 24279fe..0000000 --- a/demos/translate_demo/main.dfm +++ /dev/null @@ -1,109 +0,0 @@ -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 deleted file mode 100644 index 9a2d0ed..0000000 --- a/demos/translate_demo/main.pas +++ /dev/null @@ -1,79 +0,0 @@ -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 deleted file mode 100644 index cce612a..0000000 --- a/demos/translate_demo/translate_demo.dpr +++ /dev/null @@ -1,16 +0,0 @@ -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 deleted file mode 100644 index 3f2243c..0000000 --- a/demos/translate_demo/translate_demo.dproj +++ /dev/null @@ -1,111 +0,0 @@ -п»ї - - {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 - - -
Form6
- - - - - 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/demos/translate_demo/translate_demo.res b/demos/translate_demo/translate_demo.res deleted file mode 100644 index fc1937e..0000000 Binary files a/demos/translate_demo/translate_demo.res and /dev/null differ diff --git a/packages/BloggerApi.pas b/packages/BloggerApi.pas new file mode 100644 index 0000000..035478b --- /dev/null +++ b/packages/BloggerApi.pas @@ -0,0 +1,1211 @@ +{*******************************************************} +{ } +{ BloggerApi } +{ } +{ Copyright (C) 2010 NMD } +{ http://nmdsoft.blogspot.com/ } +{*******************************************************} + + +unit BloggerApi; + +interface + +uses + SysUtils, Classes,NativeXml,WinInet; + +//ошибки +resourcestring +rsErrorXmlTag='Нет закрывающего тега. HTHL должен быть валидным'; +rsErrorNotTolken='Нет толкена google для работы с сервисом'; +rsErrorNotSelectBlog='Блог не выбран! Смотри property CurrentBlog'; +rsErrorIdPost='Не указан Id сообщения в блоге'; +rsErrorIsEmpty='Данные от сервера не были получены'; + +rsErrorGet='Произошла сетевая ошибка при получении данных c сервера'; +rsErrorDelete='Произошла сетевая ошибка при выполнении запроса Delete'; +rsErrorPost='Произошла сетевая ошибка при отправке данных на сервер'; +rsErrorPut='Произошла сетевая ошибка при обновлении данных на сервер'; +const + cnsBlogDefault='http://www.blogger.com/feeds/default/blogs'; + cnsEntry='entry'; + cnsName='name'; + cnsId='id'; + cnsPublished='published'; + cnsUpdated='updated'; + cnsTitle='title'; + cnsCategory='category'; + cntTerm='term'; + cnsXhtml='xhtml'; + cnsXmlns='xmlns'; + cnsType='type'; + cnsText='text'; + cnsContent='content'; + cnsScheme='scheme'; + cnsTerm='term'; + cnsDiv='div'; + cnsAtomUrl='http://www.w3.org/2005/Atom'; + cnsXhtmlUrl='http://www.w3.org/1999/xhtml'; + cnsAtnsUrl='http://www.blogger.com/atom/ns#'; + //http://www.blogger.com/feeds/blogID/posts/default + cnsPostBlogStart='http://www.blogger.com/feeds/'; + cnsPostBlogEnd='/posts/default'; + cnsAppControll='app:control'; + cnsXmlnsApp='xmlns:app'; + cnsXmlnsAppUrl='http://www.w3.org/2007/app'; + cnsAppDraft='app:draft'; + cnsYes='yes'; + cnsVop='/?'; +// cnsPostIdUrl='http://www.blogger.com/feeds/blogID/posts/default/postID'; + cnsAuthor='author';//автор для комментариев + //cnsName имя автора комментария + cnsURl='uri'; + cnsEmail='email'; + cnsCommentsEnd='/comments/default'; + cnsAnonymous='Anonymous';//анонимный комментатор +type + //событие для ошибки + TErrorEvent = procedure(aE: string) of object; + //Прогресс выполнения задания + TProgressEvent = procedure(aCurrentProgress,aMaxProgress: Integer) of object; + + //для комментариев + TCommentItem = class (TCollectionItem) + private + FCommentTitle: string; + FCommentId: string; + FCommentSourse: TStringList; + FCommentPublished: TDateTime; + FCommentUpdate: TDateTime; + FAutorName:string; + FAutorURL:string; + FAutorEmail:string; + procedure SetCommentId(const Value: string); + procedure SetCommentPublished(const Value: TDateTime); + procedure SetCommentSourse(const Value: TStringList); + procedure SetCommentTitle(const Value: string); + procedure SetCommentUpdate(const Value: TDateTime); + procedure SetCommentAutorEmail(const Value: string); + procedure SetCommentAutorName(const Value: string); + procedure SetCommentAutorURL(const Value: string); + public + constructor Create(Collection: TCollection);override; + destructor Destroy; override; + published + property CommentId:string read FCommentId write SetCommentId; + property CommentTitle:string read FCommentTitle write SetCommentTitle; + property CommentSourse:TStringList read FCommentSourse write SetCommentSourse; + property CommentPublished:TDateTime read FCommentPublished write SetCommentPublished; + property CommentUpdate:TDateTime read FCommentUpdate write SetCommentUpdate; + property CommentAutorName:string read FAutorName write SetCommentAutorName; + property CommentAutorURL:string read FAutorURL write SetCommentAutorURL; + property CommentAutorEmail:string read FAutorEmail write SetCommentAutorEmail; + end; + + //комментарии + TCommentCollection = class (TCollection) + private + function GetItemComment(Index: Integer): TCommentItem; + procedure SetItemComment(Index: Integer; Value: TCommentItem); + public + constructor Create(AOwner:TComponent); + function Add: TCommentItem; + property Items[Index: Integer]: TCommentItem read GetItemComment write SetItemComment; + function AddEx(aCommentTitle,aCommentId:string; aCommentSourse:TStringList;aCommentPublished,aCommentUpdate:TDateTime;aAutorName,aAutorEmail,aAutorURL:string): TCommentItem; + end; + + //для сообщений + TPostItem = class (TCollectionItem) + private + FPostTitle: string; + FPostId: string; + FPostSourse: TStringList; + FСategoryPost:TStringList; + FPostPublished: TDateTime; + FPostUpdate: TDateTime; + procedure SetPostId(const Value: string); + procedure SetPostPublished(const Value: TDateTime); + procedure SetPostSourse(const Value: TStringList); + procedure SetPostTitle(const Value: string); + procedure SetPostUpdate(const Value: TDateTime); + procedure SetСategoryPost(const Value: TStringList); + public + constructor Create(Collection: TCollection);override; + destructor Destroy; override; + published + property PostId:string read FPostId write SetPostId; + property PostTitle:string read FPostTitle write SetPostTitle; + property PostSourse:TStringList read FPostSourse write SetPostSourse; + property СategoryPost:TStringList read FСategoryPost write SetСategoryPost; + property PostPublished:TDateTime read FPostPublished write SetPostPublished; + property PostUpdate:TDateTime read FPostUpdate write SetPostUpdate; + end; + + TPostCollection = class (TCollection) + private + function GetItemBlog(Index: Integer): TPostItem; + procedure SetItemBlog(Index: Integer; Value: TPostItem); + public + constructor Create(AOwner:TComponent); + function Add: TPostItem; + property Items[Index: Integer]: TPostItem read GetItemBlog write SetItemBlog; + function AddEx(aPostTitle,aPostId:string; aPostSourse:TStringList;aPostPublished,aPostUpdate:TDateTime): TPostItem; + end; + + + TBlogItem = class (TCollectionItem) + private + FTitle:string;//заголовок + FBlogId:string;//id блога + FСategoryBlog:TStringList;//ярлыки блога + FPublished:TDateTime;//дата последеней публикации + FUpdate:TDateTime;//дата последнего обновления + procedure SetCategory(const Value: TStringList); + procedure SetPublished(const Value: TDateTime); + procedure SetUpdate(const Value: TDateTime); + procedure SetBlogId(const Value: string); + procedure SetTitle(const Value: string); + + public + constructor Create(Collection: TCollection);override; + destructor Destroy; override; + published + property Title:string read FTitle write SetTitle; + property BlogId:string read FBlogId write SetBlogId; + property СategoryBlog:TStringList read FСategoryBlog write SetCategory; + property Publish:TDateTime read FPublished write SetPublished; + property Update:TDateTime read FUpdate write SetUpdate; + end; + + TBlogCollection = class (TCollection) + private + function GetItemBlog(Index: Integer): TBlogItem; + procedure SetItemBlog(Index: Integer; Value: TBlogItem); + public + constructor Create(AOwner:TComponent); + function Add: TBlogItem; + property Items[Index: Integer]: TBlogItem read GetItemBlog write SetItemBlog; + function AddEx(aName,aTitle,aBlogId: string;aUrl:string;aСategoryBlog:TStringList;aPublished,aUpdate:TDateTime): TBlogItem; + end; + +//класс для работы с блогами на Blogger'e +type + TBlogger = class(TComponent) + private + //для работы с xml + FXMLDoc:TNativeXml; + FAuth:string; + FUrl:string;//ссылка на профиль владельца блога + FAppName:string;//название приложения + FBlogs:TBlogCollection; + FCurrentBlog: Integer;//блог с которым будем непосредственно работать + //для событий + FProgress:TProgressEvent; + FErrorEvent: TErrorEvent;//ошибка + + //вспомогательные для работы с инетом + function GetUrl(url, param, method: string; AUTH:AnsiString;postData: UTF8String): UTF8String; + function DataAvailable(hRequest: pointer; out Size: cardinal): boolean; + function GetScriptName(url, hostname: string): string; + procedure SetFlags(url: string; out Flags_connection, Flags_Request: Cardinal); + function GetHostName(url: string): string; + + function GetIdBlog(aSourse:string):string;//получение id блога + function GetPostId(aSourse:string):string;//получение id поста + function GetCommentId(aSourse:string):string;//получение id комментария + + + procedure ToError(aError:string);//обработка ошибок + //для пропертей + procedure SetAppName(const Value: string); + procedure SetAuth(const Value: string); + procedure SetBlog(const Value: TBlogCollection); + procedure SetCurrentBlog(const Value: Integer); + + protected + public + constructor Create(AOwner: TComponent);override;//инициализация класса + destructor Destroy; override;//уничтожение + + procedure RetrievAllBlogs;//получение списка блогов пользователя + + function PostCreat(aTitle,aContent:string; aCategory:TStringList;aComment:Boolean):UTF8String;//создание сообщения и отправка в блог + function PostModify(id,aTitle,aContent:string; aCategory:TStringList;aComment:Boolean):UTF8String;//Изменение сообщения и отправка его в блог + function PostDelete(id:string):Boolean;//удаление поста из блога + + function RetrievAllPosts:TPostCollection;//получаем последние 25 постов из блога + //получение статей по заданным параметрам + function RetrievPostForParams(aCategory:string =''; aOrderby:string =''; aPublishedMin:string =''; + aPublishedMax:string =''; aUpdatedMin:string ='';aUpdatedMax:string =''; + aStartIndex:Integer=0; aMaxResults:Integer=0; aAlt : string =''):TPostCollection; + //Возвращает посты из блога по заданным параметрам созданым в ручную + function RetrievPostForTextParams(Parametrs:string):TPostCollection; + + //Комментарии + function RetrievAllComments:TCommentCollection;//возвращает все комментарии текущего блога + + published + property Auth:string read FAuth write SetAuth; + property AppName:string read FAppName write SetAppName; + property CurrentBlog:Integer read FCurrentBlog write SetCurrentBlog default -1; + property Url: string read FUrl; + property Blogs:TBlogCollection read FBlogs write SetBlog; + + //события + property OnProgress:TProgressEvent read FProgress write FProgress;//прогресс выполнения задачи + property OnError:TErrorEvent read FErrorEvent write FErrorEvent;//возникает при ошибке ) + + end; + +procedure Register; + +implementation + +constructor TBlogger.Create(AOwner: TComponent); +begin + inherited; + FBlogs:=TBlogCollection.Create(Self); + FXMLDoc:=TNativeXml.Create; + FAuth:=''; + FAppName:='MyCompany'; + FCurrentBlog:=-1; +end; + +destructor TBlogger.Destroy; +begin + FreeAndNil(FXMLDoc); + FBlogs.Free; + inherited; +end; + +//получение id комментария +function TBlogger.GetCommentId(aSourse: string): string; +var + i:Integer; +begin + Result:=''; + i:=AnsiPos('.blog-',aSourse); + Delete(aSourse,1,i+5); + Result:=aSourse; +end; + +function TBlogger.GetHostName(url : string) : string; +begin + result := ''; + if pos('https://',url) > 0 then + begin + delete(url,1,length('https://')); + SetLength(url,pos('/',url) - 1); + result := url; + end + else + if pos('http://',url) > 0 then + begin + delete(url,1,length('http://')); + SetLength(url,pos('/',url) - 1); + result := url; + end; +end; + +{------------------------------------------------------------------------------- + Функция: TBlogger.GetIdBlog + Автор: NMD + Дата: 2010.08.08 + Входные параметры: aSourse: string строка содержащая id блога + Результат: id блога string +-------------------------------------------------------------------------------} +function TBlogger.GetIdBlog(aSourse: string): string; +var + i:Integer; +begin + Result:=''; + i:=AnsiPos('.blog-',aSourse); + Delete(aSourse,1,i+5); + Result:=aSourse; +end; + +function TBlogger.GetPostId(aSourse: string): string; +var + i:Integer; +begin + Result:=''; + i:=AnsiPos('.post-',aSourse); + Delete(aSourse,1,i+5); + Result:=aSourse; +end; + +function TBlogger.GetScriptName( url,hostname : string) : string; +begin + result := ''; + delete(url,1,pos(hostname,url) + length(hostname)); + result := url; +end; + +procedure TBlogger.SetFlags(url : string; out Flags_connection,Flags_Request : Cardinal); +begin + //Оприделяем на https или http + if pos('https',url) > 0 then + begin + 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; + end + else + begin + Flags_connection := INTERNET_DEFAULT_HTTP_PORT; + Flags_Request := INTERNET_FLAG_RELOAD or INTERNET_FLAG_IGNORE_CERT_CN_INVALID or INTERNET_FLAG_NO_CACHE_WRITE or INTERNET_FLAG_PRAGMA_NOCACHE or INTERNET_FLAG_KEEP_CONNECTION; + end; +end; + +//обработка ошибок +procedure TBlogger.ToError(aError: string); +begin + if Assigned(FErrorEvent) then + OnError(aError); +end; + +function TBlogger.DataAvailable(hRequest: pointer; out Size : cardinal): boolean; +begin + result := wininet.InternetQueryDataAvailable(hRequest, Size, 0, 0); +end; + +function TBlogger.GetUrl(url : string; param: string; method : string; AUTH:AnsiString; postData:UTF8String) :UTF8String;//Получение страницы по url +var + FHost,FScript : string; + hInternet,hConnect,hRequest : Pointer; + dwBytesRead,I,L : Cardinal; + Flags_connection,Flags_Request : Cardinal; + Flag_HttpSendRequest:LongBool; + header:TStringStream; +begin + result := ''; + fHost := GetHostName(url); + fScript := GetScriptName(url,fHost); + if Param <> '' then + if fScript[Length(fScript)] = '?' then + fScript := fScript + param + else + fScript := fScript + '?' + param; + //Устанавливаем флаги + SetFlags(url,Flags_connection,Flags_Request); + //Инициализируем WinInet + hInternet := InternetOpen(PChar(FAppName),INTERNET_OPEN_TYPE_PRECONFIG,Nil,Nil,0); + if Assigned(hInternet) then + begin + //Открываем сессию + hConnect := InternetConnect(hInternet,PChar(FHost),Flags_connection,nil,nil,INTERNET_SERVICE_HTTP,0,1); + if Assigned(hConnect) then + begin + //Формируем запрос + hRequest := HttpOpenRequest(hConnect,PChar(uppercase(method)),PChar(fScript),HTTP_VERSION,nil,Nil,Flags_Request,1); + if Assigned(hRequest) then + begin + header:=TStringStream.Create; + with Header do + begin + WriteString('Content-Type:application/atom+xml'+SLineBreak); + WriteString('GData-Version:2 '+SLineBreak); + WriteString('Authorization: GoogleLogin auth='+AUTH+SLineBreak+SLineBreak); + end; + //Отправляем запрос + I := 1; + if uppercase(method)='GET' then + begin + Flag_HttpSendRequest:=HttpSendRequest(hRequest,PChar(header.DataString),Length(header.DataString),nil,0); + if not Flag_HttpSendRequest then + ToError(rsErrorGet); + end; + if uppercase(method)='POST' then + begin + Flag_HttpSendRequest:=HttpSendRequest(hRequest,PChar(header.DataString),Length(header.DataString),Pointer(postData),Length(postData)); + if not Flag_HttpSendRequest then + ToError(rsErrorPost); + end; + if uppercase(method)='PUT' then + begin + Flag_HttpSendRequest:=HttpSendRequest(hRequest,PChar(header.DataString),Length(header.DataString),Pointer(postData),Length(postData)); + if not Flag_HttpSendRequest then + ToError(rsErrorPut); + end; + if uppercase(method)='DELETE' then + begin + Flag_HttpSendRequest:=HttpSendRequest(hRequest,PChar(header.DataString),Length(header.DataString),nil,0); + if not Flag_HttpSendRequest then + begin + OnError(rsErrorDelete); + Result:='0' + end + else + begin + Result:='1'; + end; + end; + if Flag_HttpSendRequest and (uppercase(method)<>'DELETE') then + begin + repeat + DataAvailable(hRequest, L);//Получаем кол-во принимаемых данных + if L = 0 then break; + SetLength(result,L + I); + if not (InternetReadFile(hRequest,@result[I],sizeof(L),dwBytesRead)) then //Получаем данные с сервера + begin + OnError(rsErrorGet); + end; + if Assigned(FProgress) then //прогресс + OnProgress(i,L+1); + inc(I,dwBytesRead); + until dwBytesRead = 0; + result[I] := #0; + end; + end; + InternetCloseHandle(hRequest); + end; + InternetCloseHandle(hConnect); + end; + InternetCloseHandle(hInternet); + header.Free; +end; + +{------------------------------------------------------------------------------- + Процедура: TBlogger.RetrievAllBlogs + Автор: NMD + Дата: 2010.08.03 21:13:59 + Входные параметры: Нет + Результат: получение списка блогов пользователя +-------------------------------------------------------------------------------} +procedure TBlogger.RetrievAllBlogs; +var + i,i2:Integer; + Nodes,NodesChild: TXmlNodeList; +begin + FBlogs.Clear;//очистка блогов перед получением нового списка + FXMLDoc.Clear; + FXMLDoc.ReadFromString(GetUrl(cnsBlogDefault,'','get',FAuth,'')); + //проверка на наличие данных + if FXMLDoc.IsEmpty then + begin + ToError(rsErrorIsEmpty); + Exit; + end; + //проверка на существование коллекции + if not Assigned(FBlogs) then Exit; + try + Nodes:=TXmlNodeList.Create; + FXMLDoc.Root.FindNodes('entry',Nodes); + for i := 0 to Nodes.Count-1 do + begin + FBlogs.Add; + FBlogs.Items[i].BlogId:=GetIdBlog(Nodes.Items[i].NodeByName(cnsId).ValueAsString); + FBlogs.Items[i].Publish:=Nodes.Items[i].NodeByName(cnsPublished).ValueAsDateTime; + FBlogs.Items[i].Update:=Nodes.Items[i].NodeByName(cnsUpdated).ValueAsDateTime; + FBlogs.Items[i].Title:=Nodes.Items[i].NodeByName(cnsTitle).ValueAsString; + NodesChild:=TXmlNodeList.Create; + Nodes.Items[i].FindNodes(cnsCategory,NodesChild); + for i2 := 0 to NodesChild.Count - 1 do + begin + FBlogs.Items[i].СategoryBlog.Add(NodesChild.Items[i2].AttributeByName[cntTerm]); + end; + end; + finally + FreeAndNil(Nodes); + FreeAndNil(NodesChild); + end; +end; + +//возвращает все комментарии текущего блога +function TBlogger.RetrievAllComments: TCommentCollection; +var + Nodes,NodesChild: TXmlNodeList; + i,i2:Integer; +begin + Result:=TCommentCollection.Create(nil); + FXMLDoc.Clear; + if FAuth<>'' then + begin//'http://www.blogger.com/feeds/9144819905011498730/posts/default' + //http://www.blogger.com/feeds/blogID/comments/default + if FCurrentBlog>-1 then + FXMLDoc.ReadFromString(GetUrl(cnsPostBlogStart+Blogs.Items[FCurrentBlog].FBlogId+cnsCommentsEnd,'','get',FAuth,'')) + else + ToError(rsErrorNotSelectBlog); + end + else + begin + ToError(rsErrorNotTolken); + Exit;////////ИСПРАВИТЬ!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + end; + //проверка на наличие данных + if FXMLDoc.IsEmpty then + begin + ToError(rsErrorIsEmpty); + Exit; + end; + + Nodes:=TXmlNodeList.Create; + FXMLDoc.Root.FindNodes(cnsEntry,Nodes);// + for i := 0 to Nodes.Count-1 do + begin + Result.Add; + Result.Items[i].CommentId:=GetCommentId(Nodes.Items[i].NodeByName(cnsId).ValueAsString);//id комментария + Result.Items[i].CommentTitle:=Nodes.Items[i].NodeByName(cnsTitle).ValueAsString;//заголовок + Result.Items[i].CommentSourse.Add(Nodes.Items[i].NodeByName(cnsContent).ValueAsString);//текст комментария + Result.Items[i].CommentPublished:=Nodes.Items[i].NodeByName(cnsPublished).ValueAsDateTime;// дата публикации комментария + Result.Items[i].CommentUpdate:=Nodes.Items[i].NodeByName(cnsUpdated).ValueAsDateTime;// дата обновления комментария + + NodesChild:=TXmlNodeList.Create; + Nodes.Items[i].FindNodes(cnsAuthor,NodesChild); + for i2 := 0 to NodesChild.Count - 1 do + begin + Result.Items[i].CommentAutorName:=NodesChild.Items[i2].NodeByName(cnsName).ValueAsString;//имя автора + if NodesChild.Items[i2].NodeByName(cnsName).ValueAsString<>cnsAnonymous then//у анонимных людей нет профиля)) + Result.Items[i].CommentAutorURL:=NodesChild.Items[i2].NodeByName(cnsURl).ValueAsString //профиль автора + else + Result.Items[i].CommentAutorURL:=cnsAnonymous; + Result.Items[i].CommentAutorEmail:=NodesChild.Items[i2].NodeByName(cnsEmail).ValueAsString;//адрес электронной почты автора + end; + FreeAndNil(NodesChild); + end; +end; + +{------------------------------------------------------------------------------- + Функция: TBlogger.RetrievAllPosts + Автор: NMD + Дата: 2010.08.09 + Входные параметры: Нет + Что делает: получает последние 25 сообщений из блога + Результат: Коллекция TPostCollection содержащая исчерпывающую информацию о сообщении и само сообщение +-------------------------------------------------------------------------------} +function TBlogger.RetrievAllPosts: TPostCollection; +var + Nodes,NodesChild: TXmlNodeList; + i,i2:Integer; +begin + Result:=TPostCollection.Create(nil); + FXMLDoc.Clear; + if FAuth<>'' then + begin//'http://www.blogger.com/feeds/9144819905011498730/posts/default' + if FCurrentBlog>-1 then + FXMLDoc.ReadFromString(GetUrl(cnsPostBlogStart+Blogs.Items[FCurrentBlog].FBlogId+cnsPostBlogEnd,'','get',FAuth,'')) + else + begin + ToError(rsErrorNotSelectBlog); + Exit; + end; + end + else + begin + ToError(rsErrorNotTolken); + Exit; + end; + //проверка на наличие данных + if FXMLDoc.IsEmpty then + begin + ToError(rsErrorIsEmpty); + Exit; + end; + + Nodes:=TXmlNodeList.Create; + FXMLDoc.Root.FindNodes(cnsEntry,Nodes); + for i := 0 to Nodes.Count-1 do + begin + Result.Add; + Result.Items[i].PostId:=GetPostId(Nodes.Items[i].NodeByName(cnsId).ValueAsString); + Result.Items[i].PostTitle:=Nodes.Items[i].NodeByName(cnsTitle).ValueAsString; + Result.Items[i].PostSourse.Add(Nodes.Items[i].NodeByName(cnsContent).ValueAsString); + Result.Items[i].PostPublished:=Nodes.Items[i].NodeByName(cnsPublished).ValueAsDateTime; + Result.Items[i].PostUpdate:=Nodes.Items[i].NodeByName(cnsUpdated).ValueAsDateTime; + NodesChild:=TXmlNodeList.Create; + Nodes.Items[i].FindNodes(cnsCategory,NodesChild); + for i2 := 0 to NodesChild.Count - 1 do + begin + Result.Items[i].СategoryPost.Add(NodesChild.Items[i2].AttributeByName[cntTerm]); + end; + end; +end; + +{------------------------------------------------------------------------------- + Функция: TBlogger.RetrievPostForTextParams + Автор: NMD + Дата: 2010.08.10 21:09:02 + Входные параметры: + Parametrs параметры запроса постов из блога + Что делает: Возвращает посты из блога по заданным параметрам созданым в ручную + Результат: Список постов в коллекции TPostCollection + Необходимо забивать только параметры после знака вопроса + http://www.blogger.com/feeds/9144819905011498730/posts/default?category=Application + то есть category=Application +-------------------------------------------------------------------------------} +function TBlogger.RetrievPostForTextParams(Parametrs:string): TPostCollection; +var + Nodes,NodesChild: TXmlNodeList; + i,i2:Integer; +begin + Result:=TPostCollection.Create(nil); + FXMLDoc.Clear; + if FAuth<>'' then + begin + if FCurrentBlog>-1 then + FXMLDoc.ReadFromString(GetUrl(cnsPostBlogStart+Blogs.Items[FCurrentBlog].FBlogId+cnsPostBlogEnd+parametrs,'','get',FAuth,'')) + else + begin + ToError(rsErrorNotSelectBlog); + Exit; + end; + end + else + begin + ToError(rsErrorNotTolken); + Exit; + end; + //проверка на наличие данных + if FXMLDoc.IsEmpty then + begin + ToError(rsErrorIsEmpty); + Exit; + end; + + Nodes:=TXmlNodeList.Create; + FXMLDoc.Root.FindNodes(cnsEntry,Nodes); + for i := 0 to Nodes.Count-1 do + begin + Result.Add; + Result.Items[i].PostId:=GetPostId(Nodes.Items[i].NodeByName(cnsId).ValueAsString); + Result.Items[i].PostTitle:=Nodes.Items[i].NodeByName(cnsTitle).ValueAsString; + Result.Items[i].PostSourse.Add(Nodes.Items[i].NodeByName(cnsContent).ValueAsString); + Result.Items[i].PostPublished:=Nodes.Items[i].NodeByName(cnsPublished).ValueAsDateTime; + Result.Items[i].PostUpdate:=Nodes.Items[i].NodeByName(cnsUpdated).ValueAsDateTime; + NodesChild:=TXmlNodeList.Create; + Nodes.Items[i].FindNodes(cnsCategory,NodesChild); + for i2 := 0 to NodesChild.Count - 1 do + begin + Result.Items[i].СategoryPost.Add(NodesChild.Items[i2].AttributeByName[cntTerm]); + end; + end; +end; + +{------------------------------------------------------------------------------- + Функция: TBlogger.RetrievPostForParams + Автор: NMD + Дата: 2010.08.10 19:39:25 + Входные параметры: + aAlt atom(default),rss + aCategory Посты определенной категории + aOrderby Задаем порядок постов в котором мы их получим в список постов lastmodified (the default), starttime, or updated. + aPublishedMin Ограничение на дату публикации. Игнорируется если orderby установлен в updated + APublishedMax Ограничение на дату публикации. Игнорируется если orderby установлен в updated + aUpdatedMin Ограничение на дату публикации. Игнорируется если orderby установлен в updated + aUpdatedMax Ограничение на дату публикации. Игнорируется если orderby установлен в updated + aStartIndex Индекс поста который будет получен первым (для докачки постов) + aMaxResults Максимальное кол-во возвращаемых постов + Что делает: Возвращает посты из блога по заданным параметрам + Результат: Список постов в коллекции TPostCollection + Пример + http://www.blogger.com/feeds/9144819905011498730/posts/default?category=Application&max-results=10&start-index=1&published-min=2008-03-16T00:00:00&published-max=2011-03-24T23:59:59 +-------------------------------------------------------------------------------} +function TBlogger.RetrievPostForParams(aCategory:string =''; aOrderby:string =''; aPublishedMin:string =''; + aPublishedMax:string =''; aUpdatedMin:string ='';aUpdatedMax:string =''; + aStartIndex:Integer=0; aMaxResults:Integer=0; aAlt : string =''): TPostCollection; +var + i:Integer; + temp:TStringList; + parametrs:string; +begin + Result:=TPostCollection.Create(nil); + if FAuth='' then + begin + ToError(rsErrorNotTolken); + Exit; + end; + if FCurrentBlog<0 then + begin + ToError(rsErrorNotSelectBlog); + Exit; + end; + parametrs:=''; + temp:=TStringList.Create; + if aAlt<>'' then + temp.Add('alt='+aAlt); + if aCategory<>'' then + temp.Add('category='+aCategory); + if aOrderby<>'' then + temp.Add('orderby='+aOrderby); + if aPublishedMin<>'' then + temp.Add('published-min='+aPublishedMin); + if APublishedMax<>'' then + temp.Add('published-max='+aPublishedMax); + if aUpdatedMin<>'' then + temp.Add('updated-min='+aUpdatedMin); + if aUpdatedMax<>'' then + temp.Add('updated-max='+aUpdatedMax); + if aStartIndex<>0 then + temp.Add('start-index='+IntToStr(aStartIndex)); + if aMaxResults<>0 then + temp.Add('max-results='+IntToStr(aMaxResults)); + for I := 0 to temp.Count - 1 do + begin + if i>0 then + parametrs:=parametrs+'&'+temp.Strings[i] + else + parametrs:=parametrs+temp.Strings[i]; + end; + temp.Free; + Result:=RetrievPostForTextParams(cnsVop+parametrs); +end; + +{------------------------------------------------------------------------------- + Процедура: TBlogger.CreatPost формируем xml будущего сообщения и отправляем его в блог + Автор: NMD + Дата: 2010.08.06 18:37:01 + Входные параметры: + aTitle- заголовок, + aContent-текст сообщения: string; + aCategory-ярлыки сообщения: TStringList; + aComment: Boolean комментарий или нет + Результат: string получаем xml отправленной статьи но уже из блогга или текст ошибки +-------------------------------------------------------------------------------} +function TBlogger.PostCreat(aTitle, aContent: string; aCategory: TStringList; aComment: Boolean):UTF8String; +var + i:Integer; + Node,Node2:TXmlNode; + tempXML :TNativeXml; +begin + Result:=''; + if FAuth='' then + begin + ToError(rsErrorNotTolken); + Exit; + end; + if FCurrentBlog<0 then + begin + ToError(rsErrorNotSelectBlog); + Exit; + end; + + FXMLDoc.Clear; + FXMLDoc.Root.CreateName(FXMLDoc,cnsEntry).AttributeAdd(cnsXmlns,cnsAtomUrl); + { + yes + } + if aComment then + begin + Node:=FXMLDoc.Root.NodeNew(cnsAppControll); + Node.AttributeAdd(cnsXmlnsApp,cnsXmlnsAppUrl); + Node2:=TXmlNode.CreateNameValue(FXMLDoc,cnsAppDraft,cnsYes); + Node.NodeAdd(Node2); + end; + + //Marriage! + with FXMLDoc.Root.NodeNew(cnsTitle)do + begin + AttributeAdd(cnsType,cnsText); + ValueAsString:=aTitle; + end; + // + Node:=FXMLDoc.Root.NodeNew(cnsContent); + Node.AttributeAdd(cnsType,cnsXhtml); + //сам контент единственное он должен быть валидным html + tempXML:=TNativeXml.Create; + try + tempXML.ReadFromString(aContent); + except + ToError(rsErrorXmlTag); + tempXML:=nil; + Exit;//выход + end; + for I := 0 to tempXML.RootNodeList.NodeCount - 1 do + begin + node2:=tempXML.RootNodeList.Nodes[i]; + node.NodeAdd(node2); + end; +{ //
+ Node2:=TXmlNode.CreateName(FXMLDoc,cnsDiv); + Node2.AttributeAdd(cnsXmlns,cnsXhtmlUrl); + Node.NodeAdd(Node2); + Node:=TXmlNode.CreateName(FXMLDoc,'p'); + Node.ValueAsString:=aContent; + Node2.NodeAdd(Node); +} + // + for i := 0 to aCategory.Count - 1 do + with FXMLDoc.Root.NodeNew(cnsCategory) do + begin + AttributeAdd(cnsScheme,cnsAtnsUrl); + AttributeAdd(cnsTerm,sdAnsiToUtf8(aCategory.Strings[i])); + end; + Result:=GetUrl(cnsPostBlogStart+Blogs.Items[FCurrentBlog].FBlogId+cnsPostBlogEnd,'','post',FAuth,FXMLDoc.WriteToString); + tempXML:=nil; +end; + +{------------------------------------------------------------------------------- + Функция: TBlogger.PostModify + Автор: NMD + Дата: 2010.08.10 21:28:47 + Входные параметры: + id сообщения, остальное анологично созданию поста + Что делает: Производит обновление поста в блоге + Результат: xml модифицированного сообщения +-------------------------------------------------------------------------------} +function TBlogger.PostModify(id, aTitle, aContent: string; aCategory: TStringList; aComment: Boolean): UTF8String; +var + i:Integer; + Node,Node2:TXmlNode; + blogId:string; +begin + Result:=''; + if FAuth='' then + begin + ToError(rsErrorNotTolken); + Exit; + end; + if FCurrentBlog<0 then + begin + ToError(rsErrorNotSelectBlog); + Exit; + end; + FXMLDoc.Clear; + FXMLDoc.Root.CreateName(FXMLDoc,cnsEntry).AttributeAdd(cnsXmlns,cnsAtomUrl); + + { + yes + } + if aComment then + begin + Node:=FXMLDoc.Root.NodeNew(cnsAppControll); + Node.AttributeAdd(cnsXmlnsApp,cnsXmlnsAppUrl); + Node2:=TXmlNode.CreateNameValue(FXMLDoc,cnsAppDraft,cnsYes); + Node.NodeAdd(Node2); + end; + // tag:blogger.com,1999:blog-blogID.post-postID + blogId:=IntToStr(FBlogs.Items[FCurrentBlog].id);//id блога + FXMLDoc.Root.NodeNew(cnsId).ValueAsString:='tag:blogger.com,1999:blog-'+blogId+'.post-'+id; + //Marriage! + with FXMLDoc.Root.NodeNew(cnsTitle)do + begin + AttributeAdd(cnsType,cnsText); + ValueAsString:=aTitle; + end; + // + Node:=FXMLDoc.Root.NodeNew(cnsContent); + Node.AttributeAdd(cnsType,cnsXhtml); + //
+ Node2:=TXmlNode.CreateName(FXMLDoc,cnsDiv); + Node2.AttributeAdd(cnsXmlns,cnsXhtmlUrl); + Node.NodeAdd(Node2); + Node:=TXmlNode.CreateName(FXMLDoc,'p'); + Node.ValueAsString:=aContent; + Node2.NodeAdd(Node); + + // + for i := 0 to aCategory.Count - 1 do + with FXMLDoc.Root.NodeNew(cnsCategory) do + begin + AttributeAdd(cnsScheme,cnsAtnsUrl); + AttributeAdd(cnsTerm,sdAnsiToUtf8(aCategory.Strings[i])); + end; + //'http://www.blogger.com/feeds/1897581382578917834/posts/default/5129237316807356045', + Result:=GetUrl(cnsPostBlogStart+Blogs.Items[FCurrentBlog].FBlogId+cnsPostBlogEnd+'/'+id,'','put',FAuth,FXMLDoc.WriteToString); +end; + +{------------------------------------------------------------------------------- + Функция: TBlogger.PostDelete + Автор: NMD + Дата: 2010.08.11 19:24:17 + Входные параметры: + id сообщения которое необходимо удалить + Что делает: удаление поста из блога + Результат: Boolean +-------------------------------------------------------------------------------} +function TBlogger.PostDelete(id: string): Boolean; +begin + if FAuth='' then + begin + ToError(rsErrorNotTolken); + Exit; + end; + if FCurrentBlog<0 then + begin + ToError(rsErrorNotSelectBlog); + Exit; + end; + if id='' then + begin + ToError(rsErrorIdPost); + Exit; + end; + if GetUrl(cnsPostBlogStart+Blogs.Items[FCurrentBlog].FBlogId+cnsPostBlogEnd+'/'+id,'','DELETE',FAuth,'')='1' then + Result:=True + else + Result:=False; +end; + + +procedure TBlogger.SetAppName(const Value: string); +begin + if Value<>'' then + FAppName := Value; +end; + +procedure TBlogger.SetAuth(const Value: string); +begin + if Value<>'' then + begin + FAuth := Value; + end; +end; + +procedure TBlogger.SetBlog(const Value: TBlogCollection); +begin + FBlogs.Assign(Value); +end; + +procedure TBlogger.SetCurrentBlog(const Value: Integer); +begin + FCurrentBlog := Value; +end; + +{BlogCollection} +function TBlogCollection.Add: TBlogItem; +begin + result := TBlogItem(inherited Add); +end; + +function TBlogCollection.AddEx(aName, aTitle,aBlogId: string; aUrl: string; aСategoryBlog: TStringList; aPublished, + aUpdate: TDateTime): TBlogItem; +begin + result := inherited Add as TBlogItem; + Result.FTitle:=aTitle; + Result.FBlogId:=aBlogId; + Result.FСategoryBlog.Assign(aСategoryBlog); + Result.FPublished:=aPublished; + Result.FUpdate:=aUpdate; +end; + +constructor TBlogCollection.Create(AOwner: TComponent); +begin + inherited Create(TBlogItem); +end; + +function TBlogCollection.GetItemBlog(Index: Integer): TBlogItem; +begin + result := TBlogItem(inherited GetItem(Index)); +end; + +procedure TBlogCollection.SetItemBlog(Index: Integer; Value: TBlogItem); +begin + inherited SetItem(Index, Value) +end; + +constructor TBlogItem.Create(Collection: TCollection); +begin + inherited; + FTitle:=''; + FBlogId:=''; + FСategoryBlog:=TStringList.Create;//ярлыки блога + FPublished:=Time;//дата последеней публикации + FUpdate:=Time;//дата последнего обновления +end; + +destructor TBlogItem.Destroy; +begin + FСategoryBlog.Destroy; + inherited; +end; + +procedure TBlogItem.SetCategory(const Value: TStringList); +begin + FСategoryBlog.Assign(Value); +end; + +procedure TBlogItem.SetBlogId(const Value: string); +begin + FBlogId := Value; +end; + +procedure TBlogItem.SetPublished(const Value: TDateTime); +begin + FPublished := Value; +end; + +procedure TBlogItem.SetTitle(const Value: string); +begin + FTitle := Value; +end; + +procedure TBlogItem.SetUpdate(const Value: TDateTime); +begin + FUpdate := Value; +end; + +{ TPostItem } + +constructor TPostItem.Create(Collection: TCollection); +begin + inherited; + FPostSourse:=TStringList.Create; + FСategoryPost:=TStringList.Create; +end; + +destructor TPostItem.Destroy; +begin + FPostSourse.Free; + FСategoryPost.Free; + inherited; +end; + +procedure TPostItem.SetPostId(const Value: string); +begin + FPostId := Value; +end; + +procedure TPostItem.SetPostPublished(const Value: TDateTime); +begin + FPostPublished := Value; +end; + +procedure TPostItem.SetPostSourse(const Value: TStringList); +begin + FPostSourse.Assign(Value); +end; + +procedure TPostItem.SetPostTitle(const Value: string); +begin + FPostTitle := Value; +end; + +procedure TPostItem.SetPostUpdate(const Value: TDateTime); +begin + FPostUpdate:=Value; +end; + +procedure TPostItem.SetСategoryPost(const Value: TStringList); +begin + FСategoryPost.Assign(Value); +end; + +{ TPostCollection } + +function TPostCollection.Add: TPostItem; +begin + result := TPostItem(inherited Add); +end; + +function TPostCollection.AddEx(aPostTitle, aPostId: string; aPostSourse: TStringList; aPostPublished, + aPostUpdate: TDateTime): TPostItem; +begin + result := inherited Add as TPostItem; + Result.FPostTitle:=aPostTitle; + Result.FPostId:=aPostId; + Result.FPostSourse.Assign(aPostSourse); + Result.FPostPublished:=aPostPublished; + Result.FPostUpdate:=aPostUpdate; +end; + +constructor TPostCollection.Create(AOwner: TComponent); +begin + inherited Create(TPostItem); +end; + +function TPostCollection.GetItemBlog(Index: Integer): TPostItem; +begin + result := TPostItem(inherited GetItem(Index)); +end; + +procedure TPostCollection.SetItemBlog(Index: Integer; Value: TPostItem); +begin + inherited SetItem(Index, Value); +end; + +procedure Register; +begin + RegisterComponents('WebDelphi.ru', [TBlogger]); +end; + +{ TCommentItem } + +constructor TCommentItem.Create(Collection: TCollection); +begin + inherited; + FCommentSourse:=TStringList.Create; +end; + +destructor TCommentItem.Destroy; +begin + FCommentSourse.Free; + inherited; +end; + +procedure TCommentItem.SetCommentAutorEmail(const Value: string); +begin + FAutorEmail := Value; +end; + +procedure TCommentItem.SetCommentAutorName(const Value: string); +begin + FAutorName := Value; +end; + +procedure TCommentItem.SetCommentAutorURL(const Value: string); +begin + FAutorURL := Value; +end; + +procedure TCommentItem.SetCommentId(const Value: string); +begin + FCommentId:=Value; +end; + +procedure TCommentItem.SetCommentPublished(const Value: TDateTime); +begin + FCommentPublished:=Value; +end; + +procedure TCommentItem.SetCommentSourse(const Value: TStringList); +begin + FCommentSourse.Assign(Value); +end; + +procedure TCommentItem.SetCommentTitle(const Value: string); +begin + FCommentTitle:=Value; +end; + +procedure TCommentItem.SetCommentUpdate(const Value: TDateTime); +begin + FCommentUpdate:=Value; +end; + +{ TCommentCollection } + +function TCommentCollection.Add: TCommentItem; +begin + result := TCommentItem(inherited Add); +end; + +function TCommentCollection.AddEx(aCommentTitle, aCommentId: string; aCommentSourse: TStringList; aCommentPublished, + aCommentUpdate: TDateTime; aAutorName, aAutorEmail, aAutorURL: string): TCommentItem; +begin + result := inherited Add as TCommentItem; + Result.FCommentTitle:=aCommentTitle; + Result.FCommentId:=aCommentId; + Result.FCommentSourse.Assign(aCommentSourse); + Result.FCommentPublished:=aCommentPublished; + Result.FCommentUpdate:=aCommentUpdate; + Result.FAutorName:=aAutorName; + Result.FAutorEmail:=aAutorEmail; + Result.FAutorURL:=aAutorURL; +end; + +constructor TCommentCollection.Create(AOwner: TComponent); +begin + inherited Create(TCommentItem); +end; + +function TCommentCollection.GetItemComment(Index: Integer): TCommentItem; +begin + result := TCommentItem(inherited GetItem(Index)); +end; + +procedure TCommentCollection.SetItemComment(Index: Integer; Value: TCommentItem); +begin + inherited SetItem(Index, Value); +end; + +end. + diff --git a/packages/googleLogin_pack/GoogleLogin.dpk b/packages/BloggerApi_Pack.dpk similarity index 81% rename from packages/googleLogin_pack/GoogleLogin.dpk rename to packages/BloggerApi_Pack.dpk index 277156e..1a50319 100644 --- a/packages/googleLogin_pack/GoogleLogin.dpk +++ b/packages/BloggerApi_Pack.dpk @@ -1,4 +1,4 @@ -package GoogleLogin; +package BloggerApi_Pack; {$R *.res} {$ALIGN 8} @@ -14,7 +14,7 @@ package GoogleLogin; {$OPTIMIZATION ON} {$OVERFLOWCHECKS OFF} {$RANGECHECKS OFF} -{$REFERENCEINFO OFF} +{$REFERENCEINFO ON} {$SAFEDIVIDE OFF} {$STACKFRAMES OFF} {$TYPEDADDRESS OFF} @@ -26,10 +26,12 @@ package GoogleLogin; requires rtl, - vcl, - vclimg; + vcl; contains - uGoogleLogin in 'uGoogleLogin.pas'; + BloggerApi in 'BloggerApi.pas'; end. + + + diff --git a/packages/BloggerApi_Pack.res b/packages/BloggerApi_Pack.res new file mode 100644 index 0000000..654f9b6 Binary files /dev/null and b/packages/BloggerApi_Pack.res differ diff --git a/packages/feedburner_pack/FeedBurner_pack.dpk b/packages/feedburner_pack/FeedBurner_pack.dpk deleted file mode 100644 index ab61974..0000000 --- a/packages/feedburner_pack/FeedBurner_pack.dpk +++ /dev/null @@ -1,35 +0,0 @@ -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 deleted file mode 100644 index 6a21aa2..0000000 --- a/packages/feedburner_pack/FeedBurner_pack.dproj +++ /dev/null @@ -1,109 +0,0 @@ -п»ї - - {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/feedburner_pack/FeedBurner_pack.res b/packages/feedburner_pack/FeedBurner_pack.res deleted file mode 100644 index fc1937e..0000000 Binary files a/packages/feedburner_pack/FeedBurner_pack.res and /dev/null differ diff --git a/packages/gmail_pack/GMailSMTP.pas b/packages/gmail_pack/GMailSMTP.pas deleted file mode 100644 index ff909fb..0000000 --- a/packages/gmail_pack/GMailSMTP.pas +++ /dev/null @@ -1,285 +0,0 @@ -п»ї{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 deleted file mode 100644 index 1dcbd73..0000000 --- a/packages/gmail_pack/gmail_pack.dpk +++ /dev/null @@ -1,40 +0,0 @@ -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 deleted file mode 100644 index f3f54af..0000000 --- a/packages/gmail_pack/gmail_pack.dproj +++ /dev/null @@ -1,115 +0,0 @@ -п»ї - - {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/gmail_pack/gmail_pack.res b/packages/gmail_pack/gmail_pack.res deleted file mode 100644 index 7940876..0000000 Binary files a/packages/gmail_pack/gmail_pack.res and /dev/null differ diff --git a/packages/googleLogin_pack/GoogleLogin.dproj b/packages/googleLogin_pack/GoogleLogin.dproj deleted file mode 100644 index 253d7d1..0000000 --- a/packages/googleLogin_pack/GoogleLogin.dproj +++ /dev/null @@ -1,110 +0,0 @@ -п»ї - - {DA3343F7-B6E3-4BC9-B427-4D5119728B14} - GoogleLogin.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:\Documents and Settings\All Users\Документы\RAD Studio\7.0\Bpl\GoogleLogin.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 - - - - GoogleLogin.dpk - - - - True - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 1049 - 1251 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - - - True - - - 12 - - diff --git a/packages/googleLogin_pack/GoogleLogin.identcache b/packages/googleLogin_pack/GoogleLogin.identcache deleted file mode 100644 index 2c2ce82..0000000 Binary files a/packages/googleLogin_pack/GoogleLogin.identcache and /dev/null differ diff --git a/packages/googleLogin_pack/GoogleLogin.res b/packages/googleLogin_pack/GoogleLogin.res deleted file mode 100644 index ee38ccb..0000000 Binary files a/packages/googleLogin_pack/GoogleLogin.res and /dev/null differ diff --git a/packages/googleLogin_pack/uGoogleLogin.pas b/packages/googleLogin_pack/uGoogleLogin.pas deleted file mode 100644 index 1a9a3a6..0000000 --- a/packages/googleLogin_pack/uGoogleLogin.pas +++ /dev/null @@ -1,608 +0,0 @@ -п»їunit uGoogleLogin; - -interface - -uses WinInet, Graphics, Classes, Windows, TypInfo,jpeg, SysUtils; - -resourcestring - rcNone = 'Аутентификация РЅРµ производилась или сброшена'; - rcOk = 'Аутентификация прошла успешно'; - rcBadAuthentication = 'РќРµ удалось распознать РёРјСЏ пользователя или пароль, использованные РІ запросе РЅР° РІС…РѕРґ'; - rcNotVerified = 'Адрес электронной почты, связанный СЃ аккаунтом, РЅРµ был подтвержден'; - rcTermsNotAgreed = 'Пользователь РЅРµ РїСЂРёРЅСЏР» условия использования службы'; - rcCaptchaRequired = 'Требуется ответ РЅР° тест CAPTCHA'; - rcUnknown = 'Неизвестная ошибка'; - rcAccountDeleted = 'Аккаунт этого пользователя удален'; - rcAccountDisabled = 'Аккаунт этого пользователя отключен'; - rcServiceDisabled = 'Доступ пользователя Рє указанной службе запрещен'; - rcServiceUnavailable = 'Служба недоступна, повторите попытку позже'; - rcDisconnect = 'Соединение СЃ сервером разорвано'; - // ошибки соединения - rcErrServer = 'РќР° сервере произошла ошибка #'; - rcErrDont = 'РќРµ РјРѕРіСѓ получить описание ошибки'; - -const - DefaultAppName ='My-Application'; - - 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; - -type - TAccountType = (atNone, atGOOGLE, atHOSTED, atHOSTED_OR_GOOGLE); - -type - TLoginResult = (lrNone, lrOk, lrBadAuthentication, lrNotVerified, - lrTermsNotAgreed, lrCaptchaRequired, lrUnknown, lrAccountDeleted, - lrAccountDisabled, lrServiceDisabled, lrServiceUnavailable); - -type - TServices = (xapi, analytics, apps, gbase, jotspot, blogger, print, cl, - codesearch, cp, writely, finance, mail, health, local, lh2, annotateweb, - wise, sitemaps, youtube, gtrans,urlshortener); -type - TResultRec = packed record - 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; - TProgressAutorization = procedure(const Progress,MaxProgress:Integer)of object; - TErrorAutorization = procedure(const ErrorStr: string) of object; - TDisconnect = procedure(const ResultStr: string) of object; - -type - TGoogleLoginThread = class(TThread) - private - FParentComp:TComponent; - { private declarations } - 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; - 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; - protected - { protected declarations } - procedure Execute; override; - public - { public declarations } - 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 - FAppname: string; - FAccountType: TAccountType; - FLastResult: TLoginResult; - FEmail: string; - FPassword: string; - FService: TServices; - FCaptcha: string; - FCapchaToken: string; - FAfterLogin: TAutorization; - FAutorizCaptcha:TAutorizCaptcha; - FProgressAutorization:TProgressAutorization; - FErrorAutorization: TErrorAutorization; - FDisconnect: TDisconnect; - 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; - function URLEncode(const S: string): string; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; - procedure Login(aLoginToken: string = ''; aLoginCaptcha: string = ''); - procedure Disconnect; - property CapchaToken: string read FCapchaToken; - 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 Captcha: string read FCaptcha write SetCaptcha; - property Service: TServices read FService write SetService default xapi; - 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; - -procedure Register; - -implementation - -procedure Register; -begin - RegisterComponents('BuBa Group', [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; - FCapchaToken := ''; - FCaptcha := ''; - if Assigned(FDisconnect) then - OnDisconnect(rcDisconnect) -end; - -destructor TGoogleLogin.Destroy; -begin - inherited Destroy; -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 -try - 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),Integer(FService)) + '&'); - - if Length(Trim(FAppname)) > 0 then - cBody.WriteString('source=' + FAppname) - else - cBody.WriteString('source=' + DefaultAppName); - if (Length(Trim(aLoginToken)) > 0) or (Length(Trim(aLoginCaptcha))>0) then - begin - cBody.WriteString('&logintoken=' + aLoginToken); - cBody.WriteString('&logincaptcha=' + aLoginCaptcha); - end; - 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; -end; - -procedure TGoogleLogin.SetAppName(value: string); -begin - if not(value = '') then - FAppname := value - else - FAppname := DefaultAppName; -end; - -procedure TGoogleLogin.SetCaptcha(cCaptcha: string); -begin - FCaptcha := cCaptcha; - Login(FCapchaToken, FCaptcha); -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.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;aParentComp:TComponent); -begin - inherited Create(CreateSuspennded); - FParentComp:=TComponent.Create(nil); - FParentComp:=aParentComp; - FParamStr := aParamStr; - FResultRec.LoginStr := ''; - FResultRec.SID := ''; - FResultRec.LSID := ''; - FResultRec.Auth := ''; - FProgress:=0; - FMaxProgress:=0; - FCaptchaPic:=TPicture.Create; -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; - FProgress:=i; - if FMaxProgress=0 then - FMaxProgress:=L+1; - Synchronize(SynProgressAutoriz); - 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; - if FLastResult=lrCaptchaRequired then - begin - LoadCaptcha(FCaptchaURL); - Synchronize(SynCaptcha); - Synchronize(SynCapchaToken); - end; - if FLastResult<>lrCaptchaRequired then - begin - Synchronize(SynAutoriz); - end; -end; - -function TGoogleLoginThread.ExpertLoginResult(const LoginResult: string) - : TLoginResult; -var - List: TStringList; - i: Integer; -begin -try - 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); - FCapthaToken := 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; -finally - FreeAndNil(List); -end; -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; - -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(GetEnumValue(TypeInfo(TLoginResult),'lr'+ErrorText)); -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; - -function TGoogleLoginThread.LoadCaptcha(aCaptchaURL: string): Boolean; - 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; - memStream: TMemoryStream; - jpegimg: TJPEGImage; - url:string; -begin - Result:=False;; - url:='http://www.google.com/accounts/'+aCaptchaURL; - hInternet := InternetOpen('GoogleLogin', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); - try - if Assigned(hInternet) then - begin - hConnect := InternetOpenUrl(hInternet, PChar(url), nil, 0, 0, 0); - if Assigned(hConnect) then - try - i := 1; - repeat - SetLength(sTemp, L + i); - if not InternetReadFile(hConnect, @sTemp[i], sizeof(L),dwBytesRead) then - break; - inc(i, dwBytesRead); - until dwBytesRead = 0; - finally - InternetCloseHandle(hConnect); - end; - end; - finally - InternetCloseHandle(hInternet); - end; - memStream := TMemoryStream.Create; - jpegimg := TJPEGImage.Create; - try - memStream.Write(sTemp[1], Length(sTemp)); - memStream.Position := 0; - jpegimg.LoadFromStream(memStream); - FCaptchaPic.Assign(jpegimg); - finally - memStream.Free; - jpegimg.Free; - end; - Result:=True; -end; - -procedure TGoogleLoginThread.SynAutoriz; -begin - if Assigned(FAutorization) then - OnAutorization(FLastResult, FResultRec); -end; - -procedure TGoogleLoginThread.SynCapchaToken; -begin - if Assigned(FParentComp) then - TGoogleLogin(FParentComp).FCapchaToken:=Self.FCapthaToken; -end; - -procedure TGoogleLoginThread.SynCaptcha; -begin - if Assigned(FAutorizCaptcha) then - OnAutorizCaptcha(FCaptchaPic); -end; - -procedure TGoogleLoginThread.SynErrAutoriz; -begin - if Assigned(FErrorAutorization) then - OnError(GetErrorText(true)); -end; - -procedure TGoogleLoginThread.SynProgressAutoriz; -begin - if Assigned(FProgressAutorization) then - OnProgressAutorization(FProgress,FMaxProgress); -end; - -end. diff --git a/packages/translator_pack/Translator_pack.dpk b/packages/translator_pack/Translator_pack.dpk deleted file mode 100644 index 487cdb9..0000000 --- a/packages/translator_pack/Translator_pack.dpk +++ /dev/null @@ -1,35 +0,0 @@ -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 deleted file mode 100644 index a268786..0000000 --- a/packages/translator_pack/Translator_pack.dproj +++ /dev/null @@ -1,113 +0,0 @@ -п»ї - - {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 deleted file mode 100644 index 7940876..0000000 Binary files a/packages/translator_pack/Translator_pack.res and /dev/null differ diff --git a/source/GCalendar.pas b/source/GCalendar.pas deleted file mode 100644 index bb78eba..0000000 --- a/source/GCalendar.pas +++ /dev/null @@ -1,1425 +0,0 @@ -unit GCalendar; - -interface - -uses WinInet, GData, Graphics, strutils, httpsend, GHelper, XMLIntf, - GoogleLogin, Windows, SysUtils, Variants, Classes, Dialogs, - StdCtrls, NativeXML,xmldoc, xmldom, Generics.Collections, msxml, GDataCommon; - -const - ClProtocolVer = '2.0'; - - AllCelendarsLink ='http://www.google.com/calendar/feeds/default/allcalendars/full'; - OwnerCelendarLink ='http://www.google.com/calendar/feeds/default/owncalendars/full'; - - cgCalTagNames: array [0 .. 15] of string = ('gCal:accesslevel', 'gCal:color', - 'gCal:hidden', 'gCal:selected', 'gCal:settingsProperty', 'gCal:sequence', - 'gCal:suppressReplyNotifications', 'gCal:syncEvent', 'gCal:timezone', - 'gCal:timesCleaned', 'gCal:uid', 'gCal:webContent', - 'gCal:webContentGadgetPrefss', 'gCal:guestsCanModify', - 'gCal:guestsCanInviteOthers', 'gCal:guestsCanSeeGuests'); - - clEventRequareTags :array [0..19]of string=('id', - 'published','updated','title','link','content','author','gd:eventStatus', - 'gd:where','gd:who','gd:when','gd:recurrence','gd:reminder', - 'gd:transparency','gd:visibility','gCal:guestsCanInviteOthers', - 'gCal:guestsCanModify','gCal:guestsCanSeeGuests','gCal:sequence','gCal:uid'); - -type - TgCalEnum = (egCalaccesslevel, egCalcolor, egCalhidden, egCalselected, - egCalsettingsProperty, egCalsequence, egCalsuppressReplyNotifications, - egCalsyncEvent, egCaltimezone, egCaltimesCleaned, egCaluid, - egCalwebContent, egCalwebContentGadgetPrefss, egCalguestsCanModify, - egCalguestsCanInviteOthers, egCalguestsCanSeeGuests); - -const - cgCalaccesslevel: array [0 .. 5] of string = - ('none', 'read', 'freebusy', 'editor', 'owner', 'root'); - -type - TAccessLevel = (alNone, alRead, alFreebusy, alEditor, alOwner, alRoot); - -type - TgCalsuppressReplyNotifications = class(TPersistent) - private - FValue: boolean; - public - Constructor Create(const ByNode: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root: IXMLNode): IXMLNode; - property Value: boolean read FValue write FValue; - end; - -type - TgCalsyncEvent = class(TPersistent) - private - FValue: boolean; - public - Constructor Create(const ByNode: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root: IXMLNode): IXMLNode; - property Value: boolean read FValue write FValue; - end; - -type - TgCaluid = class(TPersistent) - private - FValue: string; - public - Constructor Create(const ByNode: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root: IXMLNode): IXMLNode; - property Value: string read FValue write FValue; - end; - -type - TgCalsequence = class(TPersistent) - private - FValue: integer; - public - Constructor Create(const ByNode: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root: IXMLNode): IXMLNode; - property Value: integer read FValue write FValue; - end; - -type - TgCalguestsCanSeeGuests = class(TPersistent) - private - FValue: boolean; - public - Constructor Create(const ByNode: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root: IXMLNode): IXMLNode; - property Value: boolean read FValue write FValue; - end; - -type - TgCalguestsCanInviteOthers = class(TPersistent) - private - FValue: boolean; - public - Constructor Create(const ByNode: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root: IXMLNode): IXMLNode; - property Value: boolean read FValue write FValue; - end; - -type - TgCalguestsCanModify = class(TPersistent) - private - FValue: boolean; - public - Constructor Create(const ByNode: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root: IXMLNode): IXMLNode; - property Value: boolean read FValue write FValue; - end; - -type - TgCalwebContent = packed record - // atom:link Properties - rel: string; - title: string; - href: string; - typ: string; - // Properties - height: integer; - width: integer; - url: string; - end; - -type - TgCalwebContentGadgetPrefs = packed record - Name: string; - Value: string; - end; - -type - TCelendarLinksList = TList; - -type - TgCaltimezone = Class(TPersistent) - private - FValue: string; - FDescription: string; - FGMT: extended; - public - Constructor Create(const ByNode: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root: IXMLNode): IXMLNode; - property Value: string read FValue write FValue; - property Description: string read FDescription write FDescription; - property GMT: extended read FGMT write FGMT; - end; - -type - TgCalHidden = class(TPersistent) - private - FValue: boolean; - public - Constructor Create(const ByNode: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root: IXMLNode): IXMLNode; - property Value: boolean read FValue write FValue; - end; - -type - TgCalcolor = class(TPersistent) - private - FValue: string; - FColor: TColor; - procedure SetColor(aColor: TColor); - public - Constructor Create(const ByNode: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root: IXMLNode): IXMLNode; - property Value: string read FValue write FValue; - property Color: TColor read FColor write SetColor; - end; - -type - TgCalselected = class(TPersistent) - private - FValue: boolean; - public - Constructor Create(const ByNode: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - property Value: boolean read FValue write FValue; - end; - -type - TgCalAccessLevel = class(TPersistent) - private - FValue: string; - FLevel: TAccessLevel; - procedure SetLevel(aLevel: TAccessLevel); - procedure SetValue(aValue: string); - public - Constructor Create(const ByNode: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - property Value: string read FValue write SetValue; - property Level: TAccessLevel read FLevel write SetLevel; - end; - -type - TgCaltimesCleaned = class(TPersistent) - private - FValue: integer; - public - Constructor Create(const ByNode: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - property Value: integer read FValue write FValue; - end; - -type - TCelenrarEvent = class - private - Fid: string; - FEtag: string; - FAuth: string; - Fpublished: TDateTime; - Fupdated: TDateTime; - FTitle: TTextTag; - FDescription: TTextTag; - FLinks: TCelendarLinksList; // ссылки события - FAuthor: TAuthorTag; - FeventStatus: TgdEventStatus; - Fwhere: TgdWhere; - Fwhen: TgdWhen; - Fwho: TgdWho; - Frecurrence: TgdRecurrence; - Freminders: TList; - Ftransparency: TgdTransparency; - Fvisibility: TgdVisibility; - FguestsCanInviteOthers: TgCalguestsCanInviteOthers; - FguestsCanModify: TgCalguestsCanModify; - FguestsCanSeeGuests: TgCalguestsCanSeeGuests; - Fsequence: TgCalsequence; - Fuid: TgCaluid; - procedure AddLink(const aNode: IXMLNode); - procedure AddRemainder(const aNode: IXMLNode); - procedure RetriveETag(const aLink: string); - procedure InsertCategory(Root: IXMLNode); - function GetEditURL: string; - function GetTitle: string; - procedure SetTitle(aTitle:string); - function GetDescription: string; - procedure SetDescription(aDescr: string); - public - constructor Create(const ByNode: IXMLNode=nil; aAuth: string='');overload; - destructor Destroy; - procedure ParseXML(Node: IXMLNode); - function Update:boolean; - function DeleteThis:boolean; - property ID: string read Fid; - property Etag: string read FEtag; - property PublishedTime: TDateTime read Fpublished; - property UpdateTime: TDateTime read Fupdated; - property Title: string read GetTitle write SetTitle; - property Description: string read GetDescription write SetDescription; - property Links: TCelendarLinksList read FLinks; - property Author: TAuthorTag read FAuthor write FAuthor; - property EventStatus: TgdEventStatus read FeventStatus write FeventStatus; - property Where: TgdWhere read Fwhere write Fwhere; - property When: TgdWhen read Fwhen write Fwhen; - property Who: TgdWho read Fwho write Fwho; - property Recurrence: TgdRecurrence read Frecurrence write Frecurrence; - property Reminders: TList read Freminders write Freminders; - property Transparency - : TgdTransparency read Ftransparency write Ftransparency; - property Visibility: TgdVisibility read Fvisibility write Fvisibility; - property GuestsCanInviteOthers - : TgCalguestsCanInviteOthers read FguestsCanInviteOthers write - FguestsCanInviteOthers; - property GuestsCanModify: TgCalguestsCanModify read FguestsCanModify write - FguestsCanModify; - property GuestsCanSeeGuests - : TgCalguestsCanSeeGuests read FguestsCanSeeGuests write - FguestsCanSeeGuests; - property Sequence: TgCalsequence read Fsequence write Fsequence; - property UID: TgCaluid read Fuid; - end; - -type - TCelendar = class - private - FAuth: string; - Fid: string; - FEtag: string; - FTitle: TTextTag; - FDescription: TTextTag; - FLinks: TCelendarLinksList; // ссылки календаря - FAuthor: TAuthorTag; - Ftimezone: TgCaltimezone; - Fpublished: TDateTime; - Fupdated: TDateTime; - Fhidden: TgCalHidden; - FVColor: TgCalcolor; - Fselected: TgCalselected; - Faccesslevel: TgCalAccessLevel; - Fwhere: TgdWhere; - FgCaltimesCleaned: TgCaltimesCleaned; - FEvents: TList; - procedure AddLink(const aNode: IXMLNode); - function GetLink(index: integer): TEntryLink; - procedure SetLink(i: integer; Link: TEntryLink); - function GetLinksCount: integer; - function GetEvent(i: integer): TCelenrarEvent; - procedure InsertCategory(Root: IXMLNode); - function GetEventFeedLink: string; - function GetEventCount: integer; - function GetTitle:string; - function GetDescription: string; - procedure SetTitle(aTitle: string); - procedure SetDescription(aDescr: string); - public - constructor Create(const ByNode: IXMLNode=nil; aAuth: string=''); - function DeleteThis: boolean; - procedure ParseXML(Node: IXMLNode); - function AddSingleEvent(aEvent: TCelenrarEvent): boolean; - function RetrieveEvents: integer; - function SendToGoogle(const GoogleAuth: string): boolean; - property Auth: string read FAuth write FAuth; - property title: string read GetTitle write SetTitle; - property Description: string read GetDescription write SetDescription; - property LinkCount: integer read GetLinksCount; - property Link[i: integer]: TEntryLink read GetLink write SetLink; - property Author: TAuthorTag read FAuthor write FAuthor; - property TimeZone: TgCaltimezone read Ftimezone write Ftimezone; - property PublishedTime: TDateTime read Fpublished write Fpublished; - property UpdatedTime: TDateTime read Fupdated write Fupdated; - property Hidden: TgCalHidden read Fhidden write Fhidden; - property Color: TgCalcolor read FVColor write FVColor; - property Selected: TgCalselected read Fselected write Fselected; - property AccessLevel: TgCalAccessLevel read Faccesslevel write Faccesslevel; - property Where: TgdWhere read Fwhere write Fwhere; - property TimesCleaned: TgCaltimesCleaned read FgCaltimesCleaned write - FgCaltimesCleaned; - property Event[i: integer]: TCelenrarEvent read GetEvent; - property EventCount: integer read GetEventCount; - end; - -type - TCelendarList = TList; - -type - TGoogleCalendar = class - private - FAccount: TGoogleLogin; - FCelendars: TCelendarList; // календари пользователя - public - constructor Create(const Email, password: string); - function Login: boolean; - procedure RetriveCelendars(const Owner: boolean); - property Account: TGoogleLogin read FAccount write FAccount; - property Celendars: TCelendarList read FCelendars; - end; - -function GetGClalNodeType(NodeName: string): TgCalEnum; - -implementation - -function GetGClalNodeType(NodeName: string): TgCalEnum; -var - i: integer; -begin - i := AnsiIndexStr(NodeName, cgCalTagNames); - if i > - 1 then - Result := TgCalEnum(i) -end; - -{ TGoogleCalengar } - -constructor TGoogleCalendar.Create(const Email, password: string); -begin - inherited Create; - try - FAccount:= TGoogleLogin.Create(Email, password); - FAccount.Service := tsCelendar; - FAccount.Source := DefoultAppName; - FCelendars := TCelendarList.Create; - except - Destroy; - end; -end; - -function TGoogleCalendar.Login: boolean; -begin - FAccount.Login(); - if Account.LastResult = lrOk then - Result := true - else - Result := false; -end; - -procedure TGoogleCalendar.RetriveCelendars(const Owner: boolean); -var - Doc: IXMLDocument; - i: integer; -begin - FCelendars.Clear; - Doc:=NewXMLDocument(); - if not Owner then - Doc.LoadFromStream(SendRequest('GET',AllCelendarsLink, FAccount.Auth,'2.0')) - else - Doc.LoadFromStream(SendRequest('GET',OwnerCelendarLink, FAccount.Auth,'2.0')); - for i := 0 to Doc.DocumentElement.ChildNodes.Count - 1 do - if LowerCase(Doc.DocumentElement.ChildNodes[i].NodeName) = EntryNodeName then - FCelendars.Add(TCelendar.Create(Doc.DocumentElement.ChildNodes[i], FAccount.Auth)); -end; - -{ TCelendar } - -procedure TCelendar.AddLink(const aNode: IXMLNode); -var - Link: TEntryLink; -begin - try - Link.rel := aNode.Attributes['rel']; - Link.ltype := aNode.Attributes['type']; - Link.href := aNode.Attributes['href']; - FLinks.Add(Link); - except - Exception.Create(Format(rcErrReadNode, [aNode.NodeName])); - end; -end; - -function TCelendar.AddSingleEvent(aEvent: TCelenrarEvent): boolean; -var - aDoc: TNativeXML; - Root : TXMLNode; - WhenNode:TXMLNode; - i: integer; - Stream: TStream; -begin - aDoc := TNativeXML.Create; - aDoc.CreateName(EntryNodeName); - for i := 0 to High(clNameSpaces) - 1 do - aDoc.Root.WriteAttributeString(clNameSpaces[i, 0], clNameSpaces[i, 1]); - InsertCategory(aDoc.Root); - aEvent.FTitle.AddToXML(aDoc.Root); - aEvent.FDescription.AddToXML(aDoc.Root); - aEvent.Ftransparency.AddToXML(aDoc.Root); - aEvent.FeventStatus.AddToXML(aDoc.Root); - aEvent.Fwhere.AddToXML(aDoc.Root); - // WhenNode := aEvent.Fwhen.AddToXML(Root); - if aEvent.Freminders.Count > 0 then - for i := 0 to aEvent.Freminders.Count - 1 do - // aEvent.Freminders[i].AddToXML(WhenNode); - Stream:=TStringStream.Create(''); - aDoc.SaveToStream(Stream); -if length(GetEventFeedLink) > 0 then - aDoc.LoadFromStream(SendRequest('POST', GetEventFeedLink, FAuth,ClProtocolVer,Stream)); -Result:=aDoc.Root.FindNode(EntryNodeName)<>nil; -end; - -constructor TCelendar.Create(const ByNode: IXMLNode; aAuth: string); -begin - inherited Create; - FAuth := aAuth; - FLinks := TCelendarLinksList.Create; - FAuthor := TAuthorTag.Create; - Ftimezone := TgCaltimezone.Create; - Fhidden := TgCalHidden.Create; - FVColor := TgCalcolor.Create; - Faccesslevel := TgCalAccessLevel.Create; - FgCaltimesCleaned := TgCaltimesCleaned.Create; - FTitle := TTextTag.Create; - FDescription := TTextTag.Create; - Fwhere := TgdWhere.Create; - FEvents := TList.Create; - Fselected := TgCalselected.Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -function TCelendar.DeleteThis: boolean; -var i:integer; -begin - for I := 0 to FLinks.Count - 1 do - begin - if FLinks[i].rel='edit' then - begin - with THTTPSend.Create do - begin - Headers.Add('GData-Version: '+ClProtocolVer); - Headers.Add('Authorization: GoogleLogin auth=' + FAuth); - MimeType := 'application/atom+xml'; - Headers.Add('If-Match: ' + FEtag); - if HTTPMethod('DELETE',FLinks[i].href) then - begin - if (ResultCode > 200) and (ResultCode < 400) then - begin - Headers.Clear; - Headers.Add('GData-Version: '+ClProtocolVer); - Headers.Add('Authorization: GoogleLogin auth=' + FAuth); - MimeType := 'application/atom+xml'; - Headers.Add('If-Match: ' + FEtag); - HTTPMethod('DELETE', GetNewLocationURL(Headers)); - end; - ShowMessage(IntToStr(ResultCode)); - Result:=ResultCode=200; - end - else - Result:=false; - end; - end; - end; -end; - -function TCelendar.GetDescription: string; -begin - Result:=FDescription.Value -end; - -function TCelendar.GetEvent(i: integer): TCelenrarEvent; -begin - if (i <= FEvents.Count) and (i > - 1) then - Result := FEvents[i] - else - raise Exception.Create(rcErrMissAgrument); -end; - -function TCelendar.GetEventCount: integer; -begin - Result:=FEvents.Count; -end; - -function TCelendar.GetEventFeedLink: string; -var - i: integer; -begin - Result := ''; - if FLinks.Count = 0 then - Exit; - for i := 0 to FLinks.Count - 1 do - if FLinks[i].rel = 'http://schemas.google.com/gCal/2005#eventFeed' then - begin - Result := FLinks[i].href; - break; - end; -end; - -function TCelendar.GetLink(index: integer): TEntryLink; -begin - Result := FLinks.Items[index]; -end; - -function TCelendar.GetLinksCount: integer; -begin - Result := FLinks.Count -end; - -function TCelendar.GetTitle: string; -begin - Result:=FTitle.Value; -end; - -procedure TCelendar.InsertCategory(Root: IXMLNode); -var - Node: IXMLNode; -begin - Node := Root.OwnerDocument.CreateElement('category', - 'http://www.w3.org/2005/Atom'); // создали узел - Node.Attributes[clCategories[0, 0]] := clCategories[0, 1]; - // присвоили значение - Node.Attributes[clCategories[1, 0]] := clCategories[1, 1]; - // присвоили значение - Root.ChildNodes.Add(Node); // записали документ -end; - -procedure TCelendar.ParseXML(Node: IXMLNode); -var - j, index: integer; - Entry: IXMLNodeList; -begin - if Node = nil then - Exit; - Entry := Node.ChildNodes; - FEtag := Node.Attributes['gd:etag']; - for j := 0 to Entry.Count - 1 do - begin - if Entry.Get(j).NodeName = 'id' then - Fid := Entry.Get(j).NodeValue - else - if Entry.Get(j).NodeName = 'title' then - FTitle.ParseXML(Entry.Get(j)) - else - if Entry.Get(j).NodeName = 'summary' then - FDescription.ParseXML(Entry.Get(j)) - else - if Entry.Get(j).NodeName = 'published' then - Fpublished := ServerDateToDateTime(Entry.Get(j).NodeValue) - else - if Entry.Get(j).NodeName = 'updated' then - Fupdated := ServerDateToDateTime(Entry.Get(j).NodeValue) - else - if Entry.Get(j).NodeName = 'gd:where' then - Fwhere := gdWhere(Entry[j]) - else - if Entry.Get(j).NodeName = 'link' then - AddLink(Entry[j]) - else - if Entry.Get(j).NodeName = 'gCal:selected' then - Fselected.ParseXML(Entry[j]) - else - begin - index := AnsiIndexStr(Entry[j].NodeName, cgCalTagNames); - if index > - 1 then - begin - case TgCalEnum(index) of - egCalaccesslevel: - Faccesslevel.ParseXML(Entry[j]); - egCalcolor: - FVColor.ParseXML(Entry[j]); - egCalhidden: - Fhidden.ParseXML(Entry[j]); - egCalselected: - Fselected.ParseXML(Entry[j]); - egCaltimezone: - Ftimezone.ParseXML(Entry[j]); - egCaltimesCleaned: - FgCaltimesCleaned.ParseXML(Entry[j]); - else - ShowMessage(rcUnUsedTag + Entry[j].NodeName); - end; - end; - end; - end; -end; - -function TCelendar.RetrieveEvents: integer; -var - i: integer; - aDoc: IXMLDocument; - tmpURL: string; -begin -FEvents.Clear; - for i := 0 to FLinks.Count - 1 do - if FLinks[i].rel = 'alternate' then - begin - aDoc := NewXMLDocument(); - aDoc.LoadFromStream(SendRequest('GET', FLinks[i].href, FAuth,ClProtocolVer)); - break; - end; - if not aDoc.IsEmptyDoc then - begin - for i := 0 to aDoc.DocumentElement.ChildNodes.Count - 1 do - if aDoc.DocumentElement.ChildNodes[i].NodeName = EntryNodeName then - FEvents.Add(TCelenrarEvent.Create(aDoc.DocumentElement.ChildNodes[i], - FAuth)); - end; - Result := FEvents.Count; -end; - -function TCelendar.SendToGoogle(const GoogleAuth: string): boolean; -var - aDoc, cDoc: IXMLDocument; - Root, Node: IXMLNode; - i: integer; - tmpURL: string; - V: OleVariant; -begin - aDoc := NewXMLDocument; - aDoc.Active := true; - Root := aDoc.AddChild('entry'); - for i := 0 to High(clNameSpaces) do - Root.DeclareNamespace(clNameSpaces[i, 0], clNameSpaces[i, 1]); - FTitle.AddToXML(Root); - FDescription.AddToXML(Root); - Ftimezone.AddToXML(Root); - Fhidden.AddToXML(Root); - FVColor.AddToXML(Root); - Fwhere.AddToXML(Root); - with THTTPSend.Create do - begin - Headers.Add('GData-Version: '+ClProtocolVer); - Headers.Add('Authorization: GoogleLogin auth=' + GoogleAuth); - MimeType := 'application/atom+xml'; - aDoc.SaveToStream(Document); - HTTPMethod('POST',OwnerCelendarLink); - if (ResultCode > 200) and (ResultCode < 400) then - begin - tmpURL := GetNewLocationURL(Headers); - Document.Clear; - aDoc.SaveToStream(Document); - Headers.Clear; - MimeType := 'application/atom+xml'; - Headers.Add('GData-Version: '+ClProtocolVer); - Headers.Add('Authorization: GoogleLogin auth=' + GoogleAuth); - HTTPMethod('POST', tmpURL); - end; - Result := ResultCode = 201; - end; -end; - -procedure TCelendar.SetDescription(aDescr: string); -begin - FDescription.Value:=aDescr; -end; - -procedure TCelendar.SetLink(i: integer; Link: TEntryLink); -begin - if FLinks.Contains(Link) then - begin - ShowMessage(rcDuplicateLink); - Exit; - end; - FLinks.Insert(i, Link); -end; - -procedure TCelendar.SetTitle(aTitle: string); -begin - FTitle.Value:=aTitle -end; - -{ TgCaltimezone } - -function TgCaltimezone.AddToXML(Root: IXMLNode): IXMLNode; -begin - if Root = nil then - Exit; - Result := Root.AddChild(cgCalTagNames[ord(egCaltimezone)]); - Result.Attributes[NodeValueAttr] := FValue; -end; - -constructor TgCaltimezone.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -procedure TgCaltimezone.ParseXML(Node: IXMLNode); -var - i: integer; -begin - if GetGClalNodeType(Node.NodeName) <> egCaltimezone then - raise Exception.Create - (Format(rcErrCompNodes, [cgCalTagNames[ord(egCaltimezone)]])); - try - FValue := Node.Attributes[NodeValueAttr]; - for i := 0 to High(GoogleTimeZones) - 1 do - begin - if Trim(LowerCase(GoogleTimeZones[i, 0])) = Trim(LowerCase(FValue)) then - begin - FDescription := GoogleTimeZones[i, 1]; - FGMT := StrToFloat(stringreplace(GoogleTimeZones[i,2],',',DecimalSeparator,[])); - end; - end; - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - - -{ TgCalhidden } - -function TgCalHidden.AddToXML(Root: IXMLNode): IXMLNode; -begin - if Root = nil then - Exit; - Result := Root.AddChild(cgCalTagNames[ord(egCalhidden)]); - Result.Attributes[NodeValueAttr] := FValue; -end; - -constructor TgCalHidden.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -procedure TgCalHidden.ParseXML(Node: IXMLNode); -begin - if GetGClalNodeType(Node.NodeName) <> egCalhidden then - raise Exception.Create - (Format(rcErrCompNodes, [cgCalTagNames[ord(egCalhidden)]])); - try - FValue := Node.Attributes[NodeValueAttr]; - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -{ TgCalcolor } - -function TgCalcolor.AddToXML(Root: IXMLNode): IXMLNode; -begin - if Root = nil then - Exit; - Result := Root.AddChild(cgCalTagNames[ord(egCalcolor)]); - Result.Attributes[NodeValueAttr] := FValue; -end; - -constructor TgCalcolor.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then Exit; - ParseXML(ByNode); -end; - -procedure TgCalcolor.ParseXML(Node: IXMLNode); -begin - if GetGClalNodeType(Node.NodeName) <> egCalcolor then - raise Exception.Create - (Format(rcErrCompNodes, [cgCalTagNames[ord(egCalcolor)]])); - try - FValue := Node.Attributes[NodeValueAttr]; - FColor := HexToColor(FValue); - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -procedure TgCalcolor.SetColor(aColor: TColor); -begin - FColor := aColor; - FValue := ColorToHex(aColor); -end; - -{ TgCalselected } - -constructor TgCalselected.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -procedure TgCalselected.ParseXML(Node: IXMLNode); -begin - if GetGClalNodeType(Node.NodeName) <> egCalselected then - raise Exception.Create - (Format(rcErrCompNodes, [cgCalTagNames[ord(egCalselected)]])); - try - FValue := Node.Attributes[NodeValueAttr]; - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -{ TgCalaccesslevel } - -constructor TgCalAccessLevel.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -procedure TgCalAccessLevel.ParseXML(Node: IXMLNode); -begin - if GetGClalNodeType(Node.NodeName) <> egCalaccesslevel then - raise Exception.Create(Format(rcErrCompNodes, - [cgCalTagNames[ord(egCalaccesslevel)]])); - try - FValue := Node.Attributes[NodeValueAttr]; - if AnsiIndexStr(FValue, cgCalaccesslevel) <> -1 then - FLevel := TAccessLevel(AnsiIndexStr(FValue, cgCalaccesslevel)) - else - raise Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -procedure TgCalAccessLevel.SetLevel(aLevel: TAccessLevel); -begin - try - FValue := cgCalaccesslevel[ord(aLevel)]; - FLevel := aLevel; - except - Exception.Create - (Format(rcErrWriteNode, [cgCalTagNames[ord(egCalaccesslevel)]])); - end; -end; - -procedure TgCalAccessLevel.SetValue(aValue: string); -var - i: integer; - s: string; -begin - try - s := Trim(LowerCase(FValue)); - i := AnsiIndexStr(s, cgCalaccesslevel); - if i <> 1 then - begin - FLevel := TAccessLevel(i); - FValue := s; - end - else - raise Exception.Create - (Format(rcErrWriteNode, [cgCalTagNames[ord(egCalaccesslevel)]])); - except - Exception.Create - (Format(rcErrWriteNode, [cgCalTagNames[ord(egCalaccesslevel)]])); - end; -end; - -{ TgCaltimesCleaned } - -constructor TgCaltimesCleaned.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -procedure TgCaltimesCleaned.ParseXML(Node: IXMLNode); -begin - if GetGClalNodeType(Node.NodeName) <> egCaltimesCleaned then - raise Exception.Create(Format(rcErrCompNodes, - [cgCalTagNames[ord(egCaltimesCleaned)]])); - try - FValue := Node.Attributes[NodeValueAttr]; - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -{ TgCalguestsCanInviteOthers } - -function TgCalguestsCanInviteOthers.AddToXML(Root: IXMLNode): IXMLNode; -begin - if Root = nil then - Exit; - Result := Root.AddChild(cgCalTagNames[ord(egCalguestsCanInviteOthers)]); - Result.Attributes[NodeValueAttr] := LowerCase(BoolToStr(FValue, true)); -end; - -constructor TgCalguestsCanInviteOthers.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -procedure TgCalguestsCanInviteOthers.ParseXML(Node: IXMLNode); -begin - if GetGClalNodeType(Node.NodeName) <> egCalguestsCanInviteOthers then - raise Exception.Create(Format(rcErrCompNodes, [cgCalTagNames[ord - (egCalguestsCanInviteOthers)]])); - try - FValue := Node.Attributes[NodeValueAttr]; - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -{ TgCalguestsCanModify } - -function TgCalguestsCanModify.AddToXML(Root: IXMLNode): IXMLNode; -begin - if Root = nil then - Exit; - Result := Root.AddChild(cgCalTagNames[ord(egCalguestsCanModify)]); - Result.Attributes[NodeValueAttr] := LowerCase(BoolToStr(FValue, true)); -end; - -constructor TgCalguestsCanModify.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -procedure TgCalguestsCanModify.ParseXML(Node: IXMLNode); -begin - if GetGClalNodeType(Node.NodeName) <> egCalguestsCanModify then - raise Exception.Create(Format(rcErrCompNodes, - [cgCalTagNames[ord(egCalguestsCanModify)]])); - try - FValue:=Node.Attributes[NodeValueAttr]; - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -{ TgCalguestsCanSeeGuests } - -function TgCalguestsCanSeeGuests.AddToXML(Root: IXMLNode): IXMLNode; -begin - if Root = nil then - Exit; - Result := Root.AddChild(cgCalTagNames[ord(egCalguestsCanSeeGuests)]); - Result.Attributes[NodeValueAttr] := LowerCase(BoolToStr(FValue, true)); -end; - -constructor TgCalguestsCanSeeGuests.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -procedure TgCalguestsCanSeeGuests.ParseXML(Node: IXMLNode); -begin - if GetGClalNodeType(Node.NodeName) <> egCalguestsCanSeeGuests then - raise Exception.Create(Format(rcErrCompNodes, - [cgCalTagNames[ord(egCalguestsCanSeeGuests)]])); - try - FValue := Node.Attributes[NodeValueAttr]; - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -{ TgCalsequence } - -function TgCalsequence.AddToXML(Root: IXMLNode): IXMLNode; -begin - if Root = nil then - Exit; - Result := Root.AddChild(cgCalTagNames[ord(egCalsequence)]); - Result.Attributes[NodeValueAttr] := IntToStr(FValue); -end; - -constructor TgCalsequence.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -procedure TgCalsequence.ParseXML(Node: IXMLNode); -begin - if GetGClalNodeType(Node.NodeName) <> egCalsequence then - raise Exception.Create - (Format(rcErrCompNodes, [cgCalTagNames[ord(egCalsequence)]])); - try - FValue := Node.Attributes[NodeValueAttr]; - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -{ TgCaluid } - -function TgCaluid.AddToXML(Root: IXMLNode): IXMLNode; -begin - if Root = nil then - Exit; - Result := Root.AddChild(cgCalTagNames[ord(egCaluid)]); - Result.Attributes[NodeValueAttr] := FValue; -end; - -constructor TgCaluid.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -procedure TgCaluid.ParseXML(Node: IXMLNode); -begin - if GetGClalNodeType(Node.NodeName) <> egCaluid then - raise Exception.Create - (Format(rcErrCompNodes, [cgCalTagNames[ord(egCaluid)]])); - try - FValue := Node.Attributes[NodeValueAttr]; - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -{ TgCalsuppressReplyNotifications } - -function TgCalsuppressReplyNotifications.AddToXML(Root: IXMLNode): IXMLNode; -begin - if Root = nil then - Exit; - Result := Root.AddChild(cgCalTagNames[ord(egCalsuppressReplyNotifications)]); - Result.Attributes[NodeValueAttr] := BoolToStr(FValue, true); -end; - -constructor TgCalsuppressReplyNotifications.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -procedure TgCalsuppressReplyNotifications.ParseXML(Node: IXMLNode); -begin - if GetGClalNodeType(Node.NodeName) <> egCalsuppressReplyNotifications then - raise Exception.Create(Format(rcErrCompNodes, [cgCalTagNames[ord - (egCalsuppressReplyNotifications)]])); - try - FValue := Node.Attributes[NodeValueAttr]; - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -{ TgCalsyncEvent } - -function TgCalsyncEvent.AddToXML(Root: IXMLNode): IXMLNode; -begin - if Root = nil then - Exit; - Result := Root.AddChild(cgCalTagNames[ord(egCalsyncEvent)]); - Result.Attributes[NodeValueAttr] := BoolToStr(FValue, true); -end; - -constructor TgCalsyncEvent.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -procedure TgCalsyncEvent.ParseXML(Node: IXMLNode); -begin - if GetGClalNodeType(Node.NodeName) <> egCalsyncEvent then - raise Exception.Create - (Format(rcErrCompNodes, [cgCalTagNames[ord(egCalsyncEvent)]])); - try - FValue := Node.Attributes[NodeValueAttr]; - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -{ TCelenrarEvent } - -procedure TCelenrarEvent.AddLink(const aNode: IXMLNode); -var - Link: TEntryLink; -begin - try - Link.rel := aNode.Attributes['rel']; - Link.ltype := aNode.Attributes['type']; - Link.href := aNode.Attributes['href']; - FLinks.Add(Link); - except - Exception.Create(Format(rcErrReadNode, [aNode.NodeName])); - end; -end; - -procedure TCelenrarEvent.AddRemainder(const aNode: IXMLNode); -var - Remainder: TgdReminder; -begin - Remainder := TgdReminder.Create(aNode); - Freminders.Add(Remainder); -end; - - -constructor TCelenrarEvent.Create(const ByNode: IXMLNode; aAuth: string); -var Attr: TAttribute; -begin - inherited Create; - FAuth := aAuth; - Attr.Name:='type'; - Attr.Value:='text'; - FTitle := TTextTag.Create; - FTitle.Name:='title'; - FTitle.Attributes.Add(Attr); - FDescription := TTextTag.Create; - FDescription.Name:='content'; - FDescription.Attributes.Add(Attr); - FLinks := TCelendarLinksList.Create; // ссылки события - FAuthor := TAuthorTag.Create; - FeventStatus := TgdEventStatus.Create; - Fwhere := TgdWhere.Create; - Fwhen := TgdWhen.Create; - Fwho := TgdWho.Create; - Frecurrence := TgdRecurrence.Create; - Freminders := TList.Create; - Ftransparency := TgdTransparency.Create; - Fvisibility := TgdVisibility.Create; - FguestsCanInviteOthers := TgCalguestsCanInviteOthers.Create; - FguestsCanModify := TgCalguestsCanModify.Create; - FguestsCanSeeGuests := TgCalguestsCanSeeGuests.Create; - Fsequence := TgCalsequence.Create; - Fuid := TgCaluid.Create; - if ByNode <> nil then - ParseXML(ByNode); -end; - -function TCelenrarEvent.DeleteThis:boolean; -var tmpURL:string; -begin - if length(GetEditURL) > 0 then - with THTTPSend.Create do - begin - Headers.Add('GData-Version: '+ClProtocolVer); - Headers.Add('Authorization: GoogleLogin auth=' + FAuth); - MimeType := 'application/atom+xml'; - Headers.Add('If-Match: ' + FEtag); - HTTPMethod('DELETE', GetEditURL); - if (ResultCode > 200) and (ResultCode < 400) then - begin - tmpURL := GetNewLocationURL(Headers); - Document.Clear; - Headers.Clear; - MimeType := 'application/atom+xml'; - Headers.Add('GData-Version: '+ClProtocolVer); - Headers.Add('Authorization: GoogleLogin auth=' + FAuth); - Headers.Add('If-Match: ' + FEtag); - HTTPMethod('DELETE', tmpURL); - end; - Result:=ResultCode=200; - end; -end; - -destructor TCelenrarEvent.Destroy; -begin - inherited Destroy; -end; - -function TCelenrarEvent.GetDescription: string; -begin - Result:=FDescription.Value -end; - -function TCelenrarEvent.GetEditURL: string; -var - i: integer; -begin - Result := ''; - for i := 0 to FLinks.Count - 1 do - begin - if FLinks[i].rel = 'edit' then - begin - Result := FLinks[i].href; - break; - end; - end; -end; - -function TCelenrarEvent.GetTitle: string; -begin - result:=FTitle.Value; -end; - -procedure TCelenrarEvent.InsertCategory(Root: IXMLNode); -var - Node: IXMLNode; -begin - Node := Root.OwnerDocument.CreateElement('category', - 'http://www.w3.org/2005/Atom'); // создали узел - Node.Attributes[clCategories[0, 0]] := clCategories[0, 1]; - // присвоили значение - Node.Attributes[clCategories[1, 0]] := clCategories[1, 1]; - // присвоили значение - Root.ChildNodes.Add(Node); // записали документ -end; - -procedure TCelenrarEvent.ParseXML(Node: IXMLNode); -var - i, j: integer; - Name:AnsiString; -begin - for i := 0 to Node.ChildNodes.Count - 1 do - begin - Name:=Node.ChildNodes[i].NodeName; - j:=AnsiIndexText(Name,clEventRequareTags); - case j of - 0:Fid := Node.ChildNodes[i].Text; - 1:Fpublished := ServerDateToDateTime(Node.ChildNodes[i].Text); - 2:Fupdated := ServerDateToDateTime(Node.ChildNodes[i].Text); - 3:FTitle.ParseXML(Node.ChildNodes[i]); - 4:begin - AddLink(Node.ChildNodes[i]); - if FLinks[FLinks.Count - 1].rel = 'self' then - RetriveETag(FLinks[FLinks.Count - 1].href); - end; - 5:FDescription.ParseXML(Node.ChildNodes[i]); - 6:FAuthor.ParseXML(Node.ChildNodes[i]); - 7:FeventStatus := gdEventStatus(Node.ChildNodes[i]); - 8:Fwhere.ParseXML(Node.ChildNodes[i]); - 9:Fwho.ParseXML(Node.ChildNodes[i]); - 10:begin - //!!!!! Fwhen.ParseXML(Node.ChildNodes[i]); - if Node.ChildNodes[i].ChildNodes.Count > 0 then - begin - for j := 0 to Node.ChildNodes[i].ChildNodes.Count - 1 do - AddRemainder(Node.ChildNodes[i].ChildNodes[j]) - end; - end; - 11:Frecurrence.ParseXML(Node.ChildNodes[i]); - 12:AddRemainder(Node.ChildNodes[i]); - 13:Ftransparency.ParseXML(Node.ChildNodes[i]); - 14:Fvisibility.ParseXML(Node.ChildNodes[i]); - 15:FguestsCanInviteOthers.ParseXML(Node.ChildNodes[i]); - 16:FguestsCanModify.ParseXML(Node.ChildNodes[i]); - 17:FguestsCanSeeGuests.ParseXML(Node.ChildNodes[i]); - 18:Fsequence.ParseXML(Node.ChildNodes[i]); - 19:Fuid.ParseXML(Node.ChildNodes[i]); - end; - end; -end; - -procedure TCelenrarEvent.RetriveETag(const aLink: string); -var - tmpURL: string; - i: integer; -begin - with THTTPSend.Create do - begin - Headers.Add('GData-Version: '+ClProtocolVer); - Headers.Add('Authorization: GoogleLogin auth=' + FAuth); - MimeType := 'application/atom+xml'; - HTTPMethod('HEAD', aLink); - if (ResultCode > 200) and (ResultCode < 400) then - begin - tmpURL := GetNewLocationURL(Headers); - Document.Clear; - Headers.Clear; - MimeType := 'application/atom+xml'; - Headers.Add('GData-Version: '+ClProtocolVer); - Headers.Add('Authorization: GoogleLogin auth=' + FAuth); - HTTPMethod('HEAD', tmpURL); - end; - for i := 0 to Headers.Count - 1 do - begin - if pos('ETag: ', Headers[i]) > 0 then - begin - FEtag := copy(Headers[i], 7, length(Headers[i]) - 6); - break; - end; - end; - end; -end; - -procedure TCelenrarEvent.SetDescription(aDescr: string); -begin - FDescription.Value:=aDescr; -end; - -procedure TCelenrarEvent.SetTitle(aTitle: string); -begin - FTitle.Value:=aTitle; -end; - -function TCelenrarEvent.Update: boolean; -var - i: integer; - aDoc: IXMLDocument; - Root, Node: IXMLNode; - tmpURL: string; -begin - aDoc := NewXMLDocument(); - aDoc.Active := true; - aDoc.Options := [doNodeAutoIndent]; - Root := aDoc.AddChild(EntryNodeName); - for i := 0 to High(clNameSpaces) do - Root.DeclareNamespace(clNameSpaces[i, 0], clNameSpaces[i, 1]); - Root.Attributes['gd:etag'] := FEtag; - InsertCategory(Root); - Node := aDoc.CreateElement('id', clNameSpaces[0, 1]); - Node.Text := Fid; - aDoc.DocumentElement.ChildNodes.Add(Node); - - FTitle.AddToXML(Root); - FDescription.AddToXML(Root); - FeventStatus.AddToXML(Root); - Fwhere.AddToXML(Root); -//!!!!!!!!!!!! Node:=Fwhen.AddToXML(Root); - - if Frecurrence.Text.Count=0 then - begin - for I:=0 to FReminders.Count - 1 do - Freminders[i].AddToXML(Node); - end - else - begin - for I:=0 to FReminders.Count - 1 do - Freminders[i].AddToXML(Root); - end; - - Fwho.AddToXML(Root); - Ftransparency.AddToXML(Root); - Fvisibility.AddToXML(Root); - FguestsCanInviteOthers.AddToXML(Root); - FguestsCanModify.AddToXML(Root); - FguestsCanSeeGuests.AddToXML(Root); - - - if length(GetEditURL) > 0 then - with THTTPSend.Create do - begin - Headers.Add('GData-Version: '+ClProtocolVer); - Headers.Add('Authorization: GoogleLogin auth=' + FAuth); - MimeType := 'application/atom+xml'; - Headers.Add('If-Match: ' + FEtag); - aDoc.SaveToStream(Document); - HTTPMethod('PUT', GetEditURL); - if (ResultCode > 200) and (ResultCode < 400) then - begin - tmpURL := GetNewLocationURL(Headers); - Document.Clear; - aDoc.SaveToStream(Document); - Headers.Clear; - MimeType := 'application/atom+xml'; - Headers.Add('GData-Version: '+ClProtocolVer); - Headers.Add('Authorization: GoogleLogin auth=' + FAuth); - Headers.Add('If-Match: ' + FEtag); - HTTPMethod('PUT', tmpURL); - end; - Result:=ResultCode=200; - if Result then - begin - aDoc.LoadFromStream(Document); - Self.ParseXML(aDoc.DocumentElement); - end; - end; -end; - -end. diff --git a/source/GConsts.pas b/source/GConsts.pas deleted file mode 100644 index ebae4c0..0000000 --- a/source/GConsts.pas +++ /dev/null @@ -1,394 +0,0 @@ -п»ї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 deleted file mode 100644 index 7985dbf..0000000 --- a/source/GContacts.pas +++ /dev/null @@ -1,3621 +0,0 @@ -п»ї{ 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 deleted file mode 100644 index 9ab1598..0000000 --- a/source/GData.pas +++ /dev/null @@ -1,511 +0,0 @@ -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. \ No newline at end of file diff --git a/source/GDataCommon.pas b/source/GDataCommon.pas deleted file mode 100644 index 224b641..0000000 --- a/source/GDataCommon.pas +++ /dev/null @@ -1,5816 +0,0 @@ -<<<<<<< HEAD -п»ї{ Модуль содержит наиболее общие классы для работы СЃ 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. -<<<<<<< HEAD -======= -======= -<<<<<<< HEAD ->>>>>>> remotes/origin/NMD -unit GDataCommon; -{ TODO : Проверять все классы на пустоту, иначе возникают ошибкипри добавлении данных } -interface - -uses NativeXML, Classes, XMLIntf, StrUtils, SysUtils, GHelper, Variants; - -const - cGDTagNames: array [0 .. 49] of string = ('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 - TgdEnum = (egdCountry, egdAdditionalName, egdName, egdEmail, - egdExtendedProperty, egdGeoPt, egdIm, egdOrgName, egdOrgTitle, - egdOrganization, egdOriginalEvent, egdPhoneNumber, egdPostalAddress, - egdRating, egdRecurrence, egdReminder, egdResourceId, egdWhen, egdAgent, - egdHousename, egdStreet, egdPobox, egdNeighborhood, egdCity, egdSubregion, - egdRegion, egdPostcode, egdFormattedAddress, egdStructuredPostalAddress, - egdEntryLink, egdWhere, egdFamilyName, egdGivenName, egdNamePrefix, - egdNameSuffix, egdFullName, egdOregdepartment, egdOrgJobDescription, - egdOrgSymbol, egdFamileName, egdEventStatus, egdVisibility, - egdTransparency, egdAttendeeType, egdAttendeeStatus, egdComments, - egdDeleted, egdFeedLink, egdWho, egdRecurrenceException); - -type - TGDataTags = set of TgdEnum; - -type - TEventStatus = (esCanceled, esConfirmed, esTentative); - -{ DONE -oЯ -cНедочёт : перенести в класс } -type - TgdEventStatus = class(TPersistent) - private - FValue: string; - FStatus: TEventStatus; - const - RelValues: array [0..2]of string=( - 'event.canceled','event.confirmed','event.tentative'); - procedure SetStatus(aStatus:TEventStatus); - public - Constructor Create(const ByNode:IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root:IXMLNode):IXMLNode; - property Status:TEventStatus read FStatus write SetStatus; - end; - -type - TVisibility = (vConfidential, vDefault, vPrivate, vPublic); - -{ DONE -oЯ -cНедочёт : перенести в класс } -type - TgdVisibility = class - private - FValue: string; - FVisible: TVisibility; - const - RelValues: array [0..3]of string = ( - 'event.confidential','event.default','event.private','event.public'); - procedure SetVisible(aVisible:TVisibility); - public - Constructor Create(const ByNode:IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root:IXMLNode):IXMLNode; - property Visibility: TVisibility read FVisible write SetVisible; - end; - -type - TTransparency = (tOpaque, tTransparent); - -{ DONE -oЯ -cНедочёт : перенести в класс } -type - TgdTransparency = class(TPersistent) - private - FValue: string; - FTransparency: TTransparency; - const - RelValues: array [0 .. 1] of string = ('event.opaque','event.transparent'); -// procedure SetValue(aValue:string); - procedure SetTransp(aTransp:TTransparency); - public - Constructor Create(const ByNode:IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root:IXMLNode):IXMLNode; -// property Value: string read FValue write SetValue; - property Transparency: TTransparency read FTransparency write SetTransp; - end; - -type - TAttendeeType = (aOptional, aRequired); - -{ DONE -oЯ -cНедочёт : перенести в класс } -type - TgdAttendeeType = class - private - FValue: string; - FAttType: TAttendeeType; - const RelValues: array [0 .. 1] of string = - ('event.optional','event.required'); -// procedure SetValue(aValue:string); - procedure SetType(aStatus:TAttendeeType); - public - Constructor Create(const ByNode:IXMLNode); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root:IXMLNode):IXMLNode; -// property Value: string read FValue write SetValue; - property AttendeeType: TAttendeeType read FAttType write SetType; - end; - -type - TAttendeeStatus = (asAccepted, asDeclined, asInvited, asTentative); - -{ DONE -oЯ -cНедочёт : перенести в класс } -type - TgdAttendeeStatus = class(TPersistent) - private - FValue: string; - FAttendeeStatus: TAttendeeStatus; - const - RelValues: array [0 .. 3] of string = ( - 'event.accepted','event.declined','event.invited','event.tentative'); - // procedure SetValue(aValue:string); - procedure SetStatus(aStatus:TAttendeeStatus); - public - Constructor Create(const ByNode:IXMLNode); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root:IXMLNode):IXMLNode; -// property Value: string read FValue write SetValue; - property Status: TAttendeeStatus read FAttendeeStatus write SetStatus; - end; - -type - TEntryTerms = (ttAny, ttContact, ttEvent, ttMessage, ttType); - -type - TgdCountry = class(TPersistent) - private - FCode: string; - FValue: string; - public - Constructor Create(const ByNode:TXMLNode); - 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 - TgdAdditionalNameStruct = TTextTag; - -type - TgdFamilyName = TTextTag; - TgdGivenName = TTextTag; -// TgdFamileNameStruct = string; - TgdNamePrefix = TTextTag; - TgdNameSuffix = TTextTag; - TgdFullName = TTextTag; - TgdOrgDepartment = TTextTag; - TgdOrgJobDescription = TTextTag; - TgdOrgSymbol = TTextTag; - -type - TgdName = class(TPersistent) - private - FGivenName: TTextTag; - FAdditionalName: TTextTag; - FFamilyName: TTextTag; - FNamePrefix: TTextTag; - FNameSuffix: TTextTag; - FFullName: TTextTag; - function GetFullName:string; - public - constructor Create(ByNode: TXMLNode=nil); - procedure ParseXML(const Node: TXmlNode); - function IsEmpty:boolean; - function AddToXML(Root:TXMLNode):TXmlNode; - property GivenName: TTextTag read FGivenName write FGivenName; - property AdditionalName: TTextTag read FAdditionalName write FAdditionalName; - property FamilyName: TTextTag read FFamilyName write FFamilyName; - property NamePrefix: TTextTag read FNamePrefix write FNamePrefix; - property NameSuffix: TTextTag read FNameSuffix write FNameSuffix; - property FullName: TTextTag read FFullName write FFullName; - property FullNameString: string read GetFullName; -end; - -type - TTypeElement = (ttHome,ttOther, ttWork); - -type - TgdEmail = class(TPersistent) - private - FAddress: string; - FEmailType: TTypeElement; - FLabel: string; - FRel: string; - FPrimary: boolean; - FDisplayName:string; - const RelValues: array[0..2]of string=('home','other','work'); - procedure SetRel(const aRel:string); - procedure SetEmailType(aType:TTypeElement); - public - constructor Create(ByNode: TXMLNode=nil); - procedure ParseXML(const Node: TXmlNode); - function AddToXML(Root:TXMLNode):TXmlNode; - property Address : string read FAddress write FAddress; - property Labl:string read FLabel write FLabel; - property Rel: string read FRel write SetRel; - property DisplayName: string read FDisplayName write FDisplayName; - property Primary: boolean read FPrimary write FPrimary; - property EmailType:TTypeElement read FEmailType write SetEmailType; - end; - -type - TgdExtendedPropertyStruct = record - Name: string; - Value: string; - end; - -type - TgdGeoPtStruct = record - Elav: extended; - Labels: string; - Lat: extended; - Lon: extended; - Time: TDateTime; - end; - -type - TIMProtocol = (tiAIM,tiMSN,tiYAHOO,tiSKYPE,tiQQ,tiGOOGLE_TALK,tiICQ,tiJABBER); - TIMtype = (timHome,timNetmeeting,timOther,timWork); - -type - TgdIm = class(TPersistent) - private { DONE -oЯ -cНедочёт : Добавить типы данных на протокол и атрибут Rel, избавиться от свойств string } - FAddress: string; - FLabel: string; - FPrimary: boolean; - FIMProtocol:TIMProtocol; - FIMType:TIMtype; - const - RelValues: array[0..3]of string=('home','netmeeting','other','work'); - ProtocolValues:array[0..7]of string=('AIM','MSN','YAHOO','SKYPE','QQ','GOOGLE_TALK','ICQ','JABBER'); - public - constructor Create(ByNode: TXMLNode=nil); - procedure ParseXML(const Node: TXmlNode); - function AddToXML(Root:TXMLNode):TXmlNode; - 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(TPersistent) - 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; - 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=(tpAssistant,tpCallback,tpCar,TpCompany_main,tpFax, - tpHome,tpHome_fax,tpIsdn,tpMain,tpMobile,tpOther,tpOther_fax, - tpPager,tpRadio,tpTelex,tpTty_tdd,TpWork,tpWork_fax, - tpWork_mobile,tpWork_pager); -type - TgdPhoneNumber = class(TPersistent) - private { DONE -oЯ -cНедочёт : убрать строковое поле FRel - добавлять значение в зависимости от типа } - FPrimary: boolean; - FPhoneType: TPhonesRel; - FLabel: string; - // Frel: string; - FUri: string; - FValue: string; - const RelValues: array[0..19]of string=('assistant','callback','car','company_main','fax', - 'home','home_fax','isdn','main','mobile','other','other_fax','pager', - 'radio','telex','tty_tdd','work','work_fax','work_mobile','work_pager'); - // procedure SetRel(aPhoneRel:TPhonesRel); - public - constructor Create(ByNode: TXMLNode=nil); - procedure ParseXML(const Node: TXmlNode); - function AddToXML(Root:TXMLNode):TXmlNode; - property PhoneType: TPhonesRel read FPhoneType write FPhoneType; - property Primary: boolean read FPrimary write FPrimary; - property Labl: string read FLabel write FLabel; -// property Rel: string 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(TPersistent) - private - FText: TStringList; - public - Constructor Create(const ByNode:IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root:IXMLNode):IXMLNode; - property Text: TStringList read FText write FText; -end; - -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:IXMLNode); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root:IXMLNode):IXMLNode; - 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); - -type - TgdWhen = class - private - FendTime: TDateTime; - FstartTime: TDateTime; - FvalueString: string; - public - Constructor Create(const ByNode:TXMLNode=nil); - 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(TPersistent) - 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; - FCoutry: TgdCountry; - FFormattedAddress: TgdFormattedAddress; - public - Constructor Create(const ByNode:TXMLNode=nil); - procedure ParseXML(Node: TXMLNode); - function AddToXML(Root:TXMLNode):TXMLNode; - 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 FCoutry write FCoutry; - property FormattedAddress: TgdFormattedAddress read FFormattedAddress write FFormattedAddress; - end; - -type - TgdEntryLink = class(TPersistent) - private - Fhref: string; - FReadOnly: boolean; - Frel: string; - FAtomEntry: IXMLNode; - public - Constructor Create(const ByNode:IXMLNode); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root:IXMLNode):IXMLNode; - 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(TPersistent) - private - Flabel: string; - Frel: string; - FvalueString: string; - FEntryLink: TgdEntryLink; - public - Constructor Create(const ByNode:IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root:IXMLNode):IXMLNode; - 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 = (twAttendee,twOrganizer,twPerformer,twSpeaker,twBcc,twCc,twFrom,twReply,twTo); -{ DONE -oЯ -cНедочёт : Перенести константы в класс } -type - TgdWho = class(TPersistent) - private { DONE -oЯ -cНедочёт : Избивиться от строковых свойств } - 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'); -// procedure SetRel(aRel:string); -// procedure SetRelValue(aRelValue:TWhoRel); - public - Constructor Create(const ByNode:IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - function AddToXML(Root:IXMLNode):IXMLNode; - property Email: string read FEmail write FEmail; -// property Rel: string read Frel write SetRel; - 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): integer; - -function gdAttendeeStatus(aXMLNode: IXMLNode): TgdAttendeeStatus; -function gdAttendeeType(aXMLNode: IXMLNode): TgdAttendeeType; -function gdTransparency(aXMLNode: IXMLNode): TgdTransparency; -function gdVisibility(aXMLNode: IXMLNode): TgdVisibility; -function gdEventStatus(aXMLNode: IXMLNode): TgdEventStatus; -function gdWhere(aXMLNode: IXMLNode):TgdWhere; -function gdWhen(aXMLNode: TXMLNode):TgdWhen; -function gdWho(aXMLNode: IXMLNode):TgdWho; -function gdRecurrence(aXMLNode: IXMLNode):TgdRecurrence; -function gdReminder(aXMLNode: IXMLNode):TgdReminder; - -implementation - -function gdReminder(aXMLNode: IXMLNode):TgdReminder; -begin - Result:=TgdReminder.Create(aXMLNode); -end; - -function gdRecurrence(aXMLNode: IXMLNode):TgdRecurrence; -begin - Result:=TgdRecurrence.Create(aXMLNode); -end; - -function gdWho(aXMLNode: IXMLNode):TgdWho; -begin - Result:=TgdWho.Create(aXMLNode); -end; - -function gdWhen(aXMLNode: TXMLNode):TgdWhen; -begin - Result:=TgdWhen.Create(aXMLNode); -end; - -function gdWhere(aXMLNode: IXMLNode):TgdWhere; -begin - Result:=TgdWhere.Create(aXMLNode); -end; - -function gdEventStatus(aXMLNode: IXMLNode): TgdEventStatus; -begin - Result:=TgdEventStatus.Create(aXMLNode); -end; - -function gdVisibility(aXMLNode: IXMLNode): TgdVisibility; -begin - Result:=TgdVisibility.Create(aXMLNode); -end; - -function gdTransparency(aXMLNode: IXMLNode): TgdTransparency; -begin - Result:=TgdTransparency.Create(aXMLNode); -end; - -function GetGDNodeType(cName: string): integer; -begin - Result := AnsiIndexStr(cName, cGDTagNames); -end; - -function gdAttendeeType(aXMLNode: IXMLNode): TgdAttendeeType; -begin - Result:=TgdAttendeeType.Create(aXMLNode); -end; - -function gdAttendeeStatus(aXMLNode: IXMLNode): TgdAttendeeStatus; -begin - Result:=TgdAttendeeStatus.Create(aXMLNode); -end; - -{ TgdWhere } - -function TgdWhere.AddToXML(Root: IXMLNode): IXMLNode; -begin - //добавляем узел - if Root=nil then Exit; - Result:=Root.AddChild(cgdTagNames[ord(egdWhere)]); - if Length(Flabel)>0 then - Result.Attributes['label']:=Flabel; - if Length(Frel)>0 then - Result.Attributes['rel']:=Frel; - if Length(FvalueString)>0 then - Result.Attributes['valueString']:=FvalueString; - if FEntryLink<>nil then - if (FEntryLink.FAtomEntry<>nil)or(Length(FEntryLink.Fhref)>0) then - FEntryLink.AddToXML(Result); -end; - -constructor TgdWhere.Create(const ByNode: IXMLNode); -begin -inherited Create; -if ByNode=nil then Exit; -FEntryLink:=TgdEntryLink.Create(nil); -ParseXML(ByNode); -end; - -procedure TgdWhere.ParseXML(Node: IXMLNode); -begin -if GetGDNodeType(Node.NodeName) <> ord(egdWhere) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdWhere)]])); - try - if Node.Attributes['label']<>null then - Flabel:=Node.Attributes['label']; - if Node.Attributes['rel']<>null then - Flabel:=Node.Attributes['rel']; - if Node.Attributes['valueString']<>null then - FvalueString:=Node.Attributes['valueString']; - if Node.ChildNodes.Count>0 then //есть дочерний узел с EntryLink - begin - FEntryLink.ParseXML(Node.ChildNodes.FindNode('gd:entry')); - end; - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -{ TgdEntryLinkStruct } - -function TgdEntryLink.AddToXML(Root: IXMLNode): IXMLNode; -begin -if Root=nil then Exit; - Result:=Root.AddChild(cgdTagNames[ord(egdEntryLink)]); - if Length(Trim(Fhref))>0 then - Result.Attributes['href']:=Fhref; - if Length(Trim(Frel))>0 then - Result.Attributes['rel']:=Frel; - Result.Attributes['readOnly']:=FReadOnly; - if FAtomEntry<>nil then - Result.ChildNodes.Add(FAtomEntry); -end; - -constructor TgdEntryLink.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -procedure TgdEntryLink.ParseXML(Node: IXMLNode); -begin -if GetGDNodeType(Node.NodeName) <> ord(egdEntryLink) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdEntryLink)]])); - try - if Node.Attributes['href']<>null then - Fhref:=Node.Attributes['href']; - if Node.Attributes['rel']<>null then - Frel:=Node.Attributes['rel']; - if Node.Attributes['readOnly']<>null then - FReadOnly:=Node.Attributes['readOnly']; - if Node.ChildNodes.Count>0 then //есть дочерний узел с EntryLink - FAtomEntry:=Node.ChildNodes.FindNode('entry'); - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -{ TgdEventStatus } - -function TgdEventStatus.AddToXML(Root: IXMLNode): IXMLNode; -begin -if Root=nil then Exit; - Result:=Root.AddChild(cgdTagNames[ord(egdEventStatus)]); - Result.Attributes['value']:=SchemaHref+FValue; -end; - -constructor TgdEventStatus.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -procedure TgdEventStatus.ParseXML(Node: IXMLNode); -begin - if Node=nil then Exit; - if GetGDNodeType(Node.NodeName) <> ord(egdEventStatus) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdEventStatus)]])); - try - // ShowMessage(Node.Attributes['value']); - FValue:=VarToStr(Node.Attributes['value']); - FValue:=StringReplace(FValue,SchemaHref,'',[rfIgnoreCase]); - FStatus:=TEventStatus(AnsiIndexStr(FValue, RelValues)); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -procedure TgdEventStatus.SetStatus(aStatus: TEventStatus); -begin - FStatus:=aStatus; - FValue:=RelValues[ord(aStatus)] -end; - -//procedure TgdEventStatus.SetValue(aValue: string); -//begin -// if AnsiIndexStr(aValue, RelValues)<=0 then -// raise Exception.Create(Format(rcErrMissValue, [cGDTagNames[ord(egdEventStatus)]])); -// FStatus:=TEventStatus(AnsiIndexStr(aValue, RelValues)); -// FValue:=aValue; -//end; - -{ TgdWhen } - -function TgdWhen.AddToXML(Root: TXMLNode;DateFormat:TDateFormat): TXMLNode; -begin - if (Root=nil)or isEmpty then Exit; - Result:=Root.NodeNew(cgdTagNames[ord(egdWhen)]); - 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; - -constructor TgdWhen.Create(const ByNode: TXMLNode); -begin - inherited Create; - FendTime:=0; - FstartTime:=0; - FvalueString:=''; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -function TgdWhen.isEmpty: boolean; -begin - Result:=(FendTime<=0)and(FstartTime<=0)and(length(Trim(FvalueString))=0); -end; - -procedure TgdWhen.ParseXML(Node: TXMLNode); -begin -if Node=nil then Exit; - if GetGDNodeType(Node.Name) <> ord(egdWhen) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdWhen)]])); - 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(rcErrPrepareNode, [Node.Name])); - end; -end; - -{ TgdAttendeeStatus } - -function TgdAttendeeStatus.AddToXML(Root: IXMLNode): IXMLNode; -begin - if Root=nil then Exit; - Result:=Root.AddChild(cgdTagNames[ord(egdAttendeeStatus)]); - Result.Attributes['value']:=SchemaHref+FValue; -end; - -constructor TgdAttendeeStatus.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -procedure TgdAttendeeStatus.ParseXML(Node: IXMLNode); -begin -if Node=nil then Exit; - if GetGDNodeType(Node.NodeName) <> ord(egdAttendeeStatus) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdAttendeeStatus)]])); - try - FValue := Node.Attributes['value']; - FValue:=StringReplace(FValue,SchemaHref,'',[rfIgnoreCase]); - FAttendeeStatus := TAttendeeStatus(AnsiIndexStr(FValue, RelValues)); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -procedure TgdAttendeeStatus.SetStatus(aStatus: TAttendeeStatus); -begin - FAttendeeStatus:=aStatus; - FValue:=RelValues[ord(aStatus)] -end; - -//procedure TgdAttendeeStatus.SetValue(aValue: string); -//begin -// if AnsiIndexStr(aValue, cAttendeeStatus)<=0 then -// raise Exception.Create(Format(rcErrMissValue, [cGDTagNames[ord(egdAttendeeStatus)]])); -// FAttendeeStatus:=TAttendeeStatus(AnsiIndexStr(aValue, cAttendeeStatus)); -// FValue:=aValue; -//end; - -{ TgdAttendeeType } - -function TgdAttendeeType.AddToXML(Root: IXMLNode): IXMLNode; -begin - if Root=nil then Exit; - Result:=Root.AddChild(cgdTagNames[ord(egdAttendeeType)]); - Result.Attributes['value']:=SchemaHref+FValue; -end; - -constructor TgdAttendeeType.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -procedure TgdAttendeeType.ParseXML(Node: IXMLNode); -begin - if Node=nil then Exit; - if GetGDNodeType(Node.NodeName) <> ord(egdAttendeeType) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdAttendeeType)]])); - try - FValue:=Node.Attributes['value']; - FValue:=StringReplace(FValue,SchemaHref,'',[rfIgnoreCase]); - FAttType := TAttendeeType(AnsiIndexStr(FValue, RelValues)); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -procedure TgdAttendeeType.SetType(aStatus: TAttendeeType); -begin - FAttType:=aStatus; - FValue:=RelValues[ord(aStatus)] -end; - -//procedure TgdAttendeeType.SetValue(aValue: string); -//begin -// if AnsiIndexStr(aValue, cAttendeeType)<=0 then -// raise Exception.Create(Format(rcErrMissValue, [cGDTagNames[ord(egdAttendeeType)]])); -// FAttType:=TAttendeeType(AnsiIndexStr(aValue, cAttendeeType)); -// FValue:=aValue; -//end; - -{ TgdWho } - -function TgdWho.AddToXML(Root: IXMLNode): IXMLNode; -begin - if Root=nil then Exit; - Result:=Root.AddChild(cgdTagNames[ord(egdWho)]); - if Length(Trim(FEmail))>0 then - Result.Attributes['email']:=FEmail; - if Length(Trim(Frel))>0 then - Result.Attributes['rel']:=SchemaHref+RelValues[ord(FRelValue)]; - if Length(Trim(FvalueString))>0 then - Result.Attributes['valueString']:=FvalueString; - if FAttendeeStatus<>nil then - FAttendeeStatus.AddToXML(Result); - if FAttendeeType<>nil then - FAttendeeType.AddToXML(Result); - if FEntryLink<>nil then - FEntryLink.AddToXML(Result); -end; - -constructor TgdWho.Create(const ByNode: IXMLNode); -begin - inherited Create; - FEmail:=''; -// Frel:=''; - FvalueString:=''; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -procedure TgdWho.ParseXML(Node: IXMLNode); -var i:integer; - s:string; -begin - if Node=nil then Exit; - if GetGDNodeType(Node.NodeName) <> ord(egdWho) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdWho)]])); - try - if Node.Attributes['email']<>null then - FEmail:=Node.Attributes['email']; - if Node.Attributes['rel']<>null then - begin - S:=Node.Attributes['rel']; - S:=StringReplace(S,SchemaHref,'',[rfIgnoreCase]); - FRelValue:=TWhoRel(AnsiIndexStr(S, RelValues)); - end; - if Node.Attributes['valueString']<>null then - FvalueString:=Node.Attributes['valueString']; - if Node.ChildNodes.Count>0 then - begin - for I := 0 to Node.ChildNodes.Count-1 do - case GetGDNodeType(Node.ChildNodes[i].NodeName) of - ord(egdAttendeeStatus): - FAttendeeStatus:=TgdAttendeeStatus.Create(Node.ChildNodes[i]); - ord(egdAttendeeType): - FAttendeeType:=TgdAttendeeType.Create(Node.ChildNodes[i]); - ord(egdEntryLink): - FEntryLink:=TgdEntryLink.Create(Node.ChildNodes[i]); - end; - end; - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -//procedure TgdWho.SetRel(aRel: string); -//begin -//if AnsiIndexStr(aRel, cWhoRel)<=0 then -// raise Exception.Create(Format(rcErrMissValue, [cGDTagNames[ord(egdWho)]])); -// FRelValue:=TWhoRel(AnsiIndexStr(aRel, cWhoRel)); -// Frel:=aRel; -//end; - -//procedure TgdWho.SetRelValue(aRelValue: TWhoRel); -//begin -// FRelValue:=aRelValue; -// // Frel:=cWhoRel[ord(aRelValue)] -//end; - -{ TgdRecurrence } - -function TgdRecurrence.AddToXML(Root: IXMLNode): IXMLNode; -begin -if Root=nil then Exit; - Result:=Root.AddChild(cgdTagNames[ord(egdRecurrence)]); - Result.Text:=FText.Text; -end; - -constructor TgdRecurrence.Create(const ByNode: IXMLNode); -begin - inherited Create; - FText:=TStringList.Create; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -procedure TgdRecurrence.ParseXML(Node: IXMLNode); -begin -if Node=nil then Exit; - if GetGDNodeType(Node.NodeName) <> ord(egdRecurrence) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdRecurrence)]])); - try - FText.Text:=Node.Text; - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -{ TgdReminder } - -function TgdReminder.AddToXML(Root: IXMLNode): IXMLNode; -begin - if Root=nil then Exit; - Result:=Root.AddChild(cgdTagNames[ord(egdReminder)]); - Result.Attributes['method']:=cMethods[ord(Fmethod)]; - case FPeriod of - tpDays: Result.Attributes['days']:=FPeriodValue; - tpHours: Result.Attributes['hours']:=FPeriodValue; - tpMinutes: Result.Attributes['minutes']:=FPeriodValue; - end; - if FabsoluteTime>0 then - Result.Attributes['absoluteTime']:=DateTimeToServerDate(FabsoluteTime) -end; - -constructor TgdReminder.Create(const ByNode: IXMLNode); -begin - inherited Create; - FabsoluteTime:=0; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -procedure TgdReminder.ParseXML(Node: IXMLNode); -begin -if Node=nil then Exit; - if GetGDNodeType(Node.NodeName) <> ord(egdReminder) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdReminder)]])); - try - if (Node.Attributes['absoluteTime']<>null)and(Length(Trim(Node.Attributes['absoluteTime']))>0) then - FabsoluteTime:=ServerDateToDateTime(Node.Attributes['absoluteTime']); - if Node.Attributes['method']<>null then - Fmethod:=TMethod(AnsiIndexStr(Node.Attributes['method'], cMethods)); - if Node.Attributes['days']<>null then - FPeriod:=tpDays; - if Node.Attributes['hours']<>null then - FPeriod:=tpHours; - if Node.Attributes['minutes']<>null then - FPeriod:=tpMinutes; - case FPeriod of - tpDays: FPeriodValue:=Node.Attributes['days']; - tpHours: FPeriodValue:=Node.Attributes['hours']; - tpMinutes: FPeriodValue:=Node.Attributes['minutes']; - end; - - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -{ TgdTransparency } - -function TgdTransparency.AddToXML(Root: IXMLNode): IXMLNode; -begin -if Root=nil then Exit; -Result:=Root.AddChild(cgdTagNames[ord(egdTransparency)]); -Result.Attributes['value']:=SchemaHref+FValue; -end; - -constructor TgdTransparency.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -procedure TgdTransparency.ParseXML(Node: IXMLNode); -begin - if Node=nil then Exit; - if GetGDNodeType(Node.NodeName) <> ord(egdTransparency) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdTransparency)]])); - try - FValue := Node.Attributes['value']; - FValue:=StringReplace(FValue,SchemaHref,'',[rfIgnoreCase]); - FTransparency := TTransparency(AnsiIndexStr(FValue, RelValues)); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -procedure TgdTransparency.SetTransp(aTransp: TTransparency); -begin - FTransparency:=aTransp; - FValue:=RelValues[ord(aTransp)] -end; - -//procedure TgdTransparency.SetValue(aValue: string); -//begin -//if AnsiIndexStr(aValue, cTransparency)<=0 then -// raise Exception.Create(Format(rcErrMissValue, [cGDTagNames[ord(egdTransparency)]])); -// FTransparency:=TTransparency(AnsiIndexStr(aValue, cTransparency)); -// FValue:=aValue; -//end; - -{ TgdVisibility } - -function TgdVisibility.AddToXML(Root: IXMLNode): IXMLNode; -begin -if Root=nil then Exit; -Result:=Root.AddChild(cgdTagNames[ord(egdVisibility)]); -Result.Attributes['value']:=SchemaHref+FValue; -end; - -constructor TgdVisibility.Create(const ByNode: IXMLNode); -begin - inherited Create; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -procedure TgdVisibility.ParseXML(Node: IXMLNode); -begin - if Node=nil then Exit; - if GetGDNodeType(Node.NodeName) <> ord(egdVisibility) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdVisibility)]])); - try - FValue := Node.Attributes['value']; - FValue:=StringReplace(FValue,SchemaHref,'',[rfIgnoreCase]); - FVisible := TVisibility(AnsiIndexStr(FValue, RelValues)); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - -//procedure TgdVisibility.SetValue(aValue: string); -//begin -//if AnsiIndexStr(aValue, RelValues)<=0 then -// raise Exception.Create(Format(rcErrMissValue, [cGDTagNames[ord(egdVisibility)]])); -// FVisible:=TVisibility(AnsiIndexStr(aValue, RelValues)); -// FValue:=aValue; -//end; - -procedure TgdVisibility.SetVisible(aVisible: TVisibility); -begin - FVisible:=aVisible; - FValue:=RelValues[ord(aVisible)] -end; - -{ TgdOrganization } - -function TgdOrganization.AddToXML(Root: TXMLNode): TXmlNode; -begin -if (Root=nil)or -((Trim(FRel)='')and - (Trim(FLabel)='')and - (Trim(ForgName.Value)='')and - (Trim(ForgTitle.Value)='')) then Exit; - - -Result:=Root.NodeNew(cGDTagNames[ord(egdOrganization)]); -if Trim(FRel)<>'' then - Result.WriteAttributeString('rel',FRel); -if Trim(FLabel)<>'' then - Result.WriteAttributeString('label',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; - -constructor TgdOrganization.Create(ByNode: TXMLNode); -begin - inherited Create; - ForgName:=TgdOrgName.Create; - ForgTitle:=TgdOrgTitle.Create; - FLabel:=''; - Frel:=''; - if ByNode<>nil then - ParseXML(ByNode); - -end; - -function TgdOrganization.IsEmpty: boolean; -begin -Result:=(Length(Trim(FLabel))=0)and(Length(Trim(Frel))=0) -end; - -procedure TgdOrganization.ParseXML(const Node: TXmlNode); -var i:integer; -begin -if (Node=nil)or IsEmpty then Exit; - if GetGDNodeType(Node.Name) <> ord(egdOrganization) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdOrganization)]])); - try - Frel:=Node.ReadAttributeString('rel'); - if Node.HasAttribute('primary') then - Fprimary:=Node.ReadAttributeBool('primary'); - if Node.HasAttribute('label') then - FLabel:=Node.ReadAttributeString('label'); - for i:=0 to Node.NodeCount-1 do - begin - if LowerCase(Node.Nodes[i].Name)=LowerCase(cGDTagNames[ord(egdOrgName)]) then - ForgName:=TgdOrgName.Create(Node.Nodes[i]) - else - if LowerCase(Node.Nodes[i].Name)=LowerCase(cGDTagNames[ord(egdOrgTitle)]) then - ForgTitle:=TgdOrgTitle.Create(Node.Nodes[i]); - end; - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -{ TgdEmailStruct } - -function TgdEmail.AddToXML(Root: TXMLNode): TXmlNode; -begin - if Root=nil then Exit; - Result:=Root.NodeNew(cGDTagNames[ord(egdEmail)]); - if Trim(FRel)<>'' then - Result.WriteAttributeString('rel',FRel); - if Trim(FLabel)<>'' then - Result.WriteAttributeString('label',FLabel); - if Trim(FLabel)<>'' then - Result.WriteAttributeString('displayName',FDisplayName); - if FPrimary then - Result.WriteAttributeBool('primary',FPrimary); - Result.WriteAttributeString('address',FAddress); -end; - -constructor TgdEmail.Create(ByNode: TXMLNode); -begin - inherited Create; - if ByNode<>nil then - ParseXML(ByNode); -end; - -procedure TgdEmail.ParseXML(const Node: TXmlNode); -begin - if Node=nil then Exit; - if GetGDNodeType(Node.Name) <> ord(egdEmail) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdEmail)]])); - try - Frel:=Node.ReadAttributeString('rel'); - if Node.HasAttribute('primary') then - Fprimary:=Node.ReadAttributeBool('primary'); - if Node.HasAttribute('label') then - FLabel:=Node.ReadAttributeString('label'); - if Node.HasAttribute('displayName') then - FDisplayName:=Node.ReadAttributeString('displayName'); - FAddress:=Node.ReadAttributeString('address'); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -procedure TgdEmail.SetEmailType(aType: TTypeElement); -begin -FEmailType:=aType; -SetRel(RelValues[ord(aType)]); -end; - -procedure TgdEmail.SetRel(const aRel: string); -begin - if AnsiIndexStr(aRel,RelValues)<0 then - raise Exception.Create - (Format(rcErrWriteNode, [cGDTagNames[ord(egdEmail)]])+' '+Format(rcWrongAttr,['rel'])); - FRel:=SchemaHref+aRel; -end; - -{ TgdNameStruct } - -function TgdName.AddToXML(Root: TXMLNode): TXmlNode; -begin - if (Root=nil)or IsEmpty then Exit; - - Result:=Root.NodeNew(cGDTagNames[ord(egdName)]); - 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; - -constructor TgdName.Create(ByNode: TXMLNode); -begin - inherited Create; - FGivenName:=TgdGivenName.Create(); - FAdditionalName:=TgdAdditionalNameStruct.Create(); - FFamilyName:=TgdFamilyName.Create(); - FNamePrefix:=TgdNamePrefix.Create(); - FNameSuffix:=TgdNameSuffix.Create(); - FFullName:=TgdFullName.Create(); - 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.Name) <> ord(egdName) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdName)]])); - try - for i:=0 to Node.NodeCount-1 do - begin - case GetGDNodeType(Node.Nodes[i].Name) of - ord(egdGivenName):FGivenName.ParseXML(Node.Nodes[i]); - ord(egdAdditionalName):FAdditionalName.ParseXML(Node.Nodes[i]); - ord(egdFamilyName):FFamilyName.ParseXML(Node.Nodes[i]); - ord(egdNamePrefix):FNamePrefix.ParseXML(Node.Nodes[i]); - ord(egdNameSuffix):FNameSuffix.ParseXML(Node.Nodes[i]); - ord(egdFullName):FFullName.ParseXML(Node.Nodes[i]); - end; - end; - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -{ TgdPhoneNumber } - -function TgdPhoneNumber.AddToXML(Root: TXMLNode): TXmlNode; -begin - if Root=nil then Exit; - Result:=Root.NodeNew(cGDTagNames[ord(egdPhoneNumber)]); - Result.WriteAttributeString('rel',SchemaHref+RelValues[ord(FPhoneType)]); - Result.ValueAsString:=FValue; - if Trim(FLabel)<>'' then - Result.WriteAttributeString('label',FLabel); - if Trim(FUri)<>'' then - Result.WriteAttributeString('uri',FUri); - if FPrimary then - Result.WriteAttributeBool('primary',FPrimary); -end; - -constructor TgdPhoneNumber.Create(ByNode: TXMLNode); -begin - inherited Create; - if ByNode<>nil then - ParseXML(ByNode); -end; - -procedure TgdPhoneNumber.ParseXML(const Node: TXmlNode); -var s:string; -begin - if Node=nil then Exit; - if GetGDNodeType(Node.Name) <> ord(egdPhoneNumber) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdPhoneNumber)]])); - try - s:=Node.ReadAttributeString('rel'); - s:=StringReplace(s,SchemaHref,'',[rfIgnoreCase]); - if AnsiIndexStr(s,RelValues)>-1 then - FPhoneType:=TPhonesRel(AnsiIndexStr(s,RelValues)) - else - FPhoneType:=tpOther; - if Node.HasAttribute('primary') then - Fprimary:=Node.ReadAttributeBool('primary'); - if Node.HasAttribute('label') then - FLabel:=Node.ReadAttributeString('label'); - if Node.HasAttribute('uri') then - FUri:=Node.ReadAttributeString('uri'); - FValue:=Node.ValueAsString; - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -//procedure TgdPhoneNumber.SetRel(aPhoneRel: TPhonesRel); -//begin -// FPhoneType:=aPhoneRel; -//end; - -{ TgdCountry } - -function TgdCountry.AddToXML(Root: TXMLNode): TXMLNode; -begin - if Root=nil then Exit; - Result:=Root.NodeNew(cGDTagNames[ord(egdCountry)]); - if Trim(FCode)<>'' then - Result.WriteAttributeString('code',FCode); - Result.ValueAsString:=FValue; -end; - -constructor TgdCountry.Create(const ByNode: TXMLNode); -begin - inherited Create; - if ByNode<>nil then - ParseXML(ByNode); -end; - -procedure TgdCountry.ParseXML(Node: TXMLNode); -begin - if Node=nil then Exit; - if GetGDNodeType(Node.Name) <> ord(egdCountry) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdCountry)]])); - try - FCode:=Node.ReadAttributeString('rel'); - FValue:=Node.ValueAsString; - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -{ TgdStructuredPostalAddressStruct } - -function TgdStructuredPostalAddress.AddToXML(Root: TXMLNode): TXMLNode; -begin - if Root=nil then Exit; - Result:=Root.NodeNew(cGDTagNames[ord(egdStructuredPostalAddress)]); - if Trim(FRel)<>'' then - Result.WriteAttributeString('rel',FRel); - if Trim(FMailClass)<>'' then - Result.WriteAttributeString('mailClass',FMailClass); - if Trim(Flabel)<>'' then - Result.WriteAttributeString('label',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 FCoutry<>nil then - FCoutry.AddToXML(Result); - if FFormattedAddress<>nil then - FFormattedAddress.AddToXML(Result); -end; - -constructor TgdStructuredPostalAddress.Create(const ByNode: TXMLNode); -begin - inherited Create; - if ByNode<>nil then - ParseXML(ByNode); -end; - -procedure TgdStructuredPostalAddress.ParseXML(Node: TXMLNode); -var i:integer; -begin -if Node=nil then Exit; - if GetGDNodeType(Node.Name) <> ord(egdStructuredPostalAddress) then - raise Exception.Create(Format(rcErrCompNodes, - [cGDTagNames[ord(egdStructuredPostalAddress)]])); - try - FRel:=Node.ReadAttributeString('rel'); - FMailClass:=Node.ReadAttributeString('mailClass'); - Flabel:=Node.ReadAttributeString('label'); - if Node.HasAttribute('primaty') then - Fprimary:=Node.ReadAttributeBool('primary'); - FUsage:=Node.ReadAttributeString('Usage'); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; - for I := 0 to Node.NodeCount - 1 do - begin - case GetGDNodeType(Node.Nodes[i].Name) of - ord(egdAgent):FAgent:=TgdAgent.Create(Node.Nodes[i]); - ord(egdHousename):FHousename:=TgdHousename.Create(Node.Nodes[i]); - ord(egdStreet):FStreet:=TgdStreet.Create(Node.Nodes[i]); - ord(egdPobox):FPobox:=TgdPobox.Create(Node.Nodes[i]); - ord(egdNeighborhood):FNeighborhood:=TgdNeighborhood.Create(Node.Nodes[i]); - ord(egdCity):FCity:=TgdCity.Create(Node.Nodes[i]); - ord(egdSubregion):FSubregion:=TgdSubregion.Create(Node.Nodes[i]); - ord(egdRegion):FRegion:=TgdRegion.Create(Node.Nodes[i]); - ord(egdPostcode):FPostcode:=TgdPostcode.Create(Node.Nodes[i]); - ord(egdCountry):FCoutry:=TgdCountry.Create(Node.Nodes[i]); - ord(egdFormattedAddress):FFormattedAddress:=TgdFormattedAddress.Create(Node.Nodes[i]); - end; - end; -end; - -{ TgdIm } - -function TgdIm.AddToXML(Root: TXMLNode): TXmlNode; -begin - if Root=nil then Exit; - Result:=Root.NodeNew(cGDTagNames[ord(egdIm)]); - - Result.WriteAttributeString('rel',SchemaHref+RelValues[ord(FIMType)]); - Result.WriteAttributeString('address',FAddress); - Result.WriteAttributeString('label',FLabel); - Result.WriteAttributeString('protocol',SchemaHref+ProtocolValues[ord(FIMProtocol)]); - if FPrimary then - Result.WriteAttributeBool('primary',FPrimary); -end; - -constructor TgdIm.Create(ByNode: TXMLNode); -begin - inherited Create; - if ByNode<>nil then - ParseXML(ByNode); -end; - -procedure TgdIm.ParseXML(const Node: TXmlNode); -var s:string; -begin -if Node=nil then Exit; - if GetGDNodeType(Node.Name) <> ord(egdIm) then - raise Exception.Create(Format(rcErrCompNodes,[cGDTagNames[ord(egdIm)]])); - try - s:=Node.ReadAttributeString('rel'); - s:=StringReplace(s,SchemaHref,'',[rfIgnoreCase]); - FIMType:=TImtype(AnsiIndexStr(s,RelValues)); - FLabel:=Node.ReadAttributeString('label'); - FAddress:=Node.ReadAttributeString('address'); - s:=Node.ReadAttributeString('protocol'); - s:=StringReplace(s,SchemaHref,'',[rfIgnoreCase]); - if AnsiIndexStr(s,ProtocolValues)>-1 then - FIMProtocol:=TIMProtocol(AnsiIndexStr(s,ProtocolValues)) - else - FIMProtocol:=tiGOOGLE_TALK; - if Node.HasAttribute('primary') then - FPrimary:=Node.ReadAttributeBool('primary'); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -end. -<<<<<<< HEAD ->>>>>>> remotes/origin/NMD -======= -======= -unit GDataCommon; - -interface - -uses NativeXML, Classes, StrUtils, SysUtils, GHelper, typinfo, uLanguage; - -type - 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 - TGDataTags = set of TgdEnum; - -type - TEventStatus = (esCanceled, esConfirmed, esTentative); - TgdEventStatus = class - private - FValue: string; - FStatus: TEventStatus; - const - RelValues: array [0..2]of string=( - 'event.canceled','event.confirmed','event.tentative'); - procedure SetStatus(aStatus:TEventStatus); - public - Constructor Create(const ByNode:TXMLNode=nil); - procedure Clear; - function IsEmpty: boolean; - procedure ParseXML(Node: TXMLNode); - function AddToXML(Root:TXMLNode):TXMLNode; - property Status:TEventStatus read FStatus write SetStatus; - end; - -type - TVisibility = (vConfidential, vDefault, vPrivate, vPublic); - TgdVisibility = class - private - FValue: string; - FVisible: TVisibility; - const - RelValues: array [0..3]of string = ( - 'event.confidential','event.default','event.private','event.public'); - procedure SetVisible(aVisible:TVisibility); - public - Constructor Create(const ByNode:TXMLNode=nil); - procedure Clear; - function IsEmpty:boolean; - procedure ParseXML(Node: TXMLNode); - function AddToXML(Root:TXMLNode):TXMLNode; - property Visibility: TVisibility read FVisible write SetVisible; - end; - -type - TTransparency = (tOpaque, tTransparent); - TgdTransparency = class(TPersistent) - private - FValue: string; - FTransparency: TTransparency; - const - RelValues: array [0 .. 1] of string = ('event.opaque','event.transparent'); -// procedure SetValue(aValue:string); - procedure SetTransp(aTransp:TTransparency); - public - Constructor Create(const ByNode:TXMLNode=nil); - procedure Clear; - function IsEmpty:boolean; - procedure ParseXML(Node: TXMLNode); - function AddToXML(Root:TXMLNode):TXMLNode; -// property Value: string read FValue write SetValue; - property Transparency: TTransparency read FTransparency write SetTransp; - end; - -type - TAttendeeType = (aOptional, aRequired); - TgdAttendeeType = class - private - FValue: string; - FAttType: TAttendeeType; - const RelValues: array [0 .. 1] of string = - ('event.optional','event.required'); -// procedure SetValue(aValue:string); - procedure SetType(aStatus:TAttendeeType); - public - Constructor Create(const ByNode:TXMLNode=nil); - procedure Clear; - function IsEmpty:boolean; - procedure ParseXML(Node: TXMLNode); - function AddToXML(Root:TXMLNode):TXMLNode; -// property Value: string read FValue write SetValue; - property AttendeeType: TAttendeeType read FAttType write SetType; - end; - -type - TAttendeeStatus = (asAccepted, asDeclined, asInvited, asTentative); - TgdAttendeeStatus = class - private - FValue: string; - FAttendeeStatus: TAttendeeStatus; - const - RelValues: array [0 .. 3] of string = ( - 'event.accepted','event.declined','event.invited','event.tentative'); - // procedure SetValue(aValue:string); - procedure SetStatus(aStatus:TAttendeeStatus); - public - Constructor Create(const ByNode:TXMLNode=nil); - procedure Clear; - function isEmpty: boolean; - procedure ParseXML(Node: TXMLNode); - function AddToXML(Root:TXMLNode):TXMLNode; -// property Value: string read FValue write SetValue; - property Status: TAttendeeStatus read FAttendeeStatus write SetStatus; - end; - -type - TEntryTerms = (ttAny, ttContact, ttEvent, ttMessage, ttType); - -type - TgdCountry = class(TPersistent) - 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 FNameSuffix; - property FullName: TTextTag read FFullName write SetFullName; - property FullNameString: string read GetFullName; -end; - -type - TTypeElement = (ttHome,ttOther, ttWork); - TgdEmail = class(TPersistent) - private - FAddress: string; - FEmailType: TTypeElement; - FLabel: string; - FRel: string; - FPrimary: boolean; - FDisplayName:string; - const RelValues: array[0..2]of string=('home','other','work'); - procedure SetRel(const aRel:string); - procedure SetEmailType(aType:TTypeElement); - public - constructor Create(ByNode: TXMLNode=nil); - procedure Clear; - function IsEmpty:boolean; - procedure ParseXML(const Node: TXmlNode); - function AddToXML(Root:TXMLNode):TXmlNode; - property Address : string read FAddress write FAddress; - property Labl:string read FLabel write FLabel; - property Rel: string read FRel write SetRel; - property DisplayName: string read FDisplayName write FDisplayName; - property Primary: boolean read FPrimary write FPrimary; - property EmailType:TTypeElement read FEmailType write SetEmailType; - end; - -type - TgdExtendedPropertyStruct = record - Name: string; - Value: string; - end; - -type - TgdGeoPtStruct = record - Elav: extended; - Labels: string; - Lat: extended; - Lon: extended; - Time: TDateTime; - end; - -type - TIMProtocol = (tiAIM,tiMSN,tiYAHOO,tiSKYPE,tiQQ,tiGOOGLE_TALK,tiICQ,tiJABBER); - TIMtype = (timHome,timNetmeeting,timOther,timWork); - -type - TgdIm = class(TPersistent) - private - FAddress: string; - FLabel: string; - FPrimary: boolean; - FIMProtocol:TIMProtocol; - FIMType:TIMtype; - const - RelValues: array[0..3]of string=('home','netmeeting','other','work'); - ProtocolValues:array[0..7]of string=('AIM','MSN','YAHOO','SKYPE','QQ','GOOGLE_TALK','ICQ','JABBER'); - public - constructor Create(ByNode: TXMLNode=nil); - procedure ParseXML(const Node: TXmlNode); - procedure Clear; - function IsEmpty: boolean; - function AddToXML(Root:TXMLNode):TXmlNode; - 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(TPersistent) - 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=(tpAssistant,tpCallback,tpCar,TpCompany_main,tpFax, - tpHome,tpHome_fax,tpIsdn,tpMain,tpMobile,tpOther,tpOther_fax, - tpPager,tpRadio,tpTelex,tpTty_tdd,TpWork,tpWork_fax, - tpWork_mobile,tpWork_pager); - TgdPhoneNumber = class - private { DONE -oЯ -cНедочёт : убрать строковое поле FRel - добавлять значение в зависимости от типа } - FPrimary: boolean; - FPhoneType: TPhonesRel; - FLabel: string; - // Frel: string; - FUri: string; - FValue: string; - const RelValues: array[0..19]of string=('assistant','callback','car','company_main','fax', - 'home','home_fax','isdn','main','mobile','other','other_fax','pager', - 'radio','telex','tty_tdd','work','work_fax','work_mobile','work_pager'); - // procedure SetRel(aPhoneRel:TPhonesRel); - public - constructor Create(ByNode: TXMLNode=nil); - function IsEmpty: boolean; - procedure Clear; - procedure ParseXML(const Node: TXmlNode); - function AddToXML(Root:TXMLNode):TXmlNode; - property PhoneType: TPhonesRel read FPhoneType write FPhoneType; - property Primary: boolean read FPrimary write FPrimary; - property Labl: string read FLabel write FLabel; -// property Rel: string 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 = (twAttendee,twOrganizer,twPerformer,twSpeaker,twBcc,twCc,twFrom,twReply,twTo); - TgdWho = class(TPersistent) - 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'); -// procedure SetRel(aRel:string); -// procedure SetRelValue(aRelValue:TWhoRel); - 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 Rel: string read Frel write SetRel; - 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; -function GetGDNodeName(NodeType:TgdEnum):string;inline; - -function gdAttendeeStatus(aXMLNode: TXMLNode): TgdAttendeeStatus; -function gdAttendeeType(aXMLNode: TXMLNode): TgdAttendeeType; -function gdTransparency(aXMLNode: TXMLNode): TgdTransparency; -function gdVisibility(aXMLNode: TXMLNode): TgdVisibility; -function gdEventStatus(aXMLNode: TXMLNode): TgdEventStatus; -function gdWhere(aXMLNode: TXMLNode):TgdWhere; -function gdWhen(aXMLNode: TXMLNode):TgdWhen; -function gdWho(aXMLNode: TXMLNode):TgdWho; -function gdRecurrence(aXMLNode: TXMLNode):TgdRecurrence; -function gdReminder(aXMLNode: TXMLNode):TgdReminder; - -implementation - -function GetGDNodeName(NodeType:TgdEnum):string;inline; -begin - Result:=StringReplace(GetEnumName(TypeInfo(TgdEnum),ord(NodeType)), - '_',':',[rfReplaceAll]); -end; - -function gdReminder(aXMLNode: TXMLNode):TgdReminder; -begin - Result:=TgdReminder.Create(aXMLNode); -end; - -function gdRecurrence(aXMLNode: TXMLNode):TgdRecurrence; -begin - Result:=TgdRecurrence.Create(aXMLNode); -end; - -function gdWho(aXMLNode: TXMLNode):TgdWho; -begin - Result:=TgdWho.Create(aXMLNode); -end; - -function gdWhen(aXMLNode: TXMLNode):TgdWhen; -begin - Result:=TgdWhen.Create(aXMLNode); -end; - -function gdWhere(aXMLNode: TXMLNode):TgdWhere; -begin - Result:=TgdWhere.Create(aXMLNode); -end; - -function gdEventStatus(aXMLNode: TXMLNode): TgdEventStatus; -begin - Result:=TgdEventStatus.Create(aXMLNode); -end; - -function gdVisibility(aXMLNode: TXMLNode): TgdVisibility; -begin - Result:=TgdVisibility.Create(aXMLNode); -end; - -function gdTransparency(aXMLNode: TXMLNode): TgdTransparency; -begin - Result:=TgdTransparency.Create(aXMLNode); -end; - -function GetGDNodeType(cName: string): TgdEnum; -begin - Result :=TgdEnum(GetEnumValue(TypeInfo(TgdEnum),ReplaceStr(cName,':','_'))); -end; - -function gdAttendeeType(aXMLNode: TXMLNode): TgdAttendeeType; -begin - Result:=TgdAttendeeType.Create(aXMLNode); -end; - -function gdAttendeeStatus(aXMLNode: TXMLNode): TgdAttendeeStatus; -begin - Result:=TgdAttendeeStatus.Create(aXMLNode); -end; - -{ TgdWhere } - -function TgdWhere.AddToXML(Root: TXMLNode): TXMLNode; -begin - //добавляем узел - if Root=nil then Exit; - Result:=Root.NodeNew(GetGDNodeName(gd_where)); - if Length(Flabel)>0 then - Result.WriteAttributeString('label',Flabel); - if Length(Frel)>0 then - Result.WriteAttributeString('rel',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.Name) <> gd_Where then - raise Exception.Create(Format(rcErrCompNodes, - [GetGDNodeName(gd_Where)])); - try - Flabel:=Node.ReadAttributeString('label'); - if Length(FLabel)=0 then - Flabel:=Node.ReadAttributeString('rel'); - FvalueString:=Node.ReadAttributeString('valueString'); - if Node.NodeCount>0 then //есть дочерний узел с EntryLink - begin - FEntryLink.ParseXML(Node.FindNode('gd:entry')); - end; - except - Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -{ TgdEntryLinkStruct } - -function TgdEntryLink.AddToXML(Root: TXMLNode): TXMLNode; -begin -if (Root=nil)or IsEmpty then Exit; - Result:=Root.NodeNew(GetGDNodeName(gd_EntryLink)); - if Length(Trim(Fhref))>0 then - Result.WriteAttributeString('href',Fhref); - if Length(Trim(Frel))>0 then - Result.WriteAttributeString('rel',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.Name) <> gd_EntryLink then - raise Exception.Create - (Format(rcErrCompNodes, - [GetGDNodeName(gd_EntryLink)])); - try -// if Node.Attributes['href']<>null then - Fhref:=Node.ReadAttributeString('href'); -// if Node.Attributes['rel']<>null then - Frel:=Node.ReadAttributeString('rel'); -// if Node.Attributes['readOnly']<>null then - FReadOnly:=Node.ReadAttributeBool('readOnly'); - if Node.NodeCount>0 then //есть дочерний узел с EntryLink - FAtomEntry:=Node.FindNode('entry'); - except - Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -{ TgdEventStatus } - -function TgdEventStatus.AddToXML(Root: TXMLNode): TXMLNode; -begin -if Root=nil then Exit; - Result:=Root.NodeNew(GetGDNodeName(gd_EventStatus)); - Result.WriteAttributeString('value',SchemaHref+FValue); -end; - -procedure TgdEventStatus.Clear; -begin -FValue:='' -end; - -constructor TgdEventStatus.Create(const ByNode: TXMLNode); -begin - inherited Create; - Clear; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -function TgdEventStatus.IsEmpty: boolean; -begin - Result:=Length(Trim(FValue))=0 -end; - -procedure TgdEventStatus.ParseXML(Node: TXMLNode); -begin - if Node=nil then Exit; - if GetGDNodeType(Node.Name) <> gd_EventStatus then - raise Exception.Create(Format(rcErrCompNodes, - [GetGDNodeName(gd_EventStatus)])); - try - // ShowMessage(Node.Attributes['value']); - FValue:=Node.ReadAttributeString('value'); - FValue:=StringReplace(FValue,SchemaHref,'',[rfIgnoreCase]); - FStatus:=TEventStatus(AnsiIndexStr(FValue, RelValues)); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -procedure TgdEventStatus.SetStatus(aStatus: TEventStatus); -begin - FStatus:=aStatus; - FValue:=RelValues[ord(aStatus)] -end; - -//procedure TgdEventStatus.SetValue(aValue: string); -//begin -// if AnsiIndexStr(aValue, RelValues)<=0 then -// raise Exception.Create(Format(rcErrMissValue, [cGDTagNames[ord(egdEventStatus)]])); -// FStatus:=TEventStatus(AnsiIndexStr(aValue, RelValues)); -// FValue:=aValue; -//end; - -{ TgdWhen } - -function TgdWhen.AddToXML(Root: TXMLNode;DateFormat:TDateFormat): TXMLNode; -begin - 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.Name) <> gd_When then - raise Exception.Create( - Format(rcErrCompNodes, - [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(rcErrPrepareNode, [Node.Name])); - end; -end; - -{ TgdAttendeeStatus } - -function TgdAttendeeStatus.AddToXML(Root: TXMLNode): TXMLNode; -begin - if Root=nil then Exit; - Result:=Root.NodeNew(GetGDNodeName(gd_AttendeeStatus)); - Result.WriteAttributeString('value',SchemaHref+FValue); -end; - -procedure TgdAttendeeStatus.Clear; -begin - FValue:=''; -end; - -constructor TgdAttendeeStatus.Create(const ByNode: TXMLNode); -begin - inherited Create; - Clear; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -function TgdAttendeeStatus.isEmpty: boolean; -begin - Result:=Length(Trim(FValue))=0 -end; - -procedure TgdAttendeeStatus.ParseXML(Node: TXMLNode); -begin -if (Node=nil)or isEmpty then Exit; - if GetGDNodeType(Node.Name) <> gd_AttendeeStatus then - raise Exception.Create(Format(rcErrCompNodes, - [GetGDNodeName(gd_AttendeeStatus)])); - try - FValue := Node.ReadAttributeString('value'); - FValue:=StringReplace(FValue,SchemaHref,'',[rfIgnoreCase]); - FAttendeeStatus := TAttendeeStatus(AnsiIndexStr(FValue, RelValues)); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -procedure TgdAttendeeStatus.SetStatus(aStatus: TAttendeeStatus); -begin - FAttendeeStatus:=aStatus; - FValue:=RelValues[ord(aStatus)] -end; - -//procedure TgdAttendeeStatus.SetValue(aValue: string); -//begin -// if AnsiIndexStr(aValue, cAttendeeStatus)<=0 then -// raise Exception.Create(Format(rcErrMissValue, [cGDTagNames[ord(egdAttendeeStatus)]])); -// FAttendeeStatus:=TAttendeeStatus(AnsiIndexStr(aValue, cAttendeeStatus)); -// FValue:=aValue; -//end; - -{ TgdAttendeeType } - -function TgdAttendeeType.AddToXML(Root: TXMLNode): TXMLNode; -begin - if (Root=nil)or IsEmpty then Exit; - Result:=Root.NodeNew(GetGDNodeName(gd_AttendeeType)); - Result.WriteAttributeString('value',SchemaHref+FValue); -end; - -procedure TgdAttendeeType.Clear; -begin - FValue:=''; -end; - -constructor TgdAttendeeType.Create(const ByNode: TXMLNode); -begin - inherited Create; - Clear; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -function TgdAttendeeType.IsEmpty: boolean; -begin -Result:=Length(Trim(FValue))=0; -end; - -procedure TgdAttendeeType.ParseXML(Node: TXMLNode); -begin - if Node=nil then Exit; - if GetGDNodeType(Node.Name) <> gd_AttendeeType then - raise Exception.Create( - Format(rcErrCompNodes, - [GetGDNodeName(gd_AttendeeType)])); - try - FValue:=Node.ReadAttributeString('value'); - FValue:=StringReplace(FValue,SchemaHref,'',[rfIgnoreCase]); - FAttType := TAttendeeType(AnsiIndexStr(FValue, RelValues)); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -procedure TgdAttendeeType.SetType(aStatus: TAttendeeType); -begin - FAttType:=aStatus; - FValue:=RelValues[ord(aStatus)] -end; - -//procedure TgdAttendeeType.SetValue(aValue: string); -//begin -// if AnsiIndexStr(aValue, cAttendeeType)<=0 then -// raise Exception.Create(Format(rcErrMissValue, [cGDTagNames[ord(egdAttendeeType)]])); -// FAttType:=TAttendeeType(AnsiIndexStr(aValue, cAttendeeType)); -// FValue:=aValue; -//end; - -{ TgdWho } - -function TgdWho.AddToXML(Root: TXMLNode): TXMLNode; -begin - 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('rel',SchemaHref+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.Name) <> gd_Who then - raise Exception.Create(Format(rcErrCompNodes, - [GetGDNodeName(gd_Who)])); - try -// if Node.Attributes['email']<>null then - FEmail:=Node.ReadAttributeString('email'); - if Length(Node.ReadAttributeString('rel'))>0 then - begin - S:=Node.ReadAttributeString('rel'); - S:=StringReplace(S,SchemaHref,'',[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].Name) 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(rcErrPrepareNode, [Node.Name])); - end; -end; - -//procedure TgdWho.SetRel(aRel: string); -//begin -//if AnsiIndexStr(aRel, cWhoRel)<=0 then -// raise Exception.Create(Format(rcErrMissValue, [cGDTagNames[ord(egdWho)]])); -// FRelValue:=TWhoRel(AnsiIndexStr(aRel, cWhoRel)); -// Frel:=aRel; -//end; - -//procedure TgdWho.SetRelValue(aRelValue: TWhoRel); -//begin -// FRelValue:=aRelValue; -// // Frel:=cWhoRel[ord(aRelValue)] -//end; - -{ TgdRecurrence } - -function TgdRecurrence.AddToXML(Root: TXMLNode): TXMLNode; -begin -if (Root=nil)or IsEmpty then Exit; - Result:=Root.NodeNew(GetGDNodeName(gd_Recurrence)); - Result.ValueAsString:=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.Name) <> gd_Recurrence then - raise Exception.Create(Format(rcErrCompNodes, - [GetGDNodeName(gd_Recurrence)])); - try - FText.Text:=Node.ValueAsString; - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -{ TgdReminder } - -function TgdReminder.AddToXML(Root:TXMLNode): TXMLNode; -begin - 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.Name) <> gd_Reminder then - raise Exception.Create(Format(rcErrCompNodes, - [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(rcErrPrepareNode, [Node.Name])); - end; -end; - -{ TgdTransparency } - -function TgdTransparency.AddToXML(Root: TXMLNode): TXMLNode; -begin -if (Root=nil)or IsEmpty then Exit; -Result:=Root.NodeNew(GetGDNodeName(gd_Transparency)); -Result.WriteAttributeString('value',SchemaHref+FValue); -end; - -procedure TgdTransparency.Clear; -begin - FValue:=''; -end; - -constructor TgdTransparency.Create(const ByNode: TXMLNode); -begin - inherited Create; - Clear; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -function TgdTransparency.IsEmpty: boolean; -begin - Result:=Length(Trim(FValue))=0 -end; - -procedure TgdTransparency.ParseXML(Node: TXMLNode); -begin - if Node=nil then Exit; - if GetGDNodeType(Node.Name) <> gd_Transparency then - raise Exception.Create(Format(rcErrCompNodes, - [GetGDNodeName(gd_Transparency)])); - try - FValue := Node.ReadAttributeString('value'); - FValue:=StringReplace(FValue,SchemaHref,'',[rfIgnoreCase]); - FTransparency := TTransparency(AnsiIndexStr(FValue, RelValues)); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -procedure TgdTransparency.SetTransp(aTransp: TTransparency); -begin - FTransparency:=aTransp; - FValue:=RelValues[ord(aTransp)] -end; - -//procedure TgdTransparency.SetValue(aValue: string); -//begin -//if AnsiIndexStr(aValue, cTransparency)<=0 then -// raise Exception.Create(Format(rcErrMissValue, [cGDTagNames[ord(egdTransparency)]])); -// FTransparency:=TTransparency(AnsiIndexStr(aValue, cTransparency)); -// FValue:=aValue; -//end; - -{ TgdVisibility } - -function TgdVisibility.AddToXML(Root: TXMLNode): TXMLNode; -begin -if (Root=nil)or IsEmpty then Exit; -Result:=Root.NodeNew(GetGDNodeName(gd_Visibility)); -Result.WriteAttributeString('value',SchemaHref+FValue); -end; - -procedure TgdVisibility.Clear; -begin - FValue:=''; -end; - -constructor TgdVisibility.Create(const ByNode: TXMLNode); -begin - inherited Create; - Clear; - if ByNode=nil then Exit; - ParseXML(ByNode); -end; - -function TgdVisibility.IsEmpty: boolean; -begin - Result:=Length(Trim(FValue))=0 -end; - -procedure TgdVisibility.ParseXML(Node: TXMLNode); -begin - if Node=nil then Exit; - if GetGDNodeType(Node.Name) <> gd_Visibility then - raise Exception.Create(Format(rcErrCompNodes, - [GetGDNodeName(gd_Visibility)])); - try - FValue := Node.ReadAttributeString('value'); - FValue:=StringReplace(FValue,SchemaHref,'',[rfIgnoreCase]); - FVisible := TVisibility(AnsiIndexStr(FValue, RelValues)); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -//procedure TgdVisibility.SetValue(aValue: string); -//begin -//if AnsiIndexStr(aValue, RelValues)<=0 then -// raise Exception.Create(Format(rcErrMissValue, [cGDTagNames[ord(egdVisibility)]])); -// FVisible:=TVisibility(AnsiIndexStr(aValue, RelValues)); -// FValue:=aValue; -//end; - -procedure TgdVisibility.SetVisible(aVisible: TVisibility); -begin - FVisible:=aVisible; - FValue:=RelValues[ord(aVisible)] -end; - -{ TgdOrganization } - -function TgdOrganization.AddToXML(Root: TXMLNode): TXmlNode; -begin -if (Root=nil)or IsEmpty then Exit; - - -Result:=Root.NodeNew(GetGDNodeName(gd_Organization)); -if Trim(FRel)<>'' then - Result.WriteAttributeString('rel',FRel); -if Trim(FLabel)<>'' then - Result.WriteAttributeString('label',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.Name) <> gd_Organization then - raise Exception.Create(Format(rcErrCompNodes, - [GetGDNodeName(gd_Organization)])); - try - Frel:=Node.ReadAttributeString('rel'); - if Node.HasAttribute('primary') then - Fprimary:=Node.ReadAttributeBool('primary'); - if Node.HasAttribute('label') then - FLabel:=Node.ReadAttributeString('label'); - for i:=0 to Node.NodeCount-1 do - begin - if LowerCase(Node.Nodes[i].Name)=LowerCase(GetGDNodeName(gd_OrgName)) then - ForgName:=TgdOrgName.Create(Node.Nodes[i]) - else - if LowerCase(Node.Nodes[i].Name)=LowerCase(GetGDNodeName(gd_OrgTitle)) then - ForgTitle:=TgdOrgTitle.Create(Node.Nodes[i]); - end; - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -{ TgdEmailStruct } - -function TgdEmail.AddToXML(Root: TXMLNode): TXmlNode; -begin - if (Root=nil)or IsEmpty then Exit; - Result:=Root.NodeNew(GetGDNodeName(gd_Email)); - if Trim(FRel)<>'' then - Result.WriteAttributeString('rel',FRel); - if Trim(FLabel)<>'' then - Result.WriteAttributeString('label',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:=''; - 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); -begin - if Node=nil then Exit; - if GetGDNodeType(Node.Name) <> gd_Email then - raise Exception.Create(Format(rcErrCompNodes, - [GetGDNodeName(gd_Email)])); - try - Frel:=Node.ReadAttributeString('rel'); - if Node.HasAttribute('primary') then - Fprimary:=Node.ReadAttributeBool('primary'); - if Node.HasAttribute('label') then - FLabel:=Node.ReadAttributeString('label'); - if Node.HasAttribute('displayName') then - FDisplayName:=Node.ReadAttributeString('displayName'); - FAddress:=Node.ReadAttributeString('address'); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -procedure TgdEmail.SetEmailType(aType: TTypeElement); -begin -FEmailType:=aType; -SetRel(RelValues[ord(aType)]); -end; - -procedure TgdEmail.SetRel(const aRel: string); -begin - if AnsiIndexStr(aRel,RelValues)<0 then - raise Exception.Create - (Format(rcErrWriteNode, [GetGDNodeName(gd_Email)])+' '+Format(rcWrongAttr,['rel'])); - FRel:=SchemaHref+aRel; -end; - -{ TgdNameStruct } - -function TgdName.AddToXML(Root: TXMLNode): TXmlNode; -begin - 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(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.Name) <> gd_Name then - raise Exception.Create(Format(rcErrCompNodes, - [GetGDNodeName(gd_Name)])); - try - for i:=0 to Node.NodeCount-1 do - begin - case GetGDNodeType(Node.Nodes[i].Name) 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(rcErrPrepareNode, [Node.Name])); - end; -end; - -procedure TgdName.SetAdditionalName(aAdditionalName: TTextTag); -begin -if aAdditionalName=nil then Exit; -if length(FAdditionalName.Name)=0 then - FAdditionalName.Name:='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:='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:='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:='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:='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:='gd:nameSuffix'; -FNameSuffix.Value:=aNameSuffix.Value; -end; - -{ TgdPhoneNumber } - -function TgdPhoneNumber.AddToXML(Root: TXMLNode): TXmlNode; -begin - if (Root=nil)or IsEmpty then Exit; - Result:=Root.NodeNew(GetGDNodeName(gd_PhoneNumber)); - Result.WriteAttributeString('rel',SchemaHref+RelValues[ord(FPhoneType)]); - Result.ValueAsString:=FValue; - if Trim(FLabel)<>'' then - Result.WriteAttributeString('label',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 s:string; -begin - if Node=nil then Exit; - if GetGDNodeType(Node.Name) <> gd_PhoneNumber then - raise Exception.Create(Format(rcErrCompNodes, - [GetGDNodeName(gd_PhoneNumber)])); - try - s:=Node.ReadAttributeString('rel'); - s:=StringReplace(s,SchemaHref,'',[rfIgnoreCase]); - if AnsiIndexStr(s,RelValues)>-1 then - FPhoneType:=TPhonesRel(AnsiIndexStr(s,RelValues)) - else - FPhoneType:=tpOther; - if Node.HasAttribute('primary') then - Fprimary:=Node.ReadAttributeBool('primary'); - if Node.HasAttribute('label') then - FLabel:=Node.ReadAttributeString('label'); - if Node.HasAttribute('uri') then - FUri:=Node.ReadAttributeString('uri'); - FValue:=Node.ValueAsString; - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -//procedure TgdPhoneNumber.SetRel(aPhoneRel: TPhonesRel); -//begin -// FPhoneType:=aPhoneRel; -//end; - -{ TgdCountry } - -function TgdCountry.AddToXML(Root: TXMLNode): TXMLNode; -begin - if (Root=nil)or IsEmpty then Exit; - Result:=Root.NodeNew(GetGDNodeName(gd_Country)); - if Trim(FCode)<>'' then - Result.WriteAttributeString('code',FCode); - Result.ValueAsString:=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.Name) <> gd_Country then - raise Exception.Create(Format(rcErrCompNodes, - [GetGDNodeName(gd_Country)])); - try - FCode:=Node.ReadAttributeString('rel'); - FValue:=Node.ValueAsString; - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -{ TgdStructuredPostalAddressStruct } - -function TgdStructuredPostalAddress.AddToXML(Root: TXMLNode): TXMLNode; -begin - if (Root=nil) or IsEmpty then Exit; - Result:=Root.NodeNew(GetGDNodeName(gd_StructuredPostalAddress)); - if Trim(FRel)<>'' then - Result.WriteAttributeString('rel',FRel); - if Trim(FMailClass)<>'' then - Result.WriteAttributeString('mailClass',FMailClass); - if Trim(Flabel)<>'' then - Result.WriteAttributeString('label',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.Name) <> gd_StructuredPostalAddress then - raise Exception.Create(Format(rcErrCompNodes, - [GetGDNodeName(gd_StructuredPostalAddress)])); - try - FRel:=Node.ReadAttributeString('rel'); - FMailClass:=Node.ReadAttributeString('mailClass'); - Flabel:=Node.ReadAttributeString('label'); - if Node.HasAttribute('primaty') then - Fprimary:=Node.ReadAttributeBool('primary'); - FUsage:=Node.ReadAttributeString('Usage'); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; - for I := 0 to Node.NodeCount - 1 do - begin - case GetGDNodeType(Node.Nodes[i].Name) 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; -begin - if (Root=nil)or IsEmpty then Exit; - Result:=Root.NodeNew(GetGDNodeName(gd_Im)); - - Result.WriteAttributeString('rel',SchemaHref+RelValues[ord(FIMType)]); - Result.WriteAttributeString('address',FAddress); - Result.WriteAttributeString('label',FLabel); - Result.WriteAttributeString('protocol',SchemaHref+ProtocolValues[ord(FIMProtocol)]); - 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.IsEmpty: boolean; -begin - Result:=(Length(Trim(FAddress))=0);//отсутствует обязательное поле -end; - -procedure TgdIm.ParseXML(const Node: TXmlNode); -var s:string; -begin -if Node=nil then Exit; - if GetGDNodeType(Node.Name) <> gd_Im then - raise Exception.Create(Format(rcErrCompNodes, - [GetGDNodeName(gd_Im)])); - try - s:=Node.ReadAttributeString('rel'); - s:=StringReplace(s,SchemaHref,'',[rfIgnoreCase]); - FIMType:=TImtype(AnsiIndexStr(s,RelValues)); - FLabel:=Node.ReadAttributeString('label'); - FAddress:=Node.ReadAttributeString('address'); - s:=Node.ReadAttributeString('protocol'); - s:=StringReplace(s,SchemaHref,'',[rfIgnoreCase]); - if AnsiIndexStr(s,ProtocolValues)>-1 then - FIMProtocol:=TIMProtocol(AnsiIndexStr(s,ProtocolValues)) - else - FIMProtocol:=tiGOOGLE_TALK; - if Node.HasAttribute('primary') then - FPrimary:=Node.ReadAttributeBool('primary'); - except - raise Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -end. ->>>>>>> remotes/origin/Vlad55 ->>>>>>> remotes/origin/NMD -======= ->>>>>>> remotes/origin/master diff --git a/source/GFeedBurner.pas b/source/GFeedBurner.pas deleted file mode 100644 index 5f0516f..0000000 --- a/source/GFeedBurner.pas +++ /dev/null @@ -1,1088 +0,0 @@ -п»ї{==============================================================================| -|Проект: 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; //дата Р·Р° которую необходимо получить данные - FOperation: TOperation;//уровень статистики (операция) - FURI: string; //URI блога для которого нужна статистика - FIdx: integer; //индекс потока РІ массиве - FParentComp:TFeedBurner; - FParamStr : string; - FXMLDoc : TNativeXML; - FBasicEntry: TBasicEntry; - Document: TMemoryStream; - FProgress,FMaxProgress:cardinal; - FOnProgress:TOnProgress; - FOnThreadEnd:TOnThreadEnd; - FOnParseElement: TOnParseElement; - FOnThreadStart: TOnThreadStart; - procedure SynProgress;// передача текушего прогресса авторизации РІ главную форму как положено РІ потоке - procedure SynEndThread; - function XMLWithError(XMLDoc:TNativeXml):boolean; - procedure GetParams; - protected - procedure Execute; override; // выполняем непосредственно авторизацию РЅР° сайте - public - constructor Create(CreateSuspennded: boolean; aParentComp:TFeedBurner;aIdx:integer;aDate:TDate;aOperation:TOperation;aURI:string); - published - property OnProgress: TOnProgress read FOnProgress write FOnProgress;//прогресс авторизации - property OnThreadEnd:TOnThreadEnd read FOnThreadEnd write FOnThreadEnd; - 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) 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; - FURI:=aURI; - FIdx:=aIdx; - FProgress:=0; - FMaxProgress:=0; - Document:=TMemoryStream.Create; - FXMLDoc:=TNativeXml.Create; - 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 - hInternet, hConnect, hRequest: pointer; - dwBytesRead,i: cardinal; - Buffer: array [0 .. 255] of Byte; -begin - try - Document.Clear; - hInternet := InternetOpen(PChar('FeedBurner'), - INTERNET_OPEN_TYPE_PRECONFIG, Nil, Nil, 0); - if Assigned(hInternet) then - begin - // Открываем сессию - hConnect := InternetConnect(hInternet,PChar('feedburner.google.com'), - INTERNET_DEFAULT_HTTP_PORT,nil,nil, - INTERNET_SERVICE_HTTP,0,1); - if Assigned(hConnect) then - begin - // Формируем запрос - hRequest := HttpOpenRequest(hConnect,PChar('GET'), - PChar(FParamStr), - HTTP_VERSION,nil,Nil,INTERNET_FLAG_RELOAD or - INTERNET_FLAG_NO_CACHE_WRITE or - INTERNET_FLAG_PRAGMA_NOCACHE or - INTERNET_FLAG_KEEP_CONNECTION, 1); - if Assigned(hRequest) then - begin - FMaxProgress:=GetUrlSize('http://feedburner.google.com/'+FParamStr); - if HttpSendRequest(hRequest, nil, 0, nil, 0) then - begin - repeat - if Terminated then // проверка для экстренного закрытия потока - begin - InternetCloseHandle(hRequest); - InternetCloseHandle(hConnect); - InternetCloseHandle(hInternet); - FreeAndNil(Document); - FreeAndNil(FXMLDoc); - 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); - until dwBytesRead = 0; - Document.Position:=0; - end; - end; - end; - end; - except - InternetCloseHandle(hRequest); - InternetCloseHandle(hConnect); - InternetCloseHandle(hInternet); - exit; - end; - - FXMLDoc.LoadFromStream(Document); - -if XMLWithError(FXMLDoc) then - 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'); - if Assigned(FOnParseElement) then - FOnParseElement(FBasicEntry); - end; -FreeAndNil(Document); -FreeAndNil(FXMLDoc); -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. diff --git a/source/GHelper.pas b/source/GHelper.pas deleted file mode 100644 index 3e64422..0000000 --- a/source/GHelper.pas +++ /dev/null @@ -1,1525 +0,0 @@ -<<<<<<< HEAD -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. -<<<<<<< HEAD -======= -======= -<<<<<<< HEAD ->>>>>>> remotes/origin/NMD -unit GHelper; - -interface - -uses Graphics,strutils,Windows,DateUtils,SysUtils, Variants, -Classes,StdCtrls,httpsend,Generics.Collections,xmlintf,xmldom,NativeXML,typinfo; - -resourcestring - rcErrPrepareNode = 'Ошибка обработки узла %s'; - rcErrCompNodes = 'Узел не является узлом %s'; - rcErrWriteNode = 'Ошибка записи данных для узла %s'; - rcErrReadNode = 'Ошибка чтения данных из узла %s'; - rcErrMissValue = 'Недопустимое значение атрибута для узла %s'; - rcErrMissAgrument = 'Недопустимый аргумент в вызове функции'; - rcUnUsedTag = 'Неучтенный тэг '; - rcDuplicateLink = 'Такая ссылка уже есть в списке'; - rcWrongAttr = 'Неверное значение атрибута %s'; - rcRightAttrValues = 'Допустимые значения атрибута: %s'; - rcErrCGroupCreate ='Пустой XML-документ. Чтение групп контактов прервано'; - rcErrNullAuth = 'Параметр Auth не может быть пустым'; - -const - GoogleColors: 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'); - - NodeValueAttr = 'value'; - EntryNodeName = 'entry'; - SchemaHref ='http://schemas.google.com/g/2005#'; - -//константы для TimeZone - GoogleTimeZones: 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','')); - - gdRelValues: array [1..25,1..2] of string = ( - ('http://schemas.google.com/g/2005#event',''), - ('http://schemas.google.com/g/2005#event.alternate',''), - ('http://schemas.google.com/g/2005#event.parking',''), - ('http://schemas.google.com/g/2005#message.bcc',''), - ('http://schemas.google.com/g/2005#message.cc',''), - ('http://schemas.google.com/g/2005#message.from',''), - ('http://schemas.google.com/g/2005#message.reply-to',''), - ('http://schemas.google.com/g/2005#message.to',''), - ('http://schemas.google.com/g/2005#regular',''), - ('http://schemas.google.com/g/2005#reviews',''), - ('http://schemas.google.com/g/2005#home',''), - ('http://schemas.google.com/g/2005#other',''), - ('http://schemas.google.com/g/2005#work',''), - ('http://schemas.google.com/g/2005#fax',''), - ('http://schemas.google.com/g/2005#home_fax',''), - ('http://schemas.google.com/g/2005#mobile',''), - ('http://schemas.google.com/g/2005#pager',''), - ('http://schemas.google.com/g/2005#work_fax',''), - ('http://schemas.google.com/g/2005#overall',''), - ('http://schemas.google.com/g/2005#price',''), - ('http://schemas.google.com/g/2005#quality',''), - ('http://schemas.google.com/g/2005#event.attendee',''), - ('http://schemas.google.com/g/2005#event.organizer',''), - ('http://schemas.google.com/g/2005#event.performer',''), - ('http://schemas.google.com/g/2005#event.speaker','')); - -//просранства имен для календарей -clNameSpaces: array [0 .. 2, 0 .. 1] of string = - (('xmlns', 'http://www.w3.org/2005/Atom'), ('xmlns:gd', - 'xmlns:http://schemas.google.com/g/2005'), ('xmlns:gCal', - 'http://schemas.google.com/gCal/2005')); -contactNameSpaces: array [0 .. 2, 0 .. 1] of string = - (('xmlns', 'http://www.w3.org/2005/Atom'), - ('xmlns:gd', 'http://schemas.google.com/g/2005'), - ('xmlns:gContact','http://schemas.google.com/contact/2008')); -//значения rel для узлов category календарея -clCategories: array [0 .. 1, 0 .. 1] of string = (('scheme', - 'http://schemas.google.com/g/2005#kind'), ('term', - 'http://schemas.google.com/g/2005#event')); - -type - TNodePrefix=(tpnone,tpatom); - -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; - destructor Destroy; override; - property TimeZone[i: Integer]: PTimeZone read GetRecord write SetRecord; - end; - - -type - TAttribute = packed record - Name: string; - Value: string; - end; - -type - TTextTag = class(TPersistent) - private - FName: string; - FValue: string; - FAtributes: TList; - public - Constructor Create(const ByNode: TXMLNode=nil); - procedure ParseXML(Node: TXMLNode); - function AddToXML(Root: TXMLNode; NodePrefix:TNodePrefix=tpnone): TXMLNode; - function IsEmpty:boolean; - property Value: string read FValue write FValue; - property Name: string read FName write FName; - property Attributes: TListread FAtributes write FAtributes; - end; - -type - TEntryLink = class(TPersistent) - 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; - 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(TPersistent) - private - FAuthor: string; - FEmail : string; - FUID : string; - public - constructor Create(ByNode: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - property Author: string read FAuthor write FAuthor; - property Email: string read FEmail write FEmail; - 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,MSec: 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(GoogleTimeZones) do - begin - New(Zone); - with Zone^ do - begin - gConst:=GoogleTimeZones[i,0]; - Desc:=GoogleTimeZones[i,1]; - GMT:=StrToFloat(GoogleTimeZones[i,2]); - rus:=GoogleTimeZones[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; - - -{ TTextTag } - -function TTextTag.AddToXML(Root: TXMLNode;NodePrefix:TNodePrefix): TXMLNode; -var - i: integer; - prefix:string; -begin - if IsEmpty then Exit; - if NodePrefix=tpnone then - Result:= Root.NodeNew(FName) - else - begin - prefix:=GetEnumName(TypeInfo(TNodePrefix),ord(NodePrefix)); - Delete(prefix,1,2); - Result:= Root.NodeNew(prefix+':'+FName) - end; - Result.ValueAsString:=AnsiToUtf8(FValue); - for i := 0 to FAtributes.Count - 1 do - Result.AttributeAdd(FAtributes[i].Name,FAtributes[i].Value); -end; - -constructor TTextTag.Create(const ByNode: TXMLNode); -begin - inherited Create; - FAtributes:=TList.Create; - FName:=''; - FValue:=''; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -function TTextTag.IsEmpty: boolean; -begin - Result:=(Length(Trim(FValue))=0)and(FAtributes.Count=0) -end; - -procedure TTextTag.ParseXML(Node: TXMLNode); -var - i: integer; - Attr: TAttribute; -begin - try - FValue := Node.ValueAsString; - FName := Node.Name; - for i := 0 to Node.AttributeCount - 1 do - begin - Attr.Name := Node.AttributeName[i]; - Attr.Value := Node.AttributeValue[i]; - FAtributes.Add(Attr) - end; - except - Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -{ TAuthorTag } - -{ TAuthorTag } - -constructor TAuthorTag.Create(ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -procedure TAuthorTag.ParseXML(Node: IXMLNode); -var - i: integer; -begin - try - for i := 0 to Node.ChildNodes.Count - 1 do - begin - if Node.ChildNodes[i].NodeName = 'name' then - FAuthor := Node.ChildNodes[i].Text - else - if Node.ChildNodes[i].NodeName = 'email' then - FEmail := Node.ChildNodes[i].Text - else - if Node.ChildNodes[i].NodeName = 'uid' then - FUID:=Node.ChildNodes[i].Text; - end; - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - - -{ TEntryLink } - -function TEntryLink.AddToXML(Root: TXMLNode): TXMLNode; -begin -Result:= Root.NodeNew('link'); -Result.WriteAttributeString('rel',Self.Frel); -Result.WriteAttributeString('type',Self.Ftype); -Result.WriteAttributeString('href',Self.Fhref); -Result.WriteAttributeString('gd:etag',Self.FEtag); -end; - -constructor TEntryLink.Create(const ByNode: TXMLNode); -begin - inherited Create; - if ByNode<>nil then - ParseXML(ByNode); -end; - -procedure TEntryLink.ParseXML(Node: TXMLNode); -begin - if Node=nil then Exit; - try - Frel:=Node.ReadAttributeString('rel'); - Ftype:=Node.ReadAttributeString('type'); - Fhref:=Node.ReadAttributeString('href'); - FEtag:=Node.ReadAttributeString('gd:etag') - except - Exception.Create(Format(rcErrPrepareNode, ['link'])); - end; -end; - -end. -<<<<<<< HEAD ->>>>>>> remotes/origin/NMD -======= -======= -unit GHelper; - -interface - -uses Graphics,strutils,Windows,DateUtils,SysUtils, Variants, -Classes,StdCtrls,httpsend,Generics.Collections,xmlintf,xmldom,NativeXML, -uLanguage; - -//{$I languages\lang_russian.inc} - -const - GoogleColors: 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'); - - NodeValueAttr = 'value'; - EntryNodeName = 'entry'; - SchemaHref ='http://schemas.google.com/g/2005#'; - - gdRelValues: array [1..25,1..2] of string = ( - ('http://schemas.google.com/g/2005#event',''), - ('http://schemas.google.com/g/2005#event.alternate',''), - ('http://schemas.google.com/g/2005#event.parking',''), - ('http://schemas.google.com/g/2005#message.bcc',''), - ('http://schemas.google.com/g/2005#message.cc',''), - ('http://schemas.google.com/g/2005#message.from',''), - ('http://schemas.google.com/g/2005#message.reply-to',''), - ('http://schemas.google.com/g/2005#message.to',''), - ('http://schemas.google.com/g/2005#regular',''), - ('http://schemas.google.com/g/2005#reviews',''), - ('http://schemas.google.com/g/2005#home',''), - ('http://schemas.google.com/g/2005#other',''), - ('http://schemas.google.com/g/2005#work',''), - ('http://schemas.google.com/g/2005#fax',''), - ('http://schemas.google.com/g/2005#home_fax',''), - ('http://schemas.google.com/g/2005#mobile',''), - ('http://schemas.google.com/g/2005#pager',''), - ('http://schemas.google.com/g/2005#work_fax',''), - ('http://schemas.google.com/g/2005#overall',''), - ('http://schemas.google.com/g/2005#price',''), - ('http://schemas.google.com/g/2005#quality',''), - ('http://schemas.google.com/g/2005#event.attendee',''), - ('http://schemas.google.com/g/2005#event.organizer',''), - ('http://schemas.google.com/g/2005#event.performer',''), - ('http://schemas.google.com/g/2005#event.speaker','')); - -//просранства имен для календарей -clNameSpaces: array [0 .. 2, 0 .. 1] of string = - (('', 'http://www.w3.org/2005/Atom'), ('gd', - 'http://schemas.google.com/g/2005'), ('gCal', - 'http://schemas.google.com/gCal/2005')); -//значения rel для узлов category календарея -clCategories: array [0 .. 1, 0 .. 1] of string = (('scheme', - 'http://schemas.google.com/g/2005#kind'), ('term', - 'http://schemas.google.com/g/2005#event')); - -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; - destructor Destroy; override; - property TimeZone[i: Integer]: PTimeZone read GetRecord write SetRecord; - end; - - -type - TAttribute = packed record - Name: string; - Value: string; - end; - -type - TTextTag = class - private - FName: string; - FValue: string; - FAtributes: TList; - public - Constructor Create(const ByNode: TXMLNode=nil);overload; - constructor Create(const NodeName: string; NodeValue:string='');overload; - - function IsEmpty: boolean; - procedure Clear; - procedure ParseXML(Node: TXMLNode); - 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; - 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: IXMLNode=nil); - procedure ParseXML(Node: IXMLNode); - property Author: string read FAuthor write FAuthor; - property Email: string read FEmail write FEmail; - 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,MSec: 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(GoogleTimeZones) do - begin - New(Zone); - with Zone^ do - begin - gConst:=GoogleTimeZones[i,0]; - Desc:=GoogleTimeZones[i,1]; - GMT:=StrToFloat(GoogleTimeZones[i,2]); - rus:=GoogleTimeZones[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; - - -{ TTextTag } - -function TTextTag.AddToXML(Root: TXMLNode): TXMLNode; -var - i: integer; -begin - if (Root=nil)or IsEmpty then Exit; - Result:= Root.NodeNew(FName); - Result.ValueAsString:=AnsiToUtf8(FValue); - for i := 0 to FAtributes.Count - 1 do - Result.AttributeAdd(FAtributes[i].Name,FAtributes[i].Value); - //Root.ChildNodes.Add(Result); -end; - -constructor TTextTag.Create(const ByNode: TXMLNode); -begin - inherited Create; - FAtributes:=TList.Create; - Clear; - if ByNode = nil then - Exit; - 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.ValueAsString; - FName := Node.Name; - for i := 0 to Node.AttributeCount - 1 do - begin - Attr.Name := Node.AttributeName[i]; - Attr.Value := Node.AttributeValue[i]; - FAtributes.Add(Attr) - end; - except - Exception.Create(Format(rcErrPrepareNode, [Node.Name])); - end; -end; - -{ TAuthorTag } - -{ TAuthorTag } - -constructor TAuthorTag.Create(ByNode: IXMLNode); -begin - inherited Create; - if ByNode = nil then - Exit; - ParseXML(ByNode); -end; - -procedure TAuthorTag.ParseXML(Node: IXMLNode); -var - i: integer; -begin - try - for i := 0 to Node.ChildNodes.Count - 1 do - begin - if Node.ChildNodes[i].NodeName = 'name' then - FAuthor := Node.ChildNodes[i].Text - else - if Node.ChildNodes[i].NodeName = 'email' then - FEmail := Node.ChildNodes[i].Text - else - if Node.ChildNodes[i].NodeName = 'uid' then - FUID:=Node.ChildNodes[i].Text; - end; - except - Exception.Create(Format(rcErrPrepareNode, [Node.NodeName])); - end; -end; - - -{ TEntryLink } - -function TEntryLink.AddToXML(Root: TXMLNode): TXMLNode; -begin - -end; - -constructor TEntryLink.Create(const ByNode: TXMLNode); -begin - inherited Create; - if ByNode<>nil then - ParseXML(ByNode); -end; - -procedure TEntryLink.ParseXML(Node: TXMLNode); -begin - if Node=nil then Exit; - try - Frel:=Node.ReadAttributeString('rel'); - Ftype:=Node.ReadAttributeString('type'); - Fhref:=Node.ReadAttributeString('href'); - FEtag:=Node.ReadAttributeString('gd:etag') - except - Exception.Create(Format(rcErrPrepareNode, ['link'])); - end; -end; - -end. ->>>>>>> remotes/origin/Vlad55 ->>>>>>> remotes/origin/NMD -======= ->>>>>>> remotes/origin/master diff --git a/source/GTasksAPI.pas b/source/GTasksAPI.pas deleted file mode 100644 index 3bca777..0000000 --- a/source/GTasksAPI.pas +++ /dev/null @@ -1,343 +0,0 @@ -п»ї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 deleted file mode 100644 index 344ffec..0000000 --- a/source/GTranslate.pas +++ /dev/null @@ -1,437 +0,0 @@ -{ =============================================================================| - |Проект: 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 deleted file mode 100644 index 021447f..0000000 --- a/source/GoogleLogin.pas +++ /dev/null @@ -1,991 +0,0 @@ -{ ******************************************************* } -{ } -{ 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; - -interface - -uses WinInet, strutils, SysUtils, Classes; - -resourcestring - rcNone = 'Аутентификация не производилась или сброшена'; - rcOk = 'Аутентификация прошла успешно'; - rcBadAuthentication ='Не удалось распознать имя пользователя или пароль, использованные в запросе на вход'; - rcNotVerified ='Адрес электронной почты, связанный с аккаунтом, не был подтвержден'; - rcTermsNotAgreed ='Пользователь не принял условия использования службы'; - rcCaptchaRequired ='Требуется ответ на тест CAPTCHA'; - rcUnknown ='Неизвестная ошибка'; - rcAccountDeleted ='Аккаунт этого пользователя удален'; - rcAccountDisabled ='Аккаунт этого пользователя отключен'; - rcServiceDisabled ='Доступ пользователя к указанной службе запрещен'; - rcServiceUnavailable ='Служба недоступна, повторите попытку позже'; - -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 - 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 - TAccountType = (atNone ,atGOOGLE, atHOSTED, atHOSTED_OR_GOOGLE); - -type - TLoginResult = (lrNone,lrOk, lrBadAuthentication, lrNotVerified, - lrTermsNotAgreed, lrCaptchaRequired, lrUnknown, - lrAccountDeleted, lrAccountDisabled, lrServiceDisabled, - lrServiceUnavailable); - -type - TGoogleLogin = class - 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; - 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(const aEmail, aPassword: string); - function Login(aLoginToken:string='';aLoginCaptcha:string=''):TLoginResult; - procedure Disconnect;//удаляет все данные по авторизации - property AccountType: TAccountType read FAccountType write FAccountType; - property LastResult: TLoginResult read FLastResult; - property LastResultText:string read GetResultText; - 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 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; -end; - - -implementation - -{ TGoogleLogin } - -procedure TGoogleLogin.Disconnect; -begin - FAccountType:=atNone; - FLastResult:=lrNone; - FSID:=''; - FLSID:=''; - FAuth:=''; - FLogintoken:=''; - FLogincaptcha:=''; - FCaptchaURL:=''; - FLogintoken:=''; -end; - -constructor TGoogleLogin.Create(const aEmail, aPassword: string); -begin -inherited Create; - if (Length(Trim(aEmail))>0)and(Length(Trim(aPassword))>0) then - begin - FEmail:=aEmail; - FPassword:=aPassword; - end - else - Destroy; -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; -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; - InternetCloseHandle(hRequest); - end; - InternetCloseHandle(hConnect); - end; - InternetCloseHandle(hInternet); -except - 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; - Disconnect;//обнуляем результаты -end; - -procedure TGoogleLogin.SetPassword(cPassword: string); -begin - FPassword:=cPassword; - Disconnect;//обнуляем результаты -end; - -procedure TGoogleLogin.SetService(cService: TServices); -begin - FService:=cService; - Disconnect;//обнуляем результаты - Login(); //перелогиниваемся -end; - -procedure TGoogleLogin.SetSource(cSource: string); -begin -FSource:=cSource; -Disconnect;//обнуляем результаты -end; - -end. ->>>>>>> remotes/origin/NMD diff --git a/source/GoogleOAuth.pas b/source/GoogleOAuth.pas deleted file mode 100644 index b96bdf6..0000000 --- a/source/GoogleOAuth.pas +++ /dev/null @@ -1,250 +0,0 @@ -п»ї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 deleted file mode 100644 index ad16cc8..0000000 --- a/source/languages/English/GStrings.rc +++ /dev/null @@ -1,76 +0,0 @@ -#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 deleted file mode 100644 index 8221fee..0000000 --- a/source/languages/Russian/GStrings.rc +++ /dev/null @@ -1,129 +0,0 @@ -#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 deleted file mode 100644 index c4ad5bd..0000000 --- a/source/uLanguage.pas +++ /dev/null @@ -1,138 +0,0 @@ -unit uLanguage; - -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. \ No newline at end of file diff --git a/sourse/BloggerApi.pas b/sourse/BloggerApi.pas new file mode 100644 index 0000000..18b924f --- /dev/null +++ b/sourse/BloggerApi.pas @@ -0,0 +1,967 @@ +{*******************************************************} +{ } +{ BloggerApi } +{ } +{ Copyright (C) 2010 NMD } +{ http://nmdsoft.blogspot.com/ } +{*******************************************************} + + +unit BloggerApi; + +interface + +uses + SysUtils, Classes,NativeXml,WinInet; + +//ошибки +resourcestring +rsErrorXmlTag='Нет закрывающего тега. HTHL должен быть валидным'; +rsErrorNotTolken='Нет толкена google для работы с сервисом'; +rsErrorNotSelectBlog='Блог не выбран! Смотри property CurrentBlog'; +rsErrorIdPost='Не указан Id сообщения в блоге'; + +rsErrorGet='Произошла сетевая ошибка при получении данных c сервера'; +rsErrorDelete='Произошла сетевая ошибка при выполнении запроса Delete'; +rsErrorPost='Произошла сетевая ошибка при отправке данных на сервер'; +rsErrorPut='Произошла сетевая ошибка при обновлении данных на сервер'; +const + cnsBlogDefault='http://www.blogger.com/feeds/default/blogs'; + cnsEntry='entry'; + cnsName='name'; + cnsId='id'; + cnsPublished='published'; + cnsUpdated='updated'; + cnsTitle='title'; + cnsCategory='category'; + cntTerm='term'; + cnsXhtml='xhtml'; + cnsXmlns='xmlns'; + cnsType='type'; + cnsText='text'; + cnsContent='content'; + cnsScheme='scheme'; + cnsTerm='term'; + cnsDiv='div'; + cnsAtomUrl='http://www.w3.org/2005/Atom'; + cnsXhtmlUrl='http://www.w3.org/1999/xhtml'; + cnsAtnsUrl='http://www.blogger.com/atom/ns#'; + //http://www.blogger.com/feeds/blogID/posts/default + cnsPostBlogStart='http://www.blogger.com/feeds/'; + cnsPostBlogEnd='/posts/default'; + cnsAppControll='app:control'; + cnsXmlnsApp='xmlns:app'; + cnsXmlnsAppUrl='http://www.w3.org/2007/app'; + cnsAppDraft='app:draft'; + cnsYes='yes'; + cnsVop='/?'; +// cnsPostIdUrl='http://www.blogger.com/feeds/blogID/posts/default/postID'; + +type + //событие для ошибки + TErrorEvent = procedure(aE: string) of object; + //Прогресс выполнения задания + TProgressEvent = procedure(aCurrentProgress,aMaxProgress: Integer) of object; + + TPostItem = class (TCollectionItem) + private + FPostTitle: string; + FPostId: string; + FPostSourse: TStringList; + FСategoryPost:TStringList; + FPostPublished: TDateTime; + FPostUpdate: TDateTime; + procedure SetPostId(const Value: string); + procedure SetPostPublished(const Value: TDateTime); + procedure SetPostSourse(const Value: TStringList); + procedure SetPostTitle(const Value: string); + procedure SetPostUpdate(const Value: TDateTime); + procedure SetСategoryPost(const Value: TStringList); + public + constructor Create(Collection: TCollection);override; + destructor Destroy; override; + published + property PostId:string read FPostId write SetPostId; + property PostTitle:string read FPostTitle write SetPostTitle; + property PostSourse:TStringList read FPostSourse write SetPostSourse; + property СategoryPost:TStringList read FСategoryPost write SetСategoryPost; + property PostPublished:TDateTime read FPostPublished write SetPostPublished; + property PostUpdate:TDateTime read FPostUpdate write SetPostUpdate; + end; + + TPostCollection = class (TCollection) + private + function GetItemBlog(Index: Integer): TPostItem; + procedure SetItemBlog(Index: Integer; Value: TPostItem); + public + constructor Create(AOwner:TComponent); + function Add: TPostItem; + property Items[Index: Integer]: TPostItem read GetItemBlog write SetItemBlog; + function AddEx(aPostTitle,aPostId:string; aPostSourse:TStringList;aPostPublished,aPostUpdate:TDateTime): TPostItem; + end; + + + TBlogItem = class (TCollectionItem) + private + FTitle:string;//заголовок + FBlogId:string;//id блога + FСategoryBlog:TStringList;//ярлыки блога + FPublished:TDateTime;//дата последеней публикации + FUpdate:TDateTime;//дата последнего обновления + procedure SetCategory(const Value: TStringList); + procedure SetPublished(const Value: TDateTime); + procedure SetUpdate(const Value: TDateTime); + procedure SetBlogId(const Value: string); + procedure SetTitle(const Value: string); + + public + constructor Create(Collection: TCollection);override; + destructor Destroy; override; + published + property Title:string read FTitle write SetTitle; + property BlogId:string read FBlogId write SetBlogId; + property СategoryBlog:TStringList read FСategoryBlog write SetCategory; + property Publish:TDateTime read FPublished write SetPublished; + property Update:TDateTime read FUpdate write SetUpdate; + end; + + TBlogCollection = class (TCollection) + private + function GetItemBlog(Index: Integer): TBlogItem; + procedure SetItemBlog(Index: Integer; Value: TBlogItem); + public + constructor Create(AOwner:TComponent); + function Add: TBlogItem; + property Items[Index: Integer]: TBlogItem read GetItemBlog write SetItemBlog; + function AddEx(aName,aTitle,aBlogId: string;aUrl:string;aСategoryBlog:TStringList;aPublished,aUpdate:TDateTime): TBlogItem; + end; + +//класс для работы с блогами на Blogger'e +type + TBlogger = class(TComponent) + private + //для работы с xml + FXMLDoc:TNativeXml; + FAuth:string; + FUrl:string;//ссылка на профиль владельца блога + FAppName:string;//название приложения + FBlogs:TBlogCollection; + FCurrentBlog: Integer;//блог с которым будем непосредственно работать + //для событий + FProgress:TProgressEvent; + FErrorEvent: TErrorEvent;//ошибка + + //вспомогательные для работы с инетом + function GetUrl(url, param, method: string; AUTH:AnsiString;postData: UTF8String): UTF8String; + function DataAvailable(hRequest: pointer; out Size: cardinal): boolean; + function GetScriptName(url, hostname: string): string; + procedure SetFlags(url: string; out Flags_connection, Flags_Request: Cardinal); + function GetHostName(url: string): string; + + function GetIdBlog(aSourse:string):string;//получение id блога + function GetPostId(aSourse:string):string;//получение id поста + procedure RetrievAllBlogs;//получение списка блогов пользователя + + procedure ToError(aError:string);//обработка ошибок + //для пропертей + procedure SetAppName(const Value: string); + procedure SetAuth(const Value: string); + procedure SetBlog(const Value: TBlogCollection); + procedure SetCurrentBlog(const Value: Integer); + + protected + public + function PostCreat(aTitle,aContent:string; aCategory:TStringList;aComment:Boolean):UTF8String;//создание сообщения и отправка в блог + function PostModify(id,aTitle,aContent:string; aCategory:TStringList;aComment:Boolean):UTF8String;//Изменение сообщения и отправка его в блог + function PostDelete(id:string):Boolean;//удаление поста из блога + + function RetrievAllPosts:TPostCollection;//получаем последние 25 постов из блога + //получение статей по заданным параметрам + function RetrievPostForParams(aCategory:string =''; aOrderby:string =''; aPublishedMin:string =''; + aPublishedMax:string =''; aUpdatedMin:string ='';aUpdatedMax:string =''; + aStartIndex:Integer=0; aMaxResults:Integer=0; aAlt : string =''):TPostCollection; + //Возвращает посты из блога по заданным параметрам созданым в ручную + function RetrievPostForTextParams(Parametrs:string):TPostCollection; + constructor Create(AOwner: TComponent);override;//инициализация класса + destructor Destroy; override;//уничтожение + published + property Auth:string read FAuth write SetAuth; + property AppName:string read FAppName write SetAppName; + property CurrentBlog:Integer read FCurrentBlog write SetCurrentBlog default -1; + property Url: string read FUrl; + property Blogs:TBlogCollection read FBlogs write SetBlog; + + //события + property OnProgress:TProgressEvent read FProgress write FProgress;//прогресс выполнения задачи + property OnError:TErrorEvent read FErrorEvent write FErrorEvent;//возникает при ошибке ) + + end; + +procedure Register; + +implementation + +constructor TBlogger.Create(AOwner: TComponent); +begin + inherited; + FBlogs:=TBlogCollection.Create(Self); + FXMLDoc:=TNativeXml.Create; + FAuth:=''; + FAppName:='MyCompany'; + FCurrentBlog:=-1; +end; + +destructor TBlogger.Destroy; +begin + FreeAndNil(FXMLDoc); + FBlogs.Free; + inherited; +end; + +function TBlogger.GetHostName(url : string) : string; +begin + result := ''; + if pos('https://',url) > 0 then + begin + delete(url,1,length('https://')); + SetLength(url,pos('/',url) - 1); + result := url; + end + else + if pos('http://',url) > 0 then + begin + delete(url,1,length('http://')); + SetLength(url,pos('/',url) - 1); + result := url; + end; +end; + +{------------------------------------------------------------------------------- + Функция: TBlogger.GetIdBlog + Автор: NMD + Дата: 2010.08.08 + Входные параметры: aSourse: string строка содержащая id блога + Результат: id блога string +-------------------------------------------------------------------------------} +function TBlogger.GetIdBlog(aSourse: string): string; +var + i:Integer; +begin + Result:=''; + i:=AnsiPos('.blog-',aSourse); + Delete(aSourse,1,i+5); + Result:=aSourse; +end; + +function TBlogger.GetPostId(aSourse: string): string; +var + i:Integer; +begin + Result:=''; + i:=AnsiPos('.post-',aSourse); + Delete(aSourse,1,i+5); + Result:=aSourse; +end; + +function TBlogger.GetScriptName( url,hostname : string) : string; +begin + result := ''; + delete(url,1,pos(hostname,url) + length(hostname)); + result := url; +end; + +procedure TBlogger.SetFlags(url : string; out Flags_connection,Flags_Request : Cardinal); +begin + //Оприделяем на https или http + if pos('https',url) > 0 then + begin + 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; + end + else + begin + Flags_connection := INTERNET_DEFAULT_HTTP_PORT; + Flags_Request := INTERNET_FLAG_RELOAD or INTERNET_FLAG_IGNORE_CERT_CN_INVALID or INTERNET_FLAG_NO_CACHE_WRITE or INTERNET_FLAG_PRAGMA_NOCACHE or INTERNET_FLAG_KEEP_CONNECTION; + end; +end; + +//обработка ошибок +procedure TBlogger.ToError(aError: string); +begin + if Assigned(FErrorEvent) then + OnError(aError); +end; + +function TBlogger.DataAvailable(hRequest: pointer; out Size : cardinal): boolean; +begin + result := wininet.InternetQueryDataAvailable(hRequest, Size, 0, 0); +end; + +function TBlogger.GetUrl(url : string; param: string; method : string; AUTH:AnsiString; postData:UTF8String) :UTF8String;//Получение страницы по url +var + FHost,FScript : string; + hInternet,hConnect,hRequest : Pointer; + dwBytesRead,I,L : Cardinal; + Flags_connection,Flags_Request : Cardinal; + Flag_HttpSendRequest:LongBool; + header:TStringStream; +begin + result := ''; + fHost := GetHostName(url); + fScript := GetScriptName(url,fHost); + if Param <> '' then + if fScript[Length(fScript)] = '?' then + fScript := fScript + param + else + fScript := fScript + '?' + param; + //Устанавливаем флаги + SetFlags(url,Flags_connection,Flags_Request); + //Инициализируем WinInet + hInternet := InternetOpen(PChar(FAppName),INTERNET_OPEN_TYPE_PRECONFIG,Nil,Nil,0); + if Assigned(hInternet) then + begin + //Открываем сессию + hConnect := InternetConnect(hInternet,PChar(FHost),Flags_connection,nil,nil,INTERNET_SERVICE_HTTP,0,1); + if Assigned(hConnect) then + begin + //Формируем запрос + hRequest := HttpOpenRequest(hConnect,PChar(uppercase(method)),PChar(fScript),HTTP_VERSION,nil,Nil,Flags_Request,1); + if Assigned(hRequest) then + begin + header:=TStringStream.Create; + with Header do + begin + WriteString('Content-Type:application/atom+xml'+SLineBreak); + WriteString('GData-Version:2 '+SLineBreak); + WriteString('Authorization: GoogleLogin auth='+AUTH+SLineBreak+SLineBreak); + end; + //Отправляем запрос + I := 1; + if uppercase(method)='GET' then + begin + Flag_HttpSendRequest:=HttpSendRequest(hRequest,PChar(header.DataString),Length(header.DataString),nil,0); + if not Flag_HttpSendRequest then + ToError(rsErrorGet); + end; + if uppercase(method)='POST' then + begin + Flag_HttpSendRequest:=HttpSendRequest(hRequest,PChar(header.DataString),Length(header.DataString),Pointer(postData),Length(postData)); + if not Flag_HttpSendRequest then + ToError(rsErrorPost); + end; + if uppercase(method)='PUT' then + begin + Flag_HttpSendRequest:=HttpSendRequest(hRequest,PChar(header.DataString),Length(header.DataString),Pointer(postData),Length(postData)); + if not Flag_HttpSendRequest then + ToError(rsErrorPut); + end; + if uppercase(method)='DELETE' then + begin + Flag_HttpSendRequest:=HttpSendRequest(hRequest,PChar(header.DataString),Length(header.DataString),nil,0); + if not Flag_HttpSendRequest then + begin + OnError(rsErrorDelete); + Result:='0' + end + else + begin + Result:='1'; + end; + end; + if Flag_HttpSendRequest and (uppercase(method)<>'DELETE') then + begin + repeat + DataAvailable(hRequest, L);//Получаем кол-во принимаемых данных + if L = 0 then break; + SetLength(result,L + I); + if not (InternetReadFile(hRequest,@result[I],sizeof(L),dwBytesRead)) then //Получаем данные с сервера + begin + OnError(rsErrorGet); + end; + if Assigned(FProgress) then //прогресс + OnProgress(i,L+1); + inc(I,dwBytesRead); + until dwBytesRead = 0; + result[I] := #0; + end; + end; + InternetCloseHandle(hRequest); + end; + InternetCloseHandle(hConnect); + end; + InternetCloseHandle(hInternet); + header.Free; +end; + +{------------------------------------------------------------------------------- + Процедура: TBlogger.RetrievAllBlogs + Автор: NMD + Дата: 2010.08.03 21:13:59 + Входные параметры: Нет + Результат: получение списка блогов пользователя +-------------------------------------------------------------------------------} +procedure TBlogger.RetrievAllBlogs; +var + i,i2:Integer; + Nodes,NodesChild: TXmlNodeList; +begin + FBlogs.Clear;//очистка блогов перед получением нового списка + FXMLDoc.Clear; + FXMLDoc.ReadFromString(GetUrl(cnsBlogDefault,'','get',FAuth,'')); + //проверка на существование коллекции + if not Assigned(FBlogs) then Exit; + try + Nodes:=TXmlNodeList.Create; + FXMLDoc.Root.FindNodes('entry',Nodes); + for i := 0 to Nodes.Count-1 do + begin + FBlogs.Add; + FBlogs.Items[i].BlogId:=GetIdBlog(Nodes.Items[i].NodeByName(cnsId).ValueAsString); + FBlogs.Items[i].Publish:=Nodes.Items[i].NodeByName(cnsPublished).ValueAsDateTime; + FBlogs.Items[i].Update:=Nodes.Items[i].NodeByName(cnsUpdated).ValueAsDateTime; + FBlogs.Items[i].Title:=Nodes.Items[i].NodeByName(cnsTitle).ValueAsString; + NodesChild:=TXmlNodeList.Create; + Nodes.Items[i].FindNodes(cnsCategory,NodesChild); + for i2 := 0 to NodesChild.Count - 1 do + begin + FBlogs.Items[i].СategoryBlog.Add(NodesChild.Items[i2].AttributeByName[cntTerm]); + end; + end; + finally + FreeAndNil(Nodes); + FreeAndNil(NodesChild); + end; +end; + +{------------------------------------------------------------------------------- + Функция: TBlogger.RetrievAllPosts + Автор: NMD + Дата: 2010.08.09 + Входные параметры: Нет + Что делает: получает последние 25 сообщений из блога + Результат: Коллекция TPostCollection содержащая исчерпывающую информацию о сообщении и само сообщение +-------------------------------------------------------------------------------} +function TBlogger.RetrievAllPosts: TPostCollection; +var + Nodes,NodesChild: TXmlNodeList; + i,i2:Integer; +begin + Result:=TPostCollection.Create(nil); + FXMLDoc.Clear; + if FAuth<>'' then + begin//'http://www.blogger.com/feeds/9144819905011498730/posts/default' + if FCurrentBlog>-1 then + FXMLDoc.ReadFromString(GetUrl(cnsPostBlogStart+Blogs.Items[FCurrentBlog].FBlogId+cnsPostBlogEnd,'','get',FAuth,'')) + else + ToError(rsErrorNotSelectBlog); + end + else + ToError(rsErrorNotTolken); + + Nodes:=TXmlNodeList.Create; + FXMLDoc.Root.FindNodes(cnsEntry,Nodes); + for i := 0 to Nodes.Count-1 do + begin + Result.Add; + Result.Items[i].PostId:=GetPostId(Nodes.Items[i].NodeByName(cnsId).ValueAsString); + Result.Items[i].PostTitle:=Nodes.Items[i].NodeByName(cnsTitle).ValueAsString; + Result.Items[i].PostSourse.Add(Nodes.Items[i].NodeByName(cnsContent).ValueAsString); + Result.Items[i].PostPublished:=Nodes.Items[i].NodeByName(cnsPublished).ValueAsDateTime; + Result.Items[i].PostUpdate:=Nodes.Items[i].NodeByName(cnsUpdated).ValueAsDateTime; + NodesChild:=TXmlNodeList.Create; + Nodes.Items[i].FindNodes(cnsCategory,NodesChild); + for i2 := 0 to NodesChild.Count - 1 do + begin + Result.Items[i].СategoryPost.Add(NodesChild.Items[i2].AttributeByName[cntTerm]); + end; + end; +end; + +{------------------------------------------------------------------------------- + Функция: TBlogger.RetrievPostForTextParams + Автор: NMD + Дата: 2010.08.10 21:09:02 + Входные параметры: + Parametrs параметры запроса постов из блога + Что делает: Возвращает посты из блога по заданным параметрам созданым в ручную + Результат: Список постов в коллекции TPostCollection + Необходимо забивать только параметры после знака вопроса + http://www.blogger.com/feeds/9144819905011498730/posts/default?category=Application + то есть category=Application +-------------------------------------------------------------------------------} +function TBlogger.RetrievPostForTextParams(Parametrs:string): TPostCollection; +var + Nodes,NodesChild: TXmlNodeList; + i,i2:Integer; +begin + Result:=TPostCollection.Create(nil); + FXMLDoc.Clear; + if FAuth<>'' then + begin + if FCurrentBlog>-1 then + FXMLDoc.ReadFromString(GetUrl(cnsPostBlogStart+Blogs.Items[FCurrentBlog].FBlogId+cnsPostBlogEnd+parametrs,'','get',FAuth,'')) + else + ToError(rsErrorNotSelectBlog); + end + else + ToError(rsErrorNotTolken); + + Nodes:=TXmlNodeList.Create; + FXMLDoc.Root.FindNodes(cnsEntry,Nodes); + for i := 0 to Nodes.Count-1 do + begin + Result.Add; + Result.Items[i].PostId:=GetPostId(Nodes.Items[i].NodeByName(cnsId).ValueAsString); + Result.Items[i].PostTitle:=Nodes.Items[i].NodeByName(cnsTitle).ValueAsString; + Result.Items[i].PostSourse.Add(Nodes.Items[i].NodeByName(cnsContent).ValueAsString); + Result.Items[i].PostPublished:=Nodes.Items[i].NodeByName(cnsPublished).ValueAsDateTime; + Result.Items[i].PostUpdate:=Nodes.Items[i].NodeByName(cnsUpdated).ValueAsDateTime; + NodesChild:=TXmlNodeList.Create; + Nodes.Items[i].FindNodes(cnsCategory,NodesChild); + for i2 := 0 to NodesChild.Count - 1 do + begin + Result.Items[i].СategoryPost.Add(NodesChild.Items[i2].AttributeByName[cntTerm]); + end; + end; +end; + +{------------------------------------------------------------------------------- + Функция: TBlogger.RetrievPostForParams + Автор: NMD + Дата: 2010.08.10 19:39:25 + Входные параметры: + aAlt atom(default),rss + aCategory Посты определенной категории + aOrderby Задаем порядок постов в котором мы их получим в список постов lastmodified (the default), starttime, or updated. + aPublishedMin Ограничение на дату публикации. Игнорируется если orderby установлен в updated + APublishedMax Ограничение на дату публикации. Игнорируется если orderby установлен в updated + aUpdatedMin Ограничение на дату публикации. Игнорируется если orderby установлен в updated + aUpdatedMax Ограничение на дату публикации. Игнорируется если orderby установлен в updated + aStartIndex Индекс поста который будет получен первым (для докачки постов) + aMaxResults Максимальное кол-во возвращаемых постов + Что делает: Возвращает посты из блога по заданным параметрам + Результат: Список постов в коллекции TPostCollection + Пример + http://www.blogger.com/feeds/9144819905011498730/posts/default?category=Application&max-results=10&start-index=1&published-min=2008-03-16T00:00:00&published-max=2011-03-24T23:59:59 +-------------------------------------------------------------------------------} +function TBlogger.RetrievPostForParams(aCategory:string =''; aOrderby:string =''; aPublishedMin:string =''; + aPublishedMax:string =''; aUpdatedMin:string ='';aUpdatedMax:string =''; + aStartIndex:Integer=0; aMaxResults:Integer=0; aAlt : string =''): TPostCollection; +var + i:Integer; + temp:TStringList; + parametrs:string; +begin + Result:=TPostCollection.Create(nil); + if FAuth='' then + begin + ToError(rsErrorNotTolken); + Exit; + end; + if FCurrentBlog<0 then + begin + ToError(rsErrorNotSelectBlog); + Exit; + end; + parametrs:=''; + temp:=TStringList.Create; + if aAlt<>'' then + temp.Add('alt='+aAlt); + if aCategory<>'' then + temp.Add('category='+aCategory); + if aOrderby<>'' then + temp.Add('orderby='+aOrderby); + if aPublishedMin<>'' then + temp.Add('published-min='+aPublishedMin); + if APublishedMax<>'' then + temp.Add('published-max='+aPublishedMax); + if aUpdatedMin<>'' then + temp.Add('updated-min='+aUpdatedMin); + if aUpdatedMax<>'' then + temp.Add('updated-max='+aUpdatedMax); + if aStartIndex<>0 then + temp.Add('start-index='+IntToStr(aStartIndex)); + if aMaxResults<>0 then + temp.Add('max-results='+IntToStr(aMaxResults)); + for I := 0 to temp.Count - 1 do + begin + if i>0 then + parametrs:=parametrs+'&'+temp.Strings[i] + else + parametrs:=parametrs+temp.Strings[i]; + end; + temp.Free; + Result:=RetrievPostForTextParams(cnsVop+parametrs); +end; + +{------------------------------------------------------------------------------- + Процедура: TBlogger.CreatPost формируем xml будущего сообщения и отправляем его в блог + Автор: NMD + Дата: 2010.08.06 18:37:01 + Входные параметры: + aTitle- заголовок, + aContent-текст сообщения: string; + aCategory-ярлыки сообщения: TStringList; + aComment: Boolean комментарий или нет + Результат: string получаем xml отправленной статьи но уже из блогга или текст ошибки +-------------------------------------------------------------------------------} +function TBlogger.PostCreat(aTitle, aContent: string; aCategory: TStringList; aComment: Boolean):UTF8String; +var + i:Integer; + Node,Node2:TXmlNode; + tempXML :TNativeXml; +begin + Result:=''; + if FAuth='' then + begin + ToError(rsErrorNotTolken); + Exit; + end; + if FCurrentBlog<0 then + begin + ToError(rsErrorNotSelectBlog); + Exit; + end; + + FXMLDoc.Clear; + FXMLDoc.Root.CreateName(FXMLDoc,cnsEntry).AttributeAdd(cnsXmlns,cnsAtomUrl); + { + yes + } + if aComment then + begin + Node:=FXMLDoc.Root.NodeNew(cnsAppControll); + Node.AttributeAdd(cnsXmlnsApp,cnsXmlnsAppUrl); + Node2:=TXmlNode.CreateNameValue(FXMLDoc,cnsAppDraft,cnsYes); + Node.NodeAdd(Node2); + end; + + //Marriage! + with FXMLDoc.Root.NodeNew(cnsTitle)do + begin + AttributeAdd(cnsType,cnsText); + ValueAsString:=aTitle; + end; + // + Node:=FXMLDoc.Root.NodeNew(cnsContent); + Node.AttributeAdd(cnsType,cnsXhtml); + //сам контент единственное он должен быть валидным html + tempXML:=TNativeXml.Create; + try + tempXML.ReadFromString(aContent); + except + ToError(rsErrorXmlTag); + tempXML:=nil; + Exit;//выход + end; + for I := 0 to tempXML.RootNodeList.NodeCount - 1 do + begin + node2:=tempXML.RootNodeList.Nodes[i]; + node.NodeAdd(node2); + end; +{ //
+ Node2:=TXmlNode.CreateName(FXMLDoc,cnsDiv); + Node2.AttributeAdd(cnsXmlns,cnsXhtmlUrl); + Node.NodeAdd(Node2); + Node:=TXmlNode.CreateName(FXMLDoc,'p'); + Node.ValueAsString:=aContent; + Node2.NodeAdd(Node); +} + // + for i := 0 to aCategory.Count - 1 do + with FXMLDoc.Root.NodeNew(cnsCategory) do + begin + AttributeAdd(cnsScheme,cnsAtnsUrl); + AttributeAdd(cnsTerm,sdAnsiToUtf8(aCategory.Strings[i])); + end; + Result:=GetUrl(cnsPostBlogStart+Blogs.Items[FCurrentBlog].FBlogId+cnsPostBlogEnd,'','post',FAuth,FXMLDoc.WriteToString); + tempXML:=nil; +end; + +{------------------------------------------------------------------------------- + Функция: TBlogger.PostModify + Автор: NMD + Дата: 2010.08.10 21:28:47 + Входные параметры: + id сообщения, остальное анологично созданию поста + Что делает: Производит обновление поста в блоге + Результат: xml модифицированного сообщения +-------------------------------------------------------------------------------} +function TBlogger.PostModify(id, aTitle, aContent: string; aCategory: TStringList; aComment: Boolean): UTF8String; +var + i:Integer; + Node,Node2:TXmlNode; + blogId:string; +begin + Result:=''; + if FAuth='' then + begin + ToError(rsErrorNotTolken); + Exit; + end; + if FCurrentBlog<0 then + begin + ToError(rsErrorNotSelectBlog); + Exit; + end; + FXMLDoc.Clear; + FXMLDoc.Root.CreateName(FXMLDoc,cnsEntry).AttributeAdd(cnsXmlns,cnsAtomUrl); + + { + yes + } + if aComment then + begin + Node:=FXMLDoc.Root.NodeNew(cnsAppControll); + Node.AttributeAdd(cnsXmlnsApp,cnsXmlnsAppUrl); + Node2:=TXmlNode.CreateNameValue(FXMLDoc,cnsAppDraft,cnsYes); + Node.NodeAdd(Node2); + end; + // tag:blogger.com,1999:blog-blogID.post-postID + blogId:=IntToStr(FBlogs.Items[FCurrentBlog].id);//id блога + FXMLDoc.Root.NodeNew(cnsId).ValueAsString:='tag:blogger.com,1999:blog-'+blogId+'.post-'+id; + //Marriage! + with FXMLDoc.Root.NodeNew(cnsTitle)do + begin + AttributeAdd(cnsType,cnsText); + ValueAsString:=aTitle; + end; + // + Node:=FXMLDoc.Root.NodeNew(cnsContent); + Node.AttributeAdd(cnsType,cnsXhtml); + //
+ Node2:=TXmlNode.CreateName(FXMLDoc,cnsDiv); + Node2.AttributeAdd(cnsXmlns,cnsXhtmlUrl); + Node.NodeAdd(Node2); + Node:=TXmlNode.CreateName(FXMLDoc,'p'); + Node.ValueAsString:=aContent; + Node2.NodeAdd(Node); + + // + for i := 0 to aCategory.Count - 1 do + with FXMLDoc.Root.NodeNew(cnsCategory) do + begin + AttributeAdd(cnsScheme,cnsAtnsUrl); + AttributeAdd(cnsTerm,sdAnsiToUtf8(aCategory.Strings[i])); + end; + //'http://www.blogger.com/feeds/1897581382578917834/posts/default/5129237316807356045', + Result:=GetUrl(cnsPostBlogStart+Blogs.Items[FCurrentBlog].FBlogId+cnsPostBlogEnd+'/'+id,'','put',FAuth,FXMLDoc.WriteToString); +end; + +{------------------------------------------------------------------------------- + Функция: TBlogger.PostDelete + Автор: NMD + Дата: 2010.08.11 19:24:17 + Входные параметры: + id сообщения которое необходимо удалить + Что делает: удаление поста из блога + Результат: Boolean +-------------------------------------------------------------------------------} +function TBlogger.PostDelete(id: string): Boolean; +begin + if FAuth='' then + begin + ToError(rsErrorNotTolken); + Exit; + end; + if FCurrentBlog<0 then + begin + ToError(rsErrorNotSelectBlog); + Exit; + end; + if id='' then + begin + ToError(rsErrorIdPost); + Exit; + end; + if GetUrl(cnsPostBlogStart+Blogs.Items[FCurrentBlog].FBlogId+cnsPostBlogEnd+'/'+id,'','DELETE',FAuth,'')='1' then + Result:=True + else + Result:=False; +end; + + +procedure TBlogger.SetAppName(const Value: string); +begin + if Value<>'' then + FAppName := Value; +end; + +procedure TBlogger.SetAuth(const Value: string); +begin + if Value<>'' then + begin + FAuth := Value; + RetrievAllBlogs; + end; +end; + +procedure TBlogger.SetBlog(const Value: TBlogCollection); +begin + FBlogs.Assign(Value); +end; + +procedure TBlogger.SetCurrentBlog(const Value: Integer); +begin + FCurrentBlog := Value; +end; + +{BlogCollection} +function TBlogCollection.Add: TBlogItem; +begin + result := TBlogItem(inherited Add); +end; + +function TBlogCollection.AddEx(aName, aTitle,aBlogId: string; aUrl: string; aСategoryBlog: TStringList; aPublished, + aUpdate: TDateTime): TBlogItem; +begin + result := inherited Add as TBlogItem; + Result.FTitle:=aTitle; + Result.FBlogId:=aBlogId; + Result.FСategoryBlog.Assign(aСategoryBlog); + Result.FPublished:=aPublished; + Result.FUpdate:=aUpdate; +end; + +constructor TBlogCollection.Create(AOwner: TComponent); +begin + inherited Create(TBlogItem); +end; + +function TBlogCollection.GetItemBlog(Index: Integer): TBlogItem; +begin + result := TBlogItem(inherited GetItem(Index)); +end; + +procedure TBlogCollection.SetItemBlog(Index: Integer; Value: TBlogItem); +begin + inherited SetItem(Index, Value) +end; + +constructor TBlogItem.Create(Collection: TCollection); +begin + inherited; + FTitle:=''; + FBlogId:=''; + FСategoryBlog:=TStringList.Create;//ярлыки блога + FPublished:=Time;//дата последеней публикации + FUpdate:=Time;//дата последнего обновления +end; + +destructor TBlogItem.Destroy; +begin + FСategoryBlog.Destroy; + inherited; +end; + +procedure TBlogItem.SetCategory(const Value: TStringList); +begin + FСategoryBlog.Assign(Value); +end; + +procedure TBlogItem.SetBlogId(const Value: string); +begin + FBlogId := Value; +end; + +procedure TBlogItem.SetPublished(const Value: TDateTime); +begin + FPublished := Value; +end; + +procedure TBlogItem.SetTitle(const Value: string); +begin + FTitle := Value; +end; + +procedure TBlogItem.SetUpdate(const Value: TDateTime); +begin + FUpdate := Value; +end; + +{ TPostItem } + +constructor TPostItem.Create(Collection: TCollection); +begin + inherited; + FPostSourse:=TStringList.Create; + FСategoryPost:=TStringList.Create; +end; + +destructor TPostItem.Destroy; +begin + FPostSourse.Free; + FСategoryPost.Free; + inherited; +end; + +procedure TPostItem.SetPostId(const Value: string); +begin + FPostId := Value; +end; + +procedure TPostItem.SetPostPublished(const Value: TDateTime); +begin + FPostPublished := Value; +end; + +procedure TPostItem.SetPostSourse(const Value: TStringList); +begin + FPostSourse.Assign(Value); +end; + +procedure TPostItem.SetPostTitle(const Value: string); +begin + FPostTitle := Value; +end; + +procedure TPostItem.SetPostUpdate(const Value: TDateTime); +begin + FPostUpdate:=Value; +end; + +procedure TPostItem.SetСategoryPost(const Value: TStringList); +begin + FСategoryPost.Assign(Value); +end; + +{ TPostCollection } + +function TPostCollection.Add: TPostItem; +begin + result := TPostItem(inherited Add); +end; + +function TPostCollection.AddEx(aPostTitle, aPostId: string; aPostSourse: TStringList; aPostPublished, + aPostUpdate: TDateTime): TPostItem; +begin + result := inherited Add as TPostItem; + Result.FPostTitle:=aPostTitle; + Result.FPostId:=aPostId; + Result.FPostSourse.Assign(aPostSourse); + Result.FPostPublished:=aPostPublished; + Result.FPostUpdate:=aPostUpdate; +end; + +constructor TPostCollection.Create(AOwner: TComponent); +begin + inherited Create(TPostItem); +end; + +function TPostCollection.GetItemBlog(Index: Integer): TPostItem; +begin + result := TPostItem(inherited GetItem(Index)); +end; + +procedure TPostCollection.SetItemBlog(Index: Integer; Value: TPostItem); +begin + inherited SetItem(Index, Value); +end; + +procedure Register; +begin + RegisterComponents('NMD', [TBlogger]); +end; + +end. +