unit fpjsonrtti;
{
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2022 by Michael van Canney and other members of the
    Free Pascal development team

    Json RTTI support

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

{$mode objfpc}

interface

uses
  Classes, SysUtils, contnrs, typinfo, fpjson, rttiutils, jsonparser;

Const
  RFC3339DateTimeFormat = 'yyyy"-"mm"-"dd"T"hh":"nn":"ss';
  RFC3339DateTimeFormatMsec = RFC3339DateTimeFormat+'.zzz';
  

Type

  TJSONStreamEvent = Procedure (Sender : TObject; AObject : TObject; JSON : TJSONObject) of object;
  TJSONPropertyEvent = Procedure (Sender : TObject; AObject : TObject; Info : PPropInfo; var Res : TJSONData) of object;

  TJSONStreamOption = (jsoStreamChildren,         // If set, children will be streamed in 'Children' Property
                       jsoEnumeratedAsInteger,    // Write enumerated as integer. Default is string.
                       jsoSetAsString,            // Write Set as a string. Default is an array.
                       jsoSetEnumeratedAsInteger, // Write enumerateds in set array as integers.
                       jsoSetBrackets,            // Use brackets when creating set as array
                       jsoComponentsInline,       // Always stream components inline. Default is to stream name, unless csSubcomponent in ComponentStyle
                       jsoTStringsAsArray,        // Stream TStrings as an array of strings. Associated objects are not streamed.
                       jsoTStringsAsObject,       // Stream TStrings as an object : string = { object }
                       jsoDateTimeAsString,       // Format a TDateTime value as a string
                       jsoUseFormatString,        // Use FormatString when creating JSON strings.
                       jsoCheckEmptyDateTime,     // If TDateTime value is empty and jsoDateTimeAsString is used, 0 date returns empty string
                       jsoLegacyDateTime,         // Set this to enable old date/time formatting. Current behaviour is to save date/time as a ISO 9601 value.
                       jsoLowerPropertyNames,     // Set this to force lowercase names when streaming to JSON.
                       jsoStreamTList             // Set this to assume that TList contains a list of TObjects. Use with care!
                       );  
  TJSONStreamOptions = Set of TJSONStreamOption;

  TJSONFiler = Class(TComponent)
  Protected
    Procedure Error(Const Msg : String);
    Procedure Error(Const FMT : String;  Args : Array of const);
  end;

  { TJSONStreamer }

  TJSONStreamer = Class(TJSONFiler)
  private
    FAfterStreamObject: TJSONStreamEvent;
    FBeforeStreamObject: TJSONStreamEvent;
    FChildProperty: String;
    FDateTimeFormat: String;
    FOnStreamProperty: TJSONPropertyEvent;
    FOptions: TJSONStreamOptions;
    function GetChildProperty: String;
    function IsChildStored: boolean;
    function StreamChildren(AComp: TComponent): TJSONArray;
  protected
    function StreamClassProperty(Const AObject: TObject): TJSONData; virtual;
    Function StreamProperty(Const AObject : TObject; Const PropertyName : String) : TJSONData;
    Function StreamProperty(Const AObject : TObject; PropertyInfo : PPropInfo) : TJSONData;
    Function FormatDateProp(const DateTime : TDateTime) : TJSONString;
  Public
    Constructor Create(AOwner : TComponent); override;
    Destructor Destroy;override;
    //
    // Basic functions
    //
    // Use RTTI to stream object.
    // If AObject is of type TStrings or TCollection, special treatment occurs:
    // TStrings results in { Strings: [S,S,S] } or { Strings: { "S1" : O1, "S2" : O2 }} depending on Options.
    // Collection results in { Items: [I,I,I] }
    Function ObjectToJSON(Const AObject : TObject) : TJSONObject;
    // Stream a collection - always returns an array
    function StreamCollection(Const ACollection: TCollection): TJSONArray;
    // Stream an objectlist - always returns an array
    function StreamObjectList(Const AnObjectList: TObjectList): TJSONArray;
    // Stream a List - always returns an array
    function StreamTList(Const AList: TList): TJSONArray;
    // Stream a TStrings instance as an array
    function StreamTStringsArray(Const AStrings: TStrings): TJSONArray;
    // Stream a TStrings instance as an object
    function StreamTStringsObject(Const AStrings: TStrings): TJSONObject;
    // Stream a TStrings instance. Takes into account Options.
    function StreamTStrings(Const AStrings: TStrings): TJSONData;
    // Stream a variant as JSON.
    function StreamVariant(const Data: Variant): TJSONData; virtual;
    //
    // Some utility functions.
    //
    // Call ObjectToJSON and convert result to JSON String.
    Function ObjectToJSONString(AObject : TObject) : TJSONStringType;
    // Convert TSTrings to JSON string with array or Object.
    Function StringsToJSON(Const Strings : TStrings; AsObject : Boolean = False) : TJSONStringType;
    // Convert collection to JSON string
    Function CollectionToJSON(Const ACollection : TCollection) : TJSONStringType;
    // Convert variant to JSON String
    Function VariantToJSON(Const Data : Variant) : TJSONStringType;
  Published
    // Format used when formatting DateTime values. Only used in conjunction with jsoDateTimeToString
    Property DateTimeFormat : String Read FDateTimeFormat Write FDateTimeFormat;
    // Options to use when streaming
    Property Options : TJSONStreamOptions Read FOptions Write FOptions;
    // Called before streaming an object with ObjectToJSON
    Property BeforeStreamObject : TJSONStreamEvent Read FBeforeStreamObject Write FBeforeStreamObject;
    // Called After streaming an object with ObjectToJSON
    Property AfterStreamObject : TJSONStreamEvent Read FAfterStreamObject Write FAfterStreamObject;
    // Called whenever a property was streamed. If Res is nil on return, no property is added.
    Property OnStreamProperty : TJSONPropertyEvent Read FOnStreamProperty Write FOnStreamProperty;
    // Property name to use when streaming child components. Default is "Children"
    Property ChildProperty : String Read GetChildProperty Write FChildProperty Stored IsChildStored;
  end;

  { TJSONDeStreamer }
  TJSONRestorePropertyEvent = Procedure (Sender : TObject; AObject : TObject; Info : PPropInfo; AValue : TJSONData; Var Handled : Boolean) of object;
  TJSONPropertyErrorEvent = Procedure (Sender : TObject; AObject : TObject; Info : PPropInfo; AValue : TJSONData; Error : Exception; Var Continue : Boolean) of object;
  TJSONGetObjectEvent = Procedure (Sender : TOBject; AObject : TObject; Info : PPropInfo; AData : TJSONObject; DataName : TJSONStringType; Var AValue : TObject);
  TJSONDestreamOption = (jdoCaseInsensitive,jdoIgnorePropertyErrors,jdoIgnoreNulls,jdoNullClearsProperty);
  TJSONDestreamOptions = set of TJSONDestreamOption;

  TJSONDeStreamer = Class(TJSONFiler)
  private
    FAfterReadObject: TJSONStreamEvent;
    FBeforeReadObject: TJSONStreamEvent;
    FDateTimeFormat: String;
    FOnGetObject: TJSONGetObjectEvent;
    FOnPropError: TJSONpropertyErrorEvent;
    FOnRestoreProp: TJSONRestorePropertyEvent;
    FOptions: TJSONDestreamOptions;
    procedure DeStreamClassProperty(AObject: TObject; PropInfo: PPropInfo; PropData: TJSONData);
    function GetCaseInsensitive: Boolean;
    procedure SetCaseInsensitive(AValue: Boolean);
  protected
    // Try to parse a date.
    Function ExtractDateTime(S : String): TDateTime;
    function GetObject(AInstance : TObject; const APropName: TJSONStringType; D: TJSONObject; PropInfo: PPropInfo): TObject;
    procedure DoClearProperty(AObject: TObject; PropInfo: PPropInfo); virtual;
    procedure DoRestoreProperty(AObject: TObject; PropInfo: PPropInfo;  PropData: TJSONData); virtual;
    function DoMapProperty(AObject: TObject; PropInfo: PPropInfo; JSON: TJSONObject): TJSONData; virtual;
    procedure DoBeforeReadObject(Const JSON: TJSONObject; AObject: TObject); virtual;
    procedure DoAfterReadObject(Const JSON: TJSONObject; AObject: TObject); virtual;
    Function ObjectFromString(Const JSON : TJSONStringType) : TJSONData; virtual;
    procedure RestoreProperty(AObject: TObject; PropInfo: PPropInfo; PropData: TJSONData);
  Public
    Constructor Create(AOwner : TComponent); override;
    Destructor Destroy; override;
    // Convert JSON object to properties of AObject
    Procedure JSONToObject(Const JSON : TJSONStringType; AObject : TObject);
    Procedure JSONToObject(Const JSON : TJSONObject; AObject : TObject);
    // Convert JSON object/array to collection.
    Procedure JSONToCollection(Const JSON : TJSONStringType; ACollection : TCollection);
    Procedure JSONToCollection(Const JSON : TJSONData; ACollection : TCollection);
    // Convert JSON array/object/string to TStrings
    Procedure JSONToStrings(Const JSON : TJSONStringType; AStrings : TSTrings);
    Procedure JSONToStrings(Const JSON : TJSONData; AStrings : TSTrings);
    // Convert JSON data to a variant. Supports simple data types and arrays.
    Function JSONToVariant(Data: TJSONData): Variant;
    Function JSONToVariant(Data: TJSONStringType): Variant;
    // Triggered at the start of each call to JSONToObject
    Property BeforeReadObject : TJSONStreamEvent Read FBeforeReadObject Write FBeforeReadObject;
    // Triggered at the end of each call to JSONToObject (not if exception happens)
    Property AfterReadObject : TJSONStreamEvent Read FAfterReadObject Write FAfterReadObject;
    // Called when a property will be restored. If 'Handled' is True on return, property is considered restored.
    Property OnRestoreProperty : TJSONRestorePropertyEvent Read FOnRestoreProp Write FOnRestoreProp;
    // Called when an error occurs when restoring a property. If Continue is False on return, exception is re-raised.
    Property OnPropertyError : TJSONpropertyErrorEvent Read FOnPropError Write FOnPropError;
    // Called when a object-typed property must be restored, and the property is Nil. Must return an instance for the property.
    // Published Properties of the instance will be further restored with available data.
    Property OngetObject : TJSONGetObjectEvent Read FOnGetObject Write FOnGetObject;
    // JSON is by definition case sensitive. Should properties be looked up case-insentive ?
    Property CaseInsensitive : Boolean Read GetCaseInsensitive Write SetCaseInsensitive ; deprecated;
    // DateTime format. If not set, RFC3339DateTimeFormat is assumed.
    // If set, it will be used as an argument to ScanDateTime. If that fails, StrToDateTime is used.
    Property DateTimeFormat : String Read FDateTimeFormat Write FDateTimeFormat;
    // Options overning the behaviour
    Property Options : TJSONDestreamOptions Read FOptions Write FOptions;
  end;

  EJSONRTTI = Class(Exception);


implementation

uses dateutils, variants, rtlconsts;

ResourceString
  SErrUnknownPropertyKind     = 'Unknown property kind for property : "%s"';
  SErrUnsupportedPropertyKind = 'Unsupported property kind for property: "%s"';
  SErrUnsupportedVariantType  = 'Unsupported variant type : %d';
  SErrUnsupportedArrayType    = 'JSON array cannot be streamed to object of class "%s"';
  SErrUnsupportedJSONType     = 'Cannot destream object from JSON data of type "%s"';
  SErrUnsupportedCollectionType = 'Unsupported JSON type for collections: "%s"';
  SErrUnsupportedCollectionItemType = 'Array element %d is not a valid type for a collection item: "%s"';
  SErrUnsupportedStringsItemType = 'Array element %d is not a valid type for a stringlist item: "%s"';
  SErrUnsupportedStringsType = 'Unsupported JSON type for stringlists: "%s"';
  SErrUnsupportedStringsObjectType = 'Object Element %s is not a valid type for a stringlist object: "%s"';
  SErrUnSupportedEnumDataType = 'Unsupported JSON type for enumerated property "%s" : "%s"';
  SErrUnsupportedVariantJSONType = 'Unsupported JSON type for variant value : "%s"';
  SErrUnsupportedObjectData = 'Unsupported JSON type for object property: "%s"';

{ TStreamChildrenHelper }

Type
  TSet = set of 0..31; // Used to (de)stream set properties.

  TStreamChildrenHelper = Class
  Private
   FChildren : TJSONArray;
   FStreamer:TJSONStreamer;
   procedure StreamChild(AChild: TComponent);
  public
    Function StreamChildren(AComponent : TComponent; AStreamer : TJSONStreamer): TJSONArray;
  end;

  THackComponent = Class(TComponent);

{ TJSONDeStreamer }

function TJSONDeStreamer.ObjectFromString(const JSON: TJSONStringType): TJSONData;

begin
  With TJSONParser.Create(JSON,[]) do
    try
      Result:=Parse;
    finally
      Free;
    end;
end;

constructor TJSONDeStreamer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
end;

destructor TJSONDeStreamer.Destroy;
begin
  inherited Destroy;
end;

procedure TJSONDeStreamer.JSONToObject(const JSON: TJSONStringType;
  AObject: TObject);

Var
  D : TJSONData;

begin
  D:=ObjectFromString(JSON);

  if not Assigned(D) then
    Exit;

  try
    If D.JSONType=jtObject then
      JSONToObject(D as TJSONObject,AObject)
    else if D.JSONType=jtArray then
      begin
      If AObject is TStrings then
        JSONToStrings(D,AObject as TSTrings)
      else if AObject is TCollection then
        JSONTOCollection(D,AObject as TCollection)
      else
        Error(SErrUnsupportedArrayType,[AObject.ClassName])
      end
    else if (D.JSONType=jtString) and (AObject is TStrings) then
      JSONToStrings(D,AObject as TStrings)
    else
      Error(SErrUnsupportedJSONType,[JSONTypeName(D.JSONType)]);
  finally
    FreeAndNil(D);
  end;
end;

function TJSONDeStreamer.JSONToVariant(Data: TJSONData): Variant;

Var
  I : integer;

begin
  Case Data.JSONType of
    jtNumber :
      Case TJSONNumber(Data).NumberType of
        ntFloat   : Result:=Data.AsFloat;
        ntInteger : Result:=Data.AsInteger;
        ntInt64   : Result:=Data.Asint64;
        ntQWord   : Result:=Data.AsQWord;
      end;
    jtString :
      Result:=Data.AsString;
    jtBoolean:
      Result:=Data.AsBoolean;
    jtNull:
      Result:=Null;
    jtArray :
      begin
      Result:=VarArrayCreate([0,Data.Count-1],varVariant);
      For I:=0 to Data.Count-1 do
        Result[i]:=JSONToVariant(Data.Items[i]);
      end;
  else
    Error(SErrUnsupportedVariantJSONType,[GetEnumName(TypeInfo(TJSONType),Ord(Data.JSONType))]);
  end;
end;

function TJSONDeStreamer.JSONToVariant(Data: TJSONStringType): Variant;

Var
  D : TJSONData;

begin
  D:=ObjectFromString(Data);
  try
    Result:=JSONToVariant(D);
  finally
    D.Free;
  end;
end;

procedure TJSONDeStreamer.DeStreamClassProperty(AObject : TObject;PropInfo : PPropInfo; PropData : TJSONData);

Var
  O : TObject;

begin
  O:=GetObjectProp(AObject,PropInfo);
  If O is TStrings then
    JSONToStrings(PropData,O as TStrings)
  else if (O is TCollection) then
    JSONToCollection(PropData,O as TCollection)
  else
    begin
    If (O=Nil) then
      begin
      If (PropData.JSONType=jtString) then
        O:=GetObject(AObject,PropData.AsString,Nil,PropInfo)
      else if (PropData.JSONType=jtObject) then
        O:=GetObject(AObject,'',PropData as TJSONObject,PropInfo)
      else
        Error(SErrUnsupportedObjectData,[JsonTypeName(PropData.JSONType){GetEnumName(TypeInfo(TJSONType),Ord(PropData.JSONType))}]);
      SetObjectProp(AObject,PropInfo,O);
      end;
    If (O<>Nil) and (PropData.JSONType=jtObject) then
      JSONToObject(PropData as TJSONObject,O);
    end;
end;

function TJSONDeStreamer.GetCaseInsensitive: Boolean;
begin
  Result:=jdoCaseInsensitive in Options;
end;

procedure TJSONDeStreamer.SetCaseInsensitive(AValue: Boolean);
begin
  if AValue then
    Include(Foptions,jdoCaseInsensitive)
  else
    Exclude(Foptions,jdoCaseInsensitive);
end;

function TJSONDeStreamer.ExtractDateTime(S: String): TDateTime;

Var
  Fmt : String;
  E,fmtSpecified : Boolean;

begin
  E:=False;
  FMT:=DateTimeFormat;
  fmtSpecified:=Fmt<>'';
  if Not fmtSpecified then
    FMT:=RFC3339DateTimeFormat;
  Try
    // No TryScanDateTime
    Result:=ScanDatetime(FMT,S);
  except
    if fmtSpecified then
      Raise
    else
      E:=True;
  end;
  if E then
    if not TryStrToDateTime(S,Result) then
      if not TryStrToDate(S,Result) then
        if not TryStrToTime(S,Result) then
          Raise EConvertError.CreateFmt(SInvalidDateTime,[S]);
//  ExtractDateTime(PropData.AsString)
end;

procedure TJSONDeStreamer.RestoreProperty(AObject : TObject;PropInfo : PPropInfo; PropData : TJSONData);

Var
  B : Boolean;

begin
  try
    B:=Not Assigned(FOnRestoreProp);
    If Not B then
      begin
      FOnRestoreProp(Self,AObject,PropInfo,PropData,B);
      If B then
        exit;
      end;
    if (PropData.JSONType<>jtNull) then
      DoRestoreProperty(AObject,PropInfo,PropData)
    else if (jdoNullClearsProperty in Options) then
      DoClearProperty(aObject,PropInfo)
    else if not (jdoIgnoreNulls in Options) then
      DoRestoreProperty(AObject,PropInfo,PropData)

  except
    On E : Exception do
      If Assigned(FOnPropError) then
        begin
        B:=False;
        FOnPropError(Self,AObject,PropInfo,PropData,E,B);
        If Not B then
          Raise;
        end
      else if Not (jdoIgnorePropertyErrors in Options) then
        Raise;
  end;
end;

procedure TJSONDeStreamer.DoClearProperty(AObject : TObject;PropInfo : PPropInfo);

Var
  PI : PPropInfo;
  TI : PTypeInfo;

begin
  PI:=PropInfo;
  TI:=PropInfo^.PropType;
  case TI^.Kind of
    tkUnknown :
      Error(SErrUnknownPropertyKind,[PI^.Name]);
    tkInteger,
    tkEnumeration,
    tkSet,
    tkChar,
    tkWChar,
    tkBool,
    tkQWord,
    tkUChar,
    tkInt64 :
      SetOrdProp(AObject,PI,0);
    tkFloat :
      SetFloatProp(AObject,PI,0.0);
    tkSString,
    tkLString,
    tkAString:
      SetStrProp(AObject,PI,'');
    tkWString :
      SetWideStrProp(AObject,PI,'');
    tkVariant:
      SetVariantProp(AObject,PI,Null);
    tkClass:
      SetOrdProp(AObject,PI,0);
    tkUString :
      SetUnicodeStrProp(AObject,PI,'');
  else
{
    tkObject,
    tkArray,
    tkRecord,
    tkInterface,
    tkDynArray,
    tkInterfaceRaw,
    tkProcVar,
    tkMethod }
      Error(SErrUnsupportedPropertyKind,[PI^.Name]);
  end;
end;

procedure TJSONDeStreamer.DoRestoreProperty(AObject : TObject;PropInfo : PPropInfo; PropData : TJSONData);

Var
  PI : PPropInfo;
  TI : PTypeInfo;
  I,J,S : Integer;
  A : TJSONArray;
  JS : TJSONStringType;
begin
  PI:=PropInfo;
  TI:=PropInfo^.PropType;
  case TI^.Kind of
    tkUnknown :
      Error(SErrUnknownPropertyKind,[PI^.Name]);
    tkInteger :
      SetOrdProp(AObject,PI,PropData.AsInteger);
    tkInt64 :
      SetOrdProp(AObject,PI,PropData.AsInt64);
    tkEnumeration :
      begin
      if (PropData.JSONType=jtNumber) then
        I:=PropData.AsInteger
      else if PropData.JSONType=jtString then
        I:=GetEnumValue(TI,PropData.AsString)
      else
        Error(SErrUnSupportedEnumDataType,[PI^.Name,GetEnumName(TypeInfo(TJSONType),Ord(PropData.JSONType))]);
      SetOrdProp(AObject,PI,I);
      end;
    tkFloat :
      begin
      if (TI=TypeInfo(TDateTime)) and (PropData.JSONType=jtString) then
        SetFloatProp(AObject,PI,ExtractDateTime(PropData.AsString))
      else
        SetFloatProp(AObject,PI,PropData.AsFloat)
      end;
    tkSet :
      If PropData.JSONType=jtString then
        SetSetProp(AObject,PI,PropData.AsString)
      else if (PropData.JSONType=jtArray) then
        begin
        A:=PropData as TJSONArray;
        TI:=GetTypeData(TI)^.CompType;
        S:=0;
        For I:=0 to A.Count-1 do
          begin
          if A.types[i]=jtNumber then
            J:=A.Integers[i]
          else
            J:=GetEnumValue(TI,A.strings[i]);
          TSet(S):=TSet(S)+[j];
          end;
        SetOrdProp(AObject,PI,S);
        end;
    tkChar:
      begin
      JS:=PropData.AsString;
      If (JS<>'') then
        SetOrdProp(AObject,PI,Ord(JS[1]));
      end;
    tkSString,
    tkLString,
    tkAString:
      SetStrProp(AObject,PI,PropData.AsString);
    tkWString :
      SetWideStrProp(AObject,PI,PropData.AsUnicodeString);
    tkVariant:
      SetVariantProp(AObject,PI,JSONToVariant(PropData));
    tkClass:
      DeStreamClassProperty(AObject,PI,PropData);
    tkWChar :
      begin
      JS:=PropData.asString;
      If (JS<>'') then
        SetOrdProp(AObject,PI,Ord(JS[1]));
      end;
    tkBool :
      SetOrdProp(AObject,PI,Ord(PropData.AsBoolean));
    tkQWord :
      SetOrdProp(AObject,PI,Trunc(PropData.AsFloat));
    tkObject,
    tkArray,
    tkRecord,
    tkInterface,
    tkDynArray,
    tkInterfaceRaw,
    tkProcVar,
    tkMethod :
      Error(SErrUnsupportedPropertyKind,[PI^.Name]);
    tkUString :
      SetUnicodeStrProp(AObject,PI,PropData.AsUnicodeString);
    tkUChar:
      begin
      JS:=PropData.asString;
      If (JS<>'') then
        SetOrdProp(AObject,PI,Ord(JS[1]));
      end;
  end;
end;

function TJSONDeStreamer.DoMapProperty(AObject: TObject; PropInfo: PPropInfo; JSON: TJSONObject): TJSONData;
var
  J: Integer;
begin
  J := JSON.IndexOfName(PropInfo^.Name,(jdoCaseInsensitive in Options));
  if J > -1 then
    Result := JSON.Items[J]
  else
    Result := nil;
end;

procedure TJSONDeStreamer.DoBeforeReadObject(Const JSON: TJSONObject; AObject: TObject);
begin
  If Assigned(FBeforeReadObject) then
    FBeforeReadObject(Self,AObject,JSON);
end;

procedure TJSONDeStreamer.DoAfterReadObject(Const JSON: TJSONObject; AObject: TObject);
begin
  If Assigned(FAfterReadObject) then
    FAfterReadObject(Self,AObject,JSON)
end;

procedure TJSONDeStreamer.JSONToObject(const JSON: TJSONObject; AObject: TObject
  );
Var
  I : Integer;
  PIL : TPropInfoList;
  JD: TJSONData;

begin
  DoBeforeReadObject(JSON, AObject);
  If (AObject is TStrings) then
    JSONToStrings(JSON,AObject as TStrings)
  else If (AObject is TCollection) then
    JSONToCollection(JSON, AObject as TCollection)
  else
    begin
    Pil:=TPropInfoList.Create(AObject,tkProperties);
    try
      For I:=0 to PIL.Count-1 do
        begin
        JD:=DoMapProperty(AObject, Pil.Items[i], JSON);
        If Assigned(JD) then
          RestoreProperty(AObject,PIL.Items[i],JD);
        end;
    finally
      FreeAndNil(PIL);
    end;
    end;
  DoAfterReadObject(JSON, AObject);
end;

procedure TJSONDeStreamer.JSONToCollection(const JSON: TJSONStringType;
  ACollection: TCollection);
Var
  D : TJSONData;

begin
  D:=ObjectFromString(JSON);
  try
    if Assigned(D) then
      JSONToCollection(D,ACollection);
  finally
    D.Free;
  end;
end;

procedure TJSONDeStreamer.JSONToCollection(const JSON: TJSONData;
  ACollection: TCollection);

Var
  I : integer;
  A : TJSONArray;

begin
  If (JSON.JSONType=jtArray) then
    A:=JSON As TJSONArray
  else if JSON.JSONType=jtObject then
    A:=(JSON as TJSONObject).Arrays['Items']
  else
    Error(SErrUnsupportedCollectionType,[JSONTypeName(JSON.JSONType)]);
  ACollection.Clear;
  For I:=0 to A.Count-1 do
    If (A.Types[i]<>jtObject) then
      Error(SErrUnsupportedCollectionItemType,[I,JSONTypeName(A.Types[I])])
    else
      JSONToObject(A.Objects[i],ACollection.Add);
end;

procedure TJSONDeStreamer.JSONToStrings(const JSON: TJSONStringType;
  AStrings: TSTrings);
Var
  D : TJSONData;

begin
  D:=ObjectFromString(JSON);
  try
    JSONToStrings(D,AStrings);
  finally
    D.Free;
  end;
end;

function TJSONDeStreamer.GetObject(AInstance: TObject;
  const APropName: TJSONStringType; D: TJSONObject; PropInfo: PPropInfo
  ): TObject;

Var
  C : TClass;

begin
  Result:=Nil;
  If Assigned(FOnGetObject) then
    FOnGetObject(Self,AInstance,PropInfo,D,APropName,Result);
  If (Result=Nil) and (AInstance is TComponent) and Assigned(PropInfo) then
     begin
     C:=GetTypeData(Propinfo^.PropType)^.ClassType;
     If C.InheritsFrom(TComponent) then
       Result:=TComponentClass(C).Create(TComponent(AInstance));
     end;
end;

procedure TJSONDeStreamer.JSONToStrings(const JSON: TJSONData;
  AStrings: TSTrings);

Var
  O  : TJSONObject;
  D  : TJSONData;
  I  : Integer;
  IO : TObject;
  N  : TJSONStringType;

begin
  Case JSON.JSONType of
    jtString:
      AStrings.Text:=JSON.AsString;
    jtArray:
      begin
      AStrings.Clear;
      For I:=0 to JSON.Count-1 do
        begin
        if not (JSON.Items[i].JSONType=jtString) then
          Error(SErrUnsupportedStringsItemType,[i,JSONTypeName(JSON.Items[i].JSONType)]);
        AStrings.Add(JSON.Items[i].AsString);
        end;
      end;
    jtObject:
      begin
      O:=JSON As TJSONObject;
      If (O.Count=1) and (O.Names[0]='Strings') and (O.Items[0].JSONType=jtArray) then
        JSONToStrings(O.Items[0],AStrings)
      else
        begin
        AStrings.Clear;
        For I:=0 to O.Count-1 do
          begin
          D:=O.Items[i];
          N:=O.Names[i];
          If D.JSONType=jtNull then
            IO:=Nil
          else if D.JSONType=jtObject then
            IO:=GetObject(AStrings,N,TJSONOBject(D),Nil)
          else
            Error(SErrUnsupportedStringsObjectType,[D,JSONTypeName(D.JSONType)]);
          AStrings.AddObject(O.Names[i],IO);
          end;
        end;
      end;
  else
    Error(SErrUnsupportedStringsType,[JSONTypeName(JSON.JSONType)]);
  end;
end;

Procedure TStreamChildrenHelper.StreamChild(AChild : TComponent);

begin
  FChildren.Add(FStreamer.ObjectToJSON(AChild));
end;

Function TStreamChildrenHelper.StreamChildren(AComponent : TComponent; AStreamer : TJSONStreamer): TJSONArray;

begin
  FStreamer:=AStreamer;
  Result:=TJSONArray.Create;
  try
    FChildren:=Result;
    THackComponent(AComponent).GetChildren(@StreamChild,AComponent);
  except
    FreeAndNil(Result);
    Raise;
  end;
end;

{ TJSONFiler }

procedure TJSONFiler.Error(Const Msg: String);
begin
  Raise EJSONRTTI.Create(Name+' : '+Msg);
end;

procedure TJSONFiler.Error(Const FMT: String; Args: array of const);
begin
  Raise EJSONRTTI.CreateFmt(Name+' : '+FMT,Args);
end;

{ TJSONStreamer }

constructor TJSONStreamer.Create(AOwner: TComponent);
begin
  Inherited;
end;

destructor TJSONStreamer.Destroy;
begin
  Inherited;
end;


Function TJSONStreamer.StreamChildren(AComp : TComponent) : TJSONArray;

begin
  With TStreamChildrenHelper.Create do
    try
      Result:=StreamChildren(AComp,Self);
    finally
      Free;
    end;
end;

function TJSONStreamer.GetChildProperty: String;
begin
  Result:=FChildProperty;
  If (Result='') then
    Result:='Children';
end;

function TJSONStreamer.IsChildStored: boolean;
begin
  Result:=(GetChildProperty<>'Children');
end;

function TJSONStreamer.ObjectToJSON(Const AObject: TObject): TJSONObject;

Var
  PIL : TPropInfoList;
  PD : TJSONData;
  I : Integer;

begin
  Result:=Nil;
  If (AObject=Nil) then
    Exit;
  Result:=TJSONObject.Create;
  try
    If Assigned(FBeforeStreamObject) then
      FBeforeStreamObject(Self,AObject,Result);
    If AObject is TStrings then
      Result.Add('Strings',StreamTStrings(Tstrings(AObject)))
    else If AObject is TCollection then
      Result.Add('Items',StreamCollection(TCollection(AObject)))
    else If AObject is TObjectList then
      Result.Add('Objects',StreamObjectList(TObjectList(AObject)))
    else if (jsoStreamTlist in Options) and (AObject is TList) then
      Result.Add('Objects', StreamTList(TList(AObject)))
    else
      begin
      PIL:=TPropInfoList.Create(AObject,tkProperties);
      try
        For I:=0 to PIL.Count-1 do
          begin
          PD:=StreamProperty(AObject,PIL.Items[i]);
            If (PD<>Nil) then begin
              if jsoLowerPropertyNames in Options then
                Result.Add(LowerCase(PIL.Items[I]^.Name),PD)
              else
            Result.Add(PIL.Items[I]^.Name,PD);
          end;
          end;
      finally
        FReeAndNil(Pil);
      end;
      If (jsoStreamChildren in Options) and (AObject is TComponent) then
        Result.Add(ChildProperty,StreamChildren(TComponent(AObject)));
      If Assigned(FAfterStreamObject) then
        FAfterStreamObject(Self,AObject,Result);
      end;
  except
    FreeAndNil(Result);
    Raise;
  end;
end;

function TJSONStreamer.StreamProperty(Const AObject: TObject; Const PropertyName : String): TJSONData;

begin
  Result:=StreamProperty(AObject,GetPropInfo(AObject,PropertyName));
end;

Function TJSONStreamer.StreamVariant(Const Data : Variant): TJSONData;

Var
  A : TJSONArray;
  I : Integer;

begin
  Result:=Nil;
  If VarIsArray(Data) then
    begin
    A:=TJSONArray.Create;
    try
      For I:=VarArrayLowBound(Data,1) to VarArrayHighBound(Data,1) do
        A.Add(StreamVariant(Data[i]));
    except
      FreeAndNil(A);
      Raise;
    end;
    Exit(A);
    end;
  If VarIsEmpty(Data) or VarisNull(Data) or (Data=UnAssigned) then
    Exit(TJSONNull.Create);
  Case VarType(Data) of
    varshortint,
    varbyte,
    varword,
    varsmallint,
    varinteger :
      Result:=TJSONIntegerNumber.Create(Data);
    varlongword,
    varint64 :
      Result:=TJSONInt64Number.Create(Data);
    vardecimal,
    varqword,
    varsingle,
    vardouble,
    varCurrency :
      Result:=TJSONFloatNumber.Create(Data);
    varString,
    varolestr :
      Result:=TJSONString.Create(Data);
    varboolean :
      Result:=TJSONBoolean.Create(Data);
    varDate :
      if jsoDateTimeAsString in Options then
        Result:=FormatDateProp(Data)
      else
        Result:=TJSONFloatNumber.Create(Data);
  else
    Error(SErrUnsupportedVariantType,[VarType(Data)])
  end;
end;

function TJSONStreamer.ObjectToJSONString(AObject: TObject): TJSONStringType;

Var
  O : TJSONData;

begin
  O:=ObjectToJSON(AObject);
  try
    if (jsoUseFormatString in Options) then
      Result:=O.FormatJSON()
    else
      Result:=O.AsJSON;
  finally
    FreeAndNil(O);
  end;
end;

function TJSONStreamer.StringsToJSON(Const Strings: TStrings; AsObject: Boolean = False): TJSONStringType;

Var
  D : TJSONData;

begin
  If ASObject then
    D:=StreamTSTringsObject(Strings)
  else
    D:=StreamTStringsArray(Strings);
  try
    if (jsoUseFormatString in Options) then
      Result:=D.FormatJSON
    else
      Result:=D.AsJSON;
  finally
    FreeAndNil(D);
  end;
end;

function TJSONStreamer.CollectionToJSON(const ACollection: TCollection
  ): TJSONStringType;

Var
  D : TJSONArray;

begin
  D:=StreamCollection(ACollection);
  try
    if (jsoUseFormatString in Options) then
      Result:=D.FormatJSON()
    else
    Result:=D.AsJSON;
  finally
    FreeAndNil(D);
  end;
end;

function TJSONStreamer.VariantToJSON(const Data: Variant): TJSONStringType;

Var
  D : TJSONData;

begin
  D:=StreamVariant(Data);
  try
    if (jsoUseFormatString in Options) then
      Result:=D.FormatJSON()
    else
      Result:=D.AsJSON;
  finally
    FreeAndNil(D);
  end;
end;

function TJSONStreamer.StreamTList(const AList: TList): TJSONArray;
var
  I : Integer;
  o : TJSONObject;
begin
  Result:=TJSONArray.Create;
  try
    for I:=0 to AList.Count-1 do begin
      o := ObjectToJSON(TObject(AList.Items[i]));
      if Assigned(o) then
        Result.Add(o);
    end;
  except
    FreeAndNil(Result);
    Raise;
  end;
end;

Function TJSONStreamer.StreamTStringsArray(Const AStrings : TStrings) : TJSONArray;

Var
  I : Integer;

begin
  Result:=TJSONArray.Create;
  try
    For I:=0 to AStrings.Count-1 do
      Result.Add(AStrings[i]);
  except
    FreeAndNil(Result);
    Raise;
  end;
end;

function TJSONStreamer.StreamTStringsObject(Const AStrings: TStrings): TJSONObject;

Var
  I : Integer;
  O : TJSONData;

begin
  Result:=TJSONObject.Create;
  try
    For I:=0 to AStrings.Count-1 do
      begin
      O:=ObjectToJSON(AStrings.Objects[i]);
      If O=Nil then
        O:=TJSONNull.Create;
      Result.Add(AStrings[i],O);
      end;
  except
    FreeAndNil(Result);
    Raise;
  end;
end;

function TJSONStreamer.StreamTStrings(Const AStrings: TStrings): TJSONData;
begin
  If jsoTStringsAsArray in Options then
    Result:=StreamTStringsArray(AStrings)
  else If jsoTStringsAsObject in Options then
    Result:=StreamTStringsObject(AStrings)
  else
    Result:=TJSONString.Create(AStrings.Text);
end;


Function TJSONStreamer.StreamCollection(Const ACollection : TCollection) : TJSONArray;

Var
  I : Integer;

begin
  Result:=TJSONArray.Create;
  try
    For I:=0 to ACollection.Count-1 do
      Result.Add(ObjectToJSON(ACollection.Items[i]));
  except
    FreeAndNil(Result);
    Raise;
  end;
end;

function TJSONStreamer.StreamObjectList(const AnObjectList: TObjectList): TJSONArray;
Var
  I : Integer;

begin
  if not Assigned(AnObjectList) then
    Result:=Nil;
  Result:=TJSONArray.Create;
  try
    For I:=0 to AnObjectList.Count-1 do
      Result.Add(ObjectToJSON(AnObjectList.Items[i]));
  except
    FreeAndNil(Result);
    Raise;
  end;
end;

function TJSONStreamer.StreamClassProperty(const AObject: TObject): TJSONData;


begin
  Result:=Nil;
  If (AObject=Nil) then
    Result:=TJSONNull.Create()
  else if (AObject is TComponent) then
    begin
    if (csSubComponent in TComponent(AObject).ComponentStyle) or (jsoComponentsInline in Options) then
      Result:=ObjectToJSON(AObject)
    else
      Result:=TJSONString.Create(TComponent(AObject).Name);
    end
  else if (AObject is TStrings) then
    Result:=StreamTStrings(TStrings(AObject))
  else if (AObject is TCollection) then
    Result:=StreamCollection(TCollection(Aobject))
  else If AObject is TObjectList then
    Result:=StreamObjectList(TObjectList(AObject))
  else // Normally, this is only TPersistent.
    Result:=ObjectToJSON(AObject);
end;

function TJSONStreamer.StreamProperty(Const AObject: TObject; PropertyInfo: PPropInfo): TJSONData;

Var
  PI : PPropInfo;
  PT : PTypeInfo;
  S,I : integer;

begin
  Result:=Nil;
  PI:=PropertyInfo;
  PT:=PI^.PropType;
  Case PT^.Kind of
    tkUnknown :
      Error(SErrUnknownPropertyKind,[PI^.Name]);
    tkInteger :
      Result:=TJSONIntegerNumber.Create(GetOrdProp(AObject,PI));
    tkEnumeration :
      if jsoEnumeratedAsInteger in Options then
        Result:=TJSONIntegerNumber.Create(GetOrdProp(AObject,PI))
      else
        Result:=TJSONString.Create(GetEnumName(PT,GetOrdProp(AObject,PI)));
    tkFloat :
      if (PT=TypeInfo(TDateTime)) and (jsoDateTimeAsString in Options) then
        Result:=FormatDateProp(GetFloatProp(AObject,PI))
      else
        Result:=TJSONFloatNumber.Create(GetFloatProp(AObject,PI));
    tkSet :
      If jsoSetAsString in Options then
        Result:=TJSONString.Create(GetSetProp(AObject,PI,jsoSetBrackets in Options))
      else
        begin
        PT:=GetTypeData(PT)^.CompType;
        S:=GetOrdProp(AObject,PI);
        Result:=TJSONArray.Create;
        try
          for i:=0 to 31 do
            if (i in TSet(S)) then
              if jsoSetEnumeratedAsInteger in Options then
                TJSONArray(Result).Add(i)
              else
                TJSONArray(Result).Add(GetEnumName(PT, i));
        except
          FreeAndNil(Result);
          Raise;
        end;
        end;
    tkChar:
      Result:=TJSONString.Create(Char(GetOrdProp(AObject,PI)));
    tkSString,
    tkLString,
    tkAString:
      Result:=TJSONString.Create(GetStrProp(AObject,PI));
    tkWString :
      Result:=TJSONString.Create(GetWideStrProp(AObject,PI));
    tkVariant:
      Result:=StreamVariant(GetVariantProp(AObject,PI));
    tkClass:
      Result:=StreamClassProperty(GetObjectProp(AObject,PI));
    tkWChar :
      Result:=TJSONString.Create(WideChar(GetOrdProp(AObject,PI)));
    tkBool :
      Result:=TJSONBoolean.Create(GetOrdProp(AObject,PropertyInfo)<>0);
    tkInt64 :
      Result:=TJSONInt64Number.Create(GetOrdProp(AObject,PropertyInfo));
    tkQWord :
      Result:=TJSONFloatNumber.Create(GetOrdProp(AObject,PropertyInfo));
    tkObject :
      Result:=ObjectToJSON(GetObjectProp(AObject,PropertyInfo));
    tkArray,
    tkRecord,
    tkInterface,
    tkDynArray,
    tkInterfaceRaw,
    tkProcVar,
    tkMethod :
      Error(SErrUnsupportedPropertyKind,[PI^.Name]);
    tkUString :
      Result:=TJSONString.Create(GetWideStrProp(AObject,PI));
    tkUChar:
      Result:=TJSONString.Create(UnicodeChar(GetOrdProp(AObject,PI)));
  end;
  If Assigned(FOnStreamProperty) then
    FOnStreamProperty(Self,AObject,PI,Result);
end;

function TJSONStreamer.FormatDateProp(Const DateTime: TDateTime): TJSONString;

Var
  S: String;

begin
  if (jsoCheckEmptyDateTime in Options) and (DateTime=0) then
    S:=''
  else if (DateTimeFormat<>'') then
    S:=FormatDateTime(DateTimeFormat,DateTime)
  else if (jsoLegacyDateTime in options) then  
    begin
    if Frac(DateTime)=0 then
      S:=DateToStr(DateTime)
    else if Trunc(DateTime)=0 then
      S:=TimeToStr(DateTime)
    else
      S:=DateTimeToStr(DateTime);
    end
  else
    S:=FormatDateTime(RFC3339DateTimeFormat,DateTime);
     
  Result:=TJSONString.Create(S);
end;

end.

