paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-19 00:09:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Initial implementation

Browse Source 
git-svn-id: trunk@8522 -
This commit is contained in:
michael 2007-09-17 19:01:12 +00:00
parent 05092f01f5
commit f83d92c9a0
10 changed files with 7097 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
.gitattributes vendored
View File

@ -4262,6 +4262,15 @@ packages/fcl-image/src/pixtools.pp svneol=native#text/plain
packages/fcl-image/src/pngcomn.pp svneol=native#text/plain packages/fcl-image/src/pngcomn.pp svneol=native#text/plain
packages/fcl-image/src/pscanvas.pp svneol=native#text/plain packages/fcl-image/src/pscanvas.pp svneol=native#text/plain
packages/fcl-image/src/targacmn.pp svneol=native#text/plain packages/fcl-image/src/targacmn.pp svneol=native#text/plain
packages/fcl-json/Makefile svneol=native#text/plain
packages/fcl-json/Makefile.fpc svneol=native#text/plain
packages/fcl-json/src/fpjson.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/testjson.lpi svneol=native#text/plain
packages/fcl-json/tests/testjson.pp svneol=native#text/plain
packages/fcl-json/tests/testjsondata.pp svneol=native#text/plain
packages/fcl-json/tests/testjsonparser.pp svneol=native#text/plain
packages/fcl-net/Makefile svneol=native#text/plain packages/fcl-net/Makefile svneol=native#text/plain
packages/fcl-net/Makefile.fpc svneol=native#text/plain packages/fcl-net/Makefile.fpc svneol=native#text/plain
packages/fcl-net/src/fpmake.inc svneol=native#text/plain packages/fcl-net/src/fpmake.inc svneol=native#text/plain

2783
packages/fcl-json/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

29
packages/fcl-json/Makefile.fpc Normal file
View File

@ -0,0 +1,29 @@
#
# Makefile.fpc for XML for FCL
#
[package]
name=fcl-json
version=2.2.0
[target]
units=fpjson jsonscanner jsonparser
rsts=fpjson jsonscanner jsonparser
[require]
packages=fcl-base
[compiler]
options=-S2h
sourcedir=src
[install]
fpcpackage=y
[default]
fpcdir=../..
[rules]
.NOTPARALLEL:
jsonparser$(PPUEXT): jsonparser.pp fpjson$(PPUEXT) jsonscanner$(PPUEXT)

1448
packages/fcl-json/src/fpjson.pp Normal file
View File

File diff suppressed because it is too large Load Diff

237
packages/fcl-json/src/jsonparser.pp Normal file
View File

@ -0,0 +1,237 @@
unit jsonparser;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpJSON, jsonscanner;
Type
{ TJSONParser }
TJSONParser = Class(TObject)
Private
FScanner : TJSONScanner;
function ParseNumber: TJSONNumber;
Protected
procedure DoError(Msg: String);
function DoParse(AtCurrent,AllowEOF: Boolean): TJSONData;
function GetNextToken: TJSONToken;
function CurrentTokenString: String;
function CurrentToken: TJSONToken;
function ParseArray: TJSONArray;
function ParseObject: TJSONObject;
Public
function Parse: TJSONData;
Constructor Create(Source : TStream); overload;
Constructor Create(Source : TJSONStringType); overload;
end;
EJSONScanner = Class(Exception);
implementation
Resourcestring
SErrUnexpectedEOF = 'Unexpected EOF encountered.';
SErrUnexpectedToken = 'Unexpected token (%s) encountered.';
SErrExpectedColon = 'Expected colon (:), got token "%s".';
SErrUnexpectedComma = 'Invalid comma encountered.';
SErrEmptyElement = 'Empty element encountered.';
SErrExpectedElementName = 'Expected element name, got token "%s"';
SExpectedCommaorBraceClose = 'Expected , or ], got token "%s".';
SErrInvalidNumber = 'Number is not an integer or real number: %s';
{ TJSONParser }
Function TJSONParser.Parse : TJSONData;
begin
Result:=DoParse(False,True);
end;
{
Consume next token and convert to JSON data structure.
If AtCurrent is true, the current token is used. If false,
a token is gotten from the scanner.
If AllowEOF is false, encountering a tkEOF will result in an exception.
}
Function TJSONParser.CurrentToken : TJSONToken;
begin
Result:=FScanner.CurToken;
end;
Function TJSONParser.CurrentTokenString : String;
begin
If CurrentToken in [tkString,tkNumber] then
Result:=FScanner.CurTokenString
else
Result:=TokenInfos[CurrentToken];
end;
Function TJSONParser.DoParse(AtCurrent,AllowEOF : Boolean) : TJSONData;
var
T : TJSONToken;
begin
Result:=nil;
try
If not AtCurrent then
T:=GetNextToken
else
T:=FScanner.CurToken;
Case T of
tkEof : If Not AllowEof then
DoError(SErrUnexpectedEOF);
tkNull : Result:=TJSONNull.Create;
tkTrue,
tkFalse : Result:=TJSONBoolean.Create(t=tkTrue);
tkString : Result:=TJSONString.Create(CurrentTokenString);
tkCurlyBraceOpen : Result:=ParseObject;
tkCurlyBraceClose : DoError(SErrUnexpectedToken);
tkSQuaredBraceOpen : Result:=ParseArray;
tkSQuaredBraceClose : DoError(SErrUnexpectedToken);
tkNumber : Result:=ParseNumber;
tkComma : DoError(SErrUnexpectedToken);
end;
except
if assigned(Result) then
FreeAndNil(Result);
Raise;
end;
end;
// Creates the correct JSON number type, based on the current token.
Function TJSONParser.ParseNumber : TJSONNumber;
Var
I : Integer;
F : TJSONFloat;
S : String;
begin
S:=CurrentTokenString;
I:=0;
If TryStrToInt(S,I) then
Result:=TJSONIntegerNumber.Create(I)
else
begin
I:=0;
Val(S,F,I);
If (I<>0) then
DoError(SErrInvalidNumber);
Result:=TJSONFloatNumber.Create(F);
end;
end;
// Current token is {, on exit current token is }
Function TJSONParser.ParseObject : TJSONObject;
Var
T : TJSONtoken;
E : TJSONData;
N : String;
begin
Result:=TJSONObject.Create;
Try
T:=GetNextToken;
While T<>tkCurlyBraceClose do
begin
If T<>tkString then
DoError(SErrExpectedElementName);
N:=CurrentTokenString;
T:=GetNextToken;
If (T<>tkColon) then
DoError(SErrExpectedColon);
Writeln('Getting element');
E:=DoParse(False,False);
Result.Add(N,E);
T:=GetNextToken;
If Not (T in [tkComma,tkCurlyBraceClose]) then
DoError(SExpectedCommaorBraceClose);
If T=tkComma then
T:=GetNextToken;
end;
Except
FreeAndNil(Result);
Raise;
end;
end;
// Current token is [, on exit current token is ]
Function TJSONParser.ParseArray : TJSONArray;
Var
T : TJSONtoken;
E : TJSONData;
LastComma : Boolean;
begin
Result:=TJSONArray.Create;
LastComma:=False;
Try
Repeat
T:=GetNextToken;
If (T<>tkSquaredBraceClose) then
begin
E:=DoParse(True,False);
If (E<>Nil) then
Result.Add(E)
else if (Result.Count>0) then
DoError(SErrEmptyElement);
T:=GetNextToken;
If Not (T in [tkComma,tkSquaredBraceClose]) then
DoError(SExpectedCommaorBraceClose);
LastComma:=(t=TkComma);
end;
Until (T=tkSquaredBraceClose);
If LastComma then // Test for ,] case
DoError(SErrUnExpectedToken);
Except
FreeAndNil(Result);
Raise;
end;
end;
// Get next token, discarding whitespace
Function TJSONParser.GetNextToken : TJSONToken ;
begin
Repeat
Result:=FScanner.FetchToken;
Until (Result<>tkWhiteSpace);
Writeln('GetNextToken : ',CurrentTokenString);
end;
Procedure TJSONParser.DoError(Msg : String);
Var
S : String;
begin
S:=Format(Msg,[CurrentTokenString]);
S:=Format('Error at line %d, Pos %d:',[FScanner.CurRow,FSCanner.CurColumn])+S;
Raise EJSONScanner.Create(S);
end;
constructor TJSONParser.Create(Source: TStream);
begin
Inherited Create;
FScanner:=TJSONScanner.Create(Source);
end;
constructor TJSONParser.Create(Source: TJSONStringType);
begin
Inherited Create;
FScanner:=TJSONScanner.Create(Source);
end;
end.

355
packages/fcl-json/src/jsonscanner.pp Normal file
View File

@ -0,0 +1,355 @@
{
This file is part of the Free Component Library
JSON source lexical scanner
Copyright (c) 2007 by Michael Van Canneyt michael@freepascal.org
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}
{$h+}
unit jsonscanner;
interface
uses SysUtils, Classes;
resourcestring
SErrInvalidCharacter = 'Invalid character ''%s''';
SErrOpenString = 'string exceeds end of line';
type
TJSONToken = (
tkEOF,
tkWhitespace,
tkString,
tkNumber,
tkTrue,
tkFalse,
tkNull,
// Simple (one-character) tokens
tkComma, // ','
tkColon, // ':'
tkCurlyBraceOpen, // '{'
tkCurlyBraceClose, // '}'
tkSquaredBraceOpen, // '['
tkSquaredBraceClose, // ']'
tkUnknown
);
EScannerError = class(Exception);
TJSONScanner = class
private
FSource : TStringList;
FCurRow: Integer;
FCurToken: TJSONToken;
FCurTokenString: string;
FCurLine: string;
TokenStr: PChar;
function GetCurColumn: Integer;
protected
procedure Error(const Msg: string);overload;
procedure Error(const Msg: string; Args: array of Const);overload;
function DoFetchToken: TJSONToken;
public
constructor Create(Source : TStream); overload;
constructor Create(Source : String); overload;
destructor Destroy; override;
function FetchToken: TJSONToken;
property CurLine: string read FCurLine;
property CurRow: Integer read FCurRow;
property CurColumn: Integer read GetCurColumn;
property CurToken: TJSONToken read FCurToken;
property CurTokenString: string read FCurTokenString;
end;
const
TokenInfos: array[TJSONToken] of string = (
'EOF',
'Whitespace',
'String',
'Number',
'True',
'False',
'Null',
',',
':',
'{',
'}',
'[',
']',
''
);
implementation
constructor TJSONScanner.Create(Source : TStream);
begin
FSource:=TStringList.Create;
FSource.LoadFromStream(Source);
end;
constructor TJSONScanner.Create(Source : String);
begin
FSource:=TStringList.Create;
FSource.Text:=Source;
end;
destructor TJSONScanner.Destroy;
begin
FreeAndNil(FSource);
Inherited;
end;
function TJSONScanner.FetchToken: TJSONToken;
begin
Result:=DoFetchToken;
end;
procedure TJSONScanner.Error(const Msg: string);
begin
raise EScannerError.Create(Msg);
end;
procedure TJSONScanner.Error(const Msg: string; Args: array of Const);
begin
raise EScannerError.CreateFmt(Msg, Args);
end;
function TJSONScanner.DoFetchToken: TJSONToken;
function FetchLine: Boolean;
begin
Result:=FCurRow<FSource.Count;
if Result then
begin
FCurLine:=FSource[FCurRow];
TokenStr:=PChar(FCurLine);
Inc(FCurRow);
end
else
begin
FCurLine:='';
TokenStr:=nil;
end;
end;
var
TokenStart, CurPos: PChar;
it : TJSONToken;
I : Integer;
OldLength, SectionLength, Index: Integer;
S : String;
begin
if TokenStr = nil then
if not FetchLine then
begin
Result := tkEOF;
FCurToken := Result;
exit;
end;
FCurTokenString := '';
case TokenStr[0] of
#0: // Empty line
begin
FetchLine;
Result := tkWhitespace;
end;
#9, ' ':
begin
Result := tkWhitespace;
repeat
Inc(TokenStr);
if TokenStr[0] = #0 then
if not FetchLine then
begin
FCurToken := Result;
exit;
end;
until not (TokenStr[0] in [#9, ' ']);
end;
'"':
begin
Inc(TokenStr);
TokenStart := TokenStr;
OldLength := 0;
FCurTokenString := '';
while not (TokenStr[0] in [#0,'"']) do
begin
if (TokenStr[0]='\') then
begin
// Save length
SectionLength := TokenStr - TokenStart;
Inc(TokenStr);
// Read escaped token
Case TokenStr[0] of
'"' : S:='"';
't' : S:=#9;
'b' : S:=#8;
'n' : S:=#10;
'r' : S:=#13;
'f' : S:=#12;
'\' : S:='\';
'/' : S:='/';
'u' : begin
S:='0000';
For I:=1 to 4 do
begin
Inc(TokenStr);
Case TokenStr[0] of
'0'..'9','A'..'F','a'..'f' :
S[i]:=Upcase(TokenStr[0]);
else
Error(SErrInvalidCharacter, [TokenStr[0]]);
end;
end;
// Takes care of conversion...
S:=WideChar(StrToInt('$'+S));
end;
#0 : Error(SErrOpenString);
else
Error(SErrInvalidCharacter, [TokenStr[0]]);
end;
SetLength(FCurTokenString, OldLength + SectionLength+1+Length(S));
if SectionLength > 0 then
Move(TokenStart^, FCurTokenString[OldLength + 1], SectionLength);
Move(S[1],FCurTokenString[OldLength + SectionLength+1],Length(S));
Inc(OldLength, SectionLength+Length(S));
// Next char
// Inc(TokenStr);
TokenStart := TokenStr+1;
end;
if TokenStr[0] = #0 then
Error(SErrOpenString);
Inc(TokenStr);
end;
if TokenStr[0] = #0 then
Error(SErrOpenString);
SectionLength := TokenStr - TokenStart;
SetLength(FCurTokenString, OldLength + SectionLength);
if SectionLength > 0 then
Move(TokenStart^, FCurTokenString[OldLength + 1], SectionLength);
Inc(TokenStr);
Result := tkString;
end;
',':
begin
Inc(TokenStr);
Result := tkComma;
end;
'0'..'9','-':
begin
TokenStart := TokenStr;
while true do
begin
Inc(TokenStr);
case TokenStr[0] of
'.':
begin
if TokenStr[1] in ['0'..'9', 'e', 'E'] then
begin
Inc(TokenStr);
repeat
Inc(TokenStr);
until not (TokenStr[0] in ['0'..'9', 'e', 'E','-','+']);
end;
break;
end;
'0'..'9': ;
'e', 'E':
begin
Inc(TokenStr);
if TokenStr[0] in ['-','+'] then
Inc(TokenStr);
while TokenStr[0] in ['0'..'9'] do
Inc(TokenStr);
break;
end;
else
break;
end;
end;
SectionLength := TokenStr - TokenStart;
SetLength(FCurTokenString, SectionLength);
if SectionLength > 0 then
Move(TokenStart^, FCurTokenString[1], SectionLength);
Result := tkNumber;
end;
':':
begin
Inc(TokenStr);
Result := tkColon;
end;
'{':
begin
Inc(TokenStr);
Result := tkCurlyBraceOpen;
end;
'}':
begin
Inc(TokenStr);
Result := tkCurlyBraceClose;
end;
'[':
begin
Inc(TokenStr);
Result := tkSquaredBraceOpen;
end;
']':
begin
Inc(TokenStr);
Result := tkSquaredBraceClose;
end;
'T','t','F','f','N','n' :
begin
TokenStart := TokenStr;
repeat
Inc(TokenStr);
until not (TokenStr[0] in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
SectionLength := TokenStr - TokenStart;
SetLength(FCurTokenString, SectionLength);
if SectionLength > 0 then
Move(TokenStart^, FCurTokenString[1], SectionLength);
for it := tkTrue to tkNull do
if CompareText(CurTokenString, TokenInfos[it]) = 0 then
begin
Result := it;
FCurToken := Result;
exit;
end;
Error(SErrInvalidCharacter, [TokenStart[0]]);
end;
else
Error(SErrInvalidCharacter, [TokenStr[0]]);
end;
FCurToken := Result;
end;
function TJSONScanner.GetCurColumn: Integer;
begin
Result := TokenStr - PChar(CurLine);
end;
end.

65
packages/fcl-json/tests/testjson.lpi Normal file
View File

@ -0,0 +1,65 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="/"/>
<Version Value="5"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=""/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="3">
<Item1>
<PackageName Value="LCL"/>
</Item1>
<Item2>
<PackageName Value="FPCUnitTestRunner"/>
</Item2>
<Item3>
<PackageName Value="FCL"/>
</Item3>
</RequiredPackages>
<Units Count="3">
<Unit0>
<Filename Value="testjson.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="testjson"/>
</Unit0>
<Unit1>
<Filename Value="testjsonparser.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="testjsonparser"/>
</Unit1>
<Unit2>
<Filename Value="testjsondata.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="testjsondata"/>
</Unit2>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</CONFIG>

21
packages/fcl-json/tests/testjson.pp Normal file
View File

@ -0,0 +1,21 @@
program testjson;
{$mode objfpc}{$H+}
uses
Classes, consoletestrunner, testjsondata, testjsonparser;
type
{ TLazTestRunner }
TMyTestRunner = class(TTestRunner)
protected
// override the protected methods of TTestRunner to customize its behavior
end;
var
Application: TMyTestRunner;
begin
Application := TMyTestRunner.Create(nil);
Application.Initialize;
Application.Run;
Application.Free;
end.

1786
packages/fcl-json/tests/testjsondata.pp Normal file
View File

File diff suppressed because it is too large Load Diff

364
packages/fcl-json/tests/testjsonparser.pp Normal file
View File

@ -0,0 +1,364 @@
unit testjsonparser;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpcunit, testutils, testregistry,fpjson,
jsonParser,testjsondata;
type
{ TTestParser }
TTestParser= class(TTestJSON)
private
procedure DoTestError(S: String);
procedure DoTestFloat(F: TJSONFloat); overload;
procedure DoTestFloat(F: TJSONFloat; S: String); overload;
procedure DoTestObject(S: String; const ElNames: array of String);
procedure DoTestString(S : String);
procedure DoTestArray(S: String; ACount: Integer);
published
procedure TestEmpty;
procedure TestNull;
procedure TestTrue;
procedure TestFalse;
procedure TestFloat;
procedure TestInteger;
procedure TestString;
procedure TestArray;
procedure TestObject;
procedure TestMixed;
procedure TestErrors;
end;
implementation
procedure TTestParser.TestEmpty;
Var
P : TJSONParser;
J : TJSONData;
begin
P:=TJSONParser.Create('');
Try
J:=P.Parse;
If (J<>Nil) then
Fail('Empty returns Nil');
Finally
FreeAndNil(J);
FreeAndNil(P);
end;
end;
procedure TTestParser.TestInteger;
Var
P : TJSONParser;
J : TJSONData;
begin
P:=TJSONParser.Create('1');
Try
J:=P.Parse;
If (J=Nil) then
Fail('Parse of 1 fails');
TestJSONType(J,jtNumber);
TestAsInteger(J,1);
Finally
FreeAndNil(J);
FreeAndNil(P);
end;
end;
procedure TTestParser.TestNull;
Var
P : TJSONParser;
J : TJSONData;
begin
P:=TJSONParser.Create('Null');
Try
J:=P.Parse;
If (J=Nil) then
Fail('Parse of Null fails');
TestJSONType(J,jtNull);
Finally
FreeAndNil(J);
FreeAndNil(P);
end;
end;
procedure TTestParser.TestTrue;
Var
P : TJSONParser;
J : TJSONData;
begin
P:=TJSONParser.Create('True');
Try
J:=P.Parse;
If (J=Nil) then
Fail('Parse of True fails');
TestJSONType(J,jtBoolean);
TestAsBoolean(J,True);
Finally
FreeAndNil(J);
FreeAndNil(P);
end;
end;
procedure TTestParser.TestFalse;
Var
P : TJSONParser;
J : TJSONData;
begin
P:=TJSONParser.Create('False');
Try
J:=P.Parse;
If (J=Nil) then
Fail('Parse of False fails');
TestJSONType(J,jtBoolean);
TestAsBoolean(J,False);
Finally
FreeAndNil(J);
FreeAndNil(P);
end;
end;
procedure TTestParser.TestFloat;
begin
DoTestFloat(1.2);
DoTestFloat(-1.2);
DoTestFloat(0);
DoTestFloat(1.2e1);
DoTestFloat(-1.2e1);
DoTestFloat(0);
DoTestFloat(1.2,'1.2');
DoTestFloat(-1.2,'-1.2');
DoTestFloat(0,'0.0');
end;
procedure TTestParser.TestString;
begin
DoTestString('A string');
DoTestString('');
DoTestString('\"');
end;
procedure TTestParser.TestArray;
Var
S1,S2,S3 : String;
begin
DoTestArray('[]',0);
DoTestArray('[Null]',1);
DoTestArray('[True]',1);
DoTestArray('[False]',1);
DoTestArray('[1]',1);
DoTestArray('[1, 2]',2);
DoTestArray('[1, 2, 3]',3);
Str(1.2,S1);
Str(2.3,S2);
Str(3.4,S3);
DoTestArray('['+S1+']',1);
DoTestArray('['+S1+', '+S2+']',2);
DoTestArray('['+S1+', '+S2+', '+S3+']',3);
DoTestArray('["A string"]',1);
DoTestArray('["A string", "Another string"]',2);
DoTestArray('["A string", "Another string", "Yet another string"]',3);
DoTestArray('[Null, False]',2);
DoTestArray('[True, False]',2);
DoTestArray('[Null, 1]',2);
DoTestArray('[1, "A string"]',2);
DoTestArray('[1, []]',2);
DoTestArray('[1, [1, 2]]',2);
end;
procedure TTestParser.TestMixed;
begin
DoTestArray('[1, {}]',2);
DoTestArray('[1, { "a" : 1 }]',2);
DoTestArray('[1, { "a" : 1 }, 1]',3);
DoTestObject('{ "a" : [1, 2] }',['a']);
DoTestObject('{ "a" : [1, 2], "B" : { "c" : "d" } }',['a','B']);
end;
procedure TTestParser.TestObject;
begin
DoTestObject('{}',[]);
DoTestObject('{ "a" : 1 }',['a']);
DoTestObject('{ "a" : 1, "B" : "String" }',['a','B']);
DoTestObject('{ "a" : 1, "B" : {} }',['a','B']);
DoTestObject('{ "a" : 1, "B" : { "c" : "d" } }',['a','B']);
end;
procedure TTestParser.DoTestObject(S : String; Const ElNames : Array of String);
Var
P : TJSONParser;
J : TJSONData;
O : TJSONObject;
I : Integer;
begin
P:=TJSONParser.Create(S);
Try
J:=P.Parse;
If (J=Nil) then
Fail('Parse of object "'+S+'" fails');
TestJSONType(J,jtObject);
TestItemCount(J,High(ElNames)-Low(ElNames)+1);
O:=TJSONObject(J);
For I:=Low(ElNames) to High(ElNames) do
AssertEquals(Format('Element %d name',[I-Low(Elnames)])
,ElNames[i], O.Names[I-Low(ElNames)]);
TestJSON(J,S);
Finally
FreeAndNil(J);
FreeAndNil(P);
end;
end;
procedure TTestParser.DoTestArray(S : String; ACount : Integer);
Var
P : TJSONParser;
J : TJSONData;
begin
P:=TJSONParser.Create(S);
Try
J:=P.Parse;
If (J=Nil) then
Fail('Parse of array "'+S+'" fails');
TestJSONType(J,jtArray);
TestItemCount(J,ACount);
TestJSON(J,S);
Finally
FreeAndNil(J);
FreeAndNil(P);
end;
end;
procedure TTestParser.TestErrors;
begin
DoTestError('a');
DoTestError('"b');
DoTestError('1Tru');
DoTestError('b"');
DoTestError('{"a" : }');
DoTestError('{"a" : ""');
DoTestError('{"a : ""');
DoTestError('[1,]');
DoTestError('[,]');
DoTestError('[,,]');
DoTestError('[1,,]');
end;
procedure TTestParser.DoTestError(S : String);
Var
P : TJSONParser;
J : TJSONData;
ParseOK : Boolean;
N : String;
begin
ParseOK:=False;
P:=TJSONParser.Create(S);
J:=Nil;
Try
Try
Repeat
FreeAndNil(J);
J:=P.Parse;
ParseOK:=True;
If (J<>Nil) then
N:=J.ClassName;
Until (J=Nil)
Finally
FreeAndNil(J);
FreeAndNil(P);
end;
except
ParseOk:=False;
end;
If ParseOK then
Fail('Parse of JSON string "'+S+'" should fail, but returned '+N);
end;
procedure TTestParser.DoTestString(S: String);
Var
P : TJSONParser;
J : TJSONData;
begin
P:=TJSONParser.Create('"'+S+'"');
Try
J:=P.Parse;
If (J=Nil) then
Fail('Parse of string "'+S+'" fails');
TestJSONType(J,jtString);
TestAsString(J,JSONStringToString(S));
TestJSON(J,'"'+S+'"');
Finally
FreeAndNil(J);
FreeAndNil(P);
end;
end;
procedure TTestParser.DoTestFloat(F : TJSONFloat);
Var
S : String;
begin
Str(F,S);
DoTestFloat(F,S);
end;
procedure TTestParser.DoTestFloat(F : TJSONFloat; S : String);
Var
P : TJSONParser;
J : TJSONData;
begin
P:=TJSONParser.Create(S);
Try
J:=P.Parse;
If (J=Nil) then
Fail('Parse of float '+S+' fails');
TestJSONType(J,jtNumber);
TestAsFloat(J,F);
Finally
FreeAndNil(J);
FreeAndNil(P);
end;
end;
initialization
RegisterTest(TTestParser);
end.