mirror of https://github.com/red-prig/fpPS4.git
tools added
This commit is contained in:
red-prig
parent
d587f2dc78
commit
e41f788e2f
|
|
@ -14,6 +14,6 @@
|
|||
link.res
|
||||
lib/
|
||||
backup/
|
||||
shader_dump/
|
||||
spirv/
|
||||
savedata/
|
||||
shader_dump/*
|
||||
spirv/*
|
||||
savedata/*
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,63 @@
|
|||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<SaveClosedFiles Value="False"/>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
<MainUnitHasScaledStatement Value="False"/>
|
||||
<SaveJumpHistory Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="spirv_helper"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<UseFileFilters Value="True"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<FormatVersion Value="2"/>
|
||||
<Modes Count="0"/>
|
||||
</RunParams>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="spirv_helper.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="spirv_helper"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value="xpath"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
|
|
@ -0,0 +1,461 @@
|
|||
{$mode objfpc}{$H+}
|
||||
|
||||
Uses
|
||||
classes,
|
||||
Sysutils,
|
||||
gmap,
|
||||
//spirv,
|
||||
UJson;
|
||||
|
||||
type
|
||||
TRawStrCompare=class
|
||||
class function c(var a,b:RawByteString):boolean; static;
|
||||
end;
|
||||
|
||||
TMapStr=specialize TMap<RawByteString,RawByteString,TRawStrCompare>;
|
||||
TMapGroup=class(TMapStr)
|
||||
_type:RawByteString;
|
||||
end;
|
||||
|
||||
TOpInfo=packed record
|
||||
op_min:Word;
|
||||
op_max:Word;
|
||||
result:Boolean;
|
||||
rstype:Boolean;
|
||||
align:Word;
|
||||
end;
|
||||
|
||||
TOpInfoSet=specialize TMap<RawByteString,TOpInfo,TRawStrCompare>;
|
||||
|
||||
function ReCompareText(const S1,S2:RawByteString):sizeint;
|
||||
var
|
||||
i,count1,count2: sizeint;
|
||||
Chr1, Chr2: byte;
|
||||
P1, P2: PChar;
|
||||
begin
|
||||
Count1 := Length(S1);
|
||||
Count2 := Length(S2);
|
||||
if (Count1<>Count2) then Exit(Count1-Count2);
|
||||
if (Count1>0) then
|
||||
begin
|
||||
i := 0;
|
||||
P1 := @S1[1];
|
||||
P2 := @S2[1];
|
||||
while (i<Count1) do
|
||||
begin
|
||||
Chr1 := byte(p1[i]);
|
||||
Chr2 := byte(p2[i]);
|
||||
if (Chr1<>Chr2) then
|
||||
begin
|
||||
Exit(Chr1-Chr2);
|
||||
end;
|
||||
Inc(I);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
class function TRawStrCompare.c(var a,b:RawByteString):boolean;
|
||||
begin
|
||||
Result:=ReCompareText(a,b)<0;
|
||||
end;
|
||||
|
||||
var
|
||||
Comment:RawByteString;
|
||||
LConstMeta:TStringList;
|
||||
|
||||
LEnums:TStringList;
|
||||
|
||||
OpInfoSet:TOpInfoSet;
|
||||
|
||||
function _getComment(sComment:Tjson):RawByteString;
|
||||
var
|
||||
i1,s1,i2,s2:Integer;
|
||||
r:RawByteString;
|
||||
tmp:Tjson;
|
||||
begin
|
||||
Result:='';
|
||||
s1:=sComment.Count;
|
||||
if (s1<>0) then
|
||||
For i1:=0 to s1-1 do
|
||||
begin
|
||||
tmp:=sComment.Item[i1];
|
||||
s2:=tmp.Count;
|
||||
if (s2<>0) then
|
||||
For i2:=0 to s2-1 do
|
||||
begin
|
||||
r:=tmp.Item[i2].AsStr;
|
||||
r:=Trim(r);
|
||||
if (r<>'') then r:=' '+r;
|
||||
Result:=Result+r+#13#10;
|
||||
end;
|
||||
if (i1<>s1-1) then
|
||||
Result:=Result+#13#10;
|
||||
end;
|
||||
if (Result<>'') then Result:='{'#13#10+Result+'}'#13#10;
|
||||
end;
|
||||
|
||||
Function GetPasLabel(_name:RawByteString):RawByteString;
|
||||
begin
|
||||
Case _name of
|
||||
'Function',
|
||||
'Generic',
|
||||
'Private',
|
||||
'Repeat',
|
||||
'Const',
|
||||
'Inline',
|
||||
'Export':Result:=_name+'_';
|
||||
else
|
||||
Result:=_name;
|
||||
end;
|
||||
end;
|
||||
|
||||
function _getGroup(sValues:Tjson;const _type:RawByteString):TMapGroup;
|
||||
Var
|
||||
i,s:Integer;
|
||||
val:QWORD;
|
||||
_name,_value,tmp:RawByteString;
|
||||
begin
|
||||
Result:=TMapGroup.Create;
|
||||
|
||||
s:=sValues.Count;
|
||||
if (s<>0) then
|
||||
For i:=0 to s-1 do
|
||||
begin
|
||||
_name:=sValues.Name[i];
|
||||
_value:=sValues.Item[i].AsStr;
|
||||
|
||||
if (_type='Bit') then
|
||||
if TryStrToQWord(_value,val) then
|
||||
begin
|
||||
_value:=IntToStr(1 shl val);
|
||||
end;
|
||||
|
||||
if Result.TryGetValue(_value,tmp) then
|
||||
begin
|
||||
if (Length(_name)<Length(tmp)) then
|
||||
if (copy(tmp,Length(tmp)-2,3)<>'KHR') then
|
||||
begin
|
||||
Result.Delete(_value);
|
||||
Result.Insert(_value,_name);
|
||||
end;
|
||||
end else
|
||||
begin
|
||||
Result.Insert(_value,_name);
|
||||
end;
|
||||
end;
|
||||
|
||||
if (_type='Bit') then
|
||||
Result.Insert('0','None');
|
||||
end;
|
||||
|
||||
procedure LoadOp(LGroup:TMapGroup);
|
||||
var
|
||||
IG:TMapGroup.TIterator;
|
||||
begin
|
||||
OpInfoSet:=TOpInfoSet.Create;
|
||||
IG:=LGroup.Min;
|
||||
if Assigned(IG) then
|
||||
repeat
|
||||
OpInfoSet.Insert(IG.Value,Default(TOpInfo));
|
||||
until (not IG.Next);
|
||||
FreeAndNil(IG);
|
||||
end;
|
||||
|
||||
procedure loadSpirvJson(Const fname:RawByteString);
|
||||
Var
|
||||
J,meta,enum,tmp:Tjson;
|
||||
i,s:Integer;
|
||||
_name,_type:RawByteString;
|
||||
|
||||
LGroup:TMapGroup;
|
||||
begin
|
||||
J:=Tjson.NewFromFile(fname);
|
||||
|
||||
Comment:=_getComment(J.Path['spv.meta.Comment']);
|
||||
|
||||
LConstMeta:=TStringList.Create;
|
||||
meta:=J.Path['spv.meta'];
|
||||
s:=meta.Count;
|
||||
if (s<>0) then
|
||||
For i:=0 to s-1 do
|
||||
if (meta.Name[i]<>'Comment') then
|
||||
begin
|
||||
LConstMeta.Add(meta.Name[i]+' = '+meta.Item[i].AsStr);
|
||||
end;
|
||||
|
||||
LEnums:=TStringList.Create;
|
||||
enum:=J.Path['spv.enum'];
|
||||
s:=enum.Count;
|
||||
if (s<>0) then
|
||||
For i:=0 to s-1 do
|
||||
begin
|
||||
tmp:=enum.Item[i];
|
||||
_name:=tmp.Path['Name'].AsStr;
|
||||
_type:=tmp.Path['Type'].AsStr;
|
||||
|
||||
LGroup:=_getGroup(tmp.Path['Values'],_type);
|
||||
LGroup._type:=_type;
|
||||
|
||||
LEnums.AddObject(_name,LGroup);
|
||||
|
||||
if (_name='Op') then
|
||||
LoadOp(LGroup);
|
||||
|
||||
end;
|
||||
|
||||
J.Free;
|
||||
end;
|
||||
|
||||
function _get_OpInfo(oper:Tjson):TOpInfo;
|
||||
Var
|
||||
q,k:RawByteString;
|
||||
tmp:Tjson;
|
||||
i,s:Integer;
|
||||
begin
|
||||
Result:=Default(TOpInfo);
|
||||
|
||||
s:=oper.Count;
|
||||
if (s<>0) then
|
||||
For i:=0 to s-1 do
|
||||
begin
|
||||
tmp:=oper.Item[i];
|
||||
k:=tmp.Path['kind'].AsStr;
|
||||
|
||||
case k of
|
||||
'IdResultType':Result.rstype:=True;
|
||||
'IdResult' :Result.result:=True;
|
||||
end;
|
||||
|
||||
q:=tmp.Path['quantifier'].AsStr;
|
||||
case q of
|
||||
'*':Result.op_max:=$FFFF;
|
||||
'?':if (Result.op_max<>$FFFF) then
|
||||
begin
|
||||
Result.op_max:=Result.op_max+1;
|
||||
end;
|
||||
else
|
||||
begin
|
||||
Result.op_min:=Result.op_min+1;
|
||||
if (Result.op_max<>$FFFF) then
|
||||
begin
|
||||
Result.op_max:=Result.op_max+1;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
procedure loadSpirvGrammarJson(Const fname:RawByteString);
|
||||
Var
|
||||
J,inst,tmp:Tjson;
|
||||
i,s:Integer;
|
||||
opname:RawByteString;
|
||||
OpInfo:TOpInfo;
|
||||
IT:TOpInfoSet.TIterator;
|
||||
begin
|
||||
J:=Tjson.NewFromFile(fname);
|
||||
|
||||
inst:=J.Path['instructions'];
|
||||
|
||||
s:=inst.Count;
|
||||
if (s<>0) then
|
||||
For i:=0 to s-1 do
|
||||
begin
|
||||
tmp:=inst.Item[i];
|
||||
opname:=tmp.Path['opname'].AsStr;
|
||||
OpInfo:=_get_OpInfo(tmp.Path['operands']);
|
||||
|
||||
IT:=OpInfoSet.Find(opname);
|
||||
if Assigned(IT) then
|
||||
begin
|
||||
IT.Value:=OpInfo;
|
||||
FreeAndNil(IT);
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
J.Free;
|
||||
end;
|
||||
|
||||
Function IsJson(Const FName:RawByteString):Boolean;
|
||||
begin
|
||||
Result:=False;
|
||||
Case UpperCase(ExtractFileExt(FName)) of
|
||||
'.JSON':Result:=True;
|
||||
end;
|
||||
end;
|
||||
|
||||
Const
|
||||
prologf='unit spirv;'#$0D#$0A#$0D#$0A+
|
||||
'{$mode objfpc}{$H+}'#$0D#$0A#$0D#$0A+
|
||||
'{$WARNINGS OFF}'#$0D#$0A#$0D#$0A+
|
||||
'interface'#$0D#$0A#$0D#$0A;
|
||||
|
||||
ep_impl='implementation'#$0D#$0A#$0D#$0A;
|
||||
|
||||
ep_func='end.'#$0D#$0A;
|
||||
|
||||
NL=#$0D#$0A;
|
||||
NLNL=#$0D#$0A#$0D#$0A;
|
||||
|
||||
LConst='Const'#$0D#$0A;
|
||||
LType ='Type'#$0D#$0A;
|
||||
LEnd =' end;';
|
||||
|
||||
LGetStr_i=' function GetStr(w:Word):RawByteString; static;'#$0D#$0A;
|
||||
|
||||
LGetInfo_i=' type'#$0D#$0A+
|
||||
' TOpInfo=packed record'#$0D#$0A+
|
||||
' op_min:Word;'#$0D#$0A+
|
||||
' op_max:Word;'#$0D#$0A+
|
||||
' result:Boolean;'#$0D#$0A+
|
||||
' rstype:Boolean;'#$0D#$0A+
|
||||
' align:Word;'#$0D#$0A+
|
||||
' end;'#$0D#$0A+
|
||||
' function GetInfo(w:Word):TOpInfo; static;'#$0D#$0A;
|
||||
|
||||
LGetInfo_p='function Op.GetInfo(w:Word):TOpInfo; static;'#$0D#$0A+
|
||||
'begin'#$0D#$0A+
|
||||
' Result:=Default(TOpInfo);'#$0D#$0A+
|
||||
' Case w of'#$0D#$0A;
|
||||
|
||||
LFunc='function ';
|
||||
|
||||
LGetStr_p='.GetStr(w:Word):RawByteString;'#$0D#$0A+
|
||||
'begin'#$0D#$0A+
|
||||
' Result:=''???'';'#$0D#$0A+
|
||||
' Case w of'#$0D#$0A;
|
||||
|
||||
LGetStr_e=' end;'#$0D#$0A+
|
||||
'end;'#$0D#$0A#$0D#$0A;
|
||||
|
||||
Procedure SaveToPas(Const FName:RawByteString);
|
||||
Var
|
||||
F:Thandle;
|
||||
|
||||
i,s:Integer;
|
||||
_name:RawByteString;
|
||||
|
||||
LGroup:TMapGroup;
|
||||
IG:TMapGroup.TIterator;
|
||||
IT:TOpInfoSet.TIterator;
|
||||
|
||||
begin
|
||||
F:=FileCreate(FName);
|
||||
FileWrite(F,PChar(Comment)^,Length(Comment));
|
||||
FileWrite(F,PChar(prologf)^,Length(prologf));
|
||||
|
||||
FileWrite(F,PChar(LConst)^,Length(LConst));
|
||||
s:=LConstMeta.Count;
|
||||
if (s<>0) then
|
||||
begin
|
||||
For i:=0 to s-1 do
|
||||
begin
|
||||
_name:=' '+LConstMeta.Strings[i]+';'+NL;
|
||||
FileWrite(F,PChar(_name)^,Length(_name));
|
||||
end;
|
||||
FileWrite(F,PChar(NL)^,Length(NL));
|
||||
end;
|
||||
|
||||
FileWrite(F,PChar(LType)^,Length(LType));
|
||||
s:=LEnums.Count;
|
||||
if (s<>0) then
|
||||
begin
|
||||
For i:=0 to s-1 do
|
||||
begin
|
||||
LGroup:=TMapGroup(LEnums.Objects[i]);
|
||||
_name:=LEnums.Strings[i];
|
||||
|
||||
_name:=' '+_name+'=object'+' //'+LGroup._type+NL+' '+LConst;
|
||||
FileWrite(F,PChar(_name)^,Length(_name));
|
||||
|
||||
IG:=LGroup.Min;
|
||||
if Assigned(IG) then
|
||||
repeat
|
||||
_name:=' '+GetPasLabel(IG.Value)+' = '+IG.Key+';'+NL;
|
||||
FileWrite(F,PChar(_name)^,Length(_name));
|
||||
until (not IG.Next);
|
||||
FreeAndNil(IG);
|
||||
|
||||
if (LGroup._type='Value') then
|
||||
FileWrite(F,PChar(LGetStr_i)^,Length(LGetStr_i));
|
||||
|
||||
if (LEnums.Strings[i]='Op') then
|
||||
FileWrite(F,PChar(LGetInfo_i)^,Length(LGetInfo_i));
|
||||
|
||||
FileWrite(F,PChar(LEnd)^,Length(LEnd));
|
||||
FileWrite(F,PChar(NLNL)^,Length(NLNL));
|
||||
end;
|
||||
end;
|
||||
|
||||
FileWrite(F,PChar(ep_impl)^,Length(ep_impl));
|
||||
s:=LEnums.Count;
|
||||
if (s<>0) then
|
||||
begin
|
||||
For i:=0 to s-1 do
|
||||
begin
|
||||
LGroup:=TMapGroup(LEnums.Objects[i]);
|
||||
if (LGroup._type<>'Value') then Continue;
|
||||
_name:=LEnums.Strings[i];
|
||||
|
||||
_name:=LFunc+_name+LGetStr_p;
|
||||
|
||||
FileWrite(F,PChar(_name)^,Length(_name));
|
||||
|
||||
IG:=LGroup.Min;
|
||||
if Assigned(IG) then
|
||||
repeat
|
||||
_name:=' '+GetPasLabel(IG.Value)+':Result:='''+IG.Value+''';'+NL;
|
||||
FileWrite(F,PChar(_name)^,Length(_name));
|
||||
until (not IG.Next);
|
||||
FreeAndNil(IG);
|
||||
|
||||
FileWrite(F,PChar(LGetStr_e)^,Length(LGetStr_e));
|
||||
|
||||
if (LEnums.Strings[i]='Op') then
|
||||
begin
|
||||
FileWrite(F,PChar(LGetInfo_p)^,Length(LGetInfo_p));
|
||||
|
||||
IG:=LGroup.Min;
|
||||
if Assigned(IG) then
|
||||
repeat
|
||||
|
||||
IT:=OpInfoSet.Find(IG.Value);
|
||||
if Assigned(IT) then
|
||||
begin
|
||||
_name:=' '+GetPasLabel(IG.Value)+':QWORD(Result):=$'+HexStr(QWORD(IT.Value),16)+';'+NL;
|
||||
FileWrite(F,PChar(_name)^,Length(_name));
|
||||
FreeAndNil(IT);
|
||||
end;
|
||||
|
||||
until (not IG.Next);
|
||||
FreeAndNil(IG);
|
||||
|
||||
FileWrite(F,PChar(LGetStr_e)^,Length(LGetStr_e));
|
||||
end;
|
||||
|
||||
end;
|
||||
end;
|
||||
|
||||
FileWrite(F,PChar(ep_func)^,Length(ep_func));
|
||||
FileClose(F);
|
||||
end;
|
||||
|
||||
begin
|
||||
DefaultSystemCodePage:=CP_UTF8;
|
||||
DefaultUnicodeCodePage:=CP_UTF8;
|
||||
DefaultFileSystemCodePage:=CP_UTF8;
|
||||
DefaultRTLFileSystemCodePage:=CP_UTF8;
|
||||
UTF8CompareLocale:=CP_UTF8;
|
||||
|
||||
loadSpirvJson('spirv.json');
|
||||
loadSpirvGrammarJson('spirv.core.grammar.json');
|
||||
Writeln('Load is Fin');
|
||||
SaveToPas('spirv.pas');
|
||||
Writeln('Save is Fin');
|
||||
|
||||
readln;
|
||||
end.
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,368 @@
|
|||
{
|
||||
This file is part of the Free Component Library
|
||||
|
||||
JSON Data structures
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
//modifed by Red_prig
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
unit Ufpjson;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$ifdef fpc}
|
||||
variants,
|
||||
{$endif}
|
||||
{$ifdef pas2js}
|
||||
JS, RTLConsts, Types,
|
||||
{$endif}
|
||||
SysUtils,
|
||||
classes;
|
||||
|
||||
type
|
||||
TJSONtype = (jtUnknown, jtNumber, jtString, jtBoolean, jtNull, jtArray, jtObject);
|
||||
TJSONInstanceType = (
|
||||
jitUnknown,
|
||||
jitNumberInteger,
|
||||
{$ifdef fpc}
|
||||
jitNumberInt64,
|
||||
jitNumberQWord,
|
||||
{$endif}
|
||||
jitNumberFloat,
|
||||
jitString,
|
||||
jitBoolean,
|
||||
jitNull,
|
||||
jitArray,
|
||||
jitObject);
|
||||
TJSONFloat = Double;
|
||||
TJSONStringType = {$ifdef fpc}UTF8String{$else}string{$endif};
|
||||
TJSONUnicodeStringType = Unicodestring;
|
||||
{$ifdef fpc}
|
||||
TJSONCharType = AnsiChar;
|
||||
PJSONCharType = ^TJSONCharType;
|
||||
TJSONVariant = variant;
|
||||
TFPJSStream = TMemoryStream;
|
||||
{$else}
|
||||
TJSONCharType = char;
|
||||
TJSONVariant = jsvalue;
|
||||
TFPJSStream = TJSArray;
|
||||
{$endif}
|
||||
TFormatOption = (foSingleLineArray, // Array without CR/LF : all on one line
|
||||
foSingleLineObject, // Object without CR/LF : all on one line
|
||||
foDoNotQuoteMembers, // Do not quote object member names.
|
||||
foUseTabchar, // Use tab characters instead of spaces.
|
||||
foSkipWhiteSpace, // Do not use whitespace at all
|
||||
foSkipWhiteSpaceOnlyLeading // When foSkipWhiteSpace is active, skip whitespace for object members only before :
|
||||
);
|
||||
TFormatOptions = set of TFormatOption;
|
||||
|
||||
Const
|
||||
DefaultIndentSize = 2;
|
||||
DefaultFormat = [];
|
||||
AsJSONFormat = [foSingleLineArray,foSingleLineObject]; // These options make FormatJSON behave as AsJSON
|
||||
AsCompressedJSON = [foSingleLineArray,foSingleLineObject,foskipWhiteSpace]; // These options make FormatJSON behave as AsJSON with TJSONData.CompressedJSON=True
|
||||
AsCompactJSON = [foSingleLineArray,foSingleLineObject,foskipWhiteSpace,foDoNotQuoteMembers]; // These options make FormatJSON behave as AsJSON with TJSONData.CompressedJSON=True and TJSONObject.UnquotedMemberNames=True
|
||||
ValueJSONTypes = [jtNumber, jtString, jtBoolean, jtNull];
|
||||
ActualValueJSONTypes = ValueJSONTypes - [jtNull];
|
||||
StructuredJSONTypes = [jtArray,jtObject];
|
||||
|
||||
Type
|
||||
|
||||
TJSONNumberType = (
|
||||
ntFloat,
|
||||
ntInteger
|
||||
{$ifdef fpc}
|
||||
,ntInt64
|
||||
,ntQWord
|
||||
{$endif}
|
||||
);
|
||||
|
||||
type
|
||||
TAddStr=object
|
||||
FStr:PChar;
|
||||
FLen:SizeInt;
|
||||
Procedure AddStr(Const S:RawByteString);
|
||||
Procedure AddChar(C:AnsiChar);
|
||||
Procedure Reset; inline;
|
||||
Procedure Free; inline;
|
||||
function GetStr:RawByteString; inline;
|
||||
end;
|
||||
TUtf8AddStr=object(TAddStr)
|
||||
FSP:SizeUInt;
|
||||
Procedure AddChar(C:AnsiChar); inline;
|
||||
Procedure AddWideChar(C:WideChar);
|
||||
Procedure Reset; inline;
|
||||
end;
|
||||
|
||||
Function StringToJSONString(const S : TJSONStringType;Strict:Boolean=False):TJSONStringType; inline;
|
||||
procedure _StringToJSONString(Var FAddStr:TAddStr;const S:TJSONStringType;Strict:Boolean=False); inline;
|
||||
procedure __StringToJSONString(Var FAddStr:TAddStr;P:PJSONCharType;Len:SizeInt;Strict:Boolean=False);
|
||||
Function JSONStringToString(const S :TJSONStringType):TJSONStringType; inline;
|
||||
procedure _JSONStringToString(Var FAddStr:TUtf8AddStr;const S:TJSONStringType); inline;
|
||||
procedure __JSONStringToString(Var FAddStr:TUtf8AddStr;P:PJSONCharType;Len:SizeInt);
|
||||
Function JSONTypeName(JSONType:TJSONType):String;
|
||||
|
||||
implementation
|
||||
|
||||
Uses typinfo;
|
||||
|
||||
Procedure TAddStr.AddStr(Const S:RawByteString);
|
||||
Var
|
||||
i:SizeInt;
|
||||
begin
|
||||
if Length(S)>0 then
|
||||
For i:=1 to Length(S) do
|
||||
AddChar(S[i]);
|
||||
end;
|
||||
|
||||
Procedure TAddStr.AddChar(C:AnsiChar);
|
||||
Var
|
||||
i,MemLen:SizeInt;
|
||||
begin
|
||||
|
||||
if (FStr=nil) then
|
||||
begin
|
||||
MemLen:=0
|
||||
end else
|
||||
begin
|
||||
MemLen:=MemSize(FStr);
|
||||
end;
|
||||
|
||||
i:=FLen;
|
||||
FLen:=FLen+1;
|
||||
if (MemLen<FLen) then
|
||||
begin
|
||||
Case FLen of
|
||||
0..SizeOf(Pointer)*4:
|
||||
FStr:=ReAllocMem(FStr,SizeOf(Pointer)*4);
|
||||
else
|
||||
begin
|
||||
FStr:=ReAllocMem(FStr,i+(i div 2));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
FStr[i]:=C;
|
||||
|
||||
end;
|
||||
|
||||
Procedure TUtf8AddStr.AddChar(C:AnsiChar); inline;
|
||||
begin
|
||||
FSP:=0;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
Procedure TAddStr.Reset; inline;
|
||||
begin
|
||||
FLen:=0;
|
||||
end;
|
||||
|
||||
Procedure TAddStr.Free; inline;
|
||||
begin
|
||||
FreeMem(FStr);
|
||||
end;
|
||||
|
||||
function TAddStr.GetStr:RawByteString; inline;
|
||||
begin
|
||||
SetLength(Result,FLen);
|
||||
Move(FStr^,Result[1],FLen);
|
||||
end;
|
||||
|
||||
Procedure TUtf8AddStr.AddWideChar(C:WideChar);
|
||||
Var
|
||||
lw:longword;
|
||||
begin
|
||||
lw:=Ord(C);
|
||||
if FSP<>0 then
|
||||
begin
|
||||
case lw of
|
||||
$dc00..$dfff:
|
||||
{High Surrogates 2}
|
||||
begin
|
||||
{ $d7c0 is ($d800 - ($10000 shr 10)) }
|
||||
lw:=(longword(FSP-$d7c0) shl 10) + (lw xor $dc00);
|
||||
inherited AddChar(AnsiChar($f0 or (lw shr 18)));
|
||||
inherited AddChar(AnsiChar($80 or ((lw shr 12) and $3f)));
|
||||
inherited AddChar(AnsiChar($80 or ((lw shr 6) and $3f)));
|
||||
inherited AddChar(AnsiChar($80 or (lw and $3f)));
|
||||
end;
|
||||
end;
|
||||
FSP:=0;
|
||||
end else
|
||||
begin
|
||||
case lw of
|
||||
0..$7f:
|
||||
begin
|
||||
inherited AddChar(AnsiChar(lw));
|
||||
end;
|
||||
$80..$7ff:
|
||||
begin
|
||||
inherited AddChar(AnsiChar($c0 or (lw shr 6)));
|
||||
inherited AddChar(AnsiChar($80 or (lw and $3f)));
|
||||
end;
|
||||
$800..$d7ff,$e000..$ffff:
|
||||
begin
|
||||
inherited AddChar(AnsiChar($e0 or (lw shr 12)));
|
||||
inherited AddChar(AnsiChar($80 or ((lw shr 6) and $3f)));
|
||||
inherited AddChar(AnsiChar($80 or (lw and $3f)));
|
||||
end;
|
||||
$d800..$dbff:
|
||||
{High Surrogates 1}
|
||||
begin
|
||||
FSP:=lw;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
Procedure TUtf8AddStr.Reset; inline;
|
||||
begin
|
||||
inherited;
|
||||
FSP:=0;
|
||||
end;
|
||||
|
||||
function StringToJSONString(const S:TJSONStringType;Strict:Boolean=False):TJSONStringType; inline;
|
||||
Var
|
||||
FAddStr:TAddStr;
|
||||
begin
|
||||
FAddStr:=Default(TAddStr);
|
||||
_StringToJSONString(FAddStr,S,Strict);
|
||||
Result:=FAddStr.GetStr;
|
||||
FAddStr.Free;
|
||||
end;
|
||||
|
||||
procedure _StringToJSONString(Var FAddStr:TAddStr;const S:TJSONStringType;Strict:Boolean=False); inline;
|
||||
begin
|
||||
__StringToJSONString(FAddStr,PJSONCharType(S),Length(S),Strict);
|
||||
end;
|
||||
|
||||
procedure __StringToJSONString(Var FAddStr:TAddStr;P:PJSONCharType;Len:SizeInt;Strict:Boolean=False);
|
||||
Var
|
||||
I:SizeInt;
|
||||
C,T:AnsiChar;
|
||||
begin
|
||||
I:=0;
|
||||
if Strict then T:='/' else T:=#0;
|
||||
While (I<Len) do
|
||||
begin
|
||||
C:=AnsiChar(P^);
|
||||
if (C in ['"',T,'\',#0..#31]) then
|
||||
begin
|
||||
FAddStr.AddChar('\');
|
||||
Case C of
|
||||
'\',
|
||||
'/',
|
||||
'"' : FAddStr.AddChar(C);
|
||||
#8 : FAddStr.AddChar('b');
|
||||
#9 : FAddStr.AddChar('t');
|
||||
#10 : FAddStr.AddChar('n');
|
||||
#12 : FAddStr.AddChar('f');
|
||||
#13 : FAddStr.AddChar('r');
|
||||
else
|
||||
begin
|
||||
FAddStr.AddChar('u');
|
||||
FAddStr.AddStr(HexStr(Ord(C),4));
|
||||
end;
|
||||
end;
|
||||
end else
|
||||
begin
|
||||
FAddStr.AddChar(c);
|
||||
end;
|
||||
Inc(I);
|
||||
Inc(P);
|
||||
end;
|
||||
end;
|
||||
|
||||
Function JSONStringToString(const S:TJSONStringType):TJSONStringType; inline;
|
||||
Var
|
||||
FAddStr:TUtf8AddStr;
|
||||
begin
|
||||
FAddStr:=Default(TUtf8AddStr);
|
||||
_JSONStringToString(FAddStr,S);
|
||||
Result:=FAddStr.GetStr;
|
||||
FAddStr.Free;
|
||||
end;
|
||||
|
||||
procedure _JSONStringToString(Var FAddStr:TUtf8AddStr;const S:TJSONStringType); inline;
|
||||
begin
|
||||
__JSONStringToString(FAddStr,PJSONCharType(S),Length(S));
|
||||
end;
|
||||
|
||||
procedure __JSONStringToString(Var FAddStr:TUtf8AddStr;P:PJSONCharType;Len:SizeInt);
|
||||
Const
|
||||
DifLo=Byte('a')-$A;
|
||||
DifHi=Byte('A')-$A;
|
||||
Var
|
||||
I,State:SizeInt;
|
||||
w:Word;
|
||||
begin
|
||||
State:=0;
|
||||
I:=0;
|
||||
While (I<Len) do
|
||||
begin
|
||||
Case State of
|
||||
0:begin
|
||||
if (P^='\') then
|
||||
begin
|
||||
State:=1;
|
||||
end else
|
||||
begin
|
||||
FAddStr.AddChar(P^);
|
||||
end;
|
||||
end;
|
||||
1:begin
|
||||
Case P^ of
|
||||
'b':FAddStr.AddChar(#8);
|
||||
't':FAddStr.AddChar(#9);
|
||||
'n':FAddStr.AddChar(#10);
|
||||
'f':FAddStr.AddChar(#12);
|
||||
'r':FAddStr.AddChar(#13);
|
||||
'u':begin
|
||||
State:=2;
|
||||
w:=0;
|
||||
Inc(I);
|
||||
Inc(P);
|
||||
Continue;
|
||||
end;
|
||||
else
|
||||
FAddStr.AddChar(P^);
|
||||
end;
|
||||
State:=0;
|
||||
end;
|
||||
2..5:
|
||||
begin
|
||||
Case P^ of
|
||||
'0'..'9':w:=(w shl 4) or (PByte(P)^ and $F);
|
||||
'a'..'f':w:=(w shl 4) or (PByte(P)^-DifLo);
|
||||
'A'..'F':w:=(w shl 4) or (PByte(P)^-DifHi);
|
||||
else w:=(w shl 4);
|
||||
end;
|
||||
Inc(State);
|
||||
if (State=6) then
|
||||
begin
|
||||
FAddStr.AddWideChar(WideChar(W));
|
||||
State:=0;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
Inc(I);
|
||||
Inc(P);
|
||||
end;
|
||||
end;
|
||||
|
||||
function JSONTypeName(JSONType: TJSONType): String;
|
||||
begin
|
||||
Result:=GetEnumName(TypeInfo(TJSONType),Ord(JSONType));
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
|
|
@ -0,0 +1,348 @@
|
|||
{
|
||||
This file is part of the Free Component Library
|
||||
|
||||
JSON SAX-like Reader
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
//modifed by Red_prig
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
unit Ujsonreader;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, UfpJSON, Ujsonscanner;
|
||||
|
||||
Type
|
||||
|
||||
{ TBaseJSONReader }
|
||||
|
||||
TBaseJSONReader = Class(TObject)
|
||||
Private
|
||||
FScanner : TJSONScanner;
|
||||
function GetO(AIndex: TJSONOption): Boolean;
|
||||
function GetOptions: TJSONOptions; inline;
|
||||
procedure SetO(AIndex: TJSONOption; AValue: Boolean);
|
||||
procedure SetOptions(AValue: TJSONOptions);
|
||||
Protected
|
||||
procedure DoError(const Msg: String);
|
||||
Procedure DoParse(AtCurrent,AllowEOF: Boolean);
|
||||
function GetNextToken: TJSONToken;
|
||||
function CurrentTokenString: RawByteString;
|
||||
function CurrentToken: TJSONToken; inline;
|
||||
|
||||
Procedure KeyValue(Const AKey : TJSONStringType); virtual; abstract;
|
||||
Procedure StringValue(Const AValue : TJSONStringType);virtual; abstract;
|
||||
Procedure NullValue; virtual; abstract;
|
||||
Procedure FloatValue(Const AValue : Double); virtual; abstract;
|
||||
Procedure BooleanValue(Const AValue : Boolean); virtual; abstract;
|
||||
Procedure NumberValue(Const AValue : TJSONStringType); virtual; abstract;
|
||||
Procedure IntegerValue(Const AValue : integer); virtual; abstract;
|
||||
Procedure Int64Value(Const AValue : int64); virtual; abstract;
|
||||
Procedure QWordValue(Const AValue : QWord); virtual; abstract;
|
||||
Procedure StartArray; virtual; abstract;
|
||||
Procedure StartObject; virtual; abstract;
|
||||
Procedure EndArray; virtual; abstract;
|
||||
Procedure EndObject; virtual; abstract;
|
||||
|
||||
Procedure ParseArray;
|
||||
Procedure ParseObject;
|
||||
Procedure ParseNumber;
|
||||
Procedure DoExecute;
|
||||
Property Scanner : TJSONScanner read FScanner;
|
||||
Public
|
||||
Constructor Create(Source : TStream; AUseUTF8 : Boolean = True); overload;deprecated 'use options form instead';
|
||||
Constructor Create(Source : TJSONStringType; AUseUTF8 : Boolean = True); overload;deprecated 'use options form instead';
|
||||
constructor Create(Source: TStream; AOptions: TJSONOptions); overload;
|
||||
constructor Create(const Source: RawByteString; AOptions: TJSONOptions); overload;
|
||||
destructor Destroy();override;
|
||||
// Parsing options
|
||||
Property Options : TJSONOptions Read GetOptions Write SetOptions;
|
||||
end;
|
||||
|
||||
EJSONParser = Class(EParserError);
|
||||
|
||||
implementation
|
||||
|
||||
Resourcestring
|
||||
SErrUnexpectedEOF = 'Unexpected EOF encountered.';
|
||||
SErrUnexpectedToken = 'Unexpected token (%s) encountered.';
|
||||
SErrExpectedColon = 'Expected colon (:), got token "%s".';
|
||||
//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';
|
||||
SErrNoScanner = 'No scanner. No source specified ?';
|
||||
|
||||
{ TBaseJSONReader }
|
||||
|
||||
|
||||
Procedure TBaseJSONReader.DoExecute;
|
||||
|
||||
begin
|
||||
if (FScanner=Nil) then
|
||||
DoError(SErrNoScanner);
|
||||
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 TBaseJSONReader.CurrentToken: TJSONToken;
|
||||
|
||||
begin
|
||||
Result:=FScanner.CurToken;
|
||||
end;
|
||||
|
||||
function TBaseJSONReader.CurrentTokenString: RawByteString;
|
||||
|
||||
begin
|
||||
If CurrentToken in [tkString,tkIdentifier,tkNumber,tkComment] then
|
||||
Result:=FScanner.CurTokenString
|
||||
else
|
||||
Result:=TokenInfos[CurrentToken];
|
||||
end;
|
||||
|
||||
procedure TBaseJSONReader.DoParse(AtCurrent, AllowEOF: Boolean);
|
||||
|
||||
var
|
||||
T : TJSONToken;
|
||||
|
||||
begin
|
||||
If not AtCurrent then
|
||||
T:=GetNextToken
|
||||
else
|
||||
T:=FScanner.CurToken;
|
||||
Case T of
|
||||
tkEof : If Not AllowEof then
|
||||
DoError(SErrUnexpectedEOF);
|
||||
tkNull : NullValue;
|
||||
tkTrue,
|
||||
tkFalse : BooleanValue(t=tkTrue);
|
||||
tkString : if (joUTF8 in Options) and (DefaultSystemCodePage<>CP_UTF8) then
|
||||
StringValue(TJSONStringType(UTF8Decode(CurrentTokenString)))
|
||||
else
|
||||
StringValue(CurrentTokenString);
|
||||
tkCurlyBraceOpen :
|
||||
ParseObject;
|
||||
tkCurlyBraceClose :
|
||||
DoError(SErrUnexpectedToken);
|
||||
tkSQuaredBraceOpen :
|
||||
ParseArray;
|
||||
tkSQuaredBraceClose :
|
||||
DoError(SErrUnexpectedToken);
|
||||
tkNumber :
|
||||
ParseNumber;
|
||||
tkComma :
|
||||
DoError(SErrUnexpectedToken);
|
||||
tkIdentifier :
|
||||
DoError(SErrUnexpectedToken);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
// Creates the correct JSON number type, based on the current token.
|
||||
procedure TBaseJSONReader.ParseNumber;
|
||||
|
||||
Var
|
||||
I : Integer;
|
||||
I64 : Int64;
|
||||
QW : QWord;
|
||||
F : TJSONFloat;
|
||||
S : String;
|
||||
|
||||
begin
|
||||
S:=CurrentTokenString;
|
||||
NumberValue(S);
|
||||
I:=0;
|
||||
if TryStrToQWord(S,QW) then
|
||||
begin
|
||||
if QW>qword(high(Int64)) then
|
||||
QWordValue(QW)
|
||||
else
|
||||
if QW>MaxInt then
|
||||
begin
|
||||
I64 := QW;
|
||||
Int64Value(I64);
|
||||
end
|
||||
else
|
||||
begin
|
||||
I:=QW;
|
||||
IntegerValue(I);
|
||||
end
|
||||
end
|
||||
else
|
||||
begin
|
||||
If TryStrToInt64(S,I64) then
|
||||
if (I64>Maxint) or (I64<-MaxInt) then
|
||||
Int64Value(I64)
|
||||
Else
|
||||
begin
|
||||
I:=I64;
|
||||
IntegerValue(I);
|
||||
end
|
||||
else
|
||||
begin
|
||||
I:=0;
|
||||
Val(S,F,I);
|
||||
If (I<>0) then
|
||||
DoError(SErrInvalidNumber);
|
||||
FloatValue(F);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TBaseJSONReader.GetO(AIndex: TJSONOption): Boolean;
|
||||
begin
|
||||
Result:=AIndex in Options;
|
||||
end;
|
||||
|
||||
function TBaseJSONReader.GetOptions: TJSONOptions;
|
||||
begin
|
||||
Result:=FScanner.Options
|
||||
end;
|
||||
|
||||
procedure TBaseJSONReader.SetO(AIndex: TJSONOption; AValue: Boolean);
|
||||
begin
|
||||
if aValue then
|
||||
FScanner.Options:=FScanner.Options+[AINdex]
|
||||
else
|
||||
FScanner.Options:=FScanner.Options-[AINdex]
|
||||
end;
|
||||
|
||||
procedure TBaseJSONReader.SetOptions(AValue: TJSONOptions);
|
||||
begin
|
||||
FScanner.Options:=AValue;
|
||||
end;
|
||||
|
||||
|
||||
// Current token is {, on exit current token is }
|
||||
Procedure TBaseJSONReader.ParseObject;
|
||||
|
||||
Var
|
||||
T : TJSONtoken;
|
||||
LastComma : Boolean;
|
||||
|
||||
begin
|
||||
LastComma:=False;
|
||||
StartObject;
|
||||
T:=GetNextToken;
|
||||
While T<>tkCurlyBraceClose do
|
||||
begin
|
||||
If (T<>tkString) and (T<>tkIdentifier) then
|
||||
DoError(SErrExpectedElementName);
|
||||
KeyValue(CurrentTokenString);
|
||||
T:=GetNextToken;
|
||||
If (T<>tkColon) then
|
||||
DoError(SErrExpectedColon);
|
||||
DoParse(False,False);
|
||||
T:=GetNextToken;
|
||||
If Not (T in [tkComma,tkCurlyBraceClose]) then
|
||||
DoError(SExpectedCommaorBraceClose);
|
||||
If T=tkComma then
|
||||
begin
|
||||
T:=GetNextToken;
|
||||
LastComma:=(t=tkCurlyBraceClose);
|
||||
end;
|
||||
end;
|
||||
If LastComma and ((joStrict in Options) or not (joIgnoreTrailingComma in Options)) then // Test for ,} case
|
||||
DoError(SErrUnExpectedToken);
|
||||
EndObject;
|
||||
end;
|
||||
|
||||
// Current token is [, on exit current token is ]
|
||||
Procedure TBaseJSONReader.ParseArray;
|
||||
|
||||
Var
|
||||
T : TJSONtoken;
|
||||
LastComma : Boolean;
|
||||
S : TJSONOPTions;
|
||||
|
||||
begin
|
||||
StartArray;
|
||||
LastComma:=False;
|
||||
Repeat
|
||||
T:=GetNextToken;
|
||||
If (T<>tkSquaredBraceClose) then
|
||||
begin
|
||||
DoParse(True,False);
|
||||
T:=GetNextToken;
|
||||
If Not (T in [tkComma,tkSquaredBraceClose]) then
|
||||
DoError(SExpectedCommaorBraceClose);
|
||||
LastComma:=(t=TkComma);
|
||||
end;
|
||||
Until (T=tkSquaredBraceClose);
|
||||
S:=Options;
|
||||
If LastComma and ((joStrict in S) or not (joIgnoreTrailingComma in S)) then // Test for ,] case
|
||||
DoError(SErrUnExpectedToken);
|
||||
EndArray;
|
||||
end;
|
||||
|
||||
// Get next token, discarding whitespace
|
||||
function TBaseJSONReader.GetNextToken: TJSONToken;
|
||||
|
||||
begin
|
||||
Repeat
|
||||
Result:=FScanner.FetchToken;
|
||||
Until (Not (Result in [tkComment,tkWhiteSpace]));
|
||||
end;
|
||||
|
||||
procedure TBaseJSONReader.DoError(const Msg: String);
|
||||
|
||||
Var
|
||||
S : String;
|
||||
|
||||
begin
|
||||
S:=Format(Msg,[CurrentTokenString]);
|
||||
S:=Format('Error at line %d, Pos %d:',[FScanner.CurRow,FSCanner.CurColumn])+S;
|
||||
Raise EJSONParser.Create(S);
|
||||
end;
|
||||
|
||||
constructor TBaseJSONReader.Create(Source: TStream; AUseUTF8 : Boolean = True);
|
||||
begin
|
||||
Inherited Create;
|
||||
FScanner:=TJSONScanner.Create(Source,[joUTF8]);
|
||||
if AUseUTF8 then
|
||||
Options:=Options + [joUTF8];
|
||||
end;
|
||||
|
||||
constructor TBaseJSONReader.Create(Source: TJSONStringType; AUseUTF8 : Boolean = True);
|
||||
begin
|
||||
Inherited Create;
|
||||
FScanner:=TJSONScanner.Create(Source,[joUTF8]);
|
||||
if AUseUTF8 then
|
||||
Options:=Options + [joUTF8];
|
||||
end;
|
||||
|
||||
constructor TBaseJSONReader.Create(Source: TStream; AOptions: TJSONOptions);
|
||||
begin
|
||||
FScanner:=TJSONScanner.Create(Source,AOptions);
|
||||
end;
|
||||
|
||||
constructor TBaseJSONReader.Create(const Source: RawByteString; AOptions: TJSONOptions);
|
||||
begin
|
||||
FScanner:=TJSONScanner.Create(Source,AOptions);
|
||||
end;
|
||||
|
||||
destructor TBaseJSONReader.Destroy();
|
||||
begin
|
||||
FreeAndNil(FScanner);
|
||||
inherited Destroy();
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
|
|
@ -0,0 +1,568 @@
|
|||
{
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
//modifed by Red_prig
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
|
||||
{$ifdef fpc}
|
||||
{$define UsePChar}
|
||||
{$endif}
|
||||
|
||||
unit Ujsonscanner;
|
||||
|
||||
interface
|
||||
|
||||
uses SysUtils, Classes,bufstream,Ufpjson;
|
||||
|
||||
resourcestring
|
||||
SErrInvalidCharacter = 'Invalid character at line %d, pos %d: ''%s''';
|
||||
SUnterminatedComment = 'Unterminated comment at line %d, pos %d: ''%s''';
|
||||
SErrOpenString = 'string exceeds end of line %d';
|
||||
|
||||
type
|
||||
|
||||
TJSONToken = (
|
||||
tkEOF,
|
||||
tkWhitespace,
|
||||
tkString,
|
||||
tkNumber,
|
||||
tkTrue,
|
||||
tkFalse,
|
||||
tkNull,
|
||||
// Simple (one-character) tokens
|
||||
tkComma, // ','
|
||||
tkColon, // ':'
|
||||
tkCurlyBraceOpen, // '{'
|
||||
tkCurlyBraceClose, // '}'
|
||||
tkSquaredBraceOpen, // '['
|
||||
tkSquaredBraceClose, // ']'
|
||||
tkIdentifier, // Any Javascript identifier
|
||||
tkComment,
|
||||
tkUnknown
|
||||
);
|
||||
|
||||
EScannerError = class(EParserError);
|
||||
|
||||
TJSONOption = (joUTF8,joStrict,joComments,joIgnoreTrailingComma);
|
||||
TJSONOptions = set of TJSONOption;
|
||||
|
||||
Const
|
||||
DefaultOptions = [joUTF8];
|
||||
|
||||
Type
|
||||
|
||||
TJSONSInFlag=Set of (ifFreeSource,ifPrevChar,ifEOF);
|
||||
|
||||
{ TJSONScanner }
|
||||
|
||||
TJSONScanner = class
|
||||
private
|
||||
FSource:TStream;
|
||||
FInFlag:TJSONSInFlag;
|
||||
|
||||
FCurRow,FCurColumn: Integer;
|
||||
FCurToken: TJSONToken;
|
||||
FCurTokenString: RawBytestring;
|
||||
FCurChar:AnsiChar;
|
||||
|
||||
FOptions : TJSONOptions;
|
||||
|
||||
FAddStr:TUtf8AddStr;
|
||||
|
||||
function GetO(AIndex: TJSONOption): Boolean;
|
||||
procedure SetO(AIndex: TJSONOption; AValue: Boolean);
|
||||
protected
|
||||
procedure Error(const Msg: string);overload;
|
||||
procedure Error(const Msg: string;
|
||||
Const Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif});overload;
|
||||
function DoFetchToken: TJSONToken; inline;
|
||||
public
|
||||
{$ifdef fpc}
|
||||
constructor Create(Source : TStream; AUseUTF8 : Boolean = True); overload; deprecated 'use options form instead';
|
||||
constructor Create(const Source : RawByteString; AUseUTF8 : Boolean = True); overload; deprecated 'use options form instead';
|
||||
constructor Create(Source: TStream; AOptions: TJSONOptions); overload;
|
||||
{$endif}
|
||||
constructor Create(const Source: RawByteString; AOptions: TJSONOptions); overload;
|
||||
destructor Destroy; override;
|
||||
function FetchToken: TJSONToken;
|
||||
|
||||
function NextChar:Boolean;
|
||||
Procedure StepPrev; inline;
|
||||
|
||||
//property CurLine: RawBytestring read FCurLine;
|
||||
property CurRow: Integer read FCurRow;
|
||||
property CurColumn: Integer read FCurColumn;
|
||||
|
||||
property CurToken: TJSONToken read FCurToken;
|
||||
property CurTokenString: RawBytestring read FCurTokenString;
|
||||
// Use strict JSON: " for strings, object members are strings, not identifiers
|
||||
Property Strict : Boolean Index joStrict Read GetO Write SetO ; deprecated 'use options instead';
|
||||
// if set to TRUE, then strings will be converted to UTF8 ansistrings, not system codepage ansistrings.
|
||||
Property UseUTF8 : Boolean index joUTF8 Read GetO Write SetO; deprecated 'Use options instead';
|
||||
// Parsing options
|
||||
Property Options : TJSONOptions Read FOptions Write FOptions;
|
||||
end;
|
||||
|
||||
const
|
||||
TokenInfos: array[TJSONToken] of RawBytestring = (
|
||||
'EOF',
|
||||
'Whitespace',
|
||||
'String',
|
||||
'Number',
|
||||
'True',
|
||||
'False',
|
||||
'Null',
|
||||
',',
|
||||
':',
|
||||
'{',
|
||||
'}',
|
||||
'[',
|
||||
']',
|
||||
'identifier',
|
||||
'comment',
|
||||
''
|
||||
);
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{$ifdef fpc}
|
||||
constructor TJSONScanner.Create(Source : TStream; AUseUTF8 : Boolean = True);
|
||||
|
||||
Var
|
||||
O : TJSONOptions;
|
||||
|
||||
begin
|
||||
O:=DefaultOptions;
|
||||
if AUseUTF8 then
|
||||
Include(O,joUTF8)
|
||||
else
|
||||
Exclude(O,joUTF8);
|
||||
Create(Source,O);
|
||||
end;
|
||||
|
||||
constructor TJSONScanner.Create(const Source : RawByteString; AUseUTF8 : Boolean = True);
|
||||
Var
|
||||
O : TJSONOptions;
|
||||
|
||||
begin
|
||||
O:=DefaultOptions;
|
||||
if AUseUTF8 then
|
||||
Include(O,joUTF8)
|
||||
else
|
||||
Exclude(O,joUTF8);
|
||||
Create(Source,O);
|
||||
end;
|
||||
|
||||
constructor TJSONScanner.Create(Source: TStream; AOptions: TJSONOptions);
|
||||
begin
|
||||
FAddStr:=Default(TUtf8AddStr);
|
||||
if Source.InheritsFrom(THandleStream) then
|
||||
begin
|
||||
FSource:=TReadBufStream.Create(Source,4*1024);
|
||||
FInFlag:=[ifFreeSource];
|
||||
end else
|
||||
begin
|
||||
FSource:=Source;
|
||||
end;
|
||||
|
||||
FOptions:=AOptions;
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
constructor TJSONScanner.Create(const Source: RawByteString; AOptions: TJSONOptions);
|
||||
begin
|
||||
FAddStr:=Default(TUtf8AddStr);
|
||||
FSource:=TStringStream.Create(Source);
|
||||
FInFlag:=[ifFreeSource];
|
||||
FOptions:=AOptions;
|
||||
end;
|
||||
|
||||
destructor TJSONScanner.Destroy;
|
||||
begin
|
||||
FAddStr.Free;
|
||||
if ifFreeSource in FInFlag then
|
||||
begin
|
||||
FreeAndNil(FSource);
|
||||
end;
|
||||
Inherited;
|
||||
end;
|
||||
|
||||
function TJSONScanner.NextChar:Boolean;
|
||||
begin
|
||||
if ifEOF in FInFlag then
|
||||
begin
|
||||
Result:=False;
|
||||
end;
|
||||
|
||||
if ifPrevChar in FInFlag then
|
||||
begin
|
||||
Result:=True;
|
||||
Exclude(FInFlag,ifPrevChar);
|
||||
end else
|
||||
begin
|
||||
Result:=FSource.Read(FCurChar,1)=1;
|
||||
if Result then
|
||||
begin
|
||||
Inc(FCurColumn);
|
||||
end else
|
||||
begin
|
||||
FCurToken:=tkEOF;
|
||||
Include(FInFlag,ifEOF);
|
||||
end;
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
Procedure TJSONScanner.StepPrev; inline;
|
||||
begin
|
||||
Include(FInFlag,ifPrevChar);
|
||||
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;
|
||||
const Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif});
|
||||
begin
|
||||
raise EScannerError.CreateFmt(Msg, Args);
|
||||
end;
|
||||
|
||||
function TJSONScanner.DoFetchToken: TJSONToken;
|
||||
|
||||
function CheckNextLine:Boolean; inline;
|
||||
begin
|
||||
Result:=False;
|
||||
if not NextChar then Exit;
|
||||
case FCurChar of
|
||||
#13:begin //next line
|
||||
Inc(FCurRow);
|
||||
if not NextChar then Exit;
|
||||
FCurColumn:=0;
|
||||
case FCurChar of
|
||||
#10:FCurColumn:=0;
|
||||
else
|
||||
StepPrev;
|
||||
end;
|
||||
end;
|
||||
#10:begin //next line
|
||||
Inc(FCurRow);
|
||||
if not NextChar then Exit;
|
||||
FCurColumn:=0;
|
||||
case FCurChar of
|
||||
#13:FCurColumn:=0;
|
||||
else
|
||||
StepPrev;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
Result:=True;
|
||||
end;
|
||||
|
||||
var
|
||||
it : TJSONToken;
|
||||
I : Integer;
|
||||
tstart,tcol, u2: Integer;
|
||||
C , c2: char;
|
||||
|
||||
|
||||
begin
|
||||
|
||||
if not NextChar then Exit(tkEOF);
|
||||
|
||||
if (FCurRow=0) then
|
||||
begin
|
||||
FCurRow:=1;
|
||||
if (FCurColumn=1) then
|
||||
begin
|
||||
if (FCurChar=#$EF) then
|
||||
begin
|
||||
if not NextChar then Exit(tkEOF);
|
||||
if (FCurChar=#$BB) then
|
||||
begin
|
||||
if not NextChar then Exit(tkEOF);
|
||||
if (FCurChar=#$BF) then
|
||||
begin
|
||||
if not NextChar then Exit(tkEOF);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
FCurColumn:=1;
|
||||
end;
|
||||
|
||||
FCurTokenString := '';
|
||||
|
||||
case FCurChar of
|
||||
#13:begin //next line
|
||||
Result := tkWhitespace;
|
||||
Inc(FCurRow);
|
||||
if not NextChar then Exit;
|
||||
FCurColumn:=0;
|
||||
case FCurChar of
|
||||
#10:FCurColumn:=0;
|
||||
else
|
||||
StepPrev;
|
||||
end;
|
||||
end;
|
||||
#10:begin //next line
|
||||
Result := tkWhitespace;
|
||||
Inc(FCurRow);
|
||||
if not NextChar then Exit;
|
||||
FCurColumn:=0;
|
||||
case FCurChar of
|
||||
#13:FCurColumn:=0;
|
||||
else
|
||||
StepPrev;
|
||||
end;
|
||||
end;
|
||||
#0,#9, ' ':
|
||||
begin
|
||||
Result := tkWhitespace;
|
||||
repeat
|
||||
if not CheckNextLine then Exit;
|
||||
until not (FCurChar in [#0,#9, ' ']);
|
||||
StepPrev;
|
||||
end;
|
||||
'"','''':
|
||||
begin
|
||||
C:=FCurChar;
|
||||
If (C='''') and (joStrict in Options) then
|
||||
Error(SErrInvalidCharacter, [CurRow,CurColumn,FCurChar]);
|
||||
if not NextChar then Exit(tkEOF);
|
||||
FAddStr.Reset;
|
||||
while not (FCurChar in [#0,#13,#10,C]) do
|
||||
begin
|
||||
if (FCurChar='\') then
|
||||
begin
|
||||
if not NextChar then
|
||||
begin
|
||||
Error(SErrOpenString,[FCurRow]);
|
||||
Exit(tkEOF);
|
||||
end;
|
||||
Case FCurChar of
|
||||
't' : FAddStr.AddChar(#9);
|
||||
'b' : FAddStr.AddChar(#8);
|
||||
'n' : FAddStr.AddChar(#10);
|
||||
'r' : FAddStr.AddChar(#13);
|
||||
'f' : FAddStr.AddChar(#12);
|
||||
'u' : begin
|
||||
u2:=0;
|
||||
For I:=1 to 4 do
|
||||
begin
|
||||
if not NextChar then Exit(tkEOF);
|
||||
c2:=FCurChar;
|
||||
Case c2 of
|
||||
'0'..'9': u2:=u2*16+ord(c2)-ord('0');
|
||||
'A'..'F': u2:=u2*16+ord(c2)-ord('A')+10;
|
||||
'a'..'f': u2:=u2*16+ord(c2)-ord('a')+10;
|
||||
else
|
||||
Error(SErrInvalidCharacter, [CurRow,CurColumn,FCurChar]);
|
||||
end;
|
||||
end;
|
||||
FAddStr.AddWideChar(WideChar(u2));
|
||||
end;
|
||||
else
|
||||
FAddStr.AddChar(FCurChar);
|
||||
end;
|
||||
end else
|
||||
begin
|
||||
FAddStr.AddChar(FCurChar);
|
||||
end;
|
||||
if not NextChar then Exit(tkEOF);
|
||||
end;
|
||||
if (FCurChar in [#0,#13,#10]) then
|
||||
Error(SErrOpenString,[FCurRow]);
|
||||
|
||||
Result:=tkString;
|
||||
FCurTokenString:=FAddStr.GetStr;
|
||||
end;
|
||||
',':
|
||||
begin
|
||||
Result := tkComma;
|
||||
end;
|
||||
'0'..'9','.','-':
|
||||
begin
|
||||
FAddStr.Reset;
|
||||
FAddStr.AddChar(FCurChar);
|
||||
while NextChar do
|
||||
begin
|
||||
|
||||
case FCurChar of
|
||||
'.':
|
||||
begin
|
||||
FAddStr.AddChar(FCurChar);
|
||||
if not NextChar then Break;
|
||||
//FAddStr.AddChar(FCurChar);
|
||||
if FCurChar in ['0'..'9', 'e', 'E'] then
|
||||
begin
|
||||
//if not NextChar then Break;
|
||||
repeat
|
||||
FAddStr.AddChar(FCurChar);
|
||||
if not NextChar then Break;
|
||||
until not (FCurChar in ['0'..'9', 'e', 'E','-','+']);
|
||||
end;
|
||||
StepPrev;
|
||||
break;
|
||||
end;
|
||||
'0'..'9':FAddStr.AddChar(FCurChar);
|
||||
'e', 'E':
|
||||
begin
|
||||
FAddStr.AddChar(FCurChar);
|
||||
if not NextChar then Break;
|
||||
FAddStr.AddChar(FCurChar);
|
||||
if FCurChar in ['-','+'] then
|
||||
begin
|
||||
if not NextChar then Break;
|
||||
end;
|
||||
while FCurChar in ['0'..'9'] do
|
||||
begin
|
||||
FAddStr.AddChar(FCurChar);
|
||||
if not NextChar then Break;
|
||||
end;
|
||||
StepPrev;
|
||||
break;
|
||||
end;
|
||||
else
|
||||
if not (FCurChar in [#0,'}',']',',',#9,' ',#13,#10]) then
|
||||
Error(SErrInvalidCharacter, [CurRow,CurColumn,FCurChar]);
|
||||
StepPrev;
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
|
||||
FCurTokenString:=FAddStr.GetStr;
|
||||
If (FCurTokenString[1]='.') then
|
||||
FCurTokenString:='0'+FCurTokenString;
|
||||
Result := tkNumber;
|
||||
end;
|
||||
':':
|
||||
begin
|
||||
Result := tkColon;
|
||||
end;
|
||||
'{':
|
||||
begin
|
||||
Result := tkCurlyBraceOpen;
|
||||
end;
|
||||
'}':
|
||||
begin
|
||||
Result := tkCurlyBraceClose;
|
||||
end;
|
||||
'[':
|
||||
begin
|
||||
Result := tkSquaredBraceOpen;
|
||||
end;
|
||||
']':
|
||||
begin
|
||||
Result := tkSquaredBraceClose;
|
||||
end;
|
||||
'/' :
|
||||
begin
|
||||
if Not (joComments in Options) then
|
||||
Error(SErrInvalidCharacter, [CurRow,CurCOlumn,FCurChar]);
|
||||
FAddStr.Reset;
|
||||
FAddStr.AddChar(FCurChar);
|
||||
Case FCurChar of
|
||||
'/' : begin
|
||||
i:=FCurRow;
|
||||
While (i=FCurRow) do
|
||||
begin
|
||||
if not CheckNextLine then Break;
|
||||
FAddStr.AddChar(FCurChar);
|
||||
end;
|
||||
FCurTokenString:=FAddStr.GetStr;
|
||||
end;
|
||||
'*' :
|
||||
begin
|
||||
|
||||
if not CheckNextLine then
|
||||
begin
|
||||
Error(SUnterminatedComment, [CurRow,CurCOlumn,FCurChar]);
|
||||
Exit(tkEOF);
|
||||
end;
|
||||
|
||||
repeat
|
||||
FAddStr.AddChar(FCurChar);
|
||||
c:=FCurChar;
|
||||
if not CheckNextLine then
|
||||
begin
|
||||
Error(SUnterminatedComment, [CurRow,CurCOlumn,FCurChar]);
|
||||
Break;
|
||||
end;
|
||||
until (c='*') and (FCurChar='/');
|
||||
|
||||
FCurTokenString:=FAddStr.GetStr;
|
||||
end;
|
||||
else
|
||||
Error(SErrInvalidCharacter, [CurRow,CurCOlumn,FCurChar]);
|
||||
end;
|
||||
Result:=tkComment;
|
||||
end;
|
||||
'a'..'z','A'..'Z','_':
|
||||
begin
|
||||
FAddStr.Reset;
|
||||
|
||||
tStart:=CurRow;
|
||||
tcol :=CurColumn;
|
||||
|
||||
repeat
|
||||
FAddStr.AddChar(FCurChar);
|
||||
if not NextChar then Break;
|
||||
until not (FCurChar in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
|
||||
StepPrev;
|
||||
|
||||
FCurTokenString:=FAddStr.GetStr;
|
||||
|
||||
for it := tkTrue to tkNull do
|
||||
if CompareText(FCurTokenString, TokenInfos[it]) = 0 then
|
||||
begin
|
||||
Result := it;
|
||||
FCurToken := Result;
|
||||
exit;
|
||||
end;
|
||||
|
||||
if (joStrict in Options) then
|
||||
Error(SErrInvalidCharacter, [tStart,tcol,FCurTokenString])
|
||||
else
|
||||
Result:=tkIdentifier;
|
||||
end;
|
||||
else
|
||||
Error(SErrInvalidCharacter, [CurRow,CurColumn,FCurChar]);
|
||||
end;
|
||||
|
||||
FCurToken:=Result;
|
||||
end;
|
||||
|
||||
function TJSONScanner.GetO(AIndex: TJSONOption): Boolean;
|
||||
begin
|
||||
Result:=AIndex in FOptions;
|
||||
end;
|
||||
|
||||
procedure TJSONScanner.SetO(AIndex: TJSONOption; AValue: Boolean);
|
||||
begin
|
||||
If AValue then
|
||||
Include(Foptions,AIndex)
|
||||
else
|
||||
Exclude(Foptions,AIndex)
|
||||
end;
|
||||
|
||||
end.
|
||||
Loading…
Reference in New Issue