* Added support for TJSONData.CompressedJSON and TJSONObject.UnquotedElementNames

git-svn-id: trunk@28797 -

packages/fcl-json/src/fpjson.pp

@@ -67,6 +67,12 @@ Type
   { TJSONData }
   
   TJSONData = class(TObject)
+  private
+    Class Var FCompressedJSON : Boolean;
+    Class Var FElementSep : TJSONStringType;
+    class procedure DetermineElementSeparators;
+    class function GetCompressedJSON: Boolean; static;
+    class procedure SetCompressedJSON(AValue: Boolean); static;
   protected
     Class Procedure DoError(Const Msg : String);
     Class Procedure DoError(Const Fmt : String; const Args : Array of const);
@@ -91,9 +97,11 @@ Type
     procedure SetItem(Index : Integer; const AValue: TJSONData); virtual;
     Function DoFormatJSON(Options : TFormatOptions; CurrentIndent, Indent : Integer) : TJSONStringType; virtual;
     function GetCount: Integer; virtual;
+  Public
+    Class function JSONType: TJSONType; virtual;
+    Class Property CompressedJSON : Boolean Read GetCompressedJSON Write SetCompressedJSON;
   public
     Constructor Create; virtual;
-    Class function JSONType: TJSONType; virtual;
     Procedure Clear;  virtual; Abstract;
     // Get enumerator
     function GetEnumerator: TBaseJSONEnumerator; virtual;
@@ -434,6 +442,10 @@ Type
 
   TJSONObject = class(TJSONData)
   private
+    Class var FUnquotedElementNames: Boolean;
+    Class var FObjStartSep,FObjEndSep,FElementEnd,FElementStart : TJSONStringType;
+    Class procedure DetermineElementQuotes;
+  Private
     FHash : TFPHashObjectList; // Careful : Names limited to 255 chars.
     function GetArrays(const AName : String): TJSONArray;
     function GetBooleans(const AName : String): Boolean;
@@ -457,6 +469,8 @@ Type
     procedure SetObjects(const AName : String; const AValue: TJSONObject);
     procedure SetQWords(AName : String; AValue: QWord);
     procedure SetStrings(const AName : String; const AValue: TJSONStringType);
+    class function GetUnquotedElementNames: Boolean; static;
+    class procedure SetUnquotedElementNames(AValue: Boolean); static;
   protected
     Function DoFindPath(Const APath : TJSONStringType; Out NotFound : TJSONStringType) : TJSONdata; override;
     Procedure Converterror(From : Boolean);
@@ -464,10 +478,12 @@ Type
     function GetAsFloat: TJSONFloat; override;
     function GetAsInteger: Integer; override;
     function GetAsInt64: Int64; override;
+    function GetAsQWord: QWord; override;
     procedure SetAsBoolean(const AValue: Boolean); override;
     procedure SetAsFloat(const AValue: TJSONFloat); override;
     procedure SetAsInteger(const AValue: Integer); override;
     procedure SetAsInt64(const AValue: Int64); override;
+    procedure SetAsQword(const AValue: QWord); override;
     function GetAsJSON: TJSONStringType; override;
     function GetAsString: TJSONStringType; override;
     procedure SetAsString(const AValue: TJSONStringType); override;
@@ -482,6 +498,7 @@ Type
     Constructor Create(const Elements : Array of Const); overload;
     destructor Destroy; override;
     class function JSONType: TJSONType; override;
+    Class Property UnquotedElementNames : Boolean Read GetUnquotedElementNames Write SetUnquotedElementNames;
     Function Clone : TJSONData; override;
     function GetEnumerator: TBaseJSONEnumerator; override;
     // Examine
@@ -994,12 +1011,37 @@ begin
   Clear;
 end;
 
+class function TJSONData.GetCompressedJSON: Boolean; static;
+begin
+  Result:=FCompressedJSON;
+end;
+
+class procedure TJSONData.DetermineElementSeparators;
+
+Const
+  ElementSeps  : Array[Boolean] of TJSONStringType = (', ',',');
+
+begin
+  FElementSep:=ElementSeps[FCompressedJSON];
+end;
+
+class procedure TJSONData.SetCompressedJSON(AValue: Boolean); static;
+
+
+begin
+  if AValue=FCompressedJSON then exit;
+  FCompressedJSON:=AValue;
+  DetermineElementSeparators;
+  TJSONObject.DetermineElementQuotes;
+end;
+
 class procedure TJSONData.DoError(const Msg: String);
 begin
   Raise EJSON.Create(Msg);
 end;
 
-class procedure TJSONData.DoError(const Fmt: String; Const Args: array of const);
+class procedure TJSONData.DoError(const Fmt: String;
+  const Args: array of const);
 begin
   Raise EJSON.CreateFmt(Fmt,Args);
 end;
@@ -1886,18 +1928,21 @@ end;
 
 {$warnings on}
 
+
 function TJSONArray.GetAsJSON: TJSONStringType;
 
 Var
   I : Integer;
+  Sep : String;
 
 begin
+  Sep:=TJSONData.FElementSep;
   Result:='[';
   For I:=0 to Count-1 do
     begin
     Result:=Result+Items[i].AsJSON;
     If (I<Count-1) then
-      Result:=Result+', '
+      Result:=Result+Sep;
     end;
   Result:=Result+']';
 end;
@@ -2292,6 +2337,11 @@ begin
   Result:=Getelements(Aname).JSONType;
 end;
 
+class function TJSONObject.GetUnquotedElementNames: Boolean; static;
+begin
+  Result:=FUnquotedElementNames;
+end;
+
 procedure TJSONObject.SetArrays(const AName : String; const AValue: TJSONArray);
 
 begin
@@ -2352,6 +2402,33 @@ begin
   SetElements(AName,CreateJSON(AVAlue));
 end;
 
+class procedure TJSONObject.DetermineElementQuotes;
+
+Const
+  ElementStart   : Array[Boolean] of TJSONStringType = ('"','');
+  SpacedQuoted   : Array[Boolean] of TJSONStringType = ('" : ',' : ');
+  UnSpacedQuoted : Array[Boolean] of TJSONStringType = ('":',':');
+  ObjStartSeps   : Array[Boolean] of TJSONStringType = ('{ ','{');
+  ObjEndSeps     : Array[Boolean] of TJSONStringType = (' }','}');
+
+begin
+  FObjStartSep:=ObjStartSeps[TJSONData.FCompressedJSON];
+  FObjEndSep:=ObjEndSeps[TJSONData.FCompressedJSON];
+  if TJSONData.FCompressedJSON then
+    FElementEnd:=UnSpacedQuoted[FUnquotedElementNames]
+  else
+    FElementEnd:=SpacedQuoted[FUnquotedElementNames];
+  FElementStart:=ElementStart[FUnquotedElementNames]
+end;
+
+class procedure TJSONObject.SetUnquotedElementNames(AValue: Boolean); static;
+
+begin
+  if FUnquotedElementNames=AValue then exit;
+  FUnquotedElementNames:=AValue;
+  DetermineElementQuotes;
+end;
+
 function TJSONObject.DoFindPath(const APath: TJSONStringType; out
   NotFound: TJSONStringType): TJSONdata;
 
@@ -2415,6 +2492,11 @@ begin
   ConvertError(True);
 end;
 
+function TJSONObject.GetAsQWord: QWord;
+begin
+  ConvertError(True);
+end;
+
 procedure TJSONObject.SetAsBoolean(const AValue: Boolean);
 begin
   ConvertError(False);
@@ -2434,23 +2516,32 @@ procedure TJSONObject.SetAsInt64(const AValue: Int64);
 begin
   ConvertError(False);
 end;
+
+procedure TJSONObject.SetAsQword(const AValue: QWord);
+begin
+  ConvertError(False);
+end;
+
 {$warnings on}
 
 function TJSONObject.GetAsJSON: TJSONStringType;
 
+
 Var
   I : Integer;
+  Sep : String;
 
 begin
+  Sep:=TJSONData.FElementSep;
   Result:='';
   For I:=0 to Count-1 do
     begin
     If (Result<>'') then
-      Result:=Result+', ';
-    Result:=Result+'"'+StringToJSONString(Names[i])+'" : '+Items[I].AsJSON;
+      Result:=Result+Sep;
+    Result:=Result+FElementStart+StringToJSONString(Names[i])+FElementEnd+Items[I].AsJSON;
     end;
   If (Result<>'') then
-    Result:='{ '+Result+' }'
+    Result:=FObjStartSep+Result+FObjEndSep
   else
     Result:='{}';
 end;
@@ -2867,5 +2958,9 @@ begin
     Result:=Nil;
 end;
 
+initialization
+  // Need to force initialization;
+  TJSONData.DetermineElementSeparators;
+  TJSONObject.DetermineElementQuotes;
 end.
 

packages/fcl-json/tests/testjson.lpi

@@ -24,7 +24,6 @@
     <RunParams>
       <local>
         <FormatVersion Value="1"/>
-        <CommandLineParams Value="--suite=TTestParser.TestErrors"/>
         <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
       </local>
     </RunParams>
@@ -80,11 +79,6 @@
         <UseAnsiStrings Value="False"/>
       </SyntaxOptions>
     </Parsing>
-    <Linking>
-      <Debugging>
-        <UseHeaptrc Value="True"/>
-      </Debugging>
-    </Linking>
     <Other>
       <CompilerMessages>
         <UseMsgFile Value="True"/>
@@ -92,4 +86,14 @@
       <CompilerPath Value="$(CompPath)"/>
     </Other>
   </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="2">
+      <Item1>
+        <Name Value="EConvertError"/>
+      </Item1>
+      <Item2>
+        <Name Value="EJSON"/>
+      </Item2>
+    </Exceptions>
+  </Debugging>
 </CONFIG>

packages/fcl-json/tests/testjsondata.pp

@@ -168,6 +168,7 @@ type
     Procedure TestCreateString;
     Procedure TestCreatePchar;
     procedure TestCreateStrings;
+    procedure TestCreateStringsCompressed;
     procedure TestCreateInteger;
     procedure TestCreateInt64;
     procedure TestCreateFloat;
@@ -213,15 +214,25 @@ type
   published
     Procedure TestCreate;
     Procedure TestCreateString;
+    Procedure TestCreateStringUnquoted;
     Procedure TestCreatePchar;
+    Procedure TestCreatePcharUnquoted;
     procedure TestCreateStrings;
+    procedure TestCreateStringsCompressed;
+    procedure TestCreateStringsCompressedUnquoted;
     procedure TestCreateInteger;
+    procedure TestCreateIntegerUnquoted;
     procedure TestCreateInt64;
+    procedure TestCreateInt64Unquoted;
     procedure TestCreateFloat;
+    procedure TestCreateFloatUnquoted;
     procedure TestCreateBoolean;
+    procedure TestCreateBooleanUnquoted;
     procedure TestCreateObject;
     procedure TestCreateJSONString;
+    procedure TestCreateJSONStringUnquoted;
     procedure TestCreateJSONObject;
+    procedure TestCreateJSONObjectUnquoted;
     procedure TestCreateNilPointer;
     procedure TestCreatePointer;
     procedure TestAddInteger;
@@ -1042,6 +1053,8 @@ Procedure TTestJSON.SetUp;
 begin
   inherited SetUp;
   SetDefaultInstanceTypes;
+  TJSONData.CompressedJSON:=False;
+  TJSONObject.UnquotedElementNames:=False;
 end;
 
 Procedure TTestJSON.TestItemCount(J: TJSONData; Expected: Integer);
@@ -2183,6 +2196,29 @@ begin
   end;
 end;
 
+procedure TTestArray.TestCreateStringsCompressed;
+Const
+  S = 'A string';
+  T = 'B string';
+
+Var
+  J : TJSONArray;
+
+begin
+  TJSONData.CompressedJSON:=True;
+  J:=TJSONArray.Create([S,T]);
+  try
+    TestJSONType(J,jtArray);
+    TestItemCount(J,2);
+    TestJSONType(J[0],jtString);
+    TestJSONType(J[1],jtString);
+    TestJSON(J,'["'+S+'","'+T+'"]');
+    TestIsNull(J,False);
+  finally
+    FreeAndNil(J);
+  end;
+end;
+
 procedure TTestArray.TestCreateInteger;
 
 Const
@@ -3472,6 +3508,28 @@ begin
   end;
 end;
 
+procedure TTestObject.TestCreateStringUnquoted;
+Const
+  A = 'A';
+  S = 'A string';
+
+Var
+  J : TJSONObject;
+
+begin
+  TJSONObject.UnquotedElementNames:=True;
+  J:=TJSONObject.Create([A,S]);
+  try
+    TestJSONType(J,jtObject);
+    TestItemCount(J,1);
+    TestJSONType(J[A],jtString);
+    TestJSON(J,'{ A : "'+S+'" }');
+    TestIsNull(J,False);
+  finally
+    FreeAndNil(J);
+  end;
+end;
+
 procedure TTestObject.TestCreatePchar;
 
 Const
@@ -3494,6 +3552,29 @@ begin
   end;
 end;
 
+procedure TTestObject.TestCreatePcharUnquoted;
+
+Const
+  A = 'A';
+  S = 'A string';
+
+Var
+  J : TJSONObject;
+
+begin
+  TJSONObject.UnquotedElementNames:=True;
+  J:=TJSONObject.Create([A,Pchar(S)]);
+  try
+    TestJSONType(J,jtObject);
+    TestItemCount(J,1);
+    TestJSONType(J[A],jtString);
+    TestJSON(J,'{ A : "'+S+'" }');
+    TestIsNull(J,False);
+  finally
+    FreeAndNil(J);
+  end;
+end;
+
 procedure TTestObject.TestCreateStrings;
 
 Const
@@ -3519,6 +3600,59 @@ begin
   end;
 end;
 
+procedure TTestObject.TestCreateStringsCompressed;
+
+Const
+  A = 'A';
+  B = 'B';
+  S = 'A string';
+  T = 'B string';
+
+Var
+  J : TJSONObject;
+
+begin
+  TJSONData.CompressedJSON:=True;
+  J:=TJSONObject.Create([A,S,B,T]);
+  try
+    TestJSONType(J,jtObject);
+    TestItemCount(J,2);
+    TestJSONType(J[A],jtString);
+    TestJSONType(J[B],jtString);
+    TestJSON(J,'{"A":"'+S+'","B":"'+T+'"}');
+    TestIsNull(J,False);
+  finally
+    FreeAndNil(J);
+  end;
+end;
+
+procedure TTestObject.TestCreateStringsCompressedUnquoted;
+
+Const
+  A = 'A';
+  B = 'B';
+  S = 'A string';
+  T = 'B string';
+
+Var
+  J : TJSONObject;
+
+begin
+  TJSONData.CompressedJSON:=True;
+  TJSONObject.UnquotedElementNames:=True;
+  J:=TJSONObject.Create([A,S,B,T]);
+  try
+    TestJSONType(J,jtObject);
+    TestItemCount(J,2);
+    TestJSONType(J[A],jtString);
+    TestJSONType(J[B],jtString);
+    TestJSON(J,'{A:"'+S+'",B:"'+T+'"}');
+    TestIsNull(J,False);
+  finally
+    FreeAndNil(J);
+  end;
+end;
+
 procedure TTestObject.TestCreateInteger;
 
 Const
@@ -3540,6 +3674,27 @@ begin
   end;
 end;
 
+procedure TTestObject.TestCreateIntegerUnquoted;
+Const
+  A = 'A';
+  S = 3;
+
+Var
+  J : TJSONObject;
+
+begin
+  TJSONObject.UnquotedElementNames:=True;
+  J:=TJSONObject.Create([A,S]);
+  try
+    TestJSONType(J,jtObject);
+    TestItemCount(J,1);
+    TestJSONType(J[A],jtNumber);
+    TestJSON(J,'{ A : 3 }');
+  finally
+    FreeAndNil(J);
+  end;
+end;
+
 procedure TTestObject.TestCreateFloat;
 
 Const
@@ -3563,6 +3718,29 @@ begin
   end;
 end;
 
+procedure TTestObject.TestCreateFloatUnquoted;
+Const
+  A = 'A';
+  S : double = 1.2;
+
+Var
+  J : TJSONObject;
+  r : String;
+
+begin
+  TJSONObject.UnquotedElementNames:=True;
+  J:=TJSONObject.Create([A,S]);
+  try
+    TestJSONType(J,jtObject);
+    TestItemCount(J,1);
+    TestJSONType(J[A],jtNumber);
+    Str(S,R);
+    TestJSON(J,'{ A :'+R+' }');
+  finally
+    FreeAndNil(J);
+  end;
+end;
+
 procedure TTestObject.TestCreateInt64;
 
 Const
@@ -3584,6 +3762,27 @@ begin
   end;
 end;
 
+procedure TTestObject.TestCreateInt64Unquoted;
+Const
+  A = 'A';
+  S : Int64 = $FFFFFFFFFFFFF;
+
+Var
+  J : TJSONObject;
+
+begin
+  TJSONObject.UnquotedElementNames:=True;
+  J:=TJSONObject.Create([A,S]);
+  try
+    TestJSONType(J,jtObject);
+    TestItemCount(J,1);
+    TestJSONType(J[A],jtNumber);
+    TestJSON(J,'{ A : '+IntToStr(S)+' }');
+  finally
+    FreeAndNil(J);
+  end;
+end;
+
 procedure TTestObject.TestCreateBoolean;
 
 Const
@@ -3605,6 +3804,27 @@ begin
   end;
 end;
 
+procedure TTestObject.TestCreateBooleanUnquoted;
+Const
+  A = 'A';
+  S = True;
+
+Var
+  J : TJSONObject;
+
+begin
+  TJSONObject.UnquotedElementNames:=True;
+  J:=TJSONObject.Create([A,S]);
+  try
+    TestJSONType(J,jtObject);
+    TestItemCount(J,1);
+    TestJSONType(J[A],jtBoolean);
+    TestJSON(J,'{ A : true }');
+  finally
+    FreeAndNil(J);
+  end;
+end;
+
 procedure TTestObject.TestCreateJSONObject;
 
 Const
@@ -3623,6 +3843,26 @@ begin
     FreeAndNil(J);
   end;
 end;
+
+procedure TTestObject.TestCreateJSONObjectUnquoted;
+Const
+  A = 'A';
+
+Var
+  J : TJSONObject;
+
+begin
+  TJSONObject.UnquotedElementNames:=True;
+  J:=TJSONObject.Create([A,TJSONObject.Create]);
+  try
+    TestItemCount(J,1);
+    TestJSONType(J[A],jtObject);
+    TestJSON(J,'{ A : {} }');
+  finally
+    FreeAndNil(J);
+  end;
+end;
+
 procedure TTestObject.TestCreateJSONString;
 
 Const
@@ -3643,6 +3883,27 @@ begin
   end;
 end;
 
+procedure TTestObject.TestCreateJSONStringUnquoted;
+
+Const
+  A = 'A';
+  S = 'A string';
+
+Var
+  J : TJSONObject;
+
+begin
+  TJSONObject.UnquotedElementNames:=True;
+  J:=TJSONObject.Create([A,TJSONString.Create(S)]);
+  try
+    TestItemCount(J,1);
+    TestJSONType(J[A],jtString);
+    TestJSON(J,'{ A : "'+S+'" }');
+  finally
+    FreeAndNil(J);
+  end;
+end;
+
 procedure TTestObject.TestCreateObject;
 
 Const