?? ulkjson.pas
字號:
begin
js := FieldByIndex[idx] as TlkJSONstring;
if not assigned(js) then result := ''
else result := vartostr(js.Value);
end;
function TlkJSONobject.getWideString(idx: Integer): WideString;
var
js:TlkJSONstring;
begin
js := FieldByIndex[idx] as TlkJSONstring;
if not assigned(js) then result := ''
else result := VarToWideStr(js.Value);
end;
function TlkJSONobject.getDouble(nm: String): Double;
begin
result := getDouble(IndexOfName(nm));
end;
function TlkJSONobject.getInt(nm: String): Integer;
begin
result := getInt(IndexOfName(nm));
end;
function TlkJSONobject.getString(nm: String): String;
begin
result := getString(IndexOfName(nm));
end;
function TlkJSONobject.getWideString(nm: String): WideString;
begin
result := getWideString(IndexOfName(nm));
end;
function TlkJSONobject.getBoolean(idx: Integer): Boolean;
var
jb:TlkJSONboolean;
begin
jb := FieldByIndex[idx] as TlkJSONboolean;
if not assigned(jb) then result := false
else result := jb.Value;
end;
function TlkJSONobject.getBoolean(nm: String): Boolean;
begin
result := getBoolean(IndexOfName(nm));
end;
{ TlkJSON }
class function TlkJSON.GenerateText(obj: TlkJSONbase): string;
var
{$IFDEF HAVE_FORMATSETTING}
fs: TFormatSettings;
{$ENDIF}
pt1,pt0,pt2:PAnsiChar;
ptsz:cardinal;
{$ifndef NEW_STYLE_GENERATE}
function gn_base(obj: TlkJSONbase): string;
var
ws: string;
i, j: Integer;
xs: TlkJSONstring;
begin
result := '';
if not assigned(obj) then exit;
if obj is TlkJSONnumber then
begin
{$ifdef HAVE_FORMATSETTING}
result := FloatToStr(TlkJSONnumber(obj).FValue, fs);
{$else}
result := FloatToStr(TlkJSONnumber(obj).FValue);
i := pos(DecimalSeparator, result);
if (DecimalSeparator <> '.') and (i > 0) then
result[i] := '.';
{$endif}
end
else if obj is TlkJSONstring then
begin
ws := UTF8Encode(TlkJSONstring(obj).FValue);
i := 1;
result := '"';
while i <= length(ws) do
begin
case ws[i] of
'/', '\', '"': result := result + '\' + ws[i];
#8: result := result + '\b';
#9: result := result + '\t';
#10: result := result + '\n';
#13: result := result + '\r';
#12: result := result + '\f';
else
if ord(ws[i]) < 32 then
result := result + '\u' + inttohex(ord(ws[i]), 4)
else
result := result + ws[i];
end;
inc(i);
end;
result := result + '"';
end
else if obj is TlkJSONboolean then
begin
if TlkJSONboolean(obj).FValue then
result := 'true'
else
result := 'false';
end
else if obj is TlkJSONnull then
begin
result := 'null';
end
else if obj is TlkJSONlist then
begin
result := '[';
j := TlkJSONobject(obj).Count - 1;
for i := 0 to j do
begin
if i > 0 then result := result + ',';
result := result + gn_base(TlkJSONlist(obj).Child[i]);
end;
result := result + ']';
end
else if obj is TlkJSONobjectmethod then
begin
try
xs := TlkJSONstring.Create;
xs.FValue := TlkJSONobjectmethod(obj).FName;
result := gn_base(TlkJSONbase(xs)) + ':';
result := result +
gn_base(TlkJSONbase(TlkJSONobjectmethod(obj).FValue));
finally
if assigned(xs) then FreeAndNil(xs);
end;
end
else if obj is TlkJSONobject then
begin
result := '{';
j := TlkJSONobject(obj).Count - 1;
for i := 0 to j do
begin
if i > 0 then result := result + ',';
result := result + gn_base(TlkJSONobject(obj).Child[i]);
end;
result := result + '}';
end;
end;
{$else}
procedure get_more_memory;
var delta: Integer;
begin
delta := 20000;
if pt0 = nil then
begin
pt0 := AllocMem(delta);
ptsz := 0;
pt1 := pt0;
end
else
begin
ReallocMem(pt0,ptsz+delta);
pt1 := pointer(cardinal(pt0)+ptsz);
end;
ptsz := ptsz + delta;
pt2 := pointer(cardinal(pt1)+delta);
end;
procedure mem_ch(ch:char);
begin
if pt1 >= pt2 then get_more_memory;
pt1^ := ch;
inc(pt1);
end;
procedure mem_write(rs: String);
var i: Integer;
begin
for i := 1 to length(rs) do
begin
if pt1 >= pt2 then get_more_memory;
pt1^ := rs[i];
inc(pt1);
end;
end;
procedure gn_base(obj: TlkJSONbase);
var
ws: string;
i, j: Integer;
xs: TlkJSONstring;
begin
if not assigned(obj) then exit;
if obj is TlkJSONnumber then
begin
{$ifdef HAVE_FORMATSETTING}
mem_write(FloatToStr(TlkJSONnumber(obj).FValue, fs));
{$else}
ws := FloatToStr(TlkJSONnumber(obj).FValue);
i := pos(DecimalSeparator, ws);
if (DecimalSeparator <> '.') and (i > 0) then ws[i] := '.';
mem_write(ws);
{$endif}
end
else if obj is TlkJSONstring then
begin
ws := UTF8Encode(TlkJSONstring(obj).FValue);
i := 1;
mem_ch('"');
while i <= length(ws) do
begin
case ws[i] of
'/', '\', '"':
begin
mem_ch('\');
mem_ch(ws[i]);
end;
#8: mem_write('\b');
#9: mem_write('\t');
#10: mem_write('\n');
#13: mem_write('\r');
#12: mem_write('\f');
else
if ord(ws[i]) < 32 then
mem_write('\u' + inttohex(ord(ws[i]), 4))
else
mem_ch(ws[i]);
end;
inc(i);
end;
mem_ch('"');
end
else if obj is TlkJSONboolean then
begin
if TlkJSONboolean(obj).FValue then
mem_write('true')
else
mem_write('false');
end
else if obj is TlkJSONnull then
begin
mem_write('null');
end
else if obj is TlkJSONlist then
begin
mem_ch('[');
j := TlkJSONobject(obj).Count - 1;
for i := 0 to j do
begin
if i > 0 then mem_ch(',');
gn_base(TlkJSONlist(obj).Child[i]);
end;
mem_ch(']');
end
else if obj is TlkJSONobjectmethod then
begin
try
xs := TlkJSONstring.Create;
xs.FValue := TlkJSONobjectmethod(obj).FName;
gn_base(TlkJSONbase(xs));
mem_ch(':');
gn_base(TlkJSONbase(TlkJSONobjectmethod(obj).FValue));
finally
if assigned(xs) then FreeAndNil(xs);
end;
end
else if obj is TlkJSONobject then
begin
mem_ch('{');
j := TlkJSONobject(obj).Count - 1;
for i := 0 to j do
begin
if i>0 then mem_ch(',');
gn_base(TlkJSONobject(obj).Child[i]);
end;
mem_ch('}');
end;
end;
{$endif NEW_STYLE_GENERATE}
begin
{$ifdef HAVE_FORMATSETTING}
GetLocaleFormatSettings(GetThreadLocale, fs);
fs.DecimalSeparator := '.';
{$endif}
{$ifdef NEW_STYLE_GENERATE}
pt0 := nil;
get_more_memory;
gn_base(obj);
mem_ch(#0);
result := string(pt0);
freemem(pt0);
{$else}
result := gn_base(obj);
{$endif}
end;
class function TlkJSON.ParseText(const txt: string): TlkJSONbase;
{$ifdef HAVE_FORMATSETTING}
var
fs: TFormatSettings;
{$endif}
function js_base(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean; forward;
function xe(idx: Integer): Boolean;{$IFDEF FPC}inline;{$ENDIF}
begin
result := idx <= length(txt);
end;
procedure skip_spc(var idx: Integer);{$IFDEF FPC}inline;{$ENDIF}
begin
while (xe(idx)) and (ord(txt[idx]) < 33) do
inc(idx);
end;
procedure add_child(var o, c: TlkJSONbase);
var
i: Integer;
begin
if o = nil then
begin
o := c;
end
else
begin
if o is TlkJSONobjectmethod then
begin
TlkJSONobjectmethod(o).FValue := c;
end
else if o is TlkJSONlist then
begin
TlkJSONlist(o)._Add(c);
end
else if o is TlkJSONobject then
begin
i := TlkJSONobject(o)._Add(c);
if TlkJSONobject(o).UseHash then
TlkJSONobject(o).ht.AddPair(TlkJSONobjectmethod(c).Name, i);
end;
end;
end;
function js_boolean(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
var
js: TlkJSONboolean;
begin
skip_spc(idx);
if copy(txt, idx, 4) = 'true' then
begin
result := true;
ridx := idx + 4;
js := TlkJSONboolean.Create;
js.FValue := true;
add_child(o, TlkJSONbase(js));
end
else if copy(txt, idx, 5) = 'false' then
begin
result := true;
ridx := idx + 5;
js := TlkJSONboolean.Create;
js.FValue := false;
add_child(o, TlkJSONbase(js));
end
else
begin
result := false;
end;
end;
function js_null(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
var
js: TlkJSONnull;
begin
skip_spc(idx);
if copy(txt, idx, 4) = 'null' then
begin
result := true;
ridx := idx + 4;
js := TlkJSONnull.Create;
add_child(o, TlkJSONbase(js));
end
else
begin
result := false;
end;
end;
function js_integer(idx: Integer; var ridx: Integer): Boolean;
begin
result := false;
while (xe(idx)) and (txt[idx] in ['0'..'9']) do
begin
result := true;
inc(idx);
end;
if result then ridx := idx;
end;
function js_number(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
var
js: TlkJSONnumber;
ws: string;
{$IFNDEF HAVE_FORMATSETTING}
i: Integer;
{$ENDIF}
begin
skip_spc(idx);
result := xe(idx);
if not result then exit;
if txt[idx] in ['+', '-'] then
begin
inc(idx);
result := xe(idx);
end;
if not result then exit;
result := js_integer(idx, idx);
if not result then exit;
if (xe(idx)) and (txt[idx] = '.') then
begin
inc(idx);
result := js_integer(idx, idx);
if not result then exit;
end;
if (xe(idx)) and (txt[idx] in ['e', 'E']) then
begin
inc(idx);
if (xe(idx)) and (txt[idx] in ['+', '-']) then inc(idx);
result := js_integer(idx, idx);
if not result then exit;
end;
if not result then exit;
js := TlkJSONnumber.Create;
ws := copy(txt, ridx, idx - ridx);
{$IFDEF HAVE_FORMATSETTING}
js.FValue := StrToFloat(ws, fs);
{$ELSE}
i := pos('.', ws);
if (DecimalSeparator <> '.') and (i > 0) then
ws[pos('.', ws)] := DecimalSeparator;
js.FValue := StrToFloat(ws);
{$ENDIF}
add_child(o, TlkJSONbase(js));
ridx := idx;
end;
function js_string(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
var
js: TlkJSONstring;
fin: Boolean;
ws: WideString;
begin
skip_spc(idx);
ws := '';
result := xe(idx);
if not result then exit;
result := txt[idx] = '"';
if not result then exit;
inc(idx);
result := false;
repeat
fin := not xe(idx);
if not fin then
begin
if txt[idx] = '\' then
begin
inc(idx);
if not xe(idx) then exit;
case txt[idx] of
'\': ws := ws + '\';
'"': ws := ws + '''';
'/': ws := ws + '/';
'b': ws := ws + #8;
'f': ws := ws + #12;
'n': ws := ws + #10;
'r': ws := ws + #13;
't': ws := ws + #9;
'u':
begin
// ws := ws + widechar(strtoint('$' +
// copy(txt, idx + 1, 4)));
ws := ws + code2utf(strtoint('$' + copy(txt, idx + 1, 4)));
idx := idx + 4;
end;
end;
end
else if txt[idx] <> '"' then
begin
ws := ws + txt[idx];
end
else
begin
fin := true;
result := true;
end;
inc(idx);
end;
until fin;
if not result then exit;
js := TlkJSONstring.Create;
js.FValue := UTF8Decode(ws);
add_child(o, TlkJSONbase(js));
ridx := idx;
end;
function js_list(idx: Integer; var ridx: Integer; var o:
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -