* Extended jsonrtti so it supports streaming of datetime and destreaming datetime (bug ID 28721)

git-svn-id: trunk@32876 -

.gitattributes

@@ -2502,6 +2502,7 @@ packages/fcl-json/src/jsonconf.pp svneol=native#text/plain
 packages/fcl-json/src/jsonparser.pp svneol=native#text/plain
 packages/fcl-json/src/jsonscanner.pp svneol=native#text/plain
 packages/fcl-json/tests/jsonconftest.pp svneol=native#text/plain
+packages/fcl-json/tests/testcomps.pp svneol=native#text/plain
 packages/fcl-json/tests/testjson.lpi svneol=native#text/plain
 packages/fcl-json/tests/testjson.pp svneol=native#text/plain
 packages/fcl-json/tests/testjsonconf.lpi svneol=native#text/plain

packages/fcl-json/src/fpjsonrtti.pp

@@ -7,6 +7,11 @@ 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;
@@ -22,7 +27,8 @@ Type
                        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
+                       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.
   TJSONStreamOptions = Set of TJSONStreamOption;
 
   TJSONFiler = Class(TComponent)
@@ -102,16 +108,25 @@ Type
   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);
+  TJSONDestreamOptions = set of TJSONDestreamOption;
+
   TJSONDeStreamer = Class(TJSONFiler)
   private
     FAfterReadObject: TJSONStreamEvent;
     FBeforeReadObject: TJSONStreamEvent;
+    FDateTimeFormat: String;
     FOnGetObject: TJSONGetObjectEvent;
     FOnPropError: TJSONpropertyErrorEvent;
     FOnRestoreProp: TJSONRestorePropertyEvent;
     FCaseInsensitive : Boolean;
+    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 DoRestoreProperty(AObject: TObject; PropInfo: PPropInfo;  PropData: TJSONData); virtual;
     Function ObjectFromString(Const JSON : TJSONStringType) : TJSONData; virtual;
@@ -143,7 +158,12 @@ Type
     // 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 FCaseInsensitive Write FCaseInsensitive;
+    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);
@@ -151,7 +171,7 @@ Type
 
 implementation
 
-uses variants;
+uses dateutils, variants, rtlconsts;
 
 ResourceString
   SErrUnknownPropertyKind     = 'Unknown property kind for property : "%s"';
@@ -207,7 +227,8 @@ begin
   inherited Destroy;
 end;
 
-procedure TJSONDeStreamer.JSONToObject(Const JSON: TJSONStringType; AObject: TObject);
+procedure TJSONDeStreamer.JSONToObject(const JSON: TJSONStringType;
+  AObject: TObject);
 
 Var
   D : TJSONData;
@@ -235,7 +256,7 @@ begin
   end;
 end;
 
-Function TJSONDeStreamer.JSONToVariant(Data : TJSONData) : Variant;
+function TJSONDeStreamer.JSONToVariant(Data: TJSONData): Variant;
 
 Var
   I : integer;
@@ -308,6 +329,48 @@ begin
     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
@@ -331,7 +394,9 @@ begin
         FOnPropError(Self,AObject,PropInfo,PropData,E,B);
         If Not B then
           Raise;
-        end;
+        end
+      else if Not (jdoIgnorePropertyErrors in Options) then
+        Raise;
   end;
 end;
 
@@ -367,7 +432,7 @@ begin
     tkFloat :
       begin
       if (TI=TypeInfo(TDateTime)) and (PropData.JSONType=jtString) then
-        SetFloatProp(AObject,PI,StrToDateTime(PropData.AsString))
+        SetFloatProp(AObject,PI,ExtractDateTime(PropData.AsString))
       else
         SetFloatProp(AObject,PI,PropData.AsFloat)
       end;
@@ -435,7 +500,8 @@ begin
   end;
 end;
 
-procedure TJSONDeStreamer.JSONToObject(Const JSON: TJSONObject; AObject: TObject);
+procedure TJSONDeStreamer.JSONToObject(const JSON: TJSONObject; AObject: TObject
+  );
 Var
   I,J : Integer;
   PIL : TPropInfoList;
@@ -516,7 +582,9 @@ begin
   end;
 end;
 
-Function TJSONDeStreamer.GetObject(AInstance : TObject; Const APropName : TJSONStringType; D : TJSONObject; PropInfo : PPropInfo) : TObject;
+function TJSONDeStreamer.GetObject(AInstance: TObject;
+  const APropName: TJSONStringType; D: TJSONObject; PropInfo: PPropInfo
+  ): TObject;
 
 Var
   C : TClass;
@@ -1032,12 +1100,18 @@ begin
     S:=''
   else if (DateTimeFormat<>'') then
     S:=FormatDateTime(DateTimeFormat,DateTime)
-  else if Frac(DateTime)=0 then
-    S:=DateToStr(DateTime)
-  else if Trunc(DateTime)=0 then
-    S:=TimeToStr(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:=DateTimeToStr(DateTime);
+    S:=FormatDateTime(RFC3339DateTimeFormat,DateTime);
+     
   Result:=TJSONString.Create(S);
 end;
 

packages/fcl-json/tests/testjson.lpi

@@ -25,7 +25,7 @@
     <RunParams>
       <local>
         <FormatVersion Value="1"/>
-        <CommandLineParams Value="--suite=TTestParser.TestComment"/>
+        <CommandLineParams Value="--suite=TTestJSONDeStreamer.TestDateTimeFormat"/>
         <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
       </local>
     </RunParams>
@@ -67,6 +67,12 @@
         <UseAnsiStrings Value="False"/>
       </SyntaxOptions>
     </Parsing>
+    <Linking>
+      <Debugging>
+        <UseHeaptrc Value="True"/>
+        <TrashVariables Value="True"/>
+      </Debugging>
+    </Linking>
   </CompilerOptions>
   <Debugging>
     <Exceptions Count="2">

packages/fcl-json/tests/testjson.pp

@@ -17,7 +17,8 @@
 program testjson;
 
 uses
-  Classes, testjsondata, testjsonparser, consoletestrunner; //, testjsonrtti, fpjsonrtti;
+  Classes, testjsondata, testjsonparser, testjsonrtti, consoletestrunner;
+
 type
   { TLazTestRunner }
    TMyTestRunner = class(TTestRunner)
@@ -30,8 +31,7 @@ var
 begin
   DefaultFormat := fPlain;
   DefaultRunAllTests := True;
-
-  Application := TMyTestRunner.Create(nil); 
+  Application := TMyTestRunner.Create(nil);
   Application.Initialize;
   Application.Run;  
   Application.Free;