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
|
link.res
|
||||||
lib/
|
lib/
|
||||||
backup/
|
backup/
|
||||||
shader_dump/
|
shader_dump/*
|
||||||
spirv/
|
spirv/*
|
||||||
savedata/
|
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