From e023d5e00cb3c709a6144926a615a2b11df90181 Mon Sep 17 00:00:00 2001 From: Zeus Date: Wed, 19 Jul 2023 23:47:08 +0200 Subject: [PATCH] Migrate TALJsonDocument to TALJsonNode * The support for doNodeAutoCreate has been removed. * The properties TALJsonDocument.Duplicates and TALJsonDocument.Sorted are now only applied to the child nodes list and are not inherited anymore. * The properties TALJsonDocument.ParseOptions and TALJsonDocument.Options have been moved as parameters for the methods loadFromJson/saveToJson and loadFromBson/saveToBson. * TALJsonDocument.Duplicates has been moved to the child nodes list. * The ClearChildNodes parameter from loadFromJson/saveToJson has been moved to the options of loadFromJson/saveToJson. * The property TALJSONNode.ownerDocument has been removed. * FormatSettings has been removed. * The property TALJsonDocument.Tag has been removed. * TALJsonDocument.PathSeparator has been replaced by ALDefaultJsonPathSeparator. * TALJsonDocument.NodeIndentStr has been replaced by ALDefaultJsonNodeIndentA. * TALJsonDocument.node has been removed. * TALJsonDocument.create now returns a TALJsonNode. * TALJsonDocument.IsEmptyDoc has been replaced by hasChildNodes. * The method TALJsonDocument.ExtractNode has been removed. * The property TALJsonDocument.Active has been removed. * The method TALJsonDocument.ReleaseDoc has been removed. * The ParseStartDocument and ParseEndDocument events have been removed. * TALJsonDocument.clear has been moved to childnodes.clear. * The events onParseText, onParseStartObject, onParseEndObject, onParseStartArray, and onParseEndArray have been moved to ParseBSON/ParseJSON. --- Demos/ALDatabaseBenchmark/_Source/Unit1.dfm | 33 +- Demos/ALDatabaseBenchmark/_Source/Unit1.pas | 15 +- Demos/ALJsonDoc/_Source/ALJsonDocDemo.dproj | 2 +- Demos/ALJsonDoc/_Source/superdate.pas | 47 - Demos/ALJsonDoc/_Source/superobject.pas | 6627 ----- Demos/ALJsonDoc/_Source/supertimezone.pas | 1376 -- Demos/ALJsonDoc/_Source/supertypes.pas | 38 - Demos/ALJsonDoc/_Source/superxmlparser.pas | 1474 -- Demos/ALJsonDoc/_Source/unit1.dfm | 181 +- Demos/ALJsonDoc/_Source/unit1.pas | 811 +- .../Project1.dpr | 44 + .../Project1.dproj | 225 + README.md | 1 + Source/Alcinoe.FMX.Firebase.Messaging.pas | 2 +- Source/Alcinoe.JSONDoc.pas | 20178 ++++++++-------- Source/Alcinoe.MongoDB.Client.pas | 80 +- Source/Alcinoe.Sqlite3.Client.pas | 16 +- .../_Build/Source/AndroidMerger.dpr | 10 +- .../_Source/DeployProjNormalizer.dpr | 2 +- 19 files changed, 10567 insertions(+), 20595 deletions(-) delete mode 100644 Demos/ALJsonDoc/_Source/superdate.pas delete mode 100644 Demos/ALJsonDoc/_Source/superobject.pas delete mode 100644 Demos/ALJsonDoc/_Source/supertimezone.pas delete mode 100644 Demos/ALJsonDoc/_Source/supertypes.pas delete mode 100644 Demos/ALJsonDoc/_Source/superxmlparser.pas create mode 100644 Embarcadero/_Demos/RSP-42011-performance-issue-comparing-equality-between-two-strings/Project1.dpr create mode 100644 Embarcadero/_Demos/RSP-42011-performance-issue-comparing-equality-between-two-strings/Project1.dproj diff --git a/Demos/ALDatabaseBenchmark/_Source/Unit1.dfm b/Demos/ALDatabaseBenchmark/_Source/Unit1.dfm index 229ef6522..1f0175cbc 100644 --- a/Demos/ALDatabaseBenchmark/_Source/Unit1.dfm +++ b/Demos/ALDatabaseBenchmark/_Source/Unit1.dfm @@ -28,6 +28,8 @@ object Form1: TForm1 item Width = 200 end> + ExplicitTop = 743 + ExplicitWidth = 999 end object Panel3: TPanel Left = 0 @@ -37,25 +39,27 @@ object Form1: TForm1 Align = alClient Caption = 'Panel2' TabOrder = 2 + ExplicitWidth = 999 + ExplicitHeight = 414 object Splitter4: TSplitter - Left = 709 + Left = 705 Top = 1 - Height = 414 + Height = 413 Align = alRight ExplicitLeft = 624 ExplicitTop = -3 ExplicitHeight = 469 end object Panel5: TPanel - Left = 712 + Left = 708 Top = 1 Width = 294 - Height = 414 + Height = 413 Align = alRight Caption = 'Panel2' TabOrder = 0 - ExplicitLeft = 708 - ExplicitHeight = 413 + ExplicitLeft = 704 + ExplicitHeight = 412 object ALMemoResult: TcxMemo Left = 1 Top = 1 @@ -71,6 +75,7 @@ object Form1: TForm1 Style.Font.Style = [] Style.IsFontAssigned = True TabOrder = 0 + ExplicitHeight = 410 Height = 411 Width = 292 end @@ -83,11 +88,13 @@ object Form1: TForm1 Align = alClient Caption = 'Panel2' TabOrder = 1 + ExplicitWidth = 700 + ExplicitHeight = 412 object GridThread: TcxGrid Left = 1 Top = 1 - Width = 706 - Height = 412 + Width = 702 + Height = 411 Align = alClient Font.Charset = ANSI_CHARSET Font.Color = clWindowText @@ -96,8 +103,8 @@ object Form1: TForm1 Font.Style = [] ParentFont = False TabOrder = 0 - ExplicitWidth = 702 - ExplicitHeight = 411 + ExplicitWidth = 698 + ExplicitHeight = 410 object TableViewThread: TcxGridTableView Navigator.Buttons.CustomButtons = <> Navigator.Buttons.First.Visible = False @@ -187,6 +194,7 @@ object Form1: TForm1 TabOrder = 0 Properties.ActivePage = Firebird Properties.CustomButtons.Buttons = <> + ExplicitWidth = 999 ClientRectBottom = 324 ClientRectLeft = 5 ClientRectRight = 998 @@ -194,10 +202,7 @@ object Form1: TForm1 object Firebird: TcxTabSheet Caption = 'Firebird' ImageIndex = 2 - ExplicitLeft = 0 - ExplicitTop = 0 - ExplicitWidth = 993 - ExplicitHeight = 0 + ExplicitWidth = 989 object Label2: TcxLabel Left = 71 Top = 93 diff --git a/Demos/ALDatabaseBenchmark/_Source/Unit1.pas b/Demos/ALDatabaseBenchmark/_Source/Unit1.pas index 70ce67be8..55d37651c 100644 --- a/Demos/ALDatabaseBenchmark/_Source/Unit1.pas +++ b/Demos/ALDatabaseBenchmark/_Source/Unit1.pas @@ -3035,7 +3035,7 @@ procedure TMongoDBBenchmarkThread.Execute; aSelector: AnsiString; aSkip: integer; aFirst: integer; - aJSONDATA: TALJSONDocumentA; + aJSONDATA: TALJSONNodeA; begin aJSONDATA := TALJSONDocumentA.create; @@ -3087,7 +3087,7 @@ procedure TMongoDBBenchmarkThread.Execute; nil)); //update the data - aJSONDATA.Clear; + aJSONDATA.ChildNodes.Clear; aStopWatch := TStopWatch.StartNew; if fCMD = 'SELECT' then Tform1(fOwner).MongoDBConnectionPoolClient.SelectData( aFullCollectionName, @@ -3097,7 +3097,7 @@ procedure TMongoDBBenchmarkThread.Execute; '', // rowtag aSkip, aFirst, - aJSONDATA.Node) + aJSONDATA) else if fCMD = 'UPDATE' then Tform1(fOwner).MongoDBConnectionPoolClient.UpdateData( aFullCollectionName, aQuery, @@ -3688,7 +3688,7 @@ procedure TForm1.ALButtonMemcachedVersionClick(Sender: TObject); {***********************************************************} procedure TForm1.ALButtonMongoDBSelectClick(Sender: TObject); Var aMongoDBClient: TAlMongoDBClient; - aJSONDATA: TALJSONDocumentA; + aJSONDATA: TALJSONNodeA; aStopWatch: TstopWatch; aFlags: TALMongoDBClientSelectDataFlags; begin @@ -3703,11 +3703,6 @@ procedure TForm1.ALButtonMongoDBSelectClick(Sender: TObject); aJSONDATA := TALJSONDocumentA.create; Try - With aJSONDATA Do Begin - Options := [TALJSONDocOption(doNodeAutoIndent)]; - ParseOptions := []; - end; - aflags := []; if CheckGroupMongoDBSelectFlags.States[0] = cbsChecked then aflags := aflags + [sfSlaveOk]; if CheckGroupMongoDBSelectFlags.States[1] = cbsChecked then aflags := aflags + [sfPartial]; @@ -3753,7 +3748,7 @@ procedure TForm1.ALButtonMongoDBSelectClick(Sender: TObject); SQLFastTagReplaceFunct, True, nil)), - aJSONDATA.Node); + aJSONDATA); aStopWatch.Stop; TableViewThread.DataController.RecordCount := 1; diff --git a/Demos/ALJsonDoc/_Source/ALJsonDocDemo.dproj b/Demos/ALJsonDoc/_Source/ALJsonDocDemo.dproj index afa9891a7..2d4136eb8 100644 --- a/Demos/ALJsonDoc/_Source/ALJsonDocDemo.dproj +++ b/Demos/ALJsonDoc/_Source/ALJsonDocDemo.dproj @@ -3,7 +3,7 @@ {E9B8CD6B-2DE3-408B-8DE3-5D9DECEE4A5A} ALJsonDocDemo.dpr True - Debug + Release 3 Application VCL diff --git a/Demos/ALJsonDoc/_Source/superdate.pas b/Demos/ALJsonDoc/_Source/superdate.pas deleted file mode 100644 index b7278e412..000000000 --- a/Demos/ALJsonDoc/_Source/superdate.pas +++ /dev/null @@ -1,47 +0,0 @@ -unit superdate; - -interface - -uses - supertypes, supertimezone; - -function JavaToDelphiDateTime(const dt: Int64; const TimeZone: SOString = ''): TDateTime; -function DelphiToJavaDateTime(const dt: TDateTime; const TimeZone: SOString = ''): Int64; -function JavaDateTimeToISO8601Date(const dt: Int64; const TimeZone: SOString = ''): SOString; -function DelphiDateTimeToISO8601Date(const dt: TDateTime; const TimeZone: SOString = ''): SOString; -function ISO8601DateToJavaDateTime(const str: SOString; var ms: Int64; const TimeZone: SOString = ''): Boolean; -function ISO8601DateToDelphiDateTime(const str: SOString; var dt: TDateTime; const TimeZone: SOString = ''): Boolean; - -implementation - -function JavaToDelphiDateTime(const dt: Int64; const TimeZone: SOString = ''): TDateTime; -begin - Result := TSuperTimeZone.Zone[TimeZone].JavaToDelphi(dt); -end; - -function DelphiToJavaDateTime(const dt: TDateTime; const TimeZone: SOString = ''): Int64; -begin - Result := TSuperTimeZone.Zone[TimeZone].DelphiToJava(dt); -end; - -function JavaDateTimeToISO8601Date(const dt: Int64; const TimeZone: SOString = ''): SOString; -begin - Result := TSuperTimeZone.Zone[TimeZone].JavaToISO8601(dt); -end; - -function DelphiDateTimeToISO8601Date(const dt: TDateTime; const TimeZone: SOString = ''): SOString; -begin - Result := TSuperTimeZone.Zone[TimeZone].DelphiToISO8601(dt); -end; - -function ISO8601DateToJavaDateTime(const str: SOString; var ms: Int64; const TimeZone: SOString = ''): Boolean; -begin - Result := TSuperTimeZone.Zone[TimeZone].ISO8601ToJava(str, ms); -end; - -function ISO8601DateToDelphiDateTime(const str: SOString; var dt: TDateTime; const TimeZone: SOString = ''): Boolean; -begin - Result := TSuperTimeZone.Zone[TimeZone].ISO8601ToDelphi(str, dt); -end; - -end. diff --git a/Demos/ALJsonDoc/_Source/superobject.pas b/Demos/ALJsonDoc/_Source/superobject.pas deleted file mode 100644 index 050e9e449..000000000 --- a/Demos/ALJsonDoc/_Source/superobject.pas +++ /dev/null @@ -1,6627 +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. - * - * Embarcadero Technologies Inc is not permitted to use or redistribute - * this source code without explicit permission. - * - * 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 DEBUG} // track memory leack - - -{$if defined(VER210) or defined(VER220)} - {$define VER210ORGREATER} -{$ifend} - -{$if defined(VER230) or defined(VER240) or defined(VER250) or - defined(VER260) or defined(VER270) or defined(VER280) or - defined(VER290) or defined(VER300)} - {$define VER210ORGREATER} - {$define VER230ORGREATER} -{$ifend} - -{$if defined(FPC) or defined(VER170) or defined(VER180) or defined(VER190) - or defined(VER200) or defined(VER210ORGREATER)} - {$DEFINE HAVE_INLINE} -{$ifend} - -{$if defined(VER210ORGREATER)} - {$define HAVE_RTTI} -{$ifend} - -{$if defined(VER230ORGREATER)} - {$define NEED_FORMATSETTINGS} -{$ifend} - -{$if defined(FPC) and defined(VER2_6)} - {$define NEED_FORMATSETTINGS} -{$ifend} - -{$OVERFLOWCHECKS OFF} -{$RANGECHECKS OFF} - -unit superobject; - -interface -uses - Classes, supertypes -{$IFDEF HAVE_RTTI} - ,Generics.Collections, RTTI, TypInfo -{$ENDIF} - ; - -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; - function Find(const k: SOString; var value: ISuperObject): Boolean; - function Exists(const k: SOString): Boolean; - 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(Integer) 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; overload; - function Add(Data: SuperInt): Integer; overload; - function Add(const Data: SOString): Integer; overload; - function Add(Data: Boolean): Integer; overload; - function Add(Data: Double): Integer; overload; - function AddC(const Data: Currency): 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} - 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 -{$IFDEF FPC} - function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid: tguid; out obj): longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; -{$ELSE} - function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; -{$ENDIF} - 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 HAVE_RTTI} - 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 ObjectIsNull(const obj: ISuperObject): Boolean; - -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 TryObjectToDate(const obj: ISuperObject; var dt: TDateTime): Boolean; -function UUIDToString(const g: TGUID): SOString; -function StringToUUID(const str: SOString; var g: TGUID): Boolean; - -{$IFDEF HAVE_RTTI} - -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, Windows, superdate -{$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 FloatToJson(const value: Double): SOString; -var - p: PSOChar; -begin - Result := FloatToStr(value); - if FormatSettings.DecimalSeparator <> '.' then - begin - p := PSOChar(Result); - while p^ <> #0 do - if p^ <> SOChar(FormatSettings.DecimalSeparator) then - inc(p) else - begin - p^ := '.'; - Exit; - end; - end; -end; - -function CurrToJson(const value: Currency): SOString; -var - p: PSOChar; -begin - Result := CurrToStr(value); - if FormatSettings.DecimalSeparator <> '.' then - begin - p := PSOChar(Result); - while p^ <> #0 do - if p^ <> SOChar(FormatSettings.DecimalSeparator) then - inc(p) else - begin - p^ := '.'; - Exit; - end; - end; -end; - -function TryObjectToDate(const obj: ISuperObject; var dt: TDateTime): Boolean; -var - i: Int64; -begin - case ObjectGetType(obj) of - stInt: - begin - dt := JavaToDelphiDateTime(obj.AsInteger); - Result := True; - end; - stString: - begin - if ISO8601DateToJavaDateTime(obj.AsString, i) then - begin - dt := JavaToDelphiDateTime(i); - Result := True; - end else - Result := TryStrToDateTime(obj.AsString, dt); - end; - else - Result := False; - end; -end; - -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)} - {$IFDEF FPC} - varUString: Result := TSuperObject.Create(SOString(UnicodeString(VString))); - {$ELSE} - varUString: Result := TSuperObject.Create(SOString(string(VUString))); - {$ENDIF} -{$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 ObjectIsNull(const obj: ISuperObject): Boolean; -begin - Result := ObjectIsType(obj, 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 - begin - FreeAndNil(F.Ite); - Result := False; - end; - end else - Result := False; -end; - -function ObjectFindNext(var F: TSuperObjectIter): boolean; -var - i: TSuperAvlEntry; -begin - if Assigned(F.Ite) then - 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 - else - Result := False; -end; - -procedure ObjectFindClose(var F: TSuperObjectIter); -begin - if Assigned(F.Ite) then - FreeAndNil(F.Ite); - F.val := nil; -end; - -function UuidFromString(p: PSOChar; Uuid: PGUID): Boolean; -const - hex2bin: array[48..102] of Byte = ( - 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, - 0,10,11,12,13,14,15, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0,10,11,12,13,14,15); -type - TState = (stEatSpaces, stStart, stHEX, stBracket, stEnd); - TUUID = record - case byte of - 0: (guid: TGUID); - 1: (bytes: array[0..15] of Byte); - 2: (words: array[0..7] of Word); - 3: (ints: array[0..3] of Cardinal); - 4: (i64s: array[0..1] of UInt64); - end; - - function ishex(const c: SOChar): Boolean; {$IFDEF HAVE_INLINE} inline;{$ENDIF} - begin - result := (c < #256) and (AnsiChar(c) in ['0'..'9', 'a'..'z', 'A'..'Z']) - end; -var - pos: Byte; - state, saved: TState; - bracket, separator: Boolean; -label - redo; -begin - FillChar(Uuid^, SizeOf(TGUID), 0); - saved := stStart; - state := stEatSpaces; - bracket := false; - separator := false; - pos := 0; - while true do -redo: - case state of - stEatSpaces: - begin - while true do - case p^ of - ' ', #13, #10, #9: inc(p); - else - state := saved; - goto redo; - end; - end; - stStart: - case p^ of - '{': - begin - bracket := true; - inc(p); - state := stEatSpaces; - saved := stHEX; - pos := 0; - end; - else - state := stHEX; - end; - stHEX: - case pos of - 0..7: - if ishex(p^) then - begin - Uuid^.D1 := (Uuid^.D1 * 16) + hex2bin[Ord(p^)]; - inc(p); - inc(pos); - end else - begin - Result := False; - Exit; - end; - 8: - if (p^ = '-') then - begin - separator := true; - inc(p); - inc(pos) - end else - inc(pos); - 13,18,23: - if separator then - begin - if p^ <> '-' then - begin - Result := False; - Exit; - end; - inc(p); - inc(pos); - end else - inc(pos); - 9..12: - if ishex(p^) then - begin - TUUID(Uuid^).words[2] := (TUUID(Uuid^).words[2] * 16) + hex2bin[Ord(p^)]; - inc(p); - inc(pos); - end else - begin - Result := False; - Exit; - end; - 14..17: - if ishex(p^) then - begin - TUUID(Uuid^).words[3] := (TUUID(Uuid^).words[3] * 16) + hex2bin[Ord(p^)]; - inc(p); - inc(pos); - end else - begin - Result := False; - Exit; - end; - 19..20: - if ishex(p^) then - begin - TUUID(Uuid^).bytes[8] := (TUUID(Uuid^).bytes[8] * 16) + hex2bin[Ord(p^)]; - inc(p); - inc(pos); - end else - begin - Result := False; - Exit; - end; - 21..22: - if ishex(p^) then - begin - TUUID(Uuid^).bytes[9] := (TUUID(Uuid^).bytes[9] * 16) + hex2bin[Ord(p^)]; - inc(p); - inc(pos); - end else - begin - Result := False; - Exit; - end; - 24..25: - if ishex(p^) then - begin - TUUID(Uuid^).bytes[10] := (TUUID(Uuid^).bytes[10] * 16) + hex2bin[Ord(p^)]; - inc(p); - inc(pos); - end else - begin - Result := False; - Exit; - end; - 26..27: - if ishex(p^) then - begin - TUUID(Uuid^).bytes[11] := (TUUID(Uuid^).bytes[11] * 16) + hex2bin[Ord(p^)]; - inc(p); - inc(pos); - end else - begin - Result := False; - Exit; - end; - 28..29: - if ishex(p^) then - begin - TUUID(Uuid^).bytes[12] := (TUUID(Uuid^).bytes[12] * 16) + hex2bin[Ord(p^)]; - inc(p); - inc(pos); - end else - begin - Result := False; - Exit; - end; - 30..31: - if ishex(p^) then - begin - TUUID(Uuid^).bytes[13] := (TUUID(Uuid^).bytes[13] * 16) + hex2bin[Ord(p^)]; - inc(p); - inc(pos); - end else - begin - Result := False; - Exit; - end; - 32..33: - if ishex(p^) then - begin - TUUID(Uuid^).bytes[14] := (TUUID(Uuid^).bytes[14] * 16) + hex2bin[Ord(p^)]; - inc(p); - inc(pos); - end else - begin - Result := False; - Exit; - end; - 34..35: - if ishex(p^) then - begin - TUUID(Uuid^).bytes[15] := (TUUID(Uuid^).bytes[15] * 16) + hex2bin[Ord(p^)]; - inc(p); - inc(pos); - end else - begin - Result := False; - Exit; - end; - 36: if bracket then - begin - state := stEatSpaces; - saved := stBracket; - end else - begin - state := stEatSpaces; - saved := stEnd; - end; - end; - stBracket: - begin - if p^ <> '}' then - begin - Result := False; - Exit; - end; - inc(p); - state := stEatSpaces; - saved := stEnd; - end; - stEnd: - begin - if p^ <> #0 then - begin - Result := False; - Exit; - end; - Break; - end; - end; - Result := True; -end; - -function UUIDToString(const g: TGUID): SOString; -begin - Result := 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 StringToUUID(const str: SOString; var g: TGUID): Boolean; -begin - Result := UuidFromString(PSOChar(str), @g); -end; - -{$IFDEF HAVE_RTTI} - -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; - i: Int64; -begin - case ObjectGetType(obj) of - stInt: - begin - TValueData(Value).FAsDouble := JavaToDelphiDateTime(obj.AsInteger); - Result := True; - end; - stString: - begin - if ISO8601DateToJavaDateTime(obj.AsString, i) then - begin - TValueData(Value).FAsDouble := JavaToDelphiDateTime(i); - Result := True; - end else - if TryStrToDateTime(obj.AsString, dt) then - begin - TValueData(Value).FAsDouble := dt; - Result := True; - end else - Result := False; - end; - else - Result := False; - end; -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; - 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; -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(FloatToJson(FO.c_double))); - stCurrency: - begin - Result := Append(PSOChar(CurrToJson(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 - case FDataType of - stString: Result := FOString; - stNull: Result := ''; - else - Result := AsJSon(false, false); - end; -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; {$IFDEF HAVE_INLINE} inline;{$ENDIF} - begin - if x <= '9' then - Result := byte(x) - byte('0') else - Result := (byte(x) and 7) + 9; - end; - function min(v1, v2: integer): integer;{$IFDEF HAVE_INLINE} inline;{$ENDIF} - 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; - if not (foDelete in options) then - 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; - - -{$IFDEF FPC} -function TSuperObject.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid: tguid; out obj): longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; -{$ELSE} -function TSuperObject.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; -{$ENDIF} -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; - stNull: - Result := TSuperObject.Create(stNull); - 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 - if ite.val <> nil then - PutO(ite.key, ite.val.Clone) else - PutO(ite.key, nil) - - 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 - if prop2 <> nil then - PutO(j, prop2.Clone) else - PutO(j, nil); - 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.Add(Data: SuperInt): Integer; -begin - Result := Add(TSuperObject.Create(Data)); -end; - -function TSuperArray.Add(const Data: SOString): Integer; -begin - Result := Add(TSuperObject.Create(Data)); -end; - -function TSuperArray.Add(Data: Boolean): Integer; -begin - Result := Add(TSuperObject.Create(Data)); -end; - -function TSuperArray.Add(Data: Double): Integer; -begin - Result := Add(TSuperObject.Create(Data)); -end; - -function TSuperArray.AddC(const Data: Currency): Integer; -begin - Result := Add(TSuperObject.CreateCurrency(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; - for i := 1 to Length(k) do - h := h*129 + ord(k[i]) + $9e370001; - 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.Find(const k: SOString; var value: ISuperObject): Boolean; -var - e: TSuperAvlEntry; -begin - e := Search(k); - if e <> nil then - begin - value := e.Value; - Result := True; - end else - Result := False; -end; - -function TSuperTableString.Exists(const k: SOString): Boolean; -begin - Result := Search(k) <> nil; -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 HAVE_RTTI} - -{ 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.Make(@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); - if TypeData.MaxValue > TypeData.MinValue then - Result := (i >= TypeData.MinValue) and (i <= TypeData.MaxValue) else - Result := (i >= TypeData.MinValue) and (i <= Int64(PCardinal(@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; - var - i: Integer; - begin - case ObjectGetType(obj) of - stInt: - begin - TValue.Make(nil, TypeInfo, Value); - TValueData(Value).FAsSLong := obj.AsInteger; - Result := True; - end; - stString: - begin - if TryStrToInt(obj.AsString, i) then - begin - TValue.Make(nil, TypeInfo, Value); - TValueData(Value).FAsSLong := i; - Result := True; - end else - Result := False; - end; - else - Result := False; - end; - 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 - v := TValue.Empty; - 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 -{$IFDEF VER210} - p := IValueData(TValueData(Value).FHeapData).GetReferenceToRawData; -{$ELSE} - p := TValueData(Value).FValueData.GetReferenceToRawData; -{$ENDIF} - Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v); - if Result then - f.SetValue(p, v) else - begin - //Writeln(f.Name); - Exit; - end; - 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(NativeInt(Value.AsObject))]; - if o = nil then - begin - Result := TSuperObject.Create(stObject); - index[IntToStr(NativeInt(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 -{$IFDEF VER210} - v := f.GetValue(IValueData(TValueData(Value).FHeapData).GetReferenceToRawData); -{$ELSE} - v := f.GetValue(TValueData(Value).FValueData.GetReferenceToRawData); -{$ENDIF} - 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; -{$IFNDEF VER210} - var - intf: IInterface; -{$ENDIF} - begin -{$IFDEF VER210} - if TValueData(Value).FHeapData <> nil then - TValueData(Value).FHeapData.QueryInterface(ISuperObject, Result) else - Result := nil; -{$ELSE} - if TValueData(Value).FValueData <> nil then - begin - intf := IInterface(PPointer(TValueData(Value).FValueData.GetReferenceToRawData)^); - if intf <> nil then - intf.QueryInterface(ISuperObject, Result) else - Result := nil; - end else - Result := nil; -{$ENDIF} - 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/Demos/ALJsonDoc/_Source/supertimezone.pas b/Demos/ALJsonDoc/_Source/supertimezone.pas deleted file mode 100644 index 9949f98eb..000000000 --- a/Demos/ALJsonDoc/_Source/supertimezone.pas +++ /dev/null @@ -1,1376 +0,0 @@ -unit supertimezone; - -interface - -uses - Windows, Registry, SysUtils, Math, Generics.Collections, - supertypes; - -type - TSuperTimeZone = class - private - const - TZ_TZI_KEY = '\SYSTEM\CurrentControlSet\Control\TimeZoneInformation'; { Vista and + } - TZ_KEY = '\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Time Zones\'; - TZ_KEYNAME = 'TimeZoneKeyName'; - private - FName: SOString; - function GetName: SOString; - - { Windows Internals } - function TzSpecificLocalTimeToSystemTime( - const lpTimeZoneInformation: PTimeZoneInformation; - var lpLocalTime, lpUniversalTime: TSystemTime): BOOL; - - function SystemTimeToTzSpecificLocalTime( - const lpTimeZoneInformation: PTimeZoneInformation; - var lpUniversalTime, lpLocalTime: TSystemTime): BOOL; - - function GetTimezoneBias(const pTZinfo: PTimeZoneInformation; - lpFileTime: PFileTime; islocal: Boolean; pBias: PLongint): Boolean; - - function CompTimeZoneID(const pTZinfo: PTimeZoneInformation; - lpFileTime: PFileTime; IsLocal: Boolean): LongWord; - - function DayLightCompareDate(const date: PSystemTime; - const compareDate: PSystemTime): Integer; - private - class constructor Init; - class destructor Finish; - class var FCacheCS: TRTLCriticalSection; - class var FCache: TObjectDictionary; - class function GetSuperTimeZoneInstance(const Name: string): TSuperTimeZone; static; - class function GetLocalSuperTimeZoneInstance: TSuperTimeZone; static; - public - constructor Create(const TimeZoneName: SOString = ''); - - { ISO8601 formatted date Parser } - class function ParseISO8601Date(const ISO8601Date: SOString; - var st: TSystemTime; var dayofyear: Integer; var week: Word; var bias: Integer; - var havetz, havedate: Boolean): Boolean; - - { Conversions } - function LocalToUTC(const DelphiDateTime: TDateTime): TDateTime; - function UTCToLocal(const DelphiDateTime: TDateTime): TDateTime; - - function JavaToDelphi(const JavaDateTime: Int64): TDateTime; - function DelphiToJava(const DelphiDateTime: TDateTime): Int64; - - function JavaToISO8601(JavaDateTime: Int64): SOString; - function DelphiToISO8601(DelphiDateTime: TDateTime): SOString; - - function ISO8601ToJava(const ISO8601Date: SOString; var JavaDateTime: Int64): Boolean; - function ISO8601ToDelphi(const ISO8601Date: SOString; var DelphiDateTime: TDateTime): Boolean; - - { TZ Info } - class function GetCurrentTimeZone: SOString; - function GetTimeZoneInformation(Year: Word; var TZI: TTimeZoneInformation): Boolean; - function GetDaylightDisabled: Boolean; - property Name: SOString read GetName; - - { Builder } - class property Local: TSuperTimeZone read GetLocalSuperTimeZoneInstance; - class property Zone[const TimeZoneName: string]: TSuperTimeZone read GetSuperTimeZoneInstance; - end; - -{$IFDEF MSWINDOWS} - {$WARN SYMBOL_PLATFORM OFF} - -(* NOT DST Aware *) - -{ Windows 2000+ } -function _SystemTimeToTzSpecificLocalTime( - lpTimeZoneInformation: PTimeZoneInformation; - var lpUniversalTime, lpLocalTime: TSystemTime): BOOL; stdcall; external kernel32 name 'SystemTimeToTzSpecificLocalTime' delayed; - -{ Windows XP+ } -function _TzSpecificLocalTimeToSystemTime( - lpTimeZoneInformation: PTimeZoneInformation; - var lpLocalTime, lpUniversalTime: TSystemTime): BOOL; stdcall; external kernel32 name 'TzSpecificLocalTimeToSystemTime' delayed; - -(* EXtended version - DST Aware *) - -{ Windows 7+ } -function _TzSpecificLocalTimeToSystemTimeEx( - const lpTimeZoneInformation: PDynamicTimeZoneInformation; - const lpLocalTime: PSystemTime; var lpUniversalTime: TSystemTime): BOOL; stdcall; external kernel32 name 'TzSpecificLocalTimeToSystemTimeEx' delayed; - -{ Windows 7+ } -function _SystemTimeToTzSpecificLocalTimeEx( - const lpTimeZoneInformation: PDynamicTimeZoneInformation; - const lpUniversalTime: PSystemTime; var lpLocalTime: TSystemTime): BOOL; stdcall; external kernel32 name 'SystemTimeToTzSpecificLocalTimeEx' delayed; - -{ Convert Local <=> UTC for specific time-zones using the Windows API only. NOT Guaranteed to work } - -function _ConvertLocalDateTimeToUTC(const TimeZoneName: SOString; - const Local: TDateTime; var UTC: TDateTime): Boolean; - -function _ConvertUTCDateTimeToLocal(const TimeZoneName: SOString; - const UTC: TDateTime; var Local: TDateTime): Boolean; - - {$WARN SYMBOL_PLATFORM ON} -{$ENDIF} - -implementation - -{$IFDEF MSWINDOWS} - -{ Convert Local -> UTC for specific time-zones using the Windows API only. NOT Guaranteed to work } - -function _ConvertLocalDateTimeToUTC(const TimeZoneName: SOString; - const Local: TDateTime; var UTC: TDateTime): Boolean; -var - DTZI: TDynamicTimeZoneInformation; - local_st, utc_st: TSystemTime; -begin - if not CheckWin32Version(6, 1) then - begin - Result := False; - Exit; - end; - - { We work with system times } - DateTimeToSystemTime(Local, local_st); - - { Get current Dynamic TimeZone Information } - FillChar(DTZI, SizeOf(TDynamicTimeZoneInformation), 0); - GetDynamicTimeZoneInformation(DTZI); - - { Replaces the TimeZoneKeyName member with specified TimeZoneName } - Move(TimeZoneName[1], DTZI.TimeZoneKeyName, (Length(TimeZoneName) + 1) * SizeOf(SOChar)); - - { Retrieves the TimeZoneInformation structure and convert the local time to utc } - if _TzSpecificLocalTimeToSystemTimeEx(@DTZI, @local_st, utc_st) then - begin - { We really want Delphi TDateTime } - UTC := SystemTimeToDateTime(utc_st); - Result := True; - end - else - Result := False; -end; - -{ Convert UTC -> Local for specific time-zones using the Windows API only. NOT Guaranteed to work } - -function _ConvertUTCDateTimeToLocal(const TimeZoneName: SOString; - const UTC: TDateTime; var Local: TDateTime): Boolean; -var - DTZI: TDynamicTimeZoneInformation; - utc_st, local_st: TSystemTime; -begin - if not CheckWin32Version(6, 1) then - begin - Result := False; - Exit; - end; - - { We work with system times } - DateTimeToSystemTime(UTC, utc_st); - - { Get current Dynamic TimeZone Information } - FillChar(DTZI, SizeOf(TDynamicTimeZoneInformation), 0); - GetDynamicTimeZoneInformation(DTZI); - - { Replaces the TimeZoneKeyName member with specified TimeZoneName } - Move(TimeZoneName[1], DTZI.TimeZoneKeyName[0], Length(TimeZoneName) * SizeOf(SOChar)); - - { Retrieves the TimeZoneInformation structure and convert the local time to utc } - if _SystemTimeToTzSpecificLocalTimeEx(@DTZI, @utc_st, local_st) then - begin - { We really want Delphi TDateTime } - Local := SystemTimeToDateTime(local_st); - Result := True; - end - else - Result := False; -end; -{$ENDIF} - -{ TSuperDate } - -class constructor TSuperTimeZone.Init; -begin - InitializeCriticalSection(FCacheCS); - FCache := TObjectDictionary.Create([doOwnsValues]); -end; - -class destructor TSuperTimeZone.Finish; -begin - FCache.Free; - DeleteCriticalSection(FCacheCS); -end; - -class function TSuperTimeZone.GetSuperTimeZoneInstance( - const Name: string): TSuperTimeZone; -begin - EnterCriticalSection(FCacheCS); - try - if not FCache.TryGetValue(Name, Result) then - begin - Result := TSuperTimeZone.Create(Name); - FCache.Add(Name, Result); - end; - finally - LeaveCriticalSection(FCacheCS); - end; -end; - -class function TSuperTimeZone.GetLocalSuperTimeZoneInstance: TSuperTimeZone; -begin - Result := TSuperTimeZone.GetSuperTimeZoneInstance(''); -end; - -constructor TSuperTimeZone.Create(const TimeZoneName: SOString); -begin - inherited Create; - FName := TimeZoneName; -end; - -function TSuperTimeZone.LocalToUTC(const DelphiDateTime: TDateTime): TDateTime; -var - local, utc: TSystemTime; - tzi: TTimeZoneInformation; -begin - DateTimeToSystemTime(DelphiDateTime, local); - if GetTimeZoneInformation(local.wYear, tzi) and TzSpecificLocalTimeToSystemTime(@tzi, local, utc) then - Result := SystemTimeToDateTime(utc) - else - Result := DelphiDateTime; -end; - -function TSuperTimeZone.UTCToLocal(const DelphiDateTime: TDateTime): TDateTime; -var - utc, local: TSystemTime; - tzi: TTimeZoneInformation; -begin - DateTimeToSystemTime(DelphiDateTime, utc); - if GetTimeZoneInformation(utc.wYear, tzi) and SystemTimeToTzSpecificLocalTime(@tzi, utc, local) then - Result := SystemTimeToDateTime(local) - else - Result := DelphiDateTime; -end; - -function TSuperTimeZone.DelphiToJava(const DelphiDateTime: TDateTime): Int64; -var - local, utc, st: TSystemTime; - tzi: TTimeZoneInformation; -begin - DateTimeToSystemTime(DelphiDateTime, local); - if GetTimeZoneInformation(local.wYear, tzi) and TzSpecificLocalTimeToSystemTime(@tzi, local, utc) then - st := utc - else - st := local; - Result := Round((SystemTimeToDateTime(st) - 25569) * 86400000); -end; - -function TSuperTimeZone.JavaToDelphi(const JavaDateTime: Int64): TDateTime; -var - utc, local: TSystemTime; - tzi: TTimeZoneInformation; -begin - DateTimeToSystemTime(25569 + (JavaDateTime / 86400000), utc); - if GetTimeZoneInformation(utc.wYear, tzi) and SystemTimeToTzSpecificLocalTime(@tzi, utc, local) then - Result := SystemTimeToDateTime(local) - else - Result := SystemTimeToDateTime(utc); -end; - -function TSuperTimeZone.DelphiToISO8601( - DelphiDateTime: TDateTime): SOString; -const - ISO_Fmt = '%.4d-%.2d-%.2dT%.2d:%.2d:%.2d.%d'; - TZ_Fmt = '%s%.2d:%.2d'; -var - local, utc: TSystemTime; - tzi: TTimeZoneInformation; - bias: TDateTime; - h, m, d: Word; - iso: SOString; -begin - DateTimeToSystemTime(DelphiDateTime, local); - iso := Format(ISO_Fmt, [ - local.wYear, local.wMonth, local.wDay, - local.wHour, local.wMinute, local.wSecond, local.wMilliseconds]); - if GetTimeZoneInformation(local.wYear, tzi) and TzSpecificLocalTimeToSystemTime(@tzi, local, utc) then - begin - bias := SystemTimeToDateTime(local) - SystemTimeToDateTime(utc); - DecodeTime(bias, h, m, d, d); - case Sign(bias) of - -1: Result := iso + Format(TZ_Fmt, [ '-', h, m ]); - 0: Result := iso + 'Z'; - +1: Result := iso + Format(TZ_Fmt, [ '+', h, m ]); - end; - end - else - Result := iso; -end; - -function TSuperTimeZone.JavaToISO8601(JavaDateTime: Int64): SOString; -begin - Result := DelphiToISO8601(JavaToDelphi(JavaDateTime)); -end; - -function TSuperTimeZone.ISO8601ToDelphi(const ISO8601Date: SOString; - var DelphiDateTime: TDateTime): Boolean; -var - JavaDateTime: Int64; -begin - Result := ISO8601ToJava(ISO8601Date, JavaDateTime); - if Result then - DelphiDateTime := JavaToDelphi(JavaDateTime); -end; - -function TSuperTimeZone.ISO8601ToJava(const ISO8601Date: SOString; - var JavaDateTime: Int64): Boolean; -var - st: TSystemTime; - dayofyear: Integer; - week: Word; - bias: Integer; - havetz, havedate: Boolean; - - tzi: TTimeZoneInformation; - utc: TSystemTime; - m: Word; - DayTable: PDayTable; -begin - if ParseISO8601Date(ISO8601Date, st, dayofyear, week, bias, havetz, havedate) then - begin - if (not havetz) and GetTimeZoneInformation(st.wYear, tzi) and TzSpecificLocalTimeToSystemTime(@tzi, st, utc) then - bias := Trunc((SystemTimeToDateTime(st) - SystemTimeToDateTime(utc)) * MinsPerDay); - JavaDateTime := st.wMilliseconds + st.wSecond * 1000 + (st.wMinute + bias) * 60000 + st.wHour * 3600000; - if havedate then - begin - DayTable := @MonthDays[IsLeapYear(st.wYear)]; - if st.wMonth <> 0 then - begin - if not (st.wMonth in [1..12]) or (DayTable^[st.wMonth] < st.wDay) then - begin - Result := False; - Exit; - end; - for m := 1 to st.wMonth - 1 do - Inc(JavaDateTime, Int64(DayTable^[m]) * 86400000); - end; - Dec(st.wYear); - Inc(JavaDateTime, Int64( - (st.wYear * 365) + (st.wYear div 4) - (st.wYear div 100) + - (st.wYear div 400) + st.wDay + dayofyear - 719163) * 86400000); - end; - Result := True; - end - else - Result := False; -end; - -function TSuperTimeZone.GetName: SOString; -begin - if FName <> '' then - Result := FName - else - Result := GetCurrentTimeZone; -end; - -class function TSuperTimeZone.GetCurrentTimeZone: SOString; -begin - with TRegistry.Create do - try - RootKey := HKEY_LOCAL_MACHINE; - if OpenKeyReadOnly(TZ_TZI_KEY) and ValueExists(TZ_KEYNAME) then - { Windows Vista+ } - Result := Trim(ReadString(TZ_KEYNAME)) - else - begin - { Windows 2000/XP } - CloseKey; - RootKey := HKEY_CURRENT_USER; - if OpenKeyReadOnly(TZ_KEY) and ValueExists(TZ_KEYNAME) then - Result := Trim(ReadString(TZ_KEYNAME)) - else - begin - CloseKey; - RootKey := HKEY_USERS; - if OpenKeyReadOnly('.DEFAULT\' + TZ_KEY) and ValueExists(TZ_KEYNAME) then - Result := Trim(ReadString(TZ_KEYNAME)) - else - Result := ''; - end; - end; - finally - CloseKey; - Free; - end; -end; - -function TSuperTimeZone.GetDaylightDisabled: Boolean; -var - KeyName: SOString; -begin - Result := False; - KeyName := TZ_KEY + Name; - with TRegistry.Create do - try - RootKey := HKEY_LOCAL_MACHINE; - if OpenKeyReadOnly(KeyName) then - begin - if ValueExists('IsObsolete') then - Result := ReadBool('IsObsolete'); - CloseKey; - end; - finally - Free; - end; -end; - -function TSuperTimeZone.GetTimeZoneInformation(Year: Word; - var TZI: TTimeZoneInformation): Boolean; -type - TRegistryTZI = packed record - Bias: LongInt; - StandardBias: LongInt; - DaylightBias: LongInt; - StandardChangeTime: TSystemTime; - DaylightChangeTime: TSystemTime; - end; -var - RegTZI: TRegistryTZI; - KeyName: SOString; - FirstYear, LastYear, ChangeYear: Word; - Retry: Boolean; -begin - FillChar(TZI, SizeOf(TZI), 0); - KeyName := TZ_KEY + Name; - with TRegistry.Create do - try - RootKey := HKEY_LOCAL_MACHINE; - if not KeyExists(KeyName) then - begin - Result := False; - Exit; - end; - - ChangeYear := 0; - if OpenKeyReadOnly(KeyName + '\Dynamic DST') then - try - FirstYear := ReadInteger('FirstEntry'); - LastYear := ReadInteger('LastEntry'); - - if (Year >= FirstYear) and (Year <= LastYear) then - ChangeYear := Year - else - ChangeYear := 0; - - Retry := False; - repeat - while (ChangeYear > 0) and (not ValueExists(IntToStr(ChangeYear))) do - begin - Dec(ChangeYear); - if ChangeYear < FirstYear then - ChangeYear := 0; - end; - - if ChangeYear > 0 then - begin - ReadBinaryData(IntToStr(ChangeYear), RegTZI, SizeOf(TRegistryTZI)); - if RegTZI.DaylightChangeTime.wMonth > RegTZI.StandardChangeTime.wMonth then - begin - Dec(ChangeYear); - Retry := not Retry; - end; - end; - until not Retry; - finally - CloseKey; - end; - - if (ChangeYear = 0) and OpenKeyReadOnly(KeyName) then - try - ReadBinaryData('TZI', RegTZI, SizeOf(TRegistryTZI)); - finally - CloseKey; - end; - - TZI.Bias := RegTZI.Bias; - TZI.StandardDate := RegTZI.StandardChangeTime; - TZI.StandardBias := RegTZI.StandardBias; - TZI.DaylightDate := RegTZI.DaylightChangeTime; - TZI.DaylightBias := RegTZI.DaylightBias; - - Result := True; - finally - Free; - end; -end; - -function TSuperTimeZone.TzSpecificLocalTimeToSystemTime( - const lpTimeZoneInformation: PTimeZoneInformation; - var lpLocalTime, lpUniversalTime: TSystemTime): BOOL; -var - ft: TFileTime; - lBias: LongInt; - t: Int64; -begin - Assert(lpTimeZoneInformation <> nil); - if (not SystemTimeToFileTime(lpLocalTime, ft)) then - begin - Result := False; - Exit; - end; - t := PInt64(@ft)^; - if (not GetTimezoneBias(lpTimeZoneInformation, @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; - -function TSuperTimeZone.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 TSuperTimeZone.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 (not GetDaylightDisabled) and (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 - begin - (* Down south *) - if BeforeStandardDate or AfterDaylightDate then - Result := TIME_ZONE_ID_DAYLIGHT; - end; - end - else - (* No transition date *) - Result := TIME_ZONE_ID_UNKNOWN; -end; - -function TSuperTimeZone.DayLightCompareDate(const date, 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]) 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 TSuperTimeZone.SystemTimeToTzSpecificLocalTime( - const lpTimeZoneInformation: PTimeZoneInformation; - var lpUniversalTime, lpLocalTime: TSystemTime): BOOL; -var - ft: TFileTime; - lBias: LongInt; - llTime: Int64; -begin - Assert(lpTimeZoneInformation <> nil); - if (not SystemTimeToFileTime(lpUniversalTime, ft)) then - begin - Result := False; - Exit; - end; - llTime := PInt64(@ft)^; - if (not GetTimezoneBias(lpTimeZoneInformation, @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; - -class function TSuperTimeZone.ParseISO8601Date(const ISO8601Date: SOString; - var st: TSystemTime; var dayofyear: Integer; var week: Word; - var bias: Integer; var havetz, havedate: Boolean): Boolean; - - function get(var v: Word; c: SOChar): Boolean; {$IFDEF HAVE_INLINE} inline; {$ENDIF} - begin - if (c < #256) and (AnsiChar(c) in ['0' .. '9']) then - begin - Result := True; - v := v * 10 + Ord(c) - Ord('0'); - end - else - Result := False; - end; - -type - TState = (stStart, stYear, stMonth, stWeek, stWeekDay, stDay, stDayOfYear, - stHour, stMin, stSec, stMs, stUTC, stGMTH, stGMTM, stGMTend, stEnd); - TPerhaps = (yes, no, perhaps); -var - p: PSOChar; - sep: TPerhaps; - state: TState; - pos, v: Word; - inctz: Boolean; -label - error; -begin - p := PSOChar(ISO8601Date); - sep := perhaps; - state := stStart; - pos := 0; - inctz := False; - - FillChar(st, SizeOf(st), 0); - dayofyear := 0; - week := 0; - bias := 0; - havedate := True; - havetz := False; - - while True do - case state of - stStart: - case p^ of - '0' .. '9': - state := stYear; - 'T', 't': - begin - state := stHour; - pos := 0; - Inc(p); - havedate := False; - end; - else - goto error; - end; - stYear: - case pos of - 0 .. 1, 3: - if get(st.wYear, p^) then - begin - Inc(pos); - Inc(p); - end - else - goto error; - 2: - case p^ of - '0' .. '9': - begin - st.wYear := st.wYear * 10 + Ord(p^) - Ord('0'); - Inc(pos); - Inc(p); - end; - ':': - begin - havedate := False; - st.wHour := st.wYear; - st.wYear := 0; - Inc(p); - pos := 0; - state := stMin; - sep := yes; - end; - else - goto error; - end; - 4: - case p^ of - '-': - begin - pos := 0; - Inc(p); - sep := yes; - state := stMonth; - end; - '0' .. '9': - begin - sep := no; - pos := 0; - state := stMonth; - end; - 'W', 'w': - begin - pos := 0; - Inc(p); - state := stWeek; - end; - 'T', 't', ' ': - begin - state := stHour; - pos := 0; - Inc(p); - st.wMonth := 1; - st.wDay := 1; - end; - #0: - begin - st.wMonth := 1; - st.wDay := 1; - state := stEnd; - end; - else - goto error; - end; - end; - stMonth: - case pos of - 0: - case p^ of - '0' .. '9': - begin - st.wMonth := Ord(p^) - Ord('0'); - Inc(pos); - Inc(p); - end; - 'W', 'w': - begin - pos := 0; - Inc(p); - state := stWeek; - end; - else - goto error; - end; - 1: - if get(st.wMonth, p^) then - begin - Inc(pos); - Inc(p); - end - else - goto error; - 2: - case p^ of - '-': - if (sep in [yes, perhaps]) then - begin - pos := 0; - Inc(p); - state := stDay; - sep := yes; - end - else - goto error; - '0' .. '9': - if sep in [no, perhaps] then - begin - pos := 0; - state := stDay; - sep := no; - end - else - begin - dayofyear := st.wMonth * 10 + Ord(p^) - Ord('0'); - st.wMonth := 0; - Inc(p); - pos := 3; - state := stDayOfYear; - end; - 'T', 't', ' ': - begin - state := stHour; - pos := 0; - Inc(p); - st.wDay := 1; - end; - #0: - begin - st.wDay := 1; - state := stEnd; - end; - else - goto error; - end; - end; - stDay: - case pos of - 0: - if get(st.wDay, p^) then - begin - Inc(pos); - Inc(p); - end - else - goto error; - 1: - if get(st.wDay, p^) then - begin - Inc(pos); - Inc(p); - end - else if sep in [no, perhaps] then - begin - dayofyear := st.wMonth * 10 + st.wDay; - st.wDay := 0; - st.wMonth := 0; - state := stDayOfYear; - end - else - goto error; - 2: - case p^ of - 'T', 't', ' ': - begin - pos := 0; - Inc(p); - state := stHour; - end; - #0: - state := stEnd; - else - goto error; - end; - end; - stDayOfYear: - begin - if (dayofyear <= 0) then - goto error; - case p^ of - 'T', 't', ' ': - begin - pos := 0; - Inc(p); - state := stHour; - end; - #0: - state := stEnd; - else - goto error; - end; - end; - stWeek: - begin - case pos of - 0 .. 1: - if get(week, p^) then - begin - Inc(pos); - Inc(p); - end - else - goto error; - 2: - case p^ of - '-': - if (sep in [yes, perhaps]) then - begin - Inc(p); - state := stWeekDay; - sep := yes; - end - else - goto error; - '1' .. '7': - if sep in [no, perhaps] then - begin - state := stWeekDay; - sep := no; - end - else - goto error; - else - goto error; - end; - end; - end; - stWeekDay: - begin - if (week > 0) and get(st.wDayOfWeek, p^) then - begin - Inc(p); - v := st.wYear - 1; - v := ((v * 365) + (v div 4) - (v div 100) + (v div 400)) mod 7 + 1; - dayofyear := (st.wDayOfWeek - v) + ((week) * 7) + 1; - if v <= 4 then - Dec(dayofyear, 7); - case p^ of - 'T', 't', ' ': - begin - pos := 0; - Inc(p); - state := stHour; - end; - #0: - state := stEnd; - else - goto error; - end; - end - else - goto error; - end; - stHour: - case pos of - 0: - case p^ of - '0' .. '9': - if get(st.wHour, p^) then - begin - Inc(pos); - Inc(p); - end - else - goto error; - '-': - begin - Inc(p); - state := stMin; - end; - else - goto error; - end; - 1: - if get(st.wHour, p^) then - begin - Inc(pos); - Inc(p); - end - else - goto error; - 2: - case p^ of - ':': - if sep in [yes, perhaps] then - begin - sep := yes; - pos := 0; - Inc(p); - state := stMin; - end - else - goto error; - ',', '.': - begin - Inc(p); - state := stMs; - end; - '+': - if havedate then - begin - state := stGMTH; - pos := 0; - v := 0; - Inc(p); - end - else - goto error; - '-': - if havedate then - begin - state := stGMTH; - pos := 0; - v := 0; - Inc(p); - inctz := True; - end - else - goto error; - 'Z', 'z': - if havedate then - state := stUTC - else - goto error; - '0' .. '9': - if sep in [no, perhaps] then - begin - pos := 0; - state := stMin; - sep := no; - end - else - goto error; - #0: - state := stEnd; - else - goto error; - end; - end; - stMin: - case pos of - 0: - case p^ of - '0' .. '9': - if get(st.wMinute, p^) then - begin - Inc(pos); - Inc(p); - end - else - goto error; - '-': - begin - Inc(p); - state := stSec; - end; - else - goto error; - end; - 1: - if get(st.wMinute, p^) then - begin - Inc(pos); - Inc(p); - end - else - goto error; - 2: - case p^ of - ':': - if sep in [yes, perhaps] then - begin - pos := 0; - Inc(p); - state := stSec; - sep := yes; - end - else - goto error; - ',', '.': - begin - Inc(p); - state := stMs; - end; - '+': - if havedate then - begin - state := stGMTH; - pos := 0; - v := 0; - Inc(p); - end - else - goto error; - '-': - if havedate then - begin - state := stGMTH; - pos := 0; - v := 0; - Inc(p); - inctz := True; - end - else - goto error; - 'Z', 'z': - if havedate then - state := stUTC - else - goto error; - '0' .. '9': - if sep in [no, perhaps] then - begin - pos := 0; - state := stSec; - end - else - goto error; - #0: - state := stEnd; - else - goto error; - end; - end; - stSec: - case pos of - 0 .. 1: - if get(st.wSecond, p^) then - begin - Inc(pos); - Inc(p); - end - else - goto error; - 2: - case p^ of - ',', '.': - begin - Inc(p); - state := stMs; - end; - '+': - if havedate then - begin - state := stGMTH; - pos := 0; - v := 0; - Inc(p); - end - else - goto error; - '-': - if havedate then - begin - state := stGMTH; - pos := 0; - v := 0; - Inc(p); - inctz := True; - end - else - goto error; - 'Z', 'z': - if havedate then - state := stUTC - else - goto error; - #0: - state := stEnd; - else - goto error; - end; - end; - stMs: - case p^ of - '0' .. '9': - begin - st.wMilliseconds := st.wMilliseconds * 10 + Ord(p^) - Ord('0'); - Inc(p); - end; - '+': - if havedate then - begin - state := stGMTH; - pos := 0; - v := 0; - Inc(p); - end - else - goto error; - '-': - if havedate then - begin - state := stGMTH; - pos := 0; - v := 0; - Inc(p); - inctz := True; - end - else - goto error; - 'Z', 'z': - if havedate then - state := stUTC - else - goto error; - #0: - state := stEnd; - else - goto error; - end; - stUTC: // = GMT 0 - begin - havetz := True; - Inc(p); - if p^ = #0 then - Break - else - goto error; - end; - stGMTH: - begin - havetz := True; - case pos of - 0 .. 1: - if get(v, p^) then - begin - Inc(p); - Inc(pos); - end - else - goto error; - 2: - begin - bias := v * 60; - case p^ of - ':': // if sep in [yes, perhaps] then - begin - state := stGMTM; - Inc(p); - pos := 0; - v := 0; - sep := yes; - end; // else goto error; - '0' .. '9': - // if sep in [no, perhaps] then - begin - state := stGMTM; - pos := 1; - sep := no; - Inc(p); - v := Ord(p^) - Ord('0'); - end; // else goto error; - #0: - state := stGMTend; - else - goto error; - end; - - end; - end; - end; - stGMTM: - case pos of - 0 .. 1: - if get(v, p^) then - begin - Inc(p); - Inc(pos); - end - else - goto error; - 2: - case p^ of - #0: - begin - state := stGMTend; - Inc(bias, v); - end; - else - goto error; - end; - end; - stGMTend: - begin - if not inctz then - bias := -bias; - Break; - end; - stEnd: - begin - - Break; - end; - end; - - if (st.wHour >= 24) or (st.wMinute >= 60) or (st.wSecond >= 60) or - (st.wMilliseconds >= 1000) or (week > 53) then - goto error; - - Result := True; - Exit; -error: - Result := False; -end; - -end. diff --git a/Demos/ALJsonDoc/_Source/supertypes.pas b/Demos/ALJsonDoc/_Source/supertypes.pas deleted file mode 100644 index 3ce724ff8..000000000 --- a/Demos/ALJsonDoc/_Source/supertypes.pas +++ /dev/null @@ -1,38 +0,0 @@ -unit supertypes; - -{$IFDEF FPC} - {$MODE OBJFPC}{$H+} -{$ENDIF} - -interface - -type -{$IFNDEF FPC} -{$IFDEF CPUX64} - PtrInt = Int64; - PtrUInt = UInt64; -{$ELSE} - PtrInt = longint; - PtrUInt = Longword; -{$ENDIF} -{$ENDIF} - SuperInt = Int64; - -{$if (sizeof(Char) = 1)} - SOChar = WideChar; - SOIChar = Word; - PSOChar = PWideChar; -{$IFDEF FPC} - SOString = UnicodeString; -{$ELSE} - SOString = WideString; -{$ENDIF} -{$else} - SOChar = Char; - SOIChar = Word; - PSOChar = PChar; - SOString = string; -{$ifend} -implementation - -end. diff --git a/Demos/ALJsonDoc/_Source/superxmlparser.pas b/Demos/ALJsonDoc/_Source/superxmlparser.pas deleted file mode 100644 index 63ea2936d..000000000 --- a/Demos/ALJsonDoc/_Source/superxmlparser.pas +++ /dev/null @@ -1,1474 +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. - * - * Embarcadero Technologies Inc is not permitted to use or redistribute - * this source code without explicit permission. - * - * Unit owner : Henri Gourvest - * Web site : http://www.progdigy.com - *) - - unit superxmlparser; -{$IFDEF FPC} - {$MODE OBJFPC}{$H+} -{$ENDIF} - -interface - -uses superobject, classes, supertypes; - -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; - -{$IFDEF UNICODE} -type - TXMLWriteMethod = reference to procedure(const data: string); -procedure XMLWrite(const node: ISuperObject; const method: TXMLWriteMethod); -{$ENDIF} - -const - xmlname = '#name'; - xmlattributes = '#attributes'; - xmlchildren = '#children'; - xmltext = '#text'; - - 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); - -{$IFDEF UNICODE} - procedure XMLWrite(const node: ISuperObject; const method: TXMLWriteMethod); - procedure Escape(const str: string); - var - p1, p2: PChar; - procedure push(const data: string); - begin - if p2 > p1 then - method(Copy(p1, 0, p2-p1)); - Inc(p2); - p1 := p2; - if data <> '' then - method(data); - end; - begin - p1 := PChar(str); - p2 := p1; - - while True do - case p2^ of - '<': push('<'); - '>': push('>'); - '&': push('&'); - '"': push('"'); - #0 : - begin - push(''); - Break; - end; - else - inc(p2); - end; - end; - var - o: ISuperObject; - ent: TSuperAvlEntry; - begin - method('<' + node.S[xmlname]); - if ObjectIsType(node[xmlattributes], stObject) then - for ent in node[xmlattributes].AsObject do - begin - method(' ' + ent.Name + '="'); - Escape(ent.Value.AsString); - method('"'); - end; - if ObjectIsType(node[xmlchildren], stArray) then - begin - method('>'); - for o in node[xmlchildren] do - if ObjectIsType(o, stString) then - Escape(o.AsString) else - XMLWrite(o, method); - method(''); - end else - method('/>'); - end; -{$ENDIF} - -type - 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], xmltext); - 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, xmltext); - end; - FStack^.obj.Delete(xmlchildren); - end; - if (FStack^.prev <> nil) and (FStack^.obj.AsObject.count > 1) then - begin - if (FStack^.obj.AsObject.count = 2) and (FStack^.obj.AsObject[xmltext] <> nil) then - AddProperty(FStack^.prev^.obj, FStack^.obj.AsObject[xmltext], FStack^.obj.AsObject.S[xmlname]) else - AddProperty(FStack^.prev^.obj, FStack^.obj, FStack^.obj.AsObject.S[xmlname]); - end; - 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 (ret >= min) then - begin - dst^ := WideChar(ret); - inc(Result); - end else - // too small utf8 bloc - // ignore and continue - Continue; - 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/Demos/ALJsonDoc/_Source/unit1.dfm b/Demos/ALJsonDoc/_Source/unit1.dfm index 6942607b7..ad5bd2351 100644 --- a/Demos/ALJsonDoc/_Source/unit1.dfm +++ b/Demos/ALJsonDoc/_Source/unit1.dfm @@ -2,8 +2,8 @@ object Form1: TForm1 Left = 438 Top = 209 Caption = 'Form1' - ClientHeight = 728 - ClientWidth = 1024 + ClientHeight = 724 + ClientWidth = 1008 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText @@ -14,36 +14,79 @@ object Form1: TForm1 object PageControl1: TPageControl Left = 0 Top = 0 - Width = 1024 - Height = 728 + Width = 1008 + Height = 724 ActivePage = TabSheet1 Align = alClient TabOrder = 0 - ExplicitWidth = 1028 - ExplicitHeight = 729 + ExplicitWidth = 1004 + ExplicitHeight = 723 object TabSheet1: TTabSheet Caption = 'Main' object Label1: TLabel Left = 510 - Top = 21 - Width = 82 - Height = 13 + Top = 45 + Width = 104 + Height = 16 Caption = 'Sax mode events' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = 16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False end - object ButtonLoadXmlWithALXmlDocument: TButton + object Label3: TLabel + Left = 16 + Top = 45 + Width = 36 + Height = 16 + Caption = 'JSON' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = 16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label4: TLabel + Left = 510 + Top = 509 + Width = 38 + Height = 16 + Caption = 'BSON' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = 16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object ButtonLoadJsonDocument: TButton Left = 16 Top = 632 Width = 473 Height = 25 - Caption = 'Load Json Document From the Previous Content' + Caption = 'Load Json Document From the JSON memo' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = 16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False TabOrder = 0 - OnClick = ButtonLoadXmlWithALXmlDocumentClick + OnClick = ButtonLoadJsonDocumentClick end object MemoJson: TMemo Left = 16 - Top = 18 + Top = 64 Width = 473 - Height = 599 + Height = 553 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = 16 + Font.Name = 'Courier New' + Font.Style = [] Lines.Strings = ( '{' '_id : 1.32,' @@ -64,6 +107,7 @@ object Form1: TForm1 '"Javascript":function showMilitaryTime() {if (document.theForm.s' + 'howMilitary[0].checked) {return true;}return false;}' '}') + ParentFont = False ScrollBars = ssBoth TabOrder = 1 end @@ -73,33 +117,71 @@ object Form1: TForm1 Width = 473 Height = 25 Caption = 'Create Dynamically Json Document' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = 16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False TabOrder = 2 OnClick = ButtonCreateDynamicallyJsonDocumentClick end object MemoSaxModeEvents: TMemo Left = 510 - Top = 40 + Top = 64 Width = 499 - Height = 418 + Height = 394 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = 16 + Font.Name = 'Courier New' + Font.Style = [] + ParentFont = False ScrollBars = ssBoth TabOrder = 3 end object MemoBSON: TMemo Left = 510 - Top = 505 + Top = 528 Width = 499 - Height = 183 + Height = 160 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = 16 + Font.Name = 'Courier New' + Font.Style = [] + ParentFont = False ScrollBars = ssBoth TabOrder = 4 end - object Button1: TButton + object ButtonLoadJsonFromBson: TButton Left = 510 Top = 470 Width = 499 Height = 25 - Caption = 'Load JSON Document from BSON Content Below' + Caption = 'Load JSON Document from BSON memo' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = 16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False TabOrder = 5 - OnClick = Button1Click + OnClick = ButtonLoadJsonFromBsonClick + end + object CheckBoxUseTALJsonDocumentW: TCheckBox + Left = 16 + Top = 12 + Width = 297 + Height = 17 + Caption = 'Use unicode version of TalJsonDoc (ie: TalJsonDocW)' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = 16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 6 end end object TabSheet2: TTabSheet @@ -118,11 +200,24 @@ object Form1: TForm1 Font.Style = [fsBold] ParentFont = False end + object Label5: TLabel + Left = 510 + Top = 73 + Width = 311 + Height = 16 + Caption = '!! YOU MUST COMPILE THIS DEMO IN RELEASE !!' + Font.Charset = DEFAULT_CHARSET + Font.Color = clRed + Font.Height = 16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end object Chart1: TChart Left = 0 - Top = 104 - Width = 1020 - Height = 597 + Top = 115 + Width = 1000 + Height = 581 Legend.Alignment = laTop Title.Text.Strings = ( 'TChart') @@ -198,23 +293,10 @@ object Form1: TForm1 YValues.Name = 'Bar' YValues.Order = loNone end - object Series5: TBarSeries - HoverElement = [] - Legend.Text = 'SuperObject' - LegendTitle = 'SuperObject' - Marks.Visible = False - Marks.Angle = 65 - Emboss.Color = 8684676 - Shadow.Color = 8684676 - XValues.Name = 'X' - XValues.Order = loAscending - YValues.Name = 'Bar' - YValues.Order = loNone - end end object BtnRunBenchmark: TButton Left = 24 - Top = 73 + Top = 53 Width = 220 Height = 25 Caption = 'Run benchmark' @@ -236,7 +318,7 @@ object Form1: TForm1 Top = 20 Width = 145 Height = 17 - Caption = 'TALJsonDoc (Ansistring)' + Caption = 'TALJsonDocA (Ansistring)' Checked = True State = cbChecked TabOrder = 3 @@ -246,19 +328,11 @@ object Form1: TForm1 Top = 20 Width = 153 Height = 17 - Caption = 'TALJsonDocU (Unicode)' + Caption = 'TALJsonDocW (Unicode)' Checked = True State = cbChecked TabOrder = 4 end - object CheckBoxSuperObject: TCheckBox - Left = 583 - Top = 20 - Width = 97 - Height = 17 - Caption = 'SuperObject' - TabOrder = 5 - end object CheckBoxSystemJSON: TCheckBox Left = 360 Top = 20 @@ -267,7 +341,7 @@ object Form1: TForm1 Caption = 'System.JSON' Checked = True State = cbChecked - TabOrder = 6 + TabOrder = 5 end object CheckBoxDwsJSON: TCheckBox Left = 480 @@ -277,7 +351,16 @@ object Form1: TForm1 Caption = ' dwsJSON' Checked = True State = cbChecked + TabOrder = 6 + end + object BtnMemoryConsumption: TButton + Left = 24 + Top = 84 + Width = 220 + Height = 25 + Caption = 'Memory consumption' TabOrder = 7 + OnClick = BtnMemoryConsumptionClick end end end diff --git a/Demos/ALJsonDoc/_Source/unit1.pas b/Demos/ALJsonDoc/_Source/unit1.pas index bc17f280e..b7fe90520 100644 --- a/Demos/ALJsonDoc/_Source/unit1.pas +++ b/Demos/ALJsonDoc/_Source/unit1.pas @@ -3,10 +3,10 @@ interface uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Windows, system.Types, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, Alcinoe.StringUtils, Alcinoe.JSONDoc, ExtCtrls, Alcinoe.StringList, Shellapi, Vcl.Dialogs, - Contnrs, Alcinoe.Files, diagnostics, superobject, DBXplatform, IOUtils, + Contnrs, Alcinoe.Files, diagnostics, DBXplatform, IOUtils, dwsJSON, system.Generics.collections, system.UITypes, system.JSON, Vcl.ComCtrls, VclTee.TeeGDIPlus, Vcl.Samples.Spin, VCLTee.TeEngine, VCLTee.Series, VCLTee.TeeProcs, @@ -20,30 +20,34 @@ TForm1 = class(TForm) TabSheet1: TTabSheet; TabSheet2: TTabSheet; Label1: TLabel; - ButtonLoadXmlWithALXmlDocument: TButton; + ButtonLoadJsonDocument: TButton; MemoJson: TMemo; ButtonCreateDynamicallyJsonDocument: TButton; MemoSaxModeEvents: TMemo; MemoBSON: TMemo; - Button1: TButton; + ButtonLoadJsonFromBson: TButton; Label2: TLabel; Chart1: TChart; Series1: TBarSeries; Series2: TBarSeries; Series3: TBarSeries; Series4: TBarSeries; - Series5: TBarSeries; BtnRunBenchmark: TButton; SpinEditNbItems: TSpinEdit; CheckBoxTALJsonDocJSON: TCheckBox; CheckBoxTALJsonDocUJSON: TCheckBox; - CheckBoxSuperObject: TCheckBox; CheckBoxSystemJSON: TCheckBox; CheckBoxDwsJSON: TCheckBox; - procedure ButtonLoadXmlWithALXmlDocumentClick(Sender: TObject); + Label3: TLabel; + Label4: TLabel; + CheckBoxUseTALJsonDocumentW: TCheckBox; + Label5: TLabel; + BtnMemoryConsumption: TButton; + procedure ButtonLoadJsonDocumentClick(Sender: TObject); procedure ButtonCreateDynamicallyJsonDocumentClick(Sender: TObject); - procedure Button1Click(Sender: TObject); + procedure ButtonLoadJsonFromBsonClick(Sender: TObject); procedure BtnRunBenchmarkClick(Sender: TObject); + procedure BtnMemoryConsumptionClick(Sender: TObject); private public end; @@ -55,9 +59,6 @@ implementation {$R *.dfm} -{$WARNINGS OFF} - - {**************************************} function GetTotalMemoryAllocated: int64; var aMemoryState: TMemoryManagerState; @@ -65,7 +66,9 @@ function GetTotalMemoryAllocated: int64; begin // get memory manager state + {$WARNINGS OFF} GetMemoryManagerState(aMemoryState); + {$WARNINGS ON} // take the allocated size Result := 0; @@ -86,101 +89,138 @@ function GetTotalMemoryAllocated: int64; end; -{********************************************************************} -procedure TForm1.ButtonLoadXmlWithALXmlDocumentClick(Sender: TObject); +{************************************************************} +procedure TForm1.ButtonLoadJsonDocumentClick(Sender: TObject); begin - //clear MemoJSON + //clear Memos MemoSaxModeEvents.Lines.Clear; MemoBSON.lines.Clear; MemoSaxModeEvents.Lines.Clear; - if messageDlg('Use unicode version of TalJsonDoc (ie: TalJsonDocU)?', mtConfirmation, [TMsgDlgBtn.mbNo, TMsgDlgBtn.mbYes], 0) = MrNo then begin + //Use the ansiString version of TALJSONDocument + if not CheckBoxUseTALJsonDocumentW.Checked then begin //exemple 1 load the JSON doc in memory - var LALJsonDocument := TALJSONDocumentA.Create; + var LALJsonDocumentA := TALJSONDocumentA.CreateFromJSONString(AnsiString(MemoJSON.Lines.Text)); try - LALJsonDocument.LoadFromJSONString(AnsiString(MemoJSON.Lines.Text)); - LALJsonDocument.Options := [doNodeAutoIndent]; - MemoJSON.Lines.Text := String(LALJsonDocument.JSON); - var LBsonStr := LALJsonDocument.BSON; - for var I := 1 to length(LBsonStr) do - MemoBSON.Lines.add(Inttostr(ord(LBsonStr[i]))); + var LJsonStr: AnsiString; + LALJsonDocumentA.SaveToJSONString(LJsonStr, [soNodeAutoIndent]); + MemoJSON.Lines.Text := String(LJSONStr); + + var LBsonStr := LALJsonDocumentA.BSON; + if LBsonStr <> '' then + MemoBSON.Lines.Text := String(ALBinToHexA(LALJsonDocumentA.BSON)); finally - LALJsonDocument.Free; + LALJsonDocumentA.Free; end; //exemple 2 load the JSON doc in SAX MODE - LALJsonDocument := TALJSONDocumentA.Create; - try - LALJsonDocument.onParseText := procedure (Sender: TObject; const Path: AnsiString; const name: AnsiString; const Args: array of const; NodeSubType: TALJSONNodeSubType) - begin - case NodeSubType of - nstFloat: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + string(ALFloatToStrA(Args[0].VExtended^, ALDefaultFormatSettingsA))); - nstText: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + string(ansiString(Args[0].VAnsiString))); - nstObject: ; - nstArray: ; - nstObjectID: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + 'ObjectId("'+string(ALBinToHexA(ansiString(Args[0].VAnsiString)))+'")'); - nstBoolean: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + String(ALBoolToStrA(Args[0].VBoolean,'true','false'))); - nstDateTime: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + string(ALFormatDateTimeA('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', Args[0].VExtended^, ALDefaultFormatSettingsA))); - nstNull: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + 'null'); - nstRegEx: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + string(ansiString(Args[0].VAnsiString))); - nstBinary: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + 'BinData('+inttostr(Args[1].VInteger)+', "'+string(ansiString(ALBase64EncodeString(ansiString(Args[0].VAnsiString))))+'")'); - nstJavascript: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + string(ansiString(Args[0].VAnsiString))); - nstInt32: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + 'NumberInt('+inttostr(Args[0].VInteger)+')'); - nstTimestamp: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + 'Timestamp('+inttostr(int64(cardinal(Args[0].VInteger)))+', '+inttostr(int64(cardinal(Args[1].VInteger)))+')'); - nstInt64: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + 'NumberLong('+inttostr(Args[0].VInt64^)+')'); - end; - end; - - LALJsonDocument.LoadFromJSONString(AnsiString(MemoJSON.Lines.Text), true{saxMode}); - finally - LALJsonDocument.Free; - end; + TALJSONDocumentA.ParseJSONString( + AnsiString(MemoJSON.Lines.Text), + //-- + procedure (Sender: TObject; const Path: AnsiString; const name: AnsiString; const Args: array of const; NodeSubType: TALJSONNodeSubType) + begin + case NodeSubType of + nstFloat: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + string(ALFloatToStrA(Args[0].VExtended^, ALDefaultFormatSettingsA))); + nstText: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + string(ansiString(Args[0].VAnsiString))); + nstObject: ; + nstArray: ; + nstObjectID: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + 'ObjectId("'+string(ALBinToHexA(ansiString(Args[0].VAnsiString)))+'")'); + nstBoolean: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + String(ALBoolToStrA(Args[0].VBoolean,'true','false'))); + nstDateTime: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + string(ALFormatDateTimeA('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', Args[0].VExtended^, ALDefaultFormatSettingsA))); + nstNull: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + 'null'); + nstRegEx: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + string(ansiString(Args[0].VAnsiString))); + nstBinary: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + 'BinData('+inttostr(Args[1].VInteger)+', "'+string(ansiString(ALBase64EncodeString(ansiString(Args[0].VAnsiString))))+'")'); + nstJavascript: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + string(ansiString(Args[0].VAnsiString))); + nstInt32: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + 'NumberInt('+inttostr(Args[0].VInteger)+')'); + nstTimestamp: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + 'Timestamp('+inttostr(int64(cardinal(Args[0].VInteger)))+', '+inttostr(int64(cardinal(Args[1].VInteger)))+')'); + nstInt64: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + 'NumberLong('+inttostr(Args[0].VInt64^)+')'); + end; + end{onParseText}, + //-- + procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) + begin + MemoSaxModeEvents.Lines.Add('STARTOBJECT => ' + String(Name)); + end{onParseStartObject}, + //-- + procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) + begin + MemoSaxModeEvents.Lines.Add('ENDOBJECT => ' + String(Name)); + end{onParseEndObject}, + //-- + procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) + begin + MemoSaxModeEvents.Lines.Add('STARTARRAY => ' + String(Name)); + end{onParseStartArray}, + //-- + procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) + begin + MemoSaxModeEvents.Lines.Add('ENDARRAY => ' + String(Name)); + end{onParseEndArray}); end + + //Use the unicode String version of TALJSONDocument else begin //exemple 1 load the JSON doc in memory - var LALJsonDocumentU := TALJSONDocumentW.Create; + var LALJsonDocumentW := TALJSONDocumentW.CreateFromJSONString(MemoJSON.Lines.Text); try - LALJsonDocumentU.LoadFromJSONString(MemoJSON.Lines.Text); - LALJsonDocumentU.Options := [doNodeAutoIndent]; - MemoJSON.Lines.Text := LALJsonDocumentU.JSON; - var LBsonBytes := LALJsonDocumentU.BSON; - for var I := 0 to length(LBsonBytes) - 1 do - MemoBSON.Lines.add(Inttostr(LBsonBytes[i])); + var LJsonStr: String; + LALJsonDocumentW.SaveToJSONString(LJsonStr, [soNodeAutoIndent]); + MemoJSON.Lines.Text := LJSONStr; + + var LBsonBytes := LALJsonDocumentW.BSON; + if length(LBsonBytes) > 0 then + MemoBSON.Lines.Text := ALBinToHexW(LALJsonDocumentW.BSON); finally - LALJsonDocumentU.Free; + LALJsonDocumentW.Free; end; //exemple 2 load the JSON doc in SAX MODE - LALJsonDocumentU := TALJSONDocumentW.Create; - try - LALJsonDocumentU.onParseText := procedure (Sender: TObject; const Path: String; const name: String; const Args: array of const; NodeSubType: TALJSONNodeSubType) - begin - case NodeSubType of - nstFloat: MemoSaxModeEvents.Lines.Add(Path + '=' + ALFloatToStrW(Args[0].VExtended^, ALDefaultFormatSettingsW)); - nstText: MemoSaxModeEvents.Lines.Add(Path + '=' + String(Args[0].VUnicodeString)); - nstObject: ; - nstArray: ; - nstObjectID: MemoSaxModeEvents.Lines.Add(Path + '=' + 'ObjectId("'+string(Args[0].VUnicodeString)+'")'); - nstBoolean: MemoSaxModeEvents.Lines.Add(Path + '=' + ALBoolToStrW(Args[0].VBoolean,'true','false')); - nstDateTime: MemoSaxModeEvents.Lines.Add(Path + '=' + ALFormatDateTimeW('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', Args[0].VExtended^, ALDefaultFormatSettingsW)); - nstNull: MemoSaxModeEvents.Lines.Add(Path + '=' + 'null'); - nstRegEx: MemoSaxModeEvents.Lines.Add(Path + '=' + String(Args[0].VUnicodeString)); - nstBinary: MemoSaxModeEvents.Lines.Add(Path + '=' + 'BinData('+ALIntToStrW(Args[1].VInteger)+', "'+String(Args[0].VunicodeString)+'")'); - nstJavascript: MemoSaxModeEvents.Lines.Add(Path + '=' + String(Args[0].VUnicodeString)); - nstInt32: MemoSaxModeEvents.Lines.Add(Path + '=' + 'NumberInt('+ALIntToStrW(Args[0].VInteger)+')'); - nstTimestamp: MemoSaxModeEvents.Lines.Add(Path + '=' + 'Timestamp('+ALIntToStrW(int64(cardinal(Args[0].VInteger)))+', '+ALIntToStrW(int64(cardinal(Args[1].VInteger)))+')'); - nstInt64: MemoSaxModeEvents.Lines.Add(Path + '=' + 'NumberLong('+inttostr(Args[0].VInt64^)+')'); - end; - end; - - LALJsonDocumentU.LoadFromJSONString(MemoJSON.Lines.Text, true{saxMode}); - finally - LALJsonDocumentU.Free; - end; + TALJSONDocumentW.ParseJSONString( + MemoJSON.Lines.Text, + //-- + procedure (Sender: TObject; const Path: String; const name: String; const Args: array of const; NodeSubType: TALJSONNodeSubType) + begin + case NodeSubType of + nstFloat: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + ALFloatToStrW(Args[0].VExtended^, ALDefaultFormatSettingsW)); + nstText: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + String(Args[0].VUnicodeString)); + nstObject: ; + nstArray: ; + nstObjectID: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'ObjectId("'+string(Args[0].VUnicodeString)+'")'); + nstBoolean: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + ALBoolToStrW(Args[0].VBoolean,'true','false')); + nstDateTime: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + ALFormatDateTimeW('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', Args[0].VExtended^, ALDefaultFormatSettingsW)); + nstNull: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'null'); + nstRegEx: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + String(Args[0].VUnicodeString)); + nstBinary: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'BinData('+ALIntToStrW(Args[1].VInteger)+', "'+String(Args[0].VunicodeString)+'")'); + nstJavascript: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + String(Args[0].VUnicodeString)); + nstInt32: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'NumberInt('+ALIntToStrW(Args[0].VInteger)+')'); + nstTimestamp: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'Timestamp('+ALIntToStrW(int64(cardinal(Args[0].VInteger)))+', '+ALIntToStrW(int64(cardinal(Args[1].VInteger)))+')'); + nstInt64: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'NumberLong('+inttostr(Args[0].VInt64^)+')'); + end; + end{onParseText}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + MemoSaxModeEvents.Lines.Add('STARTOBJECT => ' + Name); + end{onParseStartObject}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + MemoSaxModeEvents.Lines.Add('ENDOBJECT => ' + Name); + end{onParseEndObject}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + MemoSaxModeEvents.Lines.Add('STARTARRAY => ' + Name); + end{onParseStartArray}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + MemoSaxModeEvents.Lines.Add('ENDARRAY => ' + Name); + end{onParseEndArray}); end; @@ -188,37 +228,31 @@ procedure TForm1.ButtonLoadXmlWithALXmlDocumentClick(Sender: TObject); {*************************************************************************} procedure TForm1.ButtonCreateDynamicallyJsonDocumentClick(Sender: TObject); -Var LALJsonDocument: TALJSONDocumentA; - LALJsonDocumentU: TALJSONDocumentW; - LBsonStr: AnsiString; - LBsonBytes: Tbytes; - LBytes: Tbytes; - i: integer; begin - //clear MemoJSON + //clear Memos MemoJSON.Lines.Clear; MemoBSON.Lines.Clear; MemoSaxModeEvents.Lines.Clear; - if messageDlg('Use unicode version of TalJsonDoc (ie: TalJsonDocU)?', mtConfirmation, [TMsgDlgBtn.mbNo, TMsgDlgBtn.mbYes], 0) = MrNo then begin + //Use the ansiString version of TALJSONDocument + if not CheckBoxUseTALJsonDocumentW.Checked then begin - LALJsonDocument:= TALJSONDocumentA.Create(true); + var LALJsonDocumentA:= TALJSONDocumentA.Create; Try - - LALJsonDocument.addchild('_id').float := 1.32; - with LALJsonDocument.addchild('name', ntObject) do begin + LALJsonDocumentA.addchild('_id').float := 1.32; + with LALJsonDocumentA.addchild('name', ntObject) do begin addchild('first').text := 'John'; addchild('last').text := 'Backus'; end; - LALJsonDocument.addchild('birth').datetime := Now; - with LALJsonDocument.addchild('contribs', ntArray) do begin + LALJsonDocumentA.addchild('birth').datetime := Now; + with LALJsonDocumentA.addchild('contribs', ntArray) do begin addchild.text := 'Fortran'; addchild.text := 'ALGOL'; addchild.text := 'Backus-Naur Form'; addchild.text := 'FP'; end; - with LALJsonDocument.addchild('awards', ntArray) do begin + with LALJsonDocumentA.addchild('awards', ntArray) do begin with addchild(ntObject) do begin addchild('award').text := 'National Medal of Science'; addchild('year').int32 := 1975; @@ -230,102 +264,237 @@ procedure TForm1.ButtonCreateDynamicallyJsonDocumentClick(Sender: TObject); addchild('by').text := 'ACM'; end; end; - LALJsonDocument.addchild('spouse'); - LALJsonDocument.addchild('address', ntObject); - LALJsonDocument.addchild('phones', ntArray); - with LALJsonDocument.AddChild('regex') do begin + LALJsonDocumentA.addchild('spouse'); + LALJsonDocumentA.addchild('address', ntObject); + LALJsonDocumentA.addchild('phones', ntArray); + with LALJsonDocumentA.AddChild('regex') do begin RegEx := ']*>(.*?)'; RegExOptions := [preMultiLine, preCaseLess]; end; - with LALJsonDocument.AddChild('binary') do begin + with LALJsonDocumentA.AddChild('binary') do begin binary := #1#2#3#4#5; BinarySubType := 0; end; - LALJsonDocument.AddChild('ObjectId').ObjectId := #1#2#3#4#5#6#7#8#9#0#1#2; + LALJsonDocumentA.AddChild('ObjectId').ObjectId := #1#2#3#4#5#6#7#8#9#0#1#2; - LALJsonDocument.Options := [doNodeAutoIndent]; - MemoJSON.Lines.Text := String(LALJsonDocument.JSON); - LBsonStr := LALJsonDocument.BSON; - for I := 1 to length(LBsonStr) do - MemoBSON.Lines.add(Inttostr(ord(LBsonStr[i]))); + var LJsonStr: AnsiString; + LALJsonDocumentA.SaveToJSONString(LJsonStr, [soNodeAutoIndent]); + MemoJSON.Lines.Text := String(LJSONStr); + MemoBSON.Lines.Text := String(ALBinToHexA(LALJsonDocumentA.BSON)); finally - LALJsonDocument.Free; + LALJsonDocumentA.Free; end; - end - else begin + end - LALJsonDocumentU:= TALJSONDocumentW.Create(true); - Try + //Use the unicode String version of TALJSONDocument + else begin - LALJsonDocumentU.addchild('_id').float := 1.32; - with LALJsonDocumentU.addchild('name', ntObject) do begin - addchild('first').text := 'John'; - addchild('last').text := 'Backus'; - end; - LALJsonDocumentU.addchild('birth').datetime := Now; - with LALJsonDocumentU.addchild('contribs', ntArray) do begin - addchild.text := 'Fortran'; - addchild.text := 'ALGOL'; - addchild.text := 'Backus-Naur Form'; - addchild.text := 'FP'; - end; - with LALJsonDocumentU.addchild('awards', ntArray) do begin - with addchild(ntObject) do begin - addchild('award').text := 'National Medal of Science'; - addchild('year').int32 := 1975; - addchild('by').text := 'National Science Foundation'; - end; - with addchild(ntObject) do begin - addchild('award').text := 'Turing Award'; - addchild('year').int32 := 1977; - addchild('by').text := 'ACM'; - end; - end; - LALJsonDocumentU.addchild('spouse'); - LALJsonDocumentU.addchild('address', ntObject); - LALJsonDocumentU.addchild('phones', ntArray); - with LALJsonDocumentU.AddChild('regex') do begin - RegEx := ']*>(.*?)'; - RegExOptions := [preMultiLine, preCaseLess]; + var LALJsonDocumentW:= TALJSONDocumentW.Create; + Try + LALJsonDocumentW.addchild('_id').float := 1.32; + with LALJsonDocumentW.addchild('name', ntObject) do begin + addchild('first').text := 'John'; + addchild('last').text := 'Backus'; + end; + LALJsonDocumentW.addchild('birth').datetime := Now; + with LALJsonDocumentW.addchild('contribs', ntArray) do begin + addchild.text := 'Fortran'; + addchild.text := 'ALGOL'; + addchild.text := 'Backus-Naur Form'; + addchild.text := 'FP'; + end; + with LALJsonDocumentW.addchild('awards', ntArray) do begin + with addchild(ntObject) do begin + addchild('award').text := 'National Medal of Science'; + addchild('year').int32 := 1975; + addchild('by').text := 'National Science Foundation'; end; - with LALJsonDocumentU.AddChild('binary') do begin - setlength(LBytes, 5); - LBytes[0] := 1; - LBytes[1] := 2; - LBytes[2] := 3; - LBytes[3] := 4; - LBytes[4] := 5; - binary := ALBase64EncodeBytesW(LBytes); - BinarySubType := 0; + with addchild(ntObject) do begin + addchild('award').text := 'Turing Award'; + addchild('year').int32 := 1977; + addchild('by').text := 'ACM'; end; - setlength(LBytes, 12); + end; + LALJsonDocumentW.addchild('spouse'); + LALJsonDocumentW.addchild('address', ntObject); + LALJsonDocumentW.addchild('phones', ntArray); + with LALJsonDocumentW.AddChild('regex') do begin + RegEx := ']*>(.*?)'; + RegExOptions := [preMultiLine, preCaseLess]; + end; + var LBytes: Tbytes; + with LALJsonDocumentW.AddChild('binary') do begin + setlength(LBytes, 5); LBytes[0] := 1; LBytes[1] := 2; LBytes[2] := 3; LBytes[3] := 4; LBytes[4] := 5; - LBytes[5] := 6; - LBytes[6] := 7; - LBytes[7] := 8; - LBytes[8] := 9; - LBytes[9] := 0; - LBytes[10] := 1; - LBytes[11] := 2; - LALJsonDocumentU.AddChild('ObjectId').ObjectId := ALBinToHexW(LBytes); - - LALJsonDocumentU.Options := [doNodeAutoIndent]; - MemoJSON.Lines.Text := LALJsonDocumentU.JSON; - LBsonBytes := LALJsonDocumentU.BSON; - for I := 0 to length(LBsonBytes) - 1 do - MemoBSON.Lines.add(Inttostr(LBsonBytes[i])); - - finally - LALJsonDocumentU.Free; + binary := ALBase64EncodeBytesW(LBytes); + BinarySubType := 0; end; + setlength(LBytes, 12); + LBytes[0] := 1; + LBytes[1] := 2; + LBytes[2] := 3; + LBytes[3] := 4; + LBytes[4] := 5; + LBytes[5] := 6; + LBytes[6] := 7; + LBytes[7] := 8; + LBytes[8] := 9; + LBytes[9] := 0; + LBytes[10] := 1; + LBytes[11] := 2; + LALJsonDocumentW.AddChild('ObjectId').ObjectId := ALBinToHexW(LBytes); + + var LJsonStr: String; + LALJsonDocumentW.SaveToJSONString(LJsonStr, [soNodeAutoIndent]); + MemoJSON.Lines.Text := LJSONStr; + + MemoBSON.Lines.Text := ALBinToHexW(LALJsonDocumentW.BSON); + finally + LALJsonDocumentW.Free; + end; + + end; +end; + +{************************************************************} +procedure TForm1.ButtonLoadJsonFromBsonClick(Sender: TObject); +begin + + //init LBsonStr + var LBsonStr: AnsiString := ALHexToBin(ansiString(ALTrim(MemoBSON.Text))); + + //clear Memos + MemoJSON.Lines.Clear; + MemoSaxModeEvents.lines.clear; + + //Use the ansiString version of TALJSONDocument + if not CheckBoxUseTALJsonDocumentW.Checked then begin + + //exemple 1 load the JSON doc in memory + var LALJsonDocumentA := TALJSONDocumentA.Create; + try + LALJsonDocumentA.LoadFromBSONString(LBsonStr); + + var LJsonStr: AnsiString; + LALJsonDocumentA.SaveToJSONString(LJsonStr, [soNodeAutoIndent]); + MemoJSON.Lines.Text := String(LJSONStr); + finally + LALJsonDocumentA.Free; + end; + + //exemple 2 load the JSON doc in SAX MODE + TALJSONDocumentA.ParseBSONString( + LBsonStr, + //-- + procedure (Sender: TObject; const Path: AnsiString; const name: AnsiString; const Args: array of const; NodeSubType: TALJSONNodeSubType) + begin + case NodeSubType of + nstFloat: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + string(ALFloatToStrA(Args[0].VExtended^, ALDefaultFormatSettingsA))); + nstText: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + string(ansiString(Args[0].VAnsiString))); + nstObject: ; + nstArray: ; + nstObjectID: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + 'ObjectId("'+string(ALBinToHexA(ansiString(Args[0].VAnsiString)))+'")'); + nstBoolean: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + String(ALBoolToStrA(Args[0].VBoolean,'true','false'))); + nstDateTime: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + string(ALFormatDateTimeA('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', Args[0].VExtended^, ALDefaultFormatSettingsA))); + nstNull: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + 'null'); + nstRegEx: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + string(ansiString(Args[0].VAnsiString))); + nstBinary: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + 'BinData('+inttostr(Args[1].VInteger)+', "'+string(ansiString(ALBase64EncodeString(ansiString(Args[0].VAnsiString))))+'")'); + nstJavascript: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + string(ansiString(Args[0].VAnsiString))); + nstInt32: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + 'NumberInt('+inttostr(Args[0].VInteger)+')'); + nstTimestamp: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + 'Timestamp('+inttostr(int64(cardinal(Args[0].VInteger)))+', '+inttostr(int64(cardinal(Args[1].VInteger)))+')'); + nstInt64: MemoSaxModeEvents.Lines.Add('TEXT => ' + String(Path) + '=' + 'NumberLong('+inttostr(Args[0].VInt64^)+')'); + end; + end{onParseText}, + //-- + procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) + begin + MemoSaxModeEvents.Lines.Add('STARTOBJECT => ' + String(Name)); + end{onParseStartObject}, + //-- + procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) + begin + MemoSaxModeEvents.Lines.Add('ENDOBJECT => ' + String(Name)); + end{onParseEndObject}, + //-- + procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) + begin + MemoSaxModeEvents.Lines.Add('STARTARRAY => ' + String(Name)); + end{onParseStartArray}, + //-- + procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) + begin + MemoSaxModeEvents.Lines.Add('ENDARRAY => ' + String(Name)); + end{onParseEndArray}); + + end + + //Use the unicode String version of TALJSONDocument + else begin + + //exemple 1 load the JSON doc in memory + var LALJsonDocumentW := TALJSONDocumentW.Create; + try + LALJsonDocumentW.LoadFromBSONBytes(BytesOf(LBsonStr)); + + var LJsonStr: String; + LALJsonDocumentW.SaveToJSONString(LJsonStr, [soNodeAutoIndent]); + MemoJSON.Lines.Text := String(LJSONStr); + finally + LALJsonDocumentW.Free; + end; + + //exemple 2 load the JSON doc in SAX MODE + TALJSONDocumentW.ParseBSONBytes( + BytesOf(LBsonStr), + //-- + procedure (Sender: TObject; const Path: String; const name: String; const Args: array of const; NodeSubType: TALJSONNodeSubType) + begin + case NodeSubType of + nstFloat: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + ALFloatToStrW(Args[0].VExtended^, ALDefaultFormatSettingsW)); + nstText: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + String(Args[0].VUnicodeString)); + nstObject: ; + nstArray: ; + nstObjectID: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'ObjectId("'+string(Args[0].VUnicodeString)+'")'); + nstBoolean: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + ALBoolToStrW(Args[0].VBoolean,'true','false')); + nstDateTime: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + ALFormatDateTimeW('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', Args[0].VExtended^, ALDefaultFormatSettingsW)); + nstNull: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'null'); + nstRegEx: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + String(Args[0].VUnicodeString)); + nstBinary: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'BinData('+ALIntToStrW(Args[1].VInteger)+', "'+String(Args[0].VunicodeString)+'")'); + nstJavascript: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + String(Args[0].VUnicodeString)); + nstInt32: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'NumberInt('+ALIntToStrW(Args[0].VInteger)+')'); + nstTimestamp: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'Timestamp('+ALIntToStrW(int64(cardinal(Args[0].VInteger)))+', '+ALIntToStrW(int64(cardinal(Args[1].VInteger)))+')'); + nstInt64: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'NumberLong('+inttostr(Args[0].VInt64^)+')'); + end; + end{onParseText}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + MemoSaxModeEvents.Lines.Add('STARTOBJECT => ' + Name); + end{onParseStartObject}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + MemoSaxModeEvents.Lines.Add('ENDOBJECT => ' + Name); + end{onParseEndObject}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + MemoSaxModeEvents.Lines.Add('STARTARRAY => ' + Name); + end{onParseStartArray}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + MemoSaxModeEvents.Lines.Add('ENDARRAY => ' + Name); + end{onParseEndArray}); + + end; - end; end; {*****************************************************} @@ -388,31 +557,6 @@ procedure TForm1.BtnRunBenchmarkClick(Sender: TObject); end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _scrollAllNode(aNode: ISuperObject): Integer; overload; - Var LStack: Tstack; - Litem: ISuperObject; - begin - Result := 0; - LStack := Tstack.Create; - try - - for Litem in aNode do - LStack.Push(pointer(Litem)); - - While LStack.Count > 0 do begin - inc(result); - aNode := ISuperObject(LStack.Pop); - For Litem in ANode do - LStack.Push(pointer(Litem)); - end; - - finally - LStack.Free; - end; - - end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} function _scrollAllNode(aNode: TJSONValue): Integer; overload; Var LStack: Tstack; @@ -480,27 +624,27 @@ procedure TForm1.BtnRunBenchmarkClick(Sender: TObject); end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoTALJsonDocJSONBench(Count: integer); + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoTALJsonDocABench(Count: integer); begin //var LMemoryUsage := GetTotalMemoryAllocated; - var LALJsonDocument:= TALJSONDocumentA.Create; + var LALJsonDocumentA:= TALJSONDocumentA.Create; Try var LStopWatch := TstopWatch.StartNew; - LALJsonDocument.LoadFromJsonFile('..\sample.json'); + LALJsonDocumentA.LoadFromJsonFile('..\..\sample.json'); LStopWatch.Stop; chart1.Series[0].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Load (JSON)'); application.ProcessMessages; //---- - LALJsonDocument.Clear; + LALJsonDocumentA.ChildNodes.Clear; LStopWatch := TstopWatch.StartNew; - LALJsonDocument.LoadFromBsonFile('..\sample.bson'); + LALJsonDocumentA.LoadFromBsonFile('..\..\sample.bson'); LStopWatch.Stop; chart1.Series[0].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Load (BSON)'); application.ProcessMessages; //---- LStopWatch := TstopWatch.StartNew; - _scrollAllNode(LALJsonDocument.Node); + _scrollAllNode(LALJsonDocumentA); LStopWatch.Stop; chart1.Series[0].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Scroll all nodes'); application.ProcessMessages; @@ -509,62 +653,62 @@ procedure TForm1.BtnRunBenchmarkClick(Sender: TObject); //application.ProcessMessages; //---- for var I := 1 to count - 1 do - LALJsonDocument.Node.AddChild(ALLowerCase(ALRandomStrA(7))); + LALJsonDocumentA.AddChild(ALLowerCase(ALRandomStrA(7))); //---- LStopWatch := TstopWatch.StartNew; for var i := 1 to _iterationcount do - LALJsonDocument.Node.ChildNodes.FindNode(ALLowerCase(ALRandomStrA(7))); + LALJsonDocumentA.ChildNodes.FindNode(ALLowerCase(ALRandomStrA(7))); LStopWatch.Stop; chart1.Series[0].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Find (unsorted)'); application.ProcessMessages; //---- - LALJsonDocument.Options := LALJsonDocument.Options + [doSorted]; + LALJsonDocumentA.ChildNodes.SetSorted(True{Value}, true{Recurse}); LStopWatch := TstopWatch.StartNew; for var i := 1 to _iterationcount do - LALJsonDocument.Node.ChildNodes.FindNode(ALLowerCase(ALRandomStrA(7))); + LALJsonDocumentA.ChildNodes.FindNode(ALLowerCase(ALRandomStrA(7))); LStopWatch.Stop; chart1.Series[0].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Find (sorted)'); application.ProcessMessages; //---- LStopWatch := TStopWatch.StartNew; - LALJsonDocument.SaveToJsonFile(ALGetModulePathA + '~tmp.json'); + LALJsonDocumentA.SaveToJsonFile(ALGetModulePathW + '~tmp.json'); LStopWatch.Stop; - ALDeleteFile(ALGetModulePathA + '~tmp.json'); + Tfile.Delete(ALGetModulePathW + '~tmp.json'); chart1.Series[0].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Save (JSON)'); application.ProcessMessages; //---- LStopWatch := TStopWatch.StartNew; - LALJsonDocument.SaveToBsonFile(ALGetModulePathA + '~tmp.bson'); + LALJsonDocumentA.SaveToBsonFile(ALGetModulePathW + '~tmp.bson'); LStopWatch.Stop; - ALDeleteFile(ALGetModulePathA + '~tmp.bson'); + Tfile.Delete(ALGetModulePathW + '~tmp.bson'); chart1.Series[0].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Save (BSON)'); application.ProcessMessages; finally - LALJsonDocument.Free; + LALJsonDocumentA.Free; end; end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoTALJsonDocUJSONBench(Count: integer); + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoTALJsonDocWBench(Count: integer); begin //var LMemoryUsage := GetTotalMemoryAllocated; - var LALJsonDocument:= TALJSONDocumentW.Create; + var LALJsonDocumentW:= TALJSONDocumentW.Create; Try var LStopWatch := TstopWatch.StartNew; - LALJsonDocument.LoadFromJsonFile('..\sample.json'); + LALJsonDocumentW.LoadFromJsonFile('..\..\sample.json'); LStopWatch.Stop; chart1.Series[1].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Load (JSON)'); application.ProcessMessages; //---- - LALJsonDocument.Clear; + LALJsonDocumentW.ChildNodes.Clear; LStopWatch := TstopWatch.StartNew; - LALJsonDocument.LoadFromBsonFile('..\sample.bson'); + LALJsonDocumentW.LoadFromBsonFile('..\..\sample.bson'); LStopWatch.Stop; chart1.Series[1].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Load (BSON)'); application.ProcessMessages; //---- LStopWatch := TstopWatch.StartNew; - _scrollAllNode(LALJsonDocument.Node); + _scrollAllNode(LALJsonDocumentW); LStopWatch.Stop; chart1.Series[1].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Scroll all nodes'); application.ProcessMessages; @@ -573,38 +717,38 @@ procedure TForm1.BtnRunBenchmarkClick(Sender: TObject); //application.ProcessMessages; //---- for var I := 1 to count - 1 do - LALJsonDocument.Node.AddChild(ALLowerCase(ALRandomStrA(7))); + LALJsonDocumentW.AddChild(ALLowerCase(ALRandomStrW(7))); //---- LStopWatch := TstopWatch.StartNew; for var i := 1 to _iterationcount do - LALJsonDocument.Node.ChildNodes.FindNode(ALLowerCase(ALRandomStrA(7))); + LALJsonDocumentW.ChildNodes.FindNode(ALLowerCase(ALRandomStrW(7))); LStopWatch.Stop; chart1.Series[1].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Find (unsorted)'); application.ProcessMessages; //---- - LALJsonDocument.Options := LALJsonDocument.Options + [doSorted]; + LALJsonDocumentW.ChildNodes.SetSorted(True{Value}, true{Recurse}); LStopWatch := TstopWatch.StartNew; for var i := 1 to _iterationcount do - LALJsonDocument.Node.ChildNodes.FindNode(ALLowerCase(ALRandomStrA(7))); + LALJsonDocumentW.ChildNodes.FindNode(ALLowerCase(ALRandomStrW(7))); LStopWatch.Stop; chart1.Series[1].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Find (sorted)'); application.ProcessMessages; //---- LStopWatch := TStopWatch.StartNew; - LALJsonDocument.SaveToJsonFile(ALGetModulePathA + '~tmp.json'); + LALJsonDocumentW.SaveToJsonFile(ALGetModulePathW + '~tmp.json'); LStopWatch.Stop; - ALDeleteFile(ALGetModulePathA + '~tmp.json'); + Tfile.Delete(ALGetModulePathW + '~tmp.json'); chart1.Series[1].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Save (JSON)'); application.ProcessMessages; //---- LStopWatch := TStopWatch.StartNew; - LALJsonDocument.SaveToBsonFile(ALGetModulePathA + '~tmp.bson'); + LALJsonDocumentW.SaveToBsonFile(ALGetModulePathW + '~tmp.bson'); LStopWatch.Stop; - ALDeleteFile(ALGetModulePathA + '~tmp.bson'); + Tfile.Delete(ALGetModulePathW + '~tmp.bson'); chart1.Series[1].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Save (BSON)'); application.ProcessMessages; finally - LALJsonDocument.Free; + LALJsonDocumentW.Free; end; end; @@ -613,7 +757,7 @@ procedure TForm1.BtnRunBenchmarkClick(Sender: TObject); begin //var LMemoryUsage := GetTotalMemoryAllocated; var LStopWatch := TstopWatch.StartNew; - var LJSONValue:= TJSONObject.ParseJSONValue(TFile.ReadAllText('..\sample.json')); + var LJSONValue:= TJSONObject.ParseJSONValue(TFile.ReadAllText('..\..\sample.json')); Try LStopWatch.Stop; chart1.Series[2].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Load (JSON)'); @@ -631,7 +775,7 @@ procedure TForm1.BtnRunBenchmarkClick(Sender: TObject); //application.ProcessMessages; //---- for var I := 1 to count - 1 do - TJSONObject(LJSONValue).AddPair(ALLowerCase(ALRandomStrA(7)), ''); + TJSONObject(LJSONValue).AddPair(ALLowerCase(ALRandomStrW(7)), ''); //---- LStopWatch := TstopWatch.StartNew; for var i := 1 to _iterationcount do @@ -643,9 +787,9 @@ procedure TForm1.BtnRunBenchmarkClick(Sender: TObject); chart1.Series[2].AddY(0, 'Find (sorted)'); //----- LStopWatch := TStopWatch.StartNew; - TFile.WriteAllText(ALGetModulePathA + '~tmp.json', LJSONValue.ToString); + TFile.WriteAllText(ALGetModulePathW + '~tmp.json', LJSONValue.ToString); LStopWatch.Stop; - ALDeleteFile(ALGetModulePathA + '~tmp.json'); + Tfile.Delete(ALGetModulePathW + '~tmp.json'); chart1.Series[2].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Save (JSON)'); application.ProcessMessages; //---- @@ -661,7 +805,7 @@ procedure TForm1.BtnRunBenchmarkClick(Sender: TObject); begin //var LMemoryUsage := GetTotalMemoryAllocated; var LStopWatch := TstopWatch.StartNew; - var LJSONValue:= TdwsJSONValue.ParseFile('..\sample.json'); + var LJSONValue:= TdwsJSONValue.ParseFile('..\..\sample.json'); Try LStopWatch.Stop; chart1.Series[3].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Load (JSON)'); @@ -679,7 +823,7 @@ procedure TForm1.BtnRunBenchmarkClick(Sender: TObject); //application.ProcessMessages; //---- for var I := 1 to count - 1 do - TdwsJSONObject(LJSONValue).AddValue(ALLowerCase(ALRandomStrA(7)), ''); + TdwsJSONObject(LJSONValue).AddValue(ALLowerCase(ALRandomStrW(7)), ''); //---- LStopWatch := TstopWatch.StartNew; for var i := 1 to _iterationcount do @@ -691,9 +835,9 @@ procedure TForm1.BtnRunBenchmarkClick(Sender: TObject); chart1.Series[3].AddY(0, 'Find (sorted)'); //---- LStopWatch := TStopWatch.StartNew; - TFile.WriteAllText(ALGetModulePathA + '~tmp.json', LJSONValue.ToString); + TFile.WriteAllText(ALGetModulePathW + '~tmp.json', LJSONValue.ToString); LStopWatch.Stop; - ALDeleteFile(ALGetModulePathA + '~tmp.json'); + Tfile.Delete(ALGetModulePathW + '~tmp.json'); chart1.Series[3].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Save (JSON)'); application.ProcessMessages; //---- @@ -704,160 +848,95 @@ procedure TForm1.BtnRunBenchmarkClick(Sender: TObject); end; end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoSuperObjectBench(Count: integer); - begin - //var LMemoryUsage := GetTotalMemoryAllocated; - var LStopWatch := TstopWatch.StartNew; - var Lobj := TSuperObject.ParseFile('..\sample.json', false); - LStopWatch.Stop; - chart1.Series[4].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Load (JSON)'); - application.ProcessMessages; - //----- - chart1.Series[4].AddY(0, 'Load (BSON)'); - //----- - LStopWatch := TstopWatch.StartNew; - _scrollAllNode(Lobj); - LStopWatch.Stop; - chart1.Series[4].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'scroll all nodes'); - application.ProcessMessages; - //---- - //MemoMemoryUsed.Lines.Add('SuperObject: ' + FormatFloat('0,',(GetTotalMemoryAllocated - LMemoryUsage)) + ' bytes'); - //application.ProcessMessages; - //---- - for var I := 1 to count - 1 do - Lobj.S[ALLowerCase(ALRandomStrA(7))] := ''; - //---- - LStopWatch := TstopWatch.StartNew; - for var i := 1 to _iterationcount do - Lobj[AlLowerCase(ALRandomStrW(7))]; - LStopWatch.Stop; - chart1.Series[4].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Find (unsorted)'); - application.ProcessMessages; - //---- - chart1.Series[4].AddY(0, 'Find (sorted)'); - //---- - LStopWatch := TStopWatch.StartNew; - Lobj.SaveTo(string(ALGetModulePathA) + '~tmp.json'); - LStopWatch.Stop; - ALDeleteFile(ALGetModulePathA + '~tmp.json'); - chart1.Series[4].AddY(LStopWatch.Elapsed.TotalMilliseconds, 'Save (JSON)'); - application.ProcessMessages; - //---- - chart1.Series[4].AddY(0, 'Save (BSON)'); - application.ProcessMessages; - end; - begin chart1.Series[0].Clear; chart1.Series[1].Clear; chart1.Series[2].Clear; chart1.Series[3].Clear; - chart1.Series[4].Clear; - if CheckBoxTALJsonDocJSON.Checked then _DoTALJsonDocJSONBench(StrToInt(SpinEditNbItems.Text)); - if CheckBoxTALJsonDocUJSON.Checked then _DoTALJsonDocUJSONBench(StrToInt(SpinEditNbItems.Text)); + if CheckBoxTALJsonDocJSON.Checked then _DoTALJsonDocABench(StrToInt(SpinEditNbItems.Text)); + if CheckBoxTALJsonDocUJSON.Checked then _DoTALJsonDocWBench(StrToInt(SpinEditNbItems.Text)); if CheckBoxSystemJSON.Checked then _DoSystemJSONBench(StrToInt(SpinEditNbItems.Text)); if CheckBoxdwsJSON.Checked then _DodwsJSONBench(StrToInt(SpinEditNbItems.Text)); - if CheckBoxSuperObject.Checked then _DoSuperObjectBench(StrToInt(SpinEditNbItems.Text)); end; -{*********************************************} -procedure TForm1.Button1Click(Sender: TObject); -var LBsonStr: AnsiString; - LALJsonDocument: TALJSONDocumentA; - LALJsonDocumentU: TALJSONDocumentW; - i: integer; -begin - LBsonStr := ''; - for I := 0 to MemoBSON.Lines.Count - 1 do - LBsonStr := LBsonStr + AnsiChar(StrToInt(MemoBSON.Lines[i])); - MemoJSON.Lines.Clear; - MemoSaxModeEvents.lines.clear; - - if messageDlg('Use unicode version of TalJsonDoc (ie: TalJsonDocU)?', mtConfirmation, [TMsgDlgBtn.mbNo, TMsgDlgBtn.mbYes], 0) = MrNo then begin +{**********************************************************} +procedure TForm1.BtnMemoryConsumptionClick(Sender: TObject); - //exemple 1 load the JSON doc in memory - LALJsonDocument := TALJSONDocumentA.Create; - try - LALJsonDocument.LoadFromBSONString(LBsonStr); - LALJsonDocument.Options := [doNodeAutoIndent]; - MemoJSON.Lines.Text := String(LALJsonDocument.JSON); + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoTALJsonDocABench(Count: integer); + begin + var LMemoryUsage := GetTotalMemoryAllocated; + var LALJsonDocumentA:= TALJSONDocumentA.Create; + Try + LALJsonDocumentA.LoadFromJsonFile('..\..\sample.json'); + for var i := 1 to 2000000 do + LALJsonDocumentA.AddChild('qsdkqlskdjqsdlkqs').Text := 'sdoijsodifsqsmdlqsdmlqmsdlqmsldmqsld'; + chart1.Series[0].AddY(GetTotalMemoryAllocated - LMemoryUsage, 'Memory consumption'); + application.ProcessMessages; finally - LALJsonDocument.Free; + LALJsonDocumentA.Free; end; + end; - //exemple 2 load the JSON doc in SAX MODE - LALJsonDocument := TALJSONDocumentA.Create; - try - LALJsonDocument.onParseText := procedure (Sender: TObject; const Path: AnsiString; const name: AnsiString; const Args: array of const; NodeSubType: TALJSONNodeSubType) - begin - case NodeSubType of - nstFloat: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + string(ALFloatToStrA(Args[0].VExtended^, ALDefaultFormatSettingsA))); - nstText: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + string(ansiString(Args[0].VAnsiString))); - nstObject: ; - nstArray: ; - nstObjectID: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + 'ObjectId("'+string(ALBinToHexA(ansiString(Args[0].VAnsiString)))+'")'); - nstBoolean: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + String(ALBoolToStrA(Args[0].VBoolean,'true','false'))); - nstDateTime: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + string(ALFormatDateTimeA('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', Args[0].VExtended^, ALDefaultFormatSettingsA))); - nstNull: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + 'null'); - nstRegEx: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + string(ansiString(Args[0].VAnsiString))); - nstBinary: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + 'BinData('+inttostr(Args[1].VInteger)+', "'+string(ansiString(ALBase64EncodeString(ansiString(Args[0].VAnsiString))))+'")'); - nstJavascript: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + string(ansiString(Args[0].VAnsiString))); - nstInt32: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + 'NumberInt('+inttostr(Args[0].VInteger)+')'); - nstTimestamp: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + 'Timestamp('+inttostr(int64(cardinal(Args[0].VInteger)))+', '+inttostr(int64(cardinal(Args[1].VInteger)))+')'); - nstInt64: MemoSaxModeEvents.Lines.Add(String(Path) + '=' + 'NumberLong('+inttostr(Args[0].VInt64^)+')'); - end; - end; - LALJsonDocument.LoadFromBSONString(LBsonStr, true{saxMode}); + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoTALJsonDocWBench(Count: integer); + begin + var LMemoryUsage := GetTotalMemoryAllocated; + var LALJsonDocumentW:= TALJSONDocumentW.Create; + Try + LALJsonDocumentW.LoadFromJsonFile('..\..\sample.json'); + for var i := 1 to 2000000 do + LALJsonDocumentW.AddChild('qsdkqlskdjqsdlkqs').Text := 'sdoijsodifsqsmdlqsdmlqmsdlqmsldmqsld'; + chart1.Series[1].AddY(GetTotalMemoryAllocated - LMemoryUsage, 'Memory consumption'); + application.ProcessMessages; finally - LALJsonDocument.Free; + LALJsonDocumentW.Free; end; + end; - end - else begin - - - //exemple 1 load the JSON doc in memory - LALJsonDocumentU := TALJSONDocumentW.Create; - try - LALJsonDocumentU.LoadFromBSONBytes(BytesOf(LBsonStr)); - LALJsonDocumentU.Options := [doNodeAutoIndent]; - MemoJSON.Lines.Text := String(LALJsonDocumentU.JSON); + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoSystemJSONBench(Count: integer); + begin + var LMemoryUsage := GetTotalMemoryAllocated; + var LJSONValue:= TJSONObject.ParseJSONValue(TFile.ReadAllText('..\..\sample.json')) as TJSONObject; + Try + for var i := 1 to 2000000 do + LJSONValue.AddPair('qsdkqlskdjqsdlkqs', 'sdoijsodifsqsmdlqsdmlqmsdlqmsldmqsld'); + chart1.Series[2].AddY(GetTotalMemoryAllocated - LMemoryUsage, 'Memory consumption'); + application.ProcessMessages; finally - LALJsonDocumentU.Free; + LJSONValue.Free; end; + end; - //exemple 2 load the JSON doc in SAX MODE - LALJsonDocumentU := TALJSONDocumentW.Create; - try - LALJsonDocumentU.onParseText := procedure (Sender: TObject; const Path: String; const name: String; const Args: array of const; NodeSubType: TALJSONNodeSubType) - begin - case NodeSubType of - nstFloat: MemoSaxModeEvents.Lines.Add(Path + '=' + ALFloatToStrW(Args[0].VExtended^, ALDefaultFormatSettingsW)); - nstText: MemoSaxModeEvents.Lines.Add(Path + '=' + String(Args[0].VUnicodeString)); - nstObject: ; - nstArray: ; - nstObjectID: MemoSaxModeEvents.Lines.Add(Path + '=' + 'ObjectId("'+String(Args[0].VUnicodeString)+'")'); - nstBoolean: MemoSaxModeEvents.Lines.Add(Path + '=' + ALBoolToStrW(Args[0].VBoolean,'true','false')); - nstDateTime: MemoSaxModeEvents.Lines.Add(Path + '=' + ALFormatDateTimeW('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', Args[0].VExtended^, ALDefaultFormatSettingsW)); - nstNull: MemoSaxModeEvents.Lines.Add(Path + '=' + 'null'); - nstRegEx: MemoSaxModeEvents.Lines.Add(Path + '=' + String(Args[0].VUnicodeString)); - nstBinary: MemoSaxModeEvents.Lines.Add(Path + '=' + 'BinData('+ALIntToStrW(Args[1].VInteger)+', "'+String(Args[0].VunicodeString)+'")'); - nstJavascript: MemoSaxModeEvents.Lines.Add(Path + '=' + String(Args[0].VUnicodeString)); - nstInt32: MemoSaxModeEvents.Lines.Add(Path + '=' + 'NumberInt('+ALIntToStrW(Args[0].VInteger)+')'); - nstTimestamp: MemoSaxModeEvents.Lines.Add(Path + '=' + 'Timestamp('+ALIntToStrW(int64(cardinal(Args[0].VInteger)))+', '+ALIntToStrW(int64(cardinal(Args[1].VInteger)))+')'); - nstInt64: MemoSaxModeEvents.Lines.Add(Path + '=' + 'NumberLong('+inttostr(Args[0].VInt64^)+')'); - end; - end; - LALJsonDocumentU.LoadFromBSONBytes(BytesOf(LBsonStr), true{saxMode}); + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DodwsJSONBench(Count: integer); + begin + var LMemoryUsage := GetTotalMemoryAllocated; + var LJSONValue:= TdwsJSONValue.ParseFile('..\..\sample.json') as TdwsJSONObject; + Try + chart1.Series[3].AddY(GetTotalMemoryAllocated - LMemoryUsage, 'Memory consumption'); + for var i := 1 to 2000000 do + LJSONValue.AddValue('qsdkqlskdjqsdlkqs', 'sdoijsodifsqsmdlqsdmlqmsdlqmsldmqsld'); + application.ProcessMessages; finally - LALJsonDocumentU.Free; + LJSONValue.Free; end; - end; +begin + + chart1.Series[0].Clear; + chart1.Series[1].Clear; + chart1.Series[2].Clear; + chart1.Series[3].Clear; + if CheckBoxTALJsonDocJSON.Checked then _DoTALJsonDocABench(StrToInt(SpinEditNbItems.Text)); + if CheckBoxTALJsonDocUJSON.Checked then _DoTALJsonDocWBench(StrToInt(SpinEditNbItems.Text)); + if CheckBoxSystemJSON.Checked then _DoSystemJSONBench(StrToInt(SpinEditNbItems.Text)); + if CheckBoxdwsJSON.Checked then _DodwsJSONBench(StrToInt(SpinEditNbItems.Text)); + end; initialization diff --git a/Embarcadero/_Demos/RSP-42011-performance-issue-comparing-equality-between-two-strings/Project1.dpr b/Embarcadero/_Demos/RSP-42011-performance-issue-comparing-equality-between-two-strings/Project1.dpr new file mode 100644 index 000000000..4faa3fe4a --- /dev/null +++ b/Embarcadero/_Demos/RSP-42011-performance-issue-comparing-equality-between-two-strings/Project1.dpr @@ -0,0 +1,44 @@ +program Project1; + +{$APPTYPE CONSOLE} + +{$R *.res} + +uses + system.Diagnostics, + System.SysUtils; + +begin + try + + {$IF not defined(WIN64)} + writeln('Please run in Win64 Release'); + writeln(''); + {$ENDIF} + var SA1: ansiString := 'qsmldkqsdpoqsdkpqsokdqspodkjqsi'; + var SA2: ansiString := 'mlqskdqmslkdqsmldqsmldk'; + + var LStopWatch := TstopWatch.StartNew; + for var I := 1 to 1000000000 do + if SA1 = SA2 then + raise Exception.Create('Error FCE2EBFC-C72F-488A-A919-A6BB12C91DA1'); + LStopWatch.Stop; + writeln('AnsiString string comparaison: ' + FloatToStr(LStopWatch.Elapsed.TotalMilliseconds) + ' ms'); + + var SU1: String := 'qsmldkqsdpoqsdkpqsokdqspodkjqsi'; + var SU2: String := 'mlqskdqmslkdqsmldqsmldk'; + LStopWatch := TstopWatch.StartNew; + for var I := 1 to 1000000000 do + if SU1 = SU2 then + raise Exception.Create('Error FCE2EBFC-C72F-488A-A919-A6BB12C91DA1'); + LStopWatch.Stop; + writeln('UnicodeString string comparaison: ' + FloatToStr(LStopWatch.Elapsed.TotalMilliseconds) + ' ms'); + + writeln('AnsiString or UnicodeString comparaison must be equal in speed'); + readln; + + except + on E: Exception do + Writeln(E.ClassName, ': ', E.Message); + end; +end. diff --git a/Embarcadero/_Demos/RSP-42011-performance-issue-comparing-equality-between-two-strings/Project1.dproj b/Embarcadero/_Demos/RSP-42011-performance-issue-comparing-equality-between-two-strings/Project1.dproj new file mode 100644 index 000000000..6179574e1 --- /dev/null +++ b/Embarcadero/_Demos/RSP-42011-performance-issue-comparing-equality-between-two-strings/Project1.dproj @@ -0,0 +1,225 @@ + + + {322E32A7-D481-40D6-885C-CFE7E0F5EA3E} + 19.5 + None + True + Release + Win64 + 3 + Console + Project1.dpr + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + Project1 + + + fmx;DbxCommonDriver;bindengine;IndyIPCommon;emsclient;IndyProtocols;dbxcds;FmxTeeUI;FireDACSqliteDriver;DbxClientDriver;soapmidas;dbexpress;inet;FireDACDBXDriver;CustomIPTransport;IndySystem;ibxbindings;FireDACCommon;bindcompdbx;rtl;DBXSqliteDriver;DataSnapFireDAC;FireDAC;xmlrtl;ibxpress;dsnap;DataSnapNativeClient;FireDACCommonDriver;IndyIPClient;bindcompfmx;ibmonitor;fmxFireDAC;DataSnapCommon;fmxase;dbrtl;DBXInterBaseDriver;bindcomp;IndyCore;RESTBackendComponents;RESTComponents;IndyIPServer;dsnapxml;DataSnapClient;DataSnapProviderClient;emsclientfiredac;FireDACDSDriver;tethering;CloudService;FMXTee;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_192x192.png + $(BDS)\bin\Artwork\Android\FM_SplashImage_426x320.png + $(BDS)\bin\Artwork\Android\FM_SplashImage_470x320.png + $(BDS)\bin\Artwork\Android\FM_SplashImage_640x480.png + $(BDS)\bin\Artwork\Android\FM_SplashImage_960x720.png + $(BDS)\bin\Artwork\Android\FM_NotificationIcon_24x24.png + $(BDS)\bin\Artwork\Android\FM_NotificationIcon_36x36.png + $(BDS)\bin\Artwork\Android\FM_NotificationIcon_48x48.png + $(BDS)\bin\Artwork\Android\FM_NotificationIcon_72x72.png + $(BDS)\bin\Artwork\Android\FM_NotificationIcon_96x96.png + activity-1.1.0.dex.jar;annotation-1.2.0.dex.jar;appcompat-1.2.0.dex.jar;appcompat-resources-1.2.0.dex.jar;asynclayoutinflater-1.0.0.dex.jar;billing-4.0.0.dex.jar;biometric-1.1.0.dex.jar;browser-1.0.0.dex.jar;cloud-messaging.dex.jar;collection-1.1.0.dex.jar;coordinatorlayout-1.0.0.dex.jar;core-1.5.0-rc02.dex.jar;core-common-2.1.0.dex.jar;core-runtime-2.1.0.dex.jar;cursoradapter-1.0.0.dex.jar;customview-1.0.0.dex.jar;documentfile-1.0.0.dex.jar;drawerlayout-1.0.0.dex.jar;firebase-annotations-16.0.0.dex.jar;firebase-common-20.0.0.dex.jar;firebase-components-17.0.0.dex.jar;firebase-datatransport-18.0.0.dex.jar;firebase-encoders-17.0.0.dex.jar;firebase-encoders-json-18.0.0.dex.jar;firebase-iid-interop-17.1.0.dex.jar;firebase-installations-17.0.0.dex.jar;firebase-installations-interop-17.0.0.dex.jar;firebase-measurement-connector-19.0.0.dex.jar;firebase-messaging-22.0.0.dex.jar;fmx.dex.jar;fragment-1.2.5.dex.jar;google-play-licensing.dex.jar;interpolator-1.0.0.dex.jar;javax.inject-1.dex.jar;legacy-support-core-ui-1.0.0.dex.jar;legacy-support-core-utils-1.0.0.dex.jar;lifecycle-common-2.2.0.dex.jar;lifecycle-livedata-2.0.0.dex.jar;lifecycle-livedata-core-2.2.0.dex.jar;lifecycle-runtime-2.2.0.dex.jar;lifecycle-service-2.0.0.dex.jar;lifecycle-viewmodel-2.2.0.dex.jar;lifecycle-viewmodel-savedstate-2.2.0.dex.jar;listenablefuture-1.0.dex.jar;loader-1.0.0.dex.jar;localbroadcastmanager-1.0.0.dex.jar;play-services-ads-20.1.0.dex.jar;play-services-ads-base-20.1.0.dex.jar;play-services-ads-identifier-17.0.0.dex.jar;play-services-ads-lite-20.1.0.dex.jar;play-services-base-17.5.0.dex.jar;play-services-basement-17.6.0.dex.jar;play-services-cloud-messaging-16.0.0.dex.jar;play-services-drive-17.0.0.dex.jar;play-services-games-21.0.0.dex.jar;play-services-location-18.0.0.dex.jar;play-services-maps-17.0.1.dex.jar;play-services-measurement-base-18.0.0.dex.jar;play-services-measurement-sdk-api-18.0.0.dex.jar;play-services-places-placereport-17.0.0.dex.jar;play-services-stats-17.0.0.dex.jar;play-services-tasks-17.2.0.dex.jar;print-1.0.0.dex.jar;room-common-2.1.0.dex.jar;room-runtime-2.1.0.dex.jar;savedstate-1.0.0.dex.jar;slidingpanelayout-1.0.0.dex.jar;sqlite-2.0.1.dex.jar;sqlite-framework-2.0.1.dex.jar;swiperefreshlayout-1.0.0.dex.jar;transport-api-3.0.0.dex.jar;transport-backend-cct-3.0.0.dex.jar;transport-runtime-3.0.0.dex.jar;user-messaging-platform-1.0.0.dex.jar;vectordrawable-1.1.0.dex.jar;vectordrawable-animated-1.1.0.dex.jar;versionedparcelable-1.1.1.dex.jar;viewpager-1.0.0.dex.jar;work-runtime-2.1.0.dex.jar + + + fmx;DbxCommonDriver;bindengine;IndyIPCommon;emsclient;IndyProtocols;dbxcds;FmxTeeUI;FireDACSqliteDriver;DbxClientDriver;soapmidas;dbexpress;inet;FireDACDBXDriver;CustomIPTransport;IndySystem;ibxbindings;FireDACCommon;bindcompdbx;rtl;DBXSqliteDriver;DataSnapFireDAC;FireDAC;xmlrtl;ibxpress;dsnap;DataSnapNativeClient;FireDACCommonDriver;IndyIPClient;bindcompfmx;ibmonitor;fmxFireDAC;DataSnapCommon;dbrtl;DBXInterBaseDriver;bindcomp;IndyCore;RESTBackendComponents;RESTComponents;IndyIPServer;dsnapxml;DataSnapClient;DataSnapProviderClient;emsclientfiredac;FireDACDSDriver;tethering;CloudService;FMXTee;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_192x192.png + $(BDS)\bin\Artwork\Android\FM_SplashImage_426x320.png + $(BDS)\bin\Artwork\Android\FM_SplashImage_470x320.png + $(BDS)\bin\Artwork\Android\FM_SplashImage_640x480.png + $(BDS)\bin\Artwork\Android\FM_SplashImage_960x720.png + $(BDS)\bin\Artwork\Android\FM_NotificationIcon_24x24.png + $(BDS)\bin\Artwork\Android\FM_NotificationIcon_36x36.png + $(BDS)\bin\Artwork\Android\FM_NotificationIcon_48x48.png + $(BDS)\bin\Artwork\Android\FM_NotificationIcon_72x72.png + $(BDS)\bin\Artwork\Android\FM_NotificationIcon_96x96.png + activity-1.1.0.dex.jar;annotation-1.2.0.dex.jar;appcompat-1.2.0.dex.jar;appcompat-resources-1.2.0.dex.jar;asynclayoutinflater-1.0.0.dex.jar;billing-4.0.0.dex.jar;biometric-1.1.0.dex.jar;browser-1.0.0.dex.jar;cloud-messaging.dex.jar;collection-1.1.0.dex.jar;coordinatorlayout-1.0.0.dex.jar;core-1.5.0-rc02.dex.jar;core-common-2.1.0.dex.jar;core-runtime-2.1.0.dex.jar;cursoradapter-1.0.0.dex.jar;customview-1.0.0.dex.jar;documentfile-1.0.0.dex.jar;drawerlayout-1.0.0.dex.jar;firebase-annotations-16.0.0.dex.jar;firebase-common-20.0.0.dex.jar;firebase-components-17.0.0.dex.jar;firebase-datatransport-18.0.0.dex.jar;firebase-encoders-17.0.0.dex.jar;firebase-encoders-json-18.0.0.dex.jar;firebase-iid-interop-17.1.0.dex.jar;firebase-installations-17.0.0.dex.jar;firebase-installations-interop-17.0.0.dex.jar;firebase-measurement-connector-19.0.0.dex.jar;firebase-messaging-22.0.0.dex.jar;fmx.dex.jar;fragment-1.2.5.dex.jar;google-play-licensing.dex.jar;interpolator-1.0.0.dex.jar;javax.inject-1.dex.jar;legacy-support-core-ui-1.0.0.dex.jar;legacy-support-core-utils-1.0.0.dex.jar;lifecycle-common-2.2.0.dex.jar;lifecycle-livedata-2.0.0.dex.jar;lifecycle-livedata-core-2.2.0.dex.jar;lifecycle-runtime-2.2.0.dex.jar;lifecycle-service-2.0.0.dex.jar;lifecycle-viewmodel-2.2.0.dex.jar;lifecycle-viewmodel-savedstate-2.2.0.dex.jar;listenablefuture-1.0.dex.jar;loader-1.0.0.dex.jar;localbroadcastmanager-1.0.0.dex.jar;play-services-ads-20.1.0.dex.jar;play-services-ads-base-20.1.0.dex.jar;play-services-ads-identifier-17.0.0.dex.jar;play-services-ads-lite-20.1.0.dex.jar;play-services-base-17.5.0.dex.jar;play-services-basement-17.6.0.dex.jar;play-services-cloud-messaging-16.0.0.dex.jar;play-services-drive-17.0.0.dex.jar;play-services-games-21.0.0.dex.jar;play-services-location-18.0.0.dex.jar;play-services-maps-17.0.1.dex.jar;play-services-measurement-base-18.0.0.dex.jar;play-services-measurement-sdk-api-18.0.0.dex.jar;play-services-places-placereport-17.0.0.dex.jar;play-services-stats-17.0.0.dex.jar;play-services-tasks-17.2.0.dex.jar;print-1.0.0.dex.jar;room-common-2.1.0.dex.jar;room-runtime-2.1.0.dex.jar;savedstate-1.0.0.dex.jar;slidingpanelayout-1.0.0.dex.jar;sqlite-2.0.1.dex.jar;sqlite-framework-2.0.1.dex.jar;swiperefreshlayout-1.0.0.dex.jar;transport-api-3.0.0.dex.jar;transport-backend-cct-3.0.0.dex.jar;transport-runtime-3.0.0.dex.jar;user-messaging-platform-1.0.0.dex.jar;vectordrawable-1.1.0.dex.jar;vectordrawable-animated-1.1.0.dex.jar;versionedparcelable-1.1.1.dex.jar;viewpager-1.0.0.dex.jar;work-runtime-2.1.0.dex.jar + + + fmx;DbxCommonDriver;bindengine;IndyIPCommon;emsclient;IndyProtocols;dbxcds;FmxTeeUI;FireDACSqliteDriver;DbxClientDriver;soapmidas;dbexpress;inet;FireDACDBXDriver;CustomIPTransport;IndySystem;ibxbindings;FireDACCommon;bindcompdbx;rtl;DBXSqliteDriver;DataSnapFireDAC;FireDAC;xmlrtl;ibxpress;dsnap;DataSnapNativeClient;FireDACCommonDriver;IndyIPClient;bindcompfmx;ibmonitor;fmxFireDAC;DataSnapCommon;fmxase;dbrtl;DBXInterBaseDriver;bindcomp;IndyCore;RESTBackendComponents;RESTComponents;IndyIPServer;dsnapxml;DataSnapClient;DataSnapProviderClient;emsclientfiredac;FireDACDSDriver;tethering;CloudService;FMXTee;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + + + fmx;DbxCommonDriver;bindengine;IndyIPCommon;emsclient;IndyProtocols;dbxcds;FmxTeeUI;FireDACSqliteDriver;DbxClientDriver;soapmidas;dbexpress;inet;FireDACDBXDriver;CustomIPTransport;IndySystem;ibxbindings;FireDACCommon;bindcompdbx;rtl;DBXSqliteDriver;DataSnapFireDAC;FireDAC;xmlrtl;ibxpress;dsnap;DataSnapNativeClient;FireDACCommonDriver;IndyIPClient;bindcompfmx;ibmonitor;fmxFireDAC;DataSnapCommon;fmxase;dbrtl;DBXInterBaseDriver;bindcomp;IndyCore;RESTBackendComponents;RESTComponents;IndyIPServer;dsnapxml;DataSnapClient;DataSnapProviderClient;emsclientfiredac;FireDACDSDriver;tethering;CloudService;FMXTee;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + + + DataSnapServer;fmx;DbxCommonDriver;bindengine;FireDACCommonODBC;emsclient;IndyProtocols;dbxcds;FireDACSqliteDriver;DbxClientDriver;soapmidas;dbexpress;inet;CustomIPTransport;FireDACMSSQLDriver;IndySystem;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;emsserverresource;rtl;FireDACMySQLDriver;DataSnapFireDAC;FireDAC;xmlrtl;dsnap;FireDACDb2Driver;DataSnapNativeClient;DatasnapConnectorsFreePascal;emshosting;FireDACCommonDriver;emsedge;inetdb;FireDACASADriver;FireDACInfxDriver;DataSnapCommon;dbrtl;FireDACOracleDriver;DataSnapIndy10ServerTransport;DataSnapConnectors;FireDACMongoDBDriver;FireDACTDataDriver;bindcomp;IndyCore;RESTBackendComponents;FireDACADSDriver;RESTComponents;dsnapxml;DataSnapClient;emsclientfiredac;FireDACPgDriver;CloudService;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + + + DataSnapServer;fmx;DbxCommonDriver;bindengine;IndyIPCommon;FireDACCommonODBC;emsclient;IndyProtocols;dbxcds;FmxTeeUI;DBXFirebirdDriver;FireDACSqliteDriver;DbxClientDriver;soapmidas;dbexpress;inet;FireDACDBXDriver;fmxdae;CustomIPTransport;FireDACMSSQLDriver;IndySystem;ibxbindings;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;bindcompdbx;rtl;FireDACMySQLDriver;DBXSqliteDriver;DataSnapFireDAC;inetdbxpress;FireDAC;xmlrtl;ibxpress;dsnap;DBXOracleDriver;DBXInformixDriver;fmxobj;DataSnapNativeClient;FireDACCommonDriver;IndyIPClient;bindcompfmx;inetdb;ibmonitor;FireDACASADriver;fmxFireDAC;DBXMySQLDriver;DataSnapCommon;fmxase;dbrtl;FireDACOracleDriver;DataSnapIndy10ServerTransport;DBXInterBaseDriver;FireDACMongoDBDriver;FireDACTDataDriver;bindcomp;IndyCore;RESTBackendComponents;RESTComponents;IndyIPServer;dsnapxml;DataSnapClient;DataSnapProviderClient;emsclientfiredac;FireDACPgDriver;FireDACDSDriver;tethering;CloudService;DBXSybaseASADriver;FMXTee;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + true + + + DataSnapServer;fmx;DbxCommonDriver;bindengine;IndyIPCommon;FireDACCommonODBC;emsclient;IndyProtocols;dbxcds;FmxTeeUI;DBXFirebirdDriver;FireDACSqliteDriver;DbxClientDriver;soapmidas;dbexpress;inet;FireDACDBXDriver;fmxdae;CustomIPTransport;FireDACMSSQLDriver;IndySystem;ibxbindings;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;bindcompdbx;rtl;FireDACMySQLDriver;DBXSqliteDriver;DataSnapFireDAC;inetdbxpress;FireDAC;xmlrtl;ibxpress;dsnap;DBXOracleDriver;DBXInformixDriver;fmxobj;DataSnapNativeClient;FireDACCommonDriver;IndyIPClient;bindcompfmx;inetdb;ibmonitor;FireDACASADriver;fmxFireDAC;DBXMySQLDriver;DataSnapCommon;fmxase;dbrtl;FireDACOracleDriver;DataSnapIndy10ServerTransport;DBXInterBaseDriver;FireDACMongoDBDriver;FireDACTDataDriver;bindcomp;IndyCore;RESTBackendComponents;RESTComponents;IndyIPServer;dsnapxml;DataSnapClient;DataSnapProviderClient;emsclientfiredac;FireDACPgDriver;FireDACDSDriver;tethering;CloudService;DBXSybaseASADriver;FMXTee;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + true + + + dxPSdxSpreadSheetLnkRS28;vclwinx;DataSnapServer;fmx;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;DBXMSSQLDriver;FireDACCommonODBC;emsclient;cxExportRS28;dxHttpIndyRequestRS28;appanalytics;IndyProtocols;vclx;dxTileControlRS28;dxPSdxDBOCLnkRS28;dbxcds;vcledge;dxPSPrVwRibbonRS28;cxPivotGridOLAPRS28;FmxTeeUI;dxGDIPlusRS28;DBXFirebirdDriver;dxCoreRS28;cxPivotGridRS28;dxPSCoreRS28;FireDACSqliteDriver;DbxClientDriver;dxSpreadSheetRS28;dxSkinsCoreRS28;soapmidas;dxBarRS28;TeeUI;dxADOServerModeRS28;dxWizardControlRS28;dbexpress;inet;dxServerModeRS28;vcltouch;cxTreeListRS28;dxBarDBNavRS28;FireDACDBXDriver;fmxdae;dxPScxCommonRS28;dxNavBarRS28;CustomIPTransport;FireDACMSSQLDriver;dxSpreadSheetReportDesignerRS28;dxFireDACEMFRS28;dxComnRS28;dxFlowChartDesignerRS28;IndySystem;cxVerticalGridRS28;ibxbindings;dxmdsRS28;dxRichEditControlRS28;cxSchedulerGridRS28;dxPSdxOCLnkRS28;dxPScxSchedulerLnkRS28;dxPsPrVwAdvRS28;vclFireDAC;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;emsserverresource;dxADOEMFRS28;dxRibbonCustomizationFormRS28;dxPSdxDBTVLnkRS28;bindcompdbx;dxGaugeControlRS28;rtl;FireDACMySQLDriver;dxDockingRS28;dxPDFViewerRS28;DBXSqliteDriver;dxBarExtItemsRS28;dxPSdxFCLnkRS28;dxorgcRS28;DBXSybaseASEDriver;dxSpreadSheetCoreConditionalFormattingDialogsRS28;dxPSRichEditControlLnkRS28;vclimg;DataSnapFireDAC;inetdbxpress;FireDAC;xmlrtl;ibxpress;dsnap;FireDACDb2Driver;cxSchedulerRibbonStyleEventEditorRS28;DBXOracleDriver;dxPScxTLLnkRS28;DBXInformixDriver;vclib;fmxobj;bindcompvclsmp;DataSnapNativeClient;dxFlowChartRS28;dxPScxPCProdRS28;DatasnapConnectorsFreePascal;emshosting;dxRichEditDocumentModelRS28;dxPSdxMapControlLnkRS28;cxGridEMFRS28;dxGanttControlRS28;dxPScxVGridLnkRS28;dxPScxPivotGridLnkRS28;FireDACCommonDriver;IndyIPClient;dxCloudServiceLibraryRS28;cxLibraryRS28;bindcompvclwinx;emsedge;bindcompfmx;dxPSdxPDFViewerLnkRS28;inetdb;dxSpreadSheetCoreRS28;cxSchedulerTreeBrowserRS28;ibmonitor;FireDACASADriver;dxTabbedMDIRS28;Tee;vclactnband;fmxFireDAC;dxFireDACServerModeRS28;FireDACInfxDriver;DBXMySQLDriver;VclSmp;dxPSdxLCLnkRS28;DataSnapCommon;fmxase;dxdbtrRS28;DBXOdbcDriver;dbrtl;FireDACOracleDriver;dxPSLnksRS28;TeeDB;FireDACMSAccDriver;DataSnapIndy10ServerTransport;DataSnapConnectors;dxChartControlRS28;vcldsnap;DBXInterBaseDriver;FireDACMongoDBDriver;dxSpreadSheetConditionalFormattingDialogsRS28;FireDACTDataDriver;dxOrgChartAdvancedCustomizeFormRS28;vcldb;dxDBXServerModeRS28;cxSchedulerRS28;dxRibbonRS28;dxFlowChartLayoutsRS28;dxPScxExtCommonRS28;dxdborRS28;dxRichEditControlCoreRS28;bindcomp;dxPScxGridLnkRS28;IndyCore;RESTBackendComponents;cxPivotGridChartRS28;dxBarExtDBItemsRS28;dxRichEditCoreRS28;cxTreeListdxBarPopupMenuRS28;dxFlowChartAdvancedCustomizeFormRS28;FireDACADSDriver;RESTComponents;IndyIPServer;vcl;dsnapxml;adortl;dsnapcon;DataSnapClient;DataSnapProviderClient;cxSchedulerWebServiceStorageRS28;dxtrmdRS28;DBXDb2Driver;dxPSdxGaugeControlLnkRS28;dxSpellCheckerRS28;cxGridRS28;emsclientfiredac;FireDACPgDriver;FireDACDSDriver;tethering;dxMapControlRS28;bindcompvcl;dxEMFRS28;CloudService;DBXSybaseASADriver;FMXTee;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + true + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png + + + dxPSdxSpreadSheetLnkRS28;vclwinx;DataSnapServer;fmx;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;DBXMSSQLDriver;FireDACCommonODBC;emsclient;cxExportRS28;dxHttpIndyRequestRS28;appanalytics;IndyProtocols;vclx;dxTileControlRS28;dxPSdxDBOCLnkRS28;dbxcds;vcledge;dxPSPrVwRibbonRS28;cxPivotGridOLAPRS28;FmxTeeUI;dxGDIPlusRS28;DBXFirebirdDriver;dxCoreRS28;cxPivotGridRS28;dxPSCoreRS28;FireDACSqliteDriver;DbxClientDriver;dxSpreadSheetRS28;dxSkinsCoreRS28;soapmidas;dxBarRS28;TeeUI;dxADOServerModeRS28;dxWizardControlRS28;dbexpress;inet;dxServerModeRS28;vcltouch;cxTreeListRS28;dxBarDBNavRS28;FireDACDBXDriver;fmxdae;dxPScxCommonRS28;dxNavBarRS28;CustomIPTransport;FireDACMSSQLDriver;dxSpreadSheetReportDesignerRS28;dxFireDACEMFRS28;dxComnRS28;dxFlowChartDesignerRS28;IndySystem;cxVerticalGridRS28;ibxbindings;dxmdsRS28;dxRichEditControlRS28;cxSchedulerGridRS28;dxPSdxOCLnkRS28;dxPScxSchedulerLnkRS28;dxPsPrVwAdvRS28;vclFireDAC;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;emsserverresource;dxADOEMFRS28;dxRibbonCustomizationFormRS28;dxPSdxDBTVLnkRS28;bindcompdbx;dxGaugeControlRS28;rtl;FireDACMySQLDriver;dxDockingRS28;dxPDFViewerRS28;DBXSqliteDriver;dxBarExtItemsRS28;dxPSdxFCLnkRS28;dxorgcRS28;DBXSybaseASEDriver;dxSpreadSheetCoreConditionalFormattingDialogsRS28;dxPSRichEditControlLnkRS28;vclimg;DataSnapFireDAC;inetdbxpress;FireDAC;xmlrtl;ibxpress;dsnap;FireDACDb2Driver;cxSchedulerRibbonStyleEventEditorRS28;DBXOracleDriver;dxPScxTLLnkRS28;DBXInformixDriver;vclib;fmxobj;bindcompvclsmp;DataSnapNativeClient;dxFlowChartRS28;dxPScxPCProdRS28;DatasnapConnectorsFreePascal;emshosting;dxRichEditDocumentModelRS28;dxPSdxMapControlLnkRS28;cxGridEMFRS28;dxGanttControlRS28;dxPScxVGridLnkRS28;dxPScxPivotGridLnkRS28;FireDACCommonDriver;IndyIPClient;dxCloudServiceLibraryRS28;cxLibraryRS28;bindcompvclwinx;emsedge;bindcompfmx;dxPSdxPDFViewerLnkRS28;inetdb;dxSpreadSheetCoreRS28;cxSchedulerTreeBrowserRS28;ibmonitor;FireDACASADriver;dxTabbedMDIRS28;Tee;vclactnband;fmxFireDAC;dxFireDACServerModeRS28;FireDACInfxDriver;DBXMySQLDriver;VclSmp;dxPSdxLCLnkRS28;DataSnapCommon;fmxase;dxdbtrRS28;DBXOdbcDriver;dbrtl;FireDACOracleDriver;dxPSLnksRS28;TeeDB;FireDACMSAccDriver;DataSnapIndy10ServerTransport;DataSnapConnectors;dxChartControlRS28;vcldsnap;DBXInterBaseDriver;FireDACMongoDBDriver;dxSpreadSheetConditionalFormattingDialogsRS28;FireDACTDataDriver;dxOrgChartAdvancedCustomizeFormRS28;vcldb;dxDBXServerModeRS28;cxSchedulerRS28;dxRibbonRS28;dxFlowChartLayoutsRS28;dxPScxExtCommonRS28;dxdborRS28;dxRichEditControlCoreRS28;bindcomp;dxPScxGridLnkRS28;IndyCore;RESTBackendComponents;cxPivotGridChartRS28;dxBarExtDBItemsRS28;dxRichEditCoreRS28;cxTreeListdxBarPopupMenuRS28;dxFlowChartAdvancedCustomizeFormRS28;FireDACADSDriver;RESTComponents;IndyIPServer;vcl;dsnapxml;adortl;dsnapcon;DataSnapClient;DataSnapProviderClient;cxSchedulerWebServiceStorageRS28;dxtrmdRS28;DBXDb2Driver;dxPSdxGaugeControlLnkRS28;dxSpellCheckerRS28;cxGridRS28;emsclientfiredac;FireDACPgDriver;FireDACDSDriver;tethering;dxMapControlRS28;bindcompvcl;dxEMFRS28;CloudService;DBXSybaseASADriver;FMXTee;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) + true + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + + + DEBUG;$(DCC_Define) + true + false + true + true + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + + Base + + + Cfg_1 + Base + + + Cfg_2 + Base + + + + Delphi.Personality.12 + Application + + + + Project1.dpr + + + + + False + False + False + False + False + False + False + True + True + + + 12 + + + + + diff --git a/README.md b/README.md index 4b8bc8e9c..a286e0874 100644 --- a/README.md +++ b/README.md @@ -31,6 +31,7 @@ us to patch the original Delphi source files: * [Support for the new Android Splash Screen standard](https://quality.embarcadero.com/browse/RSP-39331) * [for android compilation, need to use aapt2 instead of aapt](https://quality.embarcadero.com/browse/RSP-27606) * [Their is no propagation of mouse event under Firemonkey](https://quality.embarcadero.com/browse/RSP-24397) +* [Performance Issue - Comparing Equality Between Two Strings](https://quality.embarcadero.com/browse/RSP-42011) * [BeginUpdate/Endupdate block with add or remove of child objects : misconception](https://quality.embarcadero.com/browse/RSP-21013) * [The width and height of a TContext3D object must be defined as single-precision floating-point numbers, not as integers](https://quality.embarcadero.com/browse/RSP-41516) * [TTextLayout.PositionAtPoint / TTextLayoutD2D.DoPositionAtPoint totally broken in Alexandria](https://quality.embarcadero.com/browse/RSP-39734) diff --git a/Source/Alcinoe.FMX.Firebase.Messaging.pas b/Source/Alcinoe.FMX.Firebase.Messaging.pas index ff01e99a1..d2e0bce85 100644 --- a/Source/Alcinoe.FMX.Firebase.Messaging.pas +++ b/Source/Alcinoe.FMX.Firebase.Messaging.pas @@ -645,7 +645,7 @@ procedure TALFirebaseMessaging.doMessageReceived(const aPayload: String); var LJsonDoc := TALJSONDocumentW.create; try LJsonDoc.LoadFromJSONString(aPayload); - doMessageReceived(LJsonDoc.Node); + doMessageReceived(LJsonDoc); finally ALFreeAndNil(LJsonDoc); end; diff --git a/Source/Alcinoe.JSONDoc.pas b/Source/Alcinoe.JSONDoc.pas index 0cac00eee..a386f37e1 100644 --- a/Source/Alcinoe.JSONDoc.pas +++ b/Source/Alcinoe.JSONDoc.pas @@ -1,32 +1,14 @@ (******************************************************************************* -TALJSONDocumentA is a Delphi parser/writer for JSON / BSON data format. it's -support DOM and SAX parser, support BSON format, and use a similar syntax than -TALXMLDocument / TXMLDocument. TALJSONDocumentA can also export Json / Bson data -in TALStringListA. - -When it deals with parsing some (textual) content, two directions are usually -envisaged. In the JSON world, you have usually to make a choice between: -- A DOM parser, which creates an in-memory tree structure of objects mapping - the JSON content; -- A SAX parser, which reads the JSON content, then call pre-defined events for - each JSON content element. - -In fact, DOM parsers use internally a SAX parser to read the JSON content. -Therefore, with the overhead of object creation and their property -initialization, DOM parsers are typically three to five times slower than SAX -(and use much much more memory to store all the nodes). But, DOM parsers are -much more powerful for handling the data: as soon as it's mapped in native -objects, code can access with no time to any given node, whereas a SAX-based -access will have to read again the whole JSON content. - -Most JSON parser available in Delphi use a DOM-like approach. For instance, the -DBXJSON unit included since Delphi 2010 or the SuperObject library create a -class instance mapping each JSON node. In order to achieve best speed, -TALJSONDocumentA implement DOM parser and also a SAX parser. - -TALJSONDocumentA syntax is very similar to TALXMLdocument / TXMLDocument - -exemple : +TALJSONDocument is a Delphi parser/writer for JSON/BSON +data formats. It supports both DOM and SAX parsers. (Note +that a better name for SAX could be SAJ for Simple API for +JSON instead of Simple API for XML, but as the concept of +SAX is well-known, I will keep this name.) TALJSONDocument +also supports BSON format and uses a syntax similar to +TALXMLDocument/TXMLDocument. Additionally, TALJSONDocument +can export Json/Bson data to TALStringListA. + +Exemple : { _id: 1, @@ -49,22 +31,17 @@ initialization, DOM parsers are typically three to five times slower than SAX ------------------------------ To access the document nodes : -MyJsonDoc.loadFromJson(AJsonStr, False); -MyJsonDoc.childnodes['_id'].int32; -MyJsonDoc.childnodes['name'].childnodes['first'].text; -MyJsonDoc.childnodes['name'].childnodes['last'].text; -MyJsonDoc.childnodes['birth'].datetime; +MyJsonDoc := TALJsonDocumentW.CreateFromJSONString('{...}'); +MyJsonDoc.GetChildNodeValueInt32('_id', 0{default if node not exists}); +MyJsonDoc.GetChildNodeValueText(['name','first'], ''{default if node not exists}); +MyJsonDoc.GetChildNodeValueDateTime('birth', Now{default if node not exists}); for i := 0 to MyJsonDoc.childnodes['contribs'].ChildNodes.count - 1 do MyJsonDoc.childnodes['contribs'].childnodes[i].text; -for i := 0 to MyJsonDoc.childnodes['awards'].ChildNodes.count - 1 do begin - MyJsonDoc.childnodes['awards'].childnodes[i].childnodes['award'].text; - MyJsonDoc.childnodes['awards'].childnodes[i].childnodes['year'].text; - MyJsonDoc.childnodes['awards'].childnodes[i].childnodes['by'].text; -end; ------------------------------ To create the document nodes : +MyJsonDoc := TALJsonDocumentW.Create; MyJsonDoc.addchild('_id').int32 := 1; with MyJsonDoc.addchild('name', ntObject) do begin addchild('first').text := 'John'; @@ -96,35 +73,86 @@ initialization, DOM parsers are typically three to five times slower than SAX ---------------------------- To load and save from BSON : -MyJsonDoc.LoadFromFile(aBSONFileName, False{saxMode}, True{BSON}); -MyJsonDoc.SaveToFile(aBSONFileName, False{saxMode}, True{BSON}); +MyJsonDoc := TALJsonDocumentW.CreateFromBSONBytes(Bytes); +MyJsonDoc.SaveToBSONFile(FileName); --------------------------------------- To parse an JSON document in Sax Mode : -MyJsonDoc.onParseText := procedure( - Sender: TObject; - const Path: AnsiString; - const name: AnsiString; - const Args: array of const; - NodeSubType: TALJSONNodeSubType) - begin - case NodeSubType of - nstFloat: Writeln(Path + '=' + ALFloatToStrA(Args[0].VExtended^, ALDefaultFormatSettingsA)); - nstText: Writeln(Path + '=' + ansiString(Args[0].VAnsiString)); - nstObjectID: Writeln(Path + '=' + 'ObjectId("'+ALBinToHexA(ansiString(Args[0].VAnsiString))+'")'); - nstBoolean: Writeln(Path + '=' + ALBoolToStrA(Args[0].VBoolean,'true','false')); - nstDateTime: Writeln(Path + '=' + ALFormatDateTimeA('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', Args[0].VExtended^, ALDefaultFormatSettingsA)); - nstNull: Writeln(Path + '=' + 'null'); - nstRegEx: Writeln(Path + '=' + ansiString(Args[0].VAnsiString)); - nstBinary: Writeln(Path + '=' + 'BinData('+inttostr(Args[1].VInteger)+', "'+ansiString(ALBase64EncodeStringNoCRLF(ansiString(Args[0].VAnsiString)))+'")'); - nstJavascript: Writeln(Path + '=' + ansiString(Args[0].VAnsiString)); - nstInt32: Writeln(Path + '=' + 'NumberInt('+inttostr(Args[0].VInteger)+')'); - nstTimestamp: Writeln(Path + '=' + 'Timestamp('+inttostr(int64(cardinal(Args[0].VInteger)))+', '+inttostr(int64(cardinal(Args[1].VInteger)))+')'); - nstInt64: Writeln(Path + '=' + 'NumberLong('+inttostr(Args[0].VInt64^)+')'); - end; - end; -MyJsonDoc.LoadFromJSON(AJsonStr, true{saxMode}); +TALJSONDocumentW.ParseJSONString( + '{...}', + //-- + procedure (Sender: TObject; const Path: String; const name: String; const Args: array of const; NodeSubType: TALJSONNodeSubType) + begin + case NodeSubType of + nstFloat: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + ALFloatToStrW(Args[0].VExtended^, ALDefaultFormatSettingsW)); + nstText: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + String(Args[0].VUnicodeString)); + nstObject: ; + nstArray: ; + nstObjectID: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'ObjectId("'+string(Args[0].VUnicodeString)+'")'); + nstBoolean: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + ALBoolToStrW(Args[0].VBoolean,'true','false')); + nstDateTime: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + ALFormatDateTimeW('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', Args[0].VExtended^, ALDefaultFormatSettingsW)); + nstNull: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'null'); + nstRegEx: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + String(Args[0].VUnicodeString)); + nstBinary: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'BinData('+ALIntToStrW(Args[1].VInteger)+', "'+String(Args[0].VunicodeString)+'")'); + nstJavascript: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + String(Args[0].VUnicodeString)); + nstInt32: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'NumberInt('+ALIntToStrW(Args[0].VInteger)+')'); + nstTimestamp: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'Timestamp('+ALIntToStrW(int64(cardinal(Args[0].VInteger)))+', '+ALIntToStrW(int64(cardinal(Args[1].VInteger)))+')'); + nstInt64: MemoSaxModeEvents.Lines.Add('TEXT => ' + Path + '=' + 'NumberLong('+inttostr(Args[0].VInt64^)+')'); + end; + end{onParseText}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + MemoSaxModeEvents.Lines.Add('STARTOBJECT => ' + Name); + end{onParseStartObject}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + MemoSaxModeEvents.Lines.Add('ENDOBJECT => ' + Name); + end{onParseEndObject}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + MemoSaxModeEvents.Lines.Add('STARTARRAY => ' + Name); + end{onParseStartArray}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + MemoSaxModeEvents.Lines.Add('ENDARRAY => ' + Name); + end{onParseEndArray}); + +------------------------------------------------------- +list of changes made with the 1.0.5 release of Alcinoe: + +* The support for doNodeAutoCreate has been removed. +* The properties TALJsonDocument.Duplicates and TALJsonDocument.Sorted are now + only applied to the child nodes list and are not inherited anymore. +* The properties TALJsonDocument.ParseOptions and TALJsonDocument.Options have + been moved as parameters for the methods loadFromJson/saveToJson and + loadFromBson/saveToBson. +* TALJsonDocument.Duplicates has been moved to the child nodes list. +* The ClearChildNodes parameter from loadFromJson/saveToJson has been moved to + the options of loadFromJson/saveToJson. +* The property TALJSONNode.ownerDocument has been removed. +* FormatSettings has been removed. +* The property TALJsonDocument.Tag has been removed. +* TALJsonDocument.PathSeparator has been replaced by ALDefaultJsonPathSeparator. +* TALJsonDocument.NodeIndentStr has been replaced by ALDefaultJsonNodeIndentA. +* TALJsonDocument.node has been removed. +* TALJsonDocument.create now returns a TALJsonNode. +* TALJsonDocument.IsEmptyDoc has been replaced by hasChildNodes. +* The method TALJsonDocument.ExtractNode has been removed. +* The property TALJsonDocument.Active has been removed. +* The method TALJsonDocument.ReleaseDoc has been removed. +* The ParseStartDocument and ParseEndDocument events have been removed. +* TALJsonDocument.clear has been moved to childnodes.clear. +* The events onParseText, onParseStartObject, onParseEndObject, + onParseStartArray, and onParseEndArray have been moved to ParseBSON/ParseJSON. + +------ +DEMO : +https://github.com/MagicFoundation/Alcinoe/tree/master/Demos/ALJsonDoc *******************************************************************************) unit Alcinoe.JSONDoc; @@ -142,7 +170,6 @@ interface Alcinoe.StringList; const - cALJSONNotActive = 'No active document'; cAlJSONNodeNotFound = 'Node "%s" not found'; cALJSONInvalidNodeType = 'Invalid node type'; cALJSONInvalidBSONNodeSubType = 'Invalid node sub type'; @@ -191,21 +218,21 @@ interface W2: LongWord); end; - TALJSONDocOption = (doNodeAutoCreate, // create only ntText Node! - doNodeAutoIndent, // affect only the SaveToStream - doProtectedSave, // save first to a tmp file and then later rename the tmp file to the desired filename - doSorted); // Node lists of object nodes are sorted by node names - TALJSONDocOptions = set of TALJSONDocOption; - - TALJSONParseOption = (poIgnoreControlCharacters, // don't decode escaped characters (like \") and not encode them also (when save / load) - poSkipNodeSubTypeHelper, // don't use helper functions like NumberLong() to handle 64-bit integers or NumberInt() - // to handle 32-bit integers - poSaveInt64AsText, // JS represents all numbers as double, and with growing integers you loose precision at some point - // use this option to return Int64 as string - poAllowComments); // allow comments inside the Json Source file. ex: - //{ - // "nodename": "nodevalue", // your comments here - //} + TALJSONSaveOption = (soNodeAutoIndent, // Automatically indents the JSON output for improved readability + soIgnoreControlCharacters, // Don't decode escaped characters (like \") and not encode them also (when save / load) + soSkipNodeSubTypeHelper, // Don't use helper functions like NumberLong() to handle 64-bit integers or NumberInt() + // to handle 32-bit integers + soSaveInt64AsText, // JS represents all numbers as double, and with growing integers you loose precision at some point + // use this option to return Int64 as string + soProtectedSave); // Save first to a tmp file and then later rename the tmp file to the desired filename + TALJSONSaveOptions = set of TALJSONSaveOption; + + TALJSONParseOption = (poIgnoreControlCharacters, // Don't decode escaped characters (like \") and not encode them also (when save / load) + poClearChildNodes, // Removes all child nodes + poAllowComments); // Allow comments inside the Json Source file. ex: + // { + // "nodename": "nodevalue", // your comments here + // } TALJSONParseOptions = set of TALJSONParseOption; {Exception} @@ -231,7 +258,6 @@ EALJSONDocError = class(Exception); TALJSONNodeListA= Class; TALJSONDocumentA= Class; - TAlJSONParseDocumentA = reference to procedure (Sender: TObject); TAlJSONParseTextEventA = reference to procedure (Sender: TObject; const Path: AnsiString; const name: AnsiString; const Args: array of const; NodeSubType: TALJSONNodeSubType); TAlJSONParseObjectEventA = reference to procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString); TAlJSONParseArrayEventA = reference to procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString); @@ -261,7 +287,7 @@ TALJSONNodeListA = class(Tobject) function Get(Index: Integer): TALJSONNodeA; function GetNodeByIndex(Const Index: Integer): TALJSONNodeA; function GetNodeByName(Const Name: AnsiString): TALJSONNodeA; - function CompareNodeNames(const S1, S2: AnsiString): Integer; + function CompareNodeNames(const S1, S2: AnsiString): Integer; inline; function Find(const NodeName: AnsiString; var Index: Integer): Boolean; procedure InternalInsert(Index: Integer; const Node: TALJSONNodeA); public @@ -281,7 +307,7 @@ TALJSONNodeListA = class(Tobject) function Extract(const index: integer): TALJSONNodeA; overload; function Extract(const Node: TALJSONNodeA): TALJSONNodeA; overload; procedure Exchange(Index1, Index2: Integer); - function FindNode(const NodeName: AnsiString; const Direction: TDirection = TDirection.FromBeginning): TALJSONNodeA; overload; + function FindNode(const NodeName: AnsiString; const Direction: TDirection = TDirection.FromBeginning): TALJSONNodeA; function FindSibling(const Node: TALJSONNodeA; Delta: Integer): TALJSONNodeA; function First: TALJSONNodeA; function IndexOf(const Name: AnsiString; const Direction: TDirection = TDirection.FromBeginning): Integer; overload; @@ -305,7 +331,6 @@ TALJSONNodeListA = class(Tobject) {TALJSONNodeA represents a node in an JSON document.} TALJSONNodeA = class(TObject) private - [weak] FDocument: TALJSONDocumentA; [weak] FParentNode: TALJSONNodeA; fNodeName: AnsiString; protected @@ -323,8 +348,6 @@ TALJSONNodeA = class(TObject) procedure SetNodeValue(const Value: int64; const NodeSubType: TALJSONNodeSubType); overload; virtual; procedure SetNodeValue(const StrValue: AnsiString; const Int64Value: int64; const NodeSubType: TALJSONNodeSubType); overload; virtual; procedure SetNodeName(const NodeName: AnsiString); - function GetOwnerDocument: TALJSONDocumentA; - procedure SetOwnerDocument(const Value: TALJSONDocumentA); function GetParentNode: TALJSONNodeA; procedure SetParentNode(const Value: TALJSONNodeA); function GetJSON: AnsiString; @@ -332,12 +355,34 @@ TALJSONNodeA = class(TObject) function GetBSON: AnsiString; procedure SetBSON(const Value: AnsiString); function NestingLevel: Integer; + Procedure ParseJSON( + const RawJSONStream: TStream; + const RawJSONString: AnsiString; + const SaxMode: Boolean; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions); + Procedure ParseBSON( + const RawBSONStream: TStream; + const RawBSONString: AnsiString; + const SaxMode: Boolean; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions); procedure SaveToBson( const Stream: TStream; - Var buffer: ansiString); + Var buffer: ansiString; + const Options: TALJSONSaveOptions); procedure SaveToJson( const Stream: TStream; - Var buffer: ansiString); + Var buffer: ansiString; + const Options: TALJSONSaveOptions); public constructor Create(const NodeName: AnsiString); virtual; procedure MultiThreadPrepare(const aOnlyChildList: Boolean = False); @@ -389,24 +434,89 @@ TALJSONNodeA = class(TObject) function AddChild(const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeA; overload; function DeleteChild(const NodeName: AnsiString): boolean; overload; function DeleteChild(const Path: array of AnsiString): boolean; overload; + function CreateNode(const NodeName: AnsiString; NodeType: TALJSONNodeType): TALJSONNodeA; function NextSibling: TALJSONNodeA; function PreviousSibling: TALJSONNodeA; - procedure SaveToJSONStream(const Stream: TStream); - procedure SaveToJSONFile(const FileName: String); overload; - procedure SaveToJSONFile(const FileName: AnsiString); overload; - procedure SaveToJSONString(var Str: AnsiString); - procedure SaveToBSONStream(const Stream: TStream); - procedure SaveToBSONFile(const FileName: String); overload; - procedure SaveToBSONFile(const FileName: AnsiString); overload; - procedure SaveToBSONString(var Str: AnsiString); - procedure LoadFromJSONString(const Str: AnsiString; Const ClearChildNodes: Boolean = True); - procedure LoadFromJSONStream(const Stream: TStream; Const ClearChildNodes: Boolean = True); - procedure LoadFromJSONFile(const FileName: String; Const ClearChildNodes: Boolean = True); overload; - procedure LoadFromJSONFile(const FileName: AnsiString; Const ClearChildNodes: Boolean = True); overload; - procedure LoadFromBSONString(const Str: AnsiString; Const ClearChildNodes: Boolean = True); - procedure LoadFromBSONStream(const Stream: TStream; Const ClearChildNodes: Boolean = True); - procedure LoadFromBSONFile(const FileName: String; Const ClearChildNodes: Boolean = True); overload; - procedure LoadFromBSONFile(const FileName: AnsiString; Const ClearChildNodes: Boolean = True); overload; + procedure SaveToJSONStream(const Stream: TStream; const Options: TALJSONSaveOptions = []); + procedure SaveToJSONFile(const FileName: String; const Options: TALJSONSaveOptions = []); overload; + procedure SaveToJSONFile(const FileName: AnsiString; const Options: TALJSONSaveOptions = []); overload; + procedure SaveToJSONString(var Str: AnsiString; const Options: TALJSONSaveOptions = []); + procedure SaveToBSONStream(const Stream: TStream; const Options: TALJSONSaveOptions = []); + procedure SaveToBSONFile(const FileName: String; const Options: TALJSONSaveOptions = []); overload; + procedure SaveToBSONFile(const FileName: AnsiString; const Options: TALJSONSaveOptions = []); overload; + procedure SaveToBSONString(var Str: AnsiString; const Options: TALJSONSaveOptions = []); + procedure LoadFromJSONString(const Str: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]); + procedure LoadFromJSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]); + procedure LoadFromJSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]); overload; + procedure LoadFromJSONFile(const FileName: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]); overload; + procedure LoadFromBSONString(const Str: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]); + procedure LoadFromBSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]); + procedure LoadFromBSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]); overload; + procedure LoadFromBSONFile(const FileName: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]); overload; + procedure ParseJSONString( + const Str: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); + procedure ParseJSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); + procedure ParseJSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); overload; + procedure ParseJSONFile( + const FileName: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); overload; + procedure ParseBSONString( + const Str: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); + procedure ParseBSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); + procedure ParseBSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); overload; + procedure ParseBSONFile( + const FileName: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); overload; property ChildNodes: TALJSONNodeListA read GetChildNodes write SetChildNodes; function GetChildNode(const nodeName: ansiString): TALJSONNodeA; overload; function GetChildNodeValueText(const nodeName: ansiString; const default: AnsiString): AnsiString; overload; @@ -471,7 +581,6 @@ TALJSONNodeA = class(TObject) property NodeType: TALJSONNodeType read GetNodeType; property NodeValue: AnsiString read GetNodeValueStr; // same as text property but without formating property NodeSubType: TALJSONNodeSubType read GetNodeSubType; - property OwnerDocument: TALJSONDocumentA read GetOwnerDocument; property ParentNode: TALJSONNodeA read GetParentNode; property Text: AnsiString read GetText write SetText; property int32: integer read GetInt32 write SetInt32; @@ -524,14 +633,14 @@ TALJSONNodeA = class(TObject) {Groups javascript, string, number, true, false, null} TALJSONTextNodeA = Class(TALJSONNodeA) private - fNodeSubType: TALJSONNodeSubType; + FRawNodeValueInt64: int64; // contain the value Stored in an int64 (if the + // value can be store in an int64) fRawNodeValueStr: AnsiString; // contain the text representation of the node // WITHOUT any node subtype helper // for exemple for NumberLong(12391293) it's // store only 12391293 - FRawNodeValueInt64: int64; // contain the value Stored in an int64 (if the - // value can be store in an int64) fRawNodeValueDefined: TALJSONTextNodeValueDefined; + fNodeSubType: TALJSONNodeSubType; protected function GetNodeType: TALJSONNodeType; override; function GetNodeSubType: TALJSONNodeSubType; override; @@ -550,167 +659,89 @@ TALJSONNodeA = class(TObject) {TALJSONDocumentA} TALJSONDocumentA = class(TObject) private - FTag: NativeInt; - FDocumentNode: TALJSONNodeA; - FNodeIndentStr: AnsiString; - FOptions: TALJSONDocOptions; - FParseOptions: TALJSONParseOptions; - FDuplicates: TDuplicates; - FPathSeparator: AnsiChar; - FOnParseStartDocument: TAlJSONParseDocumentA; - FOnParseEndDocument: TAlJSONParseDocumentA; - FonParseText: TAlJSONParseTextEventA; - FonParseStartObject: TAlJSONParseObjectEventA; - FonParseEndObject: TAlJSONParseObjectEventA; - FonParseStartArray: TAlJSONParseArrayEventA; - FonParseEndArray: TAlJSONParseArrayEventA; - fFormatSettings: pALFormatSettingsA; - protected - procedure CheckActive; - procedure DoParseStartDocument; - procedure DoParseEndDocument; - procedure DoParseText(const Path: AnsiString; const name: AnsiString; const Args: array of const; NodeSubType: TALJSONNodeSubType); - procedure DoParseStartObject(const Path: AnsiString; const Name: AnsiString); - procedure DoParseEndObject(const Path: AnsiString; const Name: AnsiString); - procedure DoParseStartArray(const Path: AnsiString; const Name: AnsiString); - procedure DoParseEndArray(const Path: AnsiString; const Name: AnsiString); - Procedure ParseJSON( - const RawJSONStream: TStream; - const RawJSONString: AnsiString; - const ContainerNode: TALJSONNodeA); - Procedure ParseBSON( - const RawBSONStream: TStream; - const RawBSONString: AnsiString; - const ContainerNode: TALJSONNodeA); - procedure ReleaseDoc; - function GetActive: Boolean; - procedure SetActive(const Value: Boolean); - function GetChildNodes: TALJSONNodeListA; - function GetDocumentNode: TALJSONNodeA; - function GetNodeIndentStr: AnsiString; - function GetOptions: TALJSONDocOptions; - function GetParseOptions: TALJSONParseOptions; - function GetPathSeparator: ansiChar; - procedure SetPathSeparator(const Value: ansiChar); - function GetJSON: AnsiString; - function GetBSON: AnsiString; - procedure SetOptions(const Value: TALJSONDocOptions); - procedure SetParseOptions(const Value: TALJSONParseOptions); - procedure SetJSON(const Value: ansiString); - procedure SetBSON(const Value: ansiString); - procedure SetNodeIndentStr(const Value: AnsiString); - procedure SetDuplicates(const Value: TDuplicates); + class function DetectNodeTypeFromJSon( + const RawJSONStream: TStream; + const RawJSONString: AnsiString): TALJSONNodeType; public - constructor Create(const aActive: Boolean = True); overload; virtual; - constructor Create(const aFormatSettings: TALFormatSettingsA; const aActive: Boolean = True); overload; virtual; - destructor Destroy; override; - procedure MultiThreadPrepare(const aOnlyChildList: Boolean = False); - procedure Clear; - function AddChild(const NodeName: AnsiString; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeA; overload; - function AddChild(const Path: array of AnsiString; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeA; overload; - function DeleteChild(const NodeName: AnsiString): boolean; overload; - function DeleteChild(const Path: array of AnsiString): boolean; overload; - function CreateNode(const NodeName: AnsiString; NodeType: TALJSONNodeType): TALJSONNodeA; - function ExtractNode: TALJSONNodeA; - function IsEmptyDoc: Boolean; - procedure LoadFromJSONString(const Str: AnsiString; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); - procedure LoadFromJSONStream(const Stream: TStream; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); - procedure LoadFromJSONFile(const FileName: String; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); overload; - procedure LoadFromJSONFile(const FileName: AnsiString; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); overload; - procedure LoadFromBSONString(const Str: AnsiString; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); - procedure LoadFromBSONStream(const Stream: TStream; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); - procedure LoadFromBSONFile(const FileName: String; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); overload; - procedure LoadFromBSONFile(const FileName: AnsiString; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); overload; - procedure SaveToJSONStream(const Stream: TStream); - procedure SaveToJSONFile(const FileName: String); overload; - procedure SaveToJSONFile(const FileName: AnsiString); overload; - procedure SaveToJSONString(var Str: AnsiString); - procedure SaveToBSONStream(const Stream: TStream); - procedure SaveToBSONFile(const FileName: String); overload; - procedure SaveToBSONFile(const FileName: AnsiString); overload; - procedure SaveToBSONString(var Str: AnsiString); - property ChildNodes: TALJSONNodeListA read GetChildNodes; - function GetChildNode(const nodeName: ansiString): TALJSONNodeA; overload; - function GetChildNodeValueText(const nodeName: ansiString; const default: AnsiString): AnsiString; overload; - function GetChildNodeValueFloat(const nodeName: ansiString; const default: Double): Double; overload; - function GetChildNodeValueDateTime(const nodeName: ansiString; const default: TDateTime): TDateTime; overload; - function GetChildNodeValueTimestamp(const nodeName: ansiString; const default: TALBSONTimestamp): TALBSONTimestamp; overload; - function GetChildNodeValueObjectID(const nodeName: ansiString; const default: AnsiString): AnsiString; overload; // return a "byte" string - function GetChildNodeValueInt32(const nodeName: ansiString; const default: Integer): Integer; overload; - function GetChildNodeValueInt64(const nodeName: ansiString; const default: Int64): Int64; overload; - function GetChildNodeValueBool(const nodeName: ansiString; const default: Boolean): Boolean; overload; - function GetChildNodeValueJavascript(const nodeName: ansiString; const default: AnsiString): AnsiString; overload; - function GetChildNodeValueRegEx(const nodeName: ansiString; const default: ansiString): ansiString; overload; - function GetChildNodeValueRegExOptions(const nodeName: ansiString; const default: TALPerlRegExOptions): TALPerlRegExOptions; overload; - function GetChildNodeValueBinary(const nodeName: ansiString; const default: AnsiString): AnsiString; overload; // return a "byte" string - function GetChildNodeValueBinarySubType(const nodeName: ansiString; const default: byte): byte; overload; - function GetChildNodeValueNull(const nodeName: ansiString): Boolean; overload; - function GetChildNode(const path: array of ansiString): TALJSONNodeA; overload; - function GetChildNodeValueText(const path: array of ansiString; const default: AnsiString): AnsiString; overload; - function GetChildNodeValueFloat(const path: array of ansiString; const default: Double): Double; overload; - function GetChildNodeValueDateTime(const path: array of ansiString; const default: TDateTime): TDateTime; overload; - function GetChildNodeValueTimestamp(const path: array of ansiString; const default: TALBSONTimestamp): TALBSONTimestamp; overload; - function GetChildNodeValueObjectID(const path: array of ansiString; const default: AnsiString): AnsiString; overload; // return a "byte" string - function GetChildNodeValueInt32(const path: array of ansiString; const default: Integer): Integer; overload; - function GetChildNodeValueInt64(const path: array of ansiString; const default: Int64): Int64; overload; - function GetChildNodeValueBool(const path: array of ansiString; const default: Boolean): Boolean; overload; - function GetChildNodeValueJavascript(const path: array of ansiString; const default: AnsiString): AnsiString; overload; - function GetChildNodeValueRegEx(const path: array of ansiString; const default: ansiString): ansiString; overload; - function GetChildNodeValueRegExOptions(const path: array of ansiString; const default: TALPerlRegExOptions): TALPerlRegExOptions; overload; - function GetChildNodeValueBinary(const path: array of ansiString; const default: AnsiString): AnsiString; overload; // return a "byte" string - function GetChildNodeValueBinarySubType(const path: array of ansiString; const default: byte): byte; overload; - function GetChildNodeValueNull(const path: array of ansiString): Boolean; overload; - procedure SetChildNodeValueText(const nodeName: ansiString; const value: AnsiString); overload; - procedure SetChildNodeValueFloat(const nodeName: ansiString; const value: Double); overload; - procedure SetChildNodeValueDateTime(const nodeName: ansiString; const value: TDateTime); overload; - procedure SetChildNodeValueTimestamp(const nodeName: ansiString; const value: TALBSONTimestamp); overload; - procedure SetChildNodeValueObjectID(const nodeName: ansiString; const value: AnsiString); overload; - procedure SetChildNodeValueInt32(const nodeName: ansiString; const value: Integer); overload; - procedure SetChildNodeValueInt64(const nodeName: ansiString; const value: Int64); overload; - procedure SetChildNodeValueBool(const nodeName: ansiString; const value: Boolean); overload; - procedure SetChildNodeValueJavascript(const nodeName: ansiString; const value: AnsiString); overload; - procedure SetChildNodeValueRegEx(const nodeName: ansiString; const value: ansiString); overload; - procedure SetChildNodeValueRegExOptions(const nodeName: ansiString; const value: TALPerlRegExOptions); overload; - procedure SetChildNodeValueBinary(const nodeName: ansiString; const value: AnsiString); overload; - procedure SetChildNodeValueBinarySubType(const nodeName: ansiString; const value: byte); overload; - procedure SetChildNodeValueNull(const nodeName: ansiString); overload; - procedure SetChildNodeValueText(const path: array of ansiString; const value: AnsiString); overload; - procedure SetChildNodeValueFloat(const path: array of ansiString; const value: Double); overload; - procedure SetChildNodeValueDateTime(const path: array of ansiString; const value: TDateTime); overload; - procedure SetChildNodeValueTimestamp(const path: array of ansiString; const value: TALBSONTimestamp); overload; - procedure SetChildNodeValueObjectID(const path: array of ansiString; const value: AnsiString); overload; - procedure SetChildNodeValueInt32(const path: array of ansiString; const value: Integer); overload; - procedure SetChildNodeValueInt64(const path: array of ansiString; const value: Int64); overload; - procedure SetChildNodeValueBool(const path: array of ansiString; const value: Boolean); overload; - procedure SetChildNodeValueJavascript(const path: array of ansiString; const value: AnsiString); overload; - procedure SetChildNodeValueRegEx(const path: array of ansiString; const value: ansiString); overload; - procedure SetChildNodeValueRegExOptions(const path: array of ansiString; const value: TALPerlRegExOptions); overload; - procedure SetChildNodeValueBinary(const path: array of ansiString; const value: AnsiString); overload; - procedure SetChildNodeValueBinarySubType(const path: array of ansiString; const value: byte); overload; - procedure SetChildNodeValueNull(const path: array of ansiString); overload; - property Node: TALJSONNodeA read GetDocumentNode; - property Active: Boolean read GetActive write SetActive; - property NodeIndentStr: AnsiString read GetNodeIndentStr write SetNodeIndentStr; - property Options: TALJSONDocOptions read GetOptions write SetOptions; - property ParseOptions: TALJSONParseOptions read GetParseOptions write SetParseOptions; - property Duplicates: TDuplicates read FDuplicates write SetDuplicates; // In pair with doSorted in options - property PathSeparator: ansiChar read GetPathSeparator write SetPathSeparator; - property JSON: AnsiString read GetJSON write SetJSON; - property BSON: AnsiString read GetBSON write SetBSON; - property OnParseStartDocument: TAlJSONParseDocumentA read fOnParseStartDocument write fOnParseStartDocument; - property OnParseEndDocument: TAlJSONParseDocumentA read fOnParseEndDocument write fOnParseEndDocument; - property onParseText: TAlJSONParseTextEventA read fonParseText write fonParseText; - property onParseStartObject: TAlJSONParseObjectEventA read fonParseStartObject write fonParseStartObject; - property onParseEndObject: TAlJSONParseObjectEventA read fonParseEndObject write fonParseEndObject; - property onParseStartArray: TAlJSONParseArrayEventA read fonParseStartArray write fonParseStartArray; - property onParseEndArray: TAlJSONParseArrayEventA read fonParseEndArray write fonParseEndArray; - property FormatSettings: pALFormatSettingsA read fFormatSettings; // this is use only on GetText/OnParseText to retrieve float and DateTime formatted according to FormatSettings - property Tag: NativeInt read FTag write FTag; + class function Create: TALJSONNodeA; + class function CreateFromJSONString(const Str: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; + class function CreateFromJSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; + class function CreateFromJSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; overload; + class function CreateFromJSONFile(const FileName: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; overload; + class function CreateFromBSONString(const Str: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; + class function CreateFromBSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; + class function CreateFromBSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; overload; + class function CreateFromBSONFile(const FileName: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; overload; + class procedure ParseJSONString( + const Str: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); + class procedure ParseJSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); + class procedure ParseJSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); overload; + class procedure ParseJSONFile( + const FileName: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); overload; + class procedure ParseBSONString( + const Str: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); + class procedure ParseBSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); + class procedure ParseBSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); overload; + class procedure ParseBSONFile( + const FileName: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); overload; end; {misc constants} var ALDefaultJsonNodeIndentA: ansiString; // var instead of const to avoid new ansitring on assign + ALDefaultJsonPathSeparatorA: AnsiChar; ALJsonISODateFormatSettingsA: TALFormatSettingsA; {misc function} @@ -830,7 +861,7 @@ TALJSONNodeListW = class(Tobject) function Get(Index: Integer): TALJSONNodeW; function GetNodeByIndex(Const Index: Integer): TALJSONNodeW; function GetNodeByName(Const Name: String): TALJSONNodeW; - function CompareNodeNames(const S1, S2: String): Integer; + function CompareNodeNames(const S1, S2: String): Integer; inline; function Find(const NodeName: String; var Index: Integer): Boolean; procedure InternalInsert(Index: Integer; const Node: TALJSONNodeW); public @@ -850,7 +881,7 @@ TALJSONNodeListW = class(Tobject) function Extract(const index: integer): TALJSONNodeW; overload; function Extract(const Node: TALJSONNodeW): TALJSONNodeW; overload; procedure Exchange(Index1, Index2: Integer); - function FindNode(const NodeName: String; const Direction: TDirection = TDirection.FromBeginning): TALJSONNodeW; overload; + function FindNode(const NodeName: String; const Direction: TDirection = TDirection.FromBeginning): TALJSONNodeW; function FindSibling(const Node: TALJSONNodeW; Delta: Integer): TALJSONNodeW; function First: TALJSONNodeW; function IndexOf(const Name: String; const Direction: TDirection = TDirection.FromBeginning): Integer; overload; @@ -874,7 +905,6 @@ TALJSONNodeListW = class(Tobject) {TALJSONNodeW represents a node in an JSON document.} TALJSONNodeW = class(TObject) private - [weak] FDocument: TALJSONDocumentW; [weak] FParentNode: TALJSONNodeW; fNodeName: String; protected @@ -892,8 +922,6 @@ TALJSONNodeW = class(TObject) procedure SetNodeValue(const Value: int64; const NodeSubType: TALJSONNodeSubType); overload; virtual; procedure SetNodeValue(const StrValue: String; const Int64Value: int64; const NodeSubType: TALJSONNodeSubType); overload; virtual; procedure SetNodeName(const NodeName: String); - function GetOwnerDocument: TALJSONDocumentW; - procedure SetOwnerDocument(const Value: TALJSONDocumentW); function GetParentNode: TALJSONNodeW; procedure SetParentNode(const Value: TALJSONNodeW); function GetJSON: String; @@ -901,13 +929,33 @@ TALJSONNodeW = class(TObject) function GetBSON: Tbytes; procedure SetBSON(const Value: Tbytes); function NestingLevel: Integer; + Procedure ParseJSON( + const Buffer: String; + const SaxMode: Boolean; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions); + Procedure ParseBSON( + const Buffer: Tbytes; + const SaxMode: Boolean; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions); procedure SaveToBson( const Stream: TStream; - Var buffer: Tbytes); + Var buffer: Tbytes; + const Options: TALJSONSaveOptions); procedure SaveToJson( const Stream: TStream; const StreamEncoding: TEncoding; - Var buffer: String); + Var buffer: String; + const Options: TALJSONSaveOptions); public constructor Create(const NodeName: String); virtual; procedure MultiThreadPrepare(const aOnlyChildList: Boolean = False); @@ -959,22 +1007,71 @@ TALJSONNodeW = class(TObject) function AddChild(const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeW; overload; function DeleteChild(const NodeName: String): boolean; overload; function DeleteChild(const Path: array of String): boolean; overload; + function CreateNode(const NodeName: String; NodeType: TALJSONNodeType): TALJSONNodeW; function NextSibling: TALJSONNodeW; function PreviousSibling: TALJSONNodeW; - procedure SaveToJSONStream(const Stream: TStream; const Encoding: TEncoding); overload; - procedure SaveToJSONStream(const Stream: TStream); overload; - procedure SaveToJSONFile(const FileName: String; const Encoding: TEncoding); overload; - procedure SaveToJSONFile(const FileName: String); overload; - procedure SaveToJSONString(var Str: String); - procedure SaveToBSONStream(const Stream: TStream); - procedure SaveToBSONFile(const FileName: String); - procedure SaveToBSONBytes(var Bytes: Tbytes); - procedure LoadFromJSONString(const Str: String; Const ClearChildNodes: Boolean = True); - procedure LoadFromJSONStream(const Stream: TStream; Const ClearChildNodes: Boolean = True); - procedure LoadFromJSONFile(const FileName: String; Const ClearChildNodes: Boolean = True); - procedure LoadFromBSONBytes(const Bytes: Tbytes; Const ClearChildNodes: Boolean = True); - procedure LoadFromBSONStream(const Stream: TStream; Const ClearChildNodes: Boolean = True); - procedure LoadFromBSONFile(const FileName: String; Const ClearChildNodes: Boolean = True); + procedure SaveToJSONStream(const Stream: TStream; const Encoding: TEncoding; const Options: TALJSONSaveOptions = []); overload; + procedure SaveToJSONStream(const Stream: TStream; const Options: TALJSONSaveOptions = []); overload; + procedure SaveToJSONFile(const FileName: String; const Encoding: TEncoding; const Options: TALJSONSaveOptions = []); overload; + procedure SaveToJSONFile(const FileName: String; const Options: TALJSONSaveOptions = []); overload; + procedure SaveToJSONString(var Str: String; const Options: TALJSONSaveOptions = []); + procedure SaveToBSONStream(const Stream: TStream; const Options: TALJSONSaveOptions = []); + procedure SaveToBSONFile(const FileName: String; const Options: TALJSONSaveOptions = []); + procedure SaveToBSONBytes(var Bytes: Tbytes; const Options: TALJSONSaveOptions = []); + procedure LoadFromJSONString(const Str: String; const Options: TALJSONParseOptions = [poClearChildNodes]); + procedure LoadFromJSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]); + procedure LoadFromJSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]); + procedure LoadFromBSONBytes(const Bytes: Tbytes; const Options: TALJSONParseOptions = [poClearChildNodes]); + procedure LoadFromBSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]); + procedure LoadFromBSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]); + procedure ParseJSONString( + const Str: String; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); + procedure ParseJSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); + procedure ParseJSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); + procedure ParseBSONBytes( + const Bytes: Tbytes; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); + procedure ParseBSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); + procedure ParseBSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); property ChildNodes: TALJSONNodeListW read GetChildNodes write SetChildNodes; function GetChildNode(const nodeName: String): TALJSONNodeW; overload; function GetChildNodeValueText(const nodeName: String; const default: String): String; overload; @@ -1039,7 +1136,6 @@ TALJSONNodeW = class(TObject) property NodeType: TALJSONNodeType read GetNodeType; property NodeValue: String read GetNodeValueStr; // same as text property but without formating property NodeSubType: TALJSONNodeSubType read GetNodeSubType; - property OwnerDocument: TALJSONDocumentW read GetOwnerDocument; property ParentNode: TALJSONNodeW read GetParentNode; property Text: String read GetText write SetText; property int32: integer read GetInt32 write SetInt32; @@ -1092,14 +1188,14 @@ TALJSONNodeW = class(TObject) {Groups javascript, string, number, true, false, null} TALJSONTextNodeW = Class(TALJSONNodeW) private - fNodeSubType: TALJSONNodeSubType; + FRawNodeValueInt64: int64; // contain the value Stored in an int64 (if the + // value can be store in an int64) fRawNodeValueStr: String; // contain the text representation of the node // WITHOUT any node subtype helper // for exemple for NumberLong(12391293) it's // store only 12391293 - FRawNodeValueInt64: int64; // contain the value Stored in an int64 (if the - // value can be store in an int64) fRawNodeValueDefined: TALJSONTextNodeValueDefined; + fNodeSubType: TALJSONNodeSubType; protected function GetNodeType: TALJSONNodeType; override; function GetNodeSubType: TALJSONNodeSubType; override; @@ -1115,166 +1211,72 @@ TALJSONNodeW = class(TObject) property RawNodeValueint64: int64 read fRawNodeValueint64; end; - {TALJSONDocumentA} + {TALJSONDocumentW} TALJSONDocumentW = class(TObject) private - FTag: NativeInt; - FDocumentNode: TALJSONNodeW; - FNodeIndentStr: String; - FOptions: TALJSONDocOptions; - FParseOptions: TALJSONParseOptions; - FDuplicates: TDuplicates; - FPathSeparator: Char; - FOnParseStartDocument: TAlJSONParseDocumentW; - FOnParseEndDocument: TAlJSONParseDocumentW; - FonParseText: TAlJSONParseTextEventW; - FonParseStartObject: TAlJSONParseObjectEventW; - FonParseEndObject: TAlJSONParseObjectEventW; - FonParseStartArray: TAlJSONParseArrayEventW; - FonParseEndArray: TAlJSONParseArrayEventW; - fFormatSettings: pALFormatSettingsW; - protected - procedure CheckActive; - procedure DoParseStartDocument; - procedure DoParseEndDocument; - procedure DoParseText(const Path: String; const name: String; const Args: array of const; NodeSubType: TALJSONNodeSubType); - procedure DoParseStartObject(const Path: String; const Name: String); - procedure DoParseEndObject(const Path: String; const Name: String); - procedure DoParseStartArray(const Path: String; const Name: String); - procedure DoParseEndArray(const Path: String; const Name: String); - Procedure ParseJSON( - const Buffer: String; - const ContainerNode: TALJSONNodeW); - Procedure ParseBSON( - const Buffer: Tbytes; - const ContainerNode: TALJSONNodeW); - procedure ReleaseDoc; - function GetActive: Boolean; - procedure SetActive(const Value: Boolean); - function GetChildNodes: TALJSONNodeListW; - function GetDocumentNode: TALJSONNodeW; - function GetNodeIndentStr: String; - function GetOptions: TALJSONDocOptions; - function GetParseOptions: TALJSONParseOptions; - function GetPathSeparator: Char; - procedure SetPathSeparator(const Value: Char); - function GetJSON: String; - function GetBSON: Tbytes; - procedure SetOptions(const Value: TALJSONDocOptions); - procedure SetParseOptions(const Value: TALJSONParseOptions); - procedure SetJSON(const Value: String); - procedure SetBSON(const Value: Tbytes); - procedure SetNodeIndentStr(const Value: String); - procedure SetDuplicates(const Value: TDuplicates); + class function DetectNodeTypeFromJSon(const Buffer: String): TALJSONNodeType; public - constructor Create(const aActive: Boolean = True); overload; virtual; - constructor Create(const aFormatSettings: TALFormatSettingsW; const aActive: Boolean = True); overload; virtual; - destructor Destroy; override; - procedure MultiThreadPrepare(const aOnlyChildList: Boolean = False); - procedure Clear; - function AddChild(const NodeName: String; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeW; overload; - function AddChild(const Path: array of String; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeW; overload; - function DeleteChild(const NodeName: String): boolean; overload; - function DeleteChild(const Path: array of String): boolean; overload; - function CreateNode(const NodeName: String; NodeType: TALJSONNodeType): TALJSONNodeW; - function ExtractNode: TALJSONNodeW; - function IsEmptyDoc: Boolean; - procedure LoadFromJSONString(const Str: String; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); - procedure LoadFromJSONStream(const Stream: TStream; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); - procedure LoadFromJSONFile(const FileName: String; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); - procedure LoadFromBSONBytes(const Bytes: Tbytes; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); - procedure LoadFromBSONStream(const Stream: TStream; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); - procedure LoadFromBSONFile(const FileName: String; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); - procedure SaveToJSONStream(const Stream: TStream; const Encoding: TEncoding); overload; - procedure SaveToJSONStream(const Stream: TStream); overload; - procedure SaveToJSONFile(const FileName: String; const Encoding: TEncoding); overload; - procedure SaveToJSONFile(const FileName: String); overload; - procedure SaveToJSONString(var Str: String); - procedure SaveToBSONStream(const Stream: TStream); - procedure SaveToBSONFile(const FileName: String); - procedure SaveToBSONBytes(var Bytes: Tbytes); - property ChildNodes: TALJSONNodeListW read GetChildNodes; - function GetChildNode(const nodeName: String): TALJSONNodeW; overload; - function GetChildNodeValueText(const nodeName: String; const default: String): String; overload; - function GetChildNodeValueFloat(const nodeName: String; const default: Double): Double; overload; - function GetChildNodeValueDateTime(const nodeName: String; const default: TDateTime): TDateTime; overload; - function GetChildNodeValueTimestamp(const nodeName: String; const default: TALBSONTimestamp): TALBSONTimestamp; overload; - function GetChildNodeValueObjectID(const nodeName: String; const default: String): String; overload; // return a hex string - function GetChildNodeValueInt32(const nodeName: String; const default: Integer): Integer; overload; - function GetChildNodeValueInt64(const nodeName: String; const default: Int64): Int64; overload; - function GetChildNodeValueBool(const nodeName: String; const default: Boolean): Boolean; overload; - function GetChildNodeValueJavascript(const nodeName: String; const default: String): String; overload; - function GetChildNodeValueRegEx(const nodeName: String; const default: String): String; overload; - function GetChildNodeValueRegExOptions(const nodeName: String; const default: TALPerlRegExOptions): TALPerlRegExOptions; overload; - function GetChildNodeValueBinary(const nodeName: String; const default: String): String; overload; // return a base64 encoded string - function GetChildNodeValueBinarySubType(const nodeName: String; const default: byte): byte; overload; - function GetChildNodeValueNull(const nodeName: String): Boolean; overload; - function GetChildNode(const path: array of String): TALJSONNodeW; overload; - function GetChildNodeValueText(const path: array of String; const default: String): String; overload; - function GetChildNodeValueFloat(const path: array of String; const default: Double): Double; overload; - function GetChildNodeValueDateTime(const path: array of String; const default: TDateTime): TDateTime; overload; - function GetChildNodeValueTimestamp(const path: array of String; const default: TALBSONTimestamp): TALBSONTimestamp; overload; - function GetChildNodeValueObjectID(const path: array of String; const default: String): String; overload; // return a hex string - function GetChildNodeValueInt32(const path: array of String; const default: Integer): Integer; overload; - function GetChildNodeValueInt64(const path: array of String; const default: Int64): Int64; overload; - function GetChildNodeValueBool(const path: array of String; const default: Boolean): Boolean; overload; - function GetChildNodeValueJavascript(const path: array of String; const default: String): String; overload; - function GetChildNodeValueRegEx(const path: array of String; const default: String): String; overload; - function GetChildNodeValueRegExOptions(const path: array of String; const default: TALPerlRegExOptions): TALPerlRegExOptions; overload; - function GetChildNodeValueBinary(const path: array of String; const default: String): String; overload; // return a base64 encoded string - function GetChildNodeValueBinarySubType(const path: array of String; const default: byte): byte; overload; - function GetChildNodeValueNull(const path: array of String): Boolean; overload; - procedure SetChildNodeValueText(const nodeName: String; const value: String); overload; - procedure SetChildNodeValueFloat(const nodeName: String; const value: Double); overload; - procedure SetChildNodeValueDateTime(const nodeName: String; const value: TDateTime); overload; - procedure SetChildNodeValueTimestamp(const nodeName: String; const value: TALBSONTimestamp); overload; - procedure SetChildNodeValueObjectID(const nodeName: String; const value: String); overload; - procedure SetChildNodeValueInt32(const nodeName: String; const value: Integer); overload; - procedure SetChildNodeValueInt64(const nodeName: String; const value: Int64); overload; - procedure SetChildNodeValueBool(const nodeName: String; const value: Boolean); overload; - procedure SetChildNodeValueJavascript(const nodeName: String; const value: String); overload; - procedure SetChildNodeValueRegEx(const nodeName: String; const value: String); overload; - procedure SetChildNodeValueRegExOptions(const nodeName: String; const value: TALPerlRegExOptions); overload; - procedure SetChildNodeValueBinary(const nodeName: String; const value: String); overload; - procedure SetChildNodeValueBinarySubType(const nodeName: String; const value: byte); overload; - procedure SetChildNodeValueNull(const nodeName: String); overload; - procedure SetChildNodeValueText(const path: array of String; const value: String); overload; - procedure SetChildNodeValueFloat(const path: array of String; const value: Double); overload; - procedure SetChildNodeValueDateTime(const path: array of String; const value: TDateTime); overload; - procedure SetChildNodeValueTimestamp(const path: array of String; const value: TALBSONTimestamp); overload; - procedure SetChildNodeValueObjectID(const path: array of String; const value: String); overload; - procedure SetChildNodeValueInt32(const path: array of String; const value: Integer); overload; - procedure SetChildNodeValueInt64(const path: array of String; const value: Int64); overload; - procedure SetChildNodeValueBool(const path: array of String; const value: Boolean); overload; - procedure SetChildNodeValueJavascript(const path: array of String; const value: String); overload; - procedure SetChildNodeValueRegEx(const path: array of String; const value: String); overload; - procedure SetChildNodeValueRegExOptions(const path: array of String; const value: TALPerlRegExOptions); overload; - procedure SetChildNodeValueBinary(const path: array of String; const value: String); overload; - procedure SetChildNodeValueBinarySubType(const path: array of String; const value: byte); overload; - procedure SetChildNodeValueNull(const path: array of String); overload; - property Node: TALJSONNodeW read GetDocumentNode; - property Active: Boolean read GetActive write SetActive; - property NodeIndentStr: String read GetNodeIndentStr write SetNodeIndentStr; - property Options: TALJSONDocOptions read GetOptions write SetOptions; - property ParseOptions: TALJSONParseOptions read GetParseOptions write SetParseOptions; - property Duplicates: TDuplicates read FDuplicates write SetDuplicates; // In pair with doSorted in options - property PathSeparator: Char read GetPathSeparator write SetPathSeparator; - property JSON: String read GetJSON write SetJSON; - property BSON: Tbytes read GetBSON write SetBSON; - property OnParseStartDocument: TAlJSONParseDocumentW read fOnParseStartDocument write fOnParseStartDocument; - property OnParseEndDocument: TAlJSONParseDocumentW read fOnParseEndDocument write fOnParseEndDocument; - property onParseText: TAlJSONParseTextEventW read fonParseText write fonParseText; - property onParseStartObject: TAlJSONParseObjectEventW read fonParseStartObject write fonParseStartObject; - property onParseEndObject: TAlJSONParseObjectEventW read fonParseEndObject write fonParseEndObject; - property onParseStartArray: TAlJSONParseArrayEventW read fonParseStartArray write fonParseStartArray; - property onParseEndArray: TAlJSONParseArrayEventW read fonParseEndArray write fonParseEndArray; - property FormatSettings: pALFormatSettingsW read fFormatSettings; // this is use only on GetText/OnParseText to retrieve float and DateTime formatted according to FormatSettings - property Tag: NativeInt read FTag write FTag; + class function Create: TALJSONNodeW; + class function CreateFromJSONString(const Str: String; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeW; + class function CreateFromJSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeW; + class function CreateFromJSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeW; + class function CreateFromBSONBytes(const Bytes: Tbytes; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeW; + class function CreateFromBSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeW; + class function CreateFromBSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeW; + class procedure ParseJSONString( + const Str: String; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); + class procedure ParseJSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); + class procedure ParseJSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); + class procedure ParseBSONBytes( + const Bytes: Tbytes; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); + class procedure ParseBSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); + class procedure ParseBSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); end; {misc constants} var ALDefaultJsonNodeIndentW: String; // var instead of const to avoid new ansitring on assign + ALDefaultJsonPathSeparatorW: Char; ALJsonISODateFormatSettingsW: TALFormatSettingsW; {misc function} @@ -1469,7 +1471,7 @@ function ALJSONTryStrToRegExA(const S: AnsiString; out RegEx: AnsiString; out Re // aRegEx.RegEx := Value.Expression; // result := aRegEx.Compile(false{RaiseException}); //finally - // aRegEx.Free; + // ALFreeAndNil(aRegEx); //end; end; @@ -1876,123 +1878,19 @@ function ALCreateJSONNodeA(const NodeName: AnsiString; NodeType: TALJSONNodeType end; end; -{*****************************************************************} -constructor TALJSONDocumentA.create(const aActive: Boolean = True); -begin - inherited create; - FDocumentNode:= nil; - FParseOptions:= []; - FDuplicates := dupAccept; - FPathSeparator := '.'; - FOnParseStartDocument := nil; - FOnParseEndDocument := nil; - FonParseText := nil; - FonParseStartObject := nil; - FonParseEndObject := nil; - FonParseStartArray := nil; - FonParseEndArray := nil; - FOptions := []; - NodeIndentStr := ALDefaultJsonNodeIndentA; - fFormatSettings := @ALDefaultFormatSettingsA; - FTag := 0; - SetActive(aActive); -end; - -{************************************************************************************************************} -constructor TALJSONDocumentA.Create(const aFormatSettings: TALFormatSettingsA; const aActive: Boolean = True); -begin - create(aActive); - if @aFormatSettings <> @ALDefaultFormatSettingsA then begin - new(fFormatSettings); - fFormatSettings^ := aFormatSettings; - end; -end; - -{**********************************} -destructor TALJSONDocumentA.Destroy; -begin - if fFormatSettings <> @ALDefaultFormatSettingsA then dispose(fFormatSettings); - ReleaseDoc; - inherited; -end; - -{***********************************************************************************} -procedure TALJSONDocumentA.MultiThreadPrepare(const aOnlyChildList: Boolean = False); -begin - node.MultiThreadPrepare(aOnlyChildList); -end; - -{*******************************} -procedure TALJSONDocumentA.Clear; -begin - releaseDoc; - Active := true; -end; - -{****************************************} -{Returns the value of the Active property. - GetActive is the read implementation of the Active property.} -function TALJSONDocumentA.GetActive: Boolean; -begin - Result := Assigned(FDocumentNode); -end; - -{*************************************} -{Sets the value of the Active property. - SetActive is the write implementation of the Active property. - *Value is the new value to set.} -procedure TALJSONDocumentA.SetActive(const Value: Boolean); -begin - if Value <> GetActive then begin - if Value then begin - FDocumentNode := TALJSONObjectNodeA.Create; - FDocumentNode.SetOwnerDocument(Self); - end - else ReleaseDoc; - end; -end; - -{**************} -{The JSON format - There are just a few rules that you need to remember: - *Objects are encapsulated within opening and closing brackets { } { - *An empty object can be represented by { } { - *Arrays are encapsulated within opening and closing square brackets [ ] - *An empty array can be represented by [ ] - *A member is represented by a key-value pair - *The key of a member should be contained in double quotes. (JavaScript does not require this. JavaScript and some parsers will tolerate single-quotes) - *Each member should have a unique key within an object structure - *The value of a member must be contained in double quotes if it's a string (JavaScript and some parsers will tolerates single-quotes) - *Boolean values are represented using the true or false literals in lower case - *Number values are represented using double-precision floating-point format. Scientific notation is supported - *Numbers should not have leading zeroes - *"Offensive"" characters in a string need to be escaped using the backslash character - *Null values are represented by the null literal in lower case - *Other object types, such as dates, are not properly supported and should be converted to strings. It becomes the responsability of the parser/client to manage this. - *Each member of an object or each array value must be followed by a comma if it's not the last one - *The common extension for json files is '.json' - *The mime type for json files is 'application/json'} -Procedure TALJSONDocumentA.ParseJSON( - const RawJSONStream: TStream; - const RawJSONString: AnsiString; - const ContainerNode: TALJSONNodeA); +{*****************************************************} +class function TALJSONDocumentA.DetectNodeTypeFromJSON( + const RawJSONStream: TStream; + const RawJSONString: AnsiString): TALJSONNodeType; Const BufferSize: integer = 8192; Var Buffer: AnsiString; BufferLength: Integer; BufferPos: Integer; - CurrName: AnsiString; - CurrIndex: integer; - CurrValue: ansiString; - NotSaxMode: Boolean; - WorkingNode: TALJSONNodeA; - NamePaths: TALNVStringListA; - ObjectPaths: TALIntegerList; - DecodeJSONReferences: boolean; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function ExpandBuffer: boolean; overload; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function ExpandBuffer: boolean; Var ByteReaded, Byte2Read: Integer; Begin if not assigned(RawJSONStream) then begin @@ -2027,11441 +1925,10585 @@ procedure TALJSONDocumentA.SetActive(const Value: Boolean); else result := True; end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function ExpandBuffer(var PosToKeepSync: Integer): boolean; overload; - var P1: integer; - begin - P1 := BufferPos; - result := ExpandBuffer; - PosToKeepSync := PosToKeepSync - (P1 - BufferPos); +var BOMSequence: integer; + c: ansiChar; + +Begin + + //init result + result := ntText; + + //init Buffer + if assigned(RawJSONStream) then begin + Buffer := ''; + BufferLength := 0; + BufferPos := 1; + ExpandBuffer; + end + else begin + Buffer := RawJSONString; + BufferLength := length(RawJSONString); + BufferPos := 1; end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function GetPathStr(Const ExtraItems: ansiString = ''): ansiString; - var I, L, P, Size: Integer; - LB: ansiChar; - S: AnsiString; - begin - LB := PathSeparator; - Size := length(ExtraItems); - if size <> 0 then Inc(Size, 1{length(LB)}); - for I := 1 to NamePaths.Count - 1 do Inc(Size, Length(NamePaths.Names[I]) + 1{length(LB)}); - SetLength(Result, Size); - P := 1; - for I := 1 to NamePaths.Count - 1 do begin - S := NamePaths.Names[I]; - L := Length(S); - if L <> 0 then begin - ALMove(pointer(S)^, Pbyte(Result)[(P-1){*sizeOf(ansiChar)}], L{*sizeOf(ansiChar)}); - Inc(P, L); - end; - L := 1{length(LB)}; - if ((i <> NamePaths.Count - 1) or - (ExtraItems <> '')) and - (((NotSaxMode) and (TALJSONNodeA(NamePaths.Objects[I]).nodetype <> ntarray)) or - ((not NotSaxMode) and (TALJSONNodeType(NamePaths.Objects[I]) <> ntarray))) then begin - ALMove(LB, Pbyte(Result)[(P-1){*sizeOf(ansiChar)}], L{*sizeOf(ansiChar)}); - Inc(P, L); - end; - end; - if ExtraItems <> '' then begin - L := length(ExtraItems); - ALMove(pointer(ExtraItems)^, Pbyte(Result)[(P-1){*sizeOf(ansiChar)}], L{*sizeOf(ansiChar)}); - Inc(P, L); + //-- + BOMSequence := 0; // hide warnings + While (BufferPos <= BufferLength) or ExpandBuffer do begin + c := Buffer[BufferPos]; + If c <= ' ' then inc(bufferPos) + else if ((bufferPos = 1) and (c=#$EF)) then begin + BOMSequence := 1; + inc(bufferPos); + end + else if ((bufferPos = 2) and (BOMSequence=1) and (c=#$BB)) then begin + BOMSequence := 2; + inc(bufferPos); + end + else if ((bufferPos = 3) and (BOMSequence=2) and (c=#$BF)) then begin + BOMSequence := 0; + inc(bufferPos); + end + else begin + if c = '{' then result := ntObject + else if c = '[' then result := ntarray + else result := ntText; + break; end; - setlength(result,P-1); end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseTextWithIndex( - const index: integer; - const Args: array of const; - const NodeSubType: TALJSONNodeSubType); - begin - DoParseText(GetPathStr('[' + ALIntToStrA(index) + ']'), '', Args, NodeSubType) - end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseTextWithName( - const name: AnsiString; - const Args: array of const; - const NodeSubType: TALJSONNodeSubType); - begin - DoParseText(GetPathStr(Name), Name, Args, NodeSubType) +{***************************************************} +class function TALJSONDocumentA.Create: TALJSONNodeA; +begin + result := ALCreateJSONNodeA('', ntObject); +end; + +{**************************************************************************************************************************************************} +class function TALJSONDocumentA.CreateFromJSONString(const Str: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; +begin + var LNodeType := DetectNodeTypeFromJSON(nil, Str); + if LNodeType in [ntObject, ntArray] then result := ALCreateJSONNodeA('', LNodeType) + else AlJSONDocErrorA(cALJSONParseError); + try + result.LoadFromJSONString(Str, Options); + except + ALFreeAndNil(Result); + raise; end; +end; - {~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseText( - const Index: integer; - const Name: AnsiString; - const Args: array of const; - const NodeSubType: TALJSONNodeSubType); - begin - if Assigned(fonParseText) then begin - if notSaxMode then begin - if WorkingNode.nodetype=ntarray then _DoParseTextWithIndex(Index, Args, NodeSubType) - else _DoParseTextWithName(Name, Args, NodeSubType); - end - else begin - if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); - if TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntArray then _DoParseTextWithIndex(Index, Args, NodeSubType) - else _DoParseTextWithName(Name, Args, NodeSubType); - end; - end; +{**************************************************************************************************************************************************} +class function TALJSONDocumentA.CreateFromJSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; +begin + var LNodeType := DetectNodeTypeFromJSON(Stream, ''); + if LNodeType in [ntObject, ntArray] then result := ALCreateJSONNodeA('', LNodeType) + else AlJSONDocErrorA(cALJSONParseError); + try + result.LoadFromJSONStream(Stream, Options); + except + ALFreeAndNil(Result); + raise; end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseStartObject(const Name: AnsiString); - begin - DoParseStartObject(GetPathStr, Name); +{*************************************************************************************************************************************************} +class function TALJSONDocumentA.CreateFromJSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; +Var LfileStream: TfileStream; +Begin + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + Result := CreateFromJSONStream(LfileStream, Options); + finally + ALFreeAndNil(LfileStream); end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseEndObject; - begin - if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); - DoParseEndObject(GetPathStr, NamePaths.Names[NamePaths.Count - 1]) +{*****************************************************************************************************************************************************} +class function TALJSONDocumentA.CreateFromJSONFile(const FileName: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; +begin + Result := CreateFromJSONFile(String(FileName), Options); +end; + +{**************************************************************************************************************************************************} +class function TALJSONDocumentA.CreateFromBSONString(const Str: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; +begin + result := ALCreateJSONNodeA('', ntObject); + try + result.LoadFromBSONString(Str, Options); + except + ALFreeAndNil(Result); + raise; end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseStartArray(const index: AnsiString); - begin - DoParseStartArray(GetPathStr, index) +{**************************************************************************************************************************************************} +class function TALJSONDocumentA.CreateFromBSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; +begin + result := ALCreateJSONNodeA('', ntObject); + try + result.LoadFromBSONStream(Stream, Options); + except + ALFreeAndNil(Result); + raise; end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseEndArray; - begin - if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); - DoParseEndArray(GetPathStr, NamePaths.Names[NamePaths.Count - 1]); +{*************************************************************************************************************************************************} +class function TALJSONDocumentA.CreateFromBSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; +Var LfileStream: TfileStream; +Begin + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + result := CreateFromBSONStream(LfileStream, Options); + finally + ALFreeAndNil(LfileStream); end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _AddIndexItemToNamePath(const index: integer; Obj: Pointer); - var S1: ansiString; - begin - setlength(S1,sizeOf(Integer) {div sizeOF(ansiChar)}); // off course sizeOf(Integer) must be a multiple of sizeOf(ansiChar) but it's always the case - ALmove(index, pointer(S1)^, sizeOf(Integer)); - NamePaths.AddNameValueObject('[' + ALIntToStrA(Index) + ']', S1, Obj) +{*****************************************************************************************************************************************************} +class function TALJSONDocumentA.CreateFromBSONFile(const FileName: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeA; +begin + Result := CreateFromBSONFile(String(FileName), Options); +end; + +{***********************************************} +class procedure TALJSONDocumentA.ParseJSONString( + const Str: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +begin + var LJsonNode: TALJsonNodeA; + var LNodeType := DetectNodeTypeFromJSON(nil, Str); + if LNodeType in [ntObject, ntArray] then LJsonNode := ALCreateJSONNodeA('', LNodeType) + else AlJSONDocErrorA(cALJSONParseError); + try + LJsonNode.ParseJSONString( + Str, + OnParseText, + OnParseStartObject, + OnParseEndObject, + OnParseStartArray, + OnParseEndArray, + Options); + finally + ALFreeAndNil(LJsonNode); end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _AddNameItemToNamePath(const name: AnsiString; Obj: Pointer); - begin - NamePaths.AddNameValueObject(Name, #$ff#$ff#$ff#$ff, Obj) +{***********************************************} +class procedure TALJSONDocumentA.ParseJSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +begin + var LJsonNode: TALJsonNodeA; + var LNodeType := DetectNodeTypeFromJSON(Stream, ''); + if LNodeType in [ntObject, ntArray] then LJsonNode := ALCreateJSONNodeA('', LNodeType) + else AlJSONDocErrorA(cALJSONParseError); + try + LJsonNode.ParseJSONStream( + Stream, + OnParseText, + OnParseStartObject, + OnParseEndObject, + OnParseStartArray, + OnParseEndArray, + Options); + finally + ALFreeAndNil(LJsonNode); end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _AddItemToNamePath(index: integer; const name: AnsiString; Obj: Pointer); - begin - if notSaxMode then begin - if WorkingNode.nodetype=ntarray then _AddIndexItemToNamePath(Index, Obj) - else _AddNameItemToNamePath(name, Obj); - end - else begin - if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); - if TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntarray then _AddIndexItemToNamePath(Index, Obj) - else _AddNameItemToNamePath(name, Obj); - end; +{*********************************************} +class procedure TALJSONDocumentA.ParseJSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +Var LfileStream: TfileStream; +Begin + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + ParseJSONStream( + LfileStream, + OnParseText, + OnParseStartObject, + OnParseEndObject, + OnParseStartArray, + OnParseEndArray, + Options); + finally + ALFreeAndNil(LfileStream); end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createInt64Node(index: integer; const name: AnsiString; const value: ansiString): boolean; - var LNode: TALJSONNodeA; - LInt64: Int64; - begin - if ALJSONTryStrToInt64A(value, LInt64) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetInt64(LInt64); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(index, Name, [LInt64], nstInt64) - end - else begin - _DoParseText(index, Name, [LInt64], nstInt64) - end; - end - else result := False; +{*********************************************} +class procedure TALJSONDocumentA.ParseJSONFile( + const FileName: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +begin + ParseJSONFile( + String(FileName), + OnParseText, + OnParseStartObject, + OnParseEndObject, + OnParseStartArray, + OnParseEndArray, + Options); +end; + +{***********************************************} +class procedure TALJSONDocumentA.ParseBSONString( + const Str: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +begin + var LJsonNode := ALCreateJSONNodeA('', ntObject); + try + LJsonNode.ParseBSONString( + Str, + OnParseText, + OnParseStartObject, + OnParseEndObject, + OnParseStartArray, + OnParseEndArray, + Options); + finally + ALFreeAndNil(LJsonNode); end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createInt32Node(index: integer; const name: AnsiString; const value: ansiString): boolean; - var LNode: TALJSONNodeA; - LInt32: Int32; - begin - if ALJSONTryStrToInt32A(value, LInt32) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setint32(LInt32); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(index, Name, [LInt32], nstInt32) - end - else begin - _DoParseText(index, Name, [LInt32], nstInt32) - end - end - else result := False; +{***********************************************} +class procedure TALJSONDocumentA.ParseBSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +begin + var LJsonNode := ALCreateJSONNodeA('', ntObject); + try + LJsonNode.ParseBSONStream( + Stream, + OnParseText, + OnParseStartObject, + OnParseEndObject, + OnParseStartArray, + OnParseEndArray, + Options); + finally + ALFreeAndNil(LJsonNode); end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createTextNode(index: integer; const name: AnsiString; const value: ansiString): boolean; - var LNode: TALJSONNodeA; - begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Settext(value); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(index, Name, [value], nstText) - end - else begin - _DoParseText(index, Name, [value], nstText) - end - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createFloatNode(index: integer; const name: AnsiString; const value: ansiString): boolean; - var LNode: TALJSONNodeA; - LDouble: Double; - begin - if ALTryStrToFloat(value, LDouble, ALDefaultFormatSettingsA) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetFloat(LDouble); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(index, Name, [LDouble], nstFloat) - end - else begin - _DoParseText(index, Name, [LDouble], nstFloat) - end - end - else result := False; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createBinaryNode(index: integer; const name: AnsiString; const value: ansiString): boolean; - var LNode: TALJSONNodeA; - LBinSubtype: byte; - LBinData: ansiString; - begin - if ALJSONTryStrToBinaryA(value, LBinData, LBinSubtype) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.setbinary(LBinData, LBinSubtype); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(index, Name, [LBinData, LBinSubtype], nstBinary); - end - else begin - _DoParseText(index, Name, [LBinData, LBinSubtype], nstBinary); - end - end - else result := False; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createObjectIDNode(index: integer; const name: AnsiString; const value: ansiString): boolean; - var LNode: TALJSONNodeA; - LObjectID: AnsiString; - begin - if ALJSONTryStrToObjectIDA(value, LObjectID) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetObjectID(LObjectID); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(index, Name, [LObjectID], nstObjectID) - end - else begin - _DoParseText(index, Name, [LObjectID], nstObjectID) - end; - end - else result := False; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createBooleanNode(index: integer; const name: AnsiString; const value: ansiString): boolean; - var LNode: TALJSONNodeA; - LBool: Boolean; - begin - if value = 'true' then LBool := true - else if value = 'false' then LBool := false - else begin - result := False; - exit; - end; - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setbool(LBool); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(index, Name, [LBool], nstBoolean); - end - else begin - _DoParseText(index, Name, [LBool], nstBoolean); - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createDateTimeNode(index: integer; const name: AnsiString; const value: ansiString): boolean; - var LNode: TALJSONNodeA; - LDateTime: TdateTime; - begin - if ALJSONTryStrToDateTimeA(value, LDateTime) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setdatetime(LDateTime); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(index, Name, [LDateTime], nstDateTime); - end - else begin - _DoParseText(index, Name, [LDateTime], nstDateTime); - end; - end - else result := False; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createTimestampNode(index: integer; const name: AnsiString; const value: ansiString): boolean; - var LNode: TALJSONNodeA; - LTimestamp: TALBSONTimestamp; - begin - if ALJSONTryStrToTimestampA(value, LTimestamp) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetTimestamp(LTimestamp); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(index, Name, [LTimestamp.W1, LTimestamp.W2], nstTimeStamp); - end - else begin - _DoParseText(index, Name, [LTimestamp.W1, LTimestamp.W2], nstTimeStamp); - end; - end - else result := False; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createnullNode(index: integer; const name: AnsiString; const value: ansiString): boolean; - var LNode: TALJSONNodeA; - begin - if value = 'null' then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setnull(true); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(index, Name, ['null'], nstNull); - end - else begin - _DoParseText(index, Name, ['null'], nstNull); - end; - end - else result := False; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createRegExNode(index: integer; const name: AnsiString; const value: ansiString): boolean; - var LNode: TALJSONNodeA; - LRegEx: ansiString; - LRegExOptions: TALPerlRegExOptions; - begin - if ALJSONTryStrToRegExA(value, LRegEx, LRegExOptions) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetRegEx(LRegEx, LRegExOptions); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(index, Name, [LRegEx, Byte(LRegExOptions)], nstRegEx) - end - else begin - _DoParseText(index, Name, [LRegEx, Byte(LRegExOptions)], nstRegEx) - end; - end - else result := False; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createJavascriptNode(index: integer; const name: AnsiString; const value: ansiString): boolean; - var LNode: TALJSONNodeA; - begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetJavascript(value); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(index, Name, [value], nstJavascript); - end - else begin - _DoParseText(index, Name, [value], nstJavascript); - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createNode(index: integer; const name: AnsiString; const value: ansiString; AQuotedValue: Boolean); - begin - if AQuotedValue then begin - _createTextNode(index, Name, Value); - exit; - end; - if _createFloatNode(index, Name, Value) then exit; // << we have the same problem as javascript, if we put here a big number like (by exemple) 9223372036854775808 - // << then the stored value will be different because of double precision that is less than int64 precision - // << it's the way javascript json work, it's have no room for int / int64 :( - // << if we want to have the possibility to store int64 precision then we must use node subtype helper - // << like NumberLong(9223372036854775808) - if _createBooleanNode(index, Name, Value) then exit; - if _createNullNode(index, Name, Value) then exit; - if _createInt32Node(index, Name, Value) then exit; - if _createInt64Node(index, Name, Value) then exit; - if _createDateTimeNode(index, Name, Value) then exit; - if _createBinaryNode(index, Name, Value) then exit; - if _createObjectIDNode(index, Name, Value) then exit; - if _createRegExNode(index, Name, Value) then exit; - if _createTimeStampNode(index, Name, Value) then exit; - _createJavascriptNode(index, Name, Value); - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _extractLastIndexFromNamePath: integer; - begin - if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); - ALMove(pointer(namePaths.ValueFromIndex[namepaths.Count - 1])^,result,sizeOf(integer)); - end; - - {~~~~~~~~~~~~~~~~~~~~} - procedure AnalyzeNode; - Var LNode: TALJSONNodeA; - LNodeType: TALJSONNodeType; - LQuoteChar: AnsiChar; - LNameValueSeparator: ansiChar; - LInSingleQuote: boolean; - LInDoubleQuote: boolean; - LInSlashQuote: boolean; - LInSquareBracket: integer; - LInRoundBracket: integer; - LInCurlyBracket: integer; - P1, P2: Integer; - c: ansiChar; - Begin - - {$REGION 'init current char (c)'} - c := Buffer[BufferPos]; - {$ENDREGION} - - {$REGION 'end Object/Array'} - // ... } .... - // ... ] .... - if c in ['}',']'] then begin // ... } ... - // ^BufferPos - - //Reset the CurrIndex - CurrIndex := -1; - - //error if Paths.Count = 0 (mean one end object/array without any starting) - if assigned(ObjectPaths) then begin - if (ObjectPaths.Count = 0) then AlJSONDocErrorA(cALJSONParseError); - end - else begin - if (NamePaths.Count = 0) then AlJSONDocErrorA(cALJSONParseError); - end; - - //if we are not in sax mode - if NotSaxMode then begin - - //init anode to one level up - if assigned(ObjectPaths) then LNode := TALJSONNodeA(ObjectPaths.Objects[ObjectPaths.Count - 1]) - else LNode := TALJSONNodeA(NamePaths.Objects[NamePaths.Count - 1]); - - //if anode <> workingNode aie aie aie - if (LNode <> WorkingNode) then AlJSONDocErrorA(CALJSONParseError); - - //calculate anodeTypeInt - LNodeType := LNode.NodeType; - if not (LNodeType in [ntObject, ntarray]) then AlJSONDocErrorA(cALJSONParseError); - - //check that the end object/array correspond to the aNodeType - if ((c = '}') and - (LNodeType <> ntObject)) or - ((c = ']') and - (LNodeType <> ntarray)) then AlJSONDocErrorA(CALJSONParseError); - - //if working node <> containernode then we can go to one level up - If WorkingNode<>ContainerNode then begin - - //init WorkingNode to the parentNode - WorkingNode := WorkingNode.ParentNode; - - //update CurrIndex if WorkingNode.NodeType = ntArray - if assigned(ObjectPaths) then begin - if WorkingNode.NodeType = ntArray then CurrIndex := ObjectPaths[Objectpaths.Count - 1] + 1; - end - else begin - if WorkingNode.NodeType = ntArray then CurrIndex := _extractLastIndexFromNamePath + 1; - end; - - end - - //if working node = containernode then we can no go to the parent node so set WorkingNode to nil - Else WorkingNode := nil; - - end - - //if we are in sax mode - else begin - - //calculate anodeTypeInt - LNodeType := TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]); - if not (LNodeType in [ntObject,ntarray]) then AlJSONDocErrorA(cALJSONParseError); - - //check that the end object/array correspond to the aNodeType - if ((c = '}') and - (LNodeType <> ntObject)) or - ((c = ']') and - (LNodeType <> ntarray)) then AlJSONDocErrorA(CALJSONParseError); - - //update CurrIndex if WorkingNode.NodeType = ntArray - if (Namepaths.Count >= 2) and - (TALJSONNodeType(NamePaths.Objects[Namepaths.Count - 2]) = ntarray) then CurrIndex := _extractLastIndexFromNamePath + 1; - - end; - - //call the DoParseEndObject/array event - if Assigned(fonParseEndObject) then begin - if LNodeType = ntObject then _DoParseEndObject - else _DoParseEndArray; - end; - - //delete the last entry from the path - if assigned(ObjectPaths) then ObjectPaths.Delete(ObjectPaths.Count - 1) - else NamePaths.Delete(NamePaths.Count - 1); - - //update BufferPos - BufferPos := BufferPos + 1; // ... } ... - // ^BufferPos - - //finallly exit from this procedure, everything was done - exit; - - end; - {$ENDREGION} - - {$REGION 'Begin Object/Array Without NAME'} - // ... { .... - // ... [ .... - if c in ['{','['] then begin // ... { ... - // ^BufferPos - - //if we are not in sax mode - if NotSaxMode then begin - - //if workingnode = nil then it's mean we are outside the containerNode - if not assigned(WorkingNode) then AlJSONDocErrorA(CALJSONParseError); - - //Node without name can be ONLY present inside an array node - if (CurrIndex < 0) or - (WorkingNode.nodetype <> ntarray) then AlJSONDocErrorA(CALJSONParseError); - - //create the node according the the braket char and add it to the workingnode - if c = '{' then LNode := CreateNode('', ntObject) - else LNode := CreateNode('', ntarray); - try - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - - //set that the current working node will be now the new node newly created - WorkingNode := LNode; - - //update the path - if assigned(ObjectPaths) then ObjectPaths.AddObject(CurrIndex, WorkingNode) - else _AddItemToNamePath(CurrIndex, '', WorkingNode); - - end - - //if we are in sax mode - else begin - - //Node without name can be ONLY present inside an array node - if (CurrIndex < 0) or - (NamePaths.Count = 0) or - (TALJsonNodeType(NamePaths.Objects[Namepaths.Count - 1]) <> ntarray) then AlJSONDocErrorA(CALJSONParseError); - - //update the path - if c = '{' then LNodeType := ntObject - else LNodeType := ntArray; - _AddItemToNamePath(CurrIndex, '', pointer(LNodeType)); - - end; - - //call the DoParseStartObject/array event - if c = '{' then begin - if Assigned(fonParseStartObject) then _DoParseStartObject(''); - CurrIndex := -1; - end - else begin - if Assigned(fonParseStartArray) then _DoParseStartArray(''); - CurrIndex := 0; - end; - - //update BufferPos - BufferPos := BufferPos + 1; // ... { ... - // ^BufferPos - - //finallly exit from this procedure, everything was done - exit; - - end; - {$ENDREGION} - - {$REGION 'extract the quoted name part'} - // "" : "" - // "name" : "value" - // "name" : 1.23 - // "name" : true - // "name" : false - // "name" : null - // "name" : ISODATE('1/1/2001') - // "name" : function(){return(new Date).getTime()}, ...} - // "name" : new Date(''Dec 03, 1924'') - // "name" : { ... } - // "name" : [ ... ] - // 'name' : '...' - // "value" - // 'value' - LQuoteChar := #0; - if c in ['"',''''] then begin // ... " ... - // ^BufferPos - LQuoteChar := c; // " - P1 := BufferPos + 1; // ... "...\"..." - // ^P1 - If P1 + 1 > BufferLength then ExpandBuffer(P1); - While P1 <= BufferLength do begin - - c := Buffer[P1]; - - If (c = '\') and - (P1 < BufferLength) and - (Buffer[P1 + 1] in ['\', LQuoteChar]) then inc(p1, 2) // ... "...\"..." - // ^^^P1 - else if c = LQuoteChar then begin - ALCopyStr(Buffer,CurrName,BufferPos + 1,P1-BufferPos - 1); - if DecodeJSONReferences then ALJavascriptDecodeV(CurrName); // ..."... - break; - end - else inc(P1); // ... "...\"..." - // ^^^^^^^^^P1 - - if P1 + 1 > BufferLength then ExpandBuffer(P1); - - end; - if P1 > BufferLength then AlJSONDocErrorA(CALJSONParseError); - BufferPos := P1 + 1; // ... "...\"..." - // ^^^^^^^^^^BufferPos - end - {$ENDREGION} - - {$REGION 'extract the unquoted name part'} - // name : "value" - // name : 1.23 - // name : true - // name : false - // name : null - // name : ISODATE('1/1/2001') - // name : function(){return(new Date).getTime()}, ...} - // name : new Date('Dec 03, 1924') - // name : { ... } - // name : [ ... ] - // 1.23 - // true - // false - // null - // ISODATE('1/1/2001') - // function(){return(new Date).getTime()}, ...} - // new Date('Dec 03, 1924') - else begin - - LInSingleQuote := False; - LInDoubleQuote := False; - LInSquareBracket := 0; - LInRoundBracket := 0; - LInCurlyBracket := 0; - - While (BufferPos <= BufferLength) or ExpandBuffer do begin - If Buffer[BufferPos] <= ' ' then inc(bufferPos) - else break; - end; - if BufferPos > BufferLength then AlJSONDocErrorA(CALJSONParseError); - - P1 := BufferPos; // ... new Date('Dec 03, 1924'), .... - // ^P1 - While (P1 <= BufferLength) or ExpandBuffer(P1) do begin - - c := Buffer[P1]; - - if (not LInSingleQuote) and - (not LInDoubleQuote) and - (LInSquareBracket = 0) and - (LInRoundBracket = 0) and - (LInCurlyBracket = 0) and - (c in [',', '}', ']', ':']) then begin - P2 := P1-1; - While P2 >= BufferPos do begin - If Buffer[P2] <= ' ' then dec(P2) - else break; - end; - ALCopyStr(Buffer,CurrName,BufferPos,P2-BufferPos+1); // new Date('Dec 03, 1924') - break; - end - else if (c = '"') then begin - if (P1 <= 1) or - (Buffer[P1 - 1] <> '\') then LInDoubleQuote := (not LInDoubleQuote) and (not LInSingleQuote); - end - else if (c = '''') then begin - if (P1 <= 1) or - (Buffer[P1 - 1] <> '\') then LInSingleQuote := (not LInSingleQuote) and (not LInDoubleQuote) - end - else if (not LInSingleQuote) and - (not LInDoubleQuote) then begin - if (c = '[') then inc(LInSquareBracket) - else if (c = ']') then dec(LInSquareBracket) - else if (c = '(') then inc(LInRoundBracket) - else if (c = ')') then dec(LInRoundBracket) - else if (c = '}') then inc(LInCurlyBracket) - else if (c = '{') then dec(LInCurlyBracket); - end; - - inc(P1); // ... new Date('Dec 03, 1924'), .... - // ^^^^^^^^^^^^^^^^^^^^^^^^^P1 - - end; - if P1 > BufferLength then AlJSONDocErrorA(CALJSONParseError); - BufferPos := P1; // ... new Date('Dec 03, 1924'), .... - // ^BufferPos - - end; - {$ENDREGION} - - {$REGION 'extract the name value separator part'} - LNameValueSeparator := #0; - While (BufferPos <= BufferLength) or ExpandBuffer do begin - If Buffer[BufferPos] <= ' ' then inc(BufferPos) - else begin - LNameValueSeparator := Buffer[BufferPos]; - break; - end; - end; - if BufferPos > BufferLength then AlJSONDocErrorA(CALJSONParseError); // .... : .... - // ^BufferPos - {$ENDREGION} - - {$REGION 'if aNameValueSeparator is absent then it is just a value'} - if LNameValueSeparator <> ':' then begin - - //Node without name can be ONLY present inside an array node - if NotSaxMode then begin - if not assigned(WorkingNode) then AlJSONDocErrorA(CALJSONParseError); - if (CurrIndex < 0) or - (WorkingNode.nodetype <> ntarray) then AlJSONDocErrorA(CALJSONParseError); - end - else begin - if (CurrIndex < 0) or - (NamePaths.Count = 0) or - (TALJSONNodeType(NamePaths.Objects[Namepaths.Count - 1]) <> ntarray) then AlJSONDocErrorA(CALJSONParseError); - end; - - //create the node - _createNode(CurrIndex,'',CurrName,LQuoteChar in ['"','''']); - - //increase the CurrIndex - inc(CurrIndex); - - //finallly exit from this procedure, everything was done - exit; - - end; - {$ENDREGION} - - {$REGION 'remove the blank space between the name valueeparator and the value'} - inc(BufferPos); // ... : .... - // ^BufferPos - While (BufferPos <= BufferLength) or ExpandBuffer do begin - If Buffer[BufferPos] <= ' ' then inc(BufferPos) - else break; - end; - if BufferPos > BufferLength then AlJSONDocErrorA(CALJSONParseError); // .... " .... - // ^BufferPos - {$ENDREGION} - - {$REGION 'init current char (c)'} - c := Buffer[BufferPos]; - {$ENDREGION} - - {$REGION 'if the value is an object/array'} - // name : { ... } - // name : [ ... ] - if c in ['{','['] then begin // ... { ... - // ^BufferPos - - //if we are not in sax mode - if NotSaxMode then begin - - //if workingnode = nil then it's mean we are outside the containerNode - if not assigned(WorkingNode) then AlJSONDocErrorA(CALJSONParseError); - - //Node withe name MUST be ONLY present inside an object node - if (CurrIndex >= 0) or - (WorkingNode.nodetype <> ntObject) then AlJSONDocErrorA(CALJSONParseError); - - //create the node according the the braket char and add it to the workingnode - if c = '{' then LNode := CreateNode(CurrName, ntObject) - else LNode := CreateNode(CurrName, ntarray); - try - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - - //set that the current working node will be now the new node newly created - WorkingNode := LNode; - - //update the path - if assigned(ObjectPaths) then ObjectPaths.AddObject(-1, WorkingNode) - else _AddItemToNamePath(-1, CurrName, WorkingNode); - - end - - //if we are in sax mode - else begin - - //Node withe name MUST be ONLY present inside an object node - if (CurrIndex >= 0) or - (NamePaths.Count = 0) or - (TALJsonNodeType(NamePaths.Objects[NamePaths.Count - 1]) <> ntobject) then AlJSONDocErrorA(CALJSONParseError); - - //update the path - if c = '{' then LNodeType := ntObject - else LNodeType := ntArray; - _AddItemToNamePath(-1, CurrName, pointer(LNodeType)); - - end; - - //call the DoParseStartObject/array event and update the CurrIndex if it's an array - if c = '{' then begin - if Assigned(fonParseStartObject) then _DoParseStartObject(CurrName) - end - else begin - if Assigned(fonParseStartArray) then _DoParseStartArray(CurrName); - CurrIndex := 0; - end; - - //update BufferPos - BufferPos := BufferPos + 1; // ... { ... - // ^BufferPos - - //finallly exit from this procedure, everything was done - exit; - - end; - {$ENDREGION} - - {$REGION 'if the value is a quoted string'} - // name : "value" - // name : 'value' - LQuoteChar := #0; - if c in ['"',''''] then begin // ... " ... - // ^BufferPos - - LQuoteChar := c; // " - P1 := BufferPos + 1; // ... "...\"..." - // ^P1 - If P1 + 1 > BufferLength then ExpandBuffer(P1); - While P1 <= BufferLength do begin - - c := Buffer[P1]; - - If (c = '\') and - (P1 < BufferLength) and - (Buffer[P1 + 1] in ['\', LQuoteChar]) then inc(p1, 2) // ... "...\"..." - // ^^^P1 - else if c = LQuoteChar then begin - ALCopyStr(Buffer,currValue,BufferPos + 1,P1-BufferPos - 1); - if DecodeJSONReferences then ALJavascriptDecodeV(currValue); // ..."... - break; - end - else inc(P1); // ... "...\"..." - // ^^^^^^^^^P1 - - if P1 + 1 > BufferLength then ExpandBuffer(P1); - - end; - if P1 > BufferLength then AlJSONDocErrorA(CALJSONParseError); - BufferPos := P1 + 1; // ... "...\"..." - // ^^^^^^^^^^BufferPos - - end - {$ENDREGION} - - {$REGION 'if the value is a UNquoted string'} - // name : 1.23 - // name : true - // name : false - // name : null - // name : ISODATE('1/1/2001') - // name : function(){return(new Date).getTime()}, ...} - // name : new Date(''Dec 03, 1924'') - // name : /test/i - else begin - - LInSingleQuote := False; - LInDoubleQuote := False; - LInSlashQuote := False; - LInSquareBracket := 0; - LInRoundBracket := 0; - LInCurlyBracket := 0; - - While (BufferPos <= BufferLength) or ExpandBuffer do begin - If Buffer[BufferPos] <= ' ' then inc(bufferPos) - else break; - end; - if BufferPos > BufferLength then AlJSONDocErrorA(CALJSONParseError); - - P1 := BufferPos; // ... new Date('Dec 03, 1924'), .... - // ^P1 - While (P1 <= BufferLength) or ExpandBuffer(P1) do begin - - c := Buffer[P1]; - - if (not LInSingleQuote) and - (not LInDoubleQuote) and - (not LInSlashQuote) and - (LInSquareBracket = 0) and - (LInRoundBracket = 0) and - (LInCurlyBracket = 0) and - (c in [',', '}', ']']) then begin - P2 := P1-1; - While P2 >= BufferPos do begin - If Buffer[P2] <= ' ' then dec(P2) - else break; - end; - ALCopyStr(Buffer,currValue,BufferPos,P2-BufferPos+1); // new Date('Dec 03, 1924') - break; - end - else if (c = '"') then begin - if (P1 <= 1) or - (Buffer[P1 - 1] <> '\') then LInDoubleQuote := (not LInDoubleQuote) and (not LInSingleQuote) and (not LInSlashQuote); - end - else if (c = '''') then begin - if (P1 <= 1) or - (Buffer[P1 - 1] <> '\') then LInSingleQuote := (not LInSingleQuote) and (not LInDoubleQuote) and (not LInSlashQuote) - end - else if (c = '/') then begin - if (P1 <= 1) or - (Buffer[P1 - 1] <> '\') then LInSlashQuote := (not LInSingleQuote) and (not LInDoubleQuote) and (not LInSlashQuote); - end - else if (not LInSingleQuote) and - (not LInDoubleQuote) and - (not LInSlashQuote) then begin - if (c = '[') then inc(LInSquareBracket) - else if (c = ']') then dec(LInSquareBracket) - else if (c = '(') then inc(LInRoundBracket) - else if (c = ')') then dec(LInRoundBracket) - else if (c = '}') then inc(LInCurlyBracket) - else if (c = '{') then dec(LInCurlyBracket); - end; - - inc(P1); // ... new Date('Dec 03, 1924'), .... - // ^^^^^^^^^^^^^^^^^^^^^^^^^P1 - - end; - if P1 > BufferLength then AlJSONDocErrorA(CALJSONParseError); - BufferPos := P1; // ... new Date('Dec 03, 1924'), .... - // ^BufferPos - - - end; - {$ENDREGION} - - {$REGION 'create the named text node'} - - //Node withe name MUST be ONLY present inside an object node - if NotSaxMode then begin - if not assigned(WorkingNode) then AlJSONDocErrorA(CALJSONParseError); - if (CurrIndex >= 0) or - (WorkingNode.nodetype <> ntObject) then AlJSONDocErrorA(CALJSONParseError); - end - else begin - if (CurrIndex >= 0) or - (NamePaths.Count = 0) or - (TALJSONNodeType(NamePaths.Objects[Namepaths.Count - 1]) <> ntObject) then AlJSONDocErrorA(CALJSONParseError); - end; - - //create the node - _createNode(currIndex,CurrName,CurrValue,LQuoteChar in ['"','''']); - - {$ENDREGION} - - end; - -var BOMSequence: integer; - InCommentLine: integer; - c: ansiChar; - -Begin - - // - // NOTE: the childNodes of the ContainerNode - // must have been cleared by the calling function! - // - // NOTE: ContainerNode must have fDocument assigned - // - // NOTE: ContainerNode must be ntobject or nil (sax mode) - // - - //event fonParseStartDocument - DoParseStartDocument; - - //init WorkingNode and NotSaxMode, CurrIndex and DecodeJSONReferences - WorkingNode := ContainerNode; - NotSaxMode := assigned(ContainerNode); - DecodeJSONReferences := not (poIgnoreControlCharacters in ParseOptions); - CurrIndex := -1; - - //init ObjectPaths or NamePaths - if (NotSaxMode) and - (not assigned(fonParseText)) and - (not assigned(FonParseStartObject)) and - (not assigned(FonParseEndObject)) and - (not assigned(FonParseStartArray)) and - (not assigned(FonParseEndArray)) then begin - ObjectPaths := TALIntegerList.Create(false{OwnsObjects}); - NamePaths := nil; - end - else begin - ObjectPaths := nil; - NamePaths := TALNVStringListA.Create; - end; - Try - - //init Buffer - if assigned(RawJSONStream) then begin - Buffer := ''; - BufferLength := 0; - BufferPos := 1; - ExpandBuffer; - end - else begin - Buffer := RawJSONString; - BufferLength := length(RawJSONString); - BufferPos := 1; - end; - - //add first node in ObjectPaths/NamePaths - if assigned(ObjectPaths) then ObjectPaths.AddObject(-1, WorkingNode) - else begin - if NotSaxMode then _AddNameItemToNamePath('', WorkingNode) - else _AddNameItemToNamePath('', pointer(ntObject)); - end; - - //skip the first { - BOMSequence := 0; // hide warnings - While (BufferPos <= BufferLength) or ExpandBuffer do begin - c := Buffer[BufferPos]; - If c <= ' ' then inc(bufferPos) - else if ((bufferPos = 1) and (c=#$EF)) then begin - BOMSequence := 1; - inc(bufferPos); - end - else if ((bufferPos = 2) and (BOMSequence=1) and (c=#$BB)) then begin - BOMSequence := 2; - inc(bufferPos); - end - else if ((bufferPos = 3) and (BOMSequence=2) and (c=#$BF)) then begin - BOMSequence := 0; - inc(bufferPos); - end - else begin - if c <> '{' then AlJSONDocErrorA(cALJSONParseError); - inc(bufferPos); - break; - end; - end; - - //analyze all the nodes - if poAllowComments in ParseOptions then begin - InCommentLine := 0; - While (BufferPos <= BufferLength) or ExpandBuffer do begin - c := Buffer[BufferPos]; - If (InCommentLine = 0) and ((c <= ' ') or (c = ',')) then inc(bufferPos) - else if (InCommentLine <= 1) and (c = '/') then begin - inc(InCommentLine); - inc(bufferPos); - end - else if (InCommentLine = 2) then begin - if ((c = #13) or (c = #10)) then InCommentLine := 0; - inc(bufferPos); - end - else begin - if InCommentLine = 1 then begin - InCommentLine := 0; - dec(BufferPos); - end; - AnalyzeNode; - end; - end; - end - else begin - While (BufferPos <= BufferLength) or ExpandBuffer do begin - c := Buffer[BufferPos]; - If (c <= ' ') or (c = ',') then inc(bufferPos) - else AnalyzeNode; - end; - end; - - //some tags are not closed - if assigned(ObjectPaths) then begin - if ObjectPaths.Count > 0 then AlJSONDocErrorA(cALJSONParseError); - end - else begin - if NamePaths.Count > 0 then AlJSONDocErrorA(cALJSONParseError); - end; - - //mean the node was not update (empty stream?) or not weel closed - if WorkingNode <> nil then AlJSONDocErrorA(cALJSONParseError); - - //event fonParseEndDocument - DoParseEndDocument; - - finally - - //free ObjectPaths/NamePaths - if assigned(ObjectPaths) then ObjectPaths.Free - else NamePaths.Free; - - end; - -end; - - -{*************************************************************} -{Last version of the spec: http://bsonspec.org/#/specification} -procedure TALJSONDocumentA.ParseBSON( - const RawBSONStream: TStream; - const RawBSONString: AnsiString; - const ContainerNode: TALJSONNodeA); - -Const BufferSize: integer = 8192; - -Var Buffer: AnsiString; - BufferLength: Integer; - BufferPos: Integer; - CurrName: AnsiString; - NotSaxMode: Boolean; - WorkingNode: TALJSONNodeA; - NamePaths: TALStringListA; - ObjectPaths: TObjectList; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function ExpandBuffer: boolean; overload; - Var ByteReaded, Byte2Read: Integer; - Begin - if not assigned(RawBSONStream) then begin - result := false; - exit; - end; - - If (BufferLength > 0) and (BufferPos > 1) then begin - if (BufferPos > BufferLength) then RawBSONStream.Position := RawBSONStream.Position - BufferLength + BufferPos - 1; - Byte2Read := min(BufferPos - 1, BufferLength); - if BufferPos <= length(Buffer) then ALMove( - Pbyte(Buffer)[BufferPos - 1], - pointer(Buffer)^, - BufferLength-BufferPos+1); - BufferPos := 1; - end - else begin - Byte2Read := BufferSize; - BufferLength := BufferLength + BufferSize; - SetLength(Buffer, BufferLength); - end; - - //range check error is we not do so - if RawBSONStream.Position < RawBSONStream.Size then ByteReaded := RawBSONStream.Read(Pbyte(Buffer)[BufferLength - Byte2Read{+ 1 - 1}],Byte2Read) - else ByteReaded := 0; - - If ByteReaded <> Byte2Read then begin - BufferLength := BufferLength - Byte2Read + ByteReaded; - SetLength(Buffer, BufferLength); - Result := ByteReaded > 0; - end - else result := True; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function ExpandBuffer(var PosToKeepSync: Integer): boolean; overload; - var P1: integer; - begin - P1 := BufferPos; - result := ExpandBuffer; - PosToKeepSync := PosToKeepSync - (P1 - BufferPos); - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function GetPathStr(Const ExtraItems: ansiString = ''): ansiString; - var I, L, P, Size: Integer; - LB: ansiChar; - S: AnsiString; - begin - LB := PathSeparator; - Size := length(ExtraItems); - if size <> 0 then Inc(Size, 1{length(LB)}); - for I := 1 to NamePaths.Count - 1 do Inc(Size, Length(NamePaths[I]) + 1{length(LB)}); - SetLength(Result, Size); - P := 1; - for I := 1 to NamePaths.Count - 1 do begin - S := NamePaths[I]; - L := Length(S); - if L <> 0 then begin - ALMove(pointer(S)^, Pbyte(Result)[(P-1){*sizeOf(ansiChar)}], L{*sizeOf(ansiChar)}); - Inc(P, L); - end; - L := 1{length(LB)}; - if ((i <> NamePaths.Count - 1) or - (ExtraItems <> '')) and - (((NotSaxMode) and (TALJSONNodeA(NamePaths.Objects[I]).nodetype <> ntarray)) or - ((not NotSaxMode) and (TALJSONNodeType(NamePaths.Objects[I]) <> ntarray))) then begin - ALMove(LB, Pbyte(Result)[(P-1){*sizeOf(ansiChar)}], L{*sizeOf(ansiChar)}); - Inc(P, L); - end; - end; - if ExtraItems <> '' then begin - L := length(ExtraItems); - ALMove(pointer(ExtraItems)^, Pbyte(Result)[(P-1){*sizeOf(ansiChar)}], L{*sizeOf(ansiChar)}); - Inc(P, L); - end; - setlength(result,P-1); - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseTextWithIndex( - const index: AnsiString; - const Args: array of const; - const NodeSubType: TALJSONNodeSubType); - begin - DoParseText(GetPathStr('[' + index + ']'), '', Args, NodeSubType) - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseTextWithName( - const name: AnsiString; - const Args: array of const; - const NodeSubType: TALJSONNodeSubType); - begin - DoParseText(GetPathStr(Name), Name, Args, NodeSubType) - end; - - {~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseText( - const NameOrIndex: AnsiString; - const Args: array of const; - const NodeSubType: TALJSONNodeSubType); - begin - if Assigned(fonParseText) then begin - if notSaxMode then begin - if WorkingNode.nodetype=ntarray then _DoParseTextWithIndex(NameOrIndex, Args, NodeSubType) - else _DoParseTextWithName(NameOrIndex, Args, NodeSubType); - end - else begin - if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); - if TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntArray then _DoParseTextWithIndex(NameOrIndex, Args, NodeSubType) - else _DoParseTextWithName(NameOrIndex, Args, NodeSubType); - end; - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseStartObject(const Name: AnsiString); - begin - DoParseStartObject(GetPathStr, Name); - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseEndObject; - begin - if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); - DoParseEndObject(GetPathStr, NamePaths[NamePaths.Count - 1]) - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseStartArray(const index: AnsiString); - begin - DoParseStartArray(GetPathStr, index) - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseEndArray; - begin - if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); - DoParseEndArray(GetPathStr, NamePaths[NamePaths.Count - 1]); - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _AddIndexItemToNamePath(const index: AnsiString; Obj: Pointer); - begin - NamePaths.AddObject('[' + Index + ']', Obj) - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _AddNameItemToNamePath(const name: AnsiString; Obj: Pointer); - begin - NamePaths.AddObject(Name, Obj) - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _AddItemToNamePath(const nameOrIndex: AnsiString; Obj: Pointer); - begin - if notSaxMode then begin - if WorkingNode.nodetype=ntarray then _AddIndexItemToNamePath(nameOrIndex, Obj) - else _AddNameItemToNamePath(nameOrIndex, Obj); - end - else begin - if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); - if TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntarray then _AddIndexItemToNamePath(nameOrIndex, Obj) - else _AddNameItemToNamePath(nameOrIndex, Obj); - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createInt64Node( - const name: AnsiString; - const NodeSubType: TALJSONNodeSubType); - var LNode: TALJSONNodeA; - LInt64: Int64; - begin - if BufferPos > BufferLength - sizeof(LInt64) + 1 then begin - ExpandBuffer; - if BufferPos > BufferLength - sizeof(LInt64) + 1 then AlJSONDocErrorA(cALBSONParseError); - end; - ALMove(Pbyte(Buffer)[BufferPos-1], LInt64, sizeof(LInt64)); - BufferPos := BufferPos + sizeof(LInt64); - - if NotSaxMode then begin - if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetInt64(LInt64); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(Name, [LInt64], NodeSubType) - end - else begin - _DoParseText(Name, [LInt64], NodeSubType) - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createInt32Node( - const name: AnsiString; - const NodeSubType: TALJSONNodeSubType); - var LNode: TALJSONNodeA; - LInt32: Int32; - begin - if BufferPos > BufferLength - sizeof(LInt32) + 1 then begin - ExpandBuffer; - if BufferPos > BufferLength - sizeof(LInt32) + 1 then AlJSONDocErrorA(cALBSONParseError); - end; - ALMove(Pbyte(Buffer)[BufferPos-1], LInt32, sizeof(LInt32)); - BufferPos := BufferPos + sizeof(LInt32); - - if NotSaxMode then begin - if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setint32(LInt32); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(Name, [LInt32], NodeSubType) - end - else begin - _DoParseText(Name, [LInt32], NodeSubType) - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createTextNode( - const name: AnsiString; - const NodeSubType: TALJSONNodeSubType); - var LNode: TALJSONNodeA; - LInt32: Int32; - LText: ansiString; - begin - if BufferPos > BufferLength - sizeof(LInt32) + 1 then begin - ExpandBuffer; - if BufferPos > BufferLength - sizeof(LInt32) + 1 then AlJSONDocErrorA(cALBSONParseError); - end; - ALMove(Pbyte(Buffer)[BufferPos-1], LInt32, sizeof(LInt32)); - BufferPos := BufferPos + sizeof(LInt32); - while (BufferPos + LInt32 - 1 > BufferLength) do - if not ExpandBuffer then AlJSONDocErrorA(cALBSONParseError); - ALCopyStr(Buffer,LText,BufferPos,LInt32 - 1{for the trailing #0}); - BufferPos := BufferPos + LInt32; - - if NotSaxMode then begin - if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Settext(LText); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(Name, [LText], NodeSubType) - end - else begin - _DoParseText(Name, [LText], NodeSubType) - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createFloatNode( - const name: AnsiString; - const NodeSubType: TALJSONNodeSubType); - var LNode: TALJSONNodeA; - LDouble: Double; - begin - if BufferPos > BufferLength - sizeof(Double) + 1 then begin - ExpandBuffer; - if BufferPos > BufferLength - sizeof(Double) + 1 then AlJSONDocErrorA(cALBSONParseError); - end; - ALMove(pbyte(Buffer)[BufferPos-1], LDouble, sizeof(Double)); - BufferPos := BufferPos + sizeof(Double); - - if NotSaxMode then begin - if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetFloat(LDouble); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(Name, [LDouble], NodeSubType) - end - else begin - _DoParseText(Name, [LDouble], NodeSubType) - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createBinaryNode( - const name: AnsiString; - const NodeSubType: TALJSONNodeSubType); - var LNode: TALJSONNodeA; - LInt32: Int32; - LBinSubtype: byte; - LBinData: ansiString; - begin - //Get size - if BufferPos > BufferLength - sizeof(LInt32) + 1 then begin - ExpandBuffer; - if BufferPos > BufferLength - sizeof(LInt32) + 1 then AlJSONDocErrorA(cALBSONParseError); - end; - ALMove(Pbyte(Buffer)[BufferPos-1], LInt32, sizeof(LInt32)); - BufferPos := BufferPos + sizeof(LInt32); - - //Get the subtype - if BufferPos > BufferLength then begin - ExpandBuffer; - if BufferPos > BufferLength then AlJSONDocErrorA(cALBSONParseError); - end; - LBinSubtype := Byte(Buffer[BufferPos]); - BufferPos := BufferPos + 1; - - //Get the data - while (BufferPos + LInt32 - 1 > BufferLength) do - if not ExpandBuffer then AlJSONDocErrorA(cALBSONParseError); - ALCopyStr(Buffer,LBinData,BufferPos,LInt32); - BufferPos := BufferPos + LInt32; - - //create the node - if NotSaxMode then begin - if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.setbinary(LBinData, LBinSubtype); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(Name, [LBinData, LBinSubtype], NodeSubType); - end - else begin - _DoParseText(Name, [LBinData, LBinSubtype], NodeSubType); - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createObjectIDNode( - const name: AnsiString; - const NodeSubType: TALJSONNodeSubType); - var LNode: TALJSONNodeA; - LObjectID: AnsiString; - begin - if BufferPos > BufferLength - 12{length(aObjectID)} + 1 then begin - ExpandBuffer; - if BufferPos > BufferLength - 12{length(aObjectID)} + 1 then AlJSONDocErrorA(cALBSONParseError); - end; - Setlength(LObjectID, 12); // ObjectId is a 12-byte BSON type - ALMove(Pbyte(Buffer)[BufferPos-1], pbyte(LObjectID)[0], 12{length(aObjectID)}); // pbyte(aObjectID)[0] to not have a jump in uniqueString (aObjectID is already unique thanks to Setlength) - BufferPos := BufferPos + 12{length(aObjectID)}; - - if NotSaxMode then begin - if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetObjectID(LObjectID); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(Name, [LObjectID], NodeSubType) - end - else begin - _DoParseText(Name, [LObjectID], NodeSubType) - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createBooleanNode( - const name: AnsiString; - const NodeSubType: TALJSONNodeSubType); - var LNode: TALJSONNodeA; - LBool: Boolean; - begin - if BufferPos > BufferLength then begin - ExpandBuffer; - if BufferPos > BufferLength then AlJSONDocErrorA(cALBSONParseError); - end; - if Buffer[BufferPos] = #$00 then LBool := False - else if Buffer[BufferPos] = #$01 then LBool := true - else begin - AlJSONDocErrorA(cALBSONParseError); - LBool := False; // to hide a warning; - end; - BufferPos := BufferPos + 1; - - if NotSaxMode then begin - if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setbool(LBool); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(Name, [LBool], NodeSubType); - end - else begin - _DoParseText(Name, [LBool], NodeSubType); - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createDateTimeNode( - const name: AnsiString; - const NodeSubType: TALJSONNodeSubType); - var LNode: TALJSONNodeA; - LDateTime: TdateTime; - LInt64: Int64; - begin - if BufferPos > BufferLength - sizeof(LInt64) + 1 then begin - ExpandBuffer; - if BufferPos > BufferLength - sizeof(LInt64) + 1 then AlJSONDocErrorA(cALBSONParseError); - end; - ALMove(Pbyte(Buffer)[BufferPos-1], LInt64, sizeof(LInt64)); - LDateTime := ALUnixMsToDateTime(LInt64); - BufferPos := BufferPos + sizeof(LInt64); - - if NotSaxMode then begin - if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setdatetime(LDateTime); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(Name, [LDateTime], NodeSubType); - end - else begin - _DoParseText(Name, [LDateTime], NodeSubType); - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createTimestampNode( - const name: AnsiString; - const NodeSubType: TALJSONNodeSubType); - var LNode: TALJSONNodeA; - LTimestamp: TALBSONTimestamp; - LInt64: Int64; - begin - if BufferPos > BufferLength - sizeof(LInt64) + 1 then begin - ExpandBuffer; - if BufferPos > BufferLength - sizeof(LInt64) + 1 then AlJSONDocErrorA(cALBSONParseError); - end; - ALMove(Pbyte(Buffer)[BufferPos-1], LInt64, sizeof(LInt64)); - LTimestamp.I64 := LInt64; - BufferPos := BufferPos + sizeof(LInt64); - - if NotSaxMode then begin - if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetTimestamp(LTimestamp); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(Name, [LTimestamp.W1, LTimestamp.W2], NodeSubType); - end - else begin - _DoParseText(Name, [LTimestamp.W1, LTimestamp.W2], NodeSubType); - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createnullNode( - const name: AnsiString; - const NodeSubType: TALJSONNodeSubType); - var LNode: TALJSONNodeA; - begin - if NotSaxMode then begin - if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setnull(true); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(Name, ['null'], NodeSubType); - end - else begin - _DoParseText(Name, ['null'], NodeSubType); - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createRegExNode( - const name: AnsiString; - const NodeSubType: TALJSONNodeSubType); - var LNode: TALJSONNodeA; - LRegEx: ansiString; - LRegExOptions: TALPerlRegExOptions; - P1: integer; - begin - //Get pattern - P1 := BufferPos; - While (P1 <= BufferLength) or ExpandBuffer(P1) do begin - If Buffer[P1] <> #$00 then inc(P1) - else begin - LRegEx := AlCopyStr(Buffer, BufferPos, P1 - BufferPos); - break; - end; - end; - if P1 > BufferLength then AlJSONDocErrorA(cALBSONParseError); - BufferPos := P1 + 1; - if BufferPos > BufferLength then ExpandBuffer; - - //Get options - LRegExOptions := []; - While (BufferPos <= BufferLength) or ExpandBuffer do begin - case Buffer[BufferPos] of - 'i': LRegExOptions := LRegExOptions + [preCaseLess]; - 'm': LRegExOptions := LRegExOptions + [preMultiLine]; - 'x': LRegExOptions := LRegExOptions + [preExtended]; - 'l':; - 's': LRegExOptions := LRegExOptions + [preSingleLine]; - 'u':; - #$00: break; - end; - inc(BufferPos); - end; - if BufferPos > BufferLength then AlJSONDocErrorA(cALBSONParseError); - inc(BufferPos); - if BufferPos > BufferLength then ExpandBuffer; - - //create the node - if NotSaxMode then begin - if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetRegEx(LRegEx, LRegExOptions); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(Name, [LRegEx, Byte(LRegExOptions)], NodeSubType) - end - else begin - _DoParseText(Name, [LRegEx, Byte(LRegExOptions)], NodeSubType) - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createJavascriptNode( - const name: AnsiString; - const NodeSubType: TALJSONNodeSubType); - var LNode: TALJSONNodeA; - LJavascript: ansiString; - LInt32: Int32; - begin - if BufferPos > BufferLength - sizeof(LInt32) + 1 then begin - ExpandBuffer; - if BufferPos > BufferLength - sizeof(LInt32) + 1 then AlJSONDocErrorA(cALBSONParseError); - end; - ALMove(Pbyte(Buffer)[BufferPos-1], LInt32, sizeof(LInt32)); - BufferPos := BufferPos + sizeof(LInt32); - while (BufferPos + LInt32 - 1 > BufferLength) do - if not ExpandBuffer then AlJSONDocErrorA(cALBSONParseError); - ALCopyStr(Buffer,LJavascript,BufferPos,LInt32 - 1{for the trailing #0}); - BufferPos := BufferPos + LInt32; - - //create the node - if NotSaxMode then begin - if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetJavascript(LJavascript); - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - _DoParseText(Name, [LJavascript], NodeSubType); - end - else begin - _DoParseText(Name, [LJavascript], NodeSubType); - end; - end; - - {~~~~~~~~~~~~~~~~~~~~} - procedure AnalyzeNode; - Var LNode: TALJSONNodeA; - LNodeType: TALJSONNodeType; - LNodeSubType: TALJSONNodeSubType; - P1: Integer; - c: ansiChar; - Begin - - {$REGION 'init current char (c)'} - c := Buffer[BufferPos]; - {$ENDREGION} - - {$REGION 'End Object/Array'} - // ... } .... - // ... ] .... - if c = #$00 then begin - - //error if Paths.Count = 0 (mean one end object/array without any starting) - if assigned(ObjectPaths) then begin - if (ObjectPaths.Count = 0) then AlJSONDocErrorA(cALBSONParseError); - end - else begin - if (NamePaths.Count = 0) then AlJSONDocErrorA(cALBSONParseError); - end; - - //if we are not in sax mode - if NotSaxMode then begin - - //init anode to one level up - if assigned(ObjectPaths) then LNode := ObjectPaths[ObjectPaths.Count - 1] - else LNode := TALJSONNodeA(NamePaths.Objects[NamePaths.Count - 1]); - - //if anode <> workingNode aie aie aie - if (LNode <> WorkingNode) then AlJSONDocErrorA(cALBSONParseError); - - //calculate anodeTypeInt - LNodeType := LNode.NodeType; - if not (LNodeType in [ntObject, ntarray]) then AlJSONDocErrorA(cALBSONParseError); - - //if working node <> containernode then we can go to one level up - If WorkingNode<>ContainerNode then begin - - //init WorkingNode to the parentNode - WorkingNode := WorkingNode.ParentNode; - - end - - //if working node = containernode then we can no go to the parent node so set WorkingNode to nil - Else WorkingNode := nil; - - end - - //if we are in sax mode - else begin - - //calculate anodeTypeInt - LNodeType := TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]); - if not (LNodeType in [ntObject,ntarray]) then AlJSONDocErrorA(cALBSONParseError); - - end; - - //call the DoParseEndObject/array event - if Assigned(fonParseEndObject) then begin - if LNodeType = ntObject then _DoParseEndObject - else _DoParseEndArray; - end; - - //delete the last entry from the path - if assigned(ObjectPaths) then ObjectPaths.Delete(ObjectPaths.Count - 1) - else NamePaths.Delete(NamePaths.Count - 1); - - //update BufferPos - BufferPos := BufferPos + 1; - - //finallly exit from this procedure, everything was done - exit; - - end; - {$ENDREGION} - - {$REGION 'Get the node sub type'} - LNodeSubType := nstText; // to hide fucking warning - case c of - #$01: LNodeSubType := nstFloat; - #$02: LNodeSubType := nstText; - #$03: LNodeSubType := nstObject; - #$04: LNodeSubType := nstArray; - #$05: LNodeSubType := nstbinary; - #$07: LNodeSubType := nstObjectID; - #$08: LNodeSubType := nstBoolean; - #$09: LNodeSubType := nstDateTime; - #$0A: LNodeSubType := nstNull; - #$0B: LNodeSubType := nstRegEx; - #$0D: LNodeSubType := nstJavascript; - #$10: LNodeSubType := nstint32; - #$11: LNodeSubType := nstTimestamp; - #$12: LNodeSubType := nstint64; - else AlJSONDocErrorA(cALBSONParseError); - end; - BufferPos := BufferPos + 1; - If BufferPos > BufferLength then ExpandBuffer; - {$ENDREGION} - - {$REGION 'Get the node name'} - P1 := BufferPos; - While (P1 <= BufferLength) or ExpandBuffer(P1) do begin - If Buffer[P1] <> #$00 then inc(P1) - else begin - AlCopyStr(Buffer, CurrName, BufferPos, P1-BufferPos); - break; - end; - end; - if P1 > BufferLength then AlJSONDocErrorA(cALBSONParseError); - BufferPos := P1 + 1; - if BufferPos > BufferLength then ExpandBuffer; - {$ENDREGION} - - {$REGION 'Begin Object/Array'} - // ... { .... - // ... [ .... - if LNodeSubType in [nstObject,nstArray] then begin - - //if we are not in sax mode - if NotSaxMode then begin - - //if workingnode = nil then it's mean we are outside the containerNode - if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); - - //create the node according the the braket char and add it to the workingnode - if LNodeSubType = nstObject then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', ntObject) - else LNode := CreateNode(CurrName, ntObject); - end - else begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', ntarray) - else LNode := CreateNode(CurrName, ntarray); - end; - try - WorkingNode.ChildNodes.Add(LNode); - except - LNode.Free; - raise; - end; - - //set that the current working node will be now the new node newly created - WorkingNode := LNode; - - //update the path - if assigned(ObjectPaths) then ObjectPaths.Add(WorkingNode) - else _AddItemToNamePath(CurrName, WorkingNode); - - end - - //if we are in sax mode - else begin - - //update the path - if LNodeSubType = nstObject then LNodeType := ntObject - else LNodeType := ntArray; - _AddItemToNamePath(CurrName, pointer(LNodeType)); - - end; - - //call the DoParseStartObject/array event - if LNodeSubType = nstObject then begin - if Assigned(fonParseStartObject) then _DoParseStartObject(CurrName) - end - else begin - if Assigned(fonParseStartArray) then _DoParseStartArray(CurrName); - end; - - //update BufferPos - BufferPos := BufferPos + 4; // we don't need the size of the object/array (4 bytes) - - //finallly exit from this procedure, everything was done - exit; - - end; - {$ENDREGION} - - {$REGION 'create the node'} - case LNodeSubType of - // \x01 + name + \x00 + double - nstFloat: _createFloatNode(CurrName, LNodeSubType); - - // \x02 + name + \x00 + length (int32) + string + \x00 - nstText: _createTextNode(CurrName, LNodeSubType); - - // \x05 + name + \x00 + int32 + subtype + (byte*) - nstbinary: _createBinaryNode(CurrName, LNodeSubType); - - // \x07 + name + \x00 + (byte*12) - nstObjectID: _createObjectIDNode(CurrName, LNodeSubType); - - // \x08 + name + \x00 + \x00 => Boolean "false" - // \x08 + name + \x00 + \x01 => Boolean "true" - nstBoolean: _createBooleanNode(CurrName, LNodeSubType); - - // \x09 + name + \x00 + int64 - nstDateTime: _createDateTimeNode(CurrName, LNodeSubType); - - // \x11 + name + \x00 + int64 - nstTimestamp: _createTimestampNode(CurrName, LNodeSubType); - - // \x0A + name + \x00 - nstnull: _createNullNode(CurrName, LNodeSubType); - - // \x0B + name + \x00 + (byte*) + \x00 + (byte*) + \x00 - nstRegEx: _createRegExNode(CurrName, LNodeSubType); - - // \x0D + name + \x00 + length (int32) + string + \x00 - nstJavascript: _createJavascriptNode(CurrName, LNodeSubType); - - // \x10 + name + \x00 + int32 - nstint32: _createInt32Node(CurrName, LNodeSubType); - - // \x12 + name + \x00 + int64 - nstint64: _createInt64Node(CurrName, LNodeSubType); - - else AlJSONDocErrorA(cALBSONParseError); - end; - {$ENDREGION} - - end; - -Begin - - // - // NOTE: the childNodes of the ContainerNode - // must have been cleared by the calling function! - // - // NOTE: ContainerNode must have fDocument assigned - // - // NOTE: ContainerNode must be ntobject or nil (sax mode) - // - - //event fonParseStartDocument - DoParseStartDocument; - - //init WorkingNode and NotSaxMode - WorkingNode := ContainerNode; - NotSaxMode := assigned(ContainerNode); - - //init ObjectPaths or NamePaths - if (NotSaxMode) and - (not assigned(fonParseText)) and - (not assigned(FonParseStartObject)) and - (not assigned(FonParseEndObject)) and - (not assigned(FonParseStartArray)) and - (not assigned(FonParseEndArray)) then begin - ObjectPaths := TObjectList.Create(false{OwnsObjects}); - NamePaths := nil; - end - else begin - ObjectPaths := nil; - NamePaths := TALStringListA.Create; - end; - Try - - //init Buffer - if assigned(RawBSONStream) then begin - Buffer := ''; - BufferLength := 0; - BufferPos := 5; // the first 4 bytes are the length of the document and we don't need it - ExpandBuffer; - end - else begin - Buffer := RawBSONString; - BufferLength := length(RawBSONString); - BufferPos := 5; // the first 4 bytes are the length of the document and we don't need it - end; - - //add first node in ObjectPaths/NamePaths - if assigned(ObjectPaths) then ObjectPaths.Add(WorkingNode) - else begin - if NotSaxMode then NamePaths.AddObject('[-1]', WorkingNode) - else NamePaths.AddObject('[-1]', pointer(ntObject)); - end; - - //analyze all the nodes - While (BufferPos <= BufferLength) or ExpandBuffer do - AnalyzeNode; - - //some tags are not closed - if assigned(ObjectPaths) then begin - if ObjectPaths.Count > 0 then AlJSONDocErrorA(cALBSONParseError); - end - else begin - if NamePaths.Count > 0 then AlJSONDocErrorA(cALBSONParseError); - end; - - //mean the node was not update (empty stream?) or not weel closed - if WorkingNode <> nil then AlJSONDocErrorA(cALBSONParseError); - - //event fonParseEndDocument - DoParseEndDocument; - - finally - - //free ObjectPaths/NamePaths - if assigned(ObjectPaths) then ObjectPaths.Free - else NamePaths.Free; - - end; - -end; - -{************************************} -procedure TALJSONDocumentA.ReleaseDoc; -begin - if assigned(FDocumentNode) then FreeAndNil(FDocumentNode); -end; - -{*****************************************************************} -{Loads a string representation of an JSON document and activates it. - Call LoadFromJSONString to assign a string as the value of the JSON document. Unlike the JSON property, which lets you assign JSON on a line-by-line - basis, LoadFromJSONString treats the text of the JSON document as a whole. - The str parameter is a string containing the text of an JSON document. It should represent the JSON text encoded using 8 bits char (utf-8, iso-8859-1, etc) - After assigning the JSON property as the contents of the document, LoadFromJSONString sets the Active property to true.} -procedure TALJSONDocumentA.LoadFromJSONString(const Str: AnsiString; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); -begin - if saxMode then SetActive(False) - else begin - if ClearChildNodes then releaseDoc; - SetActive(True); - end; - ParseJSON(nil, Str, FDocumentNode) -end; - -{****************************************************} -{Loads an JSON document from a stream and activates it. - Call LoadFromJSONStream to load the JSON document from a stream. - *Stream is a stream object that can be used to read the string of JSON that makes up the document. - After loading the document from Stream, LoadFromJSONStream sets the Active property to true.} -procedure TALJSONDocumentA.LoadFromJSONStream(const Stream: TStream; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); -begin - if saxMode then SetActive(False) - else begin - if ClearChildNodes then releaseDoc; - SetActive(True); - end; - ParseJSON(Stream, '', FDocumentNode) -end; - -{**************************************} -{Loads an JSON document and activates it. - Call LoadFromJSONFile to load the JSON document specified by AFileName and set the Active property to true so - that you can examine or modify the document. - *AFileName is the name of the JSON document to load from disk. If AFileName is an empty string, TALJSONDocumentA uses the value of the - FileName property. If AFileName is not an empty string, TALJSONDocumentA changes the FileName property to AFileName. - Once you have loaded an JSON document, any changes you make to the document are not saved back to disk until you call the SaveToFile method.} -procedure TALJSONDocumentA.LoadFromJSONFile(const FileName: String; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); -var FileStream: TFileStream; -begin - FileStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromJSONStream(FileStream, saxMode, ClearChildNodes); - finally - FileStream.Free; - end; -end; - -{*********************************************************************************************************************************************} -procedure TALJSONDocumentA.LoadFromJSONFile(const FileName: AnsiString; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); -begin - LoadFromJSONFile(String(FileName), saxMode, ClearChildNodes); -end; - -{******************************************************************************************************************************************} -procedure TALJSONDocumentA.LoadFromBSONString(const Str: AnsiString; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); -begin - if saxMode then SetActive(False) - else begin - if ClearChildNodes then releaseDoc; - SetActive(True); - end; - ParseBSON(nil, Str, FDocumentNode) -end; - -{******************************************************************************************************************************************} -procedure TALJSONDocumentA.LoadFromBSONStream(const Stream: TStream; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); -begin - if saxMode then SetActive(False) - else begin - if ClearChildNodes then releaseDoc; - SetActive(True); - end; - ParseBSON(Stream, '', FDocumentNode) -end; - -{*****************************************************************************************************************************************} -procedure TALJSONDocumentA.LoadFromBSONFile(const FileName: String; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); -var FileStream: TFileStream; -begin - FileStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromBSONStream(FileStream, saxMode, ClearChildNodes); +{*********************************************} +class procedure TALJSONDocumentA.ParseBSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +Var LfileStream: TfileStream; +Begin + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + ParseBSONStream( + LfileStream, + OnParseText, + OnParseStartObject, + OnParseEndObject, + OnParseStartArray, + OnParseEndArray, + Options); finally - FileStream.Free; + ALFreeAndNil(LfileStream); end; end; -{*********************************************************************************************************************************************} -procedure TALJSONDocumentA.LoadFromBSONFile(const FileName: AnsiString; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); -begin - LoadFromBSONFile(String(FileName), saxMode, ClearChildNodes); +{*********************************************} +class procedure TALJSONDocumentA.ParseBSONFile( + const FileName: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +begin + ParseBSONFile( + String(FileName), + OnParseText, + OnParseStartObject, + OnParseEndObject, + OnParseStartArray, + OnParseEndArray, + Options); end; -{***********************************} -{Saves the JSON document to a stream. - Call SaveToStream to save the contents of the JSON document to the stream specified by Stream.} -procedure TALJSONDocumentA.SaveToJSONStream(const Stream: TStream); +{**********************************************************} +{Creates the object that implements the ChildNodes property} +function TALJSONNodeA.CreateChildList: TALJSONNodeListA; begin - CheckActive; - node.SaveToJSONStream(Stream); + result := TALJSONNodeListA.Create(Self); end; -{******************************} -{Saves the JSON document to disk. - Call SaveToFile to save any modifications you have made to the parsed JSON document. - AFileName is the name of the file to save.} -procedure TALJSONDocumentA.SaveToJSONFile(const FileName: String); +{********************************************} +{Get Childnode without create it if not exist} +function TALJSONNodeA.InternalGetChildNodes: TALJSONNodeListA; begin - CheckActive; - node.SaveToJSONFile(FileName); + Result := nil; //virtual; end; -{********************************************************************} -procedure TALJSONDocumentA.SaveToJSONFile(const FileName: AnsiString); +{****************************************************} +function TALJSONNodeA.GetChildNodes: TALJSONNodeListA; begin - SaveToJSONFile(String(FileName)); + Result := nil; // hide warning + AlJSONDocErrorA(CALJsonOperationError,GetNodeType) end; -{************************************************} -{Saves the JSON document to a string-type variable. - Call SaveToJSON to save the contents of the JSON document to the string-type variable specified by JSON. SaveToJSON writes the contents of JSON document - using 8 bits char (utf-8, iso-8859-1, etc) as an encoding system, depending on the type of the JSON parameter. - Unlike the JSON property, which lets you write individual lines from the JSON document, SaveToJSON writes the entire text of the JSON document.} -procedure TALJSONDocumentA.SaveToJSONString(var str: AnsiString); +{******************************************************************} +procedure TALJSONNodeA.SetChildNodes(const Value: TALJSONNodeListA); begin - CheckActive; - node.SaveToJSONString(Str); + AlJSONDocErrorA(CALJsonOperationError,GetNodeType) end; -{*****************************************************************} -procedure TALJSONDocumentA.SaveToBsonStream(const Stream: TStream); +{***************************************************************************} +function TALJSONNodeA.GetChildNode(const nodeName: ansiString): TALJSONNodeA; begin - CheckActive; - node.SaveToBsonStream(Stream); + result := ChildNodes.findNode(nodeName); end; -{****************************************************************} -procedure TALJSONDocumentA.SaveToBsonFile(const FileName: String); +{*************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueText(const nodeName: ansiString; const default: AnsiString): AnsiString; +var LNode: TALJSONNodeA; begin - CheckActive; - node.SaveToBsonFile(FileName); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetText(default); end; -{********************************************************************} -procedure TALJSONDocumentA.SaveToBsonFile(const FileName: AnsiString); +{******************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueFloat(const nodeName: ansiString; const default: Double): Double; +var LNode: TALJSONNodeA; begin - SaveToBsonFile(String(FileName)); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetFloat(default); end; -{***************************************************************} -procedure TALJSONDocumentA.SaveToBsonString(var str: AnsiString); +{***************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueDateTime(const nodeName: ansiString; const default: TDateTime): TDateTime; +var LNode: TALJSONNodeA; begin - CheckActive; - node.SaveToBsonString(Str); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetDateTime(default); end; -{*************************************} -{Returns the value of the JSON property. - GetJSON is the read implementation of the JSON property.} -function TALJSONDocumentA.GetJSON: AnsiString; +{******************************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueTimestamp(const nodeName: ansiString; const default: TALBSONTimestamp): TALBSONTimestamp; +var LNode: TALJSONNodeA; begin - SaveToJSONString(Result); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetTimestamp(default); end; -{*************************************} -{Returns the value of the BSON property. - GetBSON is the read implementation of the BSON property.} -function TALJSONDocumentA.GetBSON: AnsiString; +{********************************************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueObjectID(const nodeName: ansiString; const default: AnsiString): AnsiString; // return a "byte" string +var LNode: TALJSONNodeA; begin - SaveToBSONString(Result); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetObjectID(default); end; -{**********************************} -{Sets the value of the JSON property. - SetJSON is the write implementation of the JSON property. - *Value contains the raw (unparsed) JSON to assign.} -procedure TALJSONDocumentA.SetJSON(const Value: AnsiString); +{********************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueInt32(const nodeName: ansiString; const default: Integer): Integer; +var LNode: TALJSONNodeA; begin - LoadFromJSONString(Value, False{saxMode}, true{ClearChildNodes}); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetInt32(default); end; -{**********************************} -{Sets the value of the BSON property. - SetBSON is the write implementation of the BSON property. - *Value contains the raw (unparsed) BSON to assign.} -procedure TALJSONDocumentA.SetBSON(const Value: AnsiString); +{****************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueInt64(const nodeName: ansiString; const default: Int64): Int64; +var LNode: TALJSONNodeA; begin - LoadFromBSONString(Value, False{saxMode}, true{ClearChildNodes}); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetInt64(default); end; -{*************************************} -procedure TALJSONDocumentA.CheckActive; +{*******************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueBool(const nodeName: ansiString; const default: Boolean): Boolean; +var LNode: TALJSONNodeA; begin - if not Assigned(FDocumentNode) then AlJSONDocErrorA(CALJSONNotActive); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetBool(default); end; -{************************************************************************************************************************************************} -function TALJSONDocumentA.AddChild(const NodeName: AnsiString; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeA; +{*******************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueJavascript(const nodeName: ansiString; const default: AnsiString): AnsiString; +var LNode: TALJSONNodeA; begin - Result := Node.AddChild(NodeName, NodeType, Index); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetJavascript(default); end; -{*****************************************************************************************************************************************************} -function TALJSONDocumentA.AddChild(const Path: array of AnsiString; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeA; +{**************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueRegEx(const nodeName: ansiString; const default: ansiString): ansiString; +var LNode: TALJSONNodeA; begin - Result := Node.AddChild(Path, NodeType, Index); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetRegEx(default); end; -{*************************************************************************} -function TALJSONDocumentA.DeleteChild(const NodeName: AnsiString): boolean; +{***************************************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueRegExOptions(const nodeName: ansiString; const default: TALPerlRegExOptions): TALPerlRegExOptions; +var LNode: TALJSONNodeA; begin - Result := Node.DeleteChild(NodeName); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetRegExOptions(default); end; -{******************************************************************************} -function TALJSONDocumentA.DeleteChild(const Path: array of AnsiString): boolean; +{******************************************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueBinary(const nodeName: ansiString; const default: AnsiString): AnsiString; // return a "byte" string +var LNode: TALJSONNodeA; begin - Result := Node.DeleteChild(Path); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetBinary(default); end; -{********************************************************************************************************} -function TALJSONDocumentA.CreateNode(const NodeName: AnsiString; NodeType: TALJSONNodeType): TALJSONNodeA; +{**********************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueBinarySubType(const nodeName: ansiString; const default: byte): byte; +var LNode: TALJSONNodeA; begin - Result := ALCreateJSONNodeA(NodeName, NodeType); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetBinarySubType(default); end; -{********************************************} -{Returns the value of the ChildNodes property. - GetChildNodes is the read implementation of the ChildNodes property.} -function TALJSONDocumentA.GetChildNodes: TALJSONNodeListA; +{*******************************************************************************} +function TALJSONNodeA.GetChildNodeValueNull(const nodeName: ansiString): Boolean; +var LNode: TALJSONNodeA; begin - Result := Node.ChildNodes; + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := true + else result := LNode.GetNull; end; -{*******************************************************************************} -function TALJSONDocumentA.GetChildNode(const nodeName: ansiString): TALJSONNodeA; +{********************************************************************************} +function TALJSONNodeA.GetChildNode(const path: array of ansiString): TALJSONNodeA; +var I: integer; begin - result := Node.GetChildNode(nodeName); + result := Self; + for I := low(path) to high(path) do begin + result := result.ChildNodes.findNode(path[I]); + if (result = nil) then exit; + end; end; -{*****************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueText(const nodeName: ansiString; const default: AnsiString): AnsiString; +{******************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueText(const path: array of ansiString; const default: AnsiString): AnsiString; +var LNode: TALJSONNodeA; + I: integer; begin - result := Node.GetChildNodeValueText(nodeName, default); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetText(default); end; -{**********************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueFloat(const nodeName: ansiString; const default: Double): Double; +{***********************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueFloat(const path: array of ansiString; const default: Double): Double; +var LNode: TALJSONNodeA; + I: integer; begin - result := Node.GetChildNodeValueFloat(nodeName, default); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetFloat(default); end; -{*******************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueDateTime(const nodeName: ansiString; const default: TDateTime): TDateTime; +{********************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueDateTime(const path: array of ansiString; const default: TDateTime): TDateTime; +var LNode: TALJSONNodeA; + I: integer; begin - result := Node.GetChildNodeValueDateTime(nodeName, default); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetDateTime(default); end; -{**********************************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueTimestamp(const nodeName: ansiString; const default: TALBSONTimestamp): TALBSONTimestamp; +{***********************************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueTimestamp(const path: array of ansiString; const default: TALBSONTimestamp): TALBSONTimestamp; +var LNode: TALJSONNodeA; + I: integer; begin - result := Node.GetChildNodeValueTimestamp(nodeName, default); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetTimestamp(default); end; {*************************************************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueObjectID(const nodeName: ansiString; const default: AnsiString): AnsiString; // return a "byte" string +function TALJSONNodeA.GetChildNodeValueObjectID(const path: array of ansiString; const default: AnsiString): AnsiString; // return a "byte" string +var LNode: TALJSONNodeA; + I: integer; begin - result := Node.GetChildNodeValueObjectID(nodeName, default); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetObjectID(default); end; -{************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueInt32(const nodeName: ansiString; const default: Integer): Integer; +{*************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueInt32(const path: array of ansiString; const default: Integer): Integer; +var LNode: TALJSONNodeA; + I: integer; begin - result := Node.GetChildNodeValueInt32(nodeName, default); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetInt32(default); end; -{********************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueInt64(const nodeName: ansiString; const default: Int64): Int64; +{*********************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueInt64(const path: array of ansiString; const default: Int64): Int64; +var LNode: TALJSONNodeA; + I: integer; begin - result := Node.GetChildNodeValueInt64(nodeName, default); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetInt64(default); end; -{***********************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueBool(const nodeName: ansiString; const default: Boolean): Boolean; +{************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueBool(const path: array of ansiString; const default: Boolean): Boolean; +var LNode: TALJSONNodeA; + I: integer; begin - result := Node.GetChildNodeValueBool(nodeName, default); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetBool(default); end; -{***********************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueJavascript(const nodeName: ansiString; const default: AnsiString): AnsiString; +{************************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueJavascript(const path: array of ansiString; const default: AnsiString): AnsiString; +var LNode: TALJSONNodeA; + I: integer; begin - result := Node.GetChildNodeValueJavascript(nodeName, default); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetJavascript(default); end; -{******************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueRegEx(const nodeName: ansiString; const default: ansiString): ansiString; +{*******************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueRegEx(const path: array of ansiString; const default: ansiString): ansiString; +var LNode: TALJSONNodeA; + I: integer; begin - result := Node.GetChildNodeValueRegEx(nodeName, default); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetRegEx(default); end; -{*******************************************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueRegExOptions(const nodeName: ansiString; const default: TALPerlRegExOptions): TALPerlRegExOptions; +{********************************************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueRegExOptions(const path: array of ansiString; const default: TALPerlRegExOptions): TALPerlRegExOptions; +var LNode: TALJSONNodeA; + I: integer; begin - result := Node.GetChildNodeValueRegExOptions(nodeName, default); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetRegExOptions(default); end; {***********************************************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueBinary(const nodeName: ansiString; const default: AnsiString): AnsiString; // return a "byte" string -begin - result := Node.GetChildNodeValueBinary(nodeName, default); -end; - -{**************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueBinarySubType(const nodeName: ansiString; const default: byte): byte; +function TALJSONNodeA.GetChildNodeValueBinary(const path: array of ansiString; const default: AnsiString): AnsiString; // return a "byte" string +var LNode: TALJSONNodeA; + I: integer; begin - result := Node.GetChildNodeValueBinarySubType(nodeName, default); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetBinary(default); end; -{***********************************************************************************} -function TALJSONDocumentA.GetChildNodeValueNull(const nodeName: ansiString): Boolean; +{***************************************************************************************************************} +function TALJSONNodeA.GetChildNodeValueBinarySubType(const path: array of ansiString; const default: byte): byte; +var LNode: TALJSONNodeA; + I: integer; begin - result := Node.GetChildNodeValueNull(nodeName); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetBinarySubType(default); end; {************************************************************************************} -function TALJSONDocumentA.GetChildNode(const path: array of ansiString): TALJSONNodeA; -begin - result := Node.GetChildNode(path); -end; - -{**********************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueText(const path: array of ansiString; const default: AnsiString): AnsiString; +function TALJSONNodeA.GetChildNodeValueNull(const path: array of ansiString): Boolean; +var LNode: TALJSONNodeA; + I: integer; begin - result := Node.GetChildNodeValueText(path, default); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := True; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := true + else result := LNode.GetNull; end; -{***************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueFloat(const path: array of ansiString; const default: Double): Double; +{************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueText(const nodeName: ansiString; const value: AnsiString); +var LNode: TALJSONNodeA; begin - result := Node.GetChildNodeValueFloat(path, default); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetText(value) + else LNode.SetText(value); end; -{************************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueDateTime(const path: array of ansiString; const default: TDateTime): TDateTime; +{*********************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueFloat(const nodeName: ansiString; const value: Double); +var LNode: TALJSONNodeA; begin - result := Node.GetChildNodeValueDateTime(path, default); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetFloat(value) + else LNode.SetFloat(value); end; -{***************************************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueTimestamp(const path: array of ansiString; const default: TALBSONTimestamp): TALBSONTimestamp; +{***************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueDateTime(const nodeName: ansiString; const value: TDateTime); +var LNode: TALJSONNodeA; begin - result := Node.GetChildNodeValueTimestamp(path, default); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetDateTime(value) + else LNode.SetDateTime(value); end; -{******************************************************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueObjectID(const path: array of ansiString; const default: AnsiString): AnsiString; // return a "byte" string +{***********************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueTimestamp(const nodeName: ansiString; const value: TALBSONTimestamp); +var LNode: TALJSONNodeA; begin - result := Node.GetChildNodeValueObjectID(path, default); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetTimestamp(value) + else LNode.SetTimestamp(value); end; -{*****************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueInt32(const path: array of ansiString; const default: Integer): Integer; +{****************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueObjectID(const nodeName: ansiString; const value: AnsiString); +var LNode: TALJSONNodeA; begin - result := Node.GetChildNodeValueInt32(path, default); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetObjectID(value) + else LNode.SetObjectID(value); end; -{*************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueInt64(const path: array of ansiString; const default: Int64): Int64; +{**********************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueInt32(const nodeName: ansiString; const value: Integer); +var LNode: TALJSONNodeA; begin - result := Node.GetChildNodeValueInt64(path, default); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetInt32(value) + else LNode.SetInt32(value); end; -{****************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueBool(const path: array of ansiString; const default: Boolean): Boolean; +{********************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueInt64(const nodeName: ansiString; const value: Int64); +var LNode: TALJSONNodeA; begin - result := Node.GetChildNodeValueBool(path, default); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetInt64(value) + else LNode.SetInt64(value); end; -{****************************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueJavascript(const path: array of ansiString; const default: AnsiString): AnsiString; +{*********************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueBool(const nodeName: ansiString; const value: Boolean); +var LNode: TALJSONNodeA; begin - result := Node.GetChildNodeValueJavascript(path, default); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetBool(value) + else LNode.SetBool(value); end; -{***********************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueRegEx(const path: array of ansiString; const default: ansiString): ansiString; +{******************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueJavascript(const nodeName: ansiString; const value: AnsiString); +var LNode: TALJSONNodeA; begin - result := Node.GetChildNodeValueRegEx(path, default); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetJavascript(value) + else LNode.SetJavascript(value); end; -{************************************************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueRegExOptions(const path: array of ansiString; const default: TALPerlRegExOptions): TALPerlRegExOptions; +{*************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueRegEx(const nodeName: ansiString; const value: ansiString); +var LNode: TALJSONNodeA; begin - result := Node.GetChildNodeValueRegExOptions(path, default); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetRegEx(value) + else LNode.SetRegEx(value); end; -{****************************************************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueBinary(const path: array of ansiString; const default: AnsiString): AnsiString; // return a "byte" string +{*****************************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueRegExOptions(const nodeName: ansiString; const value: TALPerlRegExOptions); +var LNode: TALJSONNodeA; begin - result := Node.GetChildNodeValueBinary(path, default); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetRegExOptions(value) + else LNode.SetRegExOptions(value); end; -{*******************************************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueBinarySubType(const path: array of ansiString; const default: byte): byte; +{**************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueBinary(const nodeName: ansiString; const value: AnsiString); +var LNode: TALJSONNodeA; begin - result := Node.GetChildNodeValueBinarySubType(path, default); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetBinary(value) + else LNode.SetBinary(value); end; -{****************************************************************************************} -function TALJSONDocumentA.GetChildNodeValueNull(const path: array of ansiString): Boolean; +{***************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueBinarySubType(const nodeName: ansiString; const value: byte); +var LNode: TALJSONNodeA; begin - result := Node.GetChildNodeValueNull(path); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetBinarySubType(value) + else LNode.SetBinarySubType(value); end; -{****************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueText(const nodeName: ansiString; const value: AnsiString); +{***********************************************************************} +procedure TALJSONNodeA.SetChildNodeValueNull(const nodeName: ansiString); +var LNode: TALJSONNodeA; begin - Node.SetChildNodeValueText(nodeName, value); + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetNull(true) + else LNode.SetNull(true); end; -{*************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueFloat(const nodeName: ansiString; const value: Double); +{*****************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueText(const path: array of ansiString; const value: AnsiString); +var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - Node.SetChildNodeValueFloat(nodeName, value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetText(value) + else LTmpNode.SetText(value); end; -{*******************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueDateTime(const nodeName: ansiString; const value: TDateTime); +{**************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueFloat(const path: array of ansiString; const value: Double); +var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - Node.SetChildNodeValueDateTime(nodeName, value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetFloat(value) + else LTmpNode.SetFloat(value); end; -{***************************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueTimestamp(const nodeName: ansiString; const value: TALBSONTimestamp); +{********************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueDateTime(const path: array of ansiString; const value: TDateTime); +var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - Node.SetChildNodeValueTimestamp(nodeName, value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetDateTime(value) + else LTmpNode.SetDateTime(value); end; -{********************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueObjectID(const nodeName: ansiString; const value: AnsiString); +{****************************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueTimestamp(const path: array of ansiString; const value: TALBSONTimestamp); +var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - Node.SetChildNodeValueObjectID(nodeName, value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetTimestamp(value) + else LTmpNode.SetTimestamp(value); end; -{**************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueInt32(const nodeName: ansiString; const value: Integer); +{*********************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueObjectID(const path: array of ansiString; const value: AnsiString); +var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - Node.SetChildNodeValueInt32(nodeName, value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetObjectID(value) + else LTmpNode.SetObjectID(value); end; -{************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueInt64(const nodeName: ansiString; const value: Int64); +{***************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueInt32(const path: array of ansiString; const value: Integer); +var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - Node.SetChildNodeValueInt64(nodeName, value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetInt32(value) + else LTmpNode.SetInt32(value); end; {*************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueBool(const nodeName: ansiString; const value: Boolean); +procedure TALJSONNodeA.SetChildNodeValueInt64(const path: array of ansiString; const value: Int64); +var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - Node.SetChildNodeValueBool(nodeName, value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetInt64(value) + else LTmpNode.SetInt64(value); end; -{**********************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueJavascript(const nodeName: ansiString; const value: AnsiString); +{**************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueBool(const path: array of ansiString; const value: Boolean); +var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - Node.SetChildNodeValueJavascript(nodeName, value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetBool(value) + else LTmpNode.SetBool(value); end; -{*****************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueRegEx(const nodeName: ansiString; const value: ansiString); +{***********************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueJavascript(const path: array of ansiString; const value: AnsiString); +var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - Node.SetChildNodeValueRegEx(nodeName, value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetJavascript(value) + else LTmpNode.SetJavascript(value); end; -{*********************************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueRegExOptions(const nodeName: ansiString; const value: TALPerlRegExOptions); +{******************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueRegEx(const path: array of ansiString; const value: ansiString); +var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - Node.SetChildNodeValueRegExOptions(nodeName, value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetRegEx(value) + else LTmpNode.SetRegEx(value); end; -{******************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueBinary(const nodeName: ansiString; const value: AnsiString); +{**********************************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueRegExOptions(const path: array of ansiString; const value: TALPerlRegExOptions); +var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - Node.SetChildNodeValueBinary(nodeName, value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetRegExOptions(value) + else LTmpNode.SetRegExOptions(value); end; {*******************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueBinarySubType(const nodeName: ansiString; const value: byte); +procedure TALJSONNodeA.SetChildNodeValueBinary(const path: array of ansiString; const value: AnsiString); +var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - Node.SetChildNodeValueBinarySubType(nodeName, value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetBinary(value) + else LTmpNode.SetBinary(value); end; -{***************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueNull(const nodeName: ansiString); +{********************************************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueBinarySubType(const path: array of ansiString; const value: byte); +var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - Node.SetChildNodeValueNull(nodeName); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetBinarySubType(value) + else LTmpNode.SetBinarySubType(value); end; -{*********************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueText(const path: array of ansiString; const value: AnsiString); +{****************************************************************************} +procedure TALJSONNodeA.SetChildNodeValueNull(const path: array of ansiString); +var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - Node.SetChildNodeValueText(path, value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetNull(true) + else LTmpNode.SetNull(true); end; -{******************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueFloat(const path: array of ansiString; const value: Double); +{***********************************************} +{Indicates whether this node has any child nodes} +function TALJSONNodeA.GetHasChildNodes: Boolean; +Var LNodeList: TALJSONNodeListA; begin - Node.SetChildNodeValueFloat(path, value); + LNodeList := InternalGetChildNodes; + Result := assigned(LNodeList) and (LNodeList.Count > 0); end; -{************************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueDateTime(const path: array of ansiString; const value: TDateTime); +{************************************************} +function TALJSONNodeA.GetNodeValueStr: ansiString; begin - Node.SetChildNodeValueDateTime(path, value); + AlJSONDocErrorA(CALJsonOperationError,GetNodeType); + result := ''; // hide warning end; -{********************************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueTimestamp(const path: array of ansiString; const value: TALBSONTimestamp); +{*********************************************} +function TALJSONNodeA.GetNodeValueInt64: int64; begin - Node.SetChildNodeValueTimestamp(path, value); + AlJSONDocErrorA(CALJsonOperationError,GetNodeType); + result := 0; // hide warning end; -{*************************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueObjectID(const path: array of ansiString; const value: AnsiString); +{**************************************************************************************************} +procedure TALJSONNodeA.SetNodeValue(const Value: AnsiString; const NodeSubType: TALJSONNodeSubType); begin - Node.SetChildNodeValueObjectID(path, value); + AlJSONDocErrorA(CALJsonOperationError,GetNodeType); end; -{*******************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueInt32(const path: array of ansiString; const value: Integer); +{*********************************************************************************************} +procedure TALJSONNodeA.SetNodeValue(const Value: int64; const NodeSubType: TALJSONNodeSubType); begin - Node.SetChildNodeValueInt32(path, value); + AlJSONDocErrorA(CALJsonOperationError,GetNodeType); end; -{*****************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueInt64(const path: array of ansiString; const value: Int64); +{******************************************************************************************************************************} +procedure TALJSONNodeA.SetNodeValue(const StrValue: AnsiString; const Int64Value: int64; const NodeSubType: TALJSONNodeSubType); begin - Node.SetChildNodeValueInt64(path, value); + AlJSONDocErrorA(CALJsonOperationError,GetNodeType); end; -{******************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueBool(const path: array of ansiString; const value: Boolean); +{*************************************************************} +procedure TALJSONNodeA.SetNodeName(const NodeName: AnsiString); begin - Node.SetChildNodeValueBool(path, value); + if fNodeName <> NodeName then begin + fNodeName := NodeName; + Var LParentNode := FParentNode; + if (LParentNode <> nil) and (LParentNode.ChildNodes.Sorted) then begin + var LNode := LParentNode.ChildNodes.Extract(self); + Try + LParentNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + End; + end; + end; end; -{***************************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueJavascript(const path: array of ansiString; const value: AnsiString); +{***********************************} +{Returns the text value of the node.} +function TALJSONNodeA.GetText: AnsiString; begin - Node.SetChildNodeValueJavascript(path, value); -end; -{**********************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueRegEx(const path: array of ansiString; const value: ansiString); -begin - Node.SetChildNodeValueRegEx(path, value); -end; + case NodeSubType of + nstFloat: result := GetNodeValueStr; // return the formated float + nstText: result := GetNodeValueStr; // return the raw text + nstObject: result := GetNodeValueStr; // return the raw objectID + nstArray: result := GetNodeValueStr; // error + nstObjectID: result := GetNodeValueStr; // error + nstBoolean: result := GetNodeValueStr; // return true or false + nstDateTime: result := GetNodeValueStr; // return the formated datetime + nstNull: result := GetNodeValueStr; // return null + nstRegEx: result := GetNodeValueStr; // return the raw regex (without the options) + nstBinary: result := GetNodeValueStr; // return the raw binary (without the binary subtype) + nstJavascript: result := GetNodeValueStr; // return the raw javascript + nstInt32: result := GetNodeValueStr; // return the number + nstTimestamp: result := GetNodeValueStr; // return the number (as int64) + nstInt64: result := GetNodeValueStr; // return the number + else AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + end; -{**************************************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueRegExOptions(const path: array of ansiString; const value: TALPerlRegExOptions); -begin - Node.SetChildNodeValueRegExOptions(path, value); end; -{***********************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueBinary(const path: array of ansiString; const value: AnsiString); +{*******************************************************************} +function TALJSONNodeA.GetText(const default: AnsiString): AnsiString; begin - Node.SetChildNodeValueBinary(path, value); + if NodeSubType = nstNull then result := default + else result := GetText; end; -{************************************************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueBinarySubType(const path: array of ansiString; const value: byte); +{********************************} +{Sets the text value of the node.} +procedure TALJSONNodeA.SetText(const Value: AnsiString); begin - Node.SetChildNodeValueBinarySubType(path, value); + setNodeValue(Value, nstText); end; -{********************************************************************************} -procedure TALJSONDocumentA.SetChildNodeValueNull(const path: array of ansiString); -begin - Node.SetChildNodeValueNull(path); -end; +{***********************************} +// By default json (ie: javascript) treats all numbers as floating-point values. +// To let other system (ie: mongoDB) understand the type of the number +// we provide the helper functions NumberLong() to handle 64-bit integers +// and NumberInt() to handle 32-bit integers (and some others). theses helper functions are +// used when saving the json document. +function TALJSONNodeA.GetNodeValueInterchange(const SkipNodeSubTypeHelper: boolean = False): AnsiString; + + {~~~~~~~~~~~~~~~~~~~~~} + procedure _GetObjectID; + begin + if SkipNodeSubTypeHelper then result := '"'+ALBinToHexA(ObjectID)+'"' + else result := 'ObjectId("'+ALBinToHexA(ObjectID)+'")'; + end; -{**************************************************} -function TALJSONDocumentA.ExtractNode: TALJSONNodeA; -begin - if assigned(FDocumentNode) then begin - result := FDocumentNode; - result.SetOwnerDocument(nil); - FDocumentNode := nil; - end - else result := nil; -end; + {~~~~~~~~~~~~~~~~~~~} + procedure _GetBinary; + begin + if SkipNodeSubTypeHelper then result := '"'+ALBase64EncodeString(Binary)+'"' + else result := 'BinData('+ALIntToStrA(BinarySubType)+', "'+ALBase64EncodeString(Binary)+'")'; + end; -{************************************************************************} -{Indicates whether the TJSONDocument instance represents an empty document. - Call IsEmptyDoc to determine whether the TALJSONDocumentA instance represents an empty document. - IsEmptyDoc returns true if the Document property is not set or if this object represents a - document with no child nodes.} -function TALJSONDocumentA.IsEmptyDoc: Boolean; -begin - Result := not (Assigned(FDocumentNode) and FDocumentNode.hasChildNodes); -end; + {~~~~~~~~~~~~~~~~~~~~~} + procedure _GetDateTime; + begin + if SkipNodeSubTypeHelper then result := ALFormatDateTimeA('''"''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z"''', DateTime, ALDefaultFormatSettingsA) + else result := ALFormatDateTimeA('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', DateTime, ALDefaultFormatSettingsA) + end; -{**************************************} -{Returns the value of the Node property. - GetDocumentNode is the read implementation of the Node property.} -function TALJSONDocumentA.GetDocumentNode: TALJSONNodeA; -begin - CheckActive; - Result := FDocumentNode; -end; + {~~~~~~~~~~~~~~~~~~} + procedure _Getint32; + begin + if SkipNodeSubTypeHelper then result := text + else result := 'NumberInt(' + text + ')' + end; -{***********************************************} -{Returns the value of the NodeIndentStr property. - GetNodeIndentStr is the read implementation of the NodeIndentStr property.} -function TALJSONDocumentA.GetNodeIndentStr: AnsiString; -begin - Result := FNodeIndentStr; -end; + {~~~~~~~~~~~~~~~~~~} + procedure _Getint64; + begin + if SkipNodeSubTypeHelper then result := text + else result := 'NumberLong(' + text + ')'; + end; -{********************************************} -{Sets the value of the NodeIndentStr property. - SetNodeIndentStr is the write implementation of the NodeIndentStr property. - *Value is the string that is inserted before nested nodes to indicate a level of nesting.} -procedure TALJSONDocumentA.SetNodeIndentStr(const Value: AnsiString); -begin - FNodeIndentStr := Value; -end; + {~~~~~~~~~~~~~~~~~~} + procedure _GetRegEx; + var LRegExOptions: TALPerlRegExOptions; + LRegExOptionsStr: ansiString; + begin + LRegExOptionsStr := ''; + LRegExOptions := RegExOptions; + if preCaseLess in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr + 'i'; + if preMultiLine in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr +'m'; + if preExtended in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr +'x'; + //'l':; + if preSingleLine in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr + 's'; + //'u':; + result := '/'+regex+'/' + LRegExOptionsStr; + if not SkipNodeSubTypeHelper then result := '"' + ALJavascriptEncode(result) + '"'; + end; -{*****************************************************************} -procedure TALJSONDocumentA.SetDuplicates(const Value: TDuplicates); -begin - if FDuplicates <> Value then begin - FDuplicates := Value; - if assigned(FDocumentNode) then begin - Var LNodeList := FDocumentNode.InternalGetChildNodes; - if LNodeList <> nil then LNodeList.SetDuplicates(FDuplicates, True{Recurse}) - end; + {~~~~~~~~~~~~~~~~~~~~~~} + procedure _GetTimestamp; + begin + if SkipNodeSubTypeHelper then result := '"Timestamp('+ALIntToStrA(GetTimeStamp.W1)+', '+ALIntToStrA(GetTimeStamp.W2)+')"' + else result := 'Timestamp('+ALIntToStrA(GetTimeStamp.W1)+', '+ALIntToStrA(GetTimeStamp.W2)+')'; end; -end; -{*****************************************} -{Returns the value of the Options property. - GetOptions is the read implementation of the Options property.} -function TALJSONDocumentA.GetOptions: TALJSONDocOptions; begin - Result := FOptions; -end; -{**************************************} -{Sets the value of the Options property. - GetOptions is the write implementation of the Options property. - *Value is the set of options to assign.} -procedure TALJSONDocumentA.SetOptions(const Value: TALJSONDocOptions); -begin - var LSortedChanged := (doSorted in FOptions) <> (doSorted in Value); - FOptions := Value; - if LSortedChanged and assigned(FDocumentNode) then begin - Var LNodeList := FDocumentNode.InternalGetChildNodes; - if LNodeList <> nil then LNodeList.SetSorted(doSorted in FOptions, True{Recurse}) + case NodeSubType of + nstFloat: result := GetNodeValueStr; + nstText: result := GetNodeValueStr; + nstBinary: _GetBinary; + nstObjectID: _GetObjectID; + nstBoolean: result := GetNodeValueStr; + nstDateTime: _GetDateTime; + nstJavascript: result := GetNodeValueStr; + nstInt32: _Getint32; + nstInt64: _Getint64; + nstNull: result := GetNodeValueStr; + nstObject: result := GetNodeValueStr; + nstArray: result := GetNodeValueStr; + nstRegEx: _GetRegEx; + nstTimestamp: _GetTimestamp; + else raise Exception.Create('Unknown Node SubType'); end; -end; -{**********************************************} -{Returns the value of the ParseOptions property. - GetParseOptions is the read implementation of the ParseOptions property.} -function TALJSONDocumentA.GetParseOptions: TALJSONParseOptions; -begin - Result := FParseOptions; end; -{*******************************************} -{Sets the value of the ParseOptions property. - GetParseOptions is the write implementation of the ParseOptions property. - *Value is the set of parser options to assign.} -procedure TALJSONDocumentA.SetParseOptions(const Value: TALJSONParseOptions); +{*************************************} +function TALJSONNodeA.GetFloat: Double; begin - FParseOptions := Value; + case NodeSubType of + nstFloat: PInt64(@result)^ := GetNodeValueInt64; + nstInt32, + nstInt64: Result := GetNodeValueInt64; + else begin + AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + result := 0; // to hide a warning; + end; + end; end; -{*****************************************************************} -procedure TALJSONDocumentA.SetPathSeparator(const Value: ansiChar); +{************************************************************} +function TALJSONNodeA.GetFloat(const default: Double): Double; begin - FPathSeparator := Value; + if NodeSubType = nstNull then result := default + else result := GetFloat; end; {***************************************************} -function TALJSONDocumentA.GetPathSeparator: ansiChar; +procedure TALJSONNodeA.SetFloat(const Value: Double); begin - result := fPathSeparator; + setNodeValue(PInt64(@Value)^, nstFloat); end; -{**********************************************} -procedure TALJSONDocumentA.DoParseStartDocument; +{*******************************************} +function TALJSONNodeA.GetDateTime: TDateTime; begin - if Assigned(fonParseStartDocument) then fonParseStartDocument(Self); + if NodeSubType = nstDateTime then PInt64(@result)^ := GetNodeValueInt64 + else begin + AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + result := 0; // to hide a warning; + end; end; -{********************************************} -procedure TALJSONDocumentA.DoParseEndDocument; +{*********************************************************************} +function TALJSONNodeA.GetDateTime(const default: TDateTime): TDateTime; begin - if Assigned(fonParseEndDocument) then fonParseEndDocument(Self); + if NodeSubType = nstNull then result := default + else result := GetDateTime; end; -{**************************************************************************************************************************************************} -procedure TALJSONDocumentA.DoParseText(const Path: AnsiString; const name: AnsiString; const Args: array of const; NodeSubType: TALJSONNodeSubType); +{*********************************************************} +procedure TALJSONNodeA.SetDateTime(const Value: TDateTime); begin - if Assigned(fonParseText) then fonParseText(Self, Path, name, Args, NodeSubType); + setNodeValue(PInt64(@Value)^, nstDateTime); end; -{********************************************************************************************} -procedure TALJSONDocumentA.DoParseStartObject(const Path: AnsiString; const Name: AnsiString); +{***************************************************} +function TALJSONNodeA.GetTimestamp: TALBSONTimestamp; begin - if Assigned(fonParseStartObject) then fonParseStartObject(Self, Path, name); + if NodeSubType = nstTimestamp then result.I64 := GetNodeValueInt64 + else begin + AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + result.I64 := 0; // to hide a warning; + end; end; -{******************************************************************************************} -procedure TALJSONDocumentA.DoParseEndObject(const Path: AnsiString; const Name: AnsiString); +{************************************************************************************} +function TALJSONNodeA.GetTimestamp(const default: TALBSONTimestamp): TALBSONTimestamp; begin - if Assigned(fonParseEndObject) then fonParseEndObject(Self, Path, name); + if NodeSubType = nstNull then result := default + else result := GetTimestamp; end; -{*******************************************************************************************} -procedure TALJSONDocumentA.DoParseStartArray(const Path: AnsiString; const Name: AnsiString); +{*****************************************************************} +procedure TALJSONNodeA.SetTimestamp(const Value: TALBSONTimestamp); begin - if Assigned(fonParseStartArray) then fonParseStartArray(Self, Path, name); + setNodeValue(Value.I64, nstTimestamp); end; -{*****************************************************************************************} -procedure TALJSONDocumentA.DoParseEndArray(const Path: AnsiString; const Name: AnsiString); +{********************************************} +function TALJSONNodeA.GetObjectID: ansiString; begin - if Assigned(fonParseEndArray) then fonParseEndArray(Self, Path, name); + if NodeSubType = nstObjectID then result := GetNodeValueStr + else begin + AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + result := ''; // to hide a warning; + end; end; -{**********************************************************} -{Creates the object that implements the ChildNodes property} -function TALJSONNodeA.CreateChildList: TALJSONNodeListA; +{***********************************************************************} +function TALJSONNodeA.GetObjectID(const default: AnsiString): AnsiString; begin - result := TALJSONNodeListA.Create(Self); + if NodeSubType = nstNull then result := default + else result := GetObjectID; end; -{********************************************} -{Get Childnode without create it if not exist} -function TALJSONNodeA.InternalGetChildNodes: TALJSONNodeListA; +{**********************************************************} +procedure TALJSONNodeA.SetObjectID(const Value: AnsiString); begin - Result := nil; //virtual; + if length(Value) <> 12 {div sizeof(ansiChar)} then AlJSONDocErrorA('ObjectID must have 12 bytes'); + setNodeValue(Value, nstObjectID); end; -{****************************************************} -function TALJSONNodeA.GetChildNodes: TALJSONNodeListA; +{**************************************} +function TALJSONNodeA.GetInt32: Integer; +var LDouble: Double; + LInt64: system.int64; begin - Result := nil; // hide warning - AlJSONDocErrorA(CALJsonOperationError,GetNodeType) + case NodeSubType of + nstFloat: begin + PInt64(@LDouble)^ := GetNodeValueInt64; + LInt64 := trunc(LDouble); + if (LInt64 <> LDouble) or // https://stackoverflow.com/questions/41779801/single-double-and-precision + // Only values that are in form m*2^e, where m and e are integers can be stored in a floating point variable + // so all integer can be store in the form m*2^e (ie: m = m*2^0) + // so we can compare aInt64 <> aDouble without the need of samevalue + (LInt64 > system.int32.MaxValue) or + (LInt64 < system.int32.MinValue) then AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + result := LInt64; + end; + nstInt32: begin + LInt64 := GetNodeValueInt64; + if (LInt64 > system.int32.MaxValue) or + (LInt64 < system.int32.MinValue) then AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + result := LInt64; + end; + nstInt64: Result := GetNodeValueInt64; + else begin + AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + result := 0; // to hide a warning; + end; + end; end; -{******************************************************************} -procedure TALJSONNodeA.SetChildNodes(const Value: TALJSONNodeListA); +{**************************************************************} +function TALJSONNodeA.GetInt32(const default: Integer): Integer; begin - AlJSONDocErrorA(CALJsonOperationError,GetNodeType) + if NodeSubType = nstNull then result := default + else result := GetInt32; end; -{***************************************************************************} -function TALJSONNodeA.GetChildNode(const nodeName: ansiString): TALJSONNodeA; +{****************************************************} +procedure TALJSONNodeA.SetInt32(const Value: Integer); begin - result := ChildNodes.findNode(nodeName); + setNodeValue(Value, nstInt32); end; -{*************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueText(const nodeName: ansiString; const default: AnsiString): AnsiString; -var LNode: TALJSONNodeA; +{************************************} +function TALJSONNodeA.GetInt64: Int64; +var LDouble: Double; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetText(default); + case NodeSubType of + nstFloat: begin + PInt64(@LDouble)^ := GetNodeValueInt64; + result := trunc(LDouble); + if result <> LDouble then AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); // https://stackoverflow.com/questions/41779801/single-double-and-precision + // Only values that are in form m*2^e, where m and e are integers can be stored in a floating point variable + // so all integer can be store in the form m*2^e (ie: m = m*2^0) + // so we can compare result <> aDouble without the need of samevalue + end; + nstInt32, + nstInt64: Result := GetNodeValueInt64; + else begin + AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + result := 0; // to hide a warning; + end; + end; end; -{******************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueFloat(const nodeName: ansiString; const default: Double): Double; -var LNode: TALJSONNodeA; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetFloat(default); +{**********************************************************} +function TALJSONNodeA.GetInt64(const default: Int64): Int64; +begin + if NodeSubType = nstNull then result := default + else result := GetInt64; end; -{***************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueDateTime(const nodeName: ansiString; const default: TDateTime): TDateTime; -var LNode: TALJSONNodeA; +{**************************************************} +procedure TALJSONNodeA.SetInt64(const Value: Int64); begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetDateTime(default); + setNodeValue(Value, nstInt64); end; -{******************************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueTimestamp(const nodeName: ansiString; const default: TALBSONTimestamp): TALBSONTimestamp; -var LNode: TALJSONNodeA; +{*************************************} +function TALJSONNodeA.GetBool: Boolean; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetTimestamp(default); + if NodeSubType = nstBoolean then begin + if GetNodeValueInt64 = 0 then result := False + else result := true; + end + else begin + AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + result := False; // to hide a warning; + end; end; -{********************************************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueObjectID(const nodeName: ansiString; const default: AnsiString): AnsiString; // return a "byte" string -var LNode: TALJSONNodeA; +{*************************************************************} +function TALJSONNodeA.GetBool(const default: Boolean): Boolean; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetObjectID(default); + if NodeSubType = nstNull then result := default + else result := GetBool; end; -{********************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueInt32(const nodeName: ansiString; const default: Integer): Integer; -var LNode: TALJSONNodeA; +{***************************************************} +procedure TALJSONNodeA.SetBool(const Value: Boolean); begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetInt32(default); + if Value then setNodeValue(1, nstBoolean) + else setNodeValue(0, nstBoolean); end; -{****************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueInt64(const nodeName: ansiString; const default: Int64): Int64; -var LNode: TALJSONNodeA; +{*************************************} +function TALJSONNodeA.GetNull: Boolean; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetInt64(default); + result := NodeSubType = nstNull; end; -{*******************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueBool(const nodeName: ansiString; const default: Boolean): Boolean; -var LNode: TALJSONNodeA; +{***************************************************} +procedure TALJSONNodeA.SetNull(const Value: Boolean); begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetBool(default); + if Value then setNodeValue(0, nstNull) + else AlJSONDocErrorA('Only "true" is allowed for setNull property'); end; -{*******************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueJavascript(const nodeName: ansiString; const default: AnsiString): AnsiString; -var LNode: TALJSONNodeA; +{**********************************************} +function TALJSONNodeA.GetJavascript: AnsiString; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetJavascript(default); + if NodeSubType = nstJavascript then result := GetNodeValueStr + else begin + AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + result := ''; // to hide a warning; + end; end; -{**************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueRegEx(const nodeName: ansiString; const default: ansiString): ansiString; -var LNode: TALJSONNodeA; +{*************************************************************************} +function TALJSONNodeA.GetJavascript(const default: AnsiString): AnsiString; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetRegEx(default); + if NodeSubType = nstNull then result := default + else result := GetJavascript; end; -{***************************************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueRegExOptions(const nodeName: ansiString; const default: TALPerlRegExOptions): TALPerlRegExOptions; -var LNode: TALJSONNodeA; +{************************************************************} +procedure TALJSONNodeA.SetJavascript(const Value: AnsiString); begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetRegExOptions(default); + setNodeValue(Value, nstJavascript); end; -{******************************************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueBinary(const nodeName: ansiString; const default: AnsiString): AnsiString; // return a "byte" string -var LNode: TALJSONNodeA; +{*****************************************} +function TALJSONNodeA.GetRegEx: ansiString; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetBinary(default); + if NodeSubType = nstRegEx then result := GetNodeValueStr + else begin + AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + result := ''; // to hide a warning; + end; end; -{**********************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueBinarySubType(const nodeName: ansiString; const default: byte): byte; -var LNode: TALJSONNodeA; +{********************************************************************} +function TALJSONNodeA.GetRegEx(const default: ansiString): ansiString; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetBinarySubType(default); + if NodeSubType = nstNull then result := default + else result := GetRegEx; end; -{*******************************************************************************} -function TALJSONNodeA.GetChildNodeValueNull(const nodeName: ansiString): Boolean; -var LNode: TALJSONNodeA; +{*********************************************************} +procedure TALJSONNodeA.SetRegEx(const Pattern: ansiString); begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := true - else result := LNode.GetNull; + setNodeValue(Pattern, 0, nstRegEx); end; -{********************************************************************************} -function TALJSONNodeA.GetChildNode(const path: array of ansiString): TALJSONNodeA; -var I: integer; +{*********************************************************************************************} +procedure TALJSONNodeA.SetRegEx(const Pattern: ansiString; const Options: TALPerlRegExOptions); begin - result := Self; - for I := low(path) to high(path) do begin - result := result.ChildNodes.findNode(path[I]); - if (result = nil) then exit; - end; + setNodeValue(Pattern, byte(Options), nstRegEx); end; -{******************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueText(const path: array of ansiString; const default: AnsiString): AnsiString; -var LNode: TALJSONNodeA; - I: integer; +{*********************************************************} +function TALJSONNodeA.GetRegExOptions: TALPerlRegExOptions; begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; + if NodeSubType = nstRegEx then result := TALPerlRegExOptions(byte(GetNodeValueInt64)) + else begin + AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + result := []; // to hide a warning; end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetText(default); end; -{***********************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueFloat(const path: array of ansiString; const default: Double): Double; -var LNode: TALJSONNodeA; - I: integer; +{*********************************************************************************************} +function TALJSONNodeA.GetRegExOptions(const default: TALPerlRegExOptions): TALPerlRegExOptions; begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetFloat(default); + if NodeSubType = nstNull then result := default + else result := GetRegExOptions; end; -{********************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueDateTime(const path: array of ansiString; const default: TDateTime): TDateTime; -var LNode: TALJSONNodeA; - I: integer; +{***********************************************************************} +procedure TALJSONNodeA.SetRegExOptions(const Value: TALPerlRegExOptions); begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetDateTime(default); + if NodeSubType <> nstRegEx then AlJSONDocErrorA('You can set regex options only to a regex node'); + setNodeValue(byte(Value), nstRegEx); end; -{***********************************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueTimestamp(const path: array of ansiString; const default: TALBSONTimestamp): TALBSONTimestamp; -var LNode: TALJSONNodeA; - I: integer; +{******************************************} +function TALJSONNodeA.GetBinary: AnsiString; begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; + if NodeSubType = nstBinary then result := GetNodeValueStr + else begin + AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + result := ''; // to hide a warning; end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetTimestamp(default); end; -{*************************************************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueObjectID(const path: array of ansiString; const default: AnsiString): AnsiString; // return a "byte" string -var LNode: TALJSONNodeA; - I: integer; +{*********************************************************************} +function TALJSONNodeA.GetBinary(const default: AnsiString): AnsiString; begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetObjectID(default); + if NodeSubType = nstNull then result := default + else result := GetBinary; end; -{*************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueInt32(const path: array of ansiString; const default: Integer): Integer; -var LNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetInt32(default); +{*******************************************************} +procedure TALJSONNodeA.SetBinary(const Data: AnsiString); +begin + setNodeValue(Data, 0, nstBinary); // 0 = Default BSON type end; -{*********************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueInt64(const path: array of ansiString; const default: Int64): Int64; -var LNode: TALJSONNodeA; - I: integer; +{****************************************************************************} +procedure TALJSONNodeA.SetBinary(const Data: AnsiString; const Subtype: byte); begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetInt64(default); + setNodeValue(Data, Subtype, nstBinary); end; -{************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueBool(const path: array of ansiString; const default: Boolean): Boolean; -var LNode: TALJSONNodeA; - I: integer; +{*******************************************} +function TALJSONNodeA.GetBinarySubType: byte; begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; + if NodeSubType = nstBinary then result := byte(GetNodeValueInt64) + else begin + AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + result := 0; // to hide a warning; end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetBool(default); end; -{************************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueJavascript(const path: array of ansiString; const default: AnsiString): AnsiString; -var LNode: TALJSONNodeA; - I: integer; +{****************************************************************} +function TALJSONNodeA.GetBinarySubType(const default: byte): byte; begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetJavascript(default); + if NodeSubType = nstNull then result := default + else result := GetBinarySubType; end; -{*******************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueRegEx(const path: array of ansiString; const default: ansiString): ansiString; -var LNode: TALJSONNodeA; - I: integer; +{***********************************************************} +procedure TALJSONNodeA.SetBinarySubType(const Subtype: byte); begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetRegEx(default); + if NodeSubType <> nstBinary then AlJSONDocErrorA('You can set binary subtype only to a binary node'); + setNodeValue(Subtype, nstBinary); end; -{********************************************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueRegExOptions(const path: array of ansiString; const default: TALPerlRegExOptions): TALPerlRegExOptions; -var LNode: TALJSONNodeA; - I: integer; +{************************} +{returns the parent node.} +function TALJSONNodeA.GetParentNode: TALJSONNodeA; begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetRegExOptions(default); + Result := FParentNode; end; -{***********************************************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueBinary(const path: array of ansiString; const default: AnsiString): AnsiString; // return a "byte" string -var LNode: TALJSONNodeA; - I: integer; +{******************************************} +{Sets the value of the ParentNode property.} +procedure TALJSONNodeA.SetParentNode(const Value: TALJSONNodeA); begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetBinary(default); + if FParentNode <> Value then + FParentNode := Value; end; -{***************************************************************************************************************} -function TALJSONNodeA.GetChildNodeValueBinarySubType(const path: array of ansiString; const default: byte): byte; -var LNode: TALJSONNodeA; - I: integer; +{*******************************************************************} +{Returns the JSON that corresponds to the subtree rooted at this node. + GetJSON returns the JSON that corresponds to this node and any child nodes it contains.} +function TALJSONNodeA.GetJSON: AnsiString; begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetBinarySubType(default); + SaveToJSONString(result); end; -{************************************************************************************} -function TALJSONNodeA.GetChildNodeValueNull(const path: array of ansiString): Boolean; -var LNode: TALJSONNodeA; - I: integer; +{************************************************} +{SetJSON reload the node with the new given value } +procedure TALJSONNodeA.SetJSON(const Value: AnsiString); +Begin + LoadFromJSONString(Value); +end; + +{*******************************************************************} +{Returns the BSON that corresponds to the subtree rooted at this node. + GetBSON returns the BSON that corresponds to this node and any child nodes it contains.} +function TALJSONNodeA.GetBSON: AnsiString; begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := True; - exit; - end; + SaveToBSONString(result); +end; + +{************************************************} +{SetBSON reload the node with the new given value } +procedure TALJSONNodeA.SetBSON(const Value: AnsiString); +Begin + LoadFromBSONString(Value); +end; + +{*****************************************************************} +{Returns the number of parents for this node in the node hierarchy. + NestingLevel returns the number of ancestors for this node in the node hierarchy.} +function TALJSONNodeA.NestingLevel: Integer; +var PNode: TALJSONNodeA; +begin + Result := 0; + PNode := ParentNode; + while PNode <> nil do begin + Inc(Result); + PNode := PNode.ParentNode; end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := true - else result := LNode.GetNull; end; -{************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueText(const nodeName: ansiString; const value: AnsiString); -var LNode: TALJSONNodeA; +{**********************************************************} +constructor TALJSONNodeA.Create(const NodeName: AnsiString); +Begin + FParentNode := nil; + fNodeName := NodeName; +end; + +{***************************************************************} +//will create all the nodevalue and childnodelist to be sure that +//multiple thread can safely read at the same time the node +procedure TALJSONNodeA.MultiThreadPrepare(const aOnlyChildList: Boolean = False); +var I: integer; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetText(value) - else LNode.SetText(value); + if (not aOnlyChildList) and (NodeType = ntText) then begin + + case NodeSubType of + nstFloat, + nstBoolean, + nstDateTime, + nstNull, + nstInt32, + nstTimestamp, + nstInt64: GetNodeValueStr; + //nstText: can not be retrieve from int64 + //nstObject: can not be retrieve from int64 + //nstArray: can not be retrieve from int64 + //nstBinary: only the binarysubtype is store in int64 + //nstObjectID: can not be retrieve from int64 + //nstRegEx: only the regex options is store in the int64 + //nstJavascript: can not be retrieve from int64 + end; + + case NodeSubType of + nstFloat, + nstBoolean, + nstDateTime, + nstNull, + nstInt32, + nstTimestamp, + nstInt64: GetNodeValueInt64; + //nstText: can not be retrieve from int64 + //nstObject: can not be retrieve from int64 + //nstArray: can not be retrieve from int64 + //nstBinary: only the binarysubtype is store in int64 + //nstObjectID: can not be retrieve from int64 + //nstRegEx: only the regex options is store in the int64 + //nstJavascript: can not be retrieve from int64 + end; + + end + + else if (NodeType in [ntObject,ntArray]) then begin + For I := 0 to ChildNodes.Count - 1 do + ChildNodes[I].MultiThreadPrepare(aOnlyChildList); + end; end; -{*********************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueFloat(const nodeName: ansiString; const value: Double); -var LNode: TALJSONNodeA; +{********************************************************************************************************************************************} +function TALJSONNodeA.AddChild(const NodeName: AnsiString; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeA; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetFloat(value) - else LNode.SetFloat(value); + Result := ALCreateJSONNodeA(NodeName,NodeType); + Try + ChildNodes.Insert(Index, Result); + except + FreeAndNil(Result); + raise; + end; end; -{***************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueDateTime(const nodeName: ansiString; const value: TDateTime); +{*************************************************************************************************************************************************} +function TALJSONNodeA.AddChild(const Path: array of AnsiString; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeA; var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetDateTime(value) - else LNode.SetDateTime(value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I], TDirection.FromEnd); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + result := LNode.addChild(path[high(path)], NodeType, Index); end; -{***********************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueTimestamp(const nodeName: ansiString; const value: TALBSONTimestamp); -var LNode: TALJSONNodeA; +{****************************************************************************************************************} +function TALJSONNodeA.AddChild(const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeA; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetTimestamp(value) - else LNode.SetTimestamp(value); + Result := AddChild('', NodeType, Index); end; -{****************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueObjectID(const nodeName: ansiString; const value: AnsiString); -var LNode: TALJSONNodeA; +{*********************************************************************} +function TALJSONNodeA.DeleteChild(const NodeName: AnsiString): boolean; +var I: integer; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetObjectID(value) - else LNode.SetObjectID(value); + I := ChildNodes.IndexOf(NodeName); + if I >= 0 then begin + ChildNodes.Delete(I); + result := True; + end + else result := False; end; -{**********************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueInt32(const nodeName: ansiString; const value: Integer); +{**************************************************************************} +function TALJSONNodeA.DeleteChild(const Path: array of AnsiString): boolean; var LNode: TALJSONNodeA; + LTmpNode: TALJSONNodeA; + I: integer; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetInt32(value) - else LNode.SetInt32(value); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then exit(false) + else LNode := LTmpNode; + end; + I := LNode.ChildNodes.IndexOf(path[high(path)]); + if I >= 0 then begin + LNode.ChildNodes.Delete(I); + result := True; + end + else result := False; end; -{********************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueInt64(const nodeName: ansiString; const value: Int64); -var LNode: TALJSONNodeA; +{****************************************************************************************************} +function TALJSONNodeA.CreateNode(const NodeName: AnsiString; NodeType: TALJSONNodeType): TALJSONNodeA; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetInt64(value) - else LNode.SetInt64(value); + Result := ALCreateJSONNodeA(NodeName, NodeType); end; -{*********************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueBool(const nodeName: ansiString; const value: Boolean); -var LNode: TALJSONNodeA; +{******************************************} +{Returns the next child of this node’s parent. + NextSibling returns the node that follows this one in the parent node’s ChildNodes property list. + If this node is the last node in its parent’s child list, NextSibling raises an exception.} +function TALJSONNodeA.NextSibling: TALJSONNodeA; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetBool(value) - else LNode.SetBool(value); + if Assigned(ParentNode) then Result := ParentNode.ChildNodes.FindSibling(Self, 1) + else Result := nil; end; -{******************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueJavascript(const nodeName: ansiString; const value: AnsiString); -var LNode: TALJSONNodeA; +{************************************************} +{Returns the previous child of this node’s parent. + PreviousSibling returns the node that precedes this one in the parent node’s ChildNodes property list. + If this node is the first node in its parent’s child list, PreviousSibling raises an exception.} +function TALJSONNodeA.PreviousSibling: TALJSONNodeA; begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetJavascript(value) - else LNode.SetJavascript(value); + if Assigned(ParentNode) then Result := ParentNode.ChildNodes.FindSibling(Self, -1) + else Result := nil; end; -{*************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueRegEx(const nodeName: ansiString; const value: ansiString); -var LNode: TALJSONNodeA; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetRegEx(value) - else LNode.SetRegEx(value); -end; +{**************} +{The JSON format + There are just a few rules that you need to remember: + *Objects are encapsulated within opening and closing brackets { } { + *An empty object can be represented by { } { + *Arrays are encapsulated within opening and closing square brackets [ ] + *An empty array can be represented by [ ] + *A member is represented by a key-value pair + *The key of a member should be contained in double quotes. (JavaScript does not require this. JavaScript and some parsers will tolerate single-quotes) + *Each member should have a unique key within an object structure + *The value of a member must be contained in double quotes if it's a string (JavaScript and some parsers will tolerates single-quotes) + *Boolean values are represented using the true or false literals in lower case + *Number values are represented using double-precision floating-point format. Scientific notation is supported + *Numbers should not have leading zeroes + *"Offensive"" characters in a string need to be escaped using the backslash character + *Null values are represented by the null literal in lower case + *Other object types, such as dates, are not properly supported and should be converted to strings. It becomes the responsability of the parser/client to manage this. + *Each member of an object or each array value must be followed by a comma if it's not the last one + *The common extension for json files is '.json' + *The mime type for json files is 'application/json'} +Procedure TALJSONNodeA.ParseJSON( + const RawJSONStream: TStream; + const RawJSONString: AnsiString; + const SaxMode: Boolean; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions); + +Const BufferSize: integer = 8192; + +Var Buffer: AnsiString; + BufferLength: Integer; + BufferPos: Integer; + CurrName: AnsiString; + CurrIndex: integer; + CurrValue: ansiString; + NotSaxMode: Boolean; + WorkingNode: TALJSONNodeA; + NamePaths: TALNVStringListA; + ObjectPaths: TALIntegerList; + DecodeJSONReferences: boolean; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function ExpandBuffer: boolean; overload; + Var ByteReaded, Byte2Read: Integer; + Begin + if not assigned(RawJSONStream) then begin + result := false; + exit; + end; + + If (BufferLength > 0) and (BufferPos > 1) then begin + if (BufferPos > BufferLength) then RawJSONStream.Position := RawJSONStream.Position - BufferLength + BufferPos - 1; + Byte2Read := min(BufferPos - 1, BufferLength); + if BufferPos <= length(Buffer) then ALMove( + Pbyte(Buffer)[BufferPos - 1], + pointer(Buffer)^, + BufferLength-BufferPos+1); + BufferPos := 1; + end + else begin + Byte2Read := BufferSize; + BufferLength := BufferLength + BufferSize; + SetLength(Buffer, BufferLength); + end; + + //range check error is we not do so + if RawJSONStream.Position < RawJSONStream.Size then ByteReaded := RawJSONStream.Read(Pbyte(Buffer)[BufferLength - Byte2Read{+ 1 - 1}],Byte2Read) + else ByteReaded := 0; + + If ByteReaded <> Byte2Read then begin + BufferLength := BufferLength - Byte2Read + ByteReaded; + SetLength(Buffer, BufferLength); + Result := ByteReaded > 0; + end + else result := True; + end; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function ExpandBuffer(var PosToKeepSync: Integer): boolean; overload; + var P1: integer; + begin + P1 := BufferPos; + result := ExpandBuffer; + PosToKeepSync := PosToKeepSync - (P1 - BufferPos); + end; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function GetPathStr(Const ExtraItems: ansiString = ''): ansiString; + var I, L, P, Size: Integer; + LB: ansiChar; + S: AnsiString; + begin + LB := ALDefaultJsonPathSeparatorA; + Size := length(ExtraItems); + if size <> 0 then Inc(Size, 1{length(LB)}); + for I := 1 to NamePaths.Count - 1 do Inc(Size, Length(NamePaths.Names[I]) + 1{length(LB)}); + SetLength(Result, Size); + P := 1; + for I := 1 to NamePaths.Count - 1 do begin + S := NamePaths.Names[I]; + L := Length(S); + if L <> 0 then begin + ALMove(pointer(S)^, Pbyte(Result)[(P-1){*sizeOf(ansiChar)}], L{*sizeOf(ansiChar)}); + Inc(P, L); + end; + L := 1{length(LB)}; + if ((i <> NamePaths.Count - 1) or + (ExtraItems <> '')) and + (((NotSaxMode) and (TALJSONNodeA(NamePaths.Objects[I]).nodetype <> ntarray)) or + ((not NotSaxMode) and (TALJSONNodeType(NamePaths.Objects[I]) <> ntarray))) then begin + ALMove(LB, Pbyte(Result)[(P-1){*sizeOf(ansiChar)}], L{*sizeOf(ansiChar)}); + Inc(P, L); + end; + end; + if ExtraItems <> '' then begin + L := length(ExtraItems); + ALMove(pointer(ExtraItems)^, Pbyte(Result)[(P-1){*sizeOf(ansiChar)}], L{*sizeOf(ansiChar)}); + Inc(P, L); + end; + setlength(result,P-1); + end; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseTextWithIndex( + const index: integer; + const Args: array of const; + const NodeSubType: TALJSONNodeSubType); + begin + if Assigned(OnParseText) then OnParseText(Self, GetPathStr('[' + ALIntToStrA(index) + ']'), '', Args, NodeSubType) + end; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseTextWithName( + const name: AnsiString; + const Args: array of const; + const NodeSubType: TALJSONNodeSubType); + begin + if Assigned(OnParseText) then OnParseText(Self, GetPathStr(Name), Name, Args, NodeSubType) + end; + + {~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseText( + const Index: integer; + const Name: AnsiString; + const Args: array of const; + const NodeSubType: TALJSONNodeSubType); + begin + if Assigned(OnParseText) then begin + if notSaxMode then begin + if WorkingNode.nodetype=ntarray then _DoParseTextWithIndex(Index, Args, NodeSubType) + else _DoParseTextWithName(Name, Args, NodeSubType); + end + else begin + if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); + if TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntArray then _DoParseTextWithIndex(Index, Args, NodeSubType) + else _DoParseTextWithName(Name, Args, NodeSubType); + end; + end; + end; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseStartObject(const Name: AnsiString); + begin + if Assigned(OnParseStartObject) then OnParseStartObject(Self, GetPathStr, Name); + end; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseEndObject; + begin + if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); + if Assigned(OnParseEndObject) then OnParseEndObject(Self, GetPathStr, NamePaths.Names[NamePaths.Count - 1]) + end; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseStartArray(const index: AnsiString); + begin + if Assigned(OnParseStartArray) then OnParseStartArray(Self, GetPathStr, index) + end; -{*****************************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueRegExOptions(const nodeName: ansiString; const value: TALPerlRegExOptions); -var LNode: TALJSONNodeA; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetRegExOptions(value) - else LNode.SetRegExOptions(value); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseEndArray; + begin + if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); + if Assigned(OnParseEndArray) then OnParseEndArray(Self, GetPathStr, NamePaths.Names[NamePaths.Count - 1]); + end; -{**************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueBinary(const nodeName: ansiString; const value: AnsiString); -var LNode: TALJSONNodeA; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetBinary(value) - else LNode.SetBinary(value); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _AddIndexItemToNamePath(const index: integer; Obj: Pointer); + var S1: ansiString; + begin + setlength(S1,sizeOf(Integer) {div sizeOF(ansiChar)}); // off course sizeOf(Integer) must be a multiple of sizeOf(ansiChar) but it's always the case + ALmove(index, pointer(S1)^, sizeOf(Integer)); + NamePaths.AddNameValueObject('[' + ALIntToStrA(Index) + ']', S1, Obj) + end; -{***************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueBinarySubType(const nodeName: ansiString; const value: byte); -var LNode: TALJSONNodeA; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetBinarySubType(value) - else LNode.SetBinarySubType(value); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _AddNameItemToNamePath(const name: AnsiString; Obj: Pointer); + begin + NamePaths.AddNameValueObject(Name, #$ff#$ff#$ff#$ff, Obj) + end; -{***********************************************************************} -procedure TALJSONNodeA.SetChildNodeValueNull(const nodeName: ansiString); -var LNode: TALJSONNodeA; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetNull(true) - else LNode.SetNull(true); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _AddItemToNamePath(index: integer; const name: AnsiString; Obj: Pointer); + begin + if notSaxMode then begin + if WorkingNode.nodetype=ntarray then _AddIndexItemToNamePath(Index, Obj) + else _AddNameItemToNamePath(name, Obj); + end + else begin + if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); + if TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntarray then _AddIndexItemToNamePath(Index, Obj) + else _AddNameItemToNamePath(name, Obj); + end; + end; -{*****************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueText(const path: array of ansiString; const value: AnsiString); -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createInt64Node(index: integer; const name: AnsiString; const value: ansiString): boolean; + var LNode: TALJSONNodeA; + LInt64: System.Int64; + begin + if ALJSONTryStrToInt64A(value, LInt64) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetInt64(LInt64); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LInt64], nstInt64) + end + else begin + _DoParseText(index, Name, [LInt64], nstInt64) + end; + end + else result := False; end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetText(value) - else LTmpNode.SetText(value); -end; -{**************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueFloat(const path: array of ansiString; const value: Double); -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createInt32Node(index: integer; const name: AnsiString; const value: ansiString): boolean; + var LNode: TALJSONNodeA; + LInt32: System.Int32; + begin + if ALJSONTryStrToInt32A(value, LInt32) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setint32(LInt32); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LInt32], nstInt32) + end + else begin + _DoParseText(index, Name, [LInt32], nstInt32) + end + end + else result := False; end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetFloat(value) - else LTmpNode.SetFloat(value); -end; -{********************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueDateTime(const path: array of ansiString; const value: TDateTime); -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createTextNode(index: integer; const name: AnsiString; const value: ansiString): boolean; + var LNode: TALJSONNodeA; + begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Settext(value); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [value], nstText) + end + else begin + _DoParseText(index, Name, [value], nstText) + end end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetDateTime(value) - else LTmpNode.SetDateTime(value); -end; -{****************************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueTimestamp(const path: array of ansiString; const value: TALBSONTimestamp); -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createFloatNode(index: integer; const name: AnsiString; const value: ansiString): boolean; + var LNode: TALJSONNodeA; + LDouble: Double; + begin + if ALTryStrToFloat(value, LDouble, ALDefaultFormatSettingsA) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetFloat(LDouble); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LDouble], nstFloat) + end + else begin + _DoParseText(index, Name, [LDouble], nstFloat) + end + end + else result := False; end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetTimestamp(value) - else LTmpNode.SetTimestamp(value); -end; -{*********************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueObjectID(const path: array of ansiString; const value: AnsiString); -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createBinaryNode(index: integer; const name: AnsiString; const value: ansiString): boolean; + var LNode: TALJSONNodeA; + LBinSubtype: byte; + LBinData: ansiString; + begin + if ALJSONTryStrToBinaryA(value, LBinData, LBinSubtype) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.setbinary(LBinData, LBinSubtype); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LBinData, LBinSubtype], nstBinary); + end + else begin + _DoParseText(index, Name, [LBinData, LBinSubtype], nstBinary); + end + end + else result := False; end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetObjectID(value) - else LTmpNode.SetObjectID(value); -end; -{***************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueInt32(const path: array of ansiString; const value: Integer); -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createObjectIDNode(index: integer; const name: AnsiString; const value: ansiString): boolean; + var LNode: TALJSONNodeA; + LObjectID: AnsiString; + begin + if ALJSONTryStrToObjectIDA(value, LObjectID) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetObjectID(LObjectID); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LObjectID], nstObjectID) + end + else begin + _DoParseText(index, Name, [LObjectID], nstObjectID) + end; + end + else result := False; end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetInt32(value) - else LTmpNode.SetInt32(value); -end; -{*************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueInt64(const path: array of ansiString; const value: Int64); -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createBooleanNode(index: integer; const name: AnsiString; const value: ansiString): boolean; + var LNode: TALJSONNodeA; + LBool: Boolean; + begin + if value = 'true' then LBool := true + else if value = 'false' then LBool := false + else begin + result := False; + exit; + end; + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setbool(LBool); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LBool], nstBoolean); + end + else begin + _DoParseText(index, Name, [LBool], nstBoolean); + end; end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetInt64(value) - else LTmpNode.SetInt64(value); -end; -{**************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueBool(const path: array of ansiString; const value: Boolean); -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createDateTimeNode(index: integer; const name: AnsiString; const value: ansiString): boolean; + var LNode: TALJSONNodeA; + LDateTime: TdateTime; + begin + if ALJSONTryStrToDateTimeA(value, LDateTime) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setdatetime(LDateTime); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LDateTime], nstDateTime); + end + else begin + _DoParseText(index, Name, [LDateTime], nstDateTime); + end; + end + else result := False; end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetBool(value) - else LTmpNode.SetBool(value); -end; -{***********************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueJavascript(const path: array of ansiString; const value: AnsiString); -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createTimestampNode(index: integer; const name: AnsiString; const value: ansiString): boolean; + var LNode: TALJSONNodeA; + LTimestamp: TALBSONTimestamp; + begin + if ALJSONTryStrToTimestampA(value, LTimestamp) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetTimestamp(LTimestamp); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LTimestamp.W1, LTimestamp.W2], nstTimeStamp); + end + else begin + _DoParseText(index, Name, [LTimestamp.W1, LTimestamp.W2], nstTimeStamp); + end; + end + else result := False; end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetJavascript(value) - else LTmpNode.SetJavascript(value); -end; -{******************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueRegEx(const path: array of ansiString; const value: ansiString); -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createnullNode(index: integer; const name: AnsiString; const value: ansiString): boolean; + var LNode: TALJSONNodeA; + begin + if value = 'null' then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setnull(true); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, ['null'], nstNull); + end + else begin + _DoParseText(index, Name, ['null'], nstNull); + end; + end + else result := False; end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetRegEx(value) - else LTmpNode.SetRegEx(value); -end; -{**********************************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueRegExOptions(const path: array of ansiString; const value: TALPerlRegExOptions); -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createRegExNode(index: integer; const name: AnsiString; const value: ansiString): boolean; + var LNode: TALJSONNodeA; + LRegEx: ansiString; + LRegExOptions: TALPerlRegExOptions; + begin + if ALJSONTryStrToRegExA(value, LRegEx, LRegExOptions) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetRegEx(LRegEx, LRegExOptions); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LRegEx, Byte(LRegExOptions)], nstRegEx) + end + else begin + _DoParseText(index, Name, [LRegEx, Byte(LRegExOptions)], nstRegEx) + end; + end + else result := False; + end; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createJavascriptNode(index: integer; const name: AnsiString; const value: ansiString): boolean; + var LNode: TALJSONNodeA; + begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetJavascript(value); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [value], nstJavascript); + end + else begin + _DoParseText(index, Name, [value], nstJavascript); + end; end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetRegExOptions(value) - else LTmpNode.SetRegExOptions(value); -end; -{*******************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueBinary(const path: array of ansiString; const value: AnsiString); -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createNode(index: integer; const name: AnsiString; const value: ansiString; AQuotedValue: Boolean); + begin + if AQuotedValue then begin + _createTextNode(index, Name, Value); + exit; + end; + if _createFloatNode(index, Name, Value) then exit; // << we have the same problem as javascript, if we put here a big number like (by exemple) 9223372036854775808 + // << then the stored value will be different because of double precision that is less than int64 precision + // << it's the way javascript json work, it's have no room for int / int64 :( + // << if we want to have the possibility to store int64 precision then we must use node subtype helper + // << like NumberLong(9223372036854775808) + if _createBooleanNode(index, Name, Value) then exit; + if _createNullNode(index, Name, Value) then exit; + if _createInt32Node(index, Name, Value) then exit; + if _createInt64Node(index, Name, Value) then exit; + if _createDateTimeNode(index, Name, Value) then exit; + if _createBinaryNode(index, Name, Value) then exit; + if _createObjectIDNode(index, Name, Value) then exit; + if _createRegExNode(index, Name, Value) then exit; + if _createTimeStampNode(index, Name, Value) then exit; + _createJavascriptNode(index, Name, Value); end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetBinary(value) - else LTmpNode.SetBinary(value); -end; -{********************************************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueBinarySubType(const path: array of ansiString; const value: byte); -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _extractLastIndexFromNamePath: integer; + begin + if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); + ALMove(pointer(namePaths.ValueFromIndex[namepaths.Count - 1])^,result,sizeOf(integer)); end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetBinarySubType(value) - else LTmpNode.SetBinarySubType(value); -end; -{****************************************************************************} -procedure TALJSONNodeA.SetChildNodeValueNull(const path: array of ansiString); -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; - end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetNull(true) - else LTmpNode.SetNull(true); -end; + {~~~~~~~~~~~~~~~~~~~~} + procedure AnalyzeNode; + Var LNode: TALJSONNodeA; + LNodeType: TALJSONNodeType; + LQuoteChar: AnsiChar; + LNameValueSeparator: ansiChar; + LInSingleQuote: boolean; + LInDoubleQuote: boolean; + LInSlashQuote: boolean; + LInSquareBracket: integer; + LInRoundBracket: integer; + LInCurlyBracket: integer; + P1, P2: Integer; + c: ansiChar; + Begin -{***********************************************} -{Indicates whether this node has any child nodes} -function TALJSONNodeA.GetHasChildNodes: Boolean; -Var LNodeList: TALJSONNodeListA; -begin - LNodeList := InternalGetChildNodes; - Result := assigned(LNodeList) and (LNodeList.Count > 0); -end; + {$REGION 'init current char (c)'} + c := Buffer[BufferPos]; + {$ENDREGION} -{************************************************} -function TALJSONNodeA.GetNodeValueStr: ansiString; -begin - AlJSONDocErrorA(CALJsonOperationError,GetNodeType); - result := ''; // hide warning -end; + {$REGION 'end Object/Array'} + // ... } .... + // ... ] .... + if c in ['}',']'] then begin // ... } ... + // ^BufferPos -{*********************************************} -function TALJSONNodeA.GetNodeValueInt64: int64; -begin - AlJSONDocErrorA(CALJsonOperationError,GetNodeType); - result := 0; // hide warning -end; + //Reset the CurrIndex + CurrIndex := -1; -{**************************************************************************************************} -procedure TALJSONNodeA.SetNodeValue(const Value: AnsiString; const NodeSubType: TALJSONNodeSubType); -begin - AlJSONDocErrorA(CALJsonOperationError,GetNodeType); -end; + //error if Paths.Count = 0 (mean one end object/array without any starting) + if assigned(ObjectPaths) then begin + if (ObjectPaths.Count = 0) then AlJSONDocErrorA(cALJSONParseError); + end + else begin + if (NamePaths.Count = 0) then AlJSONDocErrorA(cALJSONParseError); + end; -{*********************************************************************************************} -procedure TALJSONNodeA.SetNodeValue(const Value: int64; const NodeSubType: TALJSONNodeSubType); -begin - AlJSONDocErrorA(CALJsonOperationError,GetNodeType); -end; + //if we are not in sax mode + if NotSaxMode then begin -{******************************************************************************************************************************} -procedure TALJSONNodeA.SetNodeValue(const StrValue: AnsiString; const Int64Value: int64; const NodeSubType: TALJSONNodeSubType); -begin - AlJSONDocErrorA(CALJsonOperationError,GetNodeType); -end; + //init anode to one level up + if assigned(ObjectPaths) then LNode := TALJSONNodeA(ObjectPaths.Objects[ObjectPaths.Count - 1]) + else LNode := TALJSONNodeA(NamePaths.Objects[NamePaths.Count - 1]); -{*************************************************************} -procedure TALJSONNodeA.SetNodeName(const NodeName: AnsiString); -begin - if fNodeName <> NodeName then begin - fNodeName := NodeName; - Var LParentNode := FParentNode; - if (LParentNode <> nil) and (LParentNode.ChildNodes.Sorted) then begin - var LNode := LParentNode.ChildNodes.Extract(self); - Try - LParentNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - End; - end; - end; -end; + //if anode <> workingNode aie aie aie + if (LNode <> WorkingNode) then AlJSONDocErrorA(CALJSONParseError); -{***********************************} -{Returns the text value of the node.} -function TALJSONNodeA.GetText: AnsiString; -begin + //calculate anodeTypeInt + LNodeType := LNode.NodeType; + if not (LNodeType in [ntObject, ntarray]) then AlJSONDocErrorA(cALJSONParseError); - case NodeSubType of - nstFloat: begin // return the formated float - if Assigned(FDocument) and (Fdocument.FormatSettings <> @ALDefaultFormatSettingsA) then result := ALFloatToStrA(GetFloat, Fdocument.FormatSettings^) - else result := GetNodeValueStr; - end; - nstText: result := GetNodeValueStr; // return the raw text - nstObject: result := GetNodeValueStr; // return the raw objectID - nstArray: result := GetNodeValueStr; // error - nstObjectID: result := GetNodeValueStr; // error - nstBoolean: result := GetNodeValueStr; // return true or false - nstDateTime: begin // return the formated datetime - if Assigned(FDocument) and (Fdocument.FormatSettings <> @ALDefaultFormatSettingsA) then result := ALDateTimeToStrA(GetDateTime, Fdocument.FormatSettings^) - else result := GetNodeValueStr; - end; - nstNull: result := GetNodeValueStr; // return null - nstRegEx: result := GetNodeValueStr; // return the raw regex (without the options) - nstBinary: result := GetNodeValueStr; // return the raw binary (without the binary subtype) - nstJavascript: result := GetNodeValueStr; // return the raw javascript - nstInt32: result := GetNodeValueStr; // return the number - nstTimestamp: result := GetNodeValueStr; // return the number (as int64) - nstInt64: result := GetNodeValueStr; // return the number - else AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - end; + //check that the end object/array correspond to the aNodeType + if ((c = '}') and + (LNodeType <> ntObject)) or + ((c = ']') and + (LNodeType <> ntarray)) then AlJSONDocErrorA(CALJSONParseError); -end; + //if working node <> Self then we can go to one level up + If WorkingNode <> Self then begin -{*******************************************************************} -function TALJSONNodeA.GetText(const default: AnsiString): AnsiString; -begin - if NodeSubType = nstNull then result := default - else result := GetText; -end; + //init WorkingNode to the parentNode + WorkingNode := WorkingNode.ParentNode; -{********************************} -{Sets the text value of the node.} -procedure TALJSONNodeA.SetText(const Value: AnsiString); -begin - setNodeValue(Value, nstText); -end; + //update CurrIndex if WorkingNode.NodeType = ntArray + if assigned(ObjectPaths) then begin + if WorkingNode.NodeType = ntArray then CurrIndex := ObjectPaths[Objectpaths.Count - 1] + 1; + end + else begin + if WorkingNode.NodeType = ntArray then CurrIndex := _extractLastIndexFromNamePath + 1; + end; -{***********************************} -// By default json (ie: javascript) treats all numbers as floating-point values. -// To let other system (ie: mongoDB) understand the type of the number -// we provide the helper functions NumberLong() to handle 64-bit integers -// and NumberInt() to handle 32-bit integers (and some others). theses helper functions are -// used when saving the json document. -function TALJSONNodeA.GetNodeValueInterchange(const SkipNodeSubTypeHelper: boolean = False): AnsiString; + end - {~~~~~~~~~~~~~~~~~~~~~} - procedure _GetObjectID; - begin - if SkipNodeSubTypeHelper then result := '"'+ALBinToHexA(ObjectID)+'"' - else result := 'ObjectId("'+ALBinToHexA(ObjectID)+'")'; - end; + //if working node = Self then we can no go to the parent node so set WorkingNode to nil + Else WorkingNode := nil; - {~~~~~~~~~~~~~~~~~~~} - procedure _GetBinary; - begin - if SkipNodeSubTypeHelper then result := '"'+ALBase64EncodeString(Binary)+'"' - else result := 'BinData('+ALIntToStrA(BinarySubType)+', "'+ALBase64EncodeString(Binary)+'")'; - end; + end - {~~~~~~~~~~~~~~~~~~~~~} - procedure _GetDateTime; - begin - if SkipNodeSubTypeHelper then result := ALFormatDateTimeA('''"''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z"''', DateTime, ALDefaultFormatSettingsA) - else result := ALFormatDateTimeA('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', DateTime, ALDefaultFormatSettingsA) - end; + //if we are in sax mode + else begin - {~~~~~~~~~~~~~~~~~~} - procedure _Getint32; - begin - if SkipNodeSubTypeHelper then result := text - else result := 'NumberInt(' + text + ')' - end; + //calculate anodeTypeInt + LNodeType := TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]); + if not (LNodeType in [ntObject,ntarray]) then AlJSONDocErrorA(cALJSONParseError); - {~~~~~~~~~~~~~~~~~~} - procedure _Getint64; - begin - if SkipNodeSubTypeHelper then result := text - else result := 'NumberLong(' + text + ')'; - end; + //check that the end object/array correspond to the aNodeType + if ((c = '}') and + (LNodeType <> ntObject)) or + ((c = ']') and + (LNodeType <> ntarray)) then AlJSONDocErrorA(CALJSONParseError); - {~~~~~~~~~~~~~~~~~~} - procedure _GetRegEx; - var LRegExOptions: TALPerlRegExOptions; - LRegExOptionsStr: ansiString; - begin - LRegExOptionsStr := ''; - LRegExOptions := RegExOptions; - if preCaseLess in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr + 'i'; - if preMultiLine in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr +'m'; - if preExtended in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr +'x'; - //'l':; - if preSingleLine in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr + 's'; - //'u':; - result := '/'+regex+'/' + LRegExOptionsStr; - if not SkipNodeSubTypeHelper then result := '"' + ALJavascriptEncode(result) + '"'; - end; + //update CurrIndex if WorkingNode.NodeType = ntArray + if (Namepaths.Count >= 2) and + (TALJSONNodeType(NamePaths.Objects[Namepaths.Count - 2]) = ntarray) then CurrIndex := _extractLastIndexFromNamePath + 1; - {~~~~~~~~~~~~~~~~~~~~~~} - procedure _GetTimestamp; - begin - if SkipNodeSubTypeHelper then result := '"Timestamp('+ALIntToStrA(GetTimeStamp.W1)+', '+ALIntToStrA(GetTimeStamp.W2)+')"' - else result := 'Timestamp('+ALIntToStrA(GetTimeStamp.W1)+', '+ALIntToStrA(GetTimeStamp.W2)+')'; - end; + end; -begin + //call the DoParseEndObject/array event + if Assigned(OnParseEndObject) then begin + if LNodeType = ntObject then _DoParseEndObject + else _DoParseEndArray; + end; - case NodeSubType of - nstFloat: result := GetNodeValueStr; - nstText: result := GetNodeValueStr; - nstBinary: _GetBinary; - nstObjectID: _GetObjectID; - nstBoolean: result := GetNodeValueStr; - nstDateTime: _GetDateTime; - nstJavascript: result := GetNodeValueStr; - nstInt32: _Getint32; - nstInt64: _Getint64; - nstNull: result := GetNodeValueStr; - nstObject: result := GetNodeValueStr; - nstArray: result := GetNodeValueStr; - nstRegEx: _GetRegEx; - nstTimestamp: _GetTimestamp; - else raise Exception.Create('Unknown Node SubType'); - end; + //delete the last entry from the path + if assigned(ObjectPaths) then ObjectPaths.Delete(ObjectPaths.Count - 1) + else NamePaths.Delete(NamePaths.Count - 1); -end; + //update BufferPos + BufferPos := BufferPos + 1; // ... } ... + // ^BufferPos + + //finallly exit from this procedure, everything was done + exit; -{*************************************} -function TALJSONNodeA.GetFloat: Double; -begin - case NodeSubType of - nstFloat: PInt64(@result)^ := GetNodeValueInt64; - nstInt32, - nstInt64: Result := GetNodeValueInt64; - else begin - AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - result := 0; // to hide a warning; end; - end; -end; + {$ENDREGION} -{************************************************************} -function TALJSONNodeA.GetFloat(const default: Double): Double; -begin - if NodeSubType = nstNull then result := default - else result := GetFloat; -end; + {$REGION 'Begin Object/Array Without NAME'} + // ... { .... + // ... [ .... + if c in ['{','['] then begin // ... { ... + // ^BufferPos -{***************************************************} -procedure TALJSONNodeA.SetFloat(const Value: Double); -begin - setNodeValue(PInt64(@Value)^, nstFloat); -end; + //if we are not in sax mode + if NotSaxMode then begin -{*******************************************} -function TALJSONNodeA.GetDateTime: TDateTime; -begin - if NodeSubType = nstDateTime then PInt64(@result)^ := GetNodeValueInt64 - else begin - AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - result := 0; // to hide a warning; - end; -end; + //if workingnode = nil then it's mean we are outside Self + if not assigned(WorkingNode) then AlJSONDocErrorA(CALJSONParseError); -{*********************************************************************} -function TALJSONNodeA.GetDateTime(const default: TDateTime): TDateTime; -begin - if NodeSubType = nstNull then result := default - else result := GetDateTime; -end; + //Node without name can be ONLY present inside an array node + if (CurrIndex < 0) or + (WorkingNode.nodetype <> ntarray) then AlJSONDocErrorA(CALJSONParseError); -{*********************************************************} -procedure TALJSONNodeA.SetDateTime(const Value: TDateTime); -begin - setNodeValue(PInt64(@Value)^, nstDateTime); -end; + //create the node according the the braket char and add it to the workingnode + if c = '{' then LNode := CreateNode('', ntObject) + else LNode := CreateNode('', ntarray); + try + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; -{***************************************************} -function TALJSONNodeA.GetTimestamp: TALBSONTimestamp; -begin - if NodeSubType = nstTimestamp then result.I64 := GetNodeValueInt64 - else begin - AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - result.I64 := 0; // to hide a warning; - end; -end; + //set that the current working node will be now the new node newly created + WorkingNode := LNode; -{************************************************************************************} -function TALJSONNodeA.GetTimestamp(const default: TALBSONTimestamp): TALBSONTimestamp; -begin - if NodeSubType = nstNull then result := default - else result := GetTimestamp; -end; + //update the path + if assigned(ObjectPaths) then ObjectPaths.AddObject(CurrIndex, WorkingNode) + else _AddItemToNamePath(CurrIndex, '', WorkingNode); -{*****************************************************************} -procedure TALJSONNodeA.SetTimestamp(const Value: TALBSONTimestamp); -begin - setNodeValue(Value.I64, nstTimestamp); -end; + end -{********************************************} -function TALJSONNodeA.GetObjectID: ansiString; -begin - if NodeSubType = nstObjectID then result := GetNodeValueStr - else begin - AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - result := ''; // to hide a warning; - end; -end; + //if we are in sax mode + else begin -{***********************************************************************} -function TALJSONNodeA.GetObjectID(const default: AnsiString): AnsiString; -begin - if NodeSubType = nstNull then result := default - else result := GetObjectID; -end; + //Node without name can be ONLY present inside an array node + if (CurrIndex < 0) or + (NamePaths.Count = 0) or + (TALJsonNodeType(NamePaths.Objects[Namepaths.Count - 1]) <> ntarray) then AlJSONDocErrorA(CALJSONParseError); -{**********************************************************} -procedure TALJSONNodeA.SetObjectID(const Value: AnsiString); -begin - if length(Value) <> 12 {div sizeof(ansiChar)} then AlJSONDocErrorA('ObjectID must have 12 bytes'); - setNodeValue(Value, nstObjectID); -end; + //update the path + if c = '{' then LNodeType := ntObject + else LNodeType := ntArray; + _AddItemToNamePath(CurrIndex, '', pointer(LNodeType)); -{**************************************} -function TALJSONNodeA.GetInt32: Integer; -var LDouble: Double; - LInt64: system.int64; -begin - case NodeSubType of - nstFloat: begin - PInt64(@LDouble)^ := GetNodeValueInt64; - LInt64 := trunc(LDouble); - if (LInt64 <> LDouble) or // https://stackoverflow.com/questions/41779801/single-double-and-precision - // Only values that are in form m*2^e, where m and e are integers can be stored in a floating point variable - // so all integer can be store in the form m*2^e (ie: m = m*2^0) - // so we can compare aInt64 <> aDouble without the need of samevalue - (LInt64 > system.int32.MaxValue) or - (LInt64 < system.int32.MinValue) then AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - result := LInt64; - end; - nstInt32: begin - LInt64 := GetNodeValueInt64; - if (LInt64 > system.int32.MaxValue) or - (LInt64 < system.int32.MinValue) then AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - result := LInt64; - end; - nstInt64: Result := GetNodeValueInt64; - else begin - AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - result := 0; // to hide a warning; - end; - end; -end; + end; -{**************************************************************} -function TALJSONNodeA.GetInt32(const default: Integer): Integer; -begin - if NodeSubType = nstNull then result := default - else result := GetInt32; -end; + //call the DoParseStartObject/array event + if c = '{' then begin + if Assigned(OnParseStartObject) then _DoParseStartObject(''); + CurrIndex := -1; + end + else begin + if Assigned(OnParseStartArray) then _DoParseStartArray(''); + CurrIndex := 0; + end; -{****************************************************} -procedure TALJSONNodeA.SetInt32(const Value: Integer); -begin - setNodeValue(Value, nstInt32); -end; + //update BufferPos + BufferPos := BufferPos + 1; // ... { ... + // ^BufferPos + + //finallly exit from this procedure, everything was done + exit; -{************************************} -function TALJSONNodeA.GetInt64: Int64; -var LDouble: Double; -begin - case NodeSubType of - nstFloat: begin - PInt64(@LDouble)^ := GetNodeValueInt64; - result := trunc(LDouble); - if result <> LDouble then AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); // https://stackoverflow.com/questions/41779801/single-double-and-precision - // Only values that are in form m*2^e, where m and e are integers can be stored in a floating point variable - // so all integer can be store in the form m*2^e (ie: m = m*2^0) - // so we can compare result <> aDouble without the need of samevalue - end; - nstInt32, - nstInt64: Result := GetNodeValueInt64; - else begin - AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - result := 0; // to hide a warning; end; - end; -end; + {$ENDREGION} -{**********************************************************} -function TALJSONNodeA.GetInt64(const default: Int64): Int64; -begin - if NodeSubType = nstNull then result := default - else result := GetInt64; -end; + {$REGION 'extract the quoted name part'} + // "" : "" + // "name" : "value" + // "name" : 1.23 + // "name" : true + // "name" : false + // "name" : null + // "name" : ISODATE('1/1/2001') + // "name" : function(){return(new Date).getTime()}, ...} + // "name" : new Date(''Dec 03, 1924'') + // "name" : { ... } + // "name" : [ ... ] + // 'name' : '...' + // "value" + // 'value' + LQuoteChar := #0; + if c in ['"',''''] then begin // ... " ... + // ^BufferPos + LQuoteChar := c; // " + P1 := BufferPos + 1; // ... "...\"..." + // ^P1 + If P1 + 1 > BufferLength then ExpandBuffer(P1); + While P1 <= BufferLength do begin -{**************************************************} -procedure TALJSONNodeA.SetInt64(const Value: Int64); -begin - setNodeValue(Value, nstInt64); -end; + c := Buffer[P1]; -{*************************************} -function TALJSONNodeA.GetBool: Boolean; -begin - if NodeSubType = nstBoolean then begin - if GetNodeValueInt64 = 0 then result := False - else result := true; - end - else begin - AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - result := False; // to hide a warning; - end; -end; + If (c = '\') and + (P1 < BufferLength) and + (Buffer[P1 + 1] in ['\', LQuoteChar]) then inc(p1, 2) // ... "...\"..." + // ^^^P1 + else if c = LQuoteChar then begin + ALCopyStr(Buffer,CurrName,BufferPos + 1,P1-BufferPos - 1); + if DecodeJSONReferences then ALJavascriptDecodeV(CurrName); // ..."... + break; + end + else inc(P1); // ... "...\"..." + // ^^^^^^^^^P1 -{*************************************************************} -function TALJSONNodeA.GetBool(const default: Boolean): Boolean; -begin - if NodeSubType = nstNull then result := default - else result := GetBool; -end; + if P1 + 1 > BufferLength then ExpandBuffer(P1); -{***************************************************} -procedure TALJSONNodeA.SetBool(const Value: Boolean); -begin - if Value then setNodeValue(1, nstBoolean) - else setNodeValue(0, nstBoolean); -end; + end; + if P1 > BufferLength then AlJSONDocErrorA(CALJSONParseError); + BufferPos := P1 + 1; // ... "...\"..." + // ^^^^^^^^^^BufferPos + end + {$ENDREGION} -{*************************************} -function TALJSONNodeA.GetNull: Boolean; -begin - result := NodeSubType = nstNull; -end; + {$REGION 'extract the unquoted name part'} + // name : "value" + // name : 1.23 + // name : true + // name : false + // name : null + // name : ISODATE('1/1/2001') + // name : function(){return(new Date).getTime()}, ...} + // name : new Date('Dec 03, 1924') + // name : { ... } + // name : [ ... ] + // 1.23 + // true + // false + // null + // ISODATE('1/1/2001') + // function(){return(new Date).getTime()}, ...} + // new Date('Dec 03, 1924') + else begin -{***************************************************} -procedure TALJSONNodeA.SetNull(const Value: Boolean); -begin - if Value then setNodeValue(0, nstNull) - else AlJSONDocErrorA('Only "true" is allowed for setNull property'); -end; + LInSingleQuote := False; + LInDoubleQuote := False; + LInSquareBracket := 0; + LInRoundBracket := 0; + LInCurlyBracket := 0; -{**********************************************} -function TALJSONNodeA.GetJavascript: AnsiString; -begin - if NodeSubType = nstJavascript then result := GetNodeValueStr - else begin - AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - result := ''; // to hide a warning; - end; -end; + While (BufferPos <= BufferLength) or ExpandBuffer do begin + If Buffer[BufferPos] <= ' ' then inc(bufferPos) + else break; + end; + if BufferPos > BufferLength then AlJSONDocErrorA(CALJSONParseError); -{*************************************************************************} -function TALJSONNodeA.GetJavascript(const default: AnsiString): AnsiString; -begin - if NodeSubType = nstNull then result := default - else result := GetJavascript; -end; + P1 := BufferPos; // ... new Date('Dec 03, 1924'), .... + // ^P1 + While (P1 <= BufferLength) or ExpandBuffer(P1) do begin -{************************************************************} -procedure TALJSONNodeA.SetJavascript(const Value: AnsiString); -begin - setNodeValue(Value, nstJavascript); -end; + c := Buffer[P1]; -{*****************************************} -function TALJSONNodeA.GetRegEx: ansiString; -begin - if NodeSubType = nstRegEx then result := GetNodeValueStr - else begin - AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - result := ''; // to hide a warning; - end; -end; + if (not LInSingleQuote) and + (not LInDoubleQuote) and + (LInSquareBracket = 0) and + (LInRoundBracket = 0) and + (LInCurlyBracket = 0) and + (c in [',', '}', ']', ':']) then begin + P2 := P1-1; + While P2 >= BufferPos do begin + If Buffer[P2] <= ' ' then dec(P2) + else break; + end; + ALCopyStr(Buffer,CurrName,BufferPos,P2-BufferPos+1); // new Date('Dec 03, 1924') + break; + end + else if (c = '"') then begin + if (P1 <= 1) or + (Buffer[P1 - 1] <> '\') then LInDoubleQuote := (not LInDoubleQuote) and (not LInSingleQuote); + end + else if (c = '''') then begin + if (P1 <= 1) or + (Buffer[P1 - 1] <> '\') then LInSingleQuote := (not LInSingleQuote) and (not LInDoubleQuote) + end + else if (not LInSingleQuote) and + (not LInDoubleQuote) then begin + if (c = '[') then inc(LInSquareBracket) + else if (c = ']') then dec(LInSquareBracket) + else if (c = '(') then inc(LInRoundBracket) + else if (c = ')') then dec(LInRoundBracket) + else if (c = '}') then inc(LInCurlyBracket) + else if (c = '{') then dec(LInCurlyBracket); + end; -{********************************************************************} -function TALJSONNodeA.GetRegEx(const default: ansiString): ansiString; -begin - if NodeSubType = nstNull then result := default - else result := GetRegEx; -end; + inc(P1); // ... new Date('Dec 03, 1924'), .... + // ^^^^^^^^^^^^^^^^^^^^^^^^^P1 -{*********************************************************} -procedure TALJSONNodeA.SetRegEx(const Pattern: ansiString); -begin - setNodeValue(Pattern, 0, nstRegEx); -end; + end; + if P1 > BufferLength then AlJSONDocErrorA(CALJSONParseError); + BufferPos := P1; // ... new Date('Dec 03, 1924'), .... + // ^BufferPos -{*********************************************************************************************} -procedure TALJSONNodeA.SetRegEx(const Pattern: ansiString; const Options: TALPerlRegExOptions); -begin - setNodeValue(Pattern, byte(Options), nstRegEx); -end; + end; + {$ENDREGION} -{*********************************************************} -function TALJSONNodeA.GetRegExOptions: TALPerlRegExOptions; -begin - if NodeSubType = nstRegEx then result := TALPerlRegExOptions(byte(GetNodeValueInt64)) - else begin - AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - result := []; // to hide a warning; - end; -end; + {$REGION 'extract the name value separator part'} + LNameValueSeparator := #0; + While (BufferPos <= BufferLength) or ExpandBuffer do begin + If Buffer[BufferPos] <= ' ' then inc(BufferPos) + else begin + LNameValueSeparator := Buffer[BufferPos]; + break; + end; + end; + if BufferPos > BufferLength then AlJSONDocErrorA(CALJSONParseError); // .... : .... + // ^BufferPos + {$ENDREGION} + + {$REGION 'if aNameValueSeparator is absent then it is just a value'} + if LNameValueSeparator <> ':' then begin + + //Node without name can be ONLY present inside an array node + if NotSaxMode then begin + if not assigned(WorkingNode) then AlJSONDocErrorA(CALJSONParseError); + if (CurrIndex < 0) or + (WorkingNode.nodetype <> ntarray) then AlJSONDocErrorA(CALJSONParseError); + end + else begin + if (CurrIndex < 0) or + (NamePaths.Count = 0) or + (TALJSONNodeType(NamePaths.Objects[Namepaths.Count - 1]) <> ntarray) then AlJSONDocErrorA(CALJSONParseError); + end; -{*********************************************************************************************} -function TALJSONNodeA.GetRegExOptions(const default: TALPerlRegExOptions): TALPerlRegExOptions; -begin - if NodeSubType = nstNull then result := default - else result := GetRegExOptions; -end; + //create the node + _createNode(CurrIndex,'',CurrName,LQuoteChar in ['"','''']); -{***********************************************************************} -procedure TALJSONNodeA.SetRegExOptions(const Value: TALPerlRegExOptions); -begin - if NodeSubType <> nstRegEx then AlJSONDocErrorA('You can set regex options only to a regex node'); - setNodeValue(byte(Value), nstRegEx); -end; + //increase the CurrIndex + inc(CurrIndex); -{******************************************} -function TALJSONNodeA.GetBinary: AnsiString; -begin - if NodeSubType = nstBinary then result := GetNodeValueStr - else begin - AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - result := ''; // to hide a warning; - end; -end; + //finallly exit from this procedure, everything was done + exit; -{*********************************************************************} -function TALJSONNodeA.GetBinary(const default: AnsiString): AnsiString; -begin - if NodeSubType = nstNull then result := default - else result := GetBinary; -end; + end; + {$ENDREGION} -{*******************************************************} -procedure TALJSONNodeA.SetBinary(const Data: AnsiString); -begin - setNodeValue(Data, 0, nstBinary); // 0 = Default BSON type -end; + {$REGION 'remove the blank space between the name valueeparator and the value'} + inc(BufferPos); // ... : .... + // ^BufferPos + While (BufferPos <= BufferLength) or ExpandBuffer do begin + If Buffer[BufferPos] <= ' ' then inc(BufferPos) + else break; + end; + if BufferPos > BufferLength then AlJSONDocErrorA(CALJSONParseError); // .... " .... + // ^BufferPos + {$ENDREGION} -{****************************************************************************} -procedure TALJSONNodeA.SetBinary(const Data: AnsiString; const Subtype: byte); -begin - setNodeValue(Data, Subtype, nstBinary); -end; + {$REGION 'init current char (c)'} + c := Buffer[BufferPos]; + {$ENDREGION} -{*******************************************} -function TALJSONNodeA.GetBinarySubType: byte; -begin - if NodeSubType = nstBinary then result := byte(GetNodeValueInt64) - else begin - AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - result := 0; // to hide a warning; - end; -end; + {$REGION 'if the value is an object/array'} + // name : { ... } + // name : [ ... ] + if c in ['{','['] then begin // ... { ... + // ^BufferPos -{****************************************************************} -function TALJSONNodeA.GetBinarySubType(const default: byte): byte; -begin - if NodeSubType = nstNull then result := default - else result := GetBinarySubType; -end; + //if we are not in sax mode + if NotSaxMode then begin -{***********************************************************} -procedure TALJSONNodeA.SetBinarySubType(const Subtype: byte); -begin - if NodeSubType <> nstBinary then AlJSONDocErrorA('You can set binary subtype only to a binary node'); - setNodeValue(Subtype, nstBinary); -end; + //if workingnode = nil then it's mean we are outside Self + if not assigned(WorkingNode) then AlJSONDocErrorA(CALJSONParseError); -{*******************************************************} -{Returns the document object in which this node appears.} -function TALJSONNodeA.GetOwnerDocument: TALJSONDocumentA; -begin - Result := FDocument; -end; + //Node withe name MUST be ONLY present inside an object node + if (CurrIndex >= 0) or + (WorkingNode.nodetype <> ntObject) then AlJSONDocErrorA(CALJSONParseError); -{*********************************************************************} -procedure TALJSONNodeA.SetOwnerDocument(const Value: TALJSONDocumentA); -var I: Integer; - LNodeList: TALJSONNodeListA; -begin - if FDocument <> Value then begin - FDocument := Value; - LNodeList := InternalGetChildNodes; - if Assigned(LNodeList) then begin - if Assigned(FDocument) then begin - LNodeList.Duplicates := FDocument.Duplicates; - LNodeList.SetSorted(doSorted in FDocument.Options); - end; - for I := 0 to LNodeList.Count - 1 do - LNodeList[I].SetOwnerDocument(Value); - end; - end; -end; + //create the node according the the braket char and add it to the workingnode + if c = '{' then LNode := CreateNode(CurrName, ntObject) + else LNode := CreateNode(CurrName, ntarray); + try + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; -{************************} -{returns the parent node.} -function TALJSONNodeA.GetParentNode: TALJSONNodeA; -begin - Result := FParentNode; -end; + //set that the current working node will be now the new node newly created + WorkingNode := LNode; -{******************************************} -{Sets the value of the ParentNode property.} -procedure TALJSONNodeA.SetParentNode(const Value: TALJSONNodeA); -begin - if FParentNode <> Value then begin - If assigned(Value) then SetOwnerDocument(Value.OwnerDocument) - else SetOwnerDocument(nil); - FParentNode := Value; - end; -end; + //update the path + if assigned(ObjectPaths) then ObjectPaths.AddObject(-1, WorkingNode) + else _AddItemToNamePath(-1, CurrName, WorkingNode); -{*******************************************************************} -{Returns the JSON that corresponds to the subtree rooted at this node. - GetJSON returns the JSON that corresponds to this node and any child nodes it contains.} -function TALJSONNodeA.GetJSON: AnsiString; -begin - SaveToJSONString(result); -end; + end -{************************************************} -{SetJSON reload the node with the new given value } -procedure TALJSONNodeA.SetJSON(const Value: AnsiString); -Begin - LoadFromJSONString(Value, true{ClearChildNodes}); -end; + //if we are in sax mode + else begin -{*******************************************************************} -{Returns the BSON that corresponds to the subtree rooted at this node. - GetBSON returns the BSON that corresponds to this node and any child nodes it contains.} -function TALJSONNodeA.GetBSON: AnsiString; -begin - SaveToBSONString(result); -end; + //Node withe name MUST be ONLY present inside an object node + if (CurrIndex >= 0) or + (NamePaths.Count = 0) or + (TALJsonNodeType(NamePaths.Objects[NamePaths.Count - 1]) <> ntobject) then AlJSONDocErrorA(CALJSONParseError); -{************************************************} -{SetBSON reload the node with the new given value } -procedure TALJSONNodeA.SetBSON(const Value: AnsiString); -Begin - LoadFromBSONString(Value, true{ClearChildNodes}); -end; + //update the path + if c = '{' then LNodeType := ntObject + else LNodeType := ntArray; + _AddItemToNamePath(-1, CurrName, pointer(LNodeType)); -{*****************************************************************} -{Returns the number of parents for this node in the node hierarchy. - NestingLevel returns the number of ancestors for this node in the node hierarchy.} -function TALJSONNodeA.NestingLevel: Integer; -var PNode: TALJSONNodeA; -begin - Result := 0; - PNode := ParentNode; - while PNode <> nil do begin - Inc(Result); - PNode := PNode.ParentNode; - end; -end; + end; -{**********************************************************} -constructor TALJSONNodeA.Create(const NodeName: AnsiString); -Begin - FDocument := nil; - FParentNode := nil; - fNodeName := NodeName; -end; + //call the DoParseStartObject/array event and update the CurrIndex if it's an array + if c = '{' then begin + if Assigned(OnParseStartObject) then _DoParseStartObject(CurrName) + end + else begin + if Assigned(OnParseStartArray) then _DoParseStartArray(CurrName); + CurrIndex := 0; + end; -{***************************************************************} -//will create all the nodevalue and childnodelist to be sure that -//multiple thread can safely read at the same time the node -procedure TALJSONNodeA.MultiThreadPrepare(const aOnlyChildList: Boolean = False); -var I: integer; -begin - if (not aOnlyChildList) and (NodeType = ntText) then begin + //update BufferPos + BufferPos := BufferPos + 1; // ... { ... + // ^BufferPos - case NodeSubType of - nstFloat, - nstBoolean, - nstDateTime, - nstNull, - nstInt32, - nstTimestamp, - nstInt64: GetNodeValueStr; - //nstText: can not be retrieve from int64 - //nstObject: can not be retrieve from int64 - //nstArray: can not be retrieve from int64 - //nstBinary: only the binarysubtype is store in int64 - //nstObjectID: can not be retrieve from int64 - //nstRegEx: only the regex options is store in the int64 - //nstJavascript: can not be retrieve from int64 - end; + //finallly exit from this procedure, everything was done + exit; - case NodeSubType of - nstFloat, - nstBoolean, - nstDateTime, - nstNull, - nstInt32, - nstTimestamp, - nstInt64: GetNodeValueInt64; - //nstText: can not be retrieve from int64 - //nstObject: can not be retrieve from int64 - //nstArray: can not be retrieve from int64 - //nstBinary: only the binarysubtype is store in int64 - //nstObjectID: can not be retrieve from int64 - //nstRegEx: only the regex options is store in the int64 - //nstJavascript: can not be retrieve from int64 end; + {$ENDREGION} + + {$REGION 'if the value is a quoted string'} + // name : "value" + // name : 'value' + LQuoteChar := #0; + if c in ['"',''''] then begin // ... " ... + // ^BufferPos + + LQuoteChar := c; // " + P1 := BufferPos + 1; // ... "...\"..." + // ^P1 + If P1 + 1 > BufferLength then ExpandBuffer(P1); + While P1 <= BufferLength do begin + + c := Buffer[P1]; + + If (c = '\') and + (P1 < BufferLength) and + (Buffer[P1 + 1] in ['\', LQuoteChar]) then inc(p1, 2) // ... "...\"..." + // ^^^P1 + else if c = LQuoteChar then begin + ALCopyStr(Buffer,currValue,BufferPos + 1,P1-BufferPos - 1); + if DecodeJSONReferences then ALJavascriptDecodeV(currValue); // ..."... + break; + end + else inc(P1); // ... "...\"..." + // ^^^^^^^^^P1 - end + if P1 + 1 > BufferLength then ExpandBuffer(P1); - else if (NodeType in [ntObject,ntArray]) then begin - For I := 0 to ChildNodes.Count - 1 do - ChildNodes[I].MultiThreadPrepare(aOnlyChildList); - end; -end; + end; + if P1 > BufferLength then AlJSONDocErrorA(CALJSONParseError); + BufferPos := P1 + 1; // ... "...\"..." + // ^^^^^^^^^^BufferPos -{********************************************************************************************************************************************} -function TALJSONNodeA.AddChild(const NodeName: AnsiString; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeA; -begin - Result := ALCreateJSONNodeA(NodeName,NodeType); - Try - ChildNodes.Insert(Index, Result); - except - FreeAndNil(Result); - raise; - end; -end; + end + {$ENDREGION} -{*************************************************************************************************************************************************} -function TALJSONNodeA.AddChild(const Path: array of AnsiString; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeA; -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I], TDirection.FromEnd); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; - end; - result := LNode.addChild(path[high(path)], NodeType, Index); -end; + {$REGION 'if the value is a UNquoted string'} + // name : 1.23 + // name : true + // name : false + // name : null + // name : ISODATE('1/1/2001') + // name : function(){return(new Date).getTime()}, ...} + // name : new Date(''Dec 03, 1924'') + // name : /test/i + else begin -{****************************************************************************************************************} -function TALJSONNodeA.AddChild(const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeA; -begin - Result := AddChild('', NodeType, Index); -end; + LInSingleQuote := False; + LInDoubleQuote := False; + LInSlashQuote := False; + LInSquareBracket := 0; + LInRoundBracket := 0; + LInCurlyBracket := 0; -{*********************************************************************} -function TALJSONNodeA.DeleteChild(const NodeName: AnsiString): boolean; -var I: integer; -begin - I := ChildNodes.IndexOf(NodeName); - if I >= 0 then begin - ChildNodes.Delete(I); - result := True; - end - else result := False; -end; + While (BufferPos <= BufferLength) or ExpandBuffer do begin + If Buffer[BufferPos] <= ' ' then inc(bufferPos) + else break; + end; + if BufferPos > BufferLength then AlJSONDocErrorA(CALJSONParseError); -{**************************************************************************} -function TALJSONNodeA.DeleteChild(const Path: array of AnsiString): boolean; -var LNode: TALJSONNodeA; - LTmpNode: TALJSONNodeA; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then exit(false) - else LNode := LTmpNode; - end; - I := LNode.ChildNodes.IndexOf(path[high(path)]); - if I >= 0 then begin - LNode.ChildNodes.Delete(I); - result := True; - end - else result := False; -end; + P1 := BufferPos; // ... new Date('Dec 03, 1924'), .... + // ^P1 + While (P1 <= BufferLength) or ExpandBuffer(P1) do begin -{******************************************} -{Returns the next child of this node’s parent. - NextSibling returns the node that follows this one in the parent node’s ChildNodes property list. - If this node is the last node in its parent’s child list, NextSibling raises an exception.} -function TALJSONNodeA.NextSibling: TALJSONNodeA; -begin - if Assigned(ParentNode) then Result := ParentNode.ChildNodes.FindSibling(Self, 1) - else Result := nil; -end; + c := Buffer[P1]; -{************************************************} -{Returns the previous child of this node’s parent. - PreviousSibling returns the node that precedes this one in the parent node’s ChildNodes property list. - If this node is the first node in its parent’s child list, PreviousSibling raises an exception.} -function TALJSONNodeA.PreviousSibling: TALJSONNodeA; -begin - if Assigned(ParentNode) then Result := ParentNode.ChildNodes.FindSibling(Self, -1) - else Result := nil; -end; + if (not LInSingleQuote) and + (not LInDoubleQuote) and + (not LInSlashQuote) and + (LInSquareBracket = 0) and + (LInRoundBracket = 0) and + (LInCurlyBracket = 0) and + (c in [',', '}', ']']) then begin + P2 := P1-1; + While P2 >= BufferPos do begin + If Buffer[P2] <= ' ' then dec(P2) + else break; + end; + ALCopyStr(Buffer,currValue,BufferPos,P2-BufferPos+1); // new Date('Dec 03, 1924') + break; + end + else if (c = '"') then begin + if (P1 <= 1) or + (Buffer[P1 - 1] <> '\') then LInDoubleQuote := (not LInDoubleQuote) and (not LInSingleQuote) and (not LInSlashQuote); + end + else if (c = '''') then begin + if (P1 <= 1) or + (Buffer[P1 - 1] <> '\') then LInSingleQuote := (not LInSingleQuote) and (not LInDoubleQuote) and (not LInSlashQuote) + end + else if (c = '/') then begin + if (P1 <= 1) or + (Buffer[P1 - 1] <> '\') then LInSlashQuote := (not LInSingleQuote) and (not LInDoubleQuote) and (not LInSlashQuote); + end + else if (not LInSingleQuote) and + (not LInDoubleQuote) and + (not LInSlashQuote) then begin + if (c = '[') then inc(LInSquareBracket) + else if (c = ']') then dec(LInSquareBracket) + else if (c = '(') then inc(LInRoundBracket) + else if (c = ')') then dec(LInRoundBracket) + else if (c = '}') then inc(LInCurlyBracket) + else if (c = '{') then dec(LInCurlyBracket); + end; -{********************************} -procedure TALJSONNodeA.SaveToJson( - const Stream: TStream; - Var buffer: ansiString); + inc(P1); // ... new Date('Dec 03, 1924'), .... + // ^^^^^^^^^^^^^^^^^^^^^^^^^P1 -Const BufferSize: integer = 8192; + end; + if P1 > BufferLength then AlJSONDocErrorA(CALJSONParseError); + BufferPos := P1; // ... new Date('Dec 03, 1924'), .... + // ^BufferPos -Var NodeStack: Tstack; - CurrentNode: TALJSONNodeA; - CurrentParentNode: TALJSONNodeA; - CurrentIndentStr: AnsiString; - IndentStr: AnsiString; - EncodeControlCharacters: Boolean; - SkipNodeSubTypeHelper: boolean; - SaveInt64AsText: Boolean; - AutoIndentNode: Boolean; - BufferPos: Integer; - LastWrittenChar: AnsiChar; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteBuffer2Stream(const buffer: ansiString; BufferLength: Integer); - Begin - if assigned(Stream) then begin - If BufferLength > 0 then stream.Writebuffer(pointer(buffer)^,BufferLength); - BufferPos := 0; end; - end; + {$ENDREGION} - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _Write2Buffer(const Source; Count: NativeInt); - Begin - if Count = 0 then exit; - if Count + BufferPos > length(Buffer) then setlength(Buffer, Count + BufferPos + BufferSize); - ALMove(Source, pbyte(Buffer)[BufferPos{*sizeOf(ansiChar)}], Count{*sizeOf(ansiChar)}); - BufferPos := BufferPos + Count; - if BufferPos >= 32768 then _WriteBuffer2Stream(Buffer,BufferPos); - end; + {$REGION 'create the named text node'} + + //Node withe name MUST be ONLY present inside an object node + if NotSaxMode then begin + if not assigned(WorkingNode) then AlJSONDocErrorA(CALJSONParseError); + if (CurrIndex >= 0) or + (WorkingNode.nodetype <> ntObject) then AlJSONDocErrorA(CALJSONParseError); + end + else begin + if (CurrIndex >= 0) or + (NamePaths.Count = 0) or + (TALJSONNodeType(NamePaths.Objects[Namepaths.Count - 1]) <> ntObject) then AlJSONDocErrorA(CALJSONParseError); + end; + + //create the node + _createNode(currIndex,CurrName,CurrValue,LQuoteChar in ['"','''']); + + {$ENDREGION} - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteStr2Buffer(const str:AnsiString); - var L: integer; - Begin - L := Length(Str); - if L = 0 then exit; - LastWrittenChar := Str[L]; - _Write2Buffer(pointer(str)^,L); end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteTextNode2Buffer(aTextNode:TALJSONNodeA); - Begin - with aTextNode do begin +var BOMSequence: integer; + InCommentLine: integer; + c: ansiChar; - if not (LastWrittenChar in ['{','[']) then _WriteStr2Buffer(','); +Begin + + //clear the childnodes + if poClearChildNodes in Options then ChildNodes.Clear; + + //init WorkingNode and NotSaxMode and DecodeJSONReferences + WorkingNode := Self; + NotSaxMode := not SaxMode; + DecodeJSONReferences := not (poIgnoreControlCharacters in Options); + + //init ObjectPaths or NamePaths + if (NotSaxMode) and + (not assigned(OnParseText)) and + (not assigned(OnParseStartObject)) and + (not assigned(OnParseEndObject)) and + (not assigned(OnParseStartArray)) and + (not assigned(OnParseEndArray)) then begin + ObjectPaths := TALIntegerList.Create(false{OwnsObjects}); + NamePaths := nil; + end + else begin + ObjectPaths := nil; + NamePaths := TALNVStringListA.Create; + end; + Try + + //init Buffer + if assigned(RawJSONStream) then begin + Buffer := ''; + BufferLength := 0; + BufferPos := 1; + ExpandBuffer; + end + else begin + Buffer := RawJSONString; + BufferLength := length(RawJSONString); + BufferPos := 1; + end; - if AutoIndentNode then begin - _WriteStr2Buffer(#13#10); - _WriteStr2Buffer(CurrentIndentStr); - end; + //add first node in ObjectPaths/NamePaths + if assigned(ObjectPaths) then ObjectPaths.AddObject(-1, WorkingNode) + else begin + if NotSaxMode then _AddNameItemToNamePath('', WorkingNode) + else _AddNameItemToNamePath('', pointer(NodeType)); + end; - if (assigned(ParentNode)) and - (ParentNode.NodeType <> ntArray) then begin - if EncodeControlCharacters then begin - _WriteStr2Buffer('"'); - _WriteStr2Buffer(ALJavascriptEncode(NodeName)); - _WriteStr2Buffer('":'); + //skip the first { + BOMSequence := 0; // hide warnings + While (BufferPos <= BufferLength) or ExpandBuffer do begin + c := Buffer[BufferPos]; + If c <= ' ' then inc(bufferPos) + else if ((bufferPos = 1) and (c=#$EF)) then begin + BOMSequence := 1; + inc(bufferPos); + end + else if ((bufferPos = 2) and (BOMSequence=1) and (c=#$BB)) then begin + BOMSequence := 2; + inc(bufferPos); + end + else if ((bufferPos = 3) and (BOMSequence=2) and (c=#$BF)) then begin + BOMSequence := 0; + inc(bufferPos); + end + else begin + if (c = '{') then begin + if (Nodetype <> ntObject) then AlJSONDocErrorA(CALJsonOperationError,GetNodeType); + CurrIndex := -1; + _DoParseStartObject(''); end - else begin - _WriteStr2Buffer('"'); - _WriteStr2Buffer(NodeName); - _WriteStr2Buffer('":'); - end; + else if (c = '[') then begin + if (Nodetype <> ntArray) then AlJSONDocErrorA(CALJsonOperationError,GetNodeType); + CurrIndex := 0; + _DoParseStartArray(''); + end + else AlJSONDocErrorA(cALJSONParseError); + inc(bufferPos); + break; end; + end; - if (NodeSubType = NstText) or - ((NodeSubType = nstInt64) and SaveInt64AsText) then begin - if (NodeSubType = NstText) and EncodeControlCharacters then begin - _WriteStr2Buffer('"'); - _WriteStr2Buffer(ALJavascriptEncode(GetText)); - _WriteStr2Buffer('"'); + //analyze all the nodes + if poAllowComments in Options then begin + InCommentLine := 0; + While (BufferPos <= BufferLength) or ExpandBuffer do begin + c := Buffer[BufferPos]; + If (InCommentLine = 0) and ((c <= ' ') or (c = ',')) then inc(bufferPos) + else if (InCommentLine <= 1) and (c = '/') then begin + inc(InCommentLine); + inc(bufferPos); + end + else if (InCommentLine = 2) then begin + if ((c = #13) or (c = #10)) then InCommentLine := 0; + inc(bufferPos); end else begin - _WriteStr2Buffer('"'); - _WriteStr2Buffer(Text); - _WriteStr2Buffer('"'); + if InCommentLine = 1 then begin + InCommentLine := 0; + dec(BufferPos); + end; + AnalyzeNode; end; - end - else _WriteStr2Buffer(GetNodeValueInterchange(SkipNodeSubTypeHelper)); + end; + end + else begin + While (BufferPos <= BufferLength) or ExpandBuffer do begin + c := Buffer[BufferPos]; + If (c <= ' ') or (c = ',') then inc(bufferPos) + else AnalyzeNode; + end; + end; + //some tags are not closed + if assigned(ObjectPaths) then begin + if ObjectPaths.Count > 0 then AlJSONDocErrorA(cALJSONParseError); + end + else begin + if NamePaths.Count > 0 then AlJSONDocErrorA(cALJSONParseError); end; - end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteStartObjectNode2Buffer(aObjectNode:TALJSONNodeA); - var LNodeList: TALJSONNodeListA; - LEmptyNode: Boolean; - I: integer; - Begin - with aObjectNode do begin + //mean the node was not update (empty stream?) or not weel closed + if NotSaxMode and (WorkingNode <> nil) then AlJSONDocErrorA(cALJSONParseError); - if not (LastWrittenChar in ['{','[']) then _WriteStr2Buffer(','); + finally - if AutoIndentNode and (CurrentIndentStr <> '') then begin - _WriteStr2Buffer(#13#10); - _WriteStr2Buffer(CurrentIndentStr); - end; + //free ObjectPaths/NamePaths + if assigned(ObjectPaths) then ALFreeAndNil(ObjectPaths) + else ALFreeAndNil(NamePaths); - if aObjectNode = self then _WriteStr2Buffer('{') - else if (assigned(ParentNode)) and - (ParentNode.NodeType <> ntArray) then begin - if EncodeControlCharacters then begin - _WriteStr2Buffer('"'); - _WriteStr2Buffer(ALJavascriptEncode(NodeName)); - _WriteStr2Buffer('":{') - end - else begin - _WriteStr2Buffer('"'); - _WriteStr2Buffer(NodeName); - _WriteStr2Buffer('":{'); - end; - end - else _WriteStr2Buffer('{'); + end; - LEmptyNode := True; - LNodeList := InternalGetChildNodes; - If assigned(LNodeList) then begin - with LNodeList do - If count > 0 then begin - LEmptyNode := False; - NodeStack.Push(aObjectNode); - For I := Count - 1 downto 0 do NodeStack.Push(Nodes[I]); - end - end; +end; - If LEmptyNode then _WriteStr2Buffer('}') - else CurrentIndentStr := CurrentIndentStr + IndentStr; - end; - end; +{*************************************************************} +{Last version of the spec: http://bsonspec.org/#/specification} +procedure TALJSONNodeA.ParseBSON( + const RawBSONStream: TStream; + const RawBSONString: AnsiString; + const SaxMode: Boolean; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions); - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteEndObjectNode2Buffer(aObjectNode:TALJSONNodeA); +Const BufferSize: integer = 8192; + +Var Buffer: AnsiString; + BufferLength: Integer; + BufferPos: Integer; + CurrName: AnsiString; + NotSaxMode: Boolean; + WorkingNode: TALJSONNodeA; + NamePaths: TALStringListA; + ObjectPaths: TObjectList; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function ExpandBuffer: boolean; overload; + Var ByteReaded, Byte2Read: Integer; Begin - if AutoIndentNode then begin - delete(CurrentIndentStr, length(CurrentIndentStr) - length(IndentStr)+1, maxint); - _WriteStr2Buffer(#13#10); - _WriteStr2Buffer(CurrentIndentStr); + if not assigned(RawBSONStream) then begin + result := false; + exit; end; - _WriteStr2Buffer('}'); - end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteStartArrayNode2Buffer(aArrayNode:TALJSONNodeA); - var LNodeList: TALJSONNodeListA; - LEmptyNode: Boolean; - I: integer; - Begin - with aArrayNode do begin + If (BufferLength > 0) and (BufferPos > 1) then begin + if (BufferPos > BufferLength) then RawBSONStream.Position := RawBSONStream.Position - BufferLength + BufferPos - 1; + Byte2Read := min(BufferPos - 1, BufferLength); + if BufferPos <= length(Buffer) then ALMove( + Pbyte(Buffer)[BufferPos - 1], + pointer(Buffer)^, + BufferLength-BufferPos+1); + BufferPos := 1; + end + else begin + Byte2Read := BufferSize; + BufferLength := BufferLength + BufferSize; + SetLength(Buffer, BufferLength); + end; - if not (LastWrittenChar in ['{','[']) then _WriteStr2Buffer(','); + //range check error is we not do so + if RawBSONStream.Position < RawBSONStream.Size then ByteReaded := RawBSONStream.Read(Pbyte(Buffer)[BufferLength - Byte2Read{+ 1 - 1}],Byte2Read) + else ByteReaded := 0; - if AutoIndentNode and (CurrentIndentStr <> '') then begin - _WriteStr2Buffer(#13#10); - _WriteStr2Buffer(CurrentIndentStr); - end; + If ByteReaded <> Byte2Read then begin + BufferLength := BufferLength - Byte2Read + ByteReaded; + SetLength(Buffer, BufferLength); + Result := ByteReaded > 0; + end + else result := True; + end; - if aArrayNode = self then _WriteStr2Buffer('[') - else if (assigned(ParentNode)) and - (ParentNode.NodeType <> ntArray) then begin - if EncodeControlCharacters then begin - _WriteStr2Buffer('"'); - _WriteStr2Buffer(ALJavascriptEncode(NodeName)); - _WriteStr2Buffer('":['); - end - else begin - _WriteStr2Buffer('"'); - _WriteStr2Buffer(NodeName); - _WriteStr2Buffer('":['); - end; - end - else _WriteStr2Buffer('['); + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function ExpandBuffer(var PosToKeepSync: Integer): boolean; overload; + var P1: integer; + begin + P1 := BufferPos; + result := ExpandBuffer; + PosToKeepSync := PosToKeepSync - (P1 - BufferPos); + end; - LEmptyNode := True; - LNodeList := InternalGetChildNodes; - If assigned(LNodeList) then begin - with LNodeList do - If count > 0 then begin - LEmptyNode := False; - NodeStack.Push(aArrayNode); - For I := Count - 1 downto 0 do NodeStack.Push(Nodes[I]); - end + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function GetPathStr(Const ExtraItems: ansiString = ''): ansiString; + var I, L, P, Size: Integer; + LB: ansiChar; + S: AnsiString; + begin + LB := ALDefaultJsonPathSeparatorA; + Size := length(ExtraItems); + if size <> 0 then Inc(Size, 1{length(LB)}); + for I := 1 to NamePaths.Count - 1 do Inc(Size, Length(NamePaths[I]) + 1{length(LB)}); + SetLength(Result, Size); + P := 1; + for I := 1 to NamePaths.Count - 1 do begin + S := NamePaths[I]; + L := Length(S); + if L <> 0 then begin + ALMove(pointer(S)^, Pbyte(Result)[(P-1){*sizeOf(ansiChar)}], L{*sizeOf(ansiChar)}); + Inc(P, L); + end; + L := 1{length(LB)}; + if ((i <> NamePaths.Count - 1) or + (ExtraItems <> '')) and + (((NotSaxMode) and (TALJSONNodeA(NamePaths.Objects[I]).nodetype <> ntarray)) or + ((not NotSaxMode) and (TALJSONNodeType(NamePaths.Objects[I]) <> ntarray))) then begin + ALMove(LB, Pbyte(Result)[(P-1){*sizeOf(ansiChar)}], L{*sizeOf(ansiChar)}); + Inc(P, L); end; - - If LEmptyNode then _WriteStr2Buffer(']') - else CurrentIndentStr := CurrentIndentStr + IndentStr; - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteEndArrayNode2Buffer(aArrayNode:TALJSONNodeA); - Begin - if AutoIndentNode then begin - delete(CurrentIndentStr, length(CurrentIndentStr) - length(IndentStr) + 1, maxint); - _WriteStr2Buffer(#13#10); - _WriteStr2Buffer(CurrentIndentStr); + if ExtraItems <> '' then begin + L := length(ExtraItems); + ALMove(pointer(ExtraItems)^, Pbyte(Result)[(P-1){*sizeOf(ansiChar)}], L{*sizeOf(ansiChar)}); + Inc(P, L); end; - _WriteStr2Buffer(']'); + setlength(result,P-1); end; -begin - If not (NodeType in [ntObject, ntArray]) then exit; // normally only Object node can gave a valid json stream - // but their is some situation where the array (containing json node) - // is also usefull - CurrentParentNode := nil; - NodeStack := Tstack.Create; - Try - - {init buffer string} - Setlength(Buffer, BufferSize); // will make buffer uniquestring - BufferPos := 0; - LastWrittenChar := '{'; - EncodeControlCharacters := (FDocument = nil) or (not (poIgnoreControlCharacters in FDocument.ParseOptions)); - SkipNodeSubTypeHelper := (FDocument <> nil) and (poSkipNodeSubTypeHelper in FDocument.ParseOptions); - SaveInt64AsText := SkipNodeSubTypeHelper and (FDocument <> nil) and (poSaveInt64AsText in FDocument.ParseOptions); - AutoIndentNode := (FDocument <> nil) and (doNodeAutoIndent in FDocument.Options); - if FDocument <> nil then IndentStr := FDocument.NodeIndentStr - else IndentStr := ALDefaultJsonNodeIndentA; - CurrentIndentStr := ''; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseTextWithIndex( + const index: AnsiString; + const Args: array of const; + const NodeSubType: TALJSONNodeSubType); + begin + if Assigned(OnParseText) then OnParseText(Self, GetPathStr('[' + index + ']'), '', Args, NodeSubType) + end; - {SaveOnlyChildNode} - NodeStack.Push(self); + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseTextWithName( + const name: AnsiString; + const Args: array of const; + const NodeSubType: TALJSONNodeSubType); + begin + if Assigned(OnParseText) then OnParseText(Self, GetPathStr(Name), Name, Args, NodeSubType) + end; - {loop on all nodes} - While NodeStack.Count > 0 Do begin - CurrentNode := NodeStack.Pop; + {~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseText( + const NameOrIndex: AnsiString; + const Args: array of const; + const NodeSubType: TALJSONNodeSubType); + begin + if Assigned(OnParseText) then begin + if notSaxMode then begin + if WorkingNode.nodetype=ntarray then _DoParseTextWithIndex(NameOrIndex, Args, NodeSubType) + else _DoParseTextWithName(NameOrIndex, Args, NodeSubType); + end + else begin + if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); + if TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntArray then _DoParseTextWithIndex(NameOrIndex, Args, NodeSubType) + else _DoParseTextWithName(NameOrIndex, Args, NodeSubType); + end; + end; + end; - with CurrentNode do - case NodeType of - ntObject: begin - if currentNode = CurrentParentNode then _WriteEndObjectNode2Buffer(CurrentNode) - else _WriteStartObjectNode2Buffer(CurrentNode); - end; - ntArray: begin - if currentNode = CurrentParentNode then _WriteEndArrayNode2Buffer(CurrentNode) - else _WriteStartArrayNode2Buffer(CurrentNode); - end; - ntText: _WriteTextNode2Buffer(CurrentNode); - else AlJSONDocErrorA(cAlJSONInvalidNodeType); - end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseStartObject(const Name: AnsiString); + begin + if Assigned(OnParseStartObject) then OnParseStartObject(Self, GetPathStr, Name); + end; - CurrentParentNode := CurrentNode.ParentNode; - end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseEndObject; + begin + if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); + if Assigned(OnParseEndObject) then OnParseEndObject(Self, GetPathStr, NamePaths[NamePaths.Count - 1]) + end; - {Write the buffer} - if assigned(Stream) then _WriteBuffer2Stream(Buffer, BufferPos) - else setlength(Buffer,BufferPos); + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseStartArray(const index: AnsiString); + begin + if Assigned(OnParseStartArray) then OnParseStartArray(Self, GetPathStr, index) + end; - finally - NodeStack.Free; + {~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseEndArray; + begin + if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); + if Assigned(OnParseEndArray) then OnParseEndArray(Self, GetPathStr, NamePaths[NamePaths.Count - 1]); end; -end; -{***********************************} -{Saves the JSON document to a stream. - Call SaveToStream to save the contents of the JSON document to the stream specified by Stream.} -procedure TALJSONNodeA.SaveToJSONStream(const Stream: TStream); -var buffer: ansiString; -begin - SaveToJson(Stream, buffer); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _AddIndexItemToNamePath(const index: AnsiString; Obj: Pointer); + begin + NamePaths.AddObject('[' + Index + ']', Obj) + end; -{******************************} -{Saves the JSON document to disk. - Call SaveToFile to save any modifications you have made to the parsed JSON document. - AFileName is the name of the file to save.} -procedure TALJSONNodeA.SaveToJSONFile(const FileName: String); -Var LfileStream: TfileStream; - LTmpFilename: String; -begin - if (assigned(FDocument)) and - (doProtectedSave in fDocument.Options) then LTmpFilename := FileName + '.~tmp' - else LTmpFilename := FileName; - try + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _AddNameItemToNamePath(const name: AnsiString; Obj: Pointer); + begin + NamePaths.AddObject(Name, Obj) + end; - LfileStream := TfileStream.Create(LTmpFilename,fmCreate); - Try - SaveToJSONStream(LfileStream); - finally - LfileStream.Free; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _AddItemToNamePath(const nameOrIndex: AnsiString; Obj: Pointer); + begin + if notSaxMode then begin + if WorkingNode.nodetype=ntarray then _AddIndexItemToNamePath(nameOrIndex, Obj) + else _AddNameItemToNamePath(nameOrIndex, Obj); + end + else begin + if NamePaths.Count = 0 then AlJSONDocErrorA(CALJSONParseError); + if TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntarray then _AddIndexItemToNamePath(nameOrIndex, Obj) + else _AddNameItemToNamePath(nameOrIndex, Obj); end; + end; - if LTmpFilename <> FileName then begin - if TFile.Exists(FileName) then TFile.Delete(FileName); - TFile.Move(LTmpFilename, FileName); + {~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createInt64Node( + const name: AnsiString; + const NodeSubType: TALJSONNodeSubType); + var LNode: TALJSONNodeA; + LInt64: System.Int64; + begin + if BufferPos > BufferLength - sizeof(LInt64) + 1 then begin + ExpandBuffer; + if BufferPos > BufferLength - sizeof(LInt64) + 1 then AlJSONDocErrorA(cALBSONParseError); end; + ALMove(Pbyte(Buffer)[BufferPos-1], LInt64, sizeof(LInt64)); + BufferPos := BufferPos + sizeof(LInt64); - except - if (LTmpFilename <> FileName) and - (TFile.Exists(LTmpFilename)) then TFile.Delete(LTmpFilename); - raise; + if NotSaxMode then begin + if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetInt64(LInt64); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LInt64], NodeSubType) + end + else begin + _DoParseText(Name, [LInt64], NodeSubType) + end; end; -end; - -{****************************************************************} -procedure TALJSONNodeA.SaveToJSONFile(const FileName: AnsiString); -begin - SaveToJSONFile(String(FileName)); -end; - -{************************************************} -{Saves the JSON document to a string-type variable. - Call SaveToJSON to save the contents of the JSON document to the string-type variable specified by JSON. SaveToJSON writes the contents of JSON document - using 8 bits char (utf-8, iso-8859-1, etc) as an encoding system, depending on the type of the JSON parameter. - Unlike the JSON property, which lets you write individual lines from the JSON document, SaveToJSON writes the entire text of the JSON document.} -procedure TALJSONNodeA.SaveToJSONString(var str: AnsiString); -begin - SaveToJson(nil, Str); -end; -{********************************} -procedure TALJSONNodeA.SaveToBson( - const Stream: TStream; - Var buffer: ansiString); + {~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createInt32Node( + const name: AnsiString; + const NodeSubType: TALJSONNodeSubType); + var LNode: TALJSONNodeA; + LInt32: System.Int32; + begin + if BufferPos > BufferLength - sizeof(LInt32) + 1 then begin + ExpandBuffer; + if BufferPos > BufferLength - sizeof(LInt32) + 1 then AlJSONDocErrorA(cALBSONParseError); + end; + ALMove(Pbyte(Buffer)[BufferPos-1], LInt32, sizeof(LInt32)); + BufferPos := BufferPos + sizeof(LInt32); -Const BufferSize: integer = 8192; + if NotSaxMode then begin + if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setint32(LInt32); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LInt32], NodeSubType) + end + else begin + _DoParseText(Name, [LInt32], NodeSubType) + end; + end; -Var NodeStack: Tstack; - NodeIndexStack: TALintegerList; - NodeStartPosStack: TALInt64List; - CurrentNode: TALJSONNodeA; - CurrentParentNode: TALJSONNodeA; - CurrentNodeIndex: integer; - CurrentNodeStartPos: System.int64; - BufferPos: NativeInt; - StreamPos: system.int64; + {~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createTextNode( + const name: AnsiString; + const NodeSubType: TALJSONNodeSubType); + var LNode: TALJSONNodeA; + LInt32: System.Int32; + LText: ansiString; + begin + if BufferPos > BufferLength - sizeof(LInt32) + 1 then begin + ExpandBuffer; + if BufferPos > BufferLength - sizeof(LInt32) + 1 then AlJSONDocErrorA(cALBSONParseError); + end; + ALMove(Pbyte(Buffer)[BufferPos-1], LInt32, sizeof(LInt32)); + BufferPos := BufferPos + sizeof(LInt32); + while (BufferPos + LInt32 - 1 > BufferLength) do + if not ExpandBuffer then AlJSONDocErrorA(cALBSONParseError); + ALCopyStr(Buffer,LText,BufferPos,LInt32 - 1{for the trailing #0}); + BufferPos := BufferPos + LInt32; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteBuffer2Stream(const buffer: ansiString; BufferLength: Integer); - Begin - if assigned(Stream) then begin - If BufferLength > 0 then stream.Writebuffer(pointer(buffer)^,BufferLength); - BufferPos := 0; - StreamPos := stream.Position; + if NotSaxMode then begin + if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Settext(LText); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LText], NodeSubType) + end + else begin + _DoParseText(Name, [LText], NodeSubType) end; end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _Write2Buffer(const Source; Count: NativeInt); - Begin - if Count = 0 then exit; - if Count + BufferPos > length(Buffer) then setlength(Buffer, Count + BufferPos + BufferSize); - ALMove(Source, pbyte(Buffer)[BufferPos], Count); - BufferPos := BufferPos + Count; - if BufferPos >= 32768 then _WriteBuffer2Stream(Buffer,BufferPos); - end; + {~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createFloatNode( + const name: AnsiString; + const NodeSubType: TALJSONNodeSubType); + var LNode: TALJSONNodeA; + LDouble: Double; + begin + if BufferPos > BufferLength - sizeof(Double) + 1 then begin + ExpandBuffer; + if BufferPos > BufferLength - sizeof(Double) + 1 then AlJSONDocErrorA(cALBSONParseError); + end; + ALMove(pbyte(Buffer)[BufferPos-1], LDouble, sizeof(Double)); + BufferPos := BufferPos + sizeof(Double); - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteStr2Buffer(const str:AnsiString); overload; - Begin - _Write2Buffer(pointer(str)^,length(Str)); + if NotSaxMode then begin + if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetFloat(LDouble); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LDouble], NodeSubType) + end + else begin + _DoParseText(Name, [LDouble], NodeSubType) + end; end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteStr2Buffer(const index:integer); overload; - Begin - _WriteStr2Buffer(ALIntToStrA(index)); - end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createBinaryNode( + const name: AnsiString; + const NodeSubType: TALJSONNodeSubType); + var LNode: TALJSONNodeA; + LInt32: System.Int32; + LBinSubtype: byte; + LBinData: ansiString; + begin + //Get size + if BufferPos > BufferLength - sizeof(LInt32) + 1 then begin + ExpandBuffer; + if BufferPos > BufferLength - sizeof(LInt32) + 1 then AlJSONDocErrorA(cALBSONParseError); + end; + ALMove(Pbyte(Buffer)[BufferPos-1], LInt32, sizeof(LInt32)); + BufferPos := BufferPos + sizeof(LInt32); - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - //take care because fucking TStringStream (for exemple) do not permit - //to write previous to the current position (it's set the size of the - //new stream to the current position ... unbelievable!) - Procedure _WriteInt2Pos(const aInt:integer; const aPos: system.Int64); - Begin - if aPos < StreamPos then begin - Stream.position := aPos; - stream.Writebuffer(aInt,sizeof(aInt)); - Stream.position := StreamPos; + //Get the subtype + if BufferPos > BufferLength then begin + ExpandBuffer; + if BufferPos > BufferLength then AlJSONDocErrorA(cALBSONParseError); + end; + LBinSubtype := Byte(Buffer[BufferPos]); + BufferPos := BufferPos + 1; + + //Get the data + while (BufferPos + LInt32 - 1 > BufferLength) do + if not ExpandBuffer then AlJSONDocErrorA(cALBSONParseError); + ALCopyStr(Buffer,LBinData,BufferPos,LInt32); + BufferPos := BufferPos + LInt32; + + //create the node + if NotSaxMode then begin + if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.setbinary(LBinData, LBinSubtype); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LBinData, LBinSubtype], NodeSubType); end - else ALMove(aInt, Buffer[aPos - StreamPos + 1], sizeOf(aInt)); + else begin + _DoParseText(Name, [LBinData, LBinSubtype], NodeSubType); + end; end; {~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - // \x01 + name + \x00 + double - Procedure _WriteFloatValue2Buffer(aTextNode:TALJSONNodeA); - var LDouble: Double; + procedure _createObjectIDNode( + const name: AnsiString; + const NodeSubType: TALJSONNodeSubType); + var LNode: TALJSONNodeA; + LObjectID: AnsiString; begin - LDouble := aTextNode.Float; - _Write2Buffer(LDouble, sizeOf(LDouble)); - end; + if BufferPos > BufferLength - 12{length(aObjectID)} + 1 then begin + ExpandBuffer; + if BufferPos > BufferLength - 12{length(aObjectID)} + 1 then AlJSONDocErrorA(cALBSONParseError); + end; + Setlength(LObjectID, 12); // ObjectId is a 12-byte BSON type + ALMove(Pbyte(Buffer)[BufferPos-1], pbyte(LObjectID)[0], 12{length(aObjectID)}); // pbyte(aObjectID)[0] to not have a jump in uniqueString (aObjectID is already unique thanks to Setlength) + BufferPos := BufferPos + 12{length(aObjectID)}; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - // \x02 + name + \x00 + length (int32) + string + \x00 - Procedure _WriteTextValue2Buffer(aTextNode:TALJSONNodeA); - var LInt32: system.int32; - LText: ansiString; - begin - LText := aTextNode.Text; - LInt32 := length(LText) + 1 {for the trailing #0}; - _Write2Buffer(LInt32, sizeOf(LInt32)); - _WriteStr2Buffer(LText); - _WriteStr2Buffer(#$00); + if NotSaxMode then begin + if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetObjectID(LObjectID); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LObjectID], NodeSubType) + end + else begin + _DoParseText(Name, [LObjectID], NodeSubType) + end; end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - // \x05 + name + \x00 + int32 + subtype + (byte*) - Procedure _WriteBinaryValue2Buffer(aTextNode:TALJSONNodeA); - var LInt32: system.int32; - LBinary: ansiString; - LBinarySubType: Byte; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createBooleanNode( + const name: AnsiString; + const NodeSubType: TALJSONNodeSubType); + var LNode: TALJSONNodeA; + LBool: Boolean; begin - LBinary := aTextNode.binary; - LBinarySubType := aTextNode.BinarySubType; - LInt32 := length(LBinary); - _Write2Buffer(LInt32, sizeOf(LInt32)); - _Write2Buffer(LBinarySubType, sizeOF(LBinarySubType)); - _WriteStr2Buffer(LBinary); - end; + if BufferPos > BufferLength then begin + ExpandBuffer; + if BufferPos > BufferLength then AlJSONDocErrorA(cALBSONParseError); + end; + if Buffer[BufferPos] = #$00 then LBool := False + else if Buffer[BufferPos] = #$01 then LBool := true + else begin + AlJSONDocErrorA(cALBSONParseError); + LBool := False; // to hide a warning; + end; + BufferPos := BufferPos + 1; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - // \x07 + name + \x00 + (byte*12) - Procedure _WriteObjectIDValue2Buffer(aTextNode:TALJSONNodeA); - begin - _WriteStr2Buffer(aTextNode.ObjectID); + if NotSaxMode then begin + if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setbool(LBool); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LBool], NodeSubType); + end + else begin + _DoParseText(Name, [LBool], NodeSubType); + end; end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - // \x08 + name + \x00 + \x00 => Boolean "false" - // \x08 + name + \x00 + \x01 => Boolean "true" - Procedure _WriteBooleanValue2Buffer(aTextNode:TALJSONNodeA); + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createDateTimeNode( + const name: AnsiString; + const NodeSubType: TALJSONNodeSubType); + var LNode: TALJSONNodeA; + LDateTime: TdateTime; + LInt64: System.Int64; begin - if not aTextNode.bool then _WriteStr2Buffer(#$00) - else _WriteStr2Buffer(#$01); + if BufferPos > BufferLength - sizeof(LInt64) + 1 then begin + ExpandBuffer; + if BufferPos > BufferLength - sizeof(LInt64) + 1 then AlJSONDocErrorA(cALBSONParseError); + end; + ALMove(Pbyte(Buffer)[BufferPos-1], LInt64, sizeof(LInt64)); + LDateTime := ALUnixMsToDateTime(LInt64); + BufferPos := BufferPos + sizeof(LInt64); + + if NotSaxMode then begin + if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setdatetime(LDateTime); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LDateTime], NodeSubType); + end + else begin + _DoParseText(Name, [LDateTime], NodeSubType); + end; end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~} - // \x09 + name + \x00 + int64 - Procedure _WriteDateTimeValue2Buffer(aTextNode:TALJSONNodeA); - var LInt64: system.Int64; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createTimestampNode( + const name: AnsiString; + const NodeSubType: TALJSONNodeSubType); + var LNode: TALJSONNodeA; + LTimestamp: TALBSONTimestamp; + LInt64: System.Int64; begin - LInt64 := ALDateTimeToUnixMs(aTextNode.DateTime); - _Write2Buffer(LInt64, sizeOf(LInt64)); - end; + if BufferPos > BufferLength - sizeof(LInt64) + 1 then begin + ExpandBuffer; + if BufferPos > BufferLength - sizeof(LInt64) + 1 then AlJSONDocErrorA(cALBSONParseError); + end; + ALMove(Pbyte(Buffer)[BufferPos-1], LInt64, sizeof(LInt64)); + LTimestamp.I64 := LInt64; + BufferPos := BufferPos + sizeof(LInt64); - {~~~~~~~~~~~~~~~~~~~~~~~~~~~} - // \x11 + name + \x00 + int64 - Procedure _WriteTimestampValue2Buffer(aTextNode:TALJSONNodeA); - var LInt64: system.Int64; - begin - LInt64 := aTextNode.Timestamp.I64; - _Write2Buffer(LInt64, sizeOf(LInt64)); + if NotSaxMode then begin + if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetTimestamp(LTimestamp); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LTimestamp.W1, LTimestamp.W2], NodeSubType); + end + else begin + _DoParseText(Name, [LTimestamp.W1, LTimestamp.W2], NodeSubType); + end; end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - // \xOB + name + \x00 + (byte*) + \x00 + (byte*) + \x00 - Procedure _WriteRegExValue2Buffer(aTextNode:TALJSONNodeA); - var LRegExOptions: TALPerlRegExOptions; - LRegExOptionsStr: ansiString; + {~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createnullNode( + const name: AnsiString; + const NodeSubType: TALJSONNodeSubType); + var LNode: TALJSONNodeA; begin - LRegExOptionsStr := ''; - LRegExOptions := aTextNode.RegExOptions; - if preCaseLess in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr + 'i'; - if preMultiLine in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr +'m'; - if preExtended in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr +'x'; - //'l':; - if preSingleLine in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr + 's'; - //'u':; - _WriteStr2Buffer(aTextNode.RegEx); - _WriteStr2Buffer(#$00); - _WriteStr2Buffer(LRegExOptionsStr); - _WriteStr2Buffer(#$00); + if NotSaxMode then begin + if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setnull(true); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, ['null'], NodeSubType); + end + else begin + _DoParseText(Name, ['null'], NodeSubType); + end; end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - // \x0D + name + \x00 + length (int32) + string + \x00 - Procedure _WriteJavascriptValue2Buffer(aTextNode:TALJSONNodeA); - var LInt32: system.int32; - LJavascript: ansiString; + {~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createRegExNode( + const name: AnsiString; + const NodeSubType: TALJSONNodeSubType); + var LNode: TALJSONNodeA; + LRegEx: ansiString; + LRegExOptions: TALPerlRegExOptions; + P1: integer; begin - LJavascript := aTextNode.Javascript; - LInt32 := length(LJavascript) + 1 {for the trailing #0}; - _Write2Buffer(LInt32, sizeOf(LInt32)); - _WriteStr2Buffer(LJavascript); - _WriteStr2Buffer(#$00); - end; + //Get pattern + P1 := BufferPos; + While (P1 <= BufferLength) or ExpandBuffer(P1) do begin + If Buffer[P1] <> #$00 then inc(P1) + else begin + LRegEx := AlCopyStr(Buffer, BufferPos, P1 - BufferPos); + break; + end; + end; + if P1 > BufferLength then AlJSONDocErrorA(cALBSONParseError); + BufferPos := P1 + 1; + if BufferPos > BufferLength then ExpandBuffer; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~} - // \x10 + name + \x00 + int32 - Procedure _WriteInt32Value2Buffer(aTextNode:TALJSONNodeA); - var LInt32: system.Int32; - begin - LInt32 := aTextNode.int32; - _Write2Buffer(LInt32, sizeOf(LInt32)); + //Get options + LRegExOptions := []; + While (BufferPos <= BufferLength) or ExpandBuffer do begin + case Buffer[BufferPos] of + 'i': LRegExOptions := LRegExOptions + [preCaseLess]; + 'm': LRegExOptions := LRegExOptions + [preMultiLine]; + 'x': LRegExOptions := LRegExOptions + [preExtended]; + 'l':; + 's': LRegExOptions := LRegExOptions + [preSingleLine]; + 'u':; + #$00: break; + end; + inc(BufferPos); + end; + if BufferPos > BufferLength then AlJSONDocErrorA(cALBSONParseError); + inc(BufferPos); + if BufferPos > BufferLength then ExpandBuffer; + + //create the node + if NotSaxMode then begin + if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetRegEx(LRegEx, LRegExOptions); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LRegEx, Byte(LRegExOptions)], NodeSubType) + end + else begin + _DoParseText(Name, [LRegEx, Byte(LRegExOptions)], NodeSubType) + end; end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~} - // \x12 + name + \x00 + int64 - Procedure _WriteInt64Value2Buffer(aTextNode:TALJSONNodeA); - var LInt64: system.Int64; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createJavascriptNode( + const name: AnsiString; + const NodeSubType: TALJSONNodeSubType); + var LNode: TALJSONNodeA; + LJavascript: ansiString; + LInt32: System.Int32; begin - LInt64 := aTextNode.int64; - _Write2Buffer(LInt64, sizeOf(LInt64)); + if BufferPos > BufferLength - sizeof(LInt32) + 1 then begin + ExpandBuffer; + if BufferPos > BufferLength - sizeof(LInt32) + 1 then AlJSONDocErrorA(cALBSONParseError); + end; + ALMove(Pbyte(Buffer)[BufferPos-1], LInt32, sizeof(LInt32)); + BufferPos := BufferPos + sizeof(LInt32); + while (BufferPos + LInt32 - 1 > BufferLength) do + if not ExpandBuffer then AlJSONDocErrorA(cALBSONParseError); + ALCopyStr(Buffer,LJavascript,BufferPos,LInt32 - 1{for the trailing #0}); + BufferPos := BufferPos + LInt32; + + //create the node + if NotSaxMode then begin + if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetJavascript(LJavascript); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LJavascript], NodeSubType); + end + else begin + _DoParseText(Name, [LJavascript], NodeSubType); + end; end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteTextNode2Buffer(aTextNode:TALJSONNodeA; aNodeIndex: integer); + {~~~~~~~~~~~~~~~~~~~~} + procedure AnalyzeNode; + Var LNode: TALJSONNodeA; + LNodeType: TALJSONNodeType; + LNodeSubType: TALJSONNodeSubType; + P1: Integer; + c: ansiChar; Begin - with aTextNode do begin - // write the node subtype - case NodeSubType of - // \x01 + name + \x00 + double - nstFloat: _WriteStr2Buffer(#$01); - // \x02 + name + \x00 + length (int32) + string + \x00 - nstText: _WriteStr2Buffer(#$02); - // \x05 + name + \x00 + int32 + subtype + (byte*) - nstbinary: _WriteStr2Buffer(#$05); - // \x07 + name + \x00 + (byte*12) - nstObjectID: _WriteStr2Buffer(#$07); - // \x08 + name + \x00 + \x00 => Boolean "false" - // \x08 + name + \x00 + \x01 => Boolean "true" - nstBoolean: _WriteStr2Buffer(#$08); - // \x09 + name + \x00 + int64 - nstDateTime: _WriteStr2Buffer(#$09); - // \x11 + name + \x00 + int64 - nstTimestamp: _WriteStr2Buffer(#$11); - // \x0A + name + \x00 - nstNull: _WriteStr2Buffer(#$0A); - // \xOB + name + \x00 + (byte*) + \x00 + (byte*) + \x00 - nstRegEx: _WriteStr2Buffer(#$0B); - // \x0D + name + \x00 + length (int32) + string + \x00 - nstJavascript: _WriteStr2Buffer(#$0D); - // \x10 + name + \x00 + int32 - nstInt32: _WriteStr2Buffer(#$10); - // \x12 + name + \x00 + int64 - nstInt64: _WriteStr2Buffer(#$12); - else AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + {$REGION 'init current char (c)'} + c := Buffer[BufferPos]; + {$ENDREGION} + + {$REGION 'End Object/Array'} + // ... } .... + // ... ] .... + if c = #$00 then begin + + //error if Paths.Count = 0 (mean one end object/array without any starting) + if assigned(ObjectPaths) then begin + if (ObjectPaths.Count = 0) then AlJSONDocErrorA(cALBSONParseError); + end + else begin + if (NamePaths.Count = 0) then AlJSONDocErrorA(cALBSONParseError); end; - // write the nodename - if (assigned(ParentNode)) and - (ParentNode.NodeType = ntArray) then _WriteStr2Buffer(aNodeIndex) - else _WriteStr2Buffer(NodeName); - _WriteStr2Buffer(#$00); + //if we are not in sax mode + if NotSaxMode then begin + + //init anode to one level up + if assigned(ObjectPaths) then LNode := ObjectPaths[ObjectPaths.Count - 1] + else LNode := TALJSONNodeA(NamePaths.Objects[NamePaths.Count - 1]); + + //if anode <> workingNode aie aie aie + if (LNode <> WorkingNode) then AlJSONDocErrorA(cALBSONParseError); + + //calculate anodeTypeInt + LNodeType := LNode.NodeType; + if not (LNodeType in [ntObject, ntarray]) then AlJSONDocErrorA(cALBSONParseError); - // add the nodevalue to the buffer - case NodeSubType of - nstFloat: _WriteFloatValue2Buffer(aTextNode); - nstText: _WriteTextValue2Buffer(aTextNode); - nstbinary: _WritebinaryValue2Buffer(aTextNode); - nstObjectID: _WriteObjectIDValue2Buffer(aTextNode); - nstBoolean: _WriteBooleanValue2Buffer(aTextNode); - nstDateTime: _WriteDateTimeValue2Buffer(aTextNode); - nstTimestamp: _WriteTimestampValue2Buffer(aTextNode); - nstNull:; - nstRegEx: _WriteRegExValue2Buffer(aTextNode); - nstJavascript: _WriteJavascriptValue2Buffer(aTextNode); - nstInt32: _WriteInt32Value2Buffer(aTextNode); - nstInt64: _WriteInt64Value2Buffer(aTextNode); - else AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); - end; - end; - end; + //if working node <> Self then we can go to one level up + If WorkingNode <> Self then begin - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteStartObjectNode2Buffer(aObjectNode:TALJSONNodeA; aNodeIndex: integer); - var LNodeList: TALJSONNodeListA; - LEmptyNode: Boolean; - LPos: system.int64; - I: integer; - Begin - with aObjectNode do begin + //init WorkingNode to the parentNode + WorkingNode := WorkingNode.ParentNode; + + end + + //if working node = Self then we can no go to the parent node so set WorkingNode to nil + Else WorkingNode := nil; - if aObjectNode = self then _WriteStr2Buffer(#$00#$00#$00#$00) - else if (assigned(ParentNode)) and - (ParentNode.NodeType = ntArray) then begin - _WriteStr2Buffer(#$03); - _WriteStr2Buffer(aNodeIndex); - _WriteStr2Buffer(#$00#$00#$00#$00#$00); end + + //if we are in sax mode else begin - _WriteStr2Buffer(#$03); - _WriteStr2Buffer(NodeName); - _WriteStr2Buffer(#$00#$00#$00#$00#$00); - end; - LPos := StreamPos + BufferPos - 4{length of the #$00#$00#$00#$00}; + //calculate anodeTypeInt + LNodeType := TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]); + if not (LNodeType in [ntObject,ntarray]) then AlJSONDocErrorA(cALBSONParseError); - LEmptyNode := True; - LNodeList := InternalGetChildNodes; - If assigned(LNodeList) then begin - with LNodeList do - If count > 0 then begin - LEmptyNode := False; - NodeStack.Push(aObjectNode); - NodeIndexStack.Push(aNodeIndex); - NodeStartPosStack.Push(LPos); - For I := Count - 1 downto 0 do begin - NodeStack.Push(Nodes[I]); - NodeIndexStack.Push(I); - NodeStartPosStack.Push(-1); - end; - end end; - If LEmptyNode then begin - _WriteStr2Buffer(#$00); - _WriteInt2Pos(5{length of the object},LPos); + //call the DoParseEndObject/array event + if Assigned(OnParseEndObject) then begin + if LNodeType = ntObject then _DoParseEndObject + else _DoParseEndArray; end; + //delete the last entry from the path + if assigned(ObjectPaths) then ObjectPaths.Delete(ObjectPaths.Count - 1) + else NamePaths.Delete(NamePaths.Count - 1); + + //update BufferPos + BufferPos := BufferPos + 1; + + //finallly exit from this procedure, everything was done + exit; + end; - end; + {$ENDREGION} - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteEndObjectNode2Buffer(aObjectNode:TALJSONNodeA; aNodeStartPos: system.Int64); - Begin - _WriteStr2Buffer(#$00); - _WriteInt2Pos(StreamPos + BufferPos - aNodeStartPos, aNodeStartPos); - end; + {$REGION 'Get the node sub type'} + LNodeSubType := nstText; // to hide fucking warning + case c of + #$01: LNodeSubType := nstFloat; + #$02: LNodeSubType := nstText; + #$03: LNodeSubType := nstObject; + #$04: LNodeSubType := nstArray; + #$05: LNodeSubType := nstbinary; + #$07: LNodeSubType := nstObjectID; + #$08: LNodeSubType := nstBoolean; + #$09: LNodeSubType := nstDateTime; + #$0A: LNodeSubType := nstNull; + #$0B: LNodeSubType := nstRegEx; + #$0D: LNodeSubType := nstJavascript; + #$10: LNodeSubType := nstint32; + #$11: LNodeSubType := nstTimestamp; + #$12: LNodeSubType := nstint64; + else AlJSONDocErrorA(cALBSONParseError); + end; + BufferPos := BufferPos + 1; + If BufferPos > BufferLength then ExpandBuffer; + {$ENDREGION} - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteStartArrayNode2Buffer(aArrayNode:TALJSONNodeA; aNodeIndex: integer); - var LNodeList: TALJSONNodeListA; - LEmptyNode: Boolean; - LPos: system.int64; - I: integer; - Begin - with aArrayNode do begin + {$REGION 'Get the node name'} + P1 := BufferPos; + While (P1 <= BufferLength) or ExpandBuffer(P1) do begin + If Buffer[P1] <> #$00 then inc(P1) + else begin + AlCopyStr(Buffer, CurrName, BufferPos, P1-BufferPos); + break; + end; + end; + if P1 > BufferLength then AlJSONDocErrorA(cALBSONParseError); + BufferPos := P1 + 1; + if BufferPos > BufferLength then ExpandBuffer; + {$ENDREGION} + + {$REGION 'Begin Object/Array'} + // ... { .... + // ... [ .... + if LNodeSubType in [nstObject,nstArray] then begin + + //if we are not in sax mode + if NotSaxMode then begin + + //if workingnode = nil then it's mean we are outside Self + if not assigned(WorkingNode) then AlJSONDocErrorA(cALBSONParseError); + + //create the node according the the braket char and add it to the workingnode + if LNodeSubType = nstObject then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', ntObject) + else LNode := CreateNode(CurrName, ntObject); + end + else begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', ntarray) + else LNode := CreateNode(CurrName, ntarray); + end; + try + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + + //set that the current working node will be now the new node newly created + WorkingNode := LNode; + + //update the path + if assigned(ObjectPaths) then ObjectPaths.Add(WorkingNode) + else _AddItemToNamePath(CurrName, WorkingNode); - if (assigned(ParentNode)) and - (ParentNode.NodeType = ntArray) then begin - _WriteStr2Buffer(#$04); - _WriteStr2Buffer(aNodeIndex); - _WriteStr2Buffer(#$00#$00#$00#$00#$00); end + + //if we are in sax mode else begin - _WriteStr2Buffer(#$04); - _WriteStr2Buffer(NodeName); - _WriteStr2Buffer(#$00#$00#$00#$00#$00); - end; - LPos := StreamPos + BufferPos - 4{length of the #$00+#$00+#$00+#$00}; + //update the path + if LNodeSubType = nstObject then LNodeType := ntObject + else LNodeType := ntArray; + _AddItemToNamePath(CurrName, pointer(LNodeType)); - LEmptyNode := True; - LNodeList := InternalGetChildNodes; - If assigned(LNodeList) then begin - with LNodeList do - If count > 0 then begin - LEmptyNode := False; - NodeStack.Push(aArrayNode); - NodeIndexStack.Push(aNodeIndex); - NodeStartPosStack.Push(LPos); - For I := Count - 1 downto 0 do begin - NodeStack.Push(Nodes[I]); - NodeIndexStack.Push(I); - NodeStartPosStack.Push(-1); - end; - end end; - If LEmptyNode then begin - _WriteStr2Buffer(#$00); - _WriteInt2Pos(5{length of the object},LPos); + //call the DoParseStartObject/array event + if LNodeSubType = nstObject then begin + if Assigned(OnParseStartObject) then _DoParseStartObject(CurrName) + end + else begin + if Assigned(OnParseStartArray) then _DoParseStartArray(CurrName); end; + //update BufferPos + BufferPos := BufferPos + 4; // we don't need the size of the object/array (4 bytes) + + //finallly exit from this procedure, everything was done + exit; + + end; + {$ENDREGION} + + {$REGION 'create the node'} + case LNodeSubType of + // \x01 + name + \x00 + double + nstFloat: _createFloatNode(CurrName, LNodeSubType); + + // \x02 + name + \x00 + length (int32) + string + \x00 + nstText: _createTextNode(CurrName, LNodeSubType); + + // \x05 + name + \x00 + int32 + subtype + (byte*) + nstbinary: _createBinaryNode(CurrName, LNodeSubType); + + // \x07 + name + \x00 + (byte*12) + nstObjectID: _createObjectIDNode(CurrName, LNodeSubType); + + // \x08 + name + \x00 + \x00 => Boolean "false" + // \x08 + name + \x00 + \x01 => Boolean "true" + nstBoolean: _createBooleanNode(CurrName, LNodeSubType); + + // \x09 + name + \x00 + int64 + nstDateTime: _createDateTimeNode(CurrName, LNodeSubType); + + // \x11 + name + \x00 + int64 + nstTimestamp: _createTimestampNode(CurrName, LNodeSubType); + + // \x0A + name + \x00 + nstnull: _createNullNode(CurrName, LNodeSubType); + + // \x0B + name + \x00 + (byte*) + \x00 + (byte*) + \x00 + nstRegEx: _createRegExNode(CurrName, LNodeSubType); + + // \x0D + name + \x00 + length (int32) + string + \x00 + nstJavascript: _createJavascriptNode(CurrName, LNodeSubType); + + // \x10 + name + \x00 + int32 + nstint32: _createInt32Node(CurrName, LNodeSubType); + + // \x12 + name + \x00 + int64 + nstint64: _createInt64Node(CurrName, LNodeSubType); + + else AlJSONDocErrorA(cALBSONParseError); end; - end; + {$ENDREGION} - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - Procedure _WriteEndArrayNode2Buffer(aArrayNode:TALJSONNodeA; aNodeStartPos: system.Int64); - Begin - _WriteStr2Buffer(#$00); - _WriteInt2Pos(StreamPos + BufferPos - aNodeStartPos, aNodeStartPos); end; -begin - If NodeType <> ntobject then exit; +Begin - CurrentParentNode := nil; - NodeStack := Tstack.Create; - NodeIndexStack := TALintegerList.Create; - NodeStartPosStack := TALInt64List.Create; - Try + //Only Object Node can be loaded from BSON + If NodeType <> ntObject then AlJSONDocErrorA(CALJsonOperationError,GetNodeType); + if poClearChildNodes in Options then ChildNodes.Clear; - {init buffer string} - Setlength(Buffer, BufferSize); // will make buffer uniquestring - BufferPos := 0; - if assigned(Stream) then StreamPos := Stream.Position - else StreamPos := 0; + //init WorkingNode and NotSaxMode + WorkingNode := Self; + NotSaxMode := not SaxMode; - {SaveOnlyChildNode} - NodeStack.Push(self); - NodeIndexStack.Push(0); - NodeStartPosStack.Push(StreamPos); + //init ObjectPaths or NamePaths + if (NotSaxMode) and + (not assigned(OnParseText)) and + (not assigned(OnParseStartObject)) and + (not assigned(OnParseEndObject)) and + (not assigned(OnParseStartArray)) and + (not assigned(OnParseEndArray)) then begin + ObjectPaths := TObjectList.Create(false{OwnsObjects}); + NamePaths := nil; + end + else begin + ObjectPaths := nil; + NamePaths := TALStringListA.Create; + end; + Try + //init Buffer + if assigned(RawBSONStream) then begin + Buffer := ''; + BufferLength := 0; + BufferPos := 5; // the first 4 bytes are the length of the document and we don't need it + ExpandBuffer; + end + else begin + Buffer := RawBSONString; + BufferLength := length(RawBSONString); + BufferPos := 5; // the first 4 bytes are the length of the document and we don't need it + end; - {loop on all nodes} - While NodeStack.Count > 0 Do begin - CurrentNode := NodeStack.Pop; - CurrentNodeIndex := integer(NodeIndexStack.Pop); - CurrentNodeStartPos := integer(NodeStartPosStack.Pop); + //add first node in ObjectPaths/NamePaths + if assigned(ObjectPaths) then ObjectPaths.Add(WorkingNode) + else begin + if NotSaxMode then NamePaths.AddObject('', WorkingNode) + else NamePaths.AddObject('', pointer(ntObject)); + end; + _DoParseStartObject(''); - with CurrentNode do - case NodeType of - ntObject: begin - if currentNode = CurrentParentNode then _WriteEndObjectNode2Buffer(CurrentNode, CurrentNodeStartPos) - else _WriteStartObjectNode2Buffer(CurrentNode, CurrentNodeIndex); - end; - ntArray: begin - if currentNode = CurrentParentNode then _WriteEndArrayNode2Buffer(CurrentNode, CurrentNodeStartPos) - else _WriteStartArrayNode2Buffer(CurrentNode, CurrentNodeIndex); - end; - ntText: _WriteTextNode2Buffer(CurrentNode, CurrentNodeIndex); - else AlJSONDocErrorA(cAlJSONInvalidNodeType); - end; + //analyze all the nodes + While (BufferPos <= BufferLength) or ExpandBuffer do + AnalyzeNode; - CurrentParentNode := CurrentNode.ParentNode; + //some tags are not closed + if assigned(ObjectPaths) then begin + if ObjectPaths.Count > 0 then AlJSONDocErrorA(cALBSONParseError); + end + else begin + if NamePaths.Count > 0 then AlJSONDocErrorA(cALBSONParseError); end; - {Write the buffer} - if assigned(Stream) then _WriteBuffer2Stream(Buffer, BufferPos) - else setlength(Buffer,BufferPos); + //mean the node was not update (empty stream?) or not weel closed + if NotSaxMode and (WorkingNode <> nil) then AlJSONDocErrorA(cALBSONParseError); finally - NodeStack.Free; - NodeIndexStack.Free; - NodeStartPosStack.Free; + + //free ObjectPaths/NamePaths + if assigned(ObjectPaths) then ALFreeAndNil(ObjectPaths) + else ALFreeAndNil(NamePaths); + end; -end; -{*************************************************************} -procedure TALJSONNodeA.SaveToBsonStream(const Stream: TStream); -var buffer: ansiString; -begin - SaveToBson(Stream, buffer); end; -{************************************************************} -procedure TALJSONNodeA.SaveToBsonFile(const FileName: String); -Var LfileStream: TfileStream; - LTmpFilename: String; -begin - if (assigned(FDocument)) and - (doProtectedSave in fDocument.Options) then LTmpFilename := FileName + '.~tmp' - else LTmpFilename := FileName; - try +{********************************} +procedure TALJSONNodeA.SaveToJson( + const Stream: TStream; + Var buffer: ansiString; + const Options: TALJSONSaveOptions); - LfileStream := TfileStream.Create(LTmpFilename,fmCreate); - Try - SaveToBsonStream(LfileStream); - finally - LfileStream.Free; - end; +Const BufferSize: integer = 8192; - if LTmpFilename <> FileName then begin - if TFile.Exists(FileName) then TFile.Delete(FileName); - TFile.Move(LTmpFilename, FileName); - end; +Var NodeStack: Tstack; + CurrentNode: TALJSONNodeA; + CurrentParentNode: TALJSONNodeA; + CurrentIndentStr: AnsiString; + IndentStr: AnsiString; + EncodeControlCharacters: Boolean; + SkipNodeSubTypeHelper: boolean; + SaveInt64AsText: Boolean; + AutoIndentNode: Boolean; + BufferPos: Integer; + LastWrittenChar: AnsiChar; - except - if (LTmpFilename <> FileName) and - (TFile.Exists(LTmpFilename)) then TFile.Delete(LTmpFilename); - raise; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteBuffer2Stream(const buffer: ansiString; BufferLength: Integer); + Begin + if assigned(Stream) then begin + If BufferLength > 0 then stream.Writebuffer(pointer(buffer)^,BufferLength); + BufferPos := 0; + end; end; -end; - -{****************************************************************} -procedure TALJSONNodeA.SaveToBsonFile(const FileName: AnsiString); -begin - SaveToBsonFile(String(FileName)); -end; - -{***********************************************************} -procedure TALJSONNodeA.SaveToBsonString(var str: AnsiString); -begin - SaveToBson(nil, Str); -end; -{******************************************************************************************************} -procedure TALJSONNodeA.LoadFromJSONString(const Str: AnsiString; Const ClearChildNodes: Boolean = True); -Begin - If NodeType <> ntObject then AlJSONDocErrorA(CALJsonOperationError,GetNodeType); - if ClearChildNodes then ChildNodes.Clear; - Try - FDocument.ParseJson(nil, Str, self) - except - ChildNodes.Clear; - raise; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _Write2Buffer(const Source; Count: NativeInt); + Begin + if Count = 0 then exit; + if Count + BufferPos > length(Buffer) then setlength(Buffer, Count + BufferPos + BufferSize); + ALMove(Source, pbyte(Buffer)[BufferPos{*sizeOf(ansiChar)}], Count{*sizeOf(ansiChar)}); + BufferPos := BufferPos + Count; + if BufferPos >= 32768 then _WriteBuffer2Stream(Buffer,BufferPos); end; -end; -{******************************************************************************************************} -procedure TALJSONNodeA.LoadFromJSONStream(const Stream: TStream; Const ClearChildNodes: Boolean = True); -Begin - If NodeType <> ntObject then AlJSONDocErrorA(CALJsonOperationError,GetNodeType); - if ClearChildNodes then ChildNodes.Clear; - Try - FDocument.ParseJSON(Stream, '', self) - except - ChildNodes.Clear; - raise; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteStr2Buffer(const str:AnsiString); + var L: integer; + Begin + L := Length(Str); + if L = 0 then exit; + LastWrittenChar := Str[L]; + _Write2Buffer(pointer(str)^,L); end; -end; -{*****************************************************************************************************} -procedure TALJSONNodeA.LoadFromJSONFile(const FileName: String; Const ClearChildNodes: Boolean = True); -Var LfileStream: TfileStream; -Begin - LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - Try - LoadFromJSONStream(LfileStream, ClearChildNodes); - finally - LfileStream.Free; - end; -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteTextNode2Buffer(aTextNode:TALJSONNodeA); + Begin + with aTextNode do begin -{*********************************************************************************************************} -procedure TALJSONNodeA.LoadFromJSONFile(const FileName: AnsiString; Const ClearChildNodes: Boolean = True); -Begin - LoadFromJSONFile(String(FileName), ClearChildNodes); -end; + if not (LastWrittenChar in ['{','[']) then _WriteStr2Buffer(','); -{******************************************************************************************************} -procedure TALJSONNodeA.LoadFromBSONString(const Str: AnsiString; Const ClearChildNodes: Boolean = True); -Begin - If NodeType <> ntObject then AlJSONDocErrorA(CALJsonOperationError,GetNodeType); - if ClearChildNodes then ChildNodes.Clear; - Try - FDocument.ParseBSON(nil, Str, self) - except - ChildNodes.Clear; - raise; - end; -end; + if AutoIndentNode then begin + _WriteStr2Buffer(#13#10); + _WriteStr2Buffer(CurrentIndentStr); + end; -{******************************************************************************************************} -procedure TALJSONNodeA.LoadFromBSONStream(const Stream: TStream; Const ClearChildNodes: Boolean = True); -Begin - If NodeType <> ntObject then AlJSONDocErrorA(CALJsonOperationError,GetNodeType); - if ClearChildNodes then ChildNodes.Clear; - Try - FDocument.ParseBSON(Stream, '', self) - except - ChildNodes.Clear; - raise; - end; -end; + if (assigned(ParentNode)) and + (ParentNode.NodeType <> ntArray) then begin + if EncodeControlCharacters then begin + _WriteStr2Buffer('"'); + _WriteStr2Buffer(ALJavascriptEncode(NodeName)); + _WriteStr2Buffer('":'); + end + else begin + _WriteStr2Buffer('"'); + _WriteStr2Buffer(NodeName); + _WriteStr2Buffer('":'); + end; + end; -{*****************************************************************************************************} -procedure TALJSONNodeA.LoadFromBSONFile(const FileName: String; Const ClearChildNodes: Boolean = True); -Var LfileStream: TfileStream; -Begin - LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - Try - LoadFromBSONStream(LfileStream, ClearChildNodes); - finally - LfileStream.Free; + if (NodeSubType = NstText) or + ((NodeSubType = nstInt64) and SaveInt64AsText) then begin + if (NodeSubType = NstText) and EncodeControlCharacters then begin + _WriteStr2Buffer('"'); + _WriteStr2Buffer(ALJavascriptEncode(GetText)); + _WriteStr2Buffer('"'); + end + else begin + _WriteStr2Buffer('"'); + _WriteStr2Buffer(Text); + _WriteStr2Buffer('"'); + end; + end + else _WriteStr2Buffer(GetNodeValueInterchange(SkipNodeSubTypeHelper)); + + end; end; -end; -{*********************************************************************************************************} -procedure TALJSONNodeA.LoadFromBSONFile(const FileName: AnsiString; Const ClearChildNodes: Boolean = True); -Begin - LoadFromBSONFile(String(FileName), ClearChildNodes); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteStartObjectNode2Buffer(aObjectNode:TALJSONNodeA); + var LNodeList: TALJSONNodeListA; + LEmptyNode: Boolean; + I: integer; + Begin + with aObjectNode do begin + + if not (LastWrittenChar in ['{','[']) then _WriteStr2Buffer(','); -{*********************************************************************} -constructor TALJSONObjectNodeA.Create(const NodeName: AnsiString = ''); -begin - inherited create(NodeName); - FChildNodes := nil; -end; + if AutoIndentNode and (CurrentIndentStr <> '') then begin + _WriteStr2Buffer(#13#10); + _WriteStr2Buffer(CurrentIndentStr); + end; -{************************************} -destructor TALJSONObjectNodeA.Destroy; -begin - If assigned(FChildNodes) then FreeAndNil(FchildNodes); - inherited; -end; + if aObjectNode = self then _WriteStr2Buffer('{') + else if (assigned(ParentNode)) and + (ParentNode.NodeType <> ntArray) then begin + if EncodeControlCharacters then begin + _WriteStr2Buffer('"'); + _WriteStr2Buffer(ALJavascriptEncode(NodeName)); + _WriteStr2Buffer('":{') + end + else begin + _WriteStr2Buffer('"'); + _WriteStr2Buffer(NodeName); + _WriteStr2Buffer('":{'); + end; + end + else _WriteStr2Buffer('{'); -{**********************************************************} -function TALJSONObjectNodeA.GetChildNodes: TALJSONNodeListA; -begin - if not Assigned(FChildNodes) then SetChildNodes(CreateChildList); - Result := FChildNodes; -end; + LEmptyNode := True; + LNodeList := InternalGetChildNodes; + If assigned(LNodeList) then begin + with LNodeList do + If count > 0 then begin + LEmptyNode := False; + NodeStack.Push(aObjectNode); + For I := Count - 1 downto 0 do NodeStack.Push(Nodes[I]); + end + end; -{************************************************************************} -procedure TALJSONObjectNodeA.SetChildNodes(const Value: TALJSONNodeListA); -begin - If Assigned(FChildNodes) then FreeAndNil(FchildNodes); - FChildNodes := Value; -end; + If LEmptyNode then _WriteStr2Buffer('}') + else CurrentIndentStr := CurrentIndentStr + IndentStr; -{*******************************************************} -function TALJSONObjectNodeA.GetNodeType: TALJSONNodeType; -begin - Result := NtObject; -end; + end; + end; -{*************************************************************} -function TALJSONObjectNodeA.GetNodeSubType: TALJSONNodeSubType; -begin - Result := NstObject; -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteEndObjectNode2Buffer(aObjectNode:TALJSONNodeA); + Begin + if AutoIndentNode then begin + delete(CurrentIndentStr, length(CurrentIndentStr) - length(IndentStr)+1, maxint); + _WriteStr2Buffer(#13#10); + _WriteStr2Buffer(CurrentIndentStr); + end; + _WriteStr2Buffer('}'); + end; -{********************************************} -{Get Childnode without create it if not exist} -function TALJSONObjectNodeA.InternalGetChildNodes: TALJSONNodeListA; -begin - Result := FChildNodes; -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteStartArrayNode2Buffer(aArrayNode:TALJSONNodeA); + var LNodeList: TALJSONNodeListA; + LEmptyNode: Boolean; + I: integer; + Begin + with aArrayNode do begin -{********************************************************************} -constructor TALJSONArrayNodeA.Create(const NodeName: AnsiString = ''); -begin - inherited create(NodeName); - FChildNodes := nil; -end; + if not (LastWrittenChar in ['{','[']) then _WriteStr2Buffer(','); -{***********************************} -destructor TALJSONArrayNodeA.Destroy; -begin - If assigned(FChildNodes) then FreeAndNil(FchildNodes); - inherited; -end; + if AutoIndentNode and (CurrentIndentStr <> '') then begin + _WriteStr2Buffer(#13#10); + _WriteStr2Buffer(CurrentIndentStr); + end; -{*********************************************************} -function TALJSONArrayNodeA.GetChildNodes: TALJSONNodeListA; -begin - if not Assigned(FChildNodes) then SetChildNodes(CreateChildList); - Result := FChildNodes; -end; + if aArrayNode = self then _WriteStr2Buffer('[') + else if (assigned(ParentNode)) and + (ParentNode.NodeType <> ntArray) then begin + if EncodeControlCharacters then begin + _WriteStr2Buffer('"'); + _WriteStr2Buffer(ALJavascriptEncode(NodeName)); + _WriteStr2Buffer('":['); + end + else begin + _WriteStr2Buffer('"'); + _WriteStr2Buffer(NodeName); + _WriteStr2Buffer('":['); + end; + end + else _WriteStr2Buffer('['); -{***********************************************************************} -procedure TALJSONArrayNodeA.SetChildNodes(const Value: TALJSONNodeListA); -begin - If Assigned(FChildNodes) then FreeAndNil(FchildNodes); - FChildNodes := Value; -end; + LEmptyNode := True; + LNodeList := InternalGetChildNodes; + If assigned(LNodeList) then begin + with LNodeList do + If count > 0 then begin + LEmptyNode := False; + NodeStack.Push(aArrayNode); + For I := Count - 1 downto 0 do NodeStack.Push(Nodes[I]); + end + end; -{******************************************************} -function TALJSONArrayNodeA.GetNodeType: TALJSONNodeType; -begin - Result := NtArray; -end; + If LEmptyNode then _WriteStr2Buffer(']') + else CurrentIndentStr := CurrentIndentStr + IndentStr; -{************************************************************} -function TALJSONArrayNodeA.GetNodeSubType: TALJSONNodeSubType; -begin - Result := NstArray; -end; + end; + end; -{********************************************} -{Get Childnode without create it if not exist} -function TALJSONArrayNodeA.InternalGetChildNodes: TALJSONNodeListA; -begin - Result := FChildNodes; -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteEndArrayNode2Buffer(aArrayNode:TALJSONNodeA); + Begin + if AutoIndentNode then begin + delete(CurrentIndentStr, length(CurrentIndentStr) - length(IndentStr) + 1, maxint); + _WriteStr2Buffer(#13#10); + _WriteStr2Buffer(CurrentIndentStr); + end; + _WriteStr2Buffer(']'); + end; -{*******************************************************************} -constructor TALJSONTextNodeA.Create(const NodeName: AnsiString = ''); begin - inherited create(NodeName); - fNodeSubType := nstText; - fRawNodeValueStr := ''; - FRawNodeValueInt64 := 0; - fRawNodeValueDefined := [nvStr]; -end; + If not (NodeType in [ntObject, ntArray]) then exit; // normally only Object node can gave a valid json stream + // but their is some situation where the array (containing json node) + // is also usefull + CurrentParentNode := nil; + NodeStack := Tstack.Create; + Try -{*****************************************************} -function TALJSONTextNodeA.GetNodeType: TALJSONNodeType; -begin - Result := NtText; -end; + {init buffer string} + Setlength(Buffer, BufferSize); // will make buffer uniquestring + BufferPos := 0; + LastWrittenChar := '{'; + EncodeControlCharacters := not (soIgnoreControlCharacters in Options); + SkipNodeSubTypeHelper := soSkipNodeSubTypeHelper in Options; + SaveInt64AsText := SkipNodeSubTypeHelper and (soSaveInt64AsText in Options); + AutoIndentNode := soNodeAutoIndent in Options; + IndentStr := ALDefaultJsonNodeIndentA; + CurrentIndentStr := ''; -{***********************************************************} -function TALJSONTextNodeA.GetNodeSubType: TALJSONNodeSubType; -begin - Result := fNodeSubType; -end; + {SaveOnlyChildNode} + NodeStack.Push(self); -{****************************************************} -function TALJSONTextNodeA.GetNodeValueStr: ansiString; -begin - if nvStr in fRawNodeValueDefined then result := fRawNodeValueStr - else begin + {loop on all nodes} + While NodeStack.Count > 0 Do begin + CurrentNode := NodeStack.Pop; - if not (nvInt64 in fRawNodeValueDefined) then AlJSONDocErrorA(CALJsonOperationError,GetNodeType); + with CurrentNode do + case NodeType of + ntObject: begin + if currentNode = CurrentParentNode then _WriteEndObjectNode2Buffer(CurrentNode) + else _WriteStartObjectNode2Buffer(CurrentNode); + end; + ntArray: begin + if currentNode = CurrentParentNode then _WriteEndArrayNode2Buffer(CurrentNode) + else _WriteStartArrayNode2Buffer(CurrentNode); + end; + ntText: _WriteTextNode2Buffer(CurrentNode); + else AlJSONDocErrorA(cAlJSONInvalidNodeType); + end; - case fNodeSubType of - nstFloat: ALFloatToStrA(GetFloat, fRawNodeValueStr, ALDefaultFormatSettingsA); - //nstText: can not be retrieve from int64 - //nstObject: can not be retrieve from int64 - //nstArray: can not be retrieve from int64 - //nstBinary: only the binarysubtype is store in int64 - //nstObjectID: can not be retrieve from int64 - nstBoolean: ALBoolToStrA(fRawNodeValueStr, getBool, 'true', 'false'); - nstDateTime: ALDateTimeToStrA(GetDateTime, fRawNodeValueStr, ALDefaultFormatSettingsA); - nstNull: fRawNodeValueStr := 'null'; - //nstRegEx: only the regex options is store in the int64 - //nstJavascript: can not be retrieve from int64 - nstInt32: ALIntToStrA(GetInt32, fRawNodeValueStr); - nstTimestamp: ALFormatA('Timestamp(%u, %u)', [GetTimestamp.W1,GetTimestamp.W2], fRawNodeValueStr); - nstInt64: ALIntToStrA(GetInt64, fRawNodeValueStr); - else AlJSONDocErrorA(CALJsonOperationError,GetNodeType); + CurrentParentNode := CurrentNode.ParentNode; end; - fRawNodeValueDefined := fRawNodeValueDefined + [nvStr]; - result := fRawNodeValueStr; + {Write the buffer} + if assigned(Stream) then _WriteBuffer2Stream(Buffer, BufferPos) + else setlength(Buffer,BufferPos); + finally + ALFreeAndNil(NodeStack); end; end; -{*************************************************} -function TALJSONTextNodeA.GetNodeValueInt64: int64; -var LDouble: Double; - LBool: boolean; - LDateTime: TdateTime; - LInt32: system.int32; - LTimestamp: TALBSONTimestamp; +{***********************************} +{Saves the JSON document to a stream. + Call SaveToStream to save the contents of the JSON document to the stream specified by Stream.} +procedure TALJSONNodeA.SaveToJSONStream(const Stream: TStream; const Options: TALJSONSaveOptions = []); +var buffer: ansiString; begin - if nvInt64 in fRawNodeValueDefined then result := fRawNodeValueInt64 - else begin + SaveToJson(Stream, buffer, Options); +end; - if not (nvStr in fRawNodeValueDefined) then AlJSONDocErrorA(CALJsonOperationError,GetNodeType); +{******************************} +{Saves the JSON document to disk. + Call SaveToFile to save any modifications you have made to the parsed JSON document. + AFileName is the name of the file to save.} +procedure TALJSONNodeA.SaveToJSONFile(const FileName: String; const Options: TALJSONSaveOptions = []); +Var LfileStream: TfileStream; + LTmpFilename: String; +begin + if soProtectedSave in Options then LTmpFilename := FileName + '.~tmp' + else LTmpFilename := FileName; + try - case fNodeSubType of - nstFloat: begin - IF not ALTryStrToFloat(fRawNodeValueStr, LDouble, ALDefaultFormatSettingsA) then AlJSONDocErrorA('%s is not a valid Float', [fRawNodeValueStr]); - fRawNodeValueInt64 := Pint64(@LDouble)^; - end; - //nstText: can not be retrieve from int64 - //nstObject: can not be retrieve from int64 - //nstArray: can not be retrieve from int64 - //nstBinary: only the binarysubtype is store in int64 - //nstObjectID: can not be retrieve from int64 - nstBoolean: begin - IF not ALTryStrToBool(fRawNodeValueStr, LBool) then AlJSONDocErrorA('%s is not a valid Boolean', [fRawNodeValueStr]); - fRawNodeValueInt64 := ALBoolToInt(LBool); - end; - nstDateTime: begin - IF not ALTryStrToDateTime(fRawNodeValueStr, LDateTime, ALDefaultFormatSettingsA) then AlJSONDocErrorA('%s is not a valid Datetime', [fRawNodeValueStr]); - fRawNodeValueInt64 := Pint64(@LDateTime)^; - end; - nstNull: begin - fRawNodeValueInt64 := 0; - end; - //nstRegEx: only the regex options is store in the int64 - //nstJavascript: can not be retrieve from int64 - nstInt32: begin - IF not ALTryStrToInt(fRawNodeValueStr, LInt32) then AlJSONDocErrorA('%s is not a valid Int32', [fRawNodeValueStr]); - fRawNodeValueInt64 := LInt32; - end; - nstTimestamp: begin - IF not ALJSONTryStrToTimestampA(fRawNodeValueStr, LTimestamp) then AlJSONDocErrorA('%s is not a valid Timestamp', [fRawNodeValueStr]); - fRawNodeValueInt64 := LTimestamp.I64; - end; - nstInt64: begin - IF not ALTryStrToInt64(fRawNodeValueStr, fRawNodeValueInt64) then AlJSONDocErrorA('%s is not a valid Int64', [fRawNodeValueStr]); - end; - else AlJSONDocErrorA(CALJsonOperationError,GetNodeType); + LfileStream := TfileStream.Create(LTmpFilename,fmCreate); + Try + SaveToJSONStream(LfileStream, Options); + finally + ALFreeAndNil(LfileStream); end; - fRawNodeValueDefined := fRawNodeValueDefined + [nvInt64]; - result := fRawNodeValueInt64; + if LTmpFilename <> FileName then begin + if TFile.Exists(FileName) then TFile.Delete(FileName); + TFile.Move(LTmpFilename, FileName); + end; + except + if (LTmpFilename <> FileName) and + (TFile.Exists(LTmpFilename)) then TFile.Delete(LTmpFilename); + raise; end; end; -{******************************************************************************************************} -procedure TALJSONTextNodeA.SetNodeValue(const Value: AnsiString; const NodeSubType: TALJSONNodeSubType); +{********************************************************************************************************} +procedure TALJSONNodeA.SaveToJSONFile(const FileName: AnsiString; const Options: TALJSONSaveOptions = []); begin - fNodeSubType := NodeSubType; - fRawNodeValueStr := Value; - fRawNodeValueDefined := [nvStr]; + SaveToJSONFile(String(FileName), Options); end; -{*************************************************************************************************} -procedure TALJSONTextNodeA.SetNodeValue(const Value: int64; const NodeSubType: TALJSONNodeSubType); +{************************************************} +{Saves the JSON document to a string-type variable. + Call SaveToJSON to save the contents of the JSON document to the string-type variable specified by JSON. SaveToJSON writes the contents of JSON document + using 8 bits char (utf-8, iso-8859-1, etc) as an encoding system, depending on the type of the JSON parameter. + Unlike the JSON property, which lets you write individual lines from the JSON document, SaveToJSON writes the entire text of the JSON document.} +procedure TALJSONNodeA.SaveToJSONString(var str: AnsiString; const Options: TALJSONSaveOptions = []); begin - fNodeSubType := NodeSubType; - fRawNodeValueInt64 := Value; - if (NodeSubType in [nstBinary, nstRegEx]) then fRawNodeValueDefined := fRawNodeValueDefined + [nvInt64] // keep the fNodeValueStr - else fRawNodeValueDefined := [nvInt64]; + SaveToJson(nil, Str, Options); end; -{**********************************************************************************************************************************} -procedure TALJSONTextNodeA.SetNodeValue(const StrValue: AnsiString; const Int64Value: int64; const NodeSubType: TALJSONNodeSubType); -begin - fNodeSubType := NodeSubType; - fRawNodeValueStr := StrValue; - fRawNodeValueInt64 := Int64Value; - fRawNodeValueDefined := [nvStr, nvInt64]; -end; +{********************************} +procedure TALJSONNodeA.SaveToBson( + const Stream: TStream; + Var buffer: ansiString; + const Options: TALJSONSaveOptions); -{*******************************************************} -constructor TALJSONNodeListA.Create(Owner: TALJSONNodeA); -begin - FList:= nil; - FCount:= 0; - FCapacity := 0; - FOwner := Owner; - FSorted := False; - if assigned(FOwner.OwnerDocument) then begin - FDuplicates := FOwner.OwnerDocument.Duplicates; - SetSorted(doSorted in FOwner.OwnerDocument.Options); - end - else begin - FDuplicates := dupAccept; - SetSorted(False); - end; -end; +Const BufferSize: integer = 8192; -{**********************************} -destructor TALJSONNodeListA.Destroy; -begin - Clear; - inherited; -end; +Var NodeStack: Tstack; + NodeIndexStack: TALintegerList; + NodeStartPosStack: TALInt64List; + CurrentNode: TALJSONNodeA; + CurrentParentNode: TALJSONNodeA; + CurrentNodeIndex: integer; + CurrentNodeStartPos: System.int64; + BufferPos: NativeInt; + StreamPos: system.int64; -{***********************************************************************************} -{Locates the index for a node name in a sorted list and indicates whether a node name - with that value already exists in the list. Use Find to obtain the index in a - sorted list where the node name S should be added. If the node name S, or a node - name that differs from S only in case, already exists in the list, Find returns true. - If the list does not contain a node name that matches S, Find returns false. - The index where S should go is returned in the Index parameter. - The value of Index is zero-based, where the first node name has the index 0, the - second node name has the index 1, and so on. - Note: Only use Find with sorted lists. For unsorted lists, use the IndexOf method instead. - Tip: If the node name string is not found (thus return value of Find is False) then Index - is set to the index of the first node name in the list that sorts immediately before - or after S.} -function TALJSONNodeListA.Find(const NodeName: AnsiString; var Index: Integer): Boolean; -var - L, H, I, C: Integer; -begin - Result := False; - L := 0; - H := FCount - 1; - while L <= H do - begin - I := (L + H) shr 1; - C := CompareNodeNames(FList[I].NodeName, NodeName); - if C < 0 then L := I + 1 else - begin - H := I - 1; - if C = 0 then - begin - Result := True; - if Duplicates <> dupAccept then L := I; - end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteBuffer2Stream(const buffer: ansiString; BufferLength: Integer); + Begin + if assigned(Stream) then begin + If BufferLength > 0 then stream.Writebuffer(pointer(buffer)^,BufferLength); + BufferPos := 0; + StreamPos := stream.Position; end; end; - Index := L; -end; -{*************************************} -{Returns the index of a specified node. - Call IndexOf to locate a node in the list. - *Node is the object node to locate. - IndexOf returns the index of the specified node, where 0 is the index of the first node, 1 is the - index of the second node, and so on. If the specified node is not in the list, IndexOf returns -1.} -function TALJSONNodeListA.IndexOf(const Node: TALJSONNodeA; const Direction: TDirection = TDirection.FromBeginning): Integer; -begin - if Direction = TDirection.FromBeginning then begin - for Result := 0 to Count - 1 do - if FList[Result] = Node then Exit; - end - else begin - for Result := Count - 1 downto 0 do - if FList[Result] = Node then Exit; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _Write2Buffer(const Source; Count: NativeInt); + Begin + if Count = 0 then exit; + if Count + BufferPos > length(Buffer) then setlength(Buffer, Count + BufferPos + BufferSize); + ALMove(Source, pbyte(Buffer)[BufferPos], Count); + BufferPos := BufferPos + Count; + if BufferPos >= 32768 then _WriteBuffer2Stream(Buffer,BufferPos); end; - Result := -1; -end; -{*************************************} -{Returns the index of a specified node. - Call IndexOf to locate a node in the list. - *Name is the NodeName property of the node to locate. - IndexOf returns the index of the specified node, where 0 is the index of the first node, 1 is the - index of the second node, and so on. If the specified node is not in the list, IndexOf returns -1.} -function TALJSONNodeListA.IndexOf(const Name: AnsiString; const Direction: TDirection = TDirection.FromBeginning): Integer; -begin - if not Sorted then begin - if Direction = TDirection.FromBeginning then begin - for Result := 0 to Count - 1 do - if CompareNodeNames(Get(Result).NodeName, Name) = 0 then Exit; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteStr2Buffer(const str:AnsiString); overload; + Begin + _Write2Buffer(pointer(str)^,length(Str)); + end; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteStr2Buffer(const index:integer); overload; + Begin + _WriteStr2Buffer(ALIntToStrA(index)); + end; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + //take care because fucking TStringStream (for exemple) do not permit + //to write previous to the current position (it's set the size of the + //new stream to the current position ... unbelievable!) + Procedure _WriteInt2Pos(const aInt:integer; const aPos: system.Int64); + Begin + if aPos < StreamPos then begin + Stream.position := aPos; + stream.Writebuffer(aInt,sizeof(aInt)); + Stream.position := StreamPos; end - else begin - for Result := Count - 1 downto 0 do - if CompareNodeNames(Get(Result).NodeName, Name) = 0 then Exit; - end; - Result := -1; - end - else if not Find(Name, Result) then Result := -1; -end; + else ALMove(aInt, Buffer[aPos - StreamPos + 1], sizeOf(aInt)); + end; -{*******************************************************************************************************************************} -function TALJSONNodeListA.IndexOfValue(const Value: ansiString; const Direction: TDirection = TDirection.FromBeginning): Integer; -begin - if Direction = TDirection.FromBeginning then begin - for Result := 0 to Count - 1 do - if (Get(Result).Text = Value) then Exit; - end - else begin - for Result := Count - 1 downto 0 do - if (Get(Result).Text = Value) then Exit; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + // \x01 + name + \x00 + double + Procedure _WriteFloatValue2Buffer(aTextNode:TALJSONNodeA); + var LDouble: Double; + begin + LDouble := aTextNode.Float; + _Write2Buffer(LDouble, sizeOf(LDouble)); + end; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + // \x02 + name + \x00 + length (int32) + string + \x00 + Procedure _WriteTextValue2Buffer(aTextNode:TALJSONNodeA); + var LInt32: system.int32; + LText: ansiString; + begin + LText := aTextNode.Text; + LInt32 := length(LText) + 1 {for the trailing #0}; + _Write2Buffer(LInt32, sizeOf(LInt32)); + _WriteStr2Buffer(LText); + _WriteStr2Buffer(#$00); end; - Result := -1; -end; -{****************************************************************************************************************************} -function TALJSONNodeListA.IndexOfValue(const Value: integer; const Direction: TDirection = TDirection.FromBeginning): Integer; -begin - if Direction = TDirection.FromBeginning then begin - for Result := 0 to Count - 1 do - if (Get(Result).int32 = Value) then Exit; - end - else begin - for Result := Count - 1 downto 0 do - if (Get(Result).int32 = Value) then Exit; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + // \x05 + name + \x00 + int32 + subtype + (byte*) + Procedure _WriteBinaryValue2Buffer(aTextNode:TALJSONNodeA); + var LInt32: system.int32; + LBinary: ansiString; + LBinarySubType: Byte; + begin + LBinary := aTextNode.binary; + LBinarySubType := aTextNode.BinarySubType; + LInt32 := length(LBinary); + _Write2Buffer(LInt32, sizeOf(LInt32)); + _Write2Buffer(LBinarySubType, sizeOF(LBinarySubType)); + _WriteStr2Buffer(LBinary); end; - Result := -1; -end; -{**************************************************************************************************************************} -function TALJSONNodeListA.IndexOfValue(const Value: int64; const Direction: TDirection = TDirection.FromBeginning): Integer; -begin - if Direction = TDirection.FromBeginning then begin - for Result := 0 to Count - 1 do - if (Get(Result).int64 = Value) then Exit; - end - else begin - for Result := Count - 1 downto 0 do - if (Get(Result).int64 = Value) then Exit; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + // \x07 + name + \x00 + (byte*12) + Procedure _WriteObjectIDValue2Buffer(aTextNode:TALJSONNodeA); + begin + _WriteStr2Buffer(aTextNode.ObjectID); end; - Result := -1; -end; -{***************************************************************************************************************************} -function TALJSONNodeListA.IndexOfValue(const Value: Double; const Direction: TDirection = TDirection.FromBeginning): Integer; -begin - if Direction = TDirection.FromBeginning then begin - for Result := 0 to Count - 1 do - if (Get(Result).float = Value) then Exit; - end - else begin - for Result := Count - 1 downto 0 do - if (Get(Result).float = Value) then Exit; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + // \x08 + name + \x00 + \x00 => Boolean "false" + // \x08 + name + \x00 + \x01 => Boolean "true" + Procedure _WriteBooleanValue2Buffer(aTextNode:TALJSONNodeA); + begin + if not aTextNode.bool then _WriteStr2Buffer(#$00) + else _WriteStr2Buffer(#$01); end; - Result := -1; -end; -{******************************************************************************************************************************} -function TALJSONNodeListA.IndexOfValue(const Value: TDateTime; const Direction: TDirection = TDirection.FromBeginning): Integer; -begin - if Direction = TDirection.FromBeginning then begin - for Result := 0 to Count - 1 do - if (Get(Result).DateTime = Value) then Exit; - end - else begin - for Result := Count - 1 downto 0 do - if (Get(Result).DateTime = Value) then Exit; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~} + // \x09 + name + \x00 + int64 + Procedure _WriteDateTimeValue2Buffer(aTextNode:TALJSONNodeA); + var LInt64: system.Int64; + begin + LInt64 := ALDateTimeToUnixMs(aTextNode.DateTime); + _Write2Buffer(LInt64, sizeOf(LInt64)); end; - Result := -1; -end; -{**************************************} -{Returns a specified node from the list. - Call FindNode to access a particular node in the list. - *NodeName is the node to access. It specifies the NodeName property of the desired node. - FindNode returns the object of the node if it is in the list. If NodeName does not specify a node in the list, - FindNode returns nil (Delphi) or NULL (C++).} -function TALJSONNodeListA.FindNode(const NodeName: AnsiString; const Direction: TDirection = TDirection.FromBeginning): TALJSONNodeA; -var Index: Integer; -begin - Index := IndexOf(NodeName, Direction); - if Index >= 0 then Result := Get(Index) - else Result := nil; -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~} + // \x11 + name + \x00 + int64 + Procedure _WriteTimestampValue2Buffer(aTextNode:TALJSONNodeA); + var LInt64: system.Int64; + begin + LInt64 := aTextNode.Timestamp.I64; + _Write2Buffer(LInt64, sizeOf(LInt64)); + end; -{**********************************} -{Returns the first node in the list. -Call First to access the first node in the list. If the list is empty, First raises an exception} -function TALJSONNodeListA.First: TALJSONNodeA; -begin - if Count > 0 then Result := Get(0) - else Result := nil; -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + // \xOB + name + \x00 + (byte*) + \x00 + (byte*) + \x00 + Procedure _WriteRegExValue2Buffer(aTextNode:TALJSONNodeA); + var LRegExOptions: TALPerlRegExOptions; + LRegExOptionsStr: ansiString; + begin + LRegExOptionsStr := ''; + LRegExOptions := aTextNode.RegExOptions; + if preCaseLess in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr + 'i'; + if preMultiLine in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr +'m'; + if preExtended in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr +'x'; + //'l':; + if preSingleLine in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr + 's'; + //'u':; + _WriteStr2Buffer(aTextNode.RegEx); + _WriteStr2Buffer(#$00); + _WriteStr2Buffer(LRegExOptionsStr); + _WriteStr2Buffer(#$00); + end; -{*********************************} -{Returns the last node in the list. - Call Last to access the last node in the list. If the list is empty, Last raises an exception.} -function TALJSONNodeListA.Last: TALJSONNodeA; -begin - if Count > 0 then Result := Get(FCount - 1) - else result := nil; -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + // \x0D + name + \x00 + length (int32) + string + \x00 + Procedure _WriteJavascriptValue2Buffer(aTextNode:TALJSONNodeA); + var LInt32: system.int32; + LJavascript: ansiString; + begin + LJavascript := aTextNode.Javascript; + LInt32 := length(LJavascript) + 1 {for the trailing #0}; + _Write2Buffer(LInt32, sizeOf(LInt32)); + _WriteStr2Buffer(LJavascript); + _WriteStr2Buffer(#$00); + end; -{***************************************************************************} -{Returns a node that appears a specified amount before or after another node. - Call FindSibling to access the node whose position has a specified relationship to another node. - *Node is a node in the list to use as a reference point. - *Delta indicates where the desired node appears, relative to Node. If Delta is positive, FindSibling returns - the node that appears Delta positions after Node. If Delta is negative, FindSibling returns a node that appears before Node. - FindSibling returns the node that appears at the position offset by Delta, relative to the position of Node. If Delta - specifies a position before the first node or after the last node in the list, FindSibling returns nil (Delphi) or NULL (C++).} -function TALJSONNodeListA.FindSibling(const Node: TALJSONNodeA; Delta: Integer): TALJSONNodeA; -var Index: Integer; -begin - Index := IndexOf(Node) + Delta; - if (Index >= 0) and (Index < FCount) then Result := Get(Index) - else Result := nil; -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~} + // \x10 + name + \x00 + int32 + Procedure _WriteInt32Value2Buffer(aTextNode:TALJSONNodeA); + var LInt32: system.Int32; + begin + LInt32 := aTextNode.int32; + _Write2Buffer(LInt32, sizeOf(LInt32)); + end; -{************************************} -{Returns a specified node in the list. - Call Get to retrieve a node from the list, given its index. - *Index specifies the node to fetch, where 0 identifies the first node, 1 identifies the second node, and so on. - Index should be less than the value of the Count property.} -function TALJSONNodeListA.Get(Index: Integer): TALJSONNodeA; -begin - if (Index < 0) or (Index >= FCount) then AlJSONDocErrorA(CALJSONListIndexError, [Index]); - Result := FList[Index]; -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~} + // \x12 + name + \x00 + int64 + Procedure _WriteInt64Value2Buffer(aTextNode:TALJSONNodeA); + var LInt64: system.Int64; + begin + LInt64 := aTextNode.int64; + _Write2Buffer(LInt64, sizeOf(LInt64)); + end; -{**************************************} -{Returns a specified node from the list. - GetNode is the read implementation of the Nodes property. - *Index identify the desired node. 0 is the index of the first node, - 1 is the index of the second node, and so on} -function TALJSONNodeListA.GetNodeByIndex(const Index: Integer): TALJSONNodeA; -begin - Result := Get(Index); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteTextNode2Buffer(aTextNode:TALJSONNodeA; aNodeIndex: integer); + Begin + with aTextNode do begin -{**************************************} -{Returns a specified node from the list. - GetNode is the read implementation of the Nodes property. - *Name identify the desired node. it is the NodeName property of a node in the list. - If Name does not identify a node in the list, GetNode tries to create a new node with the name specified by - Name. If it can’t create the new node, GetNode raises an exception.} -function TALJSONNodeListA.GetNodeByName(const Name: AnsiString): TALJSONNodeA; -begin - Result := FindNode(Name); - if (not Assigned(Result)) and - (assigned(fOwner.OwnerDocument)) and - (doNodeAutoCreate in fOwner.OwnerDocument.Options) then Result := FOwner.AddChild(Name); // only text node will be added via doNodeAutoCreate - if not Assigned(Result) then AlJSONDocErrorA(CALJSONNodeNotFound, [Name]); -end; + // write the node subtype + case NodeSubType of + // \x01 + name + \x00 + double + nstFloat: _WriteStr2Buffer(#$01); + // \x02 + name + \x00 + length (int32) + string + \x00 + nstText: _WriteStr2Buffer(#$02); + // \x05 + name + \x00 + int32 + subtype + (byte*) + nstbinary: _WriteStr2Buffer(#$05); + // \x07 + name + \x00 + (byte*12) + nstObjectID: _WriteStr2Buffer(#$07); + // \x08 + name + \x00 + \x00 => Boolean "false" + // \x08 + name + \x00 + \x01 => Boolean "true" + nstBoolean: _WriteStr2Buffer(#$08); + // \x09 + name + \x00 + int64 + nstDateTime: _WriteStr2Buffer(#$09); + // \x11 + name + \x00 + int64 + nstTimestamp: _WriteStr2Buffer(#$11); + // \x0A + name + \x00 + nstNull: _WriteStr2Buffer(#$0A); + // \xOB + name + \x00 + (byte*) + \x00 + (byte*) + \x00 + nstRegEx: _WriteStr2Buffer(#$0B); + // \x0D + name + \x00 + length (int32) + string + \x00 + nstJavascript: _WriteStr2Buffer(#$0D); + // \x10 + name + \x00 + int32 + nstInt32: _WriteStr2Buffer(#$10); + // \x12 + name + \x00 + int64 + nstInt64: _WriteStr2Buffer(#$12); + else AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); + end; -{****************************************************************************} -function TALJSONNodeListA.CompareNodeNames(const S1, S2: AnsiString): Integer; -begin - Result := ALCompareStrA(S1, S2) -end; + // write the nodename + if (assigned(ParentNode)) and + (ParentNode.NodeType = ntArray) then _WriteStr2Buffer(aNodeIndex) + else _WriteStr2Buffer(NodeName); + _WriteStr2Buffer(#$00); -{*****************************************************************************************} -procedure TALJSONNodeListA.QuickSort(L, R: Integer; ACompare: TALJSONNodeListSortCompareA); -var - I, J, P: Integer; -begin - while L < R do - begin - if (R - L) = 1 then - begin - if ACompare(Self, L, R) > 0 then - Exchange(L, R); - break; - end; - I := L; - J := R; - P := (L + R) shr 1; - repeat - while (I <> P) and (ACompare(Self, I, P) < 0) do Inc(I); - while (J <> P) and (ACompare(Self, J, P) > 0) do Dec(J); - if I <= J then - begin - if I <> J then - Exchange(I, J); - if P = I then - P := J - else if P = J then - P := I; - Inc(I); - Dec(J); + // add the nodevalue to the buffer + case NodeSubType of + nstFloat: _WriteFloatValue2Buffer(aTextNode); + nstText: _WriteTextValue2Buffer(aTextNode); + nstbinary: _WritebinaryValue2Buffer(aTextNode); + nstObjectID: _WriteObjectIDValue2Buffer(aTextNode); + nstBoolean: _WriteBooleanValue2Buffer(aTextNode); + nstDateTime: _WriteDateTimeValue2Buffer(aTextNode); + nstTimestamp: _WriteTimestampValue2Buffer(aTextNode); + nstNull:; + nstRegEx: _WriteRegExValue2Buffer(aTextNode); + nstJavascript: _WriteJavascriptValue2Buffer(aTextNode); + nstInt32: _WriteInt32Value2Buffer(aTextNode); + nstInt64: _WriteInt64Value2Buffer(aTextNode); + else AlJSONDocErrorA(cALJSONInvalidBSONNodeSubType); end; - until I > J; - if (J - L) > (R - I) then - begin - if I < R then - QuickSort(I, R, ACompare); - R := J; - end - else - begin - if L < J then - QuickSort(L, J, ACompare); - L := I; end; end; -end; -{************************************************************************************************} -function ALJSONNodeListCompareNodeNameA(List: TALJSONNodeListA; Index1, Index2: Integer): Integer; -begin - Result := List.CompareNodeNames( - List[Index1].NodeName, - List[Index2].NodeName); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteStartObjectNode2Buffer(aObjectNode:TALJSONNodeA; aNodeIndex: integer); + var LNodeList: TALJSONNodeListA; + LEmptyNode: Boolean; + LPos: system.int64; + I: integer; + Begin + with aObjectNode do begin -{******************************} -procedure TALJSONNodeListA.Sort; -begin - CustomSort(ALJSONNodeListCompareNodeNameA); -end; + if aObjectNode = self then _WriteStr2Buffer(#$00#$00#$00#$00) + else if (assigned(ParentNode)) and + (ParentNode.NodeType = ntArray) then begin + _WriteStr2Buffer(#$03); + _WriteStr2Buffer(aNodeIndex); + _WriteStr2Buffer(#$00#$00#$00#$00#$00); + end + else begin + _WriteStr2Buffer(#$03); + _WriteStr2Buffer(NodeName); + _WriteStr2Buffer(#$00#$00#$00#$00#$00); + end; -{**************************************************************************} -procedure TALJSONNodeListA.CustomSort(Compare: TALJSONNodeListSortCompareA); -begin - if (not Sorted) and (FList <> nil) and (Count > 1) then - QuickSort(0, Count - 1, Compare); -end; + LPos := StreamPos + BufferPos - 4{length of the #$00#$00#$00#$00}; -{**************************************} -{Adds a new node to the end of the list. - Call Add to add a node to the end of the list. Add returns the index of the node once it is added, where 0 is the index - of the first node in the list, 1 is the index of the second node, and so on. - *Node is the node to add to the list.} -function TALJSONNodeListA.Add(const Node: TALJSONNodeA): Integer; -begin - if not Sorted then - Result := FCount - else - if Find(Node.NodeName, Result) then - case Duplicates of - dupIgnore: begin - ALFreeAndNil(Node); - Exit; - end; - dupError: AlJSONDocErrorA(cALJSONDuplicateNodeName); + LEmptyNode := True; + LNodeList := InternalGetChildNodes; + If assigned(LNodeList) then begin + with LNodeList do + If count > 0 then begin + LEmptyNode := False; + NodeStack.Push(aObjectNode); + NodeIndexStack.Push(aNodeIndex); + NodeStartPosStack.Push(LPos); + For I := Count - 1 downto 0 do begin + NodeStack.Push(Nodes[I]); + NodeIndexStack.Push(I); + NodeStartPosStack.Push(-1); + end; + end end; - InternalInsert(Result, Node); -end; -{**********************************************************************************} -procedure TALJSONNodeListA.InternalInsert(Index: Integer; const Node: TALJSONNodeA); -begin - if FCount = FCapacity then Grow; - if Index < FCount then - ALMove( - FList[Index], - FList[Index + 1], - (FCount - Index) * SizeOf(Pointer)); - Pointer(FList[index]) := nil; - FList[index] := Node; - Inc(FCount); - Node.SetParentNode(Fowner); -end; + If LEmptyNode then begin + _WriteStr2Buffer(#$00); + _WriteInt2Pos(5{length of the object},LPos); + end; -{********************************************************} -{Inserts a new node into a specified position in the list. - Call Insert to add a node at the position specified by Index. - *Index specifies where to insert the node, where 0 is the first position, 1 is second position, and so on. If Index does not - specify a valid index, Insert raises an exception. - *Node is the node to add to the list.} -procedure TALJSONNodeListA.Insert(Index: Integer; const Node: TALJSONNodeA); -begin - if Index = -1 then Add(Node) - else begin - if Sorted then AlJSONDocErrorA(CALJSONSortedListError); - if (Index < 0) or (Index > FCount) then AlJSONDocErrorA(CALJSONListIndexError, [Index]); - InternalInsert(Index, Node); + end; end; -end; -{**************************************} -{Removes a specified node from the list. - Delete removes the node specified by the Index or Name parameter. - *Index identifies the node to remove by index rather than name. Index ranges from 0 to one less than the value of the Count property. - Delete returns the index of the node that was removed. If there was no node that matched the value of Index Delete returns –1.} -function TALJSONNodeListA.Delete(const Index: Integer): Integer; -var Node: TALJSONNodeA; -begin - Node := Get(Index); - FList[Index] := nil; // to decrease the refcount of Node - Dec(FCount); - if Index < FCount then begin - ALMove( - FList[Index + 1], - FList[Index], - (FCount - Index) * SizeOf(Pointer)); - Pointer(FList[FCount]) := nil; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteEndObjectNode2Buffer(aObjectNode:TALJSONNodeA; aNodeStartPos: system.Int64); + Begin + _WriteStr2Buffer(#$00); + _WriteInt2Pos(StreamPos + BufferPos - aNodeStartPos, aNodeStartPos); end; - if assigned(Node) then FreeAndNil(Node); - result := Index; -end; - -{**************************************} -{Removes a specified node from the list. - Delete removes the node specified by the Index or Name parameter. - *Name identifies the node to remove from the list. This is the local name of the node to remove. - Delete returns the index of the node that was removed. If there was no node that matched the value of Name, Delete returns –1.} -function TALJSONNodeListA.Delete(const Name: AnsiString): Integer; -begin - result := indexOf(Name); - if Result >= 0 then Delete(Result); -end; - -{**************************************} -{Removes a specified node from the list. - Remove removes the specified node from the list. - *Node is the node to remove from the list. - Remove returns the index of Node before it was removed. If node is not a node in the list, Remove returns -1.} -function TALJSONNodeListA.Remove(const Node: TALJSONNodeA): Integer; -begin - Result := IndexOf(Node); - if Result >= 0 then Delete(Result); -end; - -{***********************************************************} -{Removes a specified object from the list without freeing it. - Call Extract to remove an object from the list without freeing the object itself. - After an object is removed, all the objects that follow it are moved up in index position and Count is decremented.} -function TALJSONNodeListA.Extract(const Node: TALJSONNodeA): TALJSONNodeA; -var I: Integer; -begin - Result := nil; - I := IndexOf(Node); - if I >= 0 then result := Extract(i); -end; -{***********************************************************} -procedure TALJSONNodeListA.Exchange(Index1, Index2: Integer); -var Item: Pointer; -begin - if (Index1 < 0) or (Index1 >= FCount) then AlJSONDocErrorA(cALJSONListIndexError, [Index1]); - if (Index2 < 0) or (Index2 >= FCount) then AlJSONDocErrorA(cALJSONListIndexError, [Index2]); - Item := pointer(FList[Index1]); - pointer(FList[Index1]) := pointer(FList[Index2]); - pointer(FList[Index2]) := Item; -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteStartArrayNode2Buffer(aArrayNode:TALJSONNodeA; aNodeIndex: integer); + var LNodeList: TALJSONNodeListA; + LEmptyNode: Boolean; + LPos: system.int64; + I: integer; + Begin + with aArrayNode do begin -{***********************************************************} -{Removes a specified object from the list without freeing it. - Call Extract to remove an object from the list without freeing the object itself. - After an object is removed, all the objects that follow it are moved up in index position and Count is decremented.} -function TALJSONNodeListA.Extract(const index: integer): TALJSONNodeA; -begin - Result := Get(index); - Result.SetParentNode(nil); - FList[index] := nil; - Delete(index); -end; + if (assigned(ParentNode)) and + (ParentNode.NodeType = ntArray) then begin + _WriteStr2Buffer(#$04); + _WriteStr2Buffer(aNodeIndex); + _WriteStr2Buffer(#$00#$00#$00#$00#$00); + end + else begin + _WriteStr2Buffer(#$04); + _WriteStr2Buffer(NodeName); + _WriteStr2Buffer(#$00#$00#$00#$00#$00); + end; -{*********************************************} -{Replaces a node in the list with another node. - Call ReplaceNode to replace the node specified by OldNode with the node specified by NewNode. - *OldNode is the node to replace. If OldNode does not appear in the list, then ReplaceNode adds the new node to the end of the list. - *NewNode is the node to add to the list in place of OldNode. - ReplaceNode returns OldNode (even if OldNode did not appear in the list).} -function TALJSONNodeListA.ReplaceNode(const OldNode, NewNode: TALJSONNodeA): TALJSONNodeA; -var Index: Integer; -begin - Index := indexOf(OldNode); - Result := Extract(Index); - if not sorted then Insert(Index, NewNode) - else Add(NewNode); -end; + LPos := StreamPos + BufferPos - 4{length of the #$00+#$00+#$00+#$00}; -{*******************************} -{Removes all nodes from the list. - Call Clear to empty the list. - Note: Clear does not call the BeginUpdate and EndUpdate methods, even though it may result in the - deletion of more than one node.} -procedure TALJSONNodeListA.Clear; -begin - SetCount(0); - SetCapacity(0); -end; + LEmptyNode := True; + LNodeList := InternalGetChildNodes; + If assigned(LNodeList) then begin + with LNodeList do + If count > 0 then begin + LEmptyNode := False; + NodeStack.Push(aArrayNode); + NodeIndexStack.Push(aNodeIndex); + NodeStartPosStack.Push(LPos); + For I := Count - 1 downto 0 do begin + NodeStack.Push(Nodes[I]); + NodeIndexStack.Push(I); + NodeStartPosStack.Push(-1); + end; + end + end; -{******************************} -procedure TALJSONNodeListA.Grow; -{$IF CompilerVersion <= 32}{tokyo} -var Delta: Integer; -{$endif} -begin - {$IF CompilerVersion <= 32}{tokyo} - if FCapacity > 64 then Delta := FCapacity div 4 - else if FCapacity > 8 then Delta := 16 - else Delta := 4; - SetCapacity(FCapacity + Delta); - {$else} - SetCapacity(GrowCollection(FCapacity, FCount + 1)); - {$endif} -end; + If LEmptyNode then begin + _WriteStr2Buffer(#$00); + _WriteInt2Pos(5{length of the object},LPos); + end; -{***********************************************************} -procedure TALJSONNodeListA.SetCapacity(NewCapacity: Integer); -begin - if (NewCapacity < FCount) then AlJSONDocErrorA(CALJSONListCapacityError, [NewCapacity]); - if NewCapacity <> FCapacity then begin - SetLength(FList, NewCapacity); - FCapacity := NewCapacity; + end; end; -end; -{*****************************************************************************} -procedure TALJSONNodeListA.SetDuplicates(Value: TDuplicates; Recurse: Boolean); -begin - FDuplicates := Value; - if Recurse then begin - for Var I := 0 to count-1 do begin - Var LNodeList := Get(i).InternalGetChildNodes; - if LNodeList <> nil then LNodeList.SetDuplicates(Value,Recurse); - end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + Procedure _WriteEndArrayNode2Buffer(aArrayNode:TALJSONNodeA; aNodeStartPos: system.Int64); + Begin + _WriteStr2Buffer(#$00); + _WriteInt2Pos(StreamPos + BufferPos - aNodeStartPos, aNodeStartPos); end; -end; -{***********************************************************} -procedure TALJSONNodeListA.SetDuplicates(Value: TDuplicates); begin - SetDuplicates(Value, False); -end; + If NodeType <> ntobject then exit; -{*********************************************************************} -procedure TALJSONNodeListA.SetSorted(Value: Boolean; Recurse: Boolean); -begin - if FSorted <> Value then - begin - if owner is TALJSONObjectNodeA then begin - if Value then Sort; - FSorted := Value; - end - else FSorted := False; - end; - if Recurse then begin - for Var I := 0 to count-1 do begin - Var LNodeList := Get(i).InternalGetChildNodes; - if LNodeList <> nil then LNodeList.SetSorted(Value,Recurse); - end; - end; -end; + CurrentParentNode := nil; + NodeStack := Tstack.Create; + NodeIndexStack := TALintegerList.Create; + NodeStartPosStack := TALInt64List.Create; + Try -{***************************************************} -procedure TALJSONNodeListA.SetSorted(Value: Boolean); -begin - SetSorted(Value, False); -end; + {init buffer string} + Setlength(Buffer, BufferSize); // will make buffer uniquestring + BufferPos := 0; + if assigned(Stream) then StreamPos := Stream.Position + else StreamPos := 0; -{*****************************************************} -procedure TALJSONNodeListA.SetCount(NewCount: Integer); -var I: Integer; -begin - if (NewCount < 0) then AlJSONDocErrorA(CALJSONListCountError, [NewCount]); - if NewCount > FCapacity then SetCapacity(NewCount); - if NewCount > FCount then FillChar(FList[FCount], (NewCount - FCount) * SizeOf(Pointer), 0) - else for I := FCount - 1 downto NewCount do Delete(I); - FCount := NewCount; -end; + {SaveOnlyChildNode} + NodeStack.Push(self); + NodeIndexStack.Push(0); + NodeStartPosStack.Push(StreamPos); -{**************************} -Procedure ALJSONToTStringsA( - const AJsonStr: AnsiString; - const aFormatSettings: TALFormatSettingsA; - const aPath: AnsiString; - const aLst: TALStringsA; - Const aNullStr: AnsiString = 'null'; - Const aTrueStr: AnsiString = 'true'; - Const aFalseStr: AnsiString = 'false'); -var LJsonDocument: TALJSONDocumentA; - LContainChilds: boolean; -begin - LJsonDocument := TALJSONDocumentA.Create(aFormatSettings); - try + {loop on all nodes} + While NodeStack.Count > 0 Do begin + CurrentNode := NodeStack.Pop; + CurrentNodeIndex := integer(NodeIndexStack.Pop); + CurrentNodeStartPos := integer(NodeStartPosStack.Pop); + + with CurrentNode do + case NodeType of + ntObject: begin + if currentNode = CurrentParentNode then _WriteEndObjectNode2Buffer(CurrentNode, CurrentNodeStartPos) + else _WriteStartObjectNode2Buffer(CurrentNode, CurrentNodeIndex); + end; + ntArray: begin + if currentNode = CurrentParentNode then _WriteEndArrayNode2Buffer(CurrentNode, CurrentNodeStartPos) + else _WriteStartArrayNode2Buffer(CurrentNode, CurrentNodeIndex); + end; + ntText: _WriteTextNode2Buffer(CurrentNode, CurrentNodeIndex); + else AlJSONDocErrorA(cAlJSONInvalidNodeType); + end; + + CurrentParentNode := CurrentNode.ParentNode; + end; + + {Write the buffer} + if assigned(Stream) then _WriteBuffer2Stream(Buffer, BufferPos) + else setlength(Buffer,BufferPos); - LJsonDocument.onParseText := procedure (Sender: TObject; const Path: AnsiString; const name: AnsiString; const Args: array of const; NodeSubType: TALJSONNodeSubType) - begin - if (NodeSubType = nstBoolean) then aLst.Add(aPath + Path + aLst.NameValueSeparator + ALBoolToStrA(Args[0].VBoolean,aTrueStr,aFalseStr)) - else if (NodeSubType = nstnull) then aLst.Add(aPath + Path + aLst.NameValueSeparator + aNullStr) - else aLst.Add(aPath + Path + aLst.NameValueSeparator + ansiString(Args[0].VAnsiString)); - LContainChilds := True; - end; - - LJsonDocument.onParseStartObject := procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) - begin - LContainChilds := False; - end; - - LJsonDocument.onParseEndObject := procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) - begin - if (not LContainChilds) and (aPath + Path <> ''{Path = '' mean it's the root object}) then aLst.Add(aPath+ Path + aLst.NameValueSeparator + '{}'); - LContainChilds := True; - end; - - LJsonDocument.onParseStartArray := procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) - begin - LContainChilds := False; - end; - - LJsonDocument.onParseEndArray := procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) - begin - if not LContainChilds then aLst.Add(aPath+ Path + aLst.NameValueSeparator + '[]'); - LContainChilds := True; - end; - - LJsonDocument.LoadFromJSONString(AJsonStr, true{saxMode}); finally - LJsonDocument.Free; + ALFreeAndNil(NodeStack); + ALFreeAndNil(NodeIndexStack); + ALFreeAndNil(NodeStartPosStack); end; end; -{**************************} -Procedure ALJSONToTStringsA( - const AJsonStr: AnsiString; - const aFormatSettings: TALFormatSettingsA; - const aLst: TALStringsA; - Const aNullStr: AnsiString = 'null'; - Const aTrueStr: AnsiString = 'true'; - Const aFalseStr: AnsiString = 'false'); +{*****************************************************************************************************} +procedure TALJSONNodeA.SaveToBsonStream(const Stream: TStream; const Options: TALJSONSaveOptions = []); +var buffer: ansiString; begin - ALJSONToTStringsA( - AJsonStr, - aFormatSettings, - '', - aLst, - aNullStr, - aTrueStr, - aFalseStr); + SaveToBson(Stream, buffer, Options); end; -{**************************} -Procedure ALJSONToTStringsA( - const aJsonNode: TALJSONNodeA; - Const aPath: AnsiString; - const aLst: TALStringsA; - Const aNullStr: AnsiString = 'null'; - Const aTrueStr: AnsiString = 'true'; - Const aFalseStr: AnsiString = 'false'); -var LTmpPath: AnsiString; - I: integer; +{****************************************************************************************************} +procedure TALJSONNodeA.SaveToBsonFile(const FileName: String; const Options: TALJSONSaveOptions = []); +Var LfileStream: TfileStream; + LTmpFilename: String; begin - if aJsonNode.ChildNodes.Count > 0 then begin - for I := 0 to aJsonNode.ChildNodes.Count - 1 do begin - - if aJsonNode.NodeType = ntArray then LTmpPath := aPath + '[' + ALIntToStrA(I) + ']' - else begin - if aJsonNode.ChildNodes[I].NodeName = '' then raise Exception.Create('Nodename can not be empty'); - LTmpPath := aPath + alIfThenA(aPath <> '', '.', '') + aJsonNode.ChildNodes[I].NodeName; - end; - - case aJsonNode.ChildNodes[I].NodeType of - - ntObject: ALJSONToTStringsA( - aJsonNode.ChildNodes[I], - LTmpPath, - aLst, - aNullStr, - aTrueStr, - aFalseStr); - - ntArray: ALJSONToTStringsA( - aJsonNode.ChildNodes[I], - LTmpPath, - aLst, - aNullStr, - aTrueStr, - aFalseStr); - - ntText: begin - if (aJsonNode.ChildNodes[I].NodeSubType = nstBoolean) then aLst.Add(LTmpPath + aLst.NameValueSeparator + ALBoolToStrA(aJsonNode.ChildNodes[I].Bool,aTrueStr,aFalseStr)) - else if (aJsonNode.ChildNodes[I].NodeSubType = nstnull) then aLst.Add(LTmpPath + aLst.NameValueSeparator + aNullStr) - else aLst.Add(LTmpPath + aLst.NameValueSeparator + aJsonNode.ChildNodes[I].Text); - end; + if soProtectedSave in Options then LTmpFilename := FileName + '.~tmp' + else LTmpFilename := FileName; + try - else raise Exception.Create('Unknown NodeType'); + LfileStream := TfileStream.Create(LTmpFilename,fmCreate); + Try + SaveToBsonStream(LfileStream, Options); + finally + ALFreeAndNil(LfileStream); + end; - end; + if LTmpFilename <> FileName then begin + if TFile.Exists(FileName) then TFile.Delete(FileName); + TFile.Move(LTmpFilename, FileName); end; - end - else if (aPath <> ''{aPath = '' mean it's the root object}) then begin - if aJsonNode.NodeType = ntArray then aLst.Add(aPath + aLst.NameValueSeparator + '[]') - else if aJsonNode.NodeType = ntObject then aLst.Add(aPath + aLst.NameValueSeparator + '{}'); + + except + if (LTmpFilename <> FileName) and + (TFile.Exists(LTmpFilename)) then TFile.Delete(LTmpFilename); + raise; end; end; -{**************************} -Procedure ALJSONToTStringsA( - const aJsonNode: TALJSONNodeA; - const aLst: TALStringsA; - Const aNullStr: AnsiString = 'null'; - Const aTrueStr: AnsiString = 'true'; - Const aFalseStr: AnsiString = 'false'); +{********************************************************************************************************} +procedure TALJSONNodeA.SaveToBsonFile(const FileName: AnsiString; const Options: TALJSONSaveOptions = []); begin - ALJSONToTStringsA( - aJsonNode, - '', - aLst, - aNullStr, - aTrueStr, - aFalseStr) + SaveToBsonFile(String(FileName), Options); end; -{**************************} -procedure ALTStringsToJsonA( - const aLst: TALStringsA; - const aJsonNode: TALJSONNodeA; - Const aPath: AnsiString = ''; - Const aNameToLowerCase: boolean = false; - Const aNullStr: AnsiString = 'null'); +{***************************************************************************************************} +procedure TALJSONNodeA.SaveToBsonString(var str: AnsiString; const Options: TALJSONSaveOptions = []); +begin + SaveToBson(nil, Str, Options); +end; -var LIndex: Integer; - LNames: TALStringListA; - LLowerName: AnsiString; - LCurrJsonNode, LTmpJsonNode: TALJSONNodeA; - I, J: integer; +{*************************************************************************************************************************} +procedure TALJSONNodeA.LoadFromJSONString(const Str: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]); +Begin + Try + ParseJson(nil, Str, False{SaxMode}, nil{onParseText}, nil{onParseStartObject}, nil{onParseEndObject}, nil{onParseStartArray}, nil{onParseEndArray}, Options); + except + ChildNodes.Clear; + raise; + end; +end; -begin +{*************************************************************************************************************************} +procedure TALJSONNodeA.LoadFromJSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]); +Begin + Try + ParseJSON(Stream, '', False{SaxMode}, nil{onParseText}, nil{onParseStartObject}, nil{onParseEndObject}, nil{onParseStartArray}, nil{onParseEndArray}, Options); + except + ChildNodes.Clear; + raise; + end; +end; - // create list of the part of name, - // from "aggregated_data.properties.types[3].translations.usa" => - // aggregated_data - // properties - // types - // [3] - // translations - // usa - LNames := TALStringListA.Create; - try +{************************************************************************************************************************} +procedure TALJSONNodeA.LoadFromJSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]); +Var LfileStream: TfileStream; +Begin + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + LoadFromJSONStream(LfileStream, Options); + finally + ALFreeAndNil(LfileStream); + end; +end; - //init aNames.linebreak - LNames.LineBreak := '.'; +{****************************************************************************************************************************} +procedure TALJSONNodeA.LoadFromJSONFile(const FileName: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]); +Begin + LoadFromJSONFile(String(FileName), Options); +end; - // scroll the aLst - for I := 0 to aLst.Count - 1 do begin +{*************************************************************************************************************************} +procedure TALJSONNodeA.LoadFromBSONString(const Str: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]); +Begin + Try + ParseBSON(nil, Str, False{SaxMode}, nil{onParseText}, nil{onParseStartObject}, nil{onParseEndObject}, nil{onParseStartArray}, nil{onParseEndArray}, Options); + except + ChildNodes.Clear; + raise; + end; +end; - //if it's contain path - if (aPath = '') or - (ALPosIgnoreCaseA(aPath + '.',aLst.Names[I]) = 1) then begin +{*************************************************************************************************************************} +procedure TALJSONNodeA.LoadFromBSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]); +Begin + Try + ParseBSON(Stream, '', False{SaxMode}, nil{onParseText}, nil{onParseStartObject}, nil{onParseEndObject}, nil{onParseStartArray}, nil{onParseEndArray}, Options); + except + ChildNodes.Clear; + raise; + end; +end; - // path.aggregated_data.properties.types[3].translations.usa => - // aggregated_data - // properties - // types - // [3] - // translations - // usa - if (aPath <> '') then LNames.Text := ALStringReplaceA( - ALStringReplaceA( - aLst.Names[I], - aPath + '.', - '', - [rfIgnoreCase]), - '[', - '.[', - [rfReplaceAll]) - else LNames.Text := ALStringReplaceA( - aLst.Names[I], - '[', - '.[', - [rfReplaceAll]); +{************************************************************************************************************************} +procedure TALJSONNodeA.LoadFromBSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]); +Var LfileStream: TfileStream; +Begin + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + LoadFromBSONStream(LfileStream, Options); + finally + ALFreeAndNil(LfileStream); + end; +end; - //loop on all the name - LCurrJsonNode := aJsonNode; - for J := 0 to LNames.Count - 1 do begin +{****************************************************************************************************************************} +procedure TALJSONNodeA.LoadFromBSONFile(const FileName: AnsiString; const Options: TALJSONParseOptions = [poClearChildNodes]); +Begin + LoadFromBSONFile(String(FileName), Options); +end; - //if we are in array - if LCurrJsonNode.NodeType = ntArray then begin - if (length(LNames[J]) <= 2) or - (LNames[J][1] <> '[') or - (LNames[J][length(LNames[J])] <> ']') or - (not ALTryStrToInt(ALCopyStr(LNames[J], 2, Length(LNames[J]) - 2), LIndex)) then raise EALException.CreateFmt('Wrong path: "%s"', [aLst.Names[I]]); - while LIndex > LCurrJsonNode.ChildNodes.Count - 1 do begin - if J = LNames.Count - 1 then LCurrJsonNode.AddChild(ntText) - else if (LNames[J+1] <> '') and - (LNames[J+1][1] = '[') then LCurrJsonNode.AddChild(ntarray) - else LCurrJsonNode.AddChild(ntObject); - end; - LCurrJsonNode := LCurrJsonNode.ChildNodes[LIndex]; - end +{*************************************} +procedure TALJSONNodeA.ParseJSONString( + const Str: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +Begin + ParseJson(nil, Str, true{SaxMode}, onParseText, onParseStartObject, onParseEndObject, onParseStartArray, onParseEndArray, Options); +end; - //if we are not in array - else begin - LLowerName := alifThenA(aNameToLowerCase, allowercase(LNames[J]), LNames[J]); - LTmpJsonNode := LCurrJsonNode.ChildNodes.FindNode(LLowerName); - if not assigned(LTmpJsonNode) then begin - if J = LNames.Count - 1 then LCurrJsonNode := LCurrJsonNode.AddChild(LLowerName, ntText) - else if (LNames[J+1] <> '') and - (LNames[J+1][1] = '[') then LCurrJsonNode := LCurrJsonNode.AddChild(LLowerName, ntarray) - else LCurrJsonNode := LCurrJsonNode.AddChild(LLowerName, ntObject); - end - else LCurrJsonNode := LTmpJsonNode; - end; +{*************************************} +procedure TALJSONNodeA.ParseJSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +Begin + ParseJSON(Stream, '', true{SaxMode}, onParseText, onParseStartObject, onParseEndObject, onParseStartArray, onParseEndArray, Options); +end; - //set the value - if J = LNames.Count - 1 then begin - if aLst.ValueFromIndex[I] = aNullStr then LCurrJsonNode.Null := true - else LCurrJsonNode.Text := aLst.ValueFromIndex[I]; - end; +{***********************************} +procedure TALJSONNodeA.ParseJSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +Var LfileStream: TfileStream; +Begin + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + ParseJSONStream(LfileStream, onParseText, onParseStartObject, onParseEndObject, onParseStartArray, onParseEndArray, Options); + finally + ALFreeAndNil(LfileStream); + end; +end; - end; +{***********************************} +procedure TALJSONNodeA.ParseJSONFile( + const FileName: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +Begin + ParseJSONFile(String(FileName), onParseText, onParseStartObject, onParseEndObject, onParseStartArray, onParseEndArray, Options); +end; - end; +{*************************************} +procedure TALJSONNodeA.ParseBSONString( + const Str: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +Begin + ParseBSON(nil, Str, true{SaxMode}, onParseText, onParseStartObject, onParseEndObject, onParseStartArray, onParseEndArray, Options); +end; - end; +{*************************************} +procedure TALJSONNodeA.ParseBSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +Begin + ParseBSON(Stream, '', true{SaxMode}, onParseText, onParseStartObject, onParseEndObject, onParseStartArray, onParseEndArray, Options); +end; +{***********************************} +procedure TALJSONNodeA.ParseBSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +Var LfileStream: TfileStream; +Begin + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + ParseBSONStream(LfileStream, onParseText, onParseStartObject, onParseEndObject, onParseStartArray, onParseEndArray, Options); finally - LNames.Free; + ALFreeAndNil(LfileStream); end; +end; +{***********************************} +procedure TALJSONNodeA.ParseBSONFile( + const FileName: AnsiString; + const onParseText: TAlJSONParseTextEventA; + const onParseStartObject: TAlJSONParseObjectEventA; + const onParseEndObject: TAlJSONParseObjectEventA; + const onParseStartArray: TAlJSONParseArrayEventA; + const onParseEndArray: TAlJSONParseArrayEventA; + const Options: TALJSONParseOptions = []); +Begin + ParseBSONFile(String(FileName), onParseText, onParseStartObject, onParseEndObject, onParseStartArray, onParseEndArray, Options); end; -{*********************} -Procedure ALJSONToXMLA( - const aJSONNode: TALJSONNodeA; - const aXMLNode: TALXmlNode; - const aXMLElementNameForJSONArrayEntries: TALStringsA; // JSONArrayNodeName=XMLElementName - const aDefaultXMLElementNameForJSONArrayEntries: AnsiString = 'rec'); -var LNodeName: AnsiString; - I: integer; +{*********************************************************************} +constructor TALJSONObjectNodeA.Create(const NodeName: AnsiString = ''); begin - for I := 0 to aJSONNode.ChildNodes.Count - 1 do begin - - if (aJSONNode.NodeType = ntarray) then begin - if assigned(aXMLElementNameForJSONArrayEntries) then LNodeName := aXMLElementNameForJSONArrayEntries.Values[aJSONNode.NodeName] - else LNodeName := ''; - if LNodeName = '' then LNodeName := aDefaultXMLElementNameForJSONArrayEntries; - end - else LNodeName := aJSONNode.ChildNodes[I].NodeName; - - if aJSONNode.ChildNodes[I].NodeType = ntText then aXMLNode.AddChild(LNodeName).text := aJSONNode.ChildNodes[I].text - else ALJSONToXMLA(aJSONNode.ChildNodes[I], aXMLNode.AddChild(LNodeName)); - - end; + inherited create(NodeName); + FChildNodes := nil; end; -{*********************} -Procedure ALJSONToXMLA( - const aJSONNode: TALJSONNodeA; - const aXMLNode: TALXmlNode; - const aDefaultXMLElementNameForJSONArrayEntries: AnsiString = 'rec'); +{************************************} +destructor TALJSONObjectNodeA.Destroy; begin - ALJSONToXMLA( - aJSONNode, - aXMLNode, - nil, - aDefaultXMLElementNameForJSONArrayEntries); + If assigned(FChildNodes) then FreeAndNil(FchildNodes); + inherited; end; -{*********************************************************************************} -function ALJsonEncodeFloatWithNodeSubTypeHelperA(const aValue: double): AnsiString; +{**********************************************************} +function TALJSONObjectNodeA.GetChildNodes: TALJSONNodeListA; begin - result := ALFloatToStrA(aValue, ALDefaultFormatSettingsA); + if not Assigned(FChildNodes) then SetChildNodes(CreateChildList); + Result := FChildNodes; end; -{************************************************************************************} -function ALJsonEncodeTextWithNodeSubTypeHelperA(const aValue: AnsiString): AnsiString; +{************************************************************************} +procedure TALJSONObjectNodeA.SetChildNodes(const Value: TALJSONNodeListA); begin - result := '"'+ALJavascriptEncode(aValue)+'"'; + If Assigned(FChildNodes) then FreeAndNil(FchildNodes); + FChildNodes := Value; end; -{**************************************************************************************} -function ALJsonEncodeBinaryWithNodeSubTypeHelperA(const aValue: AnsiString): AnsiString; +{*******************************************************} +function TALJSONObjectNodeA.GetNodeType: TALJSONNodeType; begin - result := 'BinData(0, "' + ALBase64EncodeString(aValue) + '")'; + Result := NtObject; end; -{****************************************************************************************} -function ALJsonEncodeObjectIDWithNodeSubTypeHelperA(const aValue: AnsiString): AnsiString; +{*************************************************************} +function TALJSONObjectNodeA.GetNodeSubType: TALJSONNodeSubType; begin - result := 'ObjectId("'+ALBinToHexA(aValue)+'")'; + Result := NstObject; end; -{************************************************************************************} -function ALJsonEncodeBooleanWithNodeSubTypeHelperA(const aValue: Boolean): AnsiString; +{********************************************} +{Get Childnode without create it if not exist} +function TALJSONObjectNodeA.InternalGetChildNodes: TALJSONNodeListA; begin - if aValue then result := 'true' - else result := 'false'; + Result := FChildNodes; end; -{***************************************************************************************} -function ALJsonEncodeDateTimeWithNodeSubTypeHelperA(const aValue: TdateTime): AnsiString; +{********************************************************************} +constructor TALJSONArrayNodeA.Create(const NodeName: AnsiString = ''); begin - result := ALFormatDateTimeA('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', aValue, ALDefaultFormatSettingsA); + inherited create(NodeName); + FChildNodes := nil; end; -{******************************************************************************************} -function ALJsonEncodeJavascriptWithNodeSubTypeHelperA(const aValue: AnsiString): AnsiString; +{***********************************} +destructor TALJSONArrayNodeA.Destroy; begin - result := aValue; + If assigned(FChildNodes) then FreeAndNil(FchildNodes); + inherited; end; -{********************************************************************************} -function ALJsonEncodeInt64WithNodeSubTypeHelperA(const aValue: int64): AnsiString; +{*********************************************************} +function TALJSONArrayNodeA.GetChildNodes: TALJSONNodeListA; begin - result := 'NumberLong(' + ALIntToStrA(aValue) + ')'; + if not Assigned(FChildNodes) then SetChildNodes(CreateChildList); + Result := FChildNodes; end; -{********************************************************************************} -function ALJsonEncodeInt32WithNodeSubTypeHelperA(const aValue: int32): AnsiString; +{***********************************************************************} +procedure TALJSONArrayNodeA.SetChildNodes(const Value: TALJSONNodeListA); begin - result := 'NumberInt(' + ALIntToStrA(aValue) + ')'; + If Assigned(FChildNodes) then FreeAndNil(FchildNodes); + FChildNodes := Value; end; -{**********************************************************} -function ALJsonEncodeNullWithNodeSubTypeHelperA: AnsiString; +{******************************************************} +function TALJSONArrayNodeA.GetNodeType: TALJSONNodeType; begin - result := 'null'; + Result := NtArray; end; -{******************************************} -function ALJsonEncodeWithNodeSubTypeHelperA( - const aValue: AnsiString; - const aNodeSubType: TALJSONNodeSubType; - const aFormatSettings: TALFormatSettingsA): AnsiString; +{************************************************************} +function TALJSONArrayNodeA.GetNodeSubType: TALJSONNodeSubType; begin - case aNodeSubType of - nstFloat: begin - if @aFormatSettings <> @ALDefaultFormatSettingsA then result := ALJsonEncodeFloatWithNodeSubTypeHelperA(ALStrToFloat(aValue, aFormatSettings)) - else result := aValue; - end; - nstText: result := ALJsonEncodeTextWithNodeSubTypeHelperA(aValue); - nstBinary: result := ALJsonEncodeBinaryWithNodeSubTypeHelperA(aValue); - nstObjectID: result := ALJsonEncodeObjectIDWithNodeSubTypeHelperA(aValue); - nstBoolean: result := ALJsonEncodeBooleanWithNodeSubTypeHelperA(ALStrToBool(aValue)); - nstDateTime: begin - if aValue = 'NOW' then result := ALJsonEncodeDateTimeWithNodeSubTypeHelperA(ALUtcNow) - else result := ALJsonEncodeDateTimeWithNodeSubTypeHelperA(ALStrToDateTime(aValue, aFormatSettings)); - end; - nstJavascript: result := ALJsonEncodeJavascriptWithNodeSubTypeHelperA(aValue); - nstInt32: result := ALJsonEncodeInt32WithNodeSubTypeHelperA(ALstrToInt(aValue)); - nstInt64: result := ALJsonEncodeInt64WithNodeSubTypeHelperA(ALstrToInt64(aValue)); - nstNull: result := ALJsonEncodeNullWithNodeSubTypeHelperA; - nstObject: raise Exception.Create('Unsupported Node SubType'); - nstArray: raise Exception.Create('Unsupported Node SubType'); - nstRegEx: raise Exception.Create('Unsupported Node SubType'); - nstTimestamp: raise Exception.Create('Unsupported Node SubType'); - else raise Exception.Create('Unknown Node SubType'); - end; + Result := NstArray; end; {********************************************} -Function ALFindJsonNodeByInt32ChildNodeValueW( - const JsonNode:TALJSONNodeW; - Const ChildNodeName: String; - Const ChildNodeValue : Int32; - Const Recurse: Boolean = False): TALJSONNodeW; -var I, J : integer; -Begin - result := nil; - if not (JsonNode.NodeType in [ntObject, ntArray]) then Exit; - for I := 0 to JsonNode.ChildNodes.Count - 1 do begin - for J := 0 to JsonNode.ChildNodes[I].ChildNodes.Count - 1 do begin - If (JsonNode.ChildNodes[I].ChildNodes[j].NodeType = nttext) and - (JsonNode.ChildNodes[I].ChildNodes[j].NodesubType = nstint32) and - (ALSameTextW(JsonNode.ChildNodes[I].ChildNodes[j].NodeName, ChildNodeName)) and - (JsonNode.ChildNodes[I].ChildNodes[j].int32 = ChildNodeValue) then begin - result := JsonNode.ChildNodes[I]; - exit; - end; - end; - if Recurse then begin - result := ALFindJsonNodeByInt32ChildNodeValueW( - JsonNode.ChildNodes[I], - ChildNodeName, - ChildNodeValue, - Recurse); - if assigned(Result) then break; - end; - end; +{Get Childnode without create it if not exist} +function TALJSONArrayNodeA.InternalGetChildNodes: TALJSONNodeListA; +begin + Result := FChildNodes; end; -{*******************************************} -Function ALFindJsonNodeByTextChildNodeValueW( - const JsonNode:TALJSONNodeW; - Const ChildNodeName: String; - Const ChildNodeValue : String; - Const Recurse: Boolean = False): TALJSONNodeW; -var I, J : integer; -Begin - result := nil; - if not (JsonNode.NodeType in [ntObject, ntArray]) then Exit; - for I := 0 to JsonNode.ChildNodes.Count - 1 do begin - for J := 0 to JsonNode.ChildNodes[I].ChildNodes.Count - 1 do begin - If (JsonNode.ChildNodes[I].ChildNodes[j].NodeType = nttext) and - (JsonNode.ChildNodes[I].ChildNodes[j].NodesubType = nstText) and - (ALSameTextW(JsonNode.ChildNodes[I].ChildNodes[j].NodeName, ChildNodeName)) and - (JsonNode.ChildNodes[I].ChildNodes[j].text = ChildNodeValue) then begin - result := JsonNode.ChildNodes[I]; - exit; - end; - end; - if Recurse then begin - result := ALFindJsonNodeByTextChildNodeValueW( - JsonNode.ChildNodes[I], - ChildNodeName, - ChildNodeValue, - Recurse); - if assigned(Result) then break; - end; - end; +{*******************************************************************} +constructor TALJSONTextNodeA.Create(const NodeName: AnsiString = ''); +begin + inherited create(NodeName); + fNodeSubType := nstText; + fRawNodeValueStr := ''; + FRawNodeValueInt64 := 0; + fRawNodeValueDefined := [nvStr]; end; -{*********************} -{$ZEROBASEDSTRINGS OFF} -function ALJSONTryStrToRegExW(const S: String; out RegEx: String; out RegExOptions: TALPerlRegExOptions): boolean; -var P1: integer; - I: integer; +{*****************************************************} +function TALJSONTextNodeA.GetNodeType: TALJSONNodeType; begin - - // regular expression in JSON must look like: /pattern/options - // list of valid options is: - // 'i' for case insensitive matching, - // 'm' for multiline matching, - // 'x' for verbose mode, - // 'l' to make \w, \W, etc. locale dependent, - // 's' for dotall mode ('.' matches everything), - // 'u' to make \w, \W, etc. match unicode. - result := false; - - // check that first character is / - if (S <> '') and (S[1] = '/') then begin - - P1 := ALLastDelimiterW('/', S); - if P1 <> 1 then begin - - //init Value - RegEx := ALCopyStr(S, 2, P1 - 2); - RegExOptions := []; - - // loop on all the options characters - // to check if they are allowed. - for I := P1 + 1 to Length(S) do - case s[I] of - 'i': RegExOptions := RegExOptions + [preCaseLess]; - 'm': RegExOptions := RegExOptions + [preMultiLine]; - 'x': RegExOptions := RegExOptions + [preExtended]; - 'l':; - 's': RegExOptions := RegExOptions + [preSingleLine]; - 'u':; - else exit; - end; - - //set the result to true - result := true; - - // check if it's compiling - //aRegEx := TALPerlRegEx.Create; - //try - // aRegEx.RegEx := Value.Expression; - // result := aRegEx.Compile(false{RaiseException}); - //finally - // aRegEx.Free; - //end; - - end; - - end; - + Result := NtText; end; -{$IF defined(ALZeroBasedStringsON)} - {$ZEROBASEDSTRINGS ON} -{$IFEND} -{*********************} -{$ZEROBASEDSTRINGS OFF} -{$WARN WIDECHAR_REDUCED OFF} -function ALJSONTryStrToBinaryW(const S: String; out Data: String; out Subtype: byte): boolean; -var LInt: integer; - Ln: integer; - P1, P2: integer; +{***********************************************************} +function TALJSONTextNodeA.GetNodeSubType: TALJSONNodeSubType; begin + Result := fNodeSubType; +end; - // s must look like - // BinData(0, "JliB6gIMRuSphAD2KmhzgQ==") - // BinData ( 0 , "JliB6gIMRuSphAD2KmhzgQ==" ) - result := false; - Ln := length(s); - P1 := 1; - - while (P1 <= ln) and (s[P1] in [#9, ' ']) do inc(P1); +{****************************************************} +function TALJSONTextNodeA.GetNodeValueStr: ansiString; +begin + if nvStr in fRawNodeValueDefined then result := fRawNodeValueStr + else begin - if (P1 + 6 > ln) or - (s[P1] <> 'B') or - (s[P1+1] <> 'i') or - (s[P1+2] <> 'n') or - (s[P1+3] <> 'D') or - (s[P1+4] <> 'a') or - (s[P1+5] <> 't') or - (s[P1+6] <> 'a') then exit; // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") - // ^ + if not (nvInt64 in fRawNodeValueDefined) then AlJSONDocErrorA(CALJsonOperationError,GetNodeType); - P1 := p1 + 7{Length('BinData')}; // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") - // ^ - while (P1 <= ln) and (s[P1] in [#9, ' ']) do inc(P1); - if (P1 > ln) or (s[P1] <> '(') then exit; // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") - // ^P1 + case fNodeSubType of + nstFloat: ALFloatToStrA(GetFloat, fRawNodeValueStr, ALDefaultFormatSettingsA); + //nstText: can not be retrieve from int64 + //nstObject: can not be retrieve from int64 + //nstArray: can not be retrieve from int64 + //nstBinary: only the binarysubtype is store in int64 + //nstObjectID: can not be retrieve from int64 + nstBoolean: ALBoolToStrA(fRawNodeValueStr, getBool, 'true', 'false'); + nstDateTime: ALDateTimeToStrA(GetDateTime, fRawNodeValueStr, ALDefaultFormatSettingsA); + nstNull: fRawNodeValueStr := 'null'; + //nstRegEx: only the regex options is store in the int64 + //nstJavascript: can not be retrieve from int64 + nstInt32: ALIntToStrA(GetInt32, fRawNodeValueStr); + nstTimestamp: ALFormatA('Timestamp(%u, %u)', [GetTimestamp.W1,GetTimestamp.W2], fRawNodeValueStr); + nstInt64: ALIntToStrA(GetInt64, fRawNodeValueStr); + else AlJSONDocErrorA(CALJsonOperationError,GetNodeType); + end; - inc(P1); // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") - // ^P1 - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") - // ^P1 - if (P1 > ln) then exit; + fRawNodeValueDefined := fRawNodeValueDefined + [nvStr]; + result := fRawNodeValueStr; - P2 := P1; - while (P2 <= ln) and (S[P2] in ['0'..'9']) do inc(P2); // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") - // ^P2 - if P2 > ln then exit; - if not ALTryStrToInt(ALCopyStr(S,P1,P2-P1), LInt) then Exit; - subtype := LInt; + end; +end; - p1 := P2; - while (P1 <= ln) and (s[P1] in [#9, ' ']) do inc(P1); - if (P1 > ln) or (s[P1] <> ',') then exit; // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") - // ^P2 +{*************************************************} +function TALJSONTextNodeA.GetNodeValueInt64: int64; +var LDouble: Double; + LBool: boolean; + LDateTime: TdateTime; + LInt32: system.int32; + LTimestamp: TALBSONTimestamp; +begin + if nvInt64 in fRawNodeValueDefined then result := fRawNodeValueInt64 + else begin - inc(P1); // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") - // ^P1 - while (P1 <= ln) and (s[P1] in [#9, ' ']) do inc(P1); - if (P1 > ln) or (not (s[P1] in ['"',''''])) then exit; // BinData(0, "JliB6gIMRuSphAD2KmhzgQ==") - // ^P1 + if not (nvStr in fRawNodeValueDefined) then AlJSONDocErrorA(CALJsonOperationError,GetNodeType); - P2 := length(s); - while (P2 > p1) and (s[P2] in [#9, ' ']) do dec(P2); - if (P2 <= p1) or (s[P2] <> ')') then exit; // BinData(0, "JliB6gIMRuSphAD2KmhzgQ==") - // ^P2 + case fNodeSubType of + nstFloat: begin + IF not ALTryStrToFloat(fRawNodeValueStr, LDouble, ALDefaultFormatSettingsA) then AlJSONDocErrorA('%s is not a valid Float', [fRawNodeValueStr]); + fRawNodeValueInt64 := Pint64(@LDouble)^; + end; + //nstText: can not be retrieve from int64 + //nstObject: can not be retrieve from int64 + //nstArray: can not be retrieve from int64 + //nstBinary: only the binarysubtype is store in int64 + //nstObjectID: can not be retrieve from int64 + nstBoolean: begin + IF not ALTryStrToBool(fRawNodeValueStr, LBool) then AlJSONDocErrorA('%s is not a valid Boolean', [fRawNodeValueStr]); + fRawNodeValueInt64 := ALBoolToInt(LBool); + end; + nstDateTime: begin + IF not ALTryStrToDateTime(fRawNodeValueStr, LDateTime, ALDefaultFormatSettingsA) then AlJSONDocErrorA('%s is not a valid Datetime', [fRawNodeValueStr]); + fRawNodeValueInt64 := Pint64(@LDateTime)^; + end; + nstNull: begin + fRawNodeValueInt64 := 0; + end; + //nstRegEx: only the regex options is store in the int64 + //nstJavascript: can not be retrieve from int64 + nstInt32: begin + IF not ALTryStrToInt(fRawNodeValueStr, LInt32) then AlJSONDocErrorA('%s is not a valid Int32', [fRawNodeValueStr]); + fRawNodeValueInt64 := LInt32; + end; + nstTimestamp: begin + IF not ALJSONTryStrToTimestampA(fRawNodeValueStr, LTimestamp) then AlJSONDocErrorA('%s is not a valid Timestamp', [fRawNodeValueStr]); + fRawNodeValueInt64 := LTimestamp.I64; + end; + nstInt64: begin + IF not ALTryStrToInt64(fRawNodeValueStr, fRawNodeValueInt64) then AlJSONDocErrorA('%s is not a valid Int64', [fRawNodeValueStr]); + end; + else AlJSONDocErrorA(CALJsonOperationError,GetNodeType); + end; - dec(p2); - if (P2 <= p1) then exit; - while (P2 > p1) and (s[P2] in [#9, ' ']) do dec(P2); - if (P2 <= p1) or (s[P2] <> s[P1]) then exit; // BinData(0, "JliB6gIMRuSphAD2KmhzgQ==") - // ^P2 + fRawNodeValueDefined := fRawNodeValueDefined + [nvInt64]; + result := fRawNodeValueInt64; - inc(p1); - Data := ALCopyStr(s, P1, P2-P1); // notmally i would like to do ALBase64DecodeString() - // and return in data the byte string but this is not possible - // because the source byte array is probably not a multiple of 2 - // and unicode string is obligatory a multiple of 2 + end; +end; - // set the result - result := true; +{******************************************************************************************************} +procedure TALJSONTextNodeA.SetNodeValue(const Value: AnsiString; const NodeSubType: TALJSONNodeSubType); +begin + fNodeSubType := NodeSubType; + fRawNodeValueStr := Value; + fRawNodeValueDefined := [nvStr]; +end; +{*************************************************************************************************} +procedure TALJSONTextNodeA.SetNodeValue(const Value: int64; const NodeSubType: TALJSONNodeSubType); +begin + fNodeSubType := NodeSubType; + fRawNodeValueInt64 := Value; + if (NodeSubType in [nstBinary, nstRegEx]) then fRawNodeValueDefined := fRawNodeValueDefined + [nvInt64] // keep the fNodeValueStr + else fRawNodeValueDefined := [nvInt64]; end; -{$WARN WIDECHAR_REDUCED ON} -{$IF defined(ALZeroBasedStringsON)} - {$ZEROBASEDSTRINGS ON} -{$IFEND} -{*********************} -{$ZEROBASEDSTRINGS OFF} -{$WARN WIDECHAR_REDUCED OFF} -function ALJSONTryStrToDateTimeW(const S: String; out Value: TDateTime): Boolean; -var LQuoteChar: Char; - LTmpStr: String; - LTmpLn: integer; - P1, P2: integer; - Ln: integer; +{**********************************************************************************************************************************} +procedure TALJSONTextNodeA.SetNodeValue(const StrValue: AnsiString; const Int64Value: int64; const NodeSubType: TALJSONNodeSubType); begin + fNodeSubType := NodeSubType; + fRawNodeValueStr := StrValue; + fRawNodeValueInt64 := Int64Value; + fRawNodeValueDefined := [nvStr, nvInt64]; +end; - // s must look like - // new Date('yyyy-mm-ddThh:nn:ss.zzzZ') - // Date('yyyy-mm-ddThh:nn:ss.zzzZ') - // new ISODate('yyyy-mm-ddThh:nn:ss.zzzZ') - // ISODate('yyyy-mm-ddThh:nn:ss.zzzZ') - result := false; - Ln := length(s); - if ALPosW('new', s) = 1 then P1 := 4{length('new') + 1} // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) - // ^P1 - else P1 := 1;// Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) - // ^P1 - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 <= ln - 3) and - (S[P1] = 'D') and - (S[P1+1] = 'a') and - (S[P1+2] = 't') and - (S[P1+3] = 'e') then inc(p1, 4) // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) - // ^P1 - else if (P1 <= ln - 6) and - (S[P1] = 'I') and - (S[P1+1] = 'S') and - (S[P1+2] = 'O') and - (S[P1+3] = 'D') and - (S[P1+4] = 'a') and - (S[P1+5] = 't') and - (S[P1+6] = 'e') then inc(p1, 7) // ISODate ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) - // ^P1 - else exit; - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 > ln) or (S[P1] <> '(') then exit; // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) - // ^P1 - inc(P1); // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) - // ^P1 - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 > ln) or (not (S[P1] in ['''','"'])) then exit; // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) - // ^P1 - LQuoteChar := S[P1]; // " - inc(p1); // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) - // ^P1 - P2 := P1; - while (P1 <= ln) and (S[P1] <> LQuoteChar) do inc(P1); - if (P1 > ln) then exit; // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) - // ^P1 - dec(P1); - if S[P1] <> 'Z' then exit; - LTmpStr := ALCopyStr(S,P2,P1-P2); // yyyy-mm-ddThh:nn:ss.zzz +{*******************************************************} +constructor TALJSONNodeListA.Create(Owner: TALJSONNodeA); +begin + FList:= nil; + FCount:= 0; + FCapacity := 0; + FOwner := Owner; + FSorted := False; + FDuplicates := dupAccept; + SetSorted(False); +end; - P2 := 1; - LTmpLn := length(LTmpStr); - while (P2 <= LTmpLn) and (LTmpStr[P2] <> 'T') do inc(P2); - if P2 > LTmpLn then exit; - LTmpStr[P2] := ' '; // yyyy-mm-dd hh:nn:ss.zzz +{**********************************} +destructor TALJSONNodeListA.Destroy; +begin + Clear; + inherited; +end; - result := ALTryStrToDateTime(LTmpStr, Value, ALJsonISODateFormatSettingsW); - if not result then exit; +{***********************************************************************************} +{Locates the index for a node name in a sorted list and indicates whether a node name + with that value already exists in the list. Use Find to obtain the index in a + sorted list where the node name S should be added. If the node name S, or a node + name that differs from S only in case, already exists in the list, Find returns true. + If the list does not contain a node name that matches S, Find returns false. + The index where S should go is returned in the Index parameter. + The value of Index is zero-based, where the first node name has the index 0, the + second node name has the index 1, and so on. + Note: Only use Find with sorted lists. For unsorted lists, use the IndexOf method instead. + Tip: If the node name string is not found (thus return value of Find is False) then Index + is set to the index of the first node name in the list that sorts immediately before + or after S.} +function TALJSONNodeListA.Find(const NodeName: AnsiString; var Index: Integer): Boolean; +var + L, H, I, C: Integer; +begin + Result := False; + L := 0; + H := FCount - 1; + while L <= H do + begin + I := (L + H) shr 1; + C := CompareNodeNames(FList[I].NodeName, NodeName); + if C < 0 then L := I + 1 else + begin + H := I - 1; + if C = 0 then + begin + Result := True; + if Duplicates <> dupAccept then L := I; + end; + end; + end; + Index := L; +end; - inc(p1,2); // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) - // ^P1 - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 <> ln) or (S[P1] <> ')') then begin - result := false; - exit; +{*************************************} +{Returns the index of a specified node. + Call IndexOf to locate a node in the list. + *Node is the object node to locate. + IndexOf returns the index of the specified node, where 0 is the index of the first node, 1 is the + index of the second node, and so on. If the specified node is not in the list, IndexOf returns -1.} +function TALJSONNodeListA.IndexOf(const Node: TALJSONNodeA; const Direction: TDirection = TDirection.FromBeginning): Integer; +begin + if Direction = TDirection.FromBeginning then begin + for Result := 0 to Count - 1 do + if FList[Result] = Node then Exit; + end + else begin + for Result := Count - 1 downto 0 do + if FList[Result] = Node then Exit; end; - + Result := -1; end; -{$WARN WIDECHAR_REDUCED ON} -{$IF defined(ALZeroBasedStringsON)} - {$ZEROBASEDSTRINGS ON} -{$IFEND} -{*********************} -{$ZEROBASEDSTRINGS OFF} -{$WARN WIDECHAR_REDUCED OFF} -// ObjectId is a 12-byte BSON type, constructed using: -// a 4-byte value representing the seconds since the Unix epoch, -// a 3-byte machine identifier, -// a 2-byte process id, and -// a 3-byte counter, starting with a random value. -function ALJSONTryStrToObjectIDW(const S: String; out Value: String): Boolean; -var LBinValue: Tbytes; - LQuoteChar: Char; - P1: integer; - Ln: integer; +{*************************************} +{Returns the index of a specified node. + Call IndexOf to locate a node in the list. + *Name is the NodeName property of the node to locate. + IndexOf returns the index of the specified node, where 0 is the index of the first node, 1 is the + index of the second node, and so on. If the specified node is not in the list, IndexOf returns -1.} +function TALJSONNodeListA.IndexOf(const Name: AnsiString; const Direction: TDirection = TDirection.FromBeginning): Integer; begin - - // s must look like - // ObjectId ( "507f1f77bcf86cd799439011" ) - result := false; - if ALPosW('ObjectId', S) <> 1 then exit; - Ln := length(s); - P1 := 9{length('ObjectId') + 1}; // ObjectId ( "507f1f77bcf86cd799439011" ) - // ^P1 - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 > ln) or (S[P1] <> '(') then exit; // ObjectId ( "507f1f77bcf86cd799439011" ) - // ^P1 - inc(p1); // ObjectId ( "507f1f77bcf86cd799439011" ) - // ^P1 - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 > ln) or (not (S[P1] in ['''','"'])) then exit; // ObjectId ( "507f1f77bcf86cd799439011" ) - // ^P1 - LQuoteChar := S[P1]; // " - inc(p1); // ObjectId ( "507f1f77bcf86cd799439011" ) - // ^P1 - if (P1 + 23{(length(aObjectIDhex)) - 1} > ln) then exit; - Value := ALCopyStr(S,P1,24{length(aObjectIDhex)}); // 507f1f77bcf86cd799439011 - inc(P1, 24{length(aObjectIDhex)}); // ObjectId ( "507f1f77bcf86cd799439011" ) - // ^P1 - if (P1 > ln) or (S[P1] <> LQuoteChar) then exit; // ObjectId ( "507f1f77bcf86cd799439011" ) - // ^P1 - inc(p1); // ObjectId ( "507f1f77bcf86cd799439011" ) - // ^P1 - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 <> ln) or (S[P1] <> ')') then exit; // ObjectId ( "507f1f77bcf86cd799439011" ) - // ^P1 - //check that 507f1f77bcf86cd799439011 is a good hex value - result := ALTryHexToBin(Value, LBinValue) and - (length(LBinValue) = 12); - + if not Sorted then begin + if Direction = TDirection.FromBeginning then begin + for Result := 0 to Count - 1 do + if FList[Result].NodeName = Name then Exit; + end + else begin + for Result := Count - 1 downto 0 do + if FList[Result].NodeName = Name then Exit; + end; + Result := -1; + end + else if not Find(Name, Result) then Result := -1; end; -{$WARN WIDECHAR_REDUCED ON} -{$IF defined(ALZeroBasedStringsON)} - {$ZEROBASEDSTRINGS ON} -{$IFEND} -{*********************} -{$ZEROBASEDSTRINGS OFF} -{$WARN WIDECHAR_REDUCED OFF} -function ALJSONTryStrToTimestampW(const S: String; out Value: TALBSONTimestamp): Boolean; -var P1, P2: integer; - LArgs: String; - LArg1: integer; - LArg2: integer; - Ln: integer; +{*******************************************************************************************************************************} +function TALJSONNodeListA.IndexOfValue(const Value: ansiString; const Direction: TDirection = TDirection.FromBeginning): Integer; begin + if Direction = TDirection.FromBeginning then begin + for Result := 0 to Count - 1 do + if (FList[Result].Text = Value) then Exit; + end + else begin + for Result := Count - 1 downto 0 do + if (FList[Result].Text = Value) then Exit; + end; + Result := -1; +end; - // s must look like - // Timestamp(0, 0) - result := false; - if ALPosW('Timestamp', S) <> 1 then Exit; - Ln := length(s); - P1 := 10{Length('Timestamp') + 1}; // Timestamp(0, 0) - // ^ - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 > ln) or (S[P1] <> '(') then exit; // Timestamp(0, 0) - // ^P1 - P2 := ALPosW(')', S, P1); - if P2 <> ln then exit; // Timestamp(0, 0) - // ^P2 - LArgs := ALCopyStr(S, P1+1, P2 - P1-1); // 0, 0 - - // take arguments of function Timestamp - P1 := ALPosW(',', LArgs); - if not ALTryStrToInt(ALTrim(ALCopyStr(LArgs, 1, P1 - 1)), LArg1) then Exit; - if not ALTryStrToInt(ALTrim(ALCopyStr(LArgs, P1 + 1, maxint)), LArg2) then Exit; +{****************************************************************************************************************************} +function TALJSONNodeListA.IndexOfValue(const Value: integer; const Direction: TDirection = TDirection.FromBeginning): Integer; +begin + if Direction = TDirection.FromBeginning then begin + for Result := 0 to Count - 1 do + if (FList[Result].int32 = Value) then Exit; + end + else begin + for Result := Count - 1 downto 0 do + if (FList[Result].int32 = Value) then Exit; + end; + Result := -1; +end; - // build result - result := true; - Value.W1 := LArg1; // higher 4 bytes - increment - Value.W2 := LArg2; // lower 4 bytes - timestamp +{**************************************************************************************************************************} +function TALJSONNodeListA.IndexOfValue(const Value: int64; const Direction: TDirection = TDirection.FromBeginning): Integer; +begin + if Direction = TDirection.FromBeginning then begin + for Result := 0 to Count - 1 do + if (FList[Result].int64 = Value) then Exit; + end + else begin + for Result := Count - 1 downto 0 do + if (FList[Result].int64 = Value) then Exit; + end; + Result := -1; +end; +{***************************************************************************************************************************} +function TALJSONNodeListA.IndexOfValue(const Value: Double; const Direction: TDirection = TDirection.FromBeginning): Integer; +begin + if Direction = TDirection.FromBeginning then begin + for Result := 0 to Count - 1 do + if (FList[Result].float = Value) then Exit; + end + else begin + for Result := Count - 1 downto 0 do + if (FList[Result].float = Value) then Exit; + end; + Result := -1; end; -{$WARN WIDECHAR_REDUCED ON} -{$IF defined(ALZeroBasedStringsON)} - {$ZEROBASEDSTRINGS ON} -{$IFEND} -{*********************} -{$ZEROBASEDSTRINGS OFF} -{$WARN WIDECHAR_REDUCED OFF} -function ALJSONTryStrToInt32W(const S: String; out Value: integer): Boolean; -var LTmpStr: String; - LQuoteChar: Char; - P1, P2: integer; - Ln: integer; +{******************************************************************************************************************************} +function TALJSONNodeListA.IndexOfValue(const Value: TDateTime; const Direction: TDirection = TDirection.FromBeginning): Integer; begin + if Direction = TDirection.FromBeginning then begin + for Result := 0 to Count - 1 do + if (FList[Result].DateTime = Value) then Exit; + end + else begin + for Result := Count - 1 downto 0 do + if (FList[Result].DateTime = Value) then Exit; + end; + Result := -1; +end; - // s must look like - // NumberInt ( "12391293" ) - // NumberInt ( 12391293 ) - // 12391293 - result := ALTryStrToInt(S, Value); - if result then exit; - if ALPosW('NumberInt', S) <> 1 then exit; - Ln := length(s); - P1 := 10{length('NumberInt') + 1}; // NumberInt ( "12391293" ) - // ^P1 - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 > ln) or (S[P1] <> '(') then exit; // NumberInt ( "12391293" ) - // ^P1 - inc(p1); // NumberInt ( "12391293" ) - // ^P1 - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 > ln) then exit - else if (not (S[P1] in ['''','"'])) then begin // NumberInt ( 12391293 ) - // ^P1 - P2 := P1+1; - while (P2 <= ln) and (S[P2] in ['0'..'9']) do inc(P2); // NumberInt ( 12391293 ) - // ^P2 - if P2 > ln then exit; - LTmpStr := ALCopyStr(S,P1,P2-P1); // 12391293 - P1 := P2; // NumberInt ( 12391293 ) - // ^P2 +{**************************************} +{Returns a specified node from the list. + Call FindNode to access a particular node in the list. + *NodeName is the node to access. It specifies the NodeName property of the desired node. + FindNode returns the object of the node if it is in the list. If NodeName does not specify a node in the list, + FindNode returns nil (Delphi) or NULL (C++).} +function TALJSONNodeListA.FindNode(const NodeName: AnsiString; const Direction: TDirection = TDirection.FromBeginning): TALJSONNodeA; +var Index: Integer; +begin + Index := IndexOf(NodeName, Direction); + if Index >= 0 then Result := Get(Index) + else Result := nil; +end; - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 <> ln) or (S[P1] <> ')') then exit; // NumberInt ( "12391293" ) - // ^P1 - end - else begin // NumberInt ( "12391293" ) - // ^P1 +{**********************************} +{Returns the first node in the list. +Call First to access the first node in the list. If the list is empty, First raises an exception} +function TALJSONNodeListA.First: TALJSONNodeA; +begin + if Count > 0 then Result := Get(0) + else Result := nil; +end; - LQuoteChar := S[P1]; // " - inc(p1); // NumberInt ( "12391293" ) - // ^P1 - P2 := P1; - while P2 <= Ln do - if S[P2] = LQuoteChar then break - else inc(P2); - if P2 > ln then exit; - LTmpStr := ALCopyStr(S,P1,P2-P1); // 12391293 - P1 := P2 + 1; // NumberInt ( "12391293" ) - // ^P1 - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 <> ln) or (S[P1] <> ')') then exit; // NumberInt ( "12391293" ) - // ^P1 - end; +{*********************************} +{Returns the last node in the list. + Call Last to access the last node in the list. If the list is empty, Last raises an exception.} +function TALJSONNodeListA.Last: TALJSONNodeA; +begin + if Count > 0 then Result := Get(FCount - 1) + else result := nil; +end; - //convert 12391293 to integer - result := ALTryStrToInt(LTmpStr, Value); +{***************************************************************************} +{Returns a node that appears a specified amount before or after another node. + Call FindSibling to access the node whose position has a specified relationship to another node. + *Node is a node in the list to use as a reference point. + *Delta indicates where the desired node appears, relative to Node. If Delta is positive, FindSibling returns + the node that appears Delta positions after Node. If Delta is negative, FindSibling returns a node that appears before Node. + FindSibling returns the node that appears at the position offset by Delta, relative to the position of Node. If Delta + specifies a position before the first node or after the last node in the list, FindSibling returns nil (Delphi) or NULL (C++).} +function TALJSONNodeListA.FindSibling(const Node: TALJSONNodeA; Delta: Integer): TALJSONNodeA; +var Index: Integer; +begin + Index := IndexOf(Node) + Delta; + if (Index >= 0) and (Index < FCount) then Result := Get(Index) + else Result := nil; +end; +{************************************} +{Returns a specified node in the list. + Call Get to retrieve a node from the list, given its index. + *Index specifies the node to fetch, where 0 identifies the first node, 1 identifies the second node, and so on. + Index should be less than the value of the Count property.} +function TALJSONNodeListA.Get(Index: Integer): TALJSONNodeA; +begin + if (Index < 0) or (Index >= FCount) then AlJSONDocErrorA(CALJSONListIndexError, [Index]); + Result := FList[Index]; end; -{$WARN WIDECHAR_REDUCED ON} -{$IF defined(ALZeroBasedStringsON)} - {$ZEROBASEDSTRINGS ON} -{$IFEND} -{*********************} -{$ZEROBASEDSTRINGS OFF} -{$WARN WIDECHAR_REDUCED OFF} -function ALJSONTryStrToInt64W(const S: String; out Value: int64): Boolean; -var LTmpStr: String; - LQuoteChar: Char; - P1, P2: integer; - Ln: integer; +{**************************************} +{Returns a specified node from the list. + GetNode is the read implementation of the Nodes property. + *Index identify the desired node. 0 is the index of the first node, + 1 is the index of the second node, and so on} +function TALJSONNodeListA.GetNodeByIndex(const Index: Integer): TALJSONNodeA; begin + Result := Get(Index); +end; - // s must look like - // NumberLong ( "12391293" ) - // NumberLong ( 12391293 ) - // 12391293 - result := ALTryStrToInt64(S, Value); - if result then exit; - if ALPosW('NumberLong', S) <> 1 then exit; - Ln := length(s); - P1 := 11{length('NumberLong') + 1}; // NumberLong ( "12391293" ) - // ^P1 - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 > ln) or (S[P1] <> '(') then exit; // NumberLong ( "12391293" ) - // ^P1 - inc(p1); // NumberLong ( "12391293" ) - // ^P1 - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 > ln) then exit - else if (not (S[P1] in ['''','"'])) then begin // NumberLong ( 12391293 ) - // ^P1 - P2 := P1+1; - while (P2 <= ln) and (S[P2] in ['0'..'9']) do inc(P2); // NumberLong ( 12391293 ) - // ^P2 - if P2 > ln then exit; - LTmpStr := ALCopyStr(S,P1,P2-P1); // 12391293 - P1 := P2; // NumberLong ( 12391293 ) - // ^P2 +{**************************************} +{Returns a specified node from the list. + GetNode is the read implementation of the Nodes property. + *Name identify the desired node. it is the NodeName property of a node in the list. + If Name does not identify a node in the list, GetNode tries to create a new node with the name specified by + Name. If it can’t create the new node, GetNode raises an exception.} +function TALJSONNodeListA.GetNodeByName(const Name: AnsiString): TALJSONNodeA; +begin + Result := FindNode(Name); + if not Assigned(Result) then AlJSONDocErrorA(CALJSONNodeNotFound, [Name]); +end; - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 <> ln) or (S[P1] <> ')') then exit; // NumberLong ( "12391293" ) - // ^P1 - end - else begin // NumberLong ( "12391293" ) - // ^P1 +{****************************************************************************} +function TALJSONNodeListA.CompareNodeNames(const S1, S2: AnsiString): Integer; +begin + Result := ALCompareStrA(S1, S2) +end; - LQuoteChar := S[P1]; // " - inc(p1); // NumberLong ( "12391293" ) - // ^P1 - P2 := P1; - while P2 <= Ln do - if S[P2] = LQuoteChar then break - else inc(P2); - if P2 > ln then exit; - LTmpStr := ALCopyStr(S,P1,P2-P1); // 12391293 - P1 := P2 + 1; // NumberLong ( "12391293" ) - // ^P1 - while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); - if (P1 <> ln) or (S[P1] <> ')') then exit; // NumberLong ( "12391293" ) - // ^P1 +{*****************************************************************************************} +procedure TALJSONNodeListA.QuickSort(L, R: Integer; ACompare: TALJSONNodeListSortCompareA); +var + I, J, P: Integer; +begin + while L < R do + begin + if (R - L) = 1 then + begin + if ACompare(Self, L, R) > 0 then + Exchange(L, R); + break; + end; + I := L; + J := R; + P := (L + R) shr 1; + repeat + while (I <> P) and (ACompare(Self, I, P) < 0) do Inc(I); + while (J <> P) and (ACompare(Self, J, P) > 0) do Dec(J); + if I <= J then + begin + if I <> J then + Exchange(I, J); + if P = I then + P := J + else if P = J then + P := I; + Inc(I); + Dec(J); + end; + until I > J; + if (J - L) > (R - I) then + begin + if I < R then + QuickSort(I, R, ACompare); + R := J; + end + else + begin + if L < J then + QuickSort(L, J, ACompare); + L := I; + end; end; +end; - //convert 12391293 to integer - result := ALTryStrToInt64(LTmpStr, Value); +{************************************************************************************************} +function ALJSONNodeListCompareNodeNameA(List: TALJSONNodeListA; Index1, Index2: Integer): Integer; +begin + Result := List.CompareNodeNames( + List[Index1].NodeName, + List[Index2].NodeName); +end; +{******************************} +procedure TALJSONNodeListA.Sort; +begin + CustomSort(ALJSONNodeListCompareNodeNameA); end; -{$WARN WIDECHAR_REDUCED ON} -{$IF defined(ALZeroBasedStringsON)} - {$ZEROBASEDSTRINGS ON} -{$IFEND} -{*****************************************************} -procedure ALJSONDocErrorW(const Msg: String); overload; +{**************************************************************************} +procedure TALJSONNodeListA.CustomSort(Compare: TALJSONNodeListSortCompareA); begin - raise EALJSONDocError.Create(Msg); + if (not Sorted) and (FList <> nil) and (Count > 1) then + QuickSort(0, Count - 1, Compare); end; -{*********************************************************************************} -procedure ALJSONDocErrorW(const Msg: String; const Args: array of const); overload; +{**************************************} +{Adds a new node to the end of the list. + Call Add to add a node to the end of the list. Add returns the index of the node once it is added, where 0 is the index + of the first node in the list, 1 is the index of the second node, and so on. + *Node is the node to add to the list.} +function TALJSONNodeListA.Add(const Node: TALJSONNodeA): Integer; begin - raise EALJSONDocError.CreateFmt(Msg, Args); + if not Sorted then + Result := FCount + else + if Find(Node.NodeName, Result) then + case Duplicates of + dupIgnore: begin + ALFreeAndNil(Node); + Exit; + end; + dupError: AlJSONDocErrorA(cALJSONDuplicateNodeName); + end; + InternalInsert(Result, Node); end; -{**************************************************************************************} -procedure ALJSONDocErrorW(const Msg: String; const NodeType: TalJsonNodeType); overload; +{**********************************************************************************} +procedure TALJSONNodeListA.InternalInsert(Index: Integer; const Node: TALJSONNodeA); begin - case NodeType of - ntObject: ALJSONDocErrorW(Msg, ['ntObject']); - ntArray: ALJSONDocErrorW(Msg, ['ntArray']); - ntText: ALJSONDocErrorW(Msg, ['ntText']); - else ALJSONDocErrorW(cAlJSONInvalidNodeType); + if FCount = FCapacity then Grow; + if Index < FCount then + ALMove( + FList[Index], + FList[Index + 1], + (FCount - Index) * SizeOf(Pointer)); + Pointer(FList[index]) := nil; + FList[index] := Node; + Inc(FCount); + Node.SetParentNode(Fowner); +end; + +{********************************************************} +{Inserts a new node into a specified position in the list. + Call Insert to add a node at the position specified by Index. + *Index specifies where to insert the node, where 0 is the first position, 1 is second position, and so on. If Index does not + specify a valid index, Insert raises an exception. + *Node is the node to add to the list.} +procedure TALJSONNodeListA.Insert(Index: Integer; const Node: TALJSONNodeA); +begin + if Index = -1 then Add(Node) + else begin + if Sorted then AlJSONDocErrorA(CALJSONSortedListError); + if (Index < 0) or (Index > FCount) then AlJSONDocErrorA(CALJSONListIndexError, [Index]); + InternalInsert(Index, Node); end; end; -{********************************************************************************************} -{Call CreateNode to create a new generic JSON node. The resulting node does not have a parent, - but can be added to the ChildNodes list of any node in the document.} -function ALCreateJSONNodeW(const NodeName: String; NodeType: TALJSONNodeType): TALJSONNodeW; +{**************************************} +{Removes a specified node from the list. + Delete removes the node specified by the Index or Name parameter. + *Index identifies the node to remove by index rather than name. Index ranges from 0 to one less than the value of the Count property. + Delete returns the index of the node that was removed. If there was no node that matched the value of Index Delete returns –1.} +function TALJSONNodeListA.Delete(const Index: Integer): Integer; +var Node: TALJSONNodeA; begin - case NodeType of - ntObject: Result := TALJSONObjectNodeW.Create(NodeName); - ntArray: Result := TALJSONArrayNodeW.Create(NodeName); - ntText: Result := TALJSONTextNodeW.Create(NodeName); - else begin - Result := nil; //for hide warning - ALJSONDocErrorW(cAlJSONInvalidNodeType); - end; + Node := Get(Index); + FList[Index] := nil; // to decrease the refcount of Node + Dec(FCount); + if Index < FCount then begin + ALMove( + FList[Index + 1], + FList[Index], + (FCount - Index) * SizeOf(Pointer)); + Pointer(FList[FCount]) := nil; end; + if assigned(Node) then FreeAndNil(Node); + result := Index; end; -{*****************************************************************} -constructor TALJSONDocumentW.create(const aActive: Boolean = True); +{**************************************} +{Removes a specified node from the list. + Delete removes the node specified by the Index or Name parameter. + *Name identifies the node to remove from the list. This is the local name of the node to remove. + Delete returns the index of the node that was removed. If there was no node that matched the value of Name, Delete returns –1.} +function TALJSONNodeListA.Delete(const Name: AnsiString): Integer; begin - inherited create; - FDocumentNode:= nil; - FParseOptions:= []; - FDuplicates := dupAccept; - FPathSeparator := '.'; - FOnParseStartDocument := nil; - FOnParseEndDocument := nil; - FonParseText := nil; - FonParseStartObject := nil; - FonParseEndObject := nil; - FonParseStartArray := nil; - FonParseEndArray := nil; - FOptions := []; - NodeIndentStr := ALDefaultJsonNodeIndentW; - fFormatSettings := @ALDefaultFormatSettingsW; - FTag := 0; - SetActive(aActive); + result := indexOf(Name); + if Result >= 0 then Delete(Result); end; -{************************************************************************************************************} -constructor TALJSONDocumentW.Create(const aFormatSettings: TALFormatSettingsW; const aActive: Boolean = True); +{**************************************} +{Removes a specified node from the list. + Remove removes the specified node from the list. + *Node is the node to remove from the list. + Remove returns the index of Node before it was removed. If node is not a node in the list, Remove returns -1.} +function TALJSONNodeListA.Remove(const Node: TALJSONNodeA): Integer; begin - create(aActive); - if @aFormatSettings <> @ALDefaultFormatSettingsW then begin - new(fFormatSettings); - fFormatSettings^ := aFormatSettings; - end; + Result := IndexOf(Node); + if Result >= 0 then Delete(Result); end; -{**********************************} -destructor TALJSONDocumentW.Destroy; +{***********************************************************} +{Removes a specified object from the list without freeing it. + Call Extract to remove an object from the list without freeing the object itself. + After an object is removed, all the objects that follow it are moved up in index position and Count is decremented.} +function TALJSONNodeListA.Extract(const Node: TALJSONNodeA): TALJSONNodeA; +var I: Integer; begin - if fFormatSettings <> @ALDefaultFormatSettingsW then dispose(fFormatSettings); - ReleaseDoc; - inherited; + Result := nil; + I := IndexOf(Node); + if I >= 0 then result := Extract(i); end; -{***********************************************************************************} -procedure TALJSONDocumentW.MultiThreadPrepare(const aOnlyChildList: Boolean = False); +{***********************************************************} +procedure TALJSONNodeListA.Exchange(Index1, Index2: Integer); +var Item: Pointer; begin - node.MultiThreadPrepare(aOnlyChildList); + if (Index1 < 0) or (Index1 >= FCount) then AlJSONDocErrorA(cALJSONListIndexError, [Index1]); + if (Index2 < 0) or (Index2 >= FCount) then AlJSONDocErrorA(cALJSONListIndexError, [Index2]); + Item := pointer(FList[Index1]); + pointer(FList[Index1]) := pointer(FList[Index2]); + pointer(FList[Index2]) := Item; end; -{*******************************} -procedure TALJSONDocumentW.Clear; +{***********************************************************} +{Removes a specified object from the list without freeing it. + Call Extract to remove an object from the list without freeing the object itself. + After an object is removed, all the objects that follow it are moved up in index position and Count is decremented.} +function TALJSONNodeListA.Extract(const index: integer): TALJSONNodeA; begin - releaseDoc; - Active := true; + Result := Get(index); + Result.SetParentNode(nil); + FList[index] := nil; + Delete(index); end; -{****************************************} -{Returns the value of the Active property. - GetActive is the read implementation of the Active property.} -function TALJSONDocumentW.GetActive: Boolean; +{*********************************************} +{Replaces a node in the list with another node. + Call ReplaceNode to replace the node specified by OldNode with the node specified by NewNode. + *OldNode is the node to replace. If OldNode does not appear in the list, then ReplaceNode adds the new node to the end of the list. + *NewNode is the node to add to the list in place of OldNode. + ReplaceNode returns OldNode (even if OldNode did not appear in the list).} +function TALJSONNodeListA.ReplaceNode(const OldNode, NewNode: TALJSONNodeA): TALJSONNodeA; +var Index: Integer; begin - Result := Assigned(FDocumentNode); -end; - -{*************************************} -{Sets the value of the Active property. - SetActive is the write implementation of the Active property. - *Value is the new value to set.} -procedure TALJSONDocumentW.SetActive(const Value: Boolean); -begin - if Value <> GetActive then begin - if Value then begin - FDocumentNode := TALJSONObjectNodeW.Create; - FDocumentNode.SetOwnerDocument(Self); - end - else ReleaseDoc; - end; + Index := indexOf(OldNode); + Result := Extract(Index); + if not sorted then Insert(Index, NewNode) + else Add(NewNode); end; -{**************} -{The JSON format - There are just a few rules that you need to remember: - *Objects are encapsulated within opening and closing brackets { } { - *An empty object can be represented by { } { - *Arrays are encapsulated within opening and closing square brackets [ ] - *An empty array can be represented by [ ] - *A member is represented by a key-value pair - *The key of a member should be contained in double quotes. (JavaScript does not require this. JavaScript and some parsers will tolerate single-quotes) - *Each member should have a unique key within an object structure - *The value of a member must be contained in double quotes if it's a string (JavaScript and some parsers will tolerates single-quotes) - *Boolean values are represented using the true or false literals in lower case - *Number values are represented using double-precision floating-point format. Scientific notation is supported - *Numbers should not have leading zeroes - *"Offensive"" characters in a string need to be escaped using the backslash character - *Null values are represented by the null literal in lower case - *Other object types, such as dates, are not properly supported and should be converted to strings. It becomes the responsability of the parser/client to manage this. - *Each member of an object or each array value must be followed by a comma if it's not the last one - *The common extension for json files is '.json' - *The mime type for json files is 'application/json'} -{$ZEROBASEDSTRINGS OFF} -{$WARN WIDECHAR_REDUCED OFF} -Procedure TALJSONDocumentW.ParseJSON( - const Buffer: String; - const ContainerNode: TALJSONNodeW); - -Var BufferLength: Integer; - BufferPos: Integer; - CurrName: String; - CurrIndex: integer; - CurrValue: String; - NotSaxMode: Boolean; - WorkingNode: TALJSONNodeW; - NamePaths: TALNVStringListW; - ObjectPaths: TALIntegerList; - DecodeJSONReferences: boolean; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function GetPathStr(Const ExtraItems: String = ''): String; - var I, L, P, Size: Integer; - LB: Char; - S: String; - begin - LB := PathSeparator; - Size := length(ExtraItems); - if size <> 0 then Inc(Size, 1{length(LB)}); - for I := 1 to NamePaths.Count - 1 do Inc(Size, Length(NamePaths.Names[I]) + 1{length(LB)}); - SetLength(Result, Size); - P := 1; - for I := 1 to NamePaths.Count - 1 do begin - S := NamePaths.Names[I]; - L := Length(S); - if L <> 0 then begin - ALMove(pointer(S)^, Pbyte(Result)[(P-1)*sizeOf(Char)], L*sizeOf(Char)); - Inc(P, L); - end; - L := 1{length(LB)}; - if ((i <> NamePaths.Count - 1) or - (ExtraItems <> '')) and - (((NotSaxMode) and (TALJSONNodeW(NamePaths.Objects[I]).nodetype <> ntarray)) or - ((not NotSaxMode) and (TALJSONNodeType(NamePaths.Objects[I]) <> ntarray))) then begin - ALMove(LB, Pbyte(Result)[(P-1)*sizeOf(Char)], L*sizeOf(Char)); - Inc(P, L); - end; - end; - if ExtraItems <> '' then begin - L := length(ExtraItems); - ALMove(pointer(ExtraItems)^, Pbyte(Result)[(P-1)*sizeOf(Char)], L*sizeOf(Char)); - Inc(P, L); - end; - setlength(result,P-1); - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseTextWithIndex( - const index: integer; - const Args: array of const; - const NodeSubType: TALJSONNodeSubType); - begin - DoParseText(GetPathStr('[' + ALIntToStrW(index) + ']'), '', Args, NodeSubType) - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseTextWithName( - const name: String; - const Args: array of const; - const NodeSubType: TALJSONNodeSubType); - begin - DoParseText(GetPathStr(Name), Name, Args, NodeSubType) - end; - - {~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseText( - const Index: integer; - const Name: String; - const Args: array of const; - const NodeSubType: TALJSONNodeSubType); - begin - if Assigned(fonParseText) then begin - if notSaxMode then begin - if WorkingNode.nodetype=ntarray then _DoParseTextWithIndex(Index, Args, NodeSubType) - else _DoParseTextWithName(Name, Args, NodeSubType); - end - else begin - if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); - if TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntArray then _DoParseTextWithIndex(Index, Args, NodeSubType) - else _DoParseTextWithName(Name, Args, NodeSubType); - end; - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseStartObject(const Name: String); - begin - DoParseStartObject(GetPathStr, Name); - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseEndObject; - begin - if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); - DoParseEndObject(GetPathStr, NamePaths.Names[NamePaths.Count - 1]) - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseStartArray(const index: String); - begin - DoParseStartArray(GetPathStr, index) - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseEndArray; - begin - if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); - DoParseEndArray(GetPathStr, NamePaths.Names[NamePaths.Count - 1]); - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _AddIndexItemToNamePath(const index: integer; Obj: Pointer); - var S1: String; - begin - setlength(S1,sizeOf(Integer) div sizeOF(Char)); // off course sizeOf(Integer) must be a multiple of sizeOf(char) but it's always the case - ALmove(index, pointer(S1)^, sizeOf(Integer)); - NamePaths.AddNameValueObject('[' + ALIntToStrW(Index) + ']', S1, Obj) - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _AddNameItemToNamePath(const name: String; Obj: Pointer); - begin - NamePaths.AddNameValueObject(Name, #$ffff#$ffff, Obj) - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _AddItemToNamePath(index: integer; const name: String; Obj: Pointer); - begin - if notSaxMode then begin - if WorkingNode.nodetype=ntarray then _AddIndexItemToNamePath(Index, Obj) - else _AddNameItemToNamePath(name, Obj); - end - else begin - if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); - if TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntarray then _AddIndexItemToNamePath(Index, Obj) - else _AddNameItemToNamePath(name, Obj); - end; - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createInt64Node(index: integer; const name: String; const value: String): boolean; - var LNode: TALJSONNodeW; - LInt64: Int64; - begin - if ALJSONTryStrToInt64W(value, LInt64) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetInt64(LInt64); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(index, Name, [LInt64], nstInt64) - end - else begin - _DoParseText(index, Name, [LInt64], nstInt64) - end; - end - else result := False; - end; +{*******************************} +{Removes all nodes from the list. + Call Clear to empty the list. + Note: Clear does not call the BeginUpdate and EndUpdate methods, even though it may result in the + deletion of more than one node.} +procedure TALJSONNodeListA.Clear; +begin + SetCount(0); + SetCapacity(0); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createInt32Node(index: integer; const name: String; const value: String): boolean; - var LNode: TALJSONNodeW; - LInt32: Int32; - begin - if ALJSONTryStrToInt32W(value, LInt32) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setint32(LInt32); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(index, Name, [LInt32], nstInt32) - end - else begin - _DoParseText(index, Name, [LInt32], nstInt32) - end - end - else result := False; - end; +{******************************} +procedure TALJSONNodeListA.Grow; +{$IF CompilerVersion <= 32}{tokyo} +var Delta: Integer; +{$endif} +begin + {$IF CompilerVersion <= 32}{tokyo} + if FCapacity > 64 then Delta := FCapacity div 4 + else if FCapacity > 8 then Delta := 16 + else Delta := 4; + SetCapacity(FCapacity + Delta); + {$else} + SetCapacity(GrowCollection(FCapacity, FCount + 1)); + {$endif} +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createTextNode(index: integer; const name: String; const value: String): boolean; - var LNode: TALJSONNodeW; - begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Settext(value); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(index, Name, [value], nstText) - end - else begin - _DoParseText(index, Name, [value], nstText) - end +{***********************************************************} +procedure TALJSONNodeListA.SetCapacity(NewCapacity: Integer); +begin + if (NewCapacity < FCount) then AlJSONDocErrorA(CALJSONListCapacityError, [NewCapacity]); + if NewCapacity <> FCapacity then begin + SetLength(FList, NewCapacity); + FCapacity := NewCapacity; end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createFloatNode(index: integer; const name: String; const value: String): boolean; - var LNode: TALJSONNodeW; - LDouble: Double; - begin - if ALTryStrToFloat(value, LDouble, ALDefaultFormatSettingsW) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetFloat(LDouble); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(index, Name, [LDouble], nstFloat) - end - else begin - _DoParseText(index, Name, [LDouble], nstFloat) - end - end - else result := False; +{*****************************************************************************} +procedure TALJSONNodeListA.SetDuplicates(Value: TDuplicates; Recurse: Boolean); +begin + FDuplicates := Value; + if Recurse then begin + for Var I := 0 to count-1 do begin + Var LNodeList := Get(i).InternalGetChildNodes; + if LNodeList <> nil then LNodeList.SetDuplicates(Value,Recurse); + end; end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createBinaryNode(index: integer; const name: String; const value: String): boolean; - var LNode: TALJSONNodeW; - LBinSubtype: byte; - LBinData: String; - begin - if ALJSONTryStrToBinaryW(value, LBinData, LBinSubtype) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.setbinary(LBinData, LBinSubtype); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(index, Name, [LBinData, LBinSubtype], nstBinary); - end - else begin - _DoParseText(index, Name, [LBinData, LBinSubtype], nstBinary); - end - end - else result := False; - end; +{***********************************************************} +procedure TALJSONNodeListA.SetDuplicates(Value: TDuplicates); +begin + SetDuplicates(Value, False); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createObjectIDNode(index: integer; const name: String; const value: String): boolean; - var LNode: TALJSONNodeW; - LObjectID: String; +{*********************************************************************} +procedure TALJSONNodeListA.SetSorted(Value: Boolean; Recurse: Boolean); +begin + if FSorted <> Value then begin - if ALJSONTryStrToObjectIDW(value, LObjectID) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetObjectID(LObjectID); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(index, Name, [LObjectID], nstObjectID) - end - else begin - _DoParseText(index, Name, [LObjectID], nstObjectID) - end; + if owner is TALJSONObjectNodeA then begin + if Value then Sort; + FSorted := Value; end - else result := False; + else FSorted := False; end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createBooleanNode(index: integer; const name: String; const value: String): boolean; - var LNode: TALJSONNodeW; - LBool: Boolean; - begin - if value = 'true' then LBool := true - else if value = 'false' then LBool := false - else begin - result := False; - exit; - end; - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setbool(LBool); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(index, Name, [LBool], nstBoolean); - end - else begin - _DoParseText(index, Name, [LBool], nstBoolean); + if Recurse then begin + for Var I := 0 to count-1 do begin + Var LNodeList := Get(i).InternalGetChildNodes; + if LNodeList <> nil then LNodeList.SetSorted(Value,Recurse); end; end; +end; + +{***************************************************} +procedure TALJSONNodeListA.SetSorted(Value: Boolean); +begin + SetSorted(Value, False); +end; + +{*****************************************************} +procedure TALJSONNodeListA.SetCount(NewCount: Integer); +var I: Integer; +begin + if (NewCount < 0) then AlJSONDocErrorA(CALJSONListCountError, [NewCount]); + if NewCount > FCapacity then SetCapacity(NewCount); + if NewCount > FCount then FillChar(FList[FCount], (NewCount - FCount) * SizeOf(Pointer), 0) + else for I := FCount - 1 downto NewCount do Delete(I); + FCount := NewCount; +end; + +{**************************} +Procedure ALJSONToTStringsA( + const AJsonStr: AnsiString; + const aFormatSettings: TALFormatSettingsA; + const aPath: AnsiString; + const aLst: TALStringsA; + Const aNullStr: AnsiString = 'null'; + Const aTrueStr: AnsiString = 'true'; + Const aFalseStr: AnsiString = 'false'); +var LContainChilds: boolean; +begin + LContainChilds := False; + TALJSONDocumentA.ParseJSONString( + AJsonStr, + //-- + procedure (Sender: TObject; const Path: AnsiString; const name: AnsiString; const Args: array of const; NodeSubType: TALJSONNodeSubType) + begin + if (NodeSubType = nstFloat) then aLst.Add(aPath + Path + aLst.NameValueSeparator + ALFloatToStrA(Args[0].VExtended^, aFormatSettings)) + else if (NodeSubType = nstDateTime) then aLst.Add(aPath + Path + aLst.NameValueSeparator + ALDateTimeToStrA(Args[0].VExtended^, aFormatSettings)) + else if (NodeSubType = nstBoolean) then aLst.Add(aPath + Path + aLst.NameValueSeparator + ALBoolToStrA(Args[0].VBoolean,aTrueStr,aFalseStr)) + else if (NodeSubType = nstnull) then aLst.Add(aPath + Path + aLst.NameValueSeparator + aNullStr) + else aLst.Add(aPath + Path + aLst.NameValueSeparator + ansiString(Args[0].VAnsiString)); + LContainChilds := True; + end{onParseText}, + //-- + procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) + begin + LContainChilds := False; + end{onParseStartObject}, + //-- + procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) + begin + if (not LContainChilds) and (aPath + Path <> ''{Path = '' mean it's the root object}) then aLst.Add(aPath+ Path + aLst.NameValueSeparator + '{}'); + LContainChilds := True; + end{onParseEndObject}, + //-- + procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) + begin + LContainChilds := False; + end{onParseStartArray}, + //-- + procedure (Sender: TObject; const Path: AnsiString; const Name: AnsiString) + begin + if not LContainChilds then aLst.Add(aPath+ Path + aLst.NameValueSeparator + '[]'); + LContainChilds := True; + end{onParseEndArray}); +end; + +{**************************} +Procedure ALJSONToTStringsA( + const AJsonStr: AnsiString; + const aFormatSettings: TALFormatSettingsA; + const aLst: TALStringsA; + Const aNullStr: AnsiString = 'null'; + Const aTrueStr: AnsiString = 'true'; + Const aFalseStr: AnsiString = 'false'); +begin + ALJSONToTStringsA( + AJsonStr, + aFormatSettings, + '', + aLst, + aNullStr, + aTrueStr, + aFalseStr); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createDateTimeNode(index: integer; const name: String; const value: String): boolean; - var LNode: TALJSONNodeW; - LDateTime: TdateTime; - begin - if ALJSONTryStrToDateTimeW(value, LDateTime) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setdatetime(LDateTime); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(index, Name, [LDateTime], nstDateTime); - end - else begin - _DoParseText(index, Name, [LDateTime], nstDateTime); - end; - end - else result := False; - end; +{**************************} +Procedure ALJSONToTStringsA( + const aJsonNode: TALJSONNodeA; + Const aPath: AnsiString; + const aLst: TALStringsA; + Const aNullStr: AnsiString = 'null'; + Const aTrueStr: AnsiString = 'true'; + Const aFalseStr: AnsiString = 'false'); +var LTmpPath: AnsiString; + I: integer; +begin + if aJsonNode.ChildNodes.Count > 0 then begin + for I := 0 to aJsonNode.ChildNodes.Count - 1 do begin - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createTimestampNode(index: integer; const name: String; const value: String): boolean; - var LNode: TALJSONNodeW; - LTimestamp: TALBSONTimestamp; - begin - if ALJSONTryStrToTimestampW(value, LTimestamp) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetTimestamp(LTimestamp); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(index, Name, [LTimestamp.W1, LTimestamp.W2], nstTimeStamp); - end + if aJsonNode.NodeType = ntArray then LTmpPath := aPath + '[' + ALIntToStrA(I) + ']' else begin - _DoParseText(index, Name, [LTimestamp.W1, LTimestamp.W2], nstTimeStamp); + if aJsonNode.ChildNodes[I].NodeName = '' then raise Exception.Create('Nodename can not be empty'); + LTmpPath := aPath + alIfThenA(aPath <> '', '.', '') + aJsonNode.ChildNodes[I].NodeName; end; - end - else result := False; - end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createnullNode(index: integer; const name: String; const value: String): boolean; - var LNode: TALJSONNodeW; - begin - if value = 'null' then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setnull(true); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(index, Name, ['null'], nstNull); - end - else begin - _DoParseText(index, Name, ['null'], nstNull); - end; - end - else result := False; - end; + case aJsonNode.ChildNodes[I].NodeType of - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createRegExNode(index: integer; const name: String; const value: String): boolean; - var LNode: TALJSONNodeW; - LRegEx: String; - LRegExOptions: TALPerlRegExOptions; - begin - if ALJSONTryStrToRegExW(value, LRegEx, LRegExOptions) then begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetRegEx(LRegEx, LRegExOptions); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(index, Name, [LRegEx, Byte(LRegExOptions)], nstRegEx) - end - else begin - _DoParseText(index, Name, [LRegEx, Byte(LRegExOptions)], nstRegEx) - end; - end - else result := False; - end; + ntObject: ALJSONToTStringsA( + aJsonNode.ChildNodes[I], + LTmpPath, + aLst, + aNullStr, + aTrueStr, + aFalseStr); + + ntArray: ALJSONToTStringsA( + aJsonNode.ChildNodes[I], + LTmpPath, + aLst, + aNullStr, + aTrueStr, + aFalseStr); + + ntText: begin + if (aJsonNode.ChildNodes[I].NodeSubType = nstBoolean) then aLst.Add(LTmpPath + aLst.NameValueSeparator + ALBoolToStrA(aJsonNode.ChildNodes[I].Bool,aTrueStr,aFalseStr)) + else if (aJsonNode.ChildNodes[I].NodeSubType = nstnull) then aLst.Add(LTmpPath + aLst.NameValueSeparator + aNullStr) + else aLst.Add(LTmpPath + aLst.NameValueSeparator + aJsonNode.ChildNodes[I].Text); + end; + + else raise Exception.Create('Unknown NodeType'); - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _createJavascriptNode(index: integer; const name: String; const value: String): boolean; - var LNode: TALJSONNodeW; - begin - result := true; - if NotSaxMode then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetJavascript(value); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; end; - _DoParseText(index, Name, [value], nstJavascript); - end - else begin - _DoParseText(index, Name, [value], nstJavascript); end; + end + else if (aPath <> ''{aPath = '' mean it's the root object}) then begin + if aJsonNode.NodeType = ntArray then aLst.Add(aPath + aLst.NameValueSeparator + '[]') + else if aJsonNode.NodeType = ntObject then aLst.Add(aPath + aLst.NameValueSeparator + '{}'); end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createNode(index: integer; const name: String; const value: String; AQuotedValue: Boolean); - begin - if AQuotedValue then begin - _createTextNode(index, Name, Value); - exit; - end; - if _createFloatNode(index, Name, Value) then exit; // << we have the same problem as javascript, if we put here a big number like (by exemple) 9223372036854775808 - // << then the stored value will be different because of double precision that is less than int64 precision - // << it's the way javascript json work, it's have no room for int / int64 :( - // << if we want to have the possibility to store int64 precision then we must use node subtype helper - // << like NumberLong(9223372036854775808) - if _createBooleanNode(index, Name, Value) then exit; - if _createNullNode(index, Name, Value) then exit; - if _createInt32Node(index, Name, Value) then exit; - if _createInt64Node(index, Name, Value) then exit; - if _createDateTimeNode(index, Name, Value) then exit; - if _createBinaryNode(index, Name, Value) then exit; - if _createObjectIDNode(index, Name, Value) then exit; - if _createRegExNode(index, Name, Value) then exit; - if _createTimeStampNode(index, Name, Value) then exit; - _createJavascriptNode(index, Name, Value); - end; +{**************************} +Procedure ALJSONToTStringsA( + const aJsonNode: TALJSONNodeA; + const aLst: TALStringsA; + Const aNullStr: AnsiString = 'null'; + Const aTrueStr: AnsiString = 'true'; + Const aFalseStr: AnsiString = 'false'); +begin + ALJSONToTStringsA( + aJsonNode, + '', + aLst, + aNullStr, + aTrueStr, + aFalseStr) +end; + +{**************************} +procedure ALTStringsToJsonA( + const aLst: TALStringsA; + const aJsonNode: TALJSONNodeA; + Const aPath: AnsiString = ''; + Const aNameToLowerCase: boolean = false; + Const aNullStr: AnsiString = 'null'); + +var LIndex: Integer; + LNames: TALStringListA; + LLowerName: AnsiString; + LCurrJsonNode, LTmpJsonNode: TALJSONNodeA; + I, J: integer; + +begin + + // create list of the part of name, + // from "aggregated_data.properties.types[3].translations.usa" => + // aggregated_data + // properties + // types + // [3] + // translations + // usa + LNames := TALStringListA.Create; + try + + //init aNames.linebreak + LNames.LineBreak := '.'; + + // scroll the aLst + for I := 0 to aLst.Count - 1 do begin + + //if it's contain path + if (aPath = '') or + (ALPosIgnoreCaseA(aPath + '.',aLst.Names[I]) = 1) then begin + + // path.aggregated_data.properties.types[3].translations.usa => + // aggregated_data + // properties + // types + // [3] + // translations + // usa + if (aPath <> '') then LNames.Text := ALStringReplaceA( + ALStringReplaceA( + aLst.Names[I], + aPath + '.', + '', + [rfIgnoreCase]), + '[', + '.[', + [rfReplaceAll]) + else LNames.Text := ALStringReplaceA( + aLst.Names[I], + '[', + '.[', + [rfReplaceAll]); - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _extractLastIndexFromNamePath: integer; - begin - if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); - ALMove(pointer(namePaths.ValueFromIndex[namepaths.Count - 1])^,result,sizeOf(integer)); - end; + //loop on all the name + LCurrJsonNode := aJsonNode; + for J := 0 to LNames.Count - 1 do begin - {~~~~~~~~~~~~~~~~~~~~} - procedure AnalyzeNode; - Var LNode: TALJSONNodeW; - LNodeType: TALJSONNodeType; - LQuoteChar: Char; - LNameValueSeparator: Char; - LInSingleQuote: boolean; - LInDoubleQuote: boolean; - LInSlashQuote: boolean; - LInSquareBracket: integer; - LInRoundBracket: integer; - LInCurlyBracket: integer; - P1, P2: Integer; - c: Char; - Begin + //if we are in array + if LCurrJsonNode.NodeType = ntArray then begin + if (length(LNames[J]) <= 2) or + (LNames[J][1] <> '[') or + (LNames[J][length(LNames[J])] <> ']') or + (not ALTryStrToInt(ALCopyStr(LNames[J], 2, Length(LNames[J]) - 2), LIndex)) then raise EALException.CreateFmt('Wrong path: "%s"', [aLst.Names[I]]); + while LIndex > LCurrJsonNode.ChildNodes.Count - 1 do begin + if J = LNames.Count - 1 then LCurrJsonNode.AddChild(ntText) + else if (LNames[J+1] <> '') and + (LNames[J+1][1] = '[') then LCurrJsonNode.AddChild(ntarray) + else LCurrJsonNode.AddChild(ntObject); + end; + LCurrJsonNode := LCurrJsonNode.ChildNodes[LIndex]; + end - {$REGION 'init current char (c)'} - c := Buffer[BufferPos]; - {$ENDREGION} + //if we are not in array + else begin + LLowerName := alifThenA(aNameToLowerCase, allowercase(LNames[J]), LNames[J]); + LTmpJsonNode := LCurrJsonNode.ChildNodes.FindNode(LLowerName); + if not assigned(LTmpJsonNode) then begin + if J = LNames.Count - 1 then LCurrJsonNode := LCurrJsonNode.AddChild(LLowerName, ntText) + else if (LNames[J+1] <> '') and + (LNames[J+1][1] = '[') then LCurrJsonNode := LCurrJsonNode.AddChild(LLowerName, ntarray) + else LCurrJsonNode := LCurrJsonNode.AddChild(LLowerName, ntObject); + end + else LCurrJsonNode := LTmpJsonNode; + end; - {$REGION 'end Object/Array'} - // ... } .... - // ... ] .... - if c in ['}',']'] then begin // ... } ... - // ^BufferPos + //set the value + if J = LNames.Count - 1 then begin + if aLst.ValueFromIndex[I] = aNullStr then LCurrJsonNode.Null := true + else LCurrJsonNode.Text := aLst.ValueFromIndex[I]; + end; - //Reset the CurrIndex - CurrIndex := -1; + end; - //error if Paths.Count = 0 (mean one end object/array without any starting) - if assigned(ObjectPaths) then begin - if (ObjectPaths.Count = 0) then ALJSONDocErrorW(cALJSONParseError); - end - else begin - if (NamePaths.Count = 0) then ALJSONDocErrorW(cALJSONParseError); end; - //if we are not in sax mode - if NotSaxMode then begin + end; - //init anode to one level up - if assigned(ObjectPaths) then LNode := TALJSONNodeW(ObjectPaths.Objects[ObjectPaths.Count - 1]) - else LNode := TALJSONNodeW(NamePaths.Objects[NamePaths.Count - 1]); + finally + ALFreeAndNil(LNames); + end; - //if anode <> workingNode aie aie aie - if (LNode <> WorkingNode) then ALJSONDocErrorW(CALJSONParseError); +end; - //calculate anodeTypeInt - LNodeType := LNode.NodeType; - if not (LNodeType in [ntObject, ntarray]) then ALJSONDocErrorW(cALJSONParseError); +{*********************} +Procedure ALJSONToXMLA( + const aJSONNode: TALJSONNodeA; + const aXMLNode: TALXmlNode; + const aXMLElementNameForJSONArrayEntries: TALStringsA; // JSONArrayNodeName=XMLElementName + const aDefaultXMLElementNameForJSONArrayEntries: AnsiString = 'rec'); +var LNodeName: AnsiString; + I: integer; +begin + for I := 0 to aJSONNode.ChildNodes.Count - 1 do begin - //check that the end object/array correspond to the aNodeType - if ((c = '}') and - (LNodeType <> ntObject)) or - ((c = ']') and - (LNodeType <> ntarray)) then ALJSONDocErrorW(CALJSONParseError); + if (aJSONNode.NodeType = ntarray) then begin + if assigned(aXMLElementNameForJSONArrayEntries) then LNodeName := aXMLElementNameForJSONArrayEntries.Values[aJSONNode.NodeName] + else LNodeName := ''; + if LNodeName = '' then LNodeName := aDefaultXMLElementNameForJSONArrayEntries; + end + else LNodeName := aJSONNode.ChildNodes[I].NodeName; - //if working node <> containernode then we can go to one level up - If WorkingNode<>ContainerNode then begin + if aJSONNode.ChildNodes[I].NodeType = ntText then aXMLNode.AddChild(LNodeName).text := aJSONNode.ChildNodes[I].text + else ALJSONToXMLA(aJSONNode.ChildNodes[I], aXMLNode.AddChild(LNodeName)); - //init WorkingNode to the parentNode - WorkingNode := WorkingNode.ParentNode; + end; +end; - //update CurrIndex if WorkingNode.NodeType = ntArray - if assigned(ObjectPaths) then begin - if WorkingNode.NodeType = ntArray then CurrIndex := ObjectPaths[Objectpaths.Count - 1] + 1; - end - else begin - if WorkingNode.NodeType = ntArray then CurrIndex := _extractLastIndexFromNamePath + 1; - end; +{*********************} +Procedure ALJSONToXMLA( + const aJSONNode: TALJSONNodeA; + const aXMLNode: TALXmlNode; + const aDefaultXMLElementNameForJSONArrayEntries: AnsiString = 'rec'); +begin + ALJSONToXMLA( + aJSONNode, + aXMLNode, + nil, + aDefaultXMLElementNameForJSONArrayEntries); +end; - end +{*********************************************************************************} +function ALJsonEncodeFloatWithNodeSubTypeHelperA(const aValue: double): AnsiString; +begin + result := ALFloatToStrA(aValue, ALDefaultFormatSettingsA); +end; - //if working node = containernode then we can no go to the parent node so set WorkingNode to nil - Else WorkingNode := nil; +{************************************************************************************} +function ALJsonEncodeTextWithNodeSubTypeHelperA(const aValue: AnsiString): AnsiString; +begin + result := '"'+ALJavascriptEncode(aValue)+'"'; +end; - end +{**************************************************************************************} +function ALJsonEncodeBinaryWithNodeSubTypeHelperA(const aValue: AnsiString): AnsiString; +begin + result := 'BinData(0, "' + ALBase64EncodeString(aValue) + '")'; +end; - //if we are in sax mode - else begin +{****************************************************************************************} +function ALJsonEncodeObjectIDWithNodeSubTypeHelperA(const aValue: AnsiString): AnsiString; +begin + result := 'ObjectId("'+ALBinToHexA(aValue)+'")'; +end; - //calculate anodeTypeInt - LNodeType := TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]); - if not (LNodeType in [ntObject,ntarray]) then ALJSONDocErrorW(cALJSONParseError); +{************************************************************************************} +function ALJsonEncodeBooleanWithNodeSubTypeHelperA(const aValue: Boolean): AnsiString; +begin + if aValue then result := 'true' + else result := 'false'; +end; - //check that the end object/array correspond to the aNodeType - if ((c = '}') and - (LNodeType <> ntObject)) or - ((c = ']') and - (LNodeType <> ntarray)) then ALJSONDocErrorW(CALJSONParseError); +{***************************************************************************************} +function ALJsonEncodeDateTimeWithNodeSubTypeHelperA(const aValue: TdateTime): AnsiString; +begin + result := ALFormatDateTimeA('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', aValue, ALDefaultFormatSettingsA); +end; - //update CurrIndex if WorkingNode.NodeType = ntArray - if (Namepaths.Count >= 2) and - (TALJSONNodeType(NamePaths.Objects[Namepaths.Count - 2]) = ntarray) then CurrIndex := _extractLastIndexFromNamePath + 1; +{******************************************************************************************} +function ALJsonEncodeJavascriptWithNodeSubTypeHelperA(const aValue: AnsiString): AnsiString; +begin + result := aValue; +end; - end; +{********************************************************************************} +function ALJsonEncodeInt64WithNodeSubTypeHelperA(const aValue: int64): AnsiString; +begin + result := 'NumberLong(' + ALIntToStrA(aValue) + ')'; +end; - //call the DoParseEndObject/array event - if Assigned(fonParseEndObject) then begin - if LNodeType = ntObject then _DoParseEndObject - else _DoParseEndArray; +{********************************************************************************} +function ALJsonEncodeInt32WithNodeSubTypeHelperA(const aValue: int32): AnsiString; +begin + result := 'NumberInt(' + ALIntToStrA(aValue) + ')'; +end; + +{**********************************************************} +function ALJsonEncodeNullWithNodeSubTypeHelperA: AnsiString; +begin + result := 'null'; +end; + +{******************************************} +function ALJsonEncodeWithNodeSubTypeHelperA( + const aValue: AnsiString; + const aNodeSubType: TALJSONNodeSubType; + const aFormatSettings: TALFormatSettingsA): AnsiString; +begin + case aNodeSubType of + nstFloat: begin + if @aFormatSettings <> @ALDefaultFormatSettingsA then result := ALJsonEncodeFloatWithNodeSubTypeHelperA(ALStrToFloat(aValue, aFormatSettings)) + else result := aValue; + end; + nstText: result := ALJsonEncodeTextWithNodeSubTypeHelperA(aValue); + nstBinary: result := ALJsonEncodeBinaryWithNodeSubTypeHelperA(aValue); + nstObjectID: result := ALJsonEncodeObjectIDWithNodeSubTypeHelperA(aValue); + nstBoolean: result := ALJsonEncodeBooleanWithNodeSubTypeHelperA(ALStrToBool(aValue)); + nstDateTime: begin + if aValue = 'NOW' then result := ALJsonEncodeDateTimeWithNodeSubTypeHelperA(ALUtcNow) + else result := ALJsonEncodeDateTimeWithNodeSubTypeHelperA(ALStrToDateTime(aValue, aFormatSettings)); + end; + nstJavascript: result := ALJsonEncodeJavascriptWithNodeSubTypeHelperA(aValue); + nstInt32: result := ALJsonEncodeInt32WithNodeSubTypeHelperA(ALstrToInt(aValue)); + nstInt64: result := ALJsonEncodeInt64WithNodeSubTypeHelperA(ALstrToInt64(aValue)); + nstNull: result := ALJsonEncodeNullWithNodeSubTypeHelperA; + nstObject: raise Exception.Create('Unsupported Node SubType'); + nstArray: raise Exception.Create('Unsupported Node SubType'); + nstRegEx: raise Exception.Create('Unsupported Node SubType'); + nstTimestamp: raise Exception.Create('Unsupported Node SubType'); + else raise Exception.Create('Unknown Node SubType'); + end; +end; + +{********************************************} +Function ALFindJsonNodeByInt32ChildNodeValueW( + const JsonNode:TALJSONNodeW; + Const ChildNodeName: String; + Const ChildNodeValue : Int32; + Const Recurse: Boolean = False): TALJSONNodeW; +var I, J : integer; +Begin + result := nil; + if not (JsonNode.NodeType in [ntObject, ntArray]) then Exit; + for I := 0 to JsonNode.ChildNodes.Count - 1 do begin + for J := 0 to JsonNode.ChildNodes[I].ChildNodes.Count - 1 do begin + If (JsonNode.ChildNodes[I].ChildNodes[j].NodeType = nttext) and + (JsonNode.ChildNodes[I].ChildNodes[j].NodesubType = nstint32) and + (ALSameTextW(JsonNode.ChildNodes[I].ChildNodes[j].NodeName, ChildNodeName)) and + (JsonNode.ChildNodes[I].ChildNodes[j].int32 = ChildNodeValue) then begin + result := JsonNode.ChildNodes[I]; + exit; end; - - //delete the last entry from the path - if assigned(ObjectPaths) then ObjectPaths.Delete(ObjectPaths.Count - 1) - else NamePaths.Delete(NamePaths.Count - 1); - - //update BufferPos - BufferPos := BufferPos + 1; // ... } ... - // ^BufferPos - - //finallly exit from this procedure, everything was done - exit; - end; - {$ENDREGION} - - {$REGION 'Begin Object/Array Without NAME'} - // ... { .... - // ... [ .... - if c in ['{','['] then begin // ... { ... - // ^BufferPos - - //if we are not in sax mode - if NotSaxMode then begin + if Recurse then begin + result := ALFindJsonNodeByInt32ChildNodeValueW( + JsonNode.ChildNodes[I], + ChildNodeName, + ChildNodeValue, + Recurse); + if assigned(Result) then break; + end; + end; +end; - //if workingnode = nil then it's mean we are outside the containerNode - if not assigned(WorkingNode) then ALJSONDocErrorW(CALJSONParseError); +{*******************************************} +Function ALFindJsonNodeByTextChildNodeValueW( + const JsonNode:TALJSONNodeW; + Const ChildNodeName: String; + Const ChildNodeValue : String; + Const Recurse: Boolean = False): TALJSONNodeW; +var I, J : integer; +Begin + result := nil; + if not (JsonNode.NodeType in [ntObject, ntArray]) then Exit; + for I := 0 to JsonNode.ChildNodes.Count - 1 do begin + for J := 0 to JsonNode.ChildNodes[I].ChildNodes.Count - 1 do begin + If (JsonNode.ChildNodes[I].ChildNodes[j].NodeType = nttext) and + (JsonNode.ChildNodes[I].ChildNodes[j].NodesubType = nstText) and + (ALSameTextW(JsonNode.ChildNodes[I].ChildNodes[j].NodeName, ChildNodeName)) and + (JsonNode.ChildNodes[I].ChildNodes[j].text = ChildNodeValue) then begin + result := JsonNode.ChildNodes[I]; + exit; + end; + end; + if Recurse then begin + result := ALFindJsonNodeByTextChildNodeValueW( + JsonNode.ChildNodes[I], + ChildNodeName, + ChildNodeValue, + Recurse); + if assigned(Result) then break; + end; + end; +end; - //Node without name can be ONLY present inside an array node - if (CurrIndex < 0) or - (WorkingNode.nodetype <> ntarray) then ALJSONDocErrorW(CALJSONParseError); +{*********************} +{$ZEROBASEDSTRINGS OFF} +function ALJSONTryStrToRegExW(const S: String; out RegEx: String; out RegExOptions: TALPerlRegExOptions): boolean; +var P1: integer; + I: integer; +begin - //create the node according the the braket char and add it to the workingnode - if c = '{' then LNode := CreateNode('', ntObject) - else LNode := CreateNode('', ntarray); - try - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; + // regular expression in JSON must look like: /pattern/options + // list of valid options is: + // 'i' for case insensitive matching, + // 'm' for multiline matching, + // 'x' for verbose mode, + // 'l' to make \w, \W, etc. locale dependent, + // 's' for dotall mode ('.' matches everything), + // 'u' to make \w, \W, etc. match unicode. + result := false; - //set that the current working node will be now the new node newly created - WorkingNode := LNode; + // check that first character is / + if (S <> '') and (S[1] = '/') then begin - //update the path - if assigned(ObjectPaths) then ObjectPaths.AddObject(CurrIndex, WorkingNode) - else _AddItemToNamePath(CurrIndex, '', WorkingNode); + P1 := ALLastDelimiterW('/', S); + if P1 <> 1 then begin - end + //init Value + RegEx := ALCopyStr(S, 2, P1 - 2); + RegExOptions := []; - //if we are in sax mode - else begin + // loop on all the options characters + // to check if they are allowed. + for I := P1 + 1 to Length(S) do + case s[I] of + 'i': RegExOptions := RegExOptions + [preCaseLess]; + 'm': RegExOptions := RegExOptions + [preMultiLine]; + 'x': RegExOptions := RegExOptions + [preExtended]; + 'l':; + 's': RegExOptions := RegExOptions + [preSingleLine]; + 'u':; + else exit; + end; - //Node without name can be ONLY present inside an array node - if (CurrIndex < 0) or - (NamePaths.Count = 0) or - (TALJsonNodeType(NamePaths.Objects[Namepaths.Count - 1]) <> ntarray) then ALJSONDocErrorW(CALJSONParseError); + //set the result to true + result := true; - //update the path - if c = '{' then LNodeType := ntObject - else LNodeType := ntArray; - _AddItemToNamePath(CurrIndex, '', pointer(LNodeType)); + // check if it's compiling + //aRegEx := TALPerlRegEx.Create; + //try + // aRegEx.RegEx := Value.Expression; + // result := aRegEx.Compile(false{RaiseException}); + //finally + // ALFreeAndNil(aRegEx); + //end; - end; + end; - //call the DoParseStartObject/array event - if c = '{' then begin - if Assigned(fonParseStartObject) then _DoParseStartObject(''); - CurrIndex := -1; - end - else begin - if Assigned(fonParseStartArray) then _DoParseStartArray(''); - CurrIndex := 0; - end; + end; - //update BufferPos - BufferPos := BufferPos + 1; // ... { ... - // ^BufferPos +end; +{$IF defined(ALZeroBasedStringsON)} + {$ZEROBASEDSTRINGS ON} +{$IFEND} - //finallly exit from this procedure, everything was done - exit; +{*********************} +{$ZEROBASEDSTRINGS OFF} +{$WARN WIDECHAR_REDUCED OFF} +function ALJSONTryStrToBinaryW(const S: String; out Data: String; out Subtype: byte): boolean; +var LInt: integer; + Ln: integer; + P1, P2: integer; +begin - end; - {$ENDREGION} + // s must look like + // BinData(0, "JliB6gIMRuSphAD2KmhzgQ==") + // BinData ( 0 , "JliB6gIMRuSphAD2KmhzgQ==" ) + result := false; + Ln := length(s); + P1 := 1; - {$REGION 'extract the quoted name part'} - // "" : "" - // "name" : "value" - // "name" : 1.23 - // "name" : true - // "name" : false - // "name" : null - // "name" : ISODATE('1/1/2001') - // "name" : function(){return(new Date).getTime()}, ...} - // "name" : new Date(''Dec 03, 1924'') - // "name" : { ... } - // "name" : [ ... ] - // 'name' : '...' - // "value" - // 'value' - LQuoteChar := #0; - if c in ['"',''''] then begin // ... " ... - // ^BufferPos - LQuoteChar := c; // " - P1 := BufferPos + 1; // ... "...\"..." - // ^P1 - While P1 <= BufferLength do begin + while (P1 <= ln) and (s[P1] in [#9, ' ']) do inc(P1); - c := Buffer[P1]; + if (P1 + 6 > ln) or + (s[P1] <> 'B') or + (s[P1+1] <> 'i') or + (s[P1+2] <> 'n') or + (s[P1+3] <> 'D') or + (s[P1+4] <> 'a') or + (s[P1+5] <> 't') or + (s[P1+6] <> 'a') then exit; // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") + // ^ - If (c = '\') and - (P1 < BufferLength) and - (Buffer[P1 + 1] in ['\', LQuoteChar]) then inc(p1, 2) // ... "...\"..." - // ^^^P1 - else if c = LQuoteChar then begin - ALCopyStr(Buffer,CurrName,BufferPos + 1,P1-BufferPos - 1); - if DecodeJSONReferences then ALJavascriptDecodeV(CurrName); // ..."... - break; - end - else inc(P1); // ... "...\"..." - // ^^^^^^^^^P1 + P1 := p1 + 7{Length('BinData')}; // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") + // ^ + while (P1 <= ln) and (s[P1] in [#9, ' ']) do inc(P1); + if (P1 > ln) or (s[P1] <> '(') then exit; // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") + // ^P1 - end; - if P1 > BufferLength then ALJSONDocErrorW(CALJSONParseError); - BufferPos := P1 + 1; // ... "...\"..." - // ^^^^^^^^^^BufferPos - end - {$ENDREGION} + inc(P1); // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") + // ^P1 + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") + // ^P1 + if (P1 > ln) then exit; - {$REGION 'extract the unquoted name part'} - // name : "value" - // name : 1.23 - // name : true - // name : false - // name : null - // name : ISODATE('1/1/2001') - // name : function(){return(new Date).getTime()}, ...} - // name : new Date('Dec 03, 1924') - // name : { ... } - // name : [ ... ] - // 1.23 - // true - // false - // null - // ISODATE('1/1/2001') - // function(){return(new Date).getTime()}, ...} - // new Date('Dec 03, 1924') - else begin + P2 := P1; + while (P2 <= ln) and (S[P2] in ['0'..'9']) do inc(P2); // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") + // ^P2 + if P2 > ln then exit; + if not ALTryStrToInt(ALCopyStr(S,P1,P2-P1), LInt) then Exit; + subtype := LInt; - LInSingleQuote := False; - LInDoubleQuote := False; - LInSquareBracket := 0; - LInRoundBracket := 0; - LInCurlyBracket := 0; + p1 := P2; + while (P1 <= ln) and (s[P1] in [#9, ' ']) do inc(P1); + if (P1 > ln) or (s[P1] <> ',') then exit; // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") + // ^P2 - While (BufferPos <= BufferLength) do begin - If Buffer[BufferPos] <= ' ' then inc(bufferPos) - else break; - end; - if BufferPos > BufferLength then ALJSONDocErrorW(CALJSONParseError); + inc(P1); // BinData( 0 , "JliB6gIMRuSphAD2KmhzgQ==") + // ^P1 + while (P1 <= ln) and (s[P1] in [#9, ' ']) do inc(P1); + if (P1 > ln) or (not (s[P1] in ['"',''''])) then exit; // BinData(0, "JliB6gIMRuSphAD2KmhzgQ==") + // ^P1 - P1 := BufferPos; // ... new Date('Dec 03, 1924'), .... - // ^P1 - While (P1 <= BufferLength) do begin + P2 := length(s); + while (P2 > p1) and (s[P2] in [#9, ' ']) do dec(P2); + if (P2 <= p1) or (s[P2] <> ')') then exit; // BinData(0, "JliB6gIMRuSphAD2KmhzgQ==") + // ^P2 - c := Buffer[P1]; + dec(p2); + if (P2 <= p1) then exit; + while (P2 > p1) and (s[P2] in [#9, ' ']) do dec(P2); + if (P2 <= p1) or (s[P2] <> s[P1]) then exit; // BinData(0, "JliB6gIMRuSphAD2KmhzgQ==") + // ^P2 - if (not LInSingleQuote) and - (not LInDoubleQuote) and - (LInSquareBracket = 0) and - (LInRoundBracket = 0) and - (LInCurlyBracket = 0) and - (c in [',', '}', ']', ':']) then begin - P2 := P1-1; - While P2 >= BufferPos do begin - If Buffer[P2] <= ' ' then dec(P2) - else break; - end; - ALCopyStr(Buffer,CurrName,BufferPos,P2-BufferPos+1); // new Date('Dec 03, 1924') - break; - end - else if (c = '"') then begin - if (P1 <= 1) or - (Buffer[P1 - 1] <> '\') then LInDoubleQuote := (not LInDoubleQuote) and (not LInSingleQuote); - end - else if (c = '''') then begin - if (P1 <= 1) or - (Buffer[P1 - 1] <> '\') then LInSingleQuote := (not LInSingleQuote) and (not LInDoubleQuote) - end - else if (not LInSingleQuote) and - (not LInDoubleQuote) then begin - if (c = '[') then inc(LInSquareBracket) - else if (c = ']') then dec(LInSquareBracket) - else if (c = '(') then inc(LInRoundBracket) - else if (c = ')') then dec(LInRoundBracket) - else if (c = '}') then inc(LInCurlyBracket) - else if (c = '{') then dec(LInCurlyBracket); - end; + inc(p1); + Data := ALCopyStr(s, P1, P2-P1); // notmally i would like to do ALBase64DecodeString() + // and return in data the byte string but this is not possible + // because the source byte array is probably not a multiple of 2 + // and unicode string is obligatory a multiple of 2 - inc(P1); // ... new Date('Dec 03, 1924'), .... - // ^^^^^^^^^^^^^^^^^^^^^^^^^P1 + // set the result + result := true; - end; - if P1 > BufferLength then ALJSONDocErrorW(CALJSONParseError); - BufferPos := P1; // ... new Date('Dec 03, 1924'), .... - // ^BufferPos +end; +{$WARN WIDECHAR_REDUCED ON} +{$IF defined(ALZeroBasedStringsON)} + {$ZEROBASEDSTRINGS ON} +{$IFEND} - end; - {$ENDREGION} +{*********************} +{$ZEROBASEDSTRINGS OFF} +{$WARN WIDECHAR_REDUCED OFF} +function ALJSONTryStrToDateTimeW(const S: String; out Value: TDateTime): Boolean; +var LQuoteChar: Char; + LTmpStr: String; + LTmpLn: integer; + P1, P2: integer; + Ln: integer; +begin - {$REGION 'extract the name value separator part'} - LNameValueSeparator := #0; - While (BufferPos <= BufferLength) do begin - If Buffer[BufferPos] <= ' ' then inc(BufferPos) - else begin - LNameValueSeparator := Buffer[BufferPos]; - break; - end; - end; - if BufferPos > BufferLength then ALJSONDocErrorW(CALJSONParseError); // .... : .... - // ^BufferPos - {$ENDREGION} + // s must look like + // new Date('yyyy-mm-ddThh:nn:ss.zzzZ') + // Date('yyyy-mm-ddThh:nn:ss.zzzZ') + // new ISODate('yyyy-mm-ddThh:nn:ss.zzzZ') + // ISODate('yyyy-mm-ddThh:nn:ss.zzzZ') + result := false; + Ln := length(s); + if ALPosW('new', s) = 1 then P1 := 4{length('new') + 1} // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) + // ^P1 + else P1 := 1;// Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) + // ^P1 + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 <= ln - 3) and + (S[P1] = 'D') and + (S[P1+1] = 'a') and + (S[P1+2] = 't') and + (S[P1+3] = 'e') then inc(p1, 4) // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) + // ^P1 + else if (P1 <= ln - 6) and + (S[P1] = 'I') and + (S[P1+1] = 'S') and + (S[P1+2] = 'O') and + (S[P1+3] = 'D') and + (S[P1+4] = 'a') and + (S[P1+5] = 't') and + (S[P1+6] = 'e') then inc(p1, 7) // ISODate ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) + // ^P1 + else exit; + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 > ln) or (S[P1] <> '(') then exit; // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) + // ^P1 + inc(P1); // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) + // ^P1 + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 > ln) or (not (S[P1] in ['''','"'])) then exit; // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) + // ^P1 + LQuoteChar := S[P1]; // " + inc(p1); // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) + // ^P1 + P2 := P1; + while (P1 <= ln) and (S[P1] <> LQuoteChar) do inc(P1); + if (P1 > ln) then exit; // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) + // ^P1 + dec(P1); + if S[P1] <> 'Z' then exit; + LTmpStr := ALCopyStr(S,P2,P1-P2); // yyyy-mm-ddThh:nn:ss.zzz - {$REGION 'if aNameValueSeparator is absent then it is just a value'} - if LNameValueSeparator <> ':' then begin + P2 := 1; + LTmpLn := length(LTmpStr); + while (P2 <= LTmpLn) and (LTmpStr[P2] <> 'T') do inc(P2); + if P2 > LTmpLn then exit; + LTmpStr[P2] := ' '; // yyyy-mm-dd hh:nn:ss.zzz - //Node without name can be ONLY present inside an array node - if NotSaxMode then begin - if not assigned(WorkingNode) then ALJSONDocErrorW(CALJSONParseError); - if (CurrIndex < 0) or - (WorkingNode.nodetype <> ntarray) then ALJSONDocErrorW(CALJSONParseError); - end - else begin - if (CurrIndex < 0) or - (NamePaths.Count = 0) or - (TALJSONNodeType(NamePaths.Objects[Namepaths.Count - 1]) <> ntarray) then ALJSONDocErrorW(CALJSONParseError); - end; + result := ALTryStrToDateTime(LTmpStr, Value, ALJsonISODateFormatSettingsW); + if not result then exit; - //create the node - _createNode(CurrIndex,'',CurrName,LQuoteChar in ['"','''']); + inc(p1,2); // new Date ( 'yyyy-mm-ddThh:nn:ss.zzzZ' ) + // ^P1 + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 <> ln) or (S[P1] <> ')') then begin + result := false; + exit; + end; - //increase the CurrIndex - inc(CurrIndex); +end; +{$WARN WIDECHAR_REDUCED ON} +{$IF defined(ALZeroBasedStringsON)} + {$ZEROBASEDSTRINGS ON} +{$IFEND} - //finallly exit from this procedure, everything was done - exit; +{*********************} +{$ZEROBASEDSTRINGS OFF} +{$WARN WIDECHAR_REDUCED OFF} +// ObjectId is a 12-byte BSON type, constructed using: +// a 4-byte value representing the seconds since the Unix epoch, +// a 3-byte machine identifier, +// a 2-byte process id, and +// a 3-byte counter, starting with a random value. +function ALJSONTryStrToObjectIDW(const S: String; out Value: String): Boolean; +var LBinValue: Tbytes; + LQuoteChar: Char; + P1: integer; + Ln: integer; +begin - end; - {$ENDREGION} + // s must look like + // ObjectId ( "507f1f77bcf86cd799439011" ) + result := false; + if ALPosW('ObjectId', S) <> 1 then exit; + Ln := length(s); + P1 := 9{length('ObjectId') + 1}; // ObjectId ( "507f1f77bcf86cd799439011" ) + // ^P1 + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 > ln) or (S[P1] <> '(') then exit; // ObjectId ( "507f1f77bcf86cd799439011" ) + // ^P1 + inc(p1); // ObjectId ( "507f1f77bcf86cd799439011" ) + // ^P1 + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 > ln) or (not (S[P1] in ['''','"'])) then exit; // ObjectId ( "507f1f77bcf86cd799439011" ) + // ^P1 + LQuoteChar := S[P1]; // " + inc(p1); // ObjectId ( "507f1f77bcf86cd799439011" ) + // ^P1 + if (P1 + 23{(length(aObjectIDhex)) - 1} > ln) then exit; + Value := ALCopyStr(S,P1,24{length(aObjectIDhex)}); // 507f1f77bcf86cd799439011 + inc(P1, 24{length(aObjectIDhex)}); // ObjectId ( "507f1f77bcf86cd799439011" ) + // ^P1 + if (P1 > ln) or (S[P1] <> LQuoteChar) then exit; // ObjectId ( "507f1f77bcf86cd799439011" ) + // ^P1 + inc(p1); // ObjectId ( "507f1f77bcf86cd799439011" ) + // ^P1 + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 <> ln) or (S[P1] <> ')') then exit; // ObjectId ( "507f1f77bcf86cd799439011" ) + // ^P1 + //check that 507f1f77bcf86cd799439011 is a good hex value + result := ALTryHexToBin(Value, LBinValue) and + (length(LBinValue) = 12); - {$REGION 'remove the blank space between the name valueeparator and the value'} - inc(BufferPos); // ... : .... - // ^BufferPos - While (BufferPos <= BufferLength) do begin - If Buffer[BufferPos] <= ' ' then inc(BufferPos) - else break; - end; - if BufferPos > BufferLength then ALJSONDocErrorW(CALJSONParseError); // .... " .... - // ^BufferPos - {$ENDREGION} +end; +{$WARN WIDECHAR_REDUCED ON} +{$IF defined(ALZeroBasedStringsON)} + {$ZEROBASEDSTRINGS ON} +{$IFEND} + +{*********************} +{$ZEROBASEDSTRINGS OFF} +{$WARN WIDECHAR_REDUCED OFF} +function ALJSONTryStrToTimestampW(const S: String; out Value: TALBSONTimestamp): Boolean; +var P1, P2: integer; + LArgs: String; + LArg1: integer; + LArg2: integer; + Ln: integer; +begin - {$REGION 'init current char (c)'} - c := Buffer[BufferPos]; - {$ENDREGION} + // s must look like + // Timestamp(0, 0) + result := false; + if ALPosW('Timestamp', S) <> 1 then Exit; + Ln := length(s); + P1 := 10{Length('Timestamp') + 1}; // Timestamp(0, 0) + // ^ + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 > ln) or (S[P1] <> '(') then exit; // Timestamp(0, 0) + // ^P1 + P2 := ALPosW(')', S, P1); + if P2 <> ln then exit; // Timestamp(0, 0) + // ^P2 + LArgs := ALCopyStr(S, P1+1, P2 - P1-1); // 0, 0 - {$REGION 'if the value is an object/array'} - // name : { ... } - // name : [ ... ] - if c in ['{','['] then begin // ... { ... - // ^BufferPos + // take arguments of function Timestamp + P1 := ALPosW(',', LArgs); + if not ALTryStrToInt(ALTrim(ALCopyStr(LArgs, 1, P1 - 1)), LArg1) then Exit; + if not ALTryStrToInt(ALTrim(ALCopyStr(LArgs, P1 + 1, maxint)), LArg2) then Exit; - //if we are not in sax mode - if NotSaxMode then begin + // build result + result := true; + Value.W1 := LArg1; // higher 4 bytes - increment + Value.W2 := LArg2; // lower 4 bytes - timestamp - //if workingnode = nil then it's mean we are outside the containerNode - if not assigned(WorkingNode) then ALJSONDocErrorW(CALJSONParseError); +end; +{$WARN WIDECHAR_REDUCED ON} +{$IF defined(ALZeroBasedStringsON)} + {$ZEROBASEDSTRINGS ON} +{$IFEND} - //Node withe name MUST be ONLY present inside an object node - if (CurrIndex >= 0) or - (WorkingNode.nodetype <> ntObject) then ALJSONDocErrorW(CALJSONParseError); +{*********************} +{$ZEROBASEDSTRINGS OFF} +{$WARN WIDECHAR_REDUCED OFF} +function ALJSONTryStrToInt32W(const S: String; out Value: integer): Boolean; +var LTmpStr: String; + LQuoteChar: Char; + P1, P2: integer; + Ln: integer; +begin - //create the node according the the braket char and add it to the workingnode - if c = '{' then LNode := CreateNode(CurrName, ntObject) - else LNode := CreateNode(CurrName, ntarray); - try - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; + // s must look like + // NumberInt ( "12391293" ) + // NumberInt ( 12391293 ) + // 12391293 + result := ALTryStrToInt(S, Value); + if result then exit; + if ALPosW('NumberInt', S) <> 1 then exit; + Ln := length(s); + P1 := 10{length('NumberInt') + 1}; // NumberInt ( "12391293" ) + // ^P1 + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 > ln) or (S[P1] <> '(') then exit; // NumberInt ( "12391293" ) + // ^P1 + inc(p1); // NumberInt ( "12391293" ) + // ^P1 + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 > ln) then exit + else if (not (S[P1] in ['''','"'])) then begin // NumberInt ( 12391293 ) + // ^P1 + P2 := P1+1; + while (P2 <= ln) and (S[P2] in ['0'..'9']) do inc(P2); // NumberInt ( 12391293 ) + // ^P2 + if P2 > ln then exit; + LTmpStr := ALCopyStr(S,P1,P2-P1); // 12391293 + P1 := P2; // NumberInt ( 12391293 ) + // ^P2 - //set that the current working node will be now the new node newly created - WorkingNode := LNode; + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 <> ln) or (S[P1] <> ')') then exit; // NumberInt ( "12391293" ) + // ^P1 + end + else begin // NumberInt ( "12391293" ) + // ^P1 - //update the path - if assigned(ObjectPaths) then ObjectPaths.AddObject(-1, WorkingNode) - else _AddItemToNamePath(-1, CurrName, WorkingNode); + LQuoteChar := S[P1]; // " + inc(p1); // NumberInt ( "12391293" ) + // ^P1 + P2 := P1; + while P2 <= Ln do + if S[P2] = LQuoteChar then break + else inc(P2); + if P2 > ln then exit; + LTmpStr := ALCopyStr(S,P1,P2-P1); // 12391293 + P1 := P2 + 1; // NumberInt ( "12391293" ) + // ^P1 + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 <> ln) or (S[P1] <> ')') then exit; // NumberInt ( "12391293" ) + // ^P1 + end; - end + //convert 12391293 to integer + result := ALTryStrToInt(LTmpStr, Value); - //if we are in sax mode - else begin +end; +{$WARN WIDECHAR_REDUCED ON} +{$IF defined(ALZeroBasedStringsON)} + {$ZEROBASEDSTRINGS ON} +{$IFEND} - //Node withe name MUST be ONLY present inside an object node - if (CurrIndex >= 0) or - (NamePaths.Count = 0) or - (TALJsonNodeType(NamePaths.Objects[NamePaths.Count - 1]) <> ntobject) then ALJSONDocErrorW(CALJSONParseError); +{*********************} +{$ZEROBASEDSTRINGS OFF} +{$WARN WIDECHAR_REDUCED OFF} +function ALJSONTryStrToInt64W(const S: String; out Value: int64): Boolean; +var LTmpStr: String; + LQuoteChar: Char; + P1, P2: integer; + Ln: integer; +begin - //update the path - if c = '{' then LNodeType := ntObject - else LNodeType := ntArray; - _AddItemToNamePath(-1, CurrName, pointer(LNodeType)); + // s must look like + // NumberLong ( "12391293" ) + // NumberLong ( 12391293 ) + // 12391293 + result := ALTryStrToInt64(S, Value); + if result then exit; + if ALPosW('NumberLong', S) <> 1 then exit; + Ln := length(s); + P1 := 11{length('NumberLong') + 1}; // NumberLong ( "12391293" ) + // ^P1 + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 > ln) or (S[P1] <> '(') then exit; // NumberLong ( "12391293" ) + // ^P1 + inc(p1); // NumberLong ( "12391293" ) + // ^P1 + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 > ln) then exit + else if (not (S[P1] in ['''','"'])) then begin // NumberLong ( 12391293 ) + // ^P1 + P2 := P1+1; + while (P2 <= ln) and (S[P2] in ['0'..'9']) do inc(P2); // NumberLong ( 12391293 ) + // ^P2 + if P2 > ln then exit; + LTmpStr := ALCopyStr(S,P1,P2-P1); // 12391293 + P1 := P2; // NumberLong ( 12391293 ) + // ^P2 - end; + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 <> ln) or (S[P1] <> ')') then exit; // NumberLong ( "12391293" ) + // ^P1 + end + else begin // NumberLong ( "12391293" ) + // ^P1 - //call the DoParseStartObject/array event and update the CurrIndex if it's an array - if c = '{' then begin - if Assigned(fonParseStartObject) then _DoParseStartObject(CurrName) - end - else begin - if Assigned(fonParseStartArray) then _DoParseStartArray(CurrName); - CurrIndex := 0; - end; + LQuoteChar := S[P1]; // " + inc(p1); // NumberLong ( "12391293" ) + // ^P1 + P2 := P1; + while P2 <= Ln do + if S[P2] = LQuoteChar then break + else inc(P2); + if P2 > ln then exit; + LTmpStr := ALCopyStr(S,P1,P2-P1); // 12391293 + P1 := P2 + 1; // NumberLong ( "12391293" ) + // ^P1 + while (P1 <= ln) and (S[P1] in [#9, ' ']) do inc(P1); + if (P1 <> ln) or (S[P1] <> ')') then exit; // NumberLong ( "12391293" ) + // ^P1 + end; - //update BufferPos - BufferPos := BufferPos + 1; // ... { ... - // ^BufferPos + //convert 12391293 to integer + result := ALTryStrToInt64(LTmpStr, Value); - //finallly exit from this procedure, everything was done - exit; +end; +{$WARN WIDECHAR_REDUCED ON} +{$IF defined(ALZeroBasedStringsON)} + {$ZEROBASEDSTRINGS ON} +{$IFEND} - end; - {$ENDREGION} +{*****************************************************} +procedure ALJSONDocErrorW(const Msg: String); overload; +begin + raise EALJSONDocError.Create(Msg); +end; - {$REGION 'if the value is a quoted string'} - // name : "value" - // name : 'value' - LQuoteChar := #0; - if c in ['"',''''] then begin // ... " ... - // ^BufferPos +{*********************************************************************************} +procedure ALJSONDocErrorW(const Msg: String; const Args: array of const); overload; +begin + raise EALJSONDocError.CreateFmt(Msg, Args); +end; - LQuoteChar := c; // " - P1 := BufferPos + 1; // ... "...\"..." - // ^P1 - While P1 <= BufferLength do begin +{**************************************************************************************} +procedure ALJSONDocErrorW(const Msg: String; const NodeType: TalJsonNodeType); overload; +begin + case NodeType of + ntObject: ALJSONDocErrorW(Msg, ['ntObject']); + ntArray: ALJSONDocErrorW(Msg, ['ntArray']); + ntText: ALJSONDocErrorW(Msg, ['ntText']); + else ALJSONDocErrorW(cAlJSONInvalidNodeType); + end; +end; - c := Buffer[P1]; +{********************************************************************************************} +{Call CreateNode to create a new generic JSON node. The resulting node does not have a parent, + but can be added to the ChildNodes list of any node in the document.} +function ALCreateJSONNodeW(const NodeName: String; NodeType: TALJSONNodeType): TALJSONNodeW; +begin + case NodeType of + ntObject: Result := TALJSONObjectNodeW.Create(NodeName); + ntArray: Result := TALJSONArrayNodeW.Create(NodeName); + ntText: Result := TALJSONTextNodeW.Create(NodeName); + else begin + Result := nil; //for hide warning + ALJSONDocErrorW(cAlJSONInvalidNodeType); + end; + end; +end; - If (c = '\') and - (P1 < BufferLength) and - (Buffer[P1 + 1] in ['\', LQuoteChar]) then inc(p1, 2) // ... "...\"..." - // ^^^P1 - else if c = LQuoteChar then begin - ALCopyStr(Buffer,currValue,BufferPos + 1,P1-BufferPos - 1); - if DecodeJSONReferences then ALJavascriptDecodeV(currValue); // ..."... - break; - end - else inc(P1); // ... "...\"..." - // ^^^^^^^^^P1 +{*********************} +{$ZEROBASEDSTRINGS OFF} +class function TALJSONDocumentW.DetectNodeTypeFromJSon(const Buffer: String): TALJSONNodeType; +Var BufferLength: Integer; + BufferPos: Integer; + c: Char; +Begin - end; - if P1 > BufferLength then ALJSONDocErrorW(CALJSONParseError); - BufferPos := P1 + 1; // ... "...\"..." - // ^^^^^^^^^^BufferPos + //init result + result := ntText; - end - {$ENDREGION} + //init Buffer + BufferLength := length(Buffer); + BufferPos := 1; - {$REGION 'if the value is a UNquoted string'} - // name : 1.23 - // name : true - // name : false - // name : null - // name : ISODATE('1/1/2001') - // name : function(){return(new Date).getTime()}, ...} - // name : new Date(''Dec 03, 1924'') - // name : /test/i + //-- + While (BufferPos <= BufferLength) do begin + c := Buffer[BufferPos]; + If c <= ' ' then inc(bufferPos) else begin + if c = '{' then result := ntObject + else if c = '[' then result := ntarray + else result := ntText; + break; + end; + end; - LInSingleQuote := False; - LInDoubleQuote := False; - LInSlashQuote := False; - LInSquareBracket := 0; - LInRoundBracket := 0; - LInCurlyBracket := 0; - - While (BufferPos <= BufferLength) do begin - If Buffer[BufferPos] <= ' ' then inc(bufferPos) - else break; - end; - if BufferPos > BufferLength then ALJSONDocErrorW(CALJSONParseError); - - P1 := BufferPos; // ... new Date('Dec 03, 1924'), .... - // ^P1 - While (P1 <= BufferLength) do begin +end; +{$IF defined(ALZeroBasedStringsON)} + {$ZEROBASEDSTRINGS ON} +{$IFEND} - c := Buffer[P1]; +{***************************************************} +class function TALJSONDocumentW.Create: TALJSONNodeW; +begin + result := ALCreateJSONNodeW('', ntObject); +end; - if (not LInSingleQuote) and - (not LInDoubleQuote) and - (not LInSlashQuote) and - (LInSquareBracket = 0) and - (LInRoundBracket = 0) and - (LInCurlyBracket = 0) and - (c in [',', '}', ']']) then begin - P2 := P1-1; - While P2 >= BufferPos do begin - If Buffer[P2] <= ' ' then dec(P2) - else break; - end; - ALCopyStr(Buffer,currValue,BufferPos,P2-BufferPos+1); // new Date('Dec 03, 1924') - break; - end - else if (c = '"') then begin - if (P1 <= 1) or - (Buffer[P1 - 1] <> '\') then LInDoubleQuote := (not LInDoubleQuote) and (not LInSingleQuote) and (not LInSlashQuote); - end - else if (c = '''') then begin - if (P1 <= 1) or - (Buffer[P1 - 1] <> '\') then LInSingleQuote := (not LInSingleQuote) and (not LInDoubleQuote) and (not LInSlashQuote); - end - else if (c = '/') then begin - if (P1 <= 1) or - (Buffer[P1 - 1] <> '\') then LInSlashQuote := (not LInSingleQuote) and (not LInDoubleQuote) and (not LInSlashQuote); - end - else if (not LInSingleQuote) and - (not LInDoubleQuote) and - (not LInSlashQuote) then begin - if (c = '[') then inc(LInSquareBracket) - else if (c = ']') then dec(LInSquareBracket) - else if (c = '(') then inc(LInRoundBracket) - else if (c = ')') then dec(LInRoundBracket) - else if (c = '}') then inc(LInCurlyBracket) - else if (c = '{') then dec(LInCurlyBracket); - end; +{**********************************************************************************************************************************************} +class function TALJSONDocumentW.CreateFromJSONString(const Str: String; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeW; +begin + var LNodeType := DetectNodeTypeFromJSON(Str); + if LNodeType in [ntObject, ntArray] then result := ALCreateJSONNodeW('', LNodeType) + else AlJSONDocErrorW(cALJSONParseError); + try + result.LoadFromJSONString(Str, Options); + except + ALFreeAndNil(Result); + raise; + end; +end; - inc(P1); // ... new Date('Dec 03, 1924'), .... - // ^^^^^^^^^^^^^^^^^^^^^^^^^P1 +{**************************************************************************************************************************************************} +class function TALJSONDocumentW.CreateFromJSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeW; +begin + result := CreateFromJSONString(ALGetStringFromStream(Stream, TEncoding.UTF8), Options); +end; - end; - if P1 > BufferLength then ALJSONDocErrorW(CALJSONParseError); - BufferPos := P1; // ... new Date('Dec 03, 1924'), .... - // ^BufferPos +{*************************************************************************************************************************************************} +class function TALJSONDocumentW.CreateFromJSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeW; +Var LfileStream: TfileStream; +Begin + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + Result := CreateFromJSONStream(LfileStream, Options); + finally + ALFreeAndNil(LfileStream); + end; +end; +{***********************************************************************************************************************************************} +class function TALJSONDocumentW.CreateFromBSONBytes(const Bytes: Tbytes; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeW; +begin + result := ALCreateJSONNodeW('', ntObject); + try + result.LoadFromBSONBytes(Bytes, Options); + except + ALFreeAndNil(Result); + raise; + end; +end; - end; - {$ENDREGION} +{**************************************************************************************************************************************************} +class function TALJSONDocumentW.CreateFromBSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeW; +begin + result := CreateFromBSONBytes(ALGetBytesFromStream(Stream), Options); +end; - {$REGION 'create the named text node'} +{*************************************************************************************************************************************************} +class function TALJSONDocumentW.CreateFromBSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]): TALJSONNodeW; +Var LfileStream: TfileStream; +Begin + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + result := CreateFromBSONStream(LfileStream, Options); + finally + ALFreeAndNil(LfileStream); + end; +end; - //Node withe name MUST be ONLY present inside an object node - if NotSaxMode then begin - if not assigned(WorkingNode) then ALJSONDocErrorW(CALJSONParseError); - if (CurrIndex >= 0) or - (WorkingNode.nodetype <> ntObject) then ALJSONDocErrorW(CALJSONParseError); - end - else begin - if (CurrIndex >= 0) or - (NamePaths.Count = 0) or - (TALJSONNodeType(NamePaths.Objects[Namepaths.Count - 1]) <> ntObject) then ALJSONDocErrorW(CALJSONParseError); - end; +{***********************************************} +class procedure TALJSONDocumentW.ParseJSONString( + const Str: String; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); +begin + var LJsonNode: TALJsonNodeW; + var LNodeType := DetectNodeTypeFromJSON(Str); + if LNodeType in [ntObject, ntArray] then LJsonNode := ALCreateJSONNodeW('', LNodeType) + else AlJSONDocErrorW(cALJSONParseError); + try + LJsonNode.ParseJSONString( + Str, + OnParseText, + OnParseStartObject, + OnParseEndObject, + OnParseStartArray, + OnParseEndArray, + Options); + finally + ALFreeAndNil(LJsonNode); + end; +end; - //create the node - _createNode(currIndex,CurrName,CurrValue,LQuoteChar in ['"','''']); +{***********************************************} +class procedure TALJSONDocumentW.ParseJSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); +begin + ParseJSONString( + ALGetStringFromStream(Stream, TEncoding.UTF8), + OnParseText, + OnParseStartObject, + OnParseEndObject, + OnParseStartArray, + OnParseEndArray, + Options); +end; - {$ENDREGION} +{*********************************************} +class procedure TALJSONDocumentW.ParseJSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); +Var LfileStream: TfileStream; +Begin + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + ParseJSONStream( + LfileStream, + OnParseText, + OnParseStartObject, + OnParseEndObject, + OnParseStartArray, + OnParseEndArray, + Options); + finally + ALFreeAndNil(LfileStream); + end; +end; +{**********************************************} +class procedure TALJSONDocumentW.ParseBSONBytes( + const Bytes: Tbytes; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); +begin + var LJsonNode := ALCreateJSONNodeW('', ntObject); + try + LJsonNode.ParseBSONBytes( + Bytes, + OnParseText, + OnParseStartObject, + OnParseEndObject, + OnParseStartArray, + OnParseEndArray, + Options); + finally + ALFreeAndNil(LJsonNode); end; +end; -var InCommentLine: integer; - c: Char; +{***********************************************} +class procedure TALJSONDocumentW.ParseBSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); +begin + ParseBSONBytes( + ALGetBytesFromStream(Stream), + OnParseText, + OnParseStartObject, + OnParseEndObject, + OnParseStartArray, + OnParseEndArray, + Options); +end; +{*********************************************} +class procedure TALJSONDocumentW.ParseBSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); +Var LfileStream: TfileStream; Begin + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + ParseBSONStream( + LfileStream, + OnParseText, + OnParseStartObject, + OnParseEndObject, + OnParseStartArray, + OnParseEndArray, + Options); + finally + ALFreeAndNil(LfileStream); + end; +end; - // - // NOTE: the childNodes of the ContainerNode - // must have been cleared by the calling function! - // - // NOTE: ContainerNode must have fDocument assigned - // - // NOTE: ContainerNode must be ntobject or nil (sax mode) - // +{**********************************************************} +{Creates the object that implements the ChildNodes property} +function TALJSONNodeW.CreateChildList: TALJSONNodeListW; +begin + result := TALJSONNodeListW.Create(Self); +end; - //event fonParseStartDocument - DoParseStartDocument; +{********************************************} +{Get Childnode without create it if not exist} +function TALJSONNodeW.InternalGetChildNodes: TALJSONNodeListW; +begin + Result := nil; //virtual; +end; - //init WorkingNode and NotSaxMode, CurrIndex and DecodeJSONReferences - WorkingNode := ContainerNode; - NotSaxMode := assigned(ContainerNode); - DecodeJSONReferences := not (poIgnoreControlCharacters in ParseOptions); - CurrIndex := -1; +{****************************************************} +function TALJSONNodeW.GetChildNodes: TALJSONNodeListW; +begin + Result := nil; // hide warning + ALJSONDocErrorW(CALJsonOperationError,GetNodeType) +end; - //init ObjectPaths or NamePaths - if (NotSaxMode) and - (not assigned(fonParseText)) and - (not assigned(FonParseStartObject)) and - (not assigned(FonParseEndObject)) and - (not assigned(FonParseStartArray)) and - (not assigned(FonParseEndArray)) then begin - ObjectPaths := TALIntegerList.Create(false{OwnsObjects}); - NamePaths := nil; - end - else begin - ObjectPaths := nil; - NamePaths := TALNVStringListW.Create; - end; - Try +{******************************************************************} +procedure TALJSONNodeW.SetChildNodes(const Value: TALJSONNodeListW); +begin + ALJSONDocErrorW(CALJsonOperationError,GetNodeType) +end; - //init Buffer - BufferLength := length(Buffer); - BufferPos := 1; +{***********************************************************************} +function TALJSONNodeW.GetChildNode(const nodeName: String): TALJSONNodeW; +begin + result := ChildNodes.findNode(nodeName); +end; - //add first node in ObjectPaths/NamePaths - if assigned(ObjectPaths) then ObjectPaths.AddObject(-1, WorkingNode) - else begin - if NotSaxMode then _AddNameItemToNamePath('', WorkingNode) - else _AddNameItemToNamePath('', pointer(ntObject)); - end; +{*************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueText(const nodeName: String; const default: String): String; +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetText(default); +end; + +{**************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueFloat(const nodeName: String; const default: Double): Double; +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetFloat(default); +end; - //skip the first { - While (BufferPos <= BufferLength) do begin - c := Buffer[BufferPos]; - If c <= ' ' then inc(bufferPos) - else begin - if c <> '{' then ALJSONDocErrorW(cALJSONParseError); - inc(bufferPos); - break; - end; - end; +{***********************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueDateTime(const nodeName: String; const default: TDateTime): TDateTime; +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetDateTime(default); +end; - //analyze all the nodes - if poAllowComments in ParseOptions then begin - InCommentLine := 0; - While (BufferPos <= BufferLength) do begin - c := Buffer[BufferPos]; - If (InCommentLine = 0) and ((c <= ' ') or (c = ',')) then inc(bufferPos) - else if (InCommentLine <= 1) and (c = '/') then begin - inc(InCommentLine); - inc(bufferPos); - end - else if (InCommentLine = 2) then begin - if ((c = #13) or (c = #10)) then InCommentLine := 0; - inc(bufferPos); - end - else begin - if InCommentLine = 1 then begin - InCommentLine := 0; - dec(BufferPos); - end; - AnalyzeNode; - end; - end; - end - else begin - While (BufferPos <= BufferLength) do begin - c := Buffer[BufferPos]; - If (c <= ' ') or (c = ',') then inc(bufferPos) - else AnalyzeNode; - end; - end; +{**************************************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueTimestamp(const nodeName: String; const default: TALBSONTimestamp): TALBSONTimestamp; +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetTimestamp(default); +end; - //some tags are not closed - if assigned(ObjectPaths) then begin - if ObjectPaths.Count > 0 then ALJSONDocErrorW(cALJSONParseError); - end - else begin - if NamePaths.Count > 0 then ALJSONDocErrorW(cALJSONParseError); - end; +{****************************************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueObjectID(const nodeName: String; const default: String): String; // return a hex string +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetObjectID(default); +end; - //mean the node was not update (empty stream?) or not weel closed - if WorkingNode <> nil then ALJSONDocErrorW(cALJSONParseError); +{****************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueInt32(const nodeName: String; const default: Integer): Integer; +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetInt32(default); +end; - //event fonParseEndDocument - DoParseEndDocument; +{************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueInt64(const nodeName: String; const default: Int64): Int64; +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetInt64(default); +end; - finally +{***************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueBool(const nodeName: String; const default: Boolean): Boolean; +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetBool(default); +end; - //free ObjectPaths/NamePaths - if assigned(ObjectPaths) then ALFreeAndNil(ObjectPaths) - else ALFreeAndNil(NamePaths); +{*******************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueJavascript(const nodeName: String; const default: String): String; +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetJavascript(default); +end; - end; +{**************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueRegEx(const nodeName: String; const default: String): String; +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetRegEx(default); +end; +{***********************************************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueRegExOptions(const nodeName: String; const default: TALPerlRegExOptions): TALPerlRegExOptions; +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetRegExOptions(default); end; -{$WARN WIDECHAR_REDUCED ON} -{$IF defined(ALZeroBasedStringsON)} - {$ZEROBASEDSTRINGS ON} -{$IFEND} -{*************************************************************} -{Last version of the spec: http://bsonspec.org/#/specification} -procedure TALJSONDocumentW.ParseBSON( - const Buffer: Tbytes; - const ContainerNode: TALJSONNodeW); +{**************************************************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueBinary(const nodeName: String; const default: String): String; // return a base64 encoded string +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetBinary(default); +end; -Var BufferLength: Integer; - BufferPos: Integer; - CurrName: String; - NotSaxMode: Boolean; - WorkingNode: TALJSONNodeW; - NamePaths: TALStringListW; - ObjectPaths: TObjectList; +{******************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueBinarySubType(const nodeName: String; const default: byte): byte; +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := default + else result := LNode.GetBinarySubType(default); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function GetPathStr(Const ExtraItems: String = ''): String; - var I, L, P, Size: Integer; - LB: Char; - S: String; - begin - LB := PathSeparator; - Size := length(ExtraItems); - if size <> 0 then Inc(Size, 1{length(LB)}); - for I := 1 to NamePaths.Count - 1 do Inc(Size, Length(NamePaths[I]) + 1{length(LB)}); - SetLength(Result, Size); - P := 1; - for I := 1 to NamePaths.Count - 1 do begin - S := NamePaths[I]; - L := Length(S); - if L <> 0 then begin - ALMove(pointer(S)^, Pbyte(Result)[(P-1)*sizeOf(Char)], L*sizeOf(Char)); - Inc(P, L); - end; - L := 1{length(LB)}; - if ((i <> NamePaths.Count - 1) or - (ExtraItems <> '')) and - (((NotSaxMode) and (TALJSONNodeW(NamePaths.Objects[I]).nodetype <> ntarray)) or - ((not NotSaxMode) and (TALJsonNodeType(NamePaths.Objects[I]) <> ntarray))) then begin - ALMove(LB, Pbyte(Result)[(P-1)*sizeOf(Char)], L*sizeOf(Char)); - Inc(P, L); - end; - end; - if ExtraItems <> '' then begin - L := length(ExtraItems); - ALMove(pointer(ExtraItems)^, Pbyte(Result)[(P-1)*sizeOf(Char)], L*sizeOf(Char)); - Inc(P, L); - end; - setlength(result,P-1); - end; +{***************************************************************************} +function TALJSONNodeW.GetChildNodeValueNull(const nodeName: String): Boolean; +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then result := true + else result := LNode.GetNull; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseTextWithIndex( - const index: String; - const Args: array of const; - const NodeSubType: TALJsonNodeSubType); - begin - DoParseText(GetPathStr('[' + index + ']'), '', Args, NodeSubType) +{****************************************************************************} +function TALJSONNodeW.GetChildNode(const path: array of String): TALJSONNodeW; +var I: integer; +begin + result := Self; + for I := low(path) to high(path) do begin + result := result.ChildNodes.findNode(path[I]); + if (result = nil) then exit; end; +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseTextWithName( - const name: String; - const Args: array of const; - const NodeSubType: TALJsonNodeSubType); - begin - DoParseText(GetPathStr(Name), Name, Args, NodeSubType) +{******************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueText(const path: array of String; const default: String): String; +var LNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetText(default); +end; - {~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseText( - const NameOrIndex: String; - const Args: array of const; - const NodeSubType: TALJsonNodeSubType); - begin - if Assigned(fonParseText) then begin - if notSaxMode then begin - if WorkingNode.nodetype=ntarray then _DoParseTextWithIndex(NameOrIndex, Args, NodeSubType) - else _DoParseTextWithName(NameOrIndex, Args, NodeSubType); - end - else begin - if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); - if TALJsonNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntArray then _DoParseTextWithIndex(NameOrIndex, Args, NodeSubType) - else _DoParseTextWithName(NameOrIndex, Args, NodeSubType); - end; +{*******************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueFloat(const path: array of String; const default: Double): Double; +var LNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; end; end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetFloat(default); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseStartObject(const Name: String); - begin - DoParseStartObject(GetPathStr, Name); - end; - - {~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseEndObject; - begin - if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); - DoParseEndObject(GetPathStr, NamePaths[NamePaths.Count - 1]) +{****************************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueDateTime(const path: array of String; const default: TDateTime): TDateTime; +var LNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetDateTime(default); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseStartArray(const index: String); - begin - DoParseStartArray(GetPathStr, index) +{*******************************************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueTimestamp(const path: array of String; const default: TALBSONTimestamp): TALBSONTimestamp; +var LNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetTimestamp(default); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _DoParseEndArray; - begin - if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); - DoParseEndArray(GetPathStr, NamePaths[NamePaths.Count - 1]); +{*********************************************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueObjectID(const path: array of String; const default: String): String; // return a hex string +var LNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetObjectID(default); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _AddIndexItemToNamePath(const index: String; Obj: Pointer); - begin - NamePaths.AddObject('[' + Index + ']', Obj) +{*********************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueInt32(const path: array of String; const default: Integer): Integer; +var LNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetInt32(default); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _AddNameItemToNamePath(const name: String; Obj: Pointer); - begin - NamePaths.AddObject(Name, Obj) +{*****************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueInt64(const path: array of String; const default: Int64): Int64; +var LNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetInt64(default); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _AddItemToNamePath(const nameOrIndex: String; Obj: Pointer); - begin - if notSaxMode then begin - if WorkingNode.nodetype=ntarray then _AddIndexItemToNamePath(nameOrIndex, Obj) - else _AddNameItemToNamePath(nameOrIndex, Obj); - end - else begin - if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); - if TALJsonNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntarray then _AddIndexItemToNamePath(nameOrIndex, Obj) - else _AddNameItemToNamePath(nameOrIndex, Obj); +{********************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueBool(const path: array of String; const default: Boolean): Boolean; +var LNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; end; end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetBool(default); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createInt64Node( - const name: String; - const NodeSubType: TALJsonNodeSubType); - var LNode: TALJSONNodeW; - LInt64: Int64; - begin - if BufferPos > BufferLength - sizeof(LInt64) then ALJSONDocErrorW(cALBSONParseError); - ALMove(Buffer[BufferPos], LInt64, sizeof(LInt64)); - BufferPos := BufferPos + sizeof(LInt64); - - if NotSaxMode then begin - if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetInt64(LInt64); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(Name, [LInt64], NodeSubType) - end - else begin - _DoParseText(Name, [LInt64], NodeSubType) +{************************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueJavascript(const path: array of String; const default: String): String; +var LNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; end; end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetJavascript(default); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createInt32Node( - const name: String; - const NodeSubType: TALJsonNodeSubType); - var LNode: TALJSONNodeW; - LInt32: Int32; - begin - if BufferPos > BufferLength - sizeof(LInt32) then ALJSONDocErrorW(cALBSONParseError); - ALMove(Buffer[BufferPos], LInt32, sizeof(LInt32)); - BufferPos := BufferPos + sizeof(LInt32); - - if NotSaxMode then begin - if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setint32(LInt32); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(Name, [LInt32], NodeSubType) - end - else begin - _DoParseText(Name, [LInt32], NodeSubType) +{*******************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueRegEx(const path: array of String; const default: String): String; +var LNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; end; end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetRegEx(default); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createTextNode( - const name: String; - const NodeSubType: TALJsonNodeSubType); - var LNode: TALJSONNodeW; - LInt32: Int32; - LText: String; - begin - if BufferPos > BufferLength - sizeof(LInt32) then ALJSONDocErrorW(cALBSONParseError); - ALMove(Buffer[BufferPos], LInt32, sizeof(LInt32)); - BufferPos := BufferPos + sizeof(LInt32); - if (BufferPos + LInt32 > BufferLength) then ALJSONDocErrorW(cALBSONParseError); - LText := Tencoding.UTF8.GetString(Buffer,BufferPos,LInt32 - 1{for the trailing #0}); - BufferPos := BufferPos + LInt32; - - if NotSaxMode then begin - if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Settext(LText); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(Name, [LText], NodeSubType) - end - else begin - _DoParseText(Name, [LText], NodeSubType) +{****************************************************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueRegExOptions(const path: array of String; const default: TALPerlRegExOptions): TALPerlRegExOptions; +var LNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; end; end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetRegExOptions(default); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createFloatNode( - const name: String; - const NodeSubType: TALJsonNodeSubType); - var LNode: TALJSONNodeW; - LDouble: Double; - begin - if BufferPos > BufferLength - sizeof(Double) then ALJSONDocErrorW(cALBSONParseError); - ALMove(Buffer[BufferPos], LDouble, sizeof(Double)); - BufferPos := BufferPos + sizeof(Double); +{*******************************************************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueBinary(const path: array of String; const default: String): String; // return a base64 encoded string +var LNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetBinary(default); +end; - if NotSaxMode then begin - if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetFloat(LDouble); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(Name, [LDouble], NodeSubType) - end - else begin - _DoParseText(Name, [LDouble], NodeSubType) +{***********************************************************************************************************} +function TALJSONNodeW.GetChildNodeValueBinarySubType(const path: array of String; const default: byte): byte; +var LNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := default; + exit; end; end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := default + else result := LNode.GetBinarySubType(default); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createBinaryNode( - const name: String; - const NodeSubType: TALJsonNodeSubType); - var LNode: TALJSONNodeW; - LInt32: Int32; - LBinSubtype: byte; - LBinData: Tbytes; - LBase64Data: String; - begin - //Get size - if BufferPos > BufferLength - sizeof(LInt32) then ALJSONDocErrorW(cALBSONParseError); - ALMove(Buffer[BufferPos], LInt32, sizeof(LInt32)); - BufferPos := BufferPos + sizeof(LInt32); +{********************************************************************************} +function TALJSONNodeW.GetChildNodeValueNull(const path: array of String): Boolean; +var LNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LNode := LNode.ChildNodes.findNode(path[I]); + if (LNode = nil) then begin + result := True; + exit; + end; + end; + LNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LNode = nil) then result := true + else result := LNode.GetNull; +end; - //Get the subtype - if BufferPos >= BufferLength then ALJSONDocErrorW(cALBSONParseError); - LBinSubtype := Buffer[BufferPos]; - BufferPos := BufferPos + 1; +{****************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueText(const nodeName: String; const value: String); +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetText(value) + else LNode.SetText(value); +end; - //Get the data - if (BufferPos + LInt32 > BufferLength) then ALJSONDocErrorW(cALBSONParseError); - setlength(LBinData, LInt32); - ALMove(Buffer[BufferPos], pointer(LBinData)^, LInt32); - LBase64Data := ALBase64EncodeBytesW(LBinData); - BufferPos := BufferPos + LInt32; +{*****************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueFloat(const nodeName: String; const value: Double); +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetFloat(value) + else LNode.SetFloat(value); +end; - //create the node - if NotSaxMode then begin - if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.setbinary(LBase64Data, LBinSubtype); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(Name, [LBase64Data, LBinSubtype], NodeSubType); - end - else begin - _DoParseText(Name, [LBase64Data, LBinSubtype], NodeSubType); - end; - end; +{***********************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueDateTime(const nodeName: String; const value: TDateTime); +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetDateTime(value) + else LNode.SetDateTime(value); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createObjectIDNode( - const name: String; - const NodeSubType: TALJsonNodeSubType); - var LNode: TALJSONNodeW; - LObjectID: Tbytes; - LHexData: String; - begin - if BufferPos > BufferLength - 12{length(aObjectID)} then ALJSONDocErrorW(cALBSONParseError); - setlength(LObjectID, 12); - ALMove(Buffer[BufferPos], pointer(LObjectID)^, 12{length(aObjectID)}); - LHexData := ALBinToHexW(LObjectID); - BufferPos := BufferPos + 12{length(aObjectID)}; +{*******************************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueTimestamp(const nodeName: String; const value: TALBSONTimestamp); +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetTimestamp(value) + else LNode.SetTimestamp(value); +end; - if NotSaxMode then begin - if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetObjectID(LHexData); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(Name, [LHexData], NodeSubType) - end - else begin - _DoParseText(Name, [LHexData], NodeSubType) - end; - end; +{********************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueObjectID(const nodeName: String; const value: String); +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetObjectID(value) + else LNode.SetObjectID(value); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createBooleanNode( - const name: String; - const NodeSubType: TALJsonNodeSubType); - var LNode: TALJSONNodeW; - LBool: Boolean; - begin - if BufferPos >= BufferLength then ALJSONDocErrorW(cALBSONParseError); - if Buffer[BufferPos] = $00 then LBool := False - else if Buffer[BufferPos] = $01 then LBool := true - else begin - ALJSONDocErrorW(cALBSONParseError); - LBool := False; // to hide a warning; - end; - BufferPos := BufferPos + 1; +{******************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueInt32(const nodeName: String; const value: Integer); +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetInt32(value) + else LNode.SetInt32(value); +end; - if NotSaxMode then begin - if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setbool(LBool); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(Name, [LBool], NodeSubType); - end - else begin - _DoParseText(Name, [LBool], NodeSubType); - end; - end; +{****************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueInt64(const nodeName: String; const value: Int64); +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetInt64(value) + else LNode.SetInt64(value); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createDateTimeNode( - const name: String; - const NodeSubType: TALJsonNodeSubType); - var LNode: TALJSONNodeW; - LDateTime: TdateTime; - LInt64: Int64; - begin - if BufferPos > BufferLength - sizeof(LInt64) then ALJSONDocErrorW(cALBSONParseError); - ALMove(Buffer[BufferPos], LInt64, sizeof(LInt64)); - LDateTime := ALUnixMsToDateTime(LInt64); - BufferPos := BufferPos + sizeof(LInt64); +{*****************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueBool(const nodeName: String; const value: Boolean); +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetBool(value) + else LNode.SetBool(value); +end; - if NotSaxMode then begin - if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setdatetime(LDateTime); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(Name, [LDateTime], NodeSubType); - end - else begin - _DoParseText(Name, [LDateTime], NodeSubType); - end; - end; +{**********************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueJavascript(const nodeName: String; const value: String); +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetJavascript(value) + else LNode.SetJavascript(value); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createTimestampNode( - const name: String; - const NodeSubType: TALJsonNodeSubType); - var LNode: TALJSONNodeW; - LTimestamp: TALBSONTimestamp; - LInt64: Int64; - begin - if BufferPos > BufferLength - sizeof(LInt64) then ALJSONDocErrorW(cALBSONParseError); - ALMove(Buffer[BufferPos], LInt64, sizeof(LInt64)); - LTimestamp.I64 := LInt64; - BufferPos := BufferPos + sizeof(LInt64); +{*****************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueRegEx(const nodeName: String; const value: String); +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetRegEx(value) + else LNode.SetRegEx(value); +end; - if NotSaxMode then begin - if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetTimestamp(LTimestamp); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(Name, [LTimestamp.W1, LTimestamp.W2], NodeSubType); - end - else begin - _DoParseText(Name, [LTimestamp.W1, LTimestamp.W2], NodeSubType); - end; - end; +{*************************************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueRegExOptions(const nodeName: String; const value: TALPerlRegExOptions); +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetRegExOptions(value) + else LNode.SetRegExOptions(value); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createnullNode( - const name: String; - const NodeSubType: TALJsonNodeSubType); - var LNode: TALJSONNodeW; - begin - if NotSaxMode then begin - if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.Setnull(true); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(Name, ['null'], NodeSubType); - end - else begin - _DoParseText(Name, ['null'], NodeSubType); - end; - end; +{******************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueBinary(const nodeName: String; const value: String); +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetBinary(value) + else LNode.SetBinary(value); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createRegExNode( - const name: String; - const NodeSubType: TALJsonNodeSubType); - var LNode: TALJSONNodeW; - LRegEx: String; - LRegExOptions: TALPerlRegExOptions; - P1: integer; - begin - //Get pattern - P1 := BufferPos; - While (P1 < BufferLength) do begin - If Buffer[P1] <> $00 then inc(P1) - else begin - LRegEx := Tencoding.UTF8.GetString(Buffer,BufferPos,P1 - BufferPos); - break; - end; - end; - if P1 >= BufferLength then ALJSONDocErrorW(cALBSONParseError); - BufferPos := P1 + 1; +{***********************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueBinarySubType(const nodeName: String; const value: byte); +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetBinarySubType(value) + else LNode.SetBinarySubType(value); +end; - //Get options - LRegExOptions := []; - While (BufferPos < BufferLength) do begin - case Buffer[BufferPos] of - ord('i'): LRegExOptions := LRegExOptions + [preCaseLess]; - ord('m'): LRegExOptions := LRegExOptions + [preMultiLine]; - ord('x'): LRegExOptions := LRegExOptions + [preExtended]; - ord('l'):; - ord('s'): LRegExOptions := LRegExOptions + [preSingleLine]; - ord('u'):; - $00: break; - end; - inc(BufferPos); - end; - if BufferPos >= BufferLength then ALJSONDocErrorW(cALBSONParseError); - inc(BufferPos); +{*******************************************************************} +procedure TALJSONNodeW.SetChildNodeValueNull(const nodeName: String); +var LNode: TALJSONNodeW; +begin + LNode := ChildNodes.findNode(nodeName); + if (LNode = nil) then addChild(nodeName).SetNull(true) + else LNode.SetNull(true); +end; - //create the node - if NotSaxMode then begin - if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetRegEx(LRegEx, LRegExOptions); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(Name, [LRegEx, Byte(LRegExOptions)], NodeSubType) - end - else begin - _DoParseText(Name, [LRegEx, Byte(LRegExOptions)], NodeSubType) - end; +{*********************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueText(const path: array of String; const value: String); +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetText(value) + else LTmpNode.SetText(value); +end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - procedure _createJavascriptNode( - const name: String; - const NodeSubType: TALJsonNodeSubType); - var LNode: TALJSONNodeW; - LJavascript: String; - LInt32: Int32; - begin - if BufferPos > BufferLength - sizeof(LInt32) then ALJSONDocErrorW(cALBSONParseError); - ALMove(Buffer[BufferPos], LInt32, sizeof(LInt32)); - BufferPos := BufferPos + sizeof(LInt32); - if (BufferPos + LInt32 > BufferLength) then ALJSONDocErrorW(cALBSONParseError); - LJavascript := Tencoding.UTF8.GetString(Buffer,BufferPos,LInt32 - 1{for the trailing #0}); - BufferPos := BufferPos + LInt32; +{**********************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueFloat(const path: array of String; const value: Double); +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetFloat(value) + else LTmpNode.SetFloat(value); +end; - //create the node - if NotSaxMode then begin - if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) - else LNode := CreateNode(Name, nttext); - try - LNode.SetJavascript(LJavascript); - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; - _DoParseText(Name, [LJavascript], NodeSubType); - end - else begin - _DoParseText(Name, [LJavascript], NodeSubType); - end; +{****************************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueDateTime(const path: array of String; const value: TDateTime); +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetDateTime(value) + else LTmpNode.SetDateTime(value); +end; + +{************************************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueTimestamp(const path: array of String; const value: TALBSONTimestamp); +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetTimestamp(value) + else LTmpNode.SetTimestamp(value); +end; - {~~~~~~~~~~~~~~~~~~~~} - procedure AnalyzeNode; - Var LNode: TALJSONNodeW; - LNodeType: TALJsonNodeType; - LNodeSubType: TALJsonNodeSubType; - P1: Integer; - c: byte; - Begin +{*************************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueObjectID(const path: array of String; const value: String); +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetObjectID(value) + else LTmpNode.SetObjectID(value); +end; - {$REGION 'init current char (c)'} - c := Buffer[BufferPos]; - {$ENDREGION} +{***********************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueInt32(const path: array of String; const value: Integer); +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetInt32(value) + else LTmpNode.SetInt32(value); +end; - {$REGION 'End Object/Array'} - // ... } .... - // ... ] .... - if c = $00 then begin +{*********************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueInt64(const path: array of String; const value: Int64); +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetInt64(value) + else LTmpNode.SetInt64(value); +end; - //error if Paths.Count = 0 (mean one end object/array without any starting) - if assigned(ObjectPaths) then begin - if (ObjectPaths.Count = 0) then ALJSONDocErrorW(cALBSONParseError); - end - else begin - if (NamePaths.Count = 0) then ALJSONDocErrorW(cALBSONParseError); - end; +{**********************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueBool(const path: array of String; const value: Boolean); +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetBool(value) + else LTmpNode.SetBool(value); +end; - //if we are not in sax mode - if NotSaxMode then begin +{***************************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueJavascript(const path: array of String; const value: String); +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetJavascript(value) + else LTmpNode.SetJavascript(value); +end; - //init anode to one level up - if assigned(ObjectPaths) then LNode := ObjectPaths[ObjectPaths.Count - 1] - else LNode := TALJSONNodeW(NamePaths.Objects[NamePaths.Count - 1]); +{**********************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueRegEx(const path: array of String; const value: String); +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetRegEx(value) + else LTmpNode.SetRegEx(value); +end; - //if anode <> workingNode aie aie aie - if (LNode <> WorkingNode) then ALJSONDocErrorW(cALBSONParseError); +{******************************************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueRegExOptions(const path: array of String; const value: TALPerlRegExOptions); +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetRegExOptions(value) + else LTmpNode.SetRegExOptions(value); +end; - //calculate anodeTypeInt - LNodeType := LNode.NodeType; - if not (LNodeType in [ntObject, ntarray]) then ALJSONDocErrorW(cALBSONParseError); +{***********************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueBinary(const path: array of String; const value: String); +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetBinary(value) + else LTmpNode.SetBinary(value); +end; - //if working node <> containernode then we can go to one level up - If WorkingNode<>ContainerNode then begin +{****************************************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueBinarySubType(const path: array of String; const value: byte); +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetBinarySubType(value) + else LTmpNode.SetBinarySubType(value); +end; - //init WorkingNode to the parentNode - WorkingNode := WorkingNode.ParentNode; +{************************************************************************} +procedure TALJSONNodeW.SetChildNodeValueNull(const path: array of String); +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; +begin + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); + if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetNull(true) + else LTmpNode.SetNull(true); +end; - end +{***********************************************} +{Indicates whether this node has any child nodes} +function TALJSONNodeW.GetHasChildNodes: Boolean; +Var LNodeList: TALJSONNodeListW; +begin + LNodeList := InternalGetChildNodes; + Result := assigned(LNodeList) and (LNodeList.Count > 0); +end; - //if working node = containernode then we can no go to the parent node so set WorkingNode to nil - Else WorkingNode := nil; +{********************************************} +function TALJSONNodeW.GetNodeValueStr: String; +begin + ALJSONDocErrorW(CALJsonOperationError,GetNodeType); + result := ''; // hide warning +end; - end +{*********************************************} +function TALJSONNodeW.GetNodeValueInt64: int64; +begin + ALJSONDocErrorW(CALJsonOperationError,GetNodeType); + result := 0; // hide warning +end; - //if we are in sax mode - else begin +{**********************************************************************************************} +procedure TALJSONNodeW.SetNodeValue(const Value: String; const NodeSubType: TALJSONNodeSubType); +begin + ALJSONDocErrorW(CALJsonOperationError,GetNodeType); +end; - //calculate anodeTypeInt - LNodeType := TALJsonNodeType(NamePaths.Objects[NamePaths.Count - 1]); - if not (LNodeType in [ntObject,ntarray]) then ALJSONDocErrorW(cALBSONParseError); +{*********************************************************************************************} +procedure TALJSONNodeW.SetNodeValue(const Value: int64; const NodeSubType: TALJSONNodeSubType); +begin + ALJSONDocErrorW(CALJsonOperationError,GetNodeType); +end; - end; +{**************************************************************************************************************************} +procedure TALJSONNodeW.SetNodeValue(const StrValue: String; const Int64Value: int64; const NodeSubType: TALJSONNodeSubType); +begin + ALJSONDocErrorW(CALJsonOperationError,GetNodeType); +end; + +{*********************************************************} +procedure TALJSONNodeW.SetNodeName(const NodeName: String); +begin + if fNodeName <> NodeName then begin + fNodeName := NodeName; + Var LParentNode := FParentNode; + if (LParentNode <> nil) and (LParentNode.ChildNodes.Sorted) then begin + var LNode := LParentNode.ChildNodes.Extract(self); + Try + LParentNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + End; + end; + end; +end; - //call the DoParseEndObject/array event - if Assigned(fonParseEndObject) then begin - if LNodeType = ntObject then _DoParseEndObject - else _DoParseEndArray; - end; +{***********************************} +{Returns the text value of the node.} +function TALJSONNodeW.GetText: String; +begin - //delete the last entry from the path - if assigned(ObjectPaths) then ObjectPaths.Delete(ObjectPaths.Count - 1) - else NamePaths.Delete(NamePaths.Count - 1); + case NodeSubType of + nstFloat: result := GetNodeValueStr; // return the formated float + nstText: result := GetNodeValueStr; // return the raw text + nstObject: result := GetNodeValueStr; // return the raw objectID + nstArray: result := GetNodeValueStr; // error + nstObjectID: result := GetNodeValueStr; // error + nstBoolean: result := GetNodeValueStr; // return true or false + nstDateTime: result := GetNodeValueStr; // return the formated datetime + nstNull: result := GetNodeValueStr; // return null + nstRegEx: result := GetNodeValueStr; // return the raw regex (without the options) + nstBinary: result := GetNodeValueStr; // return the base64 encoded binary (without the binary subtype) + nstJavascript: result := GetNodeValueStr; // return the raw javascript + nstInt32: result := GetNodeValueStr; // return the number + nstTimestamp: result := GetNodeValueStr; // return the number (as int64) + nstInt64: result := GetNodeValueStr; // return the number + else ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + end; - //update BufferPos - BufferPos := BufferPos + 1; +end; - //finallly exit from this procedure, everything was done - exit; +{***********************************************************} +function TALJSONNodeW.GetText(const default: String): String; +begin + if NodeSubType = nstNull then result := default + else result := GetText; +end; - end; - {$ENDREGION} +{********************************} +{Sets the text value of the node.} +procedure TALJSONNodeW.SetText(const Value: String); +begin + setNodeValue(Value, nstText); +end; - {$REGION 'Get the node sub type'} - LNodeSubType := nstText; // to hide fucking warning - case c of - $01: LNodeSubType := nstFloat; - $02: LNodeSubType := nstText; - $03: LNodeSubType := nstObject; - $04: LNodeSubType := nstArray; - $05: LNodeSubType := nstbinary; - $07: LNodeSubType := nstObjectID; - $08: LNodeSubType := nstBoolean; - $09: LNodeSubType := nstDateTime; - $0A: LNodeSubType := nstNull; - $0B: LNodeSubType := nstRegEx; - $0D: LNodeSubType := nstJavascript; - $10: LNodeSubType := nstint32; - $11: LNodeSubType := nstTimestamp; - $12: LNodeSubType := nstint64; - else ALJSONDocErrorW(cALBSONParseError); - end; - BufferPos := BufferPos + 1; - {$ENDREGION} +{******************************************************************************} +// By default json (ie: javascript) treats all numbers as floating-point values. +// To let other system (ie: mongoDB) understand the type of the number +// we provide the helper functions NumberLong() to handle 64-bit integers +// and NumberInt() to handle 32-bit integers (and some others). theses helper functions are +// used when saving the json document. +function TALJSONNodeW.GetNodeValueInterchange(const SkipNodeSubTypeHelper: boolean = False): String; - {$REGION 'Get the node name'} - P1 := BufferPos; - While (P1 < BufferLength) do begin - If Buffer[P1] <> $00 then inc(P1) - else begin - CurrName := Tencoding.UTF8.GetString(Buffer,BufferPos,P1-BufferPos); - break; - end; - end; - if P1 >= BufferLength then ALJSONDocErrorW(cALBSONParseError); - BufferPos := P1 + 1; - {$ENDREGION} + {~~~~~~~~~~~~~~~~~~~~~} + procedure _GetObjectID; + begin + if SkipNodeSubTypeHelper then result := '"'+ObjectID+'"' + else result := 'ObjectId("'+ObjectID+'")'; + end; - {$REGION 'Begin Object/Array'} - // ... { .... - // ... [ .... - if LNodeSubType in [nstObject,nstArray] then begin + {~~~~~~~~~~~~~~~~~~~} + procedure _GetBinary; + begin + if SkipNodeSubTypeHelper then result := '"'+Binary+'"' + else result := 'BinData('+ALIntToStrW(BinarySubType)+', "'+Binary+'")'; + end; - //if we are not in sax mode - if NotSaxMode then begin + {~~~~~~~~~~~~~~~~~~~~~} + procedure _GetDateTime; + begin + if SkipNodeSubTypeHelper then result := ALFormatDateTimeW('''"''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z"''', DateTime, ALDefaultFormatSettingsW) + else result := ALFormatDateTimeW('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', DateTime, ALDefaultFormatSettingsW) + end; - //if workingnode = nil then it's mean we are outside the containerNode - if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); + {~~~~~~~~~~~~~~~~~~} + procedure _Getint32; + begin + if SkipNodeSubTypeHelper then result := text + else result := 'NumberInt(' + text + ')' + end; - //create the node according the the braket char and add it to the workingnode - if LNodeSubType = nstObject then begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', ntObject) - else LNode := CreateNode(CurrName, ntObject); - end - else begin - if WorkingNode.nodetype=ntarray then LNode := CreateNode('', ntarray) - else LNode := CreateNode(CurrName, ntarray); - end; - try - WorkingNode.ChildNodes.Add(LNode); - except - ALFreeAndNil(LNode); - raise; - end; + {~~~~~~~~~~~~~~~~~~} + procedure _Getint64; + begin + if SkipNodeSubTypeHelper then result := text + else result := 'NumberLong(' + text + ')'; + end; - //set that the current working node will be now the new node newly created - WorkingNode := LNode; + {~~~~~~~~~~~~~~~~~~} + procedure _GetRegEx; + var LRegExOptions: TALPerlRegExOptions; + LRegExOptionsStr: String; + begin + LRegExOptionsStr := ''; + LRegExOptions := RegExOptions; + if preCaseLess in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr + 'i'; + if preMultiLine in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr +'m'; + if preExtended in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr +'x'; + //'l':; + if preSingleLine in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr + 's'; + //'u':; + result := '/'+regex+'/' + LRegExOptionsStr; + if not SkipNodeSubTypeHelper then result := '"' + ALJavascriptEncode(result) + '"' + end; - //update the path - if assigned(ObjectPaths) then ObjectPaths.Add(WorkingNode) - else _AddItemToNamePath(CurrName, WorkingNode); + {~~~~~~~~~~~~~~~~~~~~~~} + procedure _GetTimestamp; + begin + if SkipNodeSubTypeHelper then result := '"Timestamp('+ALIntToStrW(GetTimeStamp.W1)+', '+ALIntToStrW(GetTimeStamp.W2)+')"' + else result := 'Timestamp('+ALIntToStrW(GetTimeStamp.W1)+', '+ALIntToStrW(GetTimeStamp.W2)+')'; + end; - end +begin - //if we are in sax mode - else begin + case NodeSubType of + nstFloat: result := GetNodeValueStr; + nstText: result := GetNodeValueStr; + nstBinary: _GetBinary; + nstObjectID: _GetObjectID; + nstBoolean: result := GetNodeValueStr; + nstDateTime: _GetDateTime; + nstJavascript: result := GetNodeValueStr; + nstInt32: _Getint32; + nstInt64: _Getint64; + nstNull: result := GetNodeValueStr; + nstObject: result := GetNodeValueStr; + nstArray: result := GetNodeValueStr; + nstRegEx: _GetRegEx; + nstTimestamp: _GetTimestamp; + else raise Exception.Create('Unknown Node SubType'); + end; - //update the path - if LNodeSubType = nstObject then LNodeType := ntObject - else LNodeType := ntArray; - _AddItemToNamePath(CurrName, pointer(LNodeType)); +end; - end; +{*************************************} +function TALJSONNodeW.GetFloat: Double; +begin + case NodeSubType of + nstFloat: PInt64(@result)^ := GetNodeValueInt64; + nstInt32, + nstInt64: Result := GetNodeValueInt64; + else begin + ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + result := 0; // to hide a warning; + end; + end; +end; - //call the DoParseStartObject/array event - if LNodeSubType = nstObject then begin - if Assigned(fonParseStartObject) then _DoParseStartObject(CurrName) - end - else begin - if Assigned(fonParseStartArray) then _DoParseStartArray(CurrName); - end; +{************************************************************} +function TALJSONNodeW.GetFloat(const default: Double): Double; +begin + if NodeSubType = nstNull then result := default + else result := GetFloat; +end; - //update BufferPos - BufferPos := BufferPos + 4; // we don't need the size of the object/array (4 bytes) +{***************************************************} +procedure TALJSONNodeW.SetFloat(const Value: Double); +begin + setNodeValue(PInt64(@Value)^, nstFloat); +end; - //finallly exit from this procedure, everything was done - exit; +{*******************************************} +function TALJSONNodeW.GetDateTime: TDateTime; +begin + if NodeSubType = nstDateTime then PInt64(@result)^ := GetNodeValueInt64 + else begin + ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + result := 0; // to hide a warning; + end; +end; - end; - {$ENDREGION} +{*********************************************************************} +function TALJSONNodeW.GetDateTime(const default: TDateTime): TDateTime; +begin + if NodeSubType = nstNull then result := default + else result := GetDateTime; +end; - {$REGION 'create the node'} - case LNodeSubType of - // \x01 + name + \x00 + double - nstFloat: _createFloatNode(CurrName, LNodeSubType); +{*********************************************************} +procedure TALJSONNodeW.SetDateTime(const Value: TDateTime); +begin + setNodeValue(PInt64(@Value)^, nstDateTime); +end; - // \x02 + name + \x00 + length (int32) + string + \x00 - nstText: _createTextNode(CurrName, LNodeSubType); +{***************************************************} +function TALJSONNodeW.GetTimestamp: TALBSONTimestamp; +begin + if NodeSubType = nstTimestamp then result.I64 := GetNodeValueInt64 + else begin + ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + result.I64 := 0; // to hide a warning; + end; +end; - // \x05 + name + \x00 + int32 + subtype + (byte*) - nstbinary: _createBinaryNode(CurrName, LNodeSubType); +{************************************************************************************} +function TALJSONNodeW.GetTimestamp(const default: TALBSONTimestamp): TALBSONTimestamp; +begin + if NodeSubType = nstNull then result := default + else result := GetTimestamp; +end; - // \x07 + name + \x00 + (byte*12) - nstObjectID: _createObjectIDNode(CurrName, LNodeSubType); +{*****************************************************************} +procedure TALJSONNodeW.SetTimestamp(const Value: TALBSONTimestamp); +begin + setNodeValue(Value.I64, nstTimestamp); +end; - // \x08 + name + \x00 + \x00 => Boolean "false" - // \x08 + name + \x00 + \x01 => Boolean "true" - nstBoolean: _createBooleanNode(CurrName, LNodeSubType); +{****************************************} +function TALJSONNodeW.GetObjectID: String; +begin + if NodeSubType = nstObjectID then result := GetNodeValueStr + else begin + ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + result := ''; // to hide a warning; + end; +end; - // \x09 + name + \x00 + int64 - nstDateTime: _createDateTimeNode(CurrName, LNodeSubType); +{***************************************************************} +function TALJSONNodeW.GetObjectID(const default: String): String; +begin + if NodeSubType = nstNull then result := default + else result := GetObjectID; +end; - // \x11 + name + \x00 + int64 - nstTimestamp: _createTimestampNode(CurrName, LNodeSubType); +{******************************************************} +procedure TALJSONNodeW.SetObjectID(const Value: String); +begin + if length(Value) <> 24 then ALJSONDocErrorW('ObjectID must have 12 bytes'); + setNodeValue(Value, nstObjectID); +end; - // \x0A + name + \x00 - nstnull: _createNullNode(CurrName, LNodeSubType); +{**************************************} +function TALJSONNodeW.GetInt32: Integer; +var LDouble: Double; + LInt64: system.int64; +begin + case NodeSubType of + nstFloat: begin + PInt64(@LDouble)^ := GetNodeValueInt64; + LInt64 := trunc(LDouble); + if (LInt64 <> LDouble) or // https://stackoverflow.com/questions/41779801/single-double-and-precision + // Only values that are in form m*2^e, where m and e are integers can be stored in a floating point variable + // so all integer can be store in the form m*2^e (ie: m = m*2^0) + // so we can compare aInt64 <> aDouble without the need of samevalue + (LInt64 > system.int32.MaxValue) or + (LInt64 < system.int32.MinValue) then ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + result := LInt64; + end; + nstInt32: begin + LInt64 := GetNodeValueInt64; + if (LInt64 > system.int32.MaxValue) or + (LInt64 < system.int32.MinValue) then ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + result := LInt64; + end; + nstInt64: Result := GetNodeValueInt64; + else begin + ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + result := 0; // to hide a warning; + end; + end; +end; - // \x0B + name + \x00 + (byte*) + \x00 + (byte*) + \x00 - nstRegEx: _createRegExNode(CurrName, LNodeSubType); +{**************************************************************} +function TALJSONNodeW.GetInt32(const default: Integer): Integer; +begin + if NodeSubType = nstNull then result := default + else result := GetInt32; +end; - // \x0D + name + \x00 + length (int32) + string + \x00 - nstJavascript: _createJavascriptNode(CurrName, LNodeSubType); +{****************************************************} +procedure TALJSONNodeW.SetInt32(const Value: Integer); +begin + setNodeValue(Value, nstInt32); +end; - // \x10 + name + \x00 + int32 - nstint32: _createInt32Node(CurrName, LNodeSubType); +{************************************} +function TALJSONNodeW.GetInt64: Int64; +var LDouble: Double; +begin + case NodeSubType of + nstFloat: begin + PInt64(@LDouble)^ := GetNodeValueInt64; + result := trunc(LDouble); + if result <> LDouble then ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); // https://stackoverflow.com/questions/41779801/single-double-and-precision + // Only values that are in form m*2^e, where m and e are integers can be stored in a floating point variable + // so all integer can be store in the form m*2^e (ie: m = m*2^0) + // so we can compare result <> aDouble without the need of samevalue + end; + nstInt32, + nstInt64: Result := GetNodeValueInt64; + else begin + ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + result := 0; // to hide a warning; + end; + end; +end; - // \x12 + name + \x00 + int64 - nstint64: _createInt64Node(CurrName, LNodeSubType); +{**********************************************************} +function TALJSONNodeW.GetInt64(const default: Int64): Int64; +begin + if NodeSubType = nstNull then result := default + else result := GetInt64; +end; - else ALJSONDocErrorW(cALBSONParseError); - end; - {$ENDREGION} +{**************************************************} +procedure TALJSONNodeW.SetInt64(const Value: Int64); +begin + setNodeValue(Value, nstInt64); +end; +{*************************************} +function TALJSONNodeW.GetBool: Boolean; +begin + if NodeSubType = nstBoolean then begin + if GetNodeValueInt64 = 0 then result := False + else result := true; + end + else begin + ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + result := False; // to hide a warning; end; +end; -Begin +{*************************************************************} +function TALJSONNodeW.GetBool(const default: Boolean): Boolean; +begin + if NodeSubType = nstNull then result := default + else result := GetBool; +end; - // - // NOTE: the childNodes of the ContainerNode - // must have been cleared by the calling function! - // - // NOTE: ContainerNode must have fDocument assigned - // - // NOTE: ContainerNode must be ntobject or nil (sax mode) - // +{***************************************************} +procedure TALJSONNodeW.SetBool(const Value: Boolean); +begin + if Value then setNodeValue(1, nstBoolean) + else setNodeValue(0, nstBoolean); +end; - //event fonParseStartDocument - DoParseStartDocument; +{*************************************} +function TALJSONNodeW.GetNull: Boolean; +begin + result := NodeSubType = nstNull; +end; - //init WorkingNode and NotSaxMode - WorkingNode := ContainerNode; - NotSaxMode := assigned(ContainerNode); +{***************************************************} +procedure TALJSONNodeW.SetNull(const Value: Boolean); +begin + if Value then setNodeValue(0, nstNull) + else ALJSONDocErrorW('Only "true" is allowed for setNull property'); +end; - //init ObjectPaths or NamePaths - if (NotSaxMode) and - (not assigned(fonParseText)) and - (not assigned(FonParseStartObject)) and - (not assigned(FonParseEndObject)) and - (not assigned(FonParseStartArray)) and - (not assigned(FonParseEndArray)) then begin - ObjectPaths := TObjectList.Create(false{OwnsObjects}); - NamePaths := nil; - end +{******************************************} +function TALJSONNodeW.GetJavascript: String; +begin + if NodeSubType = nstJavascript then result := GetNodeValueStr else begin - ObjectPaths := nil; - NamePaths := TALStringListW.Create; + ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + result := ''; // to hide a warning; end; - Try - - //init Buffer - BufferLength := length(Buffer); - BufferPos := 4; // the first 4 bytes are the length of the document and we don't need it - - //add first node in ObjectPaths/NamePaths - if assigned(ObjectPaths) then ObjectPaths.Add(WorkingNode) - else begin - if NotSaxMode then NamePaths.AddObject('[-1]', WorkingNode) - else NamePaths.AddObject('[-1]', pointer(ntObject)); - end; +end; - //analyze all the nodes - While (BufferPos < BufferLength) do - AnalyzeNode; +{*****************************************************************} +function TALJSONNodeW.GetJavascript(const default: String): String; +begin + if NodeSubType = nstNull then result := default + else result := GetJavascript; +end; - //some tags are not closed - if assigned(ObjectPaths) then begin - if ObjectPaths.Count > 0 then ALJSONDocErrorW(cALBSONParseError); - end - else begin - if NamePaths.Count > 0 then ALJSONDocErrorW(cALBSONParseError); - end; +{********************************************************} +procedure TALJSONNodeW.SetJavascript(const Value: String); +begin + setNodeValue(Value, nstJavascript); +end; - //mean the node was not update (empty stream?) or not weel closed - if WorkingNode <> nil then ALJSONDocErrorW(cALBSONParseError); +{*************************************} +function TALJSONNodeW.GetRegEx: String; +begin + if NodeSubType = nstRegEx then result := GetNodeValueStr + else begin + ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + result := ''; // to hide a warning; + end; +end; - //event fonParseEndDocument - DoParseEndDocument; +{************************************************************} +function TALJSONNodeW.GetRegEx(const default: String): String; +begin + if NodeSubType = nstNull then result := default + else result := GetRegEx; +end; - finally +{*****************************************************} +procedure TALJSONNodeW.SetRegEx(const Pattern: String); +begin + setNodeValue(Pattern, 0, nstRegEx); +end; - //free ObjectPaths/NamePaths - if assigned(ObjectPaths) then ALFreeAndNil(ObjectPaths) - else ALFreeAndNil(NamePaths); +{*****************************************************************************************} +procedure TALJSONNodeW.SetRegEx(const Pattern: String; const Options: TALPerlRegExOptions); +begin + setNodeValue(Pattern, byte(Options), nstRegEx); +end; +{*********************************************************} +function TALJSONNodeW.GetRegExOptions: TALPerlRegExOptions; +begin + if NodeSubType = nstRegEx then result := TALPerlRegExOptions(byte(GetNodeValueInt64)) + else begin + ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + result := []; // to hide a warning; end; +end; +{*********************************************************************************************} +function TALJSONNodeW.GetRegExOptions(const default: TALPerlRegExOptions): TALPerlRegExOptions; +begin + if NodeSubType = nstNull then result := default + else result := GetRegExOptions; end; -{************************************} -procedure TALJSONDocumentW.ReleaseDoc; +{***********************************************************************} +procedure TALJSONNodeW.SetRegExOptions(const Value: TALPerlRegExOptions); begin - if assigned(FDocumentNode) then ALFreeAndNil(FDocumentNode); + if NodeSubType <> nstRegEx then ALJSONDocErrorW('You can set regex options only to a regex node'); + setNodeValue(byte(Value), nstRegEx); end; -{*****************************************************************} -{Loads a string representation of an JSON document and activates it. - Call LoadFromJSONString to assign a string as the value of the JSON document. Unlike the JSON property, which lets you assign JSON on a line-by-line - basis, LoadFromJSONString treats the text of the JSON document as a whole. - The str parameter is a string containing the text of an JSON document. It should represent the JSON text encoded using 8 bits char (utf-8, iso-8859-1, etc) - After assigning the JSON property as the contents of the document, LoadFromJSONString sets the Active property to true.} -procedure TALJSONDocumentW.LoadFromJSONString(const Str: String; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); -begin - if saxMode then SetActive(False) +{**************************************} +function TALJSONNodeW.GetBinary: String; +begin + if NodeSubType = nstBinary then result := GetNodeValueStr else begin - if ClearChildNodes then releaseDoc; - SetActive(True); + ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + result := ''; // to hide a warning; end; - ParseJSON(Str, FDocumentNode) end; -{****************************************************} -{Loads an JSON document from a stream and activates it. - Call LoadFromJSONStream to load the JSON document from a stream. - *Stream is a stream object that can be used to read the string of JSON that makes up the document. - After loading the document from Stream, LoadFromJSONStream sets the Active property to true.} -procedure TALJSONDocumentW.LoadFromJSONStream(const Stream: TStream; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); +{*************************************************************} +function TALJSONNodeW.GetBinary(const default: String): String; begin - if saxMode then SetActive(False) - else begin - if ClearChildNodes then releaseDoc; - SetActive(True); - end; - ParseJSON(ALGetStringFromStream(Stream, TEncoding.UTF8), FDocumentNode) + if NodeSubType = nstNull then result := default + else result := GetBinary; end; -{**************************************} -{Loads an JSON document and activates it. - Call LoadFromJSONFile to load the JSON document specified by AFileName and set the Active property to true so - that you can examine or modify the document. - *AFileName is the name of the JSON document to load from disk. If AFileName is an empty string, TALJSONDocumentW uses the value of the - FileName property. If AFileName is not an empty string, TALJSONDocumentW changes the FileName property to AFileName. - Once you have loaded an JSON document, any changes you make to the document are not saved back to disk until you call the SaveToFile method.} -procedure TALJSONDocumentW.LoadFromJSONFile(const FileName: String; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); -var FileStream: TFileStream; -begin - FileStream := TFileStream.Create(string(FileName), fmOpenRead or fmShareDenyWrite); - try - LoadFromJSONStream(FileStream, saxMode, ClearChildNodes); - finally - ALFreeAndNil(FileStream); - end; +{***************************************************} +procedure TALJSONNodeW.SetBinary(const Data: String); +begin + setNodeValue(Data, 0, nstBinary); // 0 = Default BSON type end; -{***************************************************************************************************************************************} -procedure TALJSONDocumentW.LoadFromBSONBytes(const Bytes: Tbytes; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); +{************************************************************************} +procedure TALJSONNodeW.SetBinary(const Data: String; const Subtype: byte); begin - if saxMode then SetActive(False) - else begin - if ClearChildNodes then releaseDoc; - SetActive(True); - end; - ParseBSON(Bytes, FDocumentNode) + setNodeValue(Data, Subtype, nstBinary); end; -{******************************************************************************************************************************************} -procedure TALJSONDocumentW.LoadFromBSONStream(const Stream: TStream; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); +{*******************************************} +function TALJSONNodeW.GetBinarySubType: byte; begin - if saxMode then SetActive(False) + if NodeSubType = nstBinary then result := byte(GetNodeValueInt64) else begin - if ClearChildNodes then releaseDoc; - SetActive(True); + ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + result := 0; // to hide a warning; end; - ParseBSON(ALGetBytesFromStream(Stream), FDocumentNode) end; -{*****************************************************************************************************************************************} -procedure TALJSONDocumentW.LoadFromBSONFile(const FileName: String; const saxMode: Boolean = False; Const ClearChildNodes: Boolean = True); -var FileStream: TFileStream; +{****************************************************************} +function TALJSONNodeW.GetBinarySubType(const default: byte): byte; begin - FileStream := TFileStream.Create(string(FileName), fmOpenRead or fmShareDenyWrite); - try - LoadFromBSONStream(FileStream, saxMode, ClearChildNodes); - finally - ALFreeAndNil(FileStream); - end; + if NodeSubType = nstNull then result := default + else result := GetBinarySubType; end; -{***********************************} -{Saves the JSON document to a stream. - Call SaveToStream to save the contents of the JSON document to the stream specified by Stream.} -procedure TALJSONDocumentW.SaveToJSONStream(const Stream: TStream; const Encoding: TEncoding); +{***********************************************************} +procedure TALJSONNodeW.SetBinarySubType(const Subtype: byte); begin - CheckActive; - node.SaveToJSONStream(Stream, Encoding); + if NodeSubType <> nstBinary then ALJSONDocErrorW('You can set binary subtype only to a binary node'); + setNodeValue(Subtype, nstBinary); end; -{*****************************************************************} -procedure TALJSONDocumentW.SaveToJSONStream(const Stream: TStream); +{************************} +{returns the parent node.} +function TALJSONNodeW.GetParentNode: TALJSONNodeW; begin - SaveToJSONStream(Stream, TEncoding.UTF8); + Result := FParentNode; end; -{******************************} -{Saves the JSON document to disk. - Call SaveToFile to save any modifications you have made to the parsed JSON document. - AFileName is the name of the file to save.} -procedure TALJSONDocumentW.SaveToJSONFile(const FileName: String; const Encoding: TEncoding); +{******************************************} +{Sets the value of the ParentNode property.} +procedure TALJSONNodeW.SetParentNode(const Value: TALJSONNodeW); begin - CheckActive; - node.SaveToJSONFile(FileName, Encoding); + if FParentNode <> Value then + FParentNode := Value; end; -{****************************************************************} -procedure TALJSONDocumentW.SaveToJSONFile(const FileName: String); +{*******************************************************************} +{Returns the JSON that corresponds to the subtree rooted at this node. + GetJSON returns the JSON that corresponds to this node and any child nodes it contains.} +function TALJSONNodeW.GetJSON: String; begin - SaveToJSONFile(FileName, TEncoding.UTF8); + SaveToJSONString(result); end; {************************************************} -{Saves the JSON document to a string-type variable. - Call SaveToJSON to save the contents of the JSON document to the string-type variable specified by JSON. SaveToJSON writes the contents of JSON document - using 8 bits char (utf-8, iso-8859-1, etc) as an encoding system, depending on the type of the JSON parameter. - Unlike the JSON property, which lets you write individual lines from the JSON document, SaveToJSON writes the entire text of the JSON document.} -procedure TALJSONDocumentW.SaveToJSONString(var str: String); +{SetJSON reload the node with the new given value } +procedure TALJSONNodeW.SetJSON(const Value: String); +Begin + LoadFromJSONString(Value); +end; + +{*******************************************************************} +{Returns the BSON that corresponds to the subtree rooted at this node. + GetBSON returns the BSON that corresponds to this node and any child nodes it contains.} +function TALJSONNodeW.GetBSON: Tbytes; begin - CheckActive; - node.SaveToJSONString(Str); + SaveToBSONBytes(result); +end; + +{************************************************} +{SetBSON reload the node with the new given value } +procedure TALJSONNodeW.SetBSON(const Value: Tbytes); +Begin + LoadFromBSONBytes(Value); end; {*****************************************************************} -procedure TALJSONDocumentW.SaveToBsonStream(const Stream: TStream); +{Returns the number of parents for this node in the node hierarchy. + NestingLevel returns the number of ancestors for this node in the node hierarchy.} +function TALJSONNodeW.NestingLevel: Integer; +var PNode: TALJSONNodeW; begin - CheckActive; - node.SaveToBsonStream(Stream); + Result := 0; + PNode := ParentNode; + while PNode <> nil do begin + Inc(Result); + PNode := PNode.ParentNode; + end; end; -{****************************************************************} -procedure TALJSONDocumentW.SaveToBsonFile(const FileName: String); +{******************************************************} +constructor TALJSONNodeW.Create(const NodeName: String); +Begin + FParentNode := nil; + fNodeName := NodeName; +end; + +{***************************************************************} +//will create all the nodevalue and childnodelist to be sure that +//multiple thread can safely read at the same time the node +procedure TALJSONNodeW.MultiThreadPrepare(const aOnlyChildList: Boolean = False); +var I: integer; begin - CheckActive; - node.SaveToBsonFile(FileName); + if (not aOnlyChildList) and (NodeType = ntText) then begin + + case NodeSubType of + nstFloat, + nstBoolean, + nstDateTime, + nstNull, + nstInt32, + nstTimestamp, + nstInt64: GetNodeValueStr; + //nstText: can not be retrieve from int64 + //nstObject: can not be retrieve from int64 + //nstArray: can not be retrieve from int64 + //nstBinary: only the binarysubtype is store in int64 + //nstObjectID: can not be retrieve from int64 + //nstRegEx: only the regex options is store in the int64 + //nstJavascript: can not be retrieve from int64 + end; + + case NodeSubType of + nstFloat, + nstBoolean, + nstDateTime, + nstNull, + nstInt32, + nstTimestamp, + nstInt64: GetNodeValueInt64; + //nstText: can not be retrieve from int64 + //nstObject: can not be retrieve from int64 + //nstArray: can not be retrieve from int64 + //nstBinary: only the binarysubtype is store in int64 + //nstObjectID: can not be retrieve from int64 + //nstRegEx: only the regex options is store in the int64 + //nstJavascript: can not be retrieve from int64 + end; + + end + + else if (NodeType in [ntObject,ntArray]) then begin + For I := 0 to ChildNodes.Count - 1 do + ChildNodes[I].MultiThreadPrepare(aOnlyChildList); + end; end; -{************************************************************} -procedure TALJSONDocumentW.SaveToBsonBytes(var bytes: Tbytes); +{****************************************************************************************************************************************} +function TALJSONNodeW.AddChild(const NodeName: String; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeW; begin - CheckActive; - node.SaveToBsonBytes(Bytes); + Result := ALCreateJSONNodeW(NodeName,NodeType); + Try + ChildNodes.Insert(Index, Result); + except + ALFreeAndNil(Result); + raise; + end; end; -{*************************************} -{Returns the value of the JSON property. - GetJSON is the read implementation of the JSON property.} -function TALJSONDocumentW.GetJSON: String; +{*********************************************************************************************************************************************} +function TALJSONNodeW.AddChild(const Path: array of String; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeW; +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; begin - SaveToJSONString(Result); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I], TDirection.FromEnd); + if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) + else LNode := LTmpNode; + end; + result := LNode.addChild(path[high(path)], NodeType, Index); end; -{*************************************} -{Returns the value of the BSON property. - GetBSON is the read implementation of the BSON property.} -function TALJSONDocumentW.GetBSON: Tbytes; +{****************************************************************************************************************} +function TALJSONNodeW.AddChild(const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeW; begin - SaveToBSONBytes(Result); + Result := AddChild('', NodeType, Index); end; -{**********************************} -{Sets the value of the JSON property. - SetJSON is the write implementation of the JSON property. - *Value contains the raw (unparsed) JSON to assign.} -procedure TALJSONDocumentW.SetJSON(const Value: String); +{*****************************************************************} +function TALJSONNodeW.DeleteChild(const NodeName: String): boolean; +var I: integer; begin - LoadFromJSONString(Value, False{saxMode}, true{ClearChildNodes}); + I := ChildNodes.IndexOf(NodeName); + if I >= 0 then begin + ChildNodes.Delete(I); + result := True; + end + else result := False; end; -{**********************************} -{Sets the value of the BSON property. - SetBSON is the write implementation of the BSON property. - *Value contains the raw (unparsed) BSON to assign.} -procedure TALJSONDocumentW.SetBSON(const Value: Tbytes); +{**********************************************************************} +function TALJSONNodeW.DeleteChild(const Path: array of String): boolean; +var LNode: TALJSONNodeW; + LTmpNode: TALJSONNodeW; + I: integer; begin - LoadFromBSONBytes(Value, False{saxMode}, true{ClearChildNodes}); + LNode := Self; + for I := low(path) to high(path) - 1 do begin + LTmpNode := LNode.ChildNodes.findNode(path[I]); + if (LTmpNode = nil) then exit(false) + else LNode := LTmpNode; + end; + I := LNode.ChildNodes.IndexOf(path[high(path)]); + if I >= 0 then begin + LNode.ChildNodes.Delete(I); + result := True; + end + else result := False; end; -{*************************************} -procedure TALJSONDocumentW.CheckActive; +{************************************************************************************************} +function TALJSONNodeW.CreateNode(const NodeName: String; NodeType: TALJSONNodeType): TALJSONNodeW; begin - if not Assigned(FDocumentNode) then ALJSONDocErrorW(CALJSONNotActive); + Result := ALCreateJSONNodeW(NodeName, NodeType); end; -{********************************************************************************************************************************************} -function TALJSONDocumentW.AddChild(const NodeName: String; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeW; +{********************************************} +{Returns the next child of this node’s parent. + NextSibling returns the node that follows this one in the parent node’s ChildNodes property list. + If this node is the last node in its parent’s child list, NextSibling raises an exception.} +function TALJSONNodeW.NextSibling: TALJSONNodeW; begin - Result := Node.AddChild(NodeName, NodeType, Index); + if Assigned(ParentNode) then Result := ParentNode.ChildNodes.FindSibling(Self, 1) + else Result := nil; end; -{*************************************************************************************************************************************************} -function TALJSONDocumentW.AddChild(const Path: array of String; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeW; +{************************************************} +{Returns the previous child of this node’s parent. + PreviousSibling returns the node that precedes this one in the parent node’s ChildNodes property list. + If this node is the first node in its parent’s child list, PreviousSibling raises an exception.} +function TALJSONNodeW.PreviousSibling: TALJSONNodeW; begin - Result := Node.AddChild(Path, NodeType, Index); + if Assigned(ParentNode) then Result := ParentNode.ChildNodes.FindSibling(Self, -1) + else Result := nil; end; -{*********************************************************************} -function TALJSONDocumentW.DeleteChild(const NodeName: String): boolean; -begin - Result := Node.DeleteChild(NodeName); -end; +{**************} +{The JSON format + There are just a few rules that you need to remember: + *Objects are encapsulated within opening and closing brackets { } { + *An empty object can be represented by { } { + *Arrays are encapsulated within opening and closing square brackets [ ] + *An empty array can be represented by [ ] + *A member is represented by a key-value pair + *The key of a member should be contained in double quotes. (JavaScript does not require this. JavaScript and some parsers will tolerate single-quotes) + *Each member should have a unique key within an object structure + *The value of a member must be contained in double quotes if it's a string (JavaScript and some parsers will tolerates single-quotes) + *Boolean values are represented using the true or false literals in lower case + *Number values are represented using double-precision floating-point format. Scientific notation is supported + *Numbers should not have leading zeroes + *"Offensive"" characters in a string need to be escaped using the backslash character + *Null values are represented by the null literal in lower case + *Other object types, such as dates, are not properly supported and should be converted to strings. It becomes the responsability of the parser/client to manage this. + *Each member of an object or each array value must be followed by a comma if it's not the last one + *The common extension for json files is '.json' + *The mime type for json files is 'application/json'} +{$ZEROBASEDSTRINGS OFF} +{$WARN WIDECHAR_REDUCED OFF} +Procedure TALJSONNodeW.ParseJSON( + const Buffer: String; + const SaxMode: Boolean; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions); + +Var BufferLength: Integer; + BufferPos: Integer; + CurrName: String; + CurrIndex: integer; + CurrValue: String; + NotSaxMode: Boolean; + WorkingNode: TALJSONNodeW; + NamePaths: TALNVStringListW; + ObjectPaths: TALIntegerList; + DecodeJSONReferences: boolean; -{**************************************************************************} -function TALJSONDocumentW.DeleteChild(const Path: array of String): boolean; -begin - Result := Node.DeleteChild(Path); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function GetPathStr(Const ExtraItems: String = ''): String; + var I, L, P, Size: Integer; + LB: Char; + S: String; + begin + LB := ALDefaultJsonPathSeparatorW; + Size := length(ExtraItems); + if size <> 0 then Inc(Size, 1{length(LB)}); + for I := 1 to NamePaths.Count - 1 do Inc(Size, Length(NamePaths.Names[I]) + 1{length(LB)}); + SetLength(Result, Size); + P := 1; + for I := 1 to NamePaths.Count - 1 do begin + S := NamePaths.Names[I]; + L := Length(S); + if L <> 0 then begin + ALMove(pointer(S)^, Pbyte(Result)[(P-1)*sizeOf(Char)], L*sizeOf(Char)); + Inc(P, L); + end; + L := 1{length(LB)}; + if ((i <> NamePaths.Count - 1) or + (ExtraItems <> '')) and + (((NotSaxMode) and (TALJSONNodeW(NamePaths.Objects[I]).nodetype <> ntarray)) or + ((not NotSaxMode) and (TALJSONNodeType(NamePaths.Objects[I]) <> ntarray))) then begin + ALMove(LB, Pbyte(Result)[(P-1)*sizeOf(Char)], L*sizeOf(Char)); + Inc(P, L); + end; + end; + if ExtraItems <> '' then begin + L := length(ExtraItems); + ALMove(pointer(ExtraItems)^, Pbyte(Result)[(P-1)*sizeOf(Char)], L*sizeOf(Char)); + Inc(P, L); + end; + setlength(result,P-1); + end; -{****************************************************************************************************} -function TALJSONDocumentW.CreateNode(const NodeName: String; NodeType: TALJSONNodeType): TALJSONNodeW; -begin - Result := ALCreateJSONNodeW(NodeName, NodeType); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseTextWithIndex( + const index: integer; + const Args: array of const; + const NodeSubType: TALJSONNodeSubType); + begin + if Assigned(OnParseText) then OnParseText(Self, GetPathStr('[' + ALIntToStrW(index) + ']'), '', Args, NodeSubType) + end; -{********************************************} -{Returns the value of the ChildNodes property. - GetChildNodes is the read implementation of the ChildNodes property.} -function TALJSONDocumentW.GetChildNodes: TALJSONNodeListW; -begin - Result := Node.ChildNodes; -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseTextWithName( + const name: String; + const Args: array of const; + const NodeSubType: TALJSONNodeSubType); + begin + if Assigned(OnParseText) then OnParseText(Self, GetPathStr(Name), Name, Args, NodeSubType) + end; -{***************************************************************************} -function TALJSONDocumentW.GetChildNode(const nodeName: String): TALJSONNodeW; -begin - result := Node.GetChildNode(nodeName); -end; + {~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseText( + const Index: integer; + const Name: String; + const Args: array of const; + const NodeSubType: TALJSONNodeSubType); + begin + if Assigned(OnParseText) then begin + if notSaxMode then begin + if WorkingNode.nodetype=ntarray then _DoParseTextWithIndex(Index, Args, NodeSubType) + else _DoParseTextWithName(Name, Args, NodeSubType); + end + else begin + if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); + if TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntArray then _DoParseTextWithIndex(Index, Args, NodeSubType) + else _DoParseTextWithName(Name, Args, NodeSubType); + end; + end; + end; -{*****************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueText(const nodeName: String; const default: String): String; -begin - result := Node.GetChildNodeValueText(nodeName, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseStartObject(const Name: String); + begin + if Assigned(OnParseStartObject) then OnParseStartObject(Self, GetPathStr, Name); + end; -{******************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueFloat(const nodeName: String; const default: Double): Double; -begin - result := Node.GetChildNodeValueFloat(nodeName, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseEndObject; + begin + if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); + if Assigned(OnParseEndObject) then OnParseEndObject(Self, GetPathStr, NamePaths.Names[NamePaths.Count - 1]) + end; -{***************************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueDateTime(const nodeName: String; const default: TDateTime): TDateTime; -begin - result := Node.GetChildNodeValueDateTime(nodeName, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseStartArray(const index: String); + begin + if Assigned(OnParseStartArray) then OnParseStartArray(Self, GetPathStr, index) + end; -{******************************************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueTimestamp(const nodeName: String; const default: TALBSONTimestamp): TALBSONTimestamp; -begin - result := Node.GetChildNodeValueTimestamp(nodeName, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseEndArray; + begin + if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); + if Assigned(OnParseEndArray) then OnParseEndArray(Self, GetPathStr, NamePaths.Names[NamePaths.Count - 1]); + end; -{*********************************************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueObjectID(const nodeName: String; const default: String): String; // return a hex string -begin - result := Node.GetChildNodeValueObjectID(nodeName, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _AddIndexItemToNamePath(const index: integer; Obj: Pointer); + var S1: String; + begin + setlength(S1,sizeOf(Integer) div sizeOF(Char)); // off course sizeOf(Integer) must be a multiple of sizeOf(char) but it's always the case + ALmove(index, pointer(S1)^, sizeOf(Integer)); + NamePaths.AddNameValueObject('[' + ALIntToStrW(Index) + ']', S1, Obj) + end; -{********************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueInt32(const nodeName: String; const default: Integer): Integer; -begin - result := Node.GetChildNodeValueInt32(nodeName, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _AddNameItemToNamePath(const name: String; Obj: Pointer); + begin + NamePaths.AddNameValueObject(Name, #$ffff#$ffff, Obj) + end; -{****************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueInt64(const nodeName: String; const default: Int64): Int64; -begin - result := Node.GetChildNodeValueInt64(nodeName, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _AddItemToNamePath(index: integer; const name: String; Obj: Pointer); + begin + if notSaxMode then begin + if WorkingNode.nodetype=ntarray then _AddIndexItemToNamePath(Index, Obj) + else _AddNameItemToNamePath(name, Obj); + end + else begin + if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); + if TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntarray then _AddIndexItemToNamePath(Index, Obj) + else _AddNameItemToNamePath(name, Obj); + end; + end; -{*******************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueBool(const nodeName: String; const default: Boolean): Boolean; -begin - result := Node.GetChildNodeValueBool(nodeName, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createInt64Node(index: integer; const name: String; const value: String): boolean; + var LNode: TALJSONNodeW; + LInt64: System.Int64; + begin + if ALJSONTryStrToInt64W(value, LInt64) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetInt64(LInt64); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LInt64], nstInt64) + end + else begin + _DoParseText(index, Name, [LInt64], nstInt64) + end; + end + else result := False; + end; -{***********************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueJavascript(const nodeName: String; const default: String): String; -begin - result := Node.GetChildNodeValueJavascript(nodeName, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createInt32Node(index: integer; const name: String; const value: String): boolean; + var LNode: TALJSONNodeW; + LInt32: System.Int32; + begin + if ALJSONTryStrToInt32W(value, LInt32) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setint32(LInt32); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LInt32], nstInt32) + end + else begin + _DoParseText(index, Name, [LInt32], nstInt32) + end + end + else result := False; + end; -{******************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueRegEx(const nodeName: String; const default: String): String; -begin - result := Node.GetChildNodeValueRegEx(nodeName, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createTextNode(index: integer; const name: String; const value: String): boolean; + var LNode: TALJSONNodeW; + begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Settext(value); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [value], nstText) + end + else begin + _DoParseText(index, Name, [value], nstText) + end + end; -{***************************************************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueRegExOptions(const nodeName: String; const default: TALPerlRegExOptions): TALPerlRegExOptions; -begin - result := Node.GetChildNodeValueRegExOptions(nodeName, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createFloatNode(index: integer; const name: String; const value: String): boolean; + var LNode: TALJSONNodeW; + LDouble: Double; + begin + if ALTryStrToFloat(value, LDouble, ALDefaultFormatSettingsW) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetFloat(LDouble); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LDouble], nstFloat) + end + else begin + _DoParseText(index, Name, [LDouble], nstFloat) + end + end + else result := False; + end; -{*******************************************************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueBinary(const nodeName: String; const default: String): String; // return a base64 encoded string -begin - result := Node.GetChildNodeValueBinary(nodeName, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createBinaryNode(index: integer; const name: String; const value: String): boolean; + var LNode: TALJSONNodeW; + LBinSubtype: byte; + LBinData: String; + begin + if ALJSONTryStrToBinaryW(value, LBinData, LBinSubtype) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.setbinary(LBinData, LBinSubtype); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LBinData, LBinSubtype], nstBinary); + end + else begin + _DoParseText(index, Name, [LBinData, LBinSubtype], nstBinary); + end + end + else result := False; + end; -{**********************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueBinarySubType(const nodeName: String; const default: byte): byte; -begin - result := Node.GetChildNodeValueBinarySubType(nodeName, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createObjectIDNode(index: integer; const name: String; const value: String): boolean; + var LNode: TALJSONNodeW; + LObjectID: String; + begin + if ALJSONTryStrToObjectIDW(value, LObjectID) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetObjectID(LObjectID); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LObjectID], nstObjectID) + end + else begin + _DoParseText(index, Name, [LObjectID], nstObjectID) + end; + end + else result := False; + end; -{*******************************************************************************} -function TALJSONDocumentW.GetChildNodeValueNull(const nodeName: String): Boolean; -begin - result := Node.GetChildNodeValueNull(nodeName); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createBooleanNode(index: integer; const name: String; const value: String): boolean; + var LNode: TALJSONNodeW; + LBool: Boolean; + begin + if value = 'true' then LBool := true + else if value = 'false' then LBool := false + else begin + result := False; + exit; + end; + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setbool(LBool); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LBool], nstBoolean); + end + else begin + _DoParseText(index, Name, [LBool], nstBoolean); + end; + end; -{********************************************************************************} -function TALJSONDocumentW.GetChildNode(const path: array of String): TALJSONNodeW; -begin - result := Node.GetChildNode(path); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createDateTimeNode(index: integer; const name: String; const value: String): boolean; + var LNode: TALJSONNodeW; + LDateTime: TdateTime; + begin + if ALJSONTryStrToDateTimeW(value, LDateTime) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setdatetime(LDateTime); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LDateTime], nstDateTime); + end + else begin + _DoParseText(index, Name, [LDateTime], nstDateTime); + end; + end + else result := False; + end; -{**********************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueText(const path: array of String; const default: String): String; -begin - result := Node.GetChildNodeValueText(path, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createTimestampNode(index: integer; const name: String; const value: String): boolean; + var LNode: TALJSONNodeW; + LTimestamp: TALBSONTimestamp; + begin + if ALJSONTryStrToTimestampW(value, LTimestamp) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetTimestamp(LTimestamp); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LTimestamp.W1, LTimestamp.W2], nstTimeStamp); + end + else begin + _DoParseText(index, Name, [LTimestamp.W1, LTimestamp.W2], nstTimeStamp); + end; + end + else result := False; + end; -{***********************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueFloat(const path: array of String; const default: Double): Double; -begin - result := Node.GetChildNodeValueFloat(path, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createnullNode(index: integer; const name: String; const value: String): boolean; + var LNode: TALJSONNodeW; + begin + if value = 'null' then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setnull(true); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, ['null'], nstNull); + end + else begin + _DoParseText(index, Name, ['null'], nstNull); + end; + end + else result := False; + end; -{********************************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueDateTime(const path: array of String; const default: TDateTime): TDateTime; -begin - result := Node.GetChildNodeValueDateTime(path, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createRegExNode(index: integer; const name: String; const value: String): boolean; + var LNode: TALJSONNodeW; + LRegEx: String; + LRegExOptions: TALPerlRegExOptions; + begin + if ALJSONTryStrToRegExW(value, LRegEx, LRegExOptions) then begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetRegEx(LRegEx, LRegExOptions); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [LRegEx, Byte(LRegExOptions)], nstRegEx) + end + else begin + _DoParseText(index, Name, [LRegEx, Byte(LRegExOptions)], nstRegEx) + end; + end + else result := False; + end; -{***********************************************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueTimestamp(const path: array of String; const default: TALBSONTimestamp): TALBSONTimestamp; -begin - result := Node.GetChildNodeValueTimestamp(path, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _createJavascriptNode(index: integer; const name: String; const value: String): boolean; + var LNode: TALJSONNodeW; + begin + result := true; + if NotSaxMode then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetJavascript(value); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(index, Name, [value], nstJavascript); + end + else begin + _DoParseText(index, Name, [value], nstJavascript); + end; + end; -{***************************************************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueObjectID(const path: array of String; const default: String): String; // return a hex string -begin - result := Node.GetChildNodeValueObjectID(path, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createNode(index: integer; const name: String; const value: String; AQuotedValue: Boolean); + begin + if AQuotedValue then begin + _createTextNode(index, Name, Value); + exit; + end; + if _createFloatNode(index, Name, Value) then exit; // << we have the same problem as javascript, if we put here a big number like (by exemple) 9223372036854775808 + // << then the stored value will be different because of double precision that is less than int64 precision + // << it's the way javascript json work, it's have no room for int / int64 :( + // << if we want to have the possibility to store int64 precision then we must use node subtype helper + // << like NumberLong(9223372036854775808) + if _createBooleanNode(index, Name, Value) then exit; + if _createNullNode(index, Name, Value) then exit; + if _createInt32Node(index, Name, Value) then exit; + if _createInt64Node(index, Name, Value) then exit; + if _createDateTimeNode(index, Name, Value) then exit; + if _createBinaryNode(index, Name, Value) then exit; + if _createObjectIDNode(index, Name, Value) then exit; + if _createRegExNode(index, Name, Value) then exit; + if _createTimeStampNode(index, Name, Value) then exit; + _createJavascriptNode(index, Name, Value); + end; -{*************************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueInt32(const path: array of String; const default: Integer): Integer; -begin - result := Node.GetChildNodeValueInt32(path, default); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _extractLastIndexFromNamePath: integer; + begin + if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); + ALMove(pointer(namePaths.ValueFromIndex[namepaths.Count - 1])^,result,sizeOf(integer)); + end; -{*********************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueInt64(const path: array of String; const default: Int64): Int64; -begin - result := Node.GetChildNodeValueInt64(path, default); -end; + {~~~~~~~~~~~~~~~~~~~~} + procedure AnalyzeNode; + Var LNode: TALJSONNodeW; + LNodeType: TALJSONNodeType; + LQuoteChar: Char; + LNameValueSeparator: Char; + LInSingleQuote: boolean; + LInDoubleQuote: boolean; + LInSlashQuote: boolean; + LInSquareBracket: integer; + LInRoundBracket: integer; + LInCurlyBracket: integer; + P1, P2: Integer; + c: Char; + Begin -{************************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueBool(const path: array of String; const default: Boolean): Boolean; -begin - result := Node.GetChildNodeValueBool(path, default); -end; + {$REGION 'init current char (c)'} + c := Buffer[BufferPos]; + {$ENDREGION} -{****************************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueJavascript(const path: array of String; const default: String): String; -begin - result := Node.GetChildNodeValueJavascript(path, default); -end; + {$REGION 'end Object/Array'} + // ... } .... + // ... ] .... + if c in ['}',']'] then begin // ... } ... + // ^BufferPos -{***********************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueRegEx(const path: array of String; const default: String): String; -begin - result := Node.GetChildNodeValueRegEx(path, default); -end; + //Reset the CurrIndex + CurrIndex := -1; -{********************************************************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueRegExOptions(const path: array of String; const default: TALPerlRegExOptions): TALPerlRegExOptions; -begin - result := Node.GetChildNodeValueRegExOptions(path, default); -end; + //error if Paths.Count = 0 (mean one end object/array without any starting) + if assigned(ObjectPaths) then begin + if (ObjectPaths.Count = 0) then ALJSONDocErrorW(cALJSONParseError); + end + else begin + if (NamePaths.Count = 0) then ALJSONDocErrorW(cALJSONParseError); + end; -{************************************************************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueBinary(const path: array of String; const default: String): String; // return a base64 encoded string -begin - result := Node.GetChildNodeValueBinary(path, default); -end; + //if we are not in sax mode + if NotSaxMode then begin -{***************************************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueBinarySubType(const path: array of String; const default: byte): byte; -begin - result := Node.GetChildNodeValueBinarySubType(path, default); -end; + //init anode to one level up + if assigned(ObjectPaths) then LNode := TALJSONNodeW(ObjectPaths.Objects[ObjectPaths.Count - 1]) + else LNode := TALJSONNodeW(NamePaths.Objects[NamePaths.Count - 1]); -{************************************************************************************} -function TALJSONDocumentW.GetChildNodeValueNull(const path: array of String): Boolean; -begin - result := Node.GetChildNodeValueNull(path); -end; + //if anode <> workingNode aie aie aie + if (LNode <> WorkingNode) then ALJSONDocErrorW(CALJSONParseError); -{********************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueText(const nodeName: String; const value: String); -begin - Node.SetChildNodeValueText(nodeName, value); -end; + //calculate anodeTypeInt + LNodeType := LNode.NodeType; + if not (LNodeType in [ntObject, ntarray]) then ALJSONDocErrorW(cALJSONParseError); -{*********************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueFloat(const nodeName: String; const value: Double); -begin - Node.SetChildNodeValueFloat(nodeName, value); -end; + //check that the end object/array correspond to the aNodeType + if ((c = '}') and + (LNodeType <> ntObject)) or + ((c = ']') and + (LNodeType <> ntarray)) then ALJSONDocErrorW(CALJSONParseError); -{***************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueDateTime(const nodeName: String; const value: TDateTime); -begin - Node.SetChildNodeValueDateTime(nodeName, value); -end; + //if working node <> Self then we can go to one level up + If WorkingNode <> Self then begin -{***********************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueTimestamp(const nodeName: String; const value: TALBSONTimestamp); -begin - Node.SetChildNodeValueTimestamp(nodeName, value); -end; + //init WorkingNode to the parentNode + WorkingNode := WorkingNode.ParentNode; -{************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueObjectID(const nodeName: String; const value: String); -begin - Node.SetChildNodeValueObjectID(nodeName, value); -end; + //update CurrIndex if WorkingNode.NodeType = ntArray + if assigned(ObjectPaths) then begin + if WorkingNode.NodeType = ntArray then CurrIndex := ObjectPaths[Objectpaths.Count - 1] + 1; + end + else begin + if WorkingNode.NodeType = ntArray then CurrIndex := _extractLastIndexFromNamePath + 1; + end; -{**********************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueInt32(const nodeName: String; const value: Integer); -begin - Node.SetChildNodeValueInt32(nodeName, value); -end; + end -{********************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueInt64(const nodeName: String; const value: Int64); -begin - Node.SetChildNodeValueInt64(nodeName, value); -end; + //if working node = Self then we can no go to the parent node so set WorkingNode to nil + Else WorkingNode := nil; -{*********************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueBool(const nodeName: String; const value: Boolean); -begin - Node.SetChildNodeValueBool(nodeName, value); -end; + end -{**************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueJavascript(const nodeName: String; const value: String); -begin - Node.SetChildNodeValueJavascript(nodeName, value); -end; + //if we are in sax mode + else begin -{*********************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueRegEx(const nodeName: String; const value: String); -begin - Node.SetChildNodeValueRegEx(nodeName, value); -end; + //calculate anodeTypeInt + LNodeType := TALJSONNodeType(NamePaths.Objects[NamePaths.Count - 1]); + if not (LNodeType in [ntObject,ntarray]) then ALJSONDocErrorW(cALJSONParseError); -{*****************************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueRegExOptions(const nodeName: String; const value: TALPerlRegExOptions); -begin - Node.SetChildNodeValueRegExOptions(nodeName, value); -end; + //check that the end object/array correspond to the aNodeType + if ((c = '}') and + (LNodeType <> ntObject)) or + ((c = ']') and + (LNodeType <> ntarray)) then ALJSONDocErrorW(CALJSONParseError); -{**********************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueBinary(const nodeName: String; const value: String); -begin - Node.SetChildNodeValueBinary(nodeName, value); -end; + //update CurrIndex if WorkingNode.NodeType = ntArray + if (Namepaths.Count >= 2) and + (TALJSONNodeType(NamePaths.Objects[Namepaths.Count - 2]) = ntarray) then CurrIndex := _extractLastIndexFromNamePath + 1; -{***************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueBinarySubType(const nodeName: String; const value: byte); -begin - Node.SetChildNodeValueBinarySubType(nodeName, value); -end; + end; -{***********************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueNull(const nodeName: String); -begin - Node.SetChildNodeValueNull(nodeName); -end; + //call the DoParseEndObject/array event + if Assigned(OnParseEndObject) then begin + if LNodeType = ntObject then _DoParseEndObject + else _DoParseEndArray; + end; -{*************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueText(const path: array of String; const value: String); -begin - Node.SetChildNodeValueText(path, value); -end; + //delete the last entry from the path + if assigned(ObjectPaths) then ObjectPaths.Delete(ObjectPaths.Count - 1) + else NamePaths.Delete(NamePaths.Count - 1); -{**************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueFloat(const path: array of String; const value: Double); -begin - Node.SetChildNodeValueFloat(path, value); -end; + //update BufferPos + BufferPos := BufferPos + 1; // ... } ... + // ^BufferPos -{********************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueDateTime(const path: array of String; const value: TDateTime); -begin - Node.SetChildNodeValueDateTime(path, value); -end; + //finallly exit from this procedure, everything was done + exit; -{****************************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueTimestamp(const path: array of String; const value: TALBSONTimestamp); -begin - Node.SetChildNodeValueTimestamp(path, value); -end; + end; + {$ENDREGION} -{*****************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueObjectID(const path: array of String; const value: String); -begin - Node.SetChildNodeValueObjectID(path, value); -end; + {$REGION 'Begin Object/Array Without NAME'} + // ... { .... + // ... [ .... + if c in ['{','['] then begin // ... { ... + // ^BufferPos -{***************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueInt32(const path: array of String; const value: Integer); -begin - Node.SetChildNodeValueInt32(path, value); -end; + //if we are not in sax mode + if NotSaxMode then begin -{*************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueInt64(const path: array of String; const value: Int64); -begin - Node.SetChildNodeValueInt64(path, value); -end; + //if workingnode = nil then it's mean we are outside Self + if not assigned(WorkingNode) then ALJSONDocErrorW(CALJSONParseError); -{**************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueBool(const path: array of String; const value: Boolean); -begin - Node.SetChildNodeValueBool(path, value); -end; + //Node without name can be ONLY present inside an array node + if (CurrIndex < 0) or + (WorkingNode.nodetype <> ntarray) then ALJSONDocErrorW(CALJSONParseError); -{*******************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueJavascript(const path: array of String; const value: String); -begin - Node.SetChildNodeValueJavascript(path, value); -end; + //create the node according the the braket char and add it to the workingnode + if c = '{' then LNode := CreateNode('', ntObject) + else LNode := CreateNode('', ntarray); + try + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; -{**************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueRegEx(const path: array of String; const value: String); -begin - Node.SetChildNodeValueRegEx(path, value); -end; + //set that the current working node will be now the new node newly created + WorkingNode := LNode; -{**********************************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueRegExOptions(const path: array of String; const value: TALPerlRegExOptions); -begin - Node.SetChildNodeValueRegExOptions(path, value); -end; + //update the path + if assigned(ObjectPaths) then ObjectPaths.AddObject(CurrIndex, WorkingNode) + else _AddItemToNamePath(CurrIndex, '', WorkingNode); -{***************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueBinary(const path: array of String; const value: String); -begin - Node.SetChildNodeValueBinary(path, value); -end; + end -{********************************************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueBinarySubType(const path: array of String; const value: byte); -begin - Node.SetChildNodeValueBinarySubType(path, value); -end; + //if we are in sax mode + else begin -{****************************************************************************} -procedure TALJSONDocumentW.SetChildNodeValueNull(const path: array of String); -begin - Node.SetChildNodeValueNull(path); -end; + //Node without name can be ONLY present inside an array node + if (CurrIndex < 0) or + (NamePaths.Count = 0) or + (TALJsonNodeType(NamePaths.Objects[Namepaths.Count - 1]) <> ntarray) then ALJSONDocErrorW(CALJSONParseError); -{**************************************************} -function TALJSONDocumentW.ExtractNode: TALJSONNodeW; -begin - if assigned(FDocumentNode) then begin - result := FDocumentNode; - result.SetOwnerDocument(nil); - FDocumentNode := nil; - end - else result := nil; -end; + //update the path + if c = '{' then LNodeType := ntObject + else LNodeType := ntArray; + _AddItemToNamePath(CurrIndex, '', pointer(LNodeType)); -{************************************************************************} -{Indicates whether the TJSONDocument instance represents an empty document. - Call IsEmptyDoc to determine whether the TALJSONDocumentW instance represents an empty document. - IsEmptyDoc returns true if the Document property is not set or if this object represents a - document with no child nodes.} -function TALJSONDocumentW.IsEmptyDoc: Boolean; -begin - Result := not (Assigned(FDocumentNode) and FDocumentNode.hasChildNodes); -end; + end; -{**************************************} -{Returns the value of the Node property. - GetDocumentNode is the read implementation of the Node property.} -function TALJSONDocumentW.GetDocumentNode: TALJSONNodeW; -begin - CheckActive; - Result := FDocumentNode; -end; + //call the DoParseStartObject/array event + if c = '{' then begin + if Assigned(OnParseStartObject) then _DoParseStartObject(''); + CurrIndex := -1; + end + else begin + if Assigned(OnParseStartArray) then _DoParseStartArray(''); + CurrIndex := 0; + end; -{***********************************************} -{Returns the value of the NodeIndentStr property. - GetNodeIndentStr is the read implementation of the NodeIndentStr property.} -function TALJSONDocumentW.GetNodeIndentStr: String; -begin - Result := FNodeIndentStr; -end; + //update BufferPos + BufferPos := BufferPos + 1; // ... { ... + // ^BufferPos -{********************************************} -{Sets the value of the NodeIndentStr property. - SetNodeIndentStr is the write implementation of the NodeIndentStr property. - *Value is the string that is inserted before nested nodes to indicate a level of nesting.} -procedure TALJSONDocumentW.SetNodeIndentStr(const Value: String); -begin - FNodeIndentStr := Value; -end; + //finallly exit from this procedure, everything was done + exit; -{*****************************************************************} -procedure TALJSONDocumentW.SetDuplicates(const Value: TDuplicates); -begin - if FDuplicates <> Value then begin - FDuplicates := Value; - if assigned(FDocumentNode) then begin - Var LNodeList := FDocumentNode.InternalGetChildNodes; - if LNodeList <> nil then LNodeList.SetDuplicates(FDuplicates, True{Recurse}) end; - end; -end; + {$ENDREGION} -{*****************************************} -{Returns the value of the Options property. - GetOptions is the read implementation of the Options property.} -function TALJSONDocumentW.GetOptions: TALJSONDocOptions; -begin - Result := FOptions; -end; + {$REGION 'extract the quoted name part'} + // "" : "" + // "name" : "value" + // "name" : 1.23 + // "name" : true + // "name" : false + // "name" : null + // "name" : ISODATE('1/1/2001') + // "name" : function(){return(new Date).getTime()}, ...} + // "name" : new Date(''Dec 03, 1924'') + // "name" : { ... } + // "name" : [ ... ] + // 'name' : '...' + // "value" + // 'value' + LQuoteChar := #0; + if c in ['"',''''] then begin // ... " ... + // ^BufferPos + LQuoteChar := c; // " + P1 := BufferPos + 1; // ... "...\"..." + // ^P1 + While P1 <= BufferLength do begin -{**************************************} -{Sets the value of the Options property. - GetOptions is the write implementation of the Options property. - *Value is the set of options to assign.} -procedure TALJSONDocumentW.SetOptions(const Value: TALJSONDocOptions); -begin - var LSortedChanged := (doSorted in FOptions) <> (doSorted in Value); - FOptions := Value; - if LSortedChanged and assigned(FDocumentNode) then begin - Var LNodeList := FDocumentNode.InternalGetChildNodes; - if LNodeList <> nil then LNodeList.SetSorted(doSorted in FOptions, True{Recurse}) - end; -end; + c := Buffer[P1]; -{**********************************************} -{Returns the value of the ParseOptions property. - GetParseOptions is the read implementation of the ParseOptions property.} -function TALJSONDocumentW.GetParseOptions: TALJSONParseOptions; -begin - Result := FParseOptions; -end; + If (c = '\') and + (P1 < BufferLength) and + (Buffer[P1 + 1] in ['\', LQuoteChar]) then inc(p1, 2) // ... "...\"..." + // ^^^P1 + else if c = LQuoteChar then begin + ALCopyStr(Buffer,CurrName,BufferPos + 1,P1-BufferPos - 1); + if DecodeJSONReferences then ALJavascriptDecodeV(CurrName); // ..."... + break; + end + else inc(P1); // ... "...\"..." + // ^^^^^^^^^P1 -{*******************************************} -{Sets the value of the ParseOptions property. - GetParseOptions is the write implementation of the ParseOptions property. - *Value is the set of parser options to assign.} -procedure TALJSONDocumentW.SetParseOptions(const Value: TALJSONParseOptions); -begin - FParseOptions := Value; -end; + end; + if P1 > BufferLength then ALJSONDocErrorW(CALJSONParseError); + BufferPos := P1 + 1; // ... "...\"..." + // ^^^^^^^^^^BufferPos + end + {$ENDREGION} -{*************************************************************} -procedure TALJSONDocumentW.SetPathSeparator(const Value: Char); -begin - FPathSeparator := Value; -end; + {$REGION 'extract the unquoted name part'} + // name : "value" + // name : 1.23 + // name : true + // name : false + // name : null + // name : ISODATE('1/1/2001') + // name : function(){return(new Date).getTime()}, ...} + // name : new Date('Dec 03, 1924') + // name : { ... } + // name : [ ... ] + // 1.23 + // true + // false + // null + // ISODATE('1/1/2001') + // function(){return(new Date).getTime()}, ...} + // new Date('Dec 03, 1924') + else begin -{***********************************************} -function TALJSONDocumentW.GetPathSeparator: Char; -begin - result := fPathSeparator; -end; + LInSingleQuote := False; + LInDoubleQuote := False; + LInSquareBracket := 0; + LInRoundBracket := 0; + LInCurlyBracket := 0; -{**********************************************} -procedure TALJSONDocumentW.DoParseStartDocument; -begin - if Assigned(fonParseStartDocument) then fonParseStartDocument(Self); -end; + While (BufferPos <= BufferLength) do begin + If Buffer[BufferPos] <= ' ' then inc(bufferPos) + else break; + end; + if BufferPos > BufferLength then ALJSONDocErrorW(CALJSONParseError); -{********************************************} -procedure TALJSONDocumentW.DoParseEndDocument; -begin - if Assigned(fonParseEndDocument) then fonParseEndDocument(Self); -end; + P1 := BufferPos; // ... new Date('Dec 03, 1924'), .... + // ^P1 + While (P1 <= BufferLength) do begin -{******************************************************************************************************************************************} -procedure TALJSONDocumentW.DoParseText(const Path: String; const name: String; const Args: array of const; NodeSubType: TALJSONNodeSubType); -begin - if Assigned(fonParseText) then fonParseText(Self, Path, name, Args, NodeSubType); -end; + c := Buffer[P1]; -{************************************************************************************} -procedure TALJSONDocumentW.DoParseStartObject(const Path: String; const Name: String); -begin - if Assigned(fonParseStartObject) then fonParseStartObject(Self, Path, name); -end; + if (not LInSingleQuote) and + (not LInDoubleQuote) and + (LInSquareBracket = 0) and + (LInRoundBracket = 0) and + (LInCurlyBracket = 0) and + (c in [',', '}', ']', ':']) then begin + P2 := P1-1; + While P2 >= BufferPos do begin + If Buffer[P2] <= ' ' then dec(P2) + else break; + end; + ALCopyStr(Buffer,CurrName,BufferPos,P2-BufferPos+1); // new Date('Dec 03, 1924') + break; + end + else if (c = '"') then begin + if (P1 <= 1) or + (Buffer[P1 - 1] <> '\') then LInDoubleQuote := (not LInDoubleQuote) and (not LInSingleQuote); + end + else if (c = '''') then begin + if (P1 <= 1) or + (Buffer[P1 - 1] <> '\') then LInSingleQuote := (not LInSingleQuote) and (not LInDoubleQuote) + end + else if (not LInSingleQuote) and + (not LInDoubleQuote) then begin + if (c = '[') then inc(LInSquareBracket) + else if (c = ']') then dec(LInSquareBracket) + else if (c = '(') then inc(LInRoundBracket) + else if (c = ')') then dec(LInRoundBracket) + else if (c = '}') then inc(LInCurlyBracket) + else if (c = '{') then dec(LInCurlyBracket); + end; -{**********************************************************************************} -procedure TALJSONDocumentW.DoParseEndObject(const Path: String; const Name: String); -begin - if Assigned(fonParseEndObject) then fonParseEndObject(Self, Path, name); -end; + inc(P1); // ... new Date('Dec 03, 1924'), .... + // ^^^^^^^^^^^^^^^^^^^^^^^^^P1 -{***********************************************************************************} -procedure TALJSONDocumentW.DoParseStartArray(const Path: String; const Name: String); -begin - if Assigned(fonParseStartArray) then fonParseStartArray(Self, Path, name); -end; + end; + if P1 > BufferLength then ALJSONDocErrorW(CALJSONParseError); + BufferPos := P1; // ... new Date('Dec 03, 1924'), .... + // ^BufferPos -{*********************************************************************************} -procedure TALJSONDocumentW.DoParseEndArray(const Path: String; const Name: String); -begin - if Assigned(fonParseEndArray) then fonParseEndArray(Self, Path, name); -end; + end; + {$ENDREGION} -{**********************************************************} -{Creates the object that implements the ChildNodes property} -function TALJSONNodeW.CreateChildList: TALJSONNodeListW; -begin - result := TALJSONNodeListW.Create(Self); -end; + {$REGION 'extract the name value separator part'} + LNameValueSeparator := #0; + While (BufferPos <= BufferLength) do begin + If Buffer[BufferPos] <= ' ' then inc(BufferPos) + else begin + LNameValueSeparator := Buffer[BufferPos]; + break; + end; + end; + if BufferPos > BufferLength then ALJSONDocErrorW(CALJSONParseError); // .... : .... + // ^BufferPos + {$ENDREGION} -{********************************************} -{Get Childnode without create it if not exist} -function TALJSONNodeW.InternalGetChildNodes: TALJSONNodeListW; -begin - Result := nil; //virtual; -end; + {$REGION 'if aNameValueSeparator is absent then it is just a value'} + if LNameValueSeparator <> ':' then begin -{****************************************************} -function TALJSONNodeW.GetChildNodes: TALJSONNodeListW; -begin - Result := nil; // hide warning - ALJSONDocErrorW(CALJsonOperationError,GetNodeType) -end; + //Node without name can be ONLY present inside an array node + if NotSaxMode then begin + if not assigned(WorkingNode) then ALJSONDocErrorW(CALJSONParseError); + if (CurrIndex < 0) or + (WorkingNode.nodetype <> ntarray) then ALJSONDocErrorW(CALJSONParseError); + end + else begin + if (CurrIndex < 0) or + (NamePaths.Count = 0) or + (TALJSONNodeType(NamePaths.Objects[Namepaths.Count - 1]) <> ntarray) then ALJSONDocErrorW(CALJSONParseError); + end; -{******************************************************************} -procedure TALJSONNodeW.SetChildNodes(const Value: TALJSONNodeListW); -begin - ALJSONDocErrorW(CALJsonOperationError,GetNodeType) -end; + //create the node + _createNode(CurrIndex,'',CurrName,LQuoteChar in ['"','''']); -{***********************************************************************} -function TALJSONNodeW.GetChildNode(const nodeName: String): TALJSONNodeW; -begin - result := ChildNodes.findNode(nodeName); -end; + //increase the CurrIndex + inc(CurrIndex); -{*************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueText(const nodeName: String; const default: String): String; -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetText(default); -end; + //finallly exit from this procedure, everything was done + exit; + + end; + {$ENDREGION} + + {$REGION 'remove the blank space between the name valueeparator and the value'} + inc(BufferPos); // ... : .... + // ^BufferPos + While (BufferPos <= BufferLength) do begin + If Buffer[BufferPos] <= ' ' then inc(BufferPos) + else break; + end; + if BufferPos > BufferLength then ALJSONDocErrorW(CALJSONParseError); // .... " .... + // ^BufferPos + {$ENDREGION} -{**************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueFloat(const nodeName: String; const default: Double): Double; -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetFloat(default); -end; + {$REGION 'init current char (c)'} + c := Buffer[BufferPos]; + {$ENDREGION} -{***********************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueDateTime(const nodeName: String; const default: TDateTime): TDateTime; -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetDateTime(default); -end; + {$REGION 'if the value is an object/array'} + // name : { ... } + // name : [ ... ] + if c in ['{','['] then begin // ... { ... + // ^BufferPos -{**************************************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueTimestamp(const nodeName: String; const default: TALBSONTimestamp): TALBSONTimestamp; -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetTimestamp(default); -end; + //if we are not in sax mode + if NotSaxMode then begin -{****************************************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueObjectID(const nodeName: String; const default: String): String; // return a hex string -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetObjectID(default); -end; + //if workingnode = nil then it's mean we are outside Self + if not assigned(WorkingNode) then ALJSONDocErrorW(CALJSONParseError); -{****************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueInt32(const nodeName: String; const default: Integer): Integer; -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetInt32(default); -end; + //Node withe name MUST be ONLY present inside an object node + if (CurrIndex >= 0) or + (WorkingNode.nodetype <> ntObject) then ALJSONDocErrorW(CALJSONParseError); -{************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueInt64(const nodeName: String; const default: Int64): Int64; -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetInt64(default); -end; + //create the node according the the braket char and add it to the workingnode + if c = '{' then LNode := CreateNode(CurrName, ntObject) + else LNode := CreateNode(CurrName, ntarray); + try + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; -{***************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueBool(const nodeName: String; const default: Boolean): Boolean; -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetBool(default); -end; + //set that the current working node will be now the new node newly created + WorkingNode := LNode; -{*******************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueJavascript(const nodeName: String; const default: String): String; -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetJavascript(default); -end; + //update the path + if assigned(ObjectPaths) then ObjectPaths.AddObject(-1, WorkingNode) + else _AddItemToNamePath(-1, CurrName, WorkingNode); -{**************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueRegEx(const nodeName: String; const default: String): String; -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetRegEx(default); -end; + end -{***********************************************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueRegExOptions(const nodeName: String; const default: TALPerlRegExOptions): TALPerlRegExOptions; -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetRegExOptions(default); -end; + //if we are in sax mode + else begin -{**************************************************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueBinary(const nodeName: String; const default: String): String; // return a base64 encoded string -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetBinary(default); -end; + //Node withe name MUST be ONLY present inside an object node + if (CurrIndex >= 0) or + (NamePaths.Count = 0) or + (TALJsonNodeType(NamePaths.Objects[NamePaths.Count - 1]) <> ntobject) then ALJSONDocErrorW(CALJSONParseError); -{******************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueBinarySubType(const nodeName: String; const default: byte): byte; -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := default - else result := LNode.GetBinarySubType(default); -end; + //update the path + if c = '{' then LNodeType := ntObject + else LNodeType := ntArray; + _AddItemToNamePath(-1, CurrName, pointer(LNodeType)); -{***************************************************************************} -function TALJSONNodeW.GetChildNodeValueNull(const nodeName: String): Boolean; -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then result := true - else result := LNode.GetNull; -end; + end; -{****************************************************************************} -function TALJSONNodeW.GetChildNode(const path: array of String): TALJSONNodeW; -var I: integer; -begin - result := Self; - for I := low(path) to high(path) do begin - result := result.ChildNodes.findNode(path[I]); - if (result = nil) then exit; - end; -end; + //call the DoParseStartObject/array event and update the CurrIndex if it's an array + if c = '{' then begin + if Assigned(OnParseStartObject) then _DoParseStartObject(CurrName) + end + else begin + if Assigned(OnParseStartArray) then _DoParseStartArray(CurrName); + CurrIndex := 0; + end; -{******************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueText(const path: array of String; const default: String): String; -var LNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetText(default); -end; + //update BufferPos + BufferPos := BufferPos + 1; // ... { ... + // ^BufferPos -{*******************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueFloat(const path: array of String; const default: Double): Double; -var LNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; + //finallly exit from this procedure, everything was done exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetFloat(default); -end; -{****************************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueDateTime(const path: array of String; const default: TDateTime): TDateTime; -var LNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetDateTime(default); -end; + {$ENDREGION} + + {$REGION 'if the value is a quoted string'} + // name : "value" + // name : 'value' + LQuoteChar := #0; + if c in ['"',''''] then begin // ... " ... + // ^BufferPos + + LQuoteChar := c; // " + P1 := BufferPos + 1; // ... "...\"..." + // ^P1 + While P1 <= BufferLength do begin + + c := Buffer[P1]; + + If (c = '\') and + (P1 < BufferLength) and + (Buffer[P1 + 1] in ['\', LQuoteChar]) then inc(p1, 2) // ... "...\"..." + // ^^^P1 + else if c = LQuoteChar then begin + ALCopyStr(Buffer,currValue,BufferPos + 1,P1-BufferPos - 1); + if DecodeJSONReferences then ALJavascriptDecodeV(currValue); // ..."... + break; + end + else inc(P1); // ... "...\"..." + // ^^^^^^^^^P1 + + end; + if P1 > BufferLength then ALJSONDocErrorW(CALJSONParseError); + BufferPos := P1 + 1; // ... "...\"..." + // ^^^^^^^^^^BufferPos + + end + {$ENDREGION} + + {$REGION 'if the value is a UNquoted string'} + // name : 1.23 + // name : true + // name : false + // name : null + // name : ISODATE('1/1/2001') + // name : function(){return(new Date).getTime()}, ...} + // name : new Date(''Dec 03, 1924'') + // name : /test/i + else begin -{*******************************************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueTimestamp(const path: array of String; const default: TALBSONTimestamp): TALBSONTimestamp; -var LNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetTimestamp(default); -end; + LInSingleQuote := False; + LInDoubleQuote := False; + LInSlashQuote := False; + LInSquareBracket := 0; + LInRoundBracket := 0; + LInCurlyBracket := 0; -{*********************************************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueObjectID(const path: array of String; const default: String): String; // return a hex string -var LNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetObjectID(default); -end; + While (BufferPos <= BufferLength) do begin + If Buffer[BufferPos] <= ' ' then inc(bufferPos) + else break; + end; + if BufferPos > BufferLength then ALJSONDocErrorW(CALJSONParseError); -{*********************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueInt32(const path: array of String; const default: Integer): Integer; -var LNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetInt32(default); -end; + P1 := BufferPos; // ... new Date('Dec 03, 1924'), .... + // ^P1 + While (P1 <= BufferLength) do begin -{*****************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueInt64(const path: array of String; const default: Int64): Int64; -var LNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetInt64(default); -end; + c := Buffer[P1]; -{********************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueBool(const path: array of String; const default: Boolean): Boolean; -var LNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetBool(default); -end; + if (not LInSingleQuote) and + (not LInDoubleQuote) and + (not LInSlashQuote) and + (LInSquareBracket = 0) and + (LInRoundBracket = 0) and + (LInCurlyBracket = 0) and + (c in [',', '}', ']']) then begin + P2 := P1-1; + While P2 >= BufferPos do begin + If Buffer[P2] <= ' ' then dec(P2) + else break; + end; + ALCopyStr(Buffer,currValue,BufferPos,P2-BufferPos+1); // new Date('Dec 03, 1924') + break; + end + else if (c = '"') then begin + if (P1 <= 1) or + (Buffer[P1 - 1] <> '\') then LInDoubleQuote := (not LInDoubleQuote) and (not LInSingleQuote) and (not LInSlashQuote); + end + else if (c = '''') then begin + if (P1 <= 1) or + (Buffer[P1 - 1] <> '\') then LInSingleQuote := (not LInSingleQuote) and (not LInDoubleQuote) and (not LInSlashQuote); + end + else if (c = '/') then begin + if (P1 <= 1) or + (Buffer[P1 - 1] <> '\') then LInSlashQuote := (not LInSingleQuote) and (not LInDoubleQuote) and (not LInSlashQuote); + end + else if (not LInSingleQuote) and + (not LInDoubleQuote) and + (not LInSlashQuote) then begin + if (c = '[') then inc(LInSquareBracket) + else if (c = ']') then dec(LInSquareBracket) + else if (c = '(') then inc(LInRoundBracket) + else if (c = ')') then dec(LInRoundBracket) + else if (c = '}') then inc(LInCurlyBracket) + else if (c = '{') then dec(LInCurlyBracket); + end; -{************************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueJavascript(const path: array of String; const default: String): String; -var LNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetJavascript(default); -end; + inc(P1); // ... new Date('Dec 03, 1924'), .... + // ^^^^^^^^^^^^^^^^^^^^^^^^^P1 -{*******************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueRegEx(const path: array of String; const default: String): String; -var LNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetRegEx(default); -end; + end; + if P1 > BufferLength then ALJSONDocErrorW(CALJSONParseError); + BufferPos := P1; // ... new Date('Dec 03, 1924'), .... + // ^BufferPos -{****************************************************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueRegExOptions(const path: array of String; const default: TALPerlRegExOptions): TALPerlRegExOptions; -var LNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetRegExOptions(default); -end; -{*******************************************************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueBinary(const path: array of String; const default: String): String; // return a base64 encoded string -var LNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetBinary(default); -end; + {$ENDREGION} -{***********************************************************************************************************} -function TALJSONNodeW.GetChildNodeValueBinarySubType(const path: array of String; const default: byte): byte; -var LNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := default; - exit; - end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := default - else result := LNode.GetBinarySubType(default); -end; + {$REGION 'create the named text node'} -{********************************************************************************} -function TALJSONNodeW.GetChildNodeValueNull(const path: array of String): Boolean; -var LNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LNode := LNode.ChildNodes.findNode(path[I]); - if (LNode = nil) then begin - result := True; - exit; + //Node withe name MUST be ONLY present inside an object node + if NotSaxMode then begin + if not assigned(WorkingNode) then ALJSONDocErrorW(CALJSONParseError); + if (CurrIndex >= 0) or + (WorkingNode.nodetype <> ntObject) then ALJSONDocErrorW(CALJSONParseError); + end + else begin + if (CurrIndex >= 0) or + (NamePaths.Count = 0) or + (TALJSONNodeType(NamePaths.Objects[Namepaths.Count - 1]) <> ntObject) then ALJSONDocErrorW(CALJSONParseError); end; - end; - LNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LNode = nil) then result := true - else result := LNode.GetNull; -end; -{****************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueText(const nodeName: String; const value: String); -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetText(value) - else LNode.SetText(value); -end; + //create the node + _createNode(currIndex,CurrName,CurrValue,LQuoteChar in ['"','''']); -{*****************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueFloat(const nodeName: String; const value: Double); -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetFloat(value) - else LNode.SetFloat(value); -end; + {$ENDREGION} -{***********************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueDateTime(const nodeName: String; const value: TDateTime); -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetDateTime(value) - else LNode.SetDateTime(value); -end; + end; -{*******************************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueTimestamp(const nodeName: String; const value: TALBSONTimestamp); -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetTimestamp(value) - else LNode.SetTimestamp(value); -end; +var InCommentLine: integer; + c: Char; -{********************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueObjectID(const nodeName: String; const value: String); -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetObjectID(value) - else LNode.SetObjectID(value); -end; +Begin -{******************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueInt32(const nodeName: String; const value: Integer); -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetInt32(value) - else LNode.SetInt32(value); -end; + //clear the childnodes + if poClearChildNodes in Options then ChildNodes.Clear; -{****************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueInt64(const nodeName: String; const value: Int64); -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetInt64(value) - else LNode.SetInt64(value); -end; + //init WorkingNode and NotSaxMode and DecodeJSONReferences + WorkingNode := Self; + NotSaxMode := not SaxMode; + DecodeJSONReferences := not (poIgnoreControlCharacters in Options); -{*****************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueBool(const nodeName: String; const value: Boolean); -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetBool(value) - else LNode.SetBool(value); -end; + //init ObjectPaths or NamePaths + if (NotSaxMode) and + (not assigned(OnParseText)) and + (not assigned(OnParseStartObject)) and + (not assigned(OnParseEndObject)) and + (not assigned(OnParseStartArray)) and + (not assigned(OnParseEndArray)) then begin + ObjectPaths := TALIntegerList.Create(false{OwnsObjects}); + NamePaths := nil; + end + else begin + ObjectPaths := nil; + NamePaths := TALNVStringListW.Create; + end; + Try -{**********************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueJavascript(const nodeName: String; const value: String); -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetJavascript(value) - else LNode.SetJavascript(value); -end; + //init Buffer + BufferLength := length(Buffer); + BufferPos := 1; -{*****************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueRegEx(const nodeName: String; const value: String); -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetRegEx(value) - else LNode.SetRegEx(value); -end; + //add first node in ObjectPaths/NamePaths + if assigned(ObjectPaths) then ObjectPaths.AddObject(-1, WorkingNode) + else begin + if NotSaxMode then _AddNameItemToNamePath('', WorkingNode) + else _AddNameItemToNamePath('', pointer(NodeType)); + end; -{*************************************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueRegExOptions(const nodeName: String; const value: TALPerlRegExOptions); -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetRegExOptions(value) - else LNode.SetRegExOptions(value); -end; + //skip the first { + While (BufferPos <= BufferLength) do begin + c := Buffer[BufferPos]; + If c <= ' ' then inc(bufferPos) + else begin + if (c = '{') then begin + if (Nodetype <> ntObject) then ALJSONDocErrorW(CALJsonOperationError,GetNodeType); + CurrIndex := -1; + _DoParseStartObject(''); + end + else if (c = '[') then begin + if (Nodetype <> ntArray) then ALJSONDocErrorW(CALJsonOperationError,GetNodeType); + CurrIndex := 0; + _DoParseStartArray(''); + end + else AlJSONDocErrorW(cALJSONParseError); + inc(bufferPos); + break; + end; + end; -{******************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueBinary(const nodeName: String; const value: String); -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetBinary(value) - else LNode.SetBinary(value); -end; + //analyze all the nodes + if poAllowComments in Options then begin + InCommentLine := 0; + While (BufferPos <= BufferLength) do begin + c := Buffer[BufferPos]; + If (InCommentLine = 0) and ((c <= ' ') or (c = ',')) then inc(bufferPos) + else if (InCommentLine <= 1) and (c = '/') then begin + inc(InCommentLine); + inc(bufferPos); + end + else if (InCommentLine = 2) then begin + if ((c = #13) or (c = #10)) then InCommentLine := 0; + inc(bufferPos); + end + else begin + if InCommentLine = 1 then begin + InCommentLine := 0; + dec(BufferPos); + end; + AnalyzeNode; + end; + end; + end + else begin + While (BufferPos <= BufferLength) do begin + c := Buffer[BufferPos]; + If (c <= ' ') or (c = ',') then inc(bufferPos) + else AnalyzeNode; + end; + end; -{***********************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueBinarySubType(const nodeName: String; const value: byte); -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetBinarySubType(value) - else LNode.SetBinarySubType(value); -end; + //some tags are not closed + if assigned(ObjectPaths) then begin + if ObjectPaths.Count > 0 then ALJSONDocErrorW(cALJSONParseError); + end + else begin + if NamePaths.Count > 0 then ALJSONDocErrorW(cALJSONParseError); + end; -{*******************************************************************} -procedure TALJSONNodeW.SetChildNodeValueNull(const nodeName: String); -var LNode: TALJSONNodeW; -begin - LNode := ChildNodes.findNode(nodeName); - if (LNode = nil) then addChild(nodeName).SetNull(true) - else LNode.SetNull(true); -end; + //mean the node was not update (empty stream?) or not weel closed + if NotSaxMode and (WorkingNode <> nil) then ALJSONDocErrorW(cALJSONParseError); -{*********************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueText(const path: array of String; const value: String); -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; - end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetText(value) - else LTmpNode.SetText(value); -end; + finally -{**********************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueFloat(const path: array of String; const value: Double); -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; - end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetFloat(value) - else LTmpNode.SetFloat(value); -end; + //free ObjectPaths/NamePaths + if assigned(ObjectPaths) then ALFreeAndNil(ObjectPaths) + else ALFreeAndNil(NamePaths); -{****************************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueDateTime(const path: array of String; const value: TDateTime); -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetDateTime(value) - else LTmpNode.SetDateTime(value); + end; +{$WARN WIDECHAR_REDUCED ON} +{$IF defined(ALZeroBasedStringsON)} + {$ZEROBASEDSTRINGS ON} +{$IFEND} + +{*************************************************************} +{Last version of the spec: http://bsonspec.org/#/specification} +procedure TALJSONNodeW.ParseBSON( + const Buffer: Tbytes; + const SaxMode: Boolean; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions); + +Var BufferLength: Integer; + BufferPos: Integer; + CurrName: String; + NotSaxMode: Boolean; + WorkingNode: TALJSONNodeW; + NamePaths: TALStringListW; + ObjectPaths: TObjectList; -{************************************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueTimestamp(const path: array of String; const value: TALBSONTimestamp); -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function GetPathStr(Const ExtraItems: String = ''): String; + var I, L, P, Size: Integer; + LB: Char; + S: String; + begin + LB := ALDefaultJsonPathSeparatorW; + Size := length(ExtraItems); + if size <> 0 then Inc(Size, 1{length(LB)}); + for I := 1 to NamePaths.Count - 1 do Inc(Size, Length(NamePaths[I]) + 1{length(LB)}); + SetLength(Result, Size); + P := 1; + for I := 1 to NamePaths.Count - 1 do begin + S := NamePaths[I]; + L := Length(S); + if L <> 0 then begin + ALMove(pointer(S)^, Pbyte(Result)[(P-1)*sizeOf(Char)], L*sizeOf(Char)); + Inc(P, L); + end; + L := 1{length(LB)}; + if ((i <> NamePaths.Count - 1) or + (ExtraItems <> '')) and + (((NotSaxMode) and (TALJSONNodeW(NamePaths.Objects[I]).nodetype <> ntarray)) or + ((not NotSaxMode) and (TALJsonNodeType(NamePaths.Objects[I]) <> ntarray))) then begin + ALMove(LB, Pbyte(Result)[(P-1)*sizeOf(Char)], L*sizeOf(Char)); + Inc(P, L); + end; + end; + if ExtraItems <> '' then begin + L := length(ExtraItems); + ALMove(pointer(ExtraItems)^, Pbyte(Result)[(P-1)*sizeOf(Char)], L*sizeOf(Char)); + Inc(P, L); + end; + setlength(result,P-1); end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetTimestamp(value) - else LTmpNode.SetTimestamp(value); -end; -{*************************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueObjectID(const path: array of String; const value: String); -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseTextWithIndex( + const index: String; + const Args: array of const; + const NodeSubType: TALJsonNodeSubType); + begin + if Assigned(OnParseText) then OnParseText(Self, GetPathStr('[' + index + ']'), '', Args, NodeSubType) end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetObjectID(value) - else LTmpNode.SetObjectID(value); -end; -{***********************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueInt32(const path: array of String; const value: Integer); -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseTextWithName( + const name: String; + const Args: array of const; + const NodeSubType: TALJsonNodeSubType); + begin + if Assigned(OnParseText) then OnParseText(Self, GetPathStr(Name), Name, Args, NodeSubType) end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetInt32(value) - else LTmpNode.SetInt32(value); -end; -{*********************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueInt64(const path: array of String; const value: Int64); -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseText( + const NameOrIndex: String; + const Args: array of const; + const NodeSubType: TALJsonNodeSubType); + begin + if Assigned(OnParseText) then begin + if notSaxMode then begin + if WorkingNode.nodetype=ntarray then _DoParseTextWithIndex(NameOrIndex, Args, NodeSubType) + else _DoParseTextWithName(NameOrIndex, Args, NodeSubType); + end + else begin + if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); + if TALJsonNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntArray then _DoParseTextWithIndex(NameOrIndex, Args, NodeSubType) + else _DoParseTextWithName(NameOrIndex, Args, NodeSubType); + end; + end; end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetInt64(value) - else LTmpNode.SetInt64(value); -end; -{**********************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueBool(const path: array of String; const value: Boolean); -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseStartObject(const Name: String); + begin + if Assigned(OnParseStartObject) then OnParseStartObject(Self, GetPathStr, Name); end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetBool(value) - else LTmpNode.SetBool(value); -end; -{***************************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueJavascript(const path: array of String; const value: String); -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseEndObject; + begin + if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); + if Assigned(OnParseEndObject) then OnParseEndObject(Self, GetPathStr, NamePaths[NamePaths.Count - 1]) end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetJavascript(value) - else LTmpNode.SetJavascript(value); -end; -{**********************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueRegEx(const path: array of String; const value: String); -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseStartArray(const index: String); + begin + if Assigned(OnParseStartArray) then OnParseStartArray(Self, GetPathStr, index) end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetRegEx(value) - else LTmpNode.SetRegEx(value); -end; -{******************************************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueRegExOptions(const path: array of String; const value: TALPerlRegExOptions); -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _DoParseEndArray; + begin + if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); + if Assigned(OnParseEndArray) then OnParseEndArray(Self, GetPathStr, NamePaths[NamePaths.Count - 1]); end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetRegExOptions(value) - else LTmpNode.SetRegExOptions(value); -end; -{***********************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueBinary(const path: array of String; const value: String); -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _AddIndexItemToNamePath(const index: String; Obj: Pointer); + begin + NamePaths.AddObject('[' + Index + ']', Obj) end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetBinary(value) - else LTmpNode.SetBinary(value); -end; -{****************************************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueBinarySubType(const path: array of String; const value: byte); -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _AddNameItemToNamePath(const name: String; Obj: Pointer); + begin + NamePaths.AddObject(Name, Obj) end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetBinarySubType(value) - else LTmpNode.SetBinarySubType(value); -end; -{************************************************************************} -procedure TALJSONNodeW.SetChildNodeValueNull(const path: array of String); -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _AddItemToNamePath(const nameOrIndex: String; Obj: Pointer); + begin + if notSaxMode then begin + if WorkingNode.nodetype=ntarray then _AddIndexItemToNamePath(nameOrIndex, Obj) + else _AddNameItemToNamePath(nameOrIndex, Obj); + end + else begin + if NamePaths.Count = 0 then ALJSONDocErrorW(CALJSONParseError); + if TALJsonNodeType(NamePaths.Objects[NamePaths.Count - 1]) = ntarray then _AddIndexItemToNamePath(nameOrIndex, Obj) + else _AddNameItemToNamePath(nameOrIndex, Obj); + end; end; - LTmpNode := LNode.ChildNodes.findNode(path[high(path)]); - if (LTmpNode = nil) then LNode.addChild(path[high(path)]).SetNull(true) - else LTmpNode.SetNull(true); -end; - -{***********************************************} -{Indicates whether this node has any child nodes} -function TALJSONNodeW.GetHasChildNodes: Boolean; -Var LNodeList: TALJSONNodeListW; -begin - LNodeList := InternalGetChildNodes; - Result := assigned(LNodeList) and (LNodeList.Count > 0); -end; -{********************************************} -function TALJSONNodeW.GetNodeValueStr: String; -begin - ALJSONDocErrorW(CALJsonOperationError,GetNodeType); - result := ''; // hide warning -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createInt64Node( + const name: String; + const NodeSubType: TALJsonNodeSubType); + var LNode: TALJSONNodeW; + LInt64: System.Int64; + begin + if BufferPos > BufferLength - sizeof(LInt64) then ALJSONDocErrorW(cALBSONParseError); + ALMove(Buffer[BufferPos], LInt64, sizeof(LInt64)); + BufferPos := BufferPos + sizeof(LInt64); -{*********************************************} -function TALJSONNodeW.GetNodeValueInt64: int64; -begin - ALJSONDocErrorW(CALJsonOperationError,GetNodeType); - result := 0; // hide warning -end; + if NotSaxMode then begin + if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetInt64(LInt64); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LInt64], NodeSubType) + end + else begin + _DoParseText(Name, [LInt64], NodeSubType) + end; + end; -{**********************************************************************************************} -procedure TALJSONNodeW.SetNodeValue(const Value: String; const NodeSubType: TALJSONNodeSubType); -begin - ALJSONDocErrorW(CALJsonOperationError,GetNodeType); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createInt32Node( + const name: String; + const NodeSubType: TALJsonNodeSubType); + var LNode: TALJSONNodeW; + LInt32: System.Int32; + begin + if BufferPos > BufferLength - sizeof(LInt32) then ALJSONDocErrorW(cALBSONParseError); + ALMove(Buffer[BufferPos], LInt32, sizeof(LInt32)); + BufferPos := BufferPos + sizeof(LInt32); -{*********************************************************************************************} -procedure TALJSONNodeW.SetNodeValue(const Value: int64; const NodeSubType: TALJSONNodeSubType); -begin - ALJSONDocErrorW(CALJsonOperationError,GetNodeType); -end; + if NotSaxMode then begin + if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setint32(LInt32); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LInt32], NodeSubType) + end + else begin + _DoParseText(Name, [LInt32], NodeSubType) + end; + end; -{**************************************************************************************************************************} -procedure TALJSONNodeW.SetNodeValue(const StrValue: String; const Int64Value: int64; const NodeSubType: TALJSONNodeSubType); -begin - ALJSONDocErrorW(CALJsonOperationError,GetNodeType); -end; + {~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createTextNode( + const name: String; + const NodeSubType: TALJsonNodeSubType); + var LNode: TALJSONNodeW; + LInt32: System.Int32; + LText: String; + begin + if BufferPos > BufferLength - sizeof(LInt32) then ALJSONDocErrorW(cALBSONParseError); + ALMove(Buffer[BufferPos], LInt32, sizeof(LInt32)); + BufferPos := BufferPos + sizeof(LInt32); + if (BufferPos + LInt32 > BufferLength) then ALJSONDocErrorW(cALBSONParseError); + LText := Tencoding.UTF8.GetString(Buffer,BufferPos,LInt32 - 1{for the trailing #0}); + BufferPos := BufferPos + LInt32; -{*********************************************************} -procedure TALJSONNodeW.SetNodeName(const NodeName: String); -begin - if fNodeName <> NodeName then begin - fNodeName := NodeName; - Var LParentNode := FParentNode; - if (LParentNode <> nil) and (LParentNode.ChildNodes.Sorted) then begin - var LNode := LParentNode.ChildNodes.Extract(self); - Try - LParentNode.ChildNodes.Add(LNode); + if NotSaxMode then begin + if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Settext(LText); + WorkingNode.ChildNodes.Add(LNode); except ALFreeAndNil(LNode); raise; - End; + end; + _DoParseText(Name, [LText], NodeSubType) + end + else begin + _DoParseText(Name, [LText], NodeSubType) end; end; -end; -{***********************************} -{Returns the text value of the node.} -function TALJSONNodeW.GetText: String; -begin + {~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createFloatNode( + const name: String; + const NodeSubType: TALJsonNodeSubType); + var LNode: TALJSONNodeW; + LDouble: Double; + begin + if BufferPos > BufferLength - sizeof(Double) then ALJSONDocErrorW(cALBSONParseError); + ALMove(Buffer[BufferPos], LDouble, sizeof(Double)); + BufferPos := BufferPos + sizeof(Double); - case NodeSubType of - nstFloat: begin // return the formated float - if Assigned(FDocument) and (Fdocument.FormatSettings <> @ALDefaultFormatSettingsW) then result := ALFloatToStrW(GetFloat, Fdocument.FormatSettings^) - else result := GetNodeValueStr; - end; - nstText: result := GetNodeValueStr; // return the raw text - nstObject: result := GetNodeValueStr; // return the raw objectID - nstArray: result := GetNodeValueStr; // error - nstObjectID: result := GetNodeValueStr; // error - nstBoolean: result := GetNodeValueStr; // return true or false - nstDateTime: begin // return the formated datetime - if Assigned(FDocument) and (Fdocument.FormatSettings <> @ALDefaultFormatSettingsW) then result := ALDateTimeToStrW(GetDateTime, Fdocument.FormatSettings^) - else result := GetNodeValueStr; - end; - nstNull: result := GetNodeValueStr; // return null - nstRegEx: result := GetNodeValueStr; // return the raw regex (without the options) - nstBinary: result := GetNodeValueStr; // return the base64 encoded binary (without the binary subtype) - nstJavascript: result := GetNodeValueStr; // return the raw javascript - nstInt32: result := GetNodeValueStr; // return the number - nstTimestamp: result := GetNodeValueStr; // return the number (as int64) - nstInt64: result := GetNodeValueStr; // return the number - else ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); + if NotSaxMode then begin + if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetFloat(LDouble); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LDouble], NodeSubType) + end + else begin + _DoParseText(Name, [LDouble], NodeSubType) + end; end; -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createBinaryNode( + const name: String; + const NodeSubType: TALJsonNodeSubType); + var LNode: TALJSONNodeW; + LInt32: System.Int32; + LBinSubtype: byte; + LBinData: Tbytes; + LBase64Data: String; + begin + //Get size + if BufferPos > BufferLength - sizeof(LInt32) then ALJSONDocErrorW(cALBSONParseError); + ALMove(Buffer[BufferPos], LInt32, sizeof(LInt32)); + BufferPos := BufferPos + sizeof(LInt32); -{***********************************************************} -function TALJSONNodeW.GetText(const default: String): String; -begin - if NodeSubType = nstNull then result := default - else result := GetText; -end; + //Get the subtype + if BufferPos >= BufferLength then ALJSONDocErrorW(cALBSONParseError); + LBinSubtype := Buffer[BufferPos]; + BufferPos := BufferPos + 1; -{********************************} -{Sets the text value of the node.} -procedure TALJSONNodeW.SetText(const Value: String); -begin - setNodeValue(Value, nstText); -end; + //Get the data + if (BufferPos + LInt32 > BufferLength) then ALJSONDocErrorW(cALBSONParseError); + setlength(LBinData, LInt32); + ALMove(Buffer[BufferPos], pointer(LBinData)^, LInt32); + LBase64Data := ALBase64EncodeBytesW(LBinData); + BufferPos := BufferPos + LInt32; -{******************************************************************************} -// By default json (ie: javascript) treats all numbers as floating-point values. -// To let other system (ie: mongoDB) understand the type of the number -// we provide the helper functions NumberLong() to handle 64-bit integers -// and NumberInt() to handle 32-bit integers (and some others). theses helper functions are -// used when saving the json document. -function TALJSONNodeW.GetNodeValueInterchange(const SkipNodeSubTypeHelper: boolean = False): String; + //create the node + if NotSaxMode then begin + if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.setbinary(LBase64Data, LBinSubtype); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LBase64Data, LBinSubtype], NodeSubType); + end + else begin + _DoParseText(Name, [LBase64Data, LBinSubtype], NodeSubType); + end; + end; - {~~~~~~~~~~~~~~~~~~~~~} - procedure _GetObjectID; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createObjectIDNode( + const name: String; + const NodeSubType: TALJsonNodeSubType); + var LNode: TALJSONNodeW; + LObjectID: Tbytes; + LHexData: String; begin - if SkipNodeSubTypeHelper then result := '"'+ObjectID+'"' - else result := 'ObjectId("'+ObjectID+'")'; + if BufferPos > BufferLength - 12{length(aObjectID)} then ALJSONDocErrorW(cALBSONParseError); + setlength(LObjectID, 12); + ALMove(Buffer[BufferPos], pointer(LObjectID)^, 12{length(aObjectID)}); + LHexData := ALBinToHexW(LObjectID); + BufferPos := BufferPos + 12{length(aObjectID)}; + + if NotSaxMode then begin + if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetObjectID(LHexData); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LHexData], NodeSubType) + end + else begin + _DoParseText(Name, [LHexData], NodeSubType) + end; end; - {~~~~~~~~~~~~~~~~~~~} - procedure _GetBinary; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createBooleanNode( + const name: String; + const NodeSubType: TALJsonNodeSubType); + var LNode: TALJSONNodeW; + LBool: Boolean; begin - if SkipNodeSubTypeHelper then result := '"'+Binary+'"' - else result := 'BinData('+ALIntToStrW(BinarySubType)+', "'+Binary+'")'; - end; + if BufferPos >= BufferLength then ALJSONDocErrorW(cALBSONParseError); + if Buffer[BufferPos] = $00 then LBool := False + else if Buffer[BufferPos] = $01 then LBool := true + else begin + ALJSONDocErrorW(cALBSONParseError); + LBool := False; // to hide a warning; + end; + BufferPos := BufferPos + 1; - {~~~~~~~~~~~~~~~~~~~~~} - procedure _GetDateTime; - begin - if SkipNodeSubTypeHelper then result := ALFormatDateTimeW('''"''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z"''', DateTime, ALDefaultFormatSettingsW) - else result := ALFormatDateTimeW('''ISODate("''yyyy''-''mm''-''dd''T''hh'':''nn'':''ss''.''zzz''Z")''', DateTime, ALDefaultFormatSettingsW) + if NotSaxMode then begin + if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setbool(LBool); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LBool], NodeSubType); + end + else begin + _DoParseText(Name, [LBool], NodeSubType); + end; end; - {~~~~~~~~~~~~~~~~~~} - procedure _Getint32; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createDateTimeNode( + const name: String; + const NodeSubType: TALJsonNodeSubType); + var LNode: TALJSONNodeW; + LDateTime: TdateTime; + LInt64: System.Int64; begin - if SkipNodeSubTypeHelper then result := text - else result := 'NumberInt(' + text + ')' + if BufferPos > BufferLength - sizeof(LInt64) then ALJSONDocErrorW(cALBSONParseError); + ALMove(Buffer[BufferPos], LInt64, sizeof(LInt64)); + LDateTime := ALUnixMsToDateTime(LInt64); + BufferPos := BufferPos + sizeof(LInt64); + + if NotSaxMode then begin + if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setdatetime(LDateTime); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LDateTime], NodeSubType); + end + else begin + _DoParseText(Name, [LDateTime], NodeSubType); + end; end; - {~~~~~~~~~~~~~~~~~~} - procedure _Getint64; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createTimestampNode( + const name: String; + const NodeSubType: TALJsonNodeSubType); + var LNode: TALJSONNodeW; + LTimestamp: TALBSONTimestamp; + LInt64: System.Int64; begin - if SkipNodeSubTypeHelper then result := text - else result := 'NumberLong(' + text + ')'; + if BufferPos > BufferLength - sizeof(LInt64) then ALJSONDocErrorW(cALBSONParseError); + ALMove(Buffer[BufferPos], LInt64, sizeof(LInt64)); + LTimestamp.I64 := LInt64; + BufferPos := BufferPos + sizeof(LInt64); + + if NotSaxMode then begin + if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetTimestamp(LTimestamp); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LTimestamp.W1, LTimestamp.W2], NodeSubType); + end + else begin + _DoParseText(Name, [LTimestamp.W1, LTimestamp.W2], NodeSubType); + end; end; - {~~~~~~~~~~~~~~~~~~} - procedure _GetRegEx; - var LRegExOptions: TALPerlRegExOptions; - LRegExOptionsStr: String; + {~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createnullNode( + const name: String; + const NodeSubType: TALJsonNodeSubType); + var LNode: TALJSONNodeW; begin - LRegExOptionsStr := ''; - LRegExOptions := RegExOptions; - if preCaseLess in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr + 'i'; - if preMultiLine in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr +'m'; - if preExtended in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr +'x'; - //'l':; - if preSingleLine in LRegExOptions then LRegExOptionsStr := LRegExOptionsStr + 's'; - //'u':; - result := '/'+regex+'/' + LRegExOptionsStr; - if not SkipNodeSubTypeHelper then result := '"' + ALJavascriptEncode(result) + '"' + if NotSaxMode then begin + if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.Setnull(true); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, ['null'], NodeSubType); + end + else begin + _DoParseText(Name, ['null'], NodeSubType); + end; end; - {~~~~~~~~~~~~~~~~~~~~~~} - procedure _GetTimestamp; + {~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createRegExNode( + const name: String; + const NodeSubType: TALJsonNodeSubType); + var LNode: TALJSONNodeW; + LRegEx: String; + LRegExOptions: TALPerlRegExOptions; + P1: integer; begin - if SkipNodeSubTypeHelper then result := '"Timestamp('+ALIntToStrW(GetTimeStamp.W1)+', '+ALIntToStrW(GetTimeStamp.W2)+')"' - else result := 'Timestamp('+ALIntToStrW(GetTimeStamp.W1)+', '+ALIntToStrW(GetTimeStamp.W2)+')'; - end; + //Get pattern + P1 := BufferPos; + While (P1 < BufferLength) do begin + If Buffer[P1] <> $00 then inc(P1) + else begin + LRegEx := Tencoding.UTF8.GetString(Buffer,BufferPos,P1 - BufferPos); + break; + end; + end; + if P1 >= BufferLength then ALJSONDocErrorW(cALBSONParseError); + BufferPos := P1 + 1; -begin + //Get options + LRegExOptions := []; + While (BufferPos < BufferLength) do begin + case Buffer[BufferPos] of + ord('i'): LRegExOptions := LRegExOptions + [preCaseLess]; + ord('m'): LRegExOptions := LRegExOptions + [preMultiLine]; + ord('x'): LRegExOptions := LRegExOptions + [preExtended]; + ord('l'):; + ord('s'): LRegExOptions := LRegExOptions + [preSingleLine]; + ord('u'):; + $00: break; + end; + inc(BufferPos); + end; + if BufferPos >= BufferLength then ALJSONDocErrorW(cALBSONParseError); + inc(BufferPos); - case NodeSubType of - nstFloat: result := GetNodeValueStr; - nstText: result := GetNodeValueStr; - nstBinary: _GetBinary; - nstObjectID: _GetObjectID; - nstBoolean: result := GetNodeValueStr; - nstDateTime: _GetDateTime; - nstJavascript: result := GetNodeValueStr; - nstInt32: _Getint32; - nstInt64: _Getint64; - nstNull: result := GetNodeValueStr; - nstObject: result := GetNodeValueStr; - nstArray: result := GetNodeValueStr; - nstRegEx: _GetRegEx; - nstTimestamp: _GetTimestamp; - else raise Exception.Create('Unknown Node SubType'); + //create the node + if NotSaxMode then begin + if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetRegEx(LRegEx, LRegExOptions); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LRegEx, Byte(LRegExOptions)], NodeSubType) + end + else begin + _DoParseText(Name, [LRegEx, Byte(LRegExOptions)], NodeSubType) + end; end; -end; + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _createJavascriptNode( + const name: String; + const NodeSubType: TALJsonNodeSubType); + var LNode: TALJSONNodeW; + LJavascript: String; + LInt32: System.Int32; + begin + if BufferPos > BufferLength - sizeof(LInt32) then ALJSONDocErrorW(cALBSONParseError); + ALMove(Buffer[BufferPos], LInt32, sizeof(LInt32)); + BufferPos := BufferPos + sizeof(LInt32); + if (BufferPos + LInt32 > BufferLength) then ALJSONDocErrorW(cALBSONParseError); + LJavascript := Tencoding.UTF8.GetString(Buffer,BufferPos,LInt32 - 1{for the trailing #0}); + BufferPos := BufferPos + LInt32; -{*************************************} -function TALJSONNodeW.GetFloat: Double; -begin - case NodeSubType of - nstFloat: PInt64(@result)^ := GetNodeValueInt64; - nstInt32, - nstInt64: Result := GetNodeValueInt64; + //create the node + if NotSaxMode then begin + if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', nttext) + else LNode := CreateNode(Name, nttext); + try + LNode.SetJavascript(LJavascript); + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; + _DoParseText(Name, [LJavascript], NodeSubType); + end else begin - ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); - result := 0; // to hide a warning; + _DoParseText(Name, [LJavascript], NodeSubType); end; end; -end; -{************************************************************} -function TALJSONNodeW.GetFloat(const default: Double): Double; -begin - if NodeSubType = nstNull then result := default - else result := GetFloat; -end; + {~~~~~~~~~~~~~~~~~~~~} + procedure AnalyzeNode; + Var LNode: TALJSONNodeW; + LNodeType: TALJsonNodeType; + LNodeSubType: TALJsonNodeSubType; + P1: Integer; + c: byte; + Begin -{***************************************************} -procedure TALJSONNodeW.SetFloat(const Value: Double); -begin - setNodeValue(PInt64(@Value)^, nstFloat); -end; + {$REGION 'init current char (c)'} + c := Buffer[BufferPos]; + {$ENDREGION} -{*******************************************} -function TALJSONNodeW.GetDateTime: TDateTime; -begin - if NodeSubType = nstDateTime then PInt64(@result)^ := GetNodeValueInt64 - else begin - ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); - result := 0; // to hide a warning; - end; -end; + {$REGION 'End Object/Array'} + // ... } .... + // ... ] .... + if c = $00 then begin -{*********************************************************************} -function TALJSONNodeW.GetDateTime(const default: TDateTime): TDateTime; -begin - if NodeSubType = nstNull then result := default - else result := GetDateTime; -end; + //error if Paths.Count = 0 (mean one end object/array without any starting) + if assigned(ObjectPaths) then begin + if (ObjectPaths.Count = 0) then ALJSONDocErrorW(cALBSONParseError); + end + else begin + if (NamePaths.Count = 0) then ALJSONDocErrorW(cALBSONParseError); + end; -{*********************************************************} -procedure TALJSONNodeW.SetDateTime(const Value: TDateTime); -begin - setNodeValue(PInt64(@Value)^, nstDateTime); -end; + //if we are not in sax mode + if NotSaxMode then begin -{***************************************************} -function TALJSONNodeW.GetTimestamp: TALBSONTimestamp; -begin - if NodeSubType = nstTimestamp then result.I64 := GetNodeValueInt64 - else begin - ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); - result.I64 := 0; // to hide a warning; - end; -end; + //init anode to one level up + if assigned(ObjectPaths) then LNode := ObjectPaths[ObjectPaths.Count - 1] + else LNode := TALJSONNodeW(NamePaths.Objects[NamePaths.Count - 1]); -{************************************************************************************} -function TALJSONNodeW.GetTimestamp(const default: TALBSONTimestamp): TALBSONTimestamp; -begin - if NodeSubType = nstNull then result := default - else result := GetTimestamp; -end; + //if anode <> workingNode aie aie aie + if (LNode <> WorkingNode) then ALJSONDocErrorW(cALBSONParseError); -{*****************************************************************} -procedure TALJSONNodeW.SetTimestamp(const Value: TALBSONTimestamp); -begin - setNodeValue(Value.I64, nstTimestamp); -end; + //calculate anodeTypeInt + LNodeType := LNode.NodeType; + if not (LNodeType in [ntObject, ntarray]) then ALJSONDocErrorW(cALBSONParseError); -{****************************************} -function TALJSONNodeW.GetObjectID: String; -begin - if NodeSubType = nstObjectID then result := GetNodeValueStr - else begin - ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); - result := ''; // to hide a warning; - end; -end; + //if working node <> Self then we can go to one level up + If WorkingNode <> Self then begin -{***************************************************************} -function TALJSONNodeW.GetObjectID(const default: String): String; -begin - if NodeSubType = nstNull then result := default - else result := GetObjectID; -end; + //init WorkingNode to the parentNode + WorkingNode := WorkingNode.ParentNode; -{******************************************************} -procedure TALJSONNodeW.SetObjectID(const Value: String); -begin - if length(Value) <> 24 then ALJSONDocErrorW('ObjectID must have 12 bytes'); - setNodeValue(Value, nstObjectID); -end; + end -{**************************************} -function TALJSONNodeW.GetInt32: Integer; -var LDouble: Double; - LInt64: system.int64; -begin - case NodeSubType of - nstFloat: begin - PInt64(@LDouble)^ := GetNodeValueInt64; - LInt64 := trunc(LDouble); - if (LInt64 <> LDouble) or // https://stackoverflow.com/questions/41779801/single-double-and-precision - // Only values that are in form m*2^e, where m and e are integers can be stored in a floating point variable - // so all integer can be store in the form m*2^e (ie: m = m*2^0) - // so we can compare aInt64 <> aDouble without the need of samevalue - (LInt64 > system.int32.MaxValue) or - (LInt64 < system.int32.MinValue) then ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); - result := LInt64; - end; - nstInt32: begin - LInt64 := GetNodeValueInt64; - if (LInt64 > system.int32.MaxValue) or - (LInt64 < system.int32.MinValue) then ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); - result := LInt64; - end; - nstInt64: Result := GetNodeValueInt64; - else begin - ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); - result := 0; // to hide a warning; - end; - end; -end; + //if working node = Self then we can no go to the parent node so set WorkingNode to nil + Else WorkingNode := nil; -{**************************************************************} -function TALJSONNodeW.GetInt32(const default: Integer): Integer; -begin - if NodeSubType = nstNull then result := default - else result := GetInt32; -end; + end -{****************************************************} -procedure TALJSONNodeW.SetInt32(const Value: Integer); -begin - setNodeValue(Value, nstInt32); -end; + //if we are in sax mode + else begin -{************************************} -function TALJSONNodeW.GetInt64: Int64; -var LDouble: Double; -begin - case NodeSubType of - nstFloat: begin - PInt64(@LDouble)^ := GetNodeValueInt64; - result := trunc(LDouble); - if result <> LDouble then ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); // https://stackoverflow.com/questions/41779801/single-double-and-precision - // Only values that are in form m*2^e, where m and e are integers can be stored in a floating point variable - // so all integer can be store in the form m*2^e (ie: m = m*2^0) - // so we can compare result <> aDouble without the need of samevalue - end; - nstInt32, - nstInt64: Result := GetNodeValueInt64; - else begin - ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); - result := 0; // to hide a warning; - end; - end; -end; + //calculate anodeTypeInt + LNodeType := TALJsonNodeType(NamePaths.Objects[NamePaths.Count - 1]); + if not (LNodeType in [ntObject,ntarray]) then ALJSONDocErrorW(cALBSONParseError); -{**********************************************************} -function TALJSONNodeW.GetInt64(const default: Int64): Int64; -begin - if NodeSubType = nstNull then result := default - else result := GetInt64; -end; + end; -{**************************************************} -procedure TALJSONNodeW.SetInt64(const Value: Int64); -begin - setNodeValue(Value, nstInt64); -end; + //call the DoParseEndObject/array event + if Assigned(OnParseEndObject) then begin + if LNodeType = ntObject then _DoParseEndObject + else _DoParseEndArray; + end; -{*************************************} -function TALJSONNodeW.GetBool: Boolean; -begin - if NodeSubType = nstBoolean then begin - if GetNodeValueInt64 = 0 then result := False - else result := true; - end - else begin - ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); - result := False; // to hide a warning; - end; -end; + //delete the last entry from the path + if assigned(ObjectPaths) then ObjectPaths.Delete(ObjectPaths.Count - 1) + else NamePaths.Delete(NamePaths.Count - 1); -{*************************************************************} -function TALJSONNodeW.GetBool(const default: Boolean): Boolean; -begin - if NodeSubType = nstNull then result := default - else result := GetBool; -end; + //update BufferPos + BufferPos := BufferPos + 1; -{***************************************************} -procedure TALJSONNodeW.SetBool(const Value: Boolean); -begin - if Value then setNodeValue(1, nstBoolean) - else setNodeValue(0, nstBoolean); -end; + //finallly exit from this procedure, everything was done + exit; + + end; + {$ENDREGION} + + {$REGION 'Get the node sub type'} + LNodeSubType := nstText; // to hide fucking warning + case c of + $01: LNodeSubType := nstFloat; + $02: LNodeSubType := nstText; + $03: LNodeSubType := nstObject; + $04: LNodeSubType := nstArray; + $05: LNodeSubType := nstbinary; + $07: LNodeSubType := nstObjectID; + $08: LNodeSubType := nstBoolean; + $09: LNodeSubType := nstDateTime; + $0A: LNodeSubType := nstNull; + $0B: LNodeSubType := nstRegEx; + $0D: LNodeSubType := nstJavascript; + $10: LNodeSubType := nstint32; + $11: LNodeSubType := nstTimestamp; + $12: LNodeSubType := nstint64; + else ALJSONDocErrorW(cALBSONParseError); + end; + BufferPos := BufferPos + 1; + {$ENDREGION} + + {$REGION 'Get the node name'} + P1 := BufferPos; + While (P1 < BufferLength) do begin + If Buffer[P1] <> $00 then inc(P1) + else begin + CurrName := Tencoding.UTF8.GetString(Buffer,BufferPos,P1-BufferPos); + break; + end; + end; + if P1 >= BufferLength then ALJSONDocErrorW(cALBSONParseError); + BufferPos := P1 + 1; + {$ENDREGION} -{*************************************} -function TALJSONNodeW.GetNull: Boolean; -begin - result := NodeSubType = nstNull; -end; + {$REGION 'Begin Object/Array'} + // ... { .... + // ... [ .... + if LNodeSubType in [nstObject,nstArray] then begin -{***************************************************} -procedure TALJSONNodeW.SetNull(const Value: Boolean); -begin - if Value then setNodeValue(0, nstNull) - else ALJSONDocErrorW('Only "true" is allowed for setNull property'); -end; + //if we are not in sax mode + if NotSaxMode then begin -{******************************************} -function TALJSONNodeW.GetJavascript: String; -begin - if NodeSubType = nstJavascript then result := GetNodeValueStr - else begin - ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); - result := ''; // to hide a warning; - end; -end; + //if workingnode = nil then it's mean we are outside Self + if not assigned(WorkingNode) then ALJSONDocErrorW(cALBSONParseError); -{*****************************************************************} -function TALJSONNodeW.GetJavascript(const default: String): String; -begin - if NodeSubType = nstNull then result := default - else result := GetJavascript; -end; + //create the node according the the braket char and add it to the workingnode + if LNodeSubType = nstObject then begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', ntObject) + else LNode := CreateNode(CurrName, ntObject); + end + else begin + if WorkingNode.nodetype=ntarray then LNode := CreateNode('', ntarray) + else LNode := CreateNode(CurrName, ntarray); + end; + try + WorkingNode.ChildNodes.Add(LNode); + except + ALFreeAndNil(LNode); + raise; + end; -{********************************************************} -procedure TALJSONNodeW.SetJavascript(const Value: String); -begin - setNodeValue(Value, nstJavascript); -end; + //set that the current working node will be now the new node newly created + WorkingNode := LNode; -{*************************************} -function TALJSONNodeW.GetRegEx: String; -begin - if NodeSubType = nstRegEx then result := GetNodeValueStr - else begin - ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); - result := ''; // to hide a warning; - end; -end; + //update the path + if assigned(ObjectPaths) then ObjectPaths.Add(WorkingNode) + else _AddItemToNamePath(CurrName, WorkingNode); -{************************************************************} -function TALJSONNodeW.GetRegEx(const default: String): String; -begin - if NodeSubType = nstNull then result := default - else result := GetRegEx; -end; + end -{*****************************************************} -procedure TALJSONNodeW.SetRegEx(const Pattern: String); -begin - setNodeValue(Pattern, 0, nstRegEx); -end; + //if we are in sax mode + else begin -{*****************************************************************************************} -procedure TALJSONNodeW.SetRegEx(const Pattern: String; const Options: TALPerlRegExOptions); -begin - setNodeValue(Pattern, byte(Options), nstRegEx); -end; + //update the path + if LNodeSubType = nstObject then LNodeType := ntObject + else LNodeType := ntArray; + _AddItemToNamePath(CurrName, pointer(LNodeType)); -{*********************************************************} -function TALJSONNodeW.GetRegExOptions: TALPerlRegExOptions; -begin - if NodeSubType = nstRegEx then result := TALPerlRegExOptions(byte(GetNodeValueInt64)) - else begin - ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); - result := []; // to hide a warning; - end; -end; + end; -{*********************************************************************************************} -function TALJSONNodeW.GetRegExOptions(const default: TALPerlRegExOptions): TALPerlRegExOptions; -begin - if NodeSubType = nstNull then result := default - else result := GetRegExOptions; -end; + //call the DoParseStartObject/array event + if LNodeSubType = nstObject then begin + if Assigned(OnParseStartObject) then _DoParseStartObject(CurrName) + end + else begin + if Assigned(OnParseStartArray) then _DoParseStartArray(CurrName); + end; -{***********************************************************************} -procedure TALJSONNodeW.SetRegExOptions(const Value: TALPerlRegExOptions); -begin - if NodeSubType <> nstRegEx then ALJSONDocErrorW('You can set regex options only to a regex node'); - setNodeValue(byte(Value), nstRegEx); -end; + //update BufferPos + BufferPos := BufferPos + 4; // we don't need the size of the object/array (4 bytes) -{**************************************} -function TALJSONNodeW.GetBinary: String; -begin - if NodeSubType = nstBinary then result := GetNodeValueStr - else begin - ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); - result := ''; // to hide a warning; - end; -end; + //finallly exit from this procedure, everything was done + exit; -{*************************************************************} -function TALJSONNodeW.GetBinary(const default: String): String; -begin - if NodeSubType = nstNull then result := default - else result := GetBinary; -end; + end; + {$ENDREGION} -{***************************************************} -procedure TALJSONNodeW.SetBinary(const Data: String); -begin - setNodeValue(Data, 0, nstBinary); // 0 = Default BSON type -end; + {$REGION 'create the node'} + case LNodeSubType of + // \x01 + name + \x00 + double + nstFloat: _createFloatNode(CurrName, LNodeSubType); -{************************************************************************} -procedure TALJSONNodeW.SetBinary(const Data: String; const Subtype: byte); -begin - setNodeValue(Data, Subtype, nstBinary); -end; + // \x02 + name + \x00 + length (int32) + string + \x00 + nstText: _createTextNode(CurrName, LNodeSubType); -{*******************************************} -function TALJSONNodeW.GetBinarySubType: byte; -begin - if NodeSubType = nstBinary then result := byte(GetNodeValueInt64) - else begin - ALJSONDocErrorW(cALJSONInvalidBSONNodeSubType); - result := 0; // to hide a warning; - end; -end; + // \x05 + name + \x00 + int32 + subtype + (byte*) + nstbinary: _createBinaryNode(CurrName, LNodeSubType); -{****************************************************************} -function TALJSONNodeW.GetBinarySubType(const default: byte): byte; -begin - if NodeSubType = nstNull then result := default - else result := GetBinarySubType; -end; + // \x07 + name + \x00 + (byte*12) + nstObjectID: _createObjectIDNode(CurrName, LNodeSubType); -{***********************************************************} -procedure TALJSONNodeW.SetBinarySubType(const Subtype: byte); -begin - if NodeSubType <> nstBinary then ALJSONDocErrorW('You can set binary subtype only to a binary node'); - setNodeValue(Subtype, nstBinary); -end; + // \x08 + name + \x00 + \x00 => Boolean "false" + // \x08 + name + \x00 + \x01 => Boolean "true" + nstBoolean: _createBooleanNode(CurrName, LNodeSubType); -{*******************************************************} -{Returns the document object in which this node appears.} -function TALJSONNodeW.GetOwnerDocument: TALJSONDocumentW; -begin - Result := FDocument; -end; + // \x09 + name + \x00 + int64 + nstDateTime: _createDateTimeNode(CurrName, LNodeSubType); -{*********************************************************************} -procedure TALJSONNodeW.SetOwnerDocument(const Value: TALJSONDocumentW); -var I: Integer; - LNodeList: TALJSONNodeListW; -begin - if FDocument <> Value then begin - FDocument := Value; - LNodeList := InternalGetChildNodes; - if Assigned(LNodeList) then begin - if Assigned(FDocument) then begin - LNodeList.Duplicates := FDocument.Duplicates; - LNodeList.SetSorted(doSorted in FDocument.Options); - end; - for I := 0 to LNodeList.Count - 1 do - LNodeList[I].SetOwnerDocument(Value); - end; - end; -end; + // \x11 + name + \x00 + int64 + nstTimestamp: _createTimestampNode(CurrName, LNodeSubType); -{************************} -{returns the parent node.} -function TALJSONNodeW.GetParentNode: TALJSONNodeW; -begin - Result := FParentNode; -end; + // \x0A + name + \x00 + nstnull: _createNullNode(CurrName, LNodeSubType); -{******************************************} -{Sets the value of the ParentNode property.} -procedure TALJSONNodeW.SetParentNode(const Value: TALJSONNodeW); -begin - if FParentNode <> Value then begin - If assigned(Value) then SetOwnerDocument(Value.OwnerDocument) - else SetOwnerDocument(nil); - FParentNode := Value; - end; -end; + // \x0B + name + \x00 + (byte*) + \x00 + (byte*) + \x00 + nstRegEx: _createRegExNode(CurrName, LNodeSubType); -{*******************************************************************} -{Returns the JSON that corresponds to the subtree rooted at this node. - GetJSON returns the JSON that corresponds to this node and any child nodes it contains.} -function TALJSONNodeW.GetJSON: String; -begin - SaveToJSONString(result); -end; + // \x0D + name + \x00 + length (int32) + string + \x00 + nstJavascript: _createJavascriptNode(CurrName, LNodeSubType); -{************************************************} -{SetJSON reload the node with the new given value } -procedure TALJSONNodeW.SetJSON(const Value: String); -Begin - LoadFromJSONString(Value, true{ClearChildNodes}); -end; + // \x10 + name + \x00 + int32 + nstint32: _createInt32Node(CurrName, LNodeSubType); -{*******************************************************************} -{Returns the BSON that corresponds to the subtree rooted at this node. - GetBSON returns the BSON that corresponds to this node and any child nodes it contains.} -function TALJSONNodeW.GetBSON: Tbytes; -begin - SaveToBSONBytes(result); -end; + // \x12 + name + \x00 + int64 + nstint64: _createInt64Node(CurrName, LNodeSubType); -{************************************************} -{SetBSON reload the node with the new given value } -procedure TALJSONNodeW.SetBSON(const Value: Tbytes); -Begin - LoadFromBSONBytes(Value, true{ClearChildNodes}); -end; + else ALJSONDocErrorW(cALBSONParseError); + end; + {$ENDREGION} -{*****************************************************************} -{Returns the number of parents for this node in the node hierarchy. - NestingLevel returns the number of ancestors for this node in the node hierarchy.} -function TALJSONNodeW.NestingLevel: Integer; -var PNode: TALJSONNodeW; -begin - Result := 0; - PNode := ParentNode; - while PNode <> nil do begin - Inc(Result); - PNode := PNode.ParentNode; end; -end; -{******************************************************} -constructor TALJSONNodeW.Create(const NodeName: String); Begin - FDocument := nil; - FParentNode := nil; - fNodeName := NodeName; -end; - -{***************************************************************} -//will create all the nodevalue and childnodelist to be sure that -//multiple thread can safely read at the same time the node -procedure TALJSONNodeW.MultiThreadPrepare(const aOnlyChildList: Boolean = False); -var I: integer; -begin - if (not aOnlyChildList) and (NodeType = ntText) then begin - case NodeSubType of - nstFloat, - nstBoolean, - nstDateTime, - nstNull, - nstInt32, - nstTimestamp, - nstInt64: GetNodeValueStr; - //nstText: can not be retrieve from int64 - //nstObject: can not be retrieve from int64 - //nstArray: can not be retrieve from int64 - //nstBinary: only the binarysubtype is store in int64 - //nstObjectID: can not be retrieve from int64 - //nstRegEx: only the regex options is store in the int64 - //nstJavascript: can not be retrieve from int64 - end; + //Only Object Node can be loaded from BSON + If NodeType <> ntObject then AlJSONDocErrorW(CALJsonOperationError,GetNodeType); + if poClearChildNodes in Options then ChildNodes.Clear; - case NodeSubType of - nstFloat, - nstBoolean, - nstDateTime, - nstNull, - nstInt32, - nstTimestamp, - nstInt64: GetNodeValueInt64; - //nstText: can not be retrieve from int64 - //nstObject: can not be retrieve from int64 - //nstArray: can not be retrieve from int64 - //nstBinary: only the binarysubtype is store in int64 - //nstObjectID: can not be retrieve from int64 - //nstRegEx: only the regex options is store in the int64 - //nstJavascript: can not be retrieve from int64 - end; + //init WorkingNode and NotSaxMode + WorkingNode := Self; + NotSaxMode := not SaxMode; + //init ObjectPaths or NamePaths + if (NotSaxMode) and + (not assigned(OnParseText)) and + (not assigned(OnParseStartObject)) and + (not assigned(OnParseEndObject)) and + (not assigned(OnParseStartArray)) and + (not assigned(OnParseEndArray)) then begin + ObjectPaths := TObjectList.Create(false{OwnsObjects}); + NamePaths := nil; end - - else if (NodeType in [ntObject,ntArray]) then begin - For I := 0 to ChildNodes.Count - 1 do - ChildNodes[I].MultiThreadPrepare(aOnlyChildList); + else begin + ObjectPaths := nil; + NamePaths := TALStringListW.Create; end; -end; - -{****************************************************************************************************************************************} -function TALJSONNodeW.AddChild(const NodeName: String; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeW; -begin - Result := ALCreateJSONNodeW(NodeName,NodeType); Try - ChildNodes.Insert(Index, Result); - except - ALFreeAndNil(Result); - raise; - end; -end; -{*********************************************************************************************************************************************} -function TALJSONNodeW.AddChild(const Path: array of String; const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeW; -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I], TDirection.FromEnd); - if (LTmpNode = nil) then LNode := LNode.addChild(path[I], ntObject) - else LNode := LTmpNode; - end; - result := LNode.addChild(path[high(path)], NodeType, Index); -end; + //init Buffer + BufferLength := length(Buffer); + BufferPos := 4; // the first 4 bytes are the length of the document and we don't need it -{****************************************************************************************************************} -function TALJSONNodeW.AddChild(const NodeType: TALJSONNodeType = ntText; const Index: Integer = -1): TALJSONNodeW; -begin - Result := AddChild('', NodeType, Index); -end; + //add first node in ObjectPaths/NamePaths + if assigned(ObjectPaths) then ObjectPaths.Add(WorkingNode) + else begin + if NotSaxMode then NamePaths.AddObject('', WorkingNode) + else NamePaths.AddObject('', pointer(ntObject)); + end; + _DoParseStartObject(''); -{*****************************************************************} -function TALJSONNodeW.DeleteChild(const NodeName: String): boolean; -var I: integer; -begin - I := ChildNodes.IndexOf(NodeName); - if I >= 0 then begin - ChildNodes.Delete(I); - result := True; - end - else result := False; -end; + //analyze all the nodes + While (BufferPos < BufferLength) do + AnalyzeNode; -{**********************************************************************} -function TALJSONNodeW.DeleteChild(const Path: array of String): boolean; -var LNode: TALJSONNodeW; - LTmpNode: TALJSONNodeW; - I: integer; -begin - LNode := Self; - for I := low(path) to high(path) - 1 do begin - LTmpNode := LNode.ChildNodes.findNode(path[I]); - if (LTmpNode = nil) then exit(false) - else LNode := LTmpNode; - end; - I := LNode.ChildNodes.IndexOf(path[high(path)]); - if I >= 0 then begin - LNode.ChildNodes.Delete(I); - result := True; - end - else result := False; -end; + //some tags are not closed + if assigned(ObjectPaths) then begin + if ObjectPaths.Count > 0 then ALJSONDocErrorW(cALBSONParseError); + end + else begin + if NamePaths.Count > 0 then ALJSONDocErrorW(cALBSONParseError); + end; -{********************************************} -{Returns the next child of this node’s parent. - NextSibling returns the node that follows this one in the parent node’s ChildNodes property list. - If this node is the last node in its parent’s child list, NextSibling raises an exception.} -function TALJSONNodeW.NextSibling: TALJSONNodeW; -begin - if Assigned(ParentNode) then Result := ParentNode.ChildNodes.FindSibling(Self, 1) - else Result := nil; -end; + //mean the node was not update (empty stream?) or not weel closed + if NotSaxMode and (WorkingNode <> nil) then ALJSONDocErrorW(cALBSONParseError); + + finally + + //free ObjectPaths/NamePaths + if assigned(ObjectPaths) then ALFreeAndNil(ObjectPaths) + else ALFreeAndNil(NamePaths); + + end; -{************************************************} -{Returns the previous child of this node’s parent. - PreviousSibling returns the node that precedes this one in the parent node’s ChildNodes property list. - If this node is the first node in its parent’s child list, PreviousSibling raises an exception.} -function TALJSONNodeW.PreviousSibling: TALJSONNodeW; -begin - if Assigned(ParentNode) then Result := ParentNode.ChildNodes.FindSibling(Self, -1) - else Result := nil; end; {*********************} @@ -13470,7 +12512,8 @@ function TALJSONNodeW.PreviousSibling: TALJSONNodeW; procedure TALJSONNodeW.SaveToJson( const Stream: TStream; const StreamEncoding: TEncoding; - Var buffer: String); + Var buffer: String; + const Options: TALJSONSaveOptions); Const BufferSize: integer = 8192; @@ -13693,12 +12736,11 @@ procedure TALJSONNodeW.SaveToJson( Setlength(Buffer, BufferSize); // will make buffer uniquestring BufferPos := 0; LastWrittenChar := '{'; - EncodeControlCharacters := (FDocument = nil) or (not (poIgnoreControlCharacters in FDocument.ParseOptions)); - SkipNodeSubTypeHelper := (FDocument <> nil) and (poSkipNodeSubTypeHelper in FDocument.ParseOptions); - SaveInt64AsText := SkipNodeSubTypeHelper and (FDocument <> nil) and (poSaveInt64AsText in FDocument.ParseOptions); - AutoIndentNode := (FDocument <> nil) and (doNodeAutoIndent in FDocument.Options); - if FDocument <> nil then IndentStr := FDocument.NodeIndentStr - else IndentStr := ALDefaultJsonNodeIndentW; + EncodeControlCharacters := not (soIgnoreControlCharacters in Options); + SkipNodeSubTypeHelper := soSkipNodeSubTypeHelper in Options; + SaveInt64AsText := SkipNodeSubTypeHelper and (soSaveInt64AsText in Options); + AutoIndentNode := soNodeAutoIndent in Options; + IndentStr := ALDefaultJsonNodeIndentW; CurrentIndentStr := ''; {SaveOnlyChildNode} @@ -13741,34 +12783,33 @@ procedure TALJSONNodeW.SaveToJson( {***********************************} {Saves the JSON document to a stream. Call SaveToStream to save the contents of the JSON document to the stream specified by Stream.} -procedure TALJSONNodeW.SaveToJSONStream(const Stream: TStream; const Encoding: TEncoding); +procedure TALJSONNodeW.SaveToJSONStream(const Stream: TStream; const Encoding: TEncoding; const Options: TALJSONSaveOptions = []); var buffer: String; begin - SaveToJson(Stream, Encoding, buffer); + SaveToJson(Stream, Encoding, buffer, Options); end; -{*************************************************************} -procedure TALJSONNodeW.SaveToJSONStream(const Stream: TStream); +{*****************************************************************************************************} +procedure TALJSONNodeW.SaveToJSONStream(const Stream: TStream; const Options: TALJSONSaveOptions = []); begin - SaveToJSONStream(Stream, TEncoding.UTF8); + SaveToJSONStream(Stream, TEncoding.UTF8, Options); end; {******************************} {Saves the JSON document to disk. Call SaveToFile to save any modifications you have made to the parsed JSON document. AFileName is the name of the file to save.} -procedure TALJSONNodeW.SaveToJSONFile(const FileName: String; const Encoding: TEncoding); +procedure TALJSONNodeW.SaveToJSONFile(const FileName: String; const Encoding: TEncoding; const Options: TALJSONSaveOptions = []); Var LfileStream: TfileStream; LTmpFilename: String; begin - if (assigned(FDocument)) and - (doProtectedSave in fDocument.Options) then LTmpFilename := FileName + '.~tmp' + if soProtectedSave in Options then LTmpFilename := FileName + '.~tmp' else LTmpFilename := FileName; try LfileStream := TfileStream.Create(LTmpFilename,fmCreate); Try - SaveToJSONStream(LfileStream, Encoding); + SaveToJSONStream(LfileStream, Encoding, Options); finally ALFreeAndNil(LfileStream); end; @@ -13785,10 +12826,10 @@ procedure TALJSONNodeW.SaveToJSONFile(const FileName: String; const Encoding: TE end; end; -{************************************************************} -procedure TALJSONNodeW.SaveToJSONFile(const FileName: String); +{****************************************************************************************************} +procedure TALJSONNodeW.SaveToJSONFile(const FileName: String; const Options: TALJSONSaveOptions = []); begin - SaveToJSONFile(FileName, TEncoding.UTF8); + SaveToJSONFile(FileName, TEncoding.UTF8, Options); end; {************************************************} @@ -13796,15 +12837,16 @@ procedure TALJSONNodeW.SaveToJSONFile(const FileName: String); Call SaveToJSON to save the contents of the JSON document to the string-type variable specified by JSON. SaveToJSON writes the contents of JSON document using 8 bits char (utf-8, iso-8859-1, etc) as an encoding system, depending on the type of the JSON parameter. Unlike the JSON property, which lets you write individual lines from the JSON document, SaveToJSON writes the entire text of the JSON document.} -procedure TALJSONNodeW.SaveToJSONString(var str: String); +procedure TALJSONNodeW.SaveToJSONString(var str: String; const Options: TALJSONSaveOptions = []); begin - SaveToJson(nil, nil, Str); + SaveToJson(nil, nil, Str, Options); end; {********************************} procedure TALJSONNodeW.SaveToBson( const Stream: TStream; - Var buffer: Tbytes); + Var buffer: Tbytes; + const Options: TALJSONSaveOptions); Const BufferSize: integer = 8192; @@ -14227,26 +13269,25 @@ procedure TALJSONNodeW.SaveToBson( end; end; -{*************************************************************} -procedure TALJSONNodeW.SaveToBsonStream(const Stream: TStream); +{*****************************************************************************************************} +procedure TALJSONNodeW.SaveToBsonStream(const Stream: TStream; const Options: TALJSONSaveOptions = []); var buffer: Tbytes; begin - SaveToBson(Stream, buffer); + SaveToBson(Stream, buffer, Options); end; -{************************************************************} -procedure TALJSONNodeW.SaveToBsonFile(const FileName: String); +{****************************************************************************************************} +procedure TALJSONNodeW.SaveToBsonFile(const FileName: String; const Options: TALJSONSaveOptions = []); Var LfileStream: TfileStream; LTmpFilename: String; begin - if (assigned(FDocument)) and - (doProtectedSave in fDocument.Options) then LTmpFilename := FileName + '.~tmp' + if soProtectedSave in Options then LTmpFilename := FileName + '.~tmp' else LTmpFilename := FileName; try LfileStream := TfileStream.Create(LTmpFilename,fmCreate); Try - SaveToBsonStream(LfileStream); + SaveToBsonStream(LfileStream, Options); finally ALFreeAndNil(LfileStream); end; @@ -14263,83 +13304,155 @@ procedure TALJSONNodeW.SaveToBsonFile(const FileName: String); end; end; -{********************************************************} -procedure TALJSONNodeW.SaveToBsonBytes(var Bytes: Tbytes); +{************************************************************************************************} +procedure TALJSONNodeW.SaveToBsonBytes(var Bytes: Tbytes; const Options: TALJSONSaveOptions = []); begin - SaveToBson(nil, Bytes); + SaveToBson(nil, Bytes, Options); end; -{**************************************************************************************************} -procedure TALJSONNodeW.LoadFromJSONString(const Str: String; Const ClearChildNodes: Boolean = True); +{*********************************************************************************************************************} +procedure TALJSONNodeW.LoadFromJSONString(const Str: String; const Options: TALJSONParseOptions = [poClearChildNodes]); Begin - If NodeType <> ntObject then ALJSONDocErrorW(CALJsonOperationError,GetNodeType); - if ClearChildNodes then ChildNodes.Clear; Try - FDocument.ParseJson(Str, self) + ParseJson(Str, False{SaxMode}, nil{onParseText}, nil{onParseStartObject}, nil{onParseEndObject}, nil{onParseStartArray}, nil{onParseEndArray}, Options); except ChildNodes.Clear; raise; end; end; -{******************************************************************************************************} -procedure TALJSONNodeW.LoadFromJSONStream(const Stream: TStream; Const ClearChildNodes: Boolean = True); +{*************************************************************************************************************************} +procedure TALJSONNodeW.LoadFromJSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]); Begin - If NodeType <> ntObject then ALJSONDocErrorW(CALJsonOperationError,GetNodeType); - if ClearChildNodes then ChildNodes.Clear; - Try - FDocument.ParseJSON(ALGetStringFromStream(Stream, TEncoding.UTF8), self) - except - ChildNodes.Clear; - raise; - end; + LoadFromJSONString(ALGetStringFromStream(Stream, TEncoding.UTF8), Options); end; -{*****************************************************************************************************} -procedure TALJSONNodeW.LoadFromJSONFile(const FileName: String; Const ClearChildNodes: Boolean = True); +{************************************************************************************************************************} +procedure TALJSONNodeW.LoadFromJSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]); Var LfileStream: TfileStream; Begin - LfileStream := TfileStream.Create(string(FileName), fmOpenRead or fmShareDenyWrite); + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); Try - LoadFromJSONStream(LfileStream, ClearChildNodes); + LoadFromJSONStream(LfileStream, Options); finally ALFreeAndNil(LfileStream); end; end; -{***************************************************************************************************} -procedure TALJSONNodeW.LoadFromBSONBytes(const Bytes: Tbytes; Const ClearChildNodes: Boolean = True); +{**********************************************************************************************************************} +procedure TALJSONNodeW.LoadFromBSONBytes(const Bytes: Tbytes; const Options: TALJSONParseOptions = [poClearChildNodes]); Begin - If NodeType <> ntObject then ALJSONDocErrorW(CALJsonOperationError,GetNodeType); - if ClearChildNodes then ChildNodes.Clear; Try - FDocument.ParseBSON(Bytes, self) + ParseBSON(Bytes, False{SaxMode}, nil{onParseText}, nil{onParseStartObject}, nil{onParseEndObject}, nil{onParseStartArray}, nil{onParseEndArray}, Options); except ChildNodes.Clear; raise; end; end; -{******************************************************************************************************} -procedure TALJSONNodeW.LoadFromBSONStream(const Stream: TStream; Const ClearChildNodes: Boolean = True); +{*************************************************************************************************************************} +procedure TALJSONNodeW.LoadFromBSONStream(const Stream: TStream; const Options: TALJSONParseOptions = [poClearChildNodes]); +Begin + LoadFromBSONBytes(ALGetBytesFromStream(Stream), Options); +end; + +{************************************************************************************************************************} +procedure TALJSONNodeW.LoadFromBSONFile(const FileName: String; const Options: TALJSONParseOptions = [poClearChildNodes]); +Var LfileStream: TfileStream; Begin - If NodeType <> ntObject then ALJSONDocErrorW(CALJsonOperationError,GetNodeType); - if ClearChildNodes then ChildNodes.Clear; + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); Try - FDocument.ParseBSON(ALGetBytesFromStream(Stream), self) - except - ChildNodes.Clear; - raise; + LoadFromBSONStream(LfileStream, Options); + finally + ALFreeAndNil(LfileStream); end; end; -{*****************************************************************************************************} -procedure TALJSONNodeW.LoadFromBSONFile(const FileName: String; Const ClearChildNodes: Boolean = True); +{*************************************} +procedure TALJSONNodeW.ParseJSONString( + const Str: String; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); +Begin + ParseJson(Str, true{SaxMode}, onParseText, onParseStartObject, onParseEndObject, onParseStartArray, onParseEndArray, Options); +end; + +{*************************************} +procedure TALJSONNodeW.ParseJSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); +Begin + ParseJSONString(ALGetStringFromStream(Stream, TEncoding.UTF8), onParseText, onParseStartObject, onParseEndObject, onParseStartArray, onParseEndArray, Options); +end; + +{***********************************} +procedure TALJSONNodeW.ParseJSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); +Var LfileStream: TfileStream; +Begin + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + Try + ParseJSONStream(LfileStream, onParseText, onParseStartObject, onParseEndObject, onParseStartArray, onParseEndArray, Options); + finally + ALFreeAndNil(LfileStream); + end; +end; + +{************************************} +procedure TALJSONNodeW.ParseBSONBytes( + const Bytes: Tbytes; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); +Begin + ParseBSON(Bytes, true{SaxMode}, onParseText, onParseStartObject, onParseEndObject, onParseStartArray, onParseEndArray, Options); +end; + +{*************************************} +procedure TALJSONNodeW.ParseBSONStream( + const Stream: TStream; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); +Begin + ParseBSONBytes(ALGetBytesFromStream(Stream), onParseText, onParseStartObject, onParseEndObject, onParseStartArray, onParseEndArray, Options); +end; + +{***********************************} +procedure TALJSONNodeW.ParseBSONFile( + const FileName: String; + const onParseText: TAlJSONParseTextEventW; + const onParseStartObject: TAlJSONParseObjectEventW; + const onParseEndObject: TAlJSONParseObjectEventW; + const onParseStartArray: TAlJSONParseArrayEventW; + const onParseEndArray: TAlJSONParseArrayEventW; + const Options: TALJSONParseOptions = []); Var LfileStream: TfileStream; Begin - LfileStream := TfileStream.Create(string(FileName), fmOpenRead or fmShareDenyWrite); + LfileStream := TfileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); Try - LoadFromBSONStream(LfileStream, ClearChildNodes); + ParseBSONStream(LfileStream, onParseText, onParseStartObject, onParseEndObject, onParseStartArray, onParseEndArray, Options); finally ALFreeAndNil(LfileStream); end; @@ -14583,14 +13696,8 @@ constructor TALJSONNodeListW.Create(Owner: TALJSONNodeW); FCapacity := 0; FOwner := Owner; FSorted := False; - if assigned(FOwner.OwnerDocument) then begin - FDuplicates := FOwner.OwnerDocument.Duplicates; - SetSorted(doSorted in FOwner.OwnerDocument.Options); - end - else begin - FDuplicates := dupAccept; - SetSorted(False); - end; + FDuplicates := dupAccept; + SetSorted(False); end; {**********************************} @@ -14667,11 +13774,11 @@ function TALJSONNodeListW.IndexOf(const Name: String; const Direction: TDirectio if not Sorted then begin if Direction = TDirection.FromBeginning then begin for Result := 0 to Count - 1 do - if CompareNodeNames(Get(Result).NodeName, Name) = 0 then Exit; + if FList[Result].NodeName = Name then Exit; end else begin for Result := Count - 1 downto 0 do - if CompareNodeNames(Get(Result).NodeName, Name) = 0 then Exit; + if FList[Result].NodeName = Name then Exit; end; Result := -1; end @@ -14683,11 +13790,11 @@ function TALJSONNodeListW.IndexOfValue(const Value: String; const Direction: TDi begin if Direction = TDirection.FromBeginning then begin for Result := 0 to Count - 1 do - if (Get(Result).Text = Value) then Exit; + if (FList[Result].Text = Value) then Exit; end else begin for Result := Count - 1 downto 0 do - if (Get(Result).Text = Value) then Exit; + if (FList[Result].Text = Value) then Exit; end; Result := -1; end; @@ -14697,11 +13804,11 @@ function TALJSONNodeListW.IndexOfValue(const Value: integer; const Direction: TD begin if Direction = TDirection.FromBeginning then begin for Result := 0 to Count - 1 do - if (Get(Result).int32 = Value) then Exit; + if (FList[Result].int32 = Value) then Exit; end else begin for Result := Count - 1 downto 0 do - if (Get(Result).int32 = Value) then Exit; + if (FList[Result].int32 = Value) then Exit; end; Result := -1; end; @@ -14711,11 +13818,11 @@ function TALJSONNodeListW.IndexOfValue(const Value: int64; const Direction: TDir begin if Direction = TDirection.FromBeginning then begin for Result := 0 to Count - 1 do - if (Get(Result).int64 = Value) then Exit; + if (FList[Result].int64 = Value) then Exit; end else begin for Result := Count - 1 downto 0 do - if (Get(Result).int64 = Value) then Exit; + if (FList[Result].int64 = Value) then Exit; end; Result := -1; end; @@ -14725,11 +13832,11 @@ function TALJSONNodeListW.IndexOfValue(const Value: Double; const Direction: TDi begin if Direction = TDirection.FromBeginning then begin for Result := 0 to Count - 1 do - if (Get(Result).float = Value) then Exit; + if (FList[Result].float = Value) then Exit; end else begin for Result := Count - 1 downto 0 do - if (Get(Result).float = Value) then Exit; + if (FList[Result].float = Value) then Exit; end; Result := -1; end; @@ -14739,11 +13846,11 @@ function TALJSONNodeListW.IndexOfValue(const Value: TDateTime; const Direction: begin if Direction = TDirection.FromBeginning then begin for Result := 0 to Count - 1 do - if (Get(Result).DateTime = Value) then Exit; + if (FList[Result].DateTime = Value) then Exit; end else begin for Result := Count - 1 downto 0 do - if (Get(Result).DateTime = Value) then Exit; + if (FList[Result].DateTime = Value) then Exit; end; Result := -1; end; @@ -14826,9 +13933,6 @@ function TALJSONNodeListW.GetNodeByIndex(const Index: Integer): TALJSONNodeW; function TALJSONNodeListW.GetNodeByName(const Name: String): TALJSONNodeW; begin Result := FindNode(Name); - if (not Assigned(Result)) and - (assigned(fOwner.OwnerDocument)) and - (doNodeAutoCreate in fOwner.OwnerDocument.Options) then Result := FOwner.AddChild(Name); // only text node will be added via doNodeAutoCreate if not Assigned(Result) then ALJSONDocErrorW(CALJSONNodeNotFound, [Name]); end; @@ -15151,47 +14255,43 @@ procedure TALJSONNodeListW.SetCount(NewCount: Integer); Const aNullStr: String = 'null'; Const aTrueStr: String = 'true'; Const aFalseStr: String = 'false'); - -var LJsonDocument: TALJSONDocumentW; - LContainChilds: boolean; +var LContainChilds: boolean; begin - LJsonDocument := TALJSONDocumentW.Create(aFormatSettings); - try - - LJsonDocument.onParseText := procedure (Sender: TObject; const Path: String; const name: String; const Args: array of const; NodeSubType: TALJSONNodeSubType) - begin - if (NodeSubType = nstBoolean) then aLst.Add(aPath + Path + aLst.NameValueSeparator + ALBoolToStrW(Args[0].VBoolean,aTrueStr,aFalseStr)) - else if (NodeSubType = nstnull) then aLst.Add(aPath + Path + aLst.NameValueSeparator + aNullStr) - else aLst.Add(aPath + Path + aLst.NameValueSeparator + String(Args[0].VUnicodeString)); - LContainChilds := True; - end; - - LJsonDocument.onParseStartObject := procedure (Sender: TObject; const Path: String; const Name: String) - begin - LContainChilds := False; - end; - - LJsonDocument.onParseEndObject := procedure (Sender: TObject; const Path: String; const Name: String) - begin - if (not LContainChilds) and (aPath + Path <> ''{Path = '' mean it's the root object}) then aLst.Add(aPath+ Path + aLst.NameValueSeparator + '{}'); - LContainChilds := True; - end; - - LJsonDocument.onParseStartArray := procedure (Sender: TObject; const Path: String; const Name: String) - begin - LContainChilds := False; - end; - - LJsonDocument.onParseEndArray := procedure (Sender: TObject; const Path: String; const Name: String) - begin - if not LContainChilds then aLst.Add(aPath+ Path + aLst.NameValueSeparator + '[]'); - LContainChilds := True; - end; - - LJsonDocument.LoadFromJSONString(AJsonStr, true{saxMode}); - finally - ALFreeAndNil(LJsonDocument); - end; + LContainChilds := False; + TALJSONDocumentW.ParseJSONString( + AJsonStr, + //-- + procedure (Sender: TObject; const Path: String; const name: String; const Args: array of const; NodeSubType: TALJSONNodeSubType) + begin + if (NodeSubType = nstFloat) then aLst.Add(aPath + Path + aLst.NameValueSeparator + ALFloatToStrW(Args[0].VExtended^, aFormatSettings)) + else if (NodeSubType = nstDateTime) then aLst.Add(aPath + Path + aLst.NameValueSeparator + ALDateTimeToStrW(Args[0].VExtended^, aFormatSettings)) + else if (NodeSubType = nstBoolean) then aLst.Add(aPath + Path + aLst.NameValueSeparator + ALBoolToStrW(Args[0].VBoolean,aTrueStr,aFalseStr)) + else if (NodeSubType = nstnull) then aLst.Add(aPath + Path + aLst.NameValueSeparator + aNullStr) + else aLst.Add(aPath + Path + aLst.NameValueSeparator + String(Args[0].VUnicodeString)); + LContainChilds := True; + end{onParseText}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + LContainChilds := False; + end{onParseStartObject}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + if (not LContainChilds) and (aPath + Path <> ''{Path = '' mean it's the root object}) then aLst.Add(aPath+ Path + aLst.NameValueSeparator + '{}'); + LContainChilds := True; + end{onParseEndObject}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + LContainChilds := False; + end{onParseStartArray}, + //-- + procedure (Sender: TObject; const Path: String; const Name: String) + begin + if not LContainChilds then aLst.Add(aPath+ Path + aLst.NameValueSeparator + '[]'); + LContainChilds := True; + end{onParseEndArray}); end; {**************************} @@ -15494,6 +14594,7 @@ initialization ALJsonISODateFormatSettingsA.ShortDateFormat := 'yyyy-mm-dd'; ALJsonISODateFormatSettingsA.ShortTimeFormat := 'hh:nn:ss.zzz'; ALDefaultJsonNodeIndentA := ' '; { 2 spaces } + ALDefaultJsonPathSeparatorA := '.'; ALJsonISODateFormatSettingsW := TALFormatSettingsW.Create('en-US'); ALJsonISODateFormatSettingsW.DateSeparator := '-'; @@ -15501,5 +14602,6 @@ initialization ALJsonISODateFormatSettingsW.ShortDateFormat := 'yyyy-mm-dd'; ALJsonISODateFormatSettingsW.ShortTimeFormat := 'hh:nn:ss.zzz'; ALDefaultJsonNodeIndentW := ' '; { 2 spaces } + ALDefaultJsonPathSeparatorW := '.'; end. diff --git a/Source/Alcinoe.MongoDB.Client.pas b/Source/Alcinoe.MongoDB.Client.pas index 939964e12..227c1c84c 100644 --- a/Source/Alcinoe.MongoDB.Client.pas +++ b/Source/Alcinoe.MongoDB.Client.pas @@ -23,9 +23,9 @@ '{fieldA:1, fieldB:1}', // the return fields selector aJSONDoc.node); aMongoDBClient.disconnect; - for i := 0 to aJSONDoc.node.childnodes.count - 1 do - with aJSONDoc.node.childnodes[i] do - writeln(aJSONDoc.node.childnodes[i].nodename + '=' + aJSONDoc.node.childnodes[i].text) + for i := 0 to aJSONDoc.ChildNodes.count - 1 do + with aJSONDoc.ChildNodes[i] do + writeln(aJSONDoc.ChildNodes[i].nodename + '=' + aJSONDoc.ChildNodes[i].text) finally aMongoDBClient.free; aJSONDoc.free; @@ -1173,7 +1173,7 @@ function TAlBaseMongoDBClient.GetResponse(aSocketDescriptor: TSocket): AnsiStrin LStartingFrom: integer; LNumberReturned: integer; LContinue: boolean; - LJSONDoc: TALJSONDocumentA; + LJSONDoc: TALJSONNodeA; LCodeNode: TALJSONNodeA; LCodeInt: int32; LNode: TALJSONNodeA; @@ -1195,7 +1195,7 @@ function TAlBaseMongoDBClient.GetResponse(aSocketDescriptor: TSocket): AnsiStrin LCursorID, LStartingFrom, LNumberReturned, - LJSONDoc.Node, + LJSONDoc, nil, nil, '', @@ -1203,21 +1203,21 @@ function TAlBaseMongoDBClient.GetResponse(aSocketDescriptor: TSocket): AnsiStrin LContinue); try - CheckRunCommandResponse(LJSONDoc.Node); + CheckRunCommandResponse(LJSONDoc); - LCodeNode := LJSONDoc.Node.ChildNodes.FindNode('code'); + LCodeNode := LJSONDoc.ChildNodes.FindNode('code'); if assigned(LCodeNode) and (not LCodeNode.Null) then LCodeInt := LCodeNode.int32 else LCodeInt := 0; //err is null unless an error occurs. When there was an error with the preceding //operation, err contains a string identifying the error. - LNode := LJSONDoc.Node.ChildNodes.FindNode('err'); + LNode := LJSONDoc.ChildNodes.FindNode('err'); if assigned(LNode) and (not LNode.Null) then raise EAlMongoDBClientException.Create(LNode.Text, LCodeInt); //errmsg contains the description of the error. errmsg only appears //if there was an error with the preceding operation. - LNode := LJSONDoc.Node.ChildNodes.FindNode('errmsg'); + LNode := LJSONDoc.ChildNodes.FindNode('errmsg'); if assigned(LNode) and (not LNode.Null) then raise EAlMongoDBClientException.Create(LNode.Text, LCodeInt); @@ -1236,18 +1236,18 @@ function TAlBaseMongoDBClient.GetResponse(aSocketDescriptor: TSocket): AnsiStrin //results in the creation of a new document, n returns the number of documents inserted. // //n is 0 if reporting on an update or remove that occurs through a findAndModify operation. - LNode := LJSONDoc.Node.ChildNodes.FindNode('n'); + LNode := LJSONDoc.ChildNodes.FindNode('n'); if assigned(LNode) then NumberOfDocumentsUpdatedOrRemoved := LNode.int32 else NumberOfDocumentsUpdatedOrRemoved := 0; //updatedExisting is true when an update affects at least one document and //does not result in an upsert. - LNode := LJSONDoc.Node.ChildNodes.FindNode('updatedExisting'); + LNode := LJSONDoc.ChildNodes.FindNode('updatedExisting'); if assigned(LNode) then UpdatedExisting := LNode.bool else UpdatedExisting := False; //If the update results in an insert, upserted is the value of _id field of the document. - LNode := LJSONDoc.Node.ChildNodes.FindNode('upserted'); + LNode := LJSONDoc.ChildNodes.FindNode('upserted'); if assigned(LNode) then Upserted := LNode.text else Upserted := ''; @@ -1358,7 +1358,7 @@ function TAlBaseMongoDBClient.GetResponse(aSocketDescriptor: TSocket): AnsiStrin LTmpInt: integer; LOPCode: integer; LBsonDocuments: ansiString; - LJsonDocument: TALJSONDocumentA; + LJsonDocument: TALJSONNodeA; i: integer; begin @@ -1387,7 +1387,7 @@ function TAlBaseMongoDBClient.GetResponse(aSocketDescriptor: TSocket): AnsiStrin LJsonDocument.LoadFromJSONString('{"documents":' + documents + '}'); // { .... } => {"documents":{ .... } } // [{ ... }, { ... }, { ... }] => {"documents":[{ ... }, { ... }, { ... }] } LBsonDocuments := ''; - with LJsonDocument.Node.ChildNodes['documents'] do begin + with LJsonDocument.ChildNodes['documents'] do begin if nodeType = ntObject then LBsonDocuments := BSON // {"documents":{ .... } } else begin // {"documents":[{ ... }, { ... }, { ... }] } for I := 0 to ChildNodes.Count - 1 do @@ -1461,7 +1461,7 @@ function TAlBaseMongoDBClient.GetResponse(aSocketDescriptor: TSocket): AnsiStrin LZERO: integer; LBsonSelector: ansiString; LBsonUpdate: AnsiString; - LJSONDocument: TALJSONDocumentA; + LJSONDocument: TALJSONNodeA; begin // @@ -1579,7 +1579,7 @@ function TAlBaseMongoDBClient.GetResponse(aSocketDescriptor: TSocket): AnsiStrin LOPCode: integer; LZERO: integer; LBsonSelector: ansiString; - LJSONDocument: TALJSONDocumentA; + LJSONDocument: TALJSONNodeA; begin // @@ -1676,7 +1676,7 @@ function TAlBaseMongoDBClient.GetResponse(aSocketDescriptor: TSocket): AnsiStrin LOPCode: integer; LBsonQuery: ansiString; LBSONReturnFieldsSelector: ansiString; - LJsonDocument: TALJSONDocumentA; + LJsonDocument: TALJSONNodeA; begin // @@ -1974,7 +1974,7 @@ function TAlBaseMongoDBClient.GetResponse(aSocketDescriptor: TSocket): AnsiStrin if (LTmpRowTag <> '') or (documents.NodeType = ntarray) then LJsonNode1 := documents.AddChild(LTmpRowTag, ntobject) else LJsonNode1 := documents; - LJsonNode1.LoadFromBSONString(LDocumentStr, False{ClearChildNodes}); + LJsonNode1.LoadFromBSONString(LDocumentStr, []); if LUpdateRowTagByFieldValue then begin LJsonNode2 := LJsonNode1.ChildNodes.FindNode(LTmpRowTag); if assigned(LJsonNode2) then LJsonNode1.NodeName := LJsonNode2.Text; @@ -2435,7 +2435,7 @@ procedure TAlMongoDBClient.Disconnect; ExtData: Pointer); Var LViewRec: TALJSONNodeA; - LJSONDocument: TALJSONDocumentA; + LJSONDocument: TALJSONNodeA; LResponseFlags: integer; LCursorID: int64; LStartingFrom: integer; @@ -2459,7 +2459,7 @@ procedure TAlMongoDBClient.Disconnect; if assigned(JSONDATA) then LJSONDocument := Nil else begin LJSONDocument := TALJSONDocumentA.create; - JSONDATA := LJSONDocument.Node; + JSONDATA := LJSONDocument; end; Try @@ -2493,7 +2493,7 @@ procedure TAlMongoDBClient.Disconnect; else LViewRec := JSONDATA; //assign the tmp data to the XMLData - LViewRec.LoadFromJsonString(LCacheStr, false{ClearChildNodes}); + LViewRec.LoadFromJsonString(LCacheStr, []); //exit exit; @@ -2921,7 +2921,7 @@ procedure TAlMongoDBClient.Disconnect; LRowRec: TALJSONNodeA; LCursorRec: TALJSONNodeA; LFirstBatchRec: TALJSONNodeA; - LJSONDocument: TALJSONDocumentA; + LJSONDocument: TALJSONNodeA; LResponseFlags: integer; LCursorID: int64; LStartingFrom: integer; @@ -2949,7 +2949,7 @@ procedure TAlMongoDBClient.Disconnect; if assigned(JSONDATA) then LJSONDocument := Nil else begin LJSONDocument := TALJSONDocumentA.create; - JSONDATA := LJSONDocument.Node; + JSONDATA := LJSONDocument; end; try @@ -2982,7 +2982,7 @@ procedure TAlMongoDBClient.Disconnect; else LViewRec := JSONDATA; //assign the tmp data to the XMLData - LViewRec.LoadFromJsonString(LCacheStr, false{ClearChildNodes}); + LViewRec.LoadFromJsonString(LCacheStr, []); //exit exit; @@ -3546,7 +3546,7 @@ procedure TAlMongoDBClient.Disconnect; LContinue: boolean; LTmpRowTag: ansiString; LUpdateRowTagByFieldValue: Boolean; - LJSONDoc: TALJSONDocumentA; + LJSONDoc: TALJSONNodeA; LNode1: TALJSONNodeA; LNode2: TALJSONNodeA; LLastErrorObjectNode: TALJSONNodeA; @@ -3594,7 +3594,7 @@ procedure TAlMongoDBClient.Disconnect; LCursorID, LStartingFrom, LNumberReturned, - LJSONDoc.Node, + LJSONDoc, nil, nil, '', @@ -3633,10 +3633,10 @@ procedure TAlMongoDBClient.Disconnect; else LViewRec := JSONdata; //check error - CheckRunCommandResponse(LJSONDoc.Node); + CheckRunCommandResponse(LJSONDoc); //get the value node - LNode1 := LJSONDoc.Node.ChildNodes.FindNode('value'); + LNode1 := LJSONDoc.ChildNodes.FindNode('value'); if assigned(LNode1) and (LNode1.NodeType = ntObject) then begin //init aUpdateRowTagByFieldValue and aTmpRowTag @@ -3673,7 +3673,7 @@ procedure TAlMongoDBClient.Disconnect; end; //init alastErrorObjectNode; - LLastErrorObjectNode := LJSONDoc.Node.ChildNodes['lastErrorObject']; + LLastErrorObjectNode := LJSONDoc.ChildNodes['lastErrorObject']; //NumberOfDocumentsUpdatedOrRemoved LNode1 := LLastErrorObjectNode.ChildNodes.FindNode('n'); @@ -4053,7 +4053,7 @@ procedure TAlMongoDBConnectionPoolClient.ReleaseAllConnections(Const WaitWorking const ConnectionSocket: TSocket = INVALID_SOCKET); Var LViewRec: TALJSONNodeA; - LJSONDocument: TALJSONDocumentA; + LJSONDocument: TALJSONNodeA; LResponseFlags: integer; LCursorID: int64; LStartingFrom: integer; @@ -4076,7 +4076,7 @@ procedure TAlMongoDBConnectionPoolClient.ReleaseAllConnections(Const WaitWorking if assigned(JSONDATA) then LJSONDocument := Nil else begin LJSONDocument := TALJSONDocumentA.create; - JSONDATA := LJSONDocument.Node; + JSONDATA := LJSONDocument; end; try @@ -4110,7 +4110,7 @@ procedure TAlMongoDBConnectionPoolClient.ReleaseAllConnections(Const WaitWorking else LViewRec := JSONDATA; //assign the tmp data to the XMLData - LViewRec.LoadFromJsonString(LCacheStr, false{ClearChildNodes}); + LViewRec.LoadFromJsonString(LCacheStr, []); //exit exit; @@ -4564,7 +4564,7 @@ procedure TAlMongoDBConnectionPoolClient.ReleaseAllConnections(Const WaitWorking LRowRec: TALJSONNodeA; LCursorRec: TALJSONNodeA; LFirstBatchRec: TALJSONNodeA; - LJSONDocument: TALJSONDocumentA; + LJSONDocument: TALJSONNodeA; LResponseFlags: integer; LCursorID: int64; LStartingFrom: integer; @@ -4591,7 +4591,7 @@ procedure TAlMongoDBConnectionPoolClient.ReleaseAllConnections(Const WaitWorking if assigned(JSONDATA) then LJSONDocument := Nil else begin LJSONDocument := TALJSONDocumentA.create; - JSONDATA := LJSONDocument.Node; + JSONDATA := LJSONDocument; end; try @@ -4624,7 +4624,7 @@ procedure TAlMongoDBConnectionPoolClient.ReleaseAllConnections(Const WaitWorking else LViewRec := JSONDATA; //assign the tmp data to the XMLData - LViewRec.LoadFromJsonString(LCacheStr, false{ClearChildNodes}); + LViewRec.LoadFromJsonString(LCacheStr, []); //exit exit; @@ -5317,7 +5317,7 @@ procedure TAlMongoDBConnectionPoolClient.ReleaseAllConnections(Const WaitWorking LContinue: boolean; LTmpRowTag: ansiString; LUpdateRowTagByFieldValue: Boolean; - LJSONDoc: TALJSONDocumentA; + LJSONDoc: TALJSONNodeA; LNode1: TALJSONNodeA; LNode2: TALJSONNodeA; LLastErrorObjectNode: TALJSONNodeA; @@ -5374,7 +5374,7 @@ procedure TAlMongoDBConnectionPoolClient.ReleaseAllConnections(Const WaitWorking LCursorID, LStartingFrom, LNumberReturned, - LJSONDoc.Node, + LJSONDoc, nil, nil, '', @@ -5413,10 +5413,10 @@ procedure TAlMongoDBConnectionPoolClient.ReleaseAllConnections(Const WaitWorking else LViewRec := JSONdata; //check error - CheckRunCommandResponse(LJSONDoc.Node); + CheckRunCommandResponse(LJSONDoc); //get the value node - LNode1 := LJSONDoc.Node.ChildNodes.FindNode('value'); + LNode1 := LJSONDoc.ChildNodes.FindNode('value'); if assigned(LNode1) and (LNode1.NodeType = ntObject) then begin //init aUpdateRowTagByFieldValue and aTmpRowTag @@ -5453,7 +5453,7 @@ procedure TAlMongoDBConnectionPoolClient.ReleaseAllConnections(Const WaitWorking end; //init alastErrorObjectNode; - LLastErrorObjectNode := LJSONDoc.Node.ChildNodes['lastErrorObject']; + LLastErrorObjectNode := LJSONDoc.ChildNodes['lastErrorObject']; //NumberOfDocumentsUpdatedOrRemoved LNode1 := LLastErrorObjectNode.ChildNodes.FindNode('n'); diff --git a/Source/Alcinoe.Sqlite3.Client.pas b/Source/Alcinoe.Sqlite3.Client.pas index 6bf33c1c6..5bc6eab03 100644 --- a/Source/Alcinoe.Sqlite3.Client.pas +++ b/Source/Alcinoe.Sqlite3.Client.pas @@ -717,7 +717,7 @@ procedure TalSqlite3Client.OnUpdateDataDone( LRecIndex: integer; LRecAdded: integer; LContinue: Boolean; - LJsonDocument: TALJSONDocumentA; + LJsonDocument: TALJSONNodeA; LUpdateRowTagByFieldValue: Boolean; LStopWatch: TStopWatch; LCacheKey: ansiString; @@ -736,7 +736,7 @@ procedure TalSqlite3Client.OnUpdateDataDone( if assigned(JsonDATA) then LJsonDocument := Nil else begin LJsonDocument := TALJSONDocumentA.create; - JsonDATA := LJsonDocument.Node; + JsonDATA := LJsonDocument; end; try @@ -765,7 +765,7 @@ procedure TalSqlite3Client.OnUpdateDataDone( else LViewRec := Jsondata; //assign the tmp data to the JsonData - LViewRec.LoadFromBsonString(LCacheStr, false{ClearChildNodes}); + LViewRec.LoadFromBsonString(LCacheStr, []); //exit exit; @@ -851,7 +851,7 @@ procedure TalSqlite3Client.OnUpdateDataDone( end; //free the node if aJsonDocument - if assigned(LJsonDocument) then LJsonDocument.Node.ChildNodes.Clear; + if assigned(LJsonDocument) then LJsonDocument.ChildNodes.Clear; //handle the First inc(LRecAdded); @@ -1832,7 +1832,7 @@ procedure TalSqlite3ConnectionPoolClient.OnUpdateDataDone( LTmpConnectionHandle: SQLite3; LOwnConnection: Boolean; LContinue: Boolean; - LJsonDocument: TALJSONDocumentA; + LJsonDocument: TALJSONNodeA; LUpdateRowTagByFieldValue: Boolean; LStopWatch: TStopWatch; LCacheKey: ansiString; @@ -1848,7 +1848,7 @@ procedure TalSqlite3ConnectionPoolClient.OnUpdateDataDone( if assigned(JsonDATA) then LJsonDocument := Nil else begin LJsonDocument := TALJSONDocumentA.create; - JsonDATA := LJsonDocument.Node; + JsonDATA := LJsonDocument; end; try @@ -1877,7 +1877,7 @@ procedure TalSqlite3ConnectionPoolClient.OnUpdateDataDone( else LViewRec := Jsondata; //assign the tmp data to the JsonData - LViewRec.LoadFromBsonString(LCacheStr, false{ClearChildNodes}); + LViewRec.LoadFromBsonString(LCacheStr, []); //exit exit; @@ -1969,7 +1969,7 @@ procedure TalSqlite3ConnectionPoolClient.OnUpdateDataDone( end; //free the node if aJsonDocument - if assigned(LJsonDocument) then LJsonDocument.Node.ChildNodes.Clear; + if assigned(LJsonDocument) then LJsonDocument.ChildNodes.Clear; //handle the First inc(LRecAdded); diff --git a/Tools/AndroidMerger/_Build/Source/AndroidMerger.dpr b/Tools/AndroidMerger/_Build/Source/AndroidMerger.dpr index dae27af34..a647221bb 100644 --- a/Tools/AndroidMerger/_Build/Source/AndroidMerger.dpr +++ b/Tools/AndroidMerger/_Build/Source/AndroidMerger.dpr @@ -1593,7 +1593,7 @@ end; {***********************} Function FindLibraryNode( - const ALibraries: TALJSONDocumentA; + const ALibraries: TALJSONNodeA; const AGroupID: AnsiString; const AArtifactID: AnsiString; const AVersion: AnsiString): TALJSONNodeA; @@ -1612,7 +1612,7 @@ end; {*************************} Function RemoveLibraryNode( - const ALibraries: TALJSONDocumentA; + const ALibraries: TALJSONNodeA; const AGroupID: AnsiString; const AArtifactID: AnsiString; const AVersion: AnsiString): TALJSONNodeA; @@ -2361,7 +2361,7 @@ begin else begin if ALPosA(' ', LDependencyVersion) > 0 then raise Exception.Create('Error CD3F7D9C-874C-4089-B674-9CCCE4AFA50E'#13#10+string(LGradleResultSrc)); if FindLibraryNode( - LLibraries, // const ALibraries: TALJSONDocumentA; + LLibraries, // const ALibraries: TALJSONNodeA; LDependencyGroupID, // const AGroupID: AnsiString; LDependencyArtifactID, // const AArtifactID: AnsiString; LDependencyVersion) <> nil then continue; // const AVersion: AnsiString): TALJSONNodeA; then @@ -2503,7 +2503,7 @@ begin {$REGION 'init LAlreadyIncludedDependencyLibrary'} var LAlreadyIncludedDependencyLibrary := FindLibraryNode( - LLibraries, // const ALibraries: TALJSONDocumentA; + LLibraries, // const ALibraries: TALJSONNodeA; LDependencyGroupID, // const AGroupID: AnsiString; LDependencyArtifactID, // const AArtifactID: AnsiString; ''); // const AVersion: AnsiString): TALJSONNodeA; @@ -2675,7 +2675,7 @@ begin if (LTodeleteGroupID = '') or (LTodeleteArtifactid = '') or (LTodeleteVersion = '') then raise Exception.Create('Error 47607420-D49C-4D38-9185-A2B597EF7551'); RemoveLibraryNode( - LLibraries, // const ALibraries: TALJSONDocumentA; + LLibraries, // const ALibraries: TALJSONNodeA; LTodeleteGroupID, // const AGroupID: AnsiString; LTodeleteArtifactid, // const AArtifactID: AnsiString; LTodeleteVersion); // const AVersion: AnsiString): TALJSONNodeA; diff --git a/Tools/DeployProjNormalizer/_Source/DeployProjNormalizer.dpr b/Tools/DeployProjNormalizer/_Source/DeployProjNormalizer.dpr index 2ab8b3905..bc9177636 100644 --- a/Tools/DeployProjNormalizer/_Source/DeployProjNormalizer.dpr +++ b/Tools/DeployProjNormalizer/_Source/DeployProjNormalizer.dpr @@ -290,7 +290,7 @@ begin LDeployProjXmlDoc.ParseOptions := []; //remove the Prolog node - LDeployProjXmlDoc.Node.ChildNodes.Delete(0); + LDeployProjXmlDoc.ChildNodes.Delete(0); // LDeployProjXmlDoc.DocumentElement.Attributes['xmlns'] := LDProjXmlDoc.DocumentElement.Attributes['xmlns'];