* JSON parser handler

git-svn-id: trunk@25693 -

packages/fcl-json/src/fpjson.pp

@@ -456,6 +456,8 @@ Type
 
   EJSON = Class(Exception);
 
+  TJSONParserHandler = Procedure(AStream : TStream; Const AUseUTF8 : Boolean; Out Data : TJSONData);
+
 Procedure SetJSONInstanceType(AType : TJSONInstanceType; AClass : TJSONDataClass);
 Function GetJSONInstanceType(AType : TJSONInstanceType) : TJSONDataClass;
 
@@ -463,6 +465,7 @@ Function StringToJSONString(const S : TJSONStringType) : TJSONStringType;
 Function JSONStringToString(const S : TJSONStringType) : TJSONStringType;
 Function JSONTypeName(JSONType : TJSONType) : String;
 
+// These functions create JSONData structures, taking into account the instance types
 Function CreateJSON : TJSONNull;
 Function CreateJSON(Data : Boolean) : TJSONBoolean;
 Function CreateJSON(Data : Integer) : TJSONIntegerNumber;
@@ -472,6 +475,13 @@ Function CreateJSON(Data : TJSONStringType) : TJSONString;
 Function CreateJSONArray(Data : Array of const) : TJSONArray;
 Function CreateJSONObject(Data : Array of const) : TJSONObject;
 
+// These functions rely on a callback. If the callback is not set, they will raise an error.
+// When the jsonparser unit is included in the project, the callback is automatically set.
+Function GetJSON(Const JSON : TJSONStringType; Const UseUTF8 : Boolean = True) : TJSONData;
+Function GetJSON(Const JSON : TStream; Const UseUTF8 : Boolean = True) : TJSONData;
+Procedure SetJSONParserHandler(AHandler : TJSONParserHandler);
+Function GetJSONParserHandler : TJSONParserHandler;
+
 implementation
 
 Uses typinfo;
@@ -496,6 +506,7 @@ Resourcestring
   SErrNonexistentElement = 'Unknown object member: "%s"';
   SErrPathElementNotFound = 'Path "%s" invalid: element "%s" not found.';
   SErrWrongInstanceClass = 'Cannot set instance class: %s does not descend from %s.';
+  SErrNoParserHandler = 'No JSON parser handler installed. Recompile your project with the jsonparser unit included';
 
 Var
   DefaultJSONInstanceTypes :
@@ -648,6 +659,41 @@ begin
   Result:=TJSONObjectCLass(DefaultJSONInstanceTypes[jitObject]).Create(Data);
 end;
 
+Var
+  JPH : TJSONParserHandler;
+
+function GetJSON(const JSON: TJSONStringType; Const UseUTF8: Boolean): TJSONData;
+
+Var
+  SS : TStringStream;
+begin
+  SS:=TStringStream.Create(JSON);
+  try
+    Result:=GetJSON(SS,UseUTF8);
+  finally
+    SS.Free;
+  end;
+end;
+
+function GetJSON(Const JSON: TStream; Const UseUTF8: Boolean): TJSONData;
+
+begin
+  Result:=Nil;
+  If (JPH=Nil) then
+    TJSONData.DoError(SErrNoParserHandler);
+  JPH(JSON,UseUTF8,Result);
+end;
+
+procedure SetJSONParserHandler(AHandler: TJSONParserHandler);
+begin
+  JPH:=AHandler;
+end;
+
+function GetJSONParserHandler: TJSONParserHandler;
+begin
+  Result:=JPH;
+end;
+
 
 
 { TJSONData }

packages/fcl-json/src/jsonparser.pp

@@ -71,6 +71,22 @@ Resourcestring
   
 { TJSONParser }
 
+procedure DefJSONParserHandler(AStream: TStream; const AUseUTF8: Boolean; out
+  Data: TJSONData);
+
+Var
+  P : TJSONParser;
+
+begin
+  Data:=Nil;
+  P:=TJSONParser.Create(AStream,AUseUTF8);
+  try
+    Data:=P.Parse;
+  finally
+    P.Free;
+  end;
+end;
+
 Function TJSONParser.Parse : TJSONData;
 
 begin
@@ -299,5 +315,23 @@ begin
   inherited Destroy();
 end;
 
+Procedure InitJSONHandler;
+
+begin
+  if GetJSONParserHandler=Nil then
+    SetJSONParserHandler(@DefJSONParserHandler);
+end;
+
+Procedure DoneJSONHandler;
+
+begin
+  if GetJSONParserHandler=@DefJSONParserHandler then
+    SetJSONParserHandler(Nil);
+end;
+
+initialization
+  InitJSONHandler;
+finalization
+  DoneJSONHandler;
 end.
 

packages/fcl-json/tests/testjsonparser.pp

@@ -26,8 +26,9 @@ type
 
   { TTestParser }
 
-  TTestParser= class(TTestJSON)
+  TTestParser = class(TTestJSON)
   private
+    procedure CallNoHandlerStream;
     procedure DoTestError(S: String);
     procedure DoTestFloat(F: TJSONFloat); overload;
     procedure DoTestFloat(F: TJSONFloat; S: String); overload;
@@ -35,6 +36,7 @@ type
     procedure DoTestString(S : String);
     procedure DoTestArray(S: String; ACount: Integer);
     Procedure DoTestClass(S : String; AClass : TJSONDataClass);
+    procedure CallNoHandler;
   published
     procedure TestEmpty;
     procedure TestNull;
@@ -49,6 +51,10 @@ type
     procedure TestMixed;
     procedure TestErrors;
     Procedure TestClasses;
+    Procedure TestHandler;
+    Procedure TestNoHandlerError;
+    Procedure TestHandlerResult;
+    Procedure TestHandlerResultStream;
   end;
 
 implementation
@@ -367,6 +373,80 @@ begin
   DoTestClass('[]',TMyArray);
 end;
 
+procedure TTestParser.CallNoHandler;
+
+begin
+  GetJSON('1',True).Free;
+end;
+
+procedure TTestParser.CallNoHandlerStream;
+
+Var
+  S : TStringStream;
+
+begin
+  S:=TstringStream.Create('1');
+  try
+    GetJSON(S,True).Free;
+  finally
+    S.Free;
+  end;
+end;
+
+procedure TTestParser.TestHandler;
+begin
+  AssertNotNull('Handler installed',GetJSONParserHandler);
+end;
+
+procedure TTestParser.TestNoHandlerError;
+
+Var
+  H : TJSONParserHandler;
+
+begin
+  H:=GetJSONParserHandler;
+  try
+    SetJSONParserHandler(Nil);
+    AssertException('No handler raises exception',EJSON,@CallNoHandler);
+    AssertException('No handler raises exception',EJSON,@CallNoHandlerStream);
+  finally
+    SetJSONParserHandler(H);
+  end;
+end;
+
+procedure TTestParser.TestHandlerResult;
+
+Var
+  D : TJSONData;
+
+begin
+  D:=GetJSON('"123"');
+  try
+    AssertEquals('Have correct string','123',D.AsString);
+  finally
+    D.Free;
+  end;
+end;
+
+procedure TTestParser.TestHandlerResultStream;
+Var
+  D : TJSONData;
+  S : TStream;
+
+begin
+  S:=TStringStream.Create('"123"');
+  try
+    D:=GetJSON(S);
+    try
+      AssertEquals('Have correct string','123',D.AsString);
+    finally
+      D.Free;
+    end;
+  finally
+    S.Free;
+  end;
+end;
+
 procedure TTestParser.DoTestError(S : String);
 
 Var