?? ulkjson.pas
字號:
TlkJSONbase): Boolean;
var
js: TlkJSONlist;
begin
result := false;
try
js := TlkJSONlist.Create;
skip_spc(idx);
result := xe(idx);
if not result then exit;
result := txt[idx] = '[';
if not result then exit;
inc(idx);
while js_base(idx, idx, TlkJSONbase(js)) do
begin
skip_spc(idx);
if (xe(idx)) and (txt[idx] = ',') then inc(idx);
end;
result := (xe(idx)) and (txt[idx] = ']');
if not result then exit;
inc(idx);
finally
if not result then
begin
js.Free;
end
else
begin
add_child(o, TlkJSONbase(js));
ridx := idx;
end;
end;
end;
function js_method(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
var
mth: TlkJSONobjectmethod;
ws: TlkJSONstring;
begin
result := false;
try
ws := nil;
mth := TlkJSONobjectmethod.Create;
skip_spc(idx);
result := xe(idx);
if not result then exit;
result := js_string(idx, idx, TlkJSONbase(ws));
if not result then exit;
skip_spc(idx);
result := xe(idx) and (txt[idx] = ':');
if not result then exit;
inc(idx);
mth.FName := ws.FValue;
result := js_base(idx, idx, TlkJSONbase(mth));
finally
if ws <> nil then ws.Free;
if result then
begin
add_child(o, TlkJSONbase(mth));
ridx := idx;
end
else
begin
mth.Free;
end;
end;
end;
function js_object(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
var
js: TlkJSONobject;
begin
result := false;
try
js := TlkJSONobject.Create;
skip_spc(idx);
result := xe(idx);
if not result then exit;
result := txt[idx] = '{';
if not result then exit;
inc(idx);
while js_method(idx, idx, TlkJSONbase(js)) do
begin
skip_spc(idx);
if (xe(idx)) and (txt[idx] = ',') then inc(idx);
end;
result := (xe(idx)) and (txt[idx] = '}');
if not result then exit;
inc(idx);
finally
if not result then
begin
js.Free;
end
else
begin
add_child(o, TlkJSONbase(js));
ridx := idx;
end;
end;
end;
function js_base(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
begin
skip_spc(idx);
result := js_boolean(idx, idx, o);
if not result then result := js_null(idx, idx, o);
if not result then result := js_number(idx, idx, o);
if not result then result := js_string(idx, idx, o);
if not result then result := js_list(idx, idx, o);
if not result then result := js_object(idx, idx, o);
if result then ridx := idx;
end;
var
idx: Integer;
begin
{$ifdef HAVE_FORMATSETTING}
GetLocaleFormatSettings(GetThreadLocale, fs);
fs.DecimalSeparator := '.';
{$endif}
result := nil;
if txt = '' then exit;
try
idx := 1;
if not js_base(idx, idx, result) then FreeAndNil(result);
except
if assigned(result) then FreeAndNil(result);
end;
end;
{ ElkIntException }
constructor ElkIntException.Create(idx: Integer; msg: string);
begin
self.idx := idx;
inherited Create(msg);
end;
{ TlkHashTable }
procedure TlkHashTable.AddPair(const ws: WideString; idx: Integer);
var
i, j, k: cardinal;
p,p2: PlkHashItem;
begin
if InTable(ws, i, j, k) then
begin
// if string is already in table, changing index
// a_h[j, k].index := idx;
PlkHashItem(a_x[j].Items[k])^.index := idx;
end
else
begin
// k := length(a_h[j]);
// SetLength(a_h[j], k + 1);
// a_h[j, k].hash := i;
// a_h[j, k].index := idx;
//// sorting array of hashes
// while (k > 0) and (a_h[j, k].hash < a_h[j, k - 1].hash) do
// begin
// hswap(j, k, k - 1);
// dec(k);
// end;
//--- new version
GetMem(p,sizeof(TlkHashItem));
k := a_x[j].Add(p);
p^.hash := i;
p^.index := idx;
while (k>0) and (PlkHashItem(a_x[j].Items[k])^.hash <
PlkHashItem(a_x[j].Items[k-1])^.hash) do
begin
a_x[j].Exchange(k,k-1);
dec(k);
end;
end;
end;
function TlkHashTable.counters: string;
var
i, j: Integer;
ws: string;
begin
ws := '';
for i := 0 to 15 do
begin
for j := 0 to 15 do
// ws := ws + format('%.3d ', [length(a_h[i * 16 + j])]);
ws := ws + format('%.3d ', [a_x[i * 16 + j].Count]);
ws := ws + #13#10;
end;
result := ws;
end;
procedure TlkHashTable.Delete(const ws: WideString);
var
i, j, k: cardinal;
begin
if InTable(ws, i, j, k) then
begin
// while k < high(a_h[j]) do
// begin
// hswap(j, k, k + 1);
// inc(k);
// end;
// SetLength(a_h[j], k);
FreeMem(a_x[j].Items[k]);
a_x[j].Delete(k);
end;
end;
{$IFDEF THREADSAFE}
const
rnd_table: array[0..255] of byte =
(216,191,234,201,12,163,190,205,128,199,210,17,52,43,38,149,40,207,186,89,92,179,142,93,208,215,162,
161,132,59,246,37,120,223,138,233,172,195,94,237,32,231,114,49,212,75,198,181,200,239,90,121,252,211,
46,125,112,247,66,193,36,91,150,69,24,255,42,9,76,227,254,13,192,7,18,81,116,107,102,213,104,15,250,
153,156,243,206,157,16,23,226,225,196,123,54,101,184,31,202,41,236,3,158,45,96,39,178,113,20,139,6,
245,8,47,154,185,60,19,110,189,176,55,130,1,100,155,214,133,88,63,106,73,140,35,62,77,0,71,82,145,180,
171,166,21,168,79,58,217,220,51,14,221,80,87,34,33,4,187,118,165,248,95,10,105,44,67,222,109,160,103,
242,177,84,203,70,53,72,111,218,249,124,83,174,253,240,119,194,65,164,219,22,197,152,127,170,137,204,
99,126,141,64,135,146,209,244,235,230,85,232,143,122,25,28,115,78,29,144,151,98,97,68,251,182,229,56,
159,74,169,108,131,30,173,224,167,50,241,148,11,134,117,136,175,26,57,188,147,238,61,48,183,2,129,
228,27,86,5);
{$ELSE}
var
rnd_table: array[0..255] of byte;
{$ENDIF}
function TlkHashTable.DefaultHashOf(const ws: WideString): cardinal;
{$IFDEF DOTNET}
var
i, j: Integer;
x1, x2, x3, x4: byte;
begin
result := 0;
// result := 0;
x1 := 0;
x2 := 1;
for i := 1 to length(ws) do
begin
j := ord(ws[i]);
// first version of hashing
x1 := (x1 + j) {and $FF};
x2 := (x2 + 1 + (j shr 8)) {and $FF};
x3 := rnd_table[x1];
x4 := rnd_table[x3];
result := ((x1 * x4) + (x2 * x3)) xor result;
end;
end;
{$ELSE}
var
x1, x2, x3, x4: byte;
p: PWideChar;
begin
result := 0;
x1 := 0;
x2 := 1;
p := PWideChar(ws);
while p^ <> #0 do
begin
inc(x1, ord(p^)) {and $FF};
inc(x2, 1 + (ord(p^) shr 8)) {and $FF};
x3 := rnd_table[x1];
x4 := rnd_table[x3];
result := ((x1 * x4) + (x2 * x3)) xor result;
inc(p);
end;
end;
{$ENDIF}
procedure TlkHashTable.hswap(j, k, l: Integer);
var
h: TlkHashItem;
begin
// h := a_h[j, k];
// a_h[j, k] := a_h[j, l];
// a_h[j, l] := h;
a_x[j].Exchange(k,l);
end;
function TlkHashTable.IndexOf(const ws: WideString): Integer;
var
i, j, k: Cardinal;
begin
if not InTable(ws, i, j, k) then
begin
result := -1;
end
else
begin
// result := a_h[j, k].index;
result := PlkHashItem(a_x[j].Items[k])^.index;
end;
end;
function TlkHashTable.InTable(const ws: WideString; var i, j, k: cardinal):
Boolean;
var
l, wu, wl: Integer;
x: Cardinal;
fin: Boolean;
begin
i := HashOf(ws);
j := i and $FF;
result := false;
// if length(a_h[j]) < 25 then
if a_x[j].Count < 25 then
begin
//// for small array use linear search
// for l := 0 to high(a_h[j]) do
// if a_h[j, l].hash = i then
// begin
// k := l;
// result := true;
// break;
// end;
for l := 0 to a_x[j].Count-1 do
if PlkHashItem(a_x[j].Items[l])^.hash = i then
begin
k := l;
result := true;
break;
end;
end
else
begin
// for larger array use "binary" search, becouse array is sorted
// wl := low(a_h[j]);
// wu := high(a_h[j]);
wl := 0;
wu := a_x[j].Count-1;
repeat
fin := true;
if PlkHashItem(a_x[j].Items[wl])^.hash = i then
begin
k := wl;
result := true;
end
else if PlkHashItem(a_x[j].Items[wu])^.hash = i then
begin
k := wu;
result := true;
end
else if (wu - wl) > 1 then
begin
fin := false;
x := (wl + wu) shr 1;
if PlkHashItem(a_x[j].Items[x])^.hash > i then
begin
wu := x;
end
else
begin
wl := x;
end;
end;
until fin;
end;
end;
{$ifndef THREADSAFE}
procedure init_rnd;
var
x0: Integer;
i: Integer;
begin
x0 := 5;
for i := 0 to 255 do
begin
x0 := (x0 * 29 + 71) and $FF;
rnd_table[i] := x0;
end;
end;
{$endif}
procedure TlkHashTable.SetHashFunction(const AValue: TlkHashFunction);
begin
FHashFunction := AValue;
end;
constructor TlkHashTable.Create;
var
i: Integer;
begin
inherited;
// for i := 0 to 255 do SetLength(a_h[i], 0);
for i := 0 to 255 do a_x[i] := TList.Create;
HashOf := {$IFDEF FPC}@{$ENDIF}DefaultHashOf;
end;
destructor TlkHashTable.Destroy;
var
i,j: Integer;
begin
// for i := 0 to 255 do SetLength(a_h[i], 0);
for i := 0 to 255 do
begin
for j := 0 to a_x[i].Count-1 do Freemem(a_x[i].Items[j]);
a_x[i].Free;
end;
inherited;
end;
function TlkHashTable.SimpleHashOf(const ws: WideString): cardinal;
var
i: Integer;
begin
result := length(ws);
for i := 1 to length(ws) do result := result + ord(ws[i]);
end;
{ TlkJSONstreamed }
{$IFNDEF KOL}
class function TlkJSONstreamed.LoadFromFile(srcname: string):
TlkJSONbase;
var
fs: TFileStream;
begin
result := nil;
if not FileExists(srcname) then exit;
try
fs := TFileStream.Create(srcname, fmOpenRead);
result := LoadFromStream(fs);
finally
if Assigned(fs) then FreeAndNil(fs);
end;
end;
class function TlkJSONstreamed.LoadFromStream(src: TStream):
TlkJSONbase;
var
ws: string;
len: int64;
begin
result := nil;
if not assigned(src) then exit;
len := src.Size - src.Position;
SetLength(ws, len);
src.Read(pchar(ws)^, len);
result := ParseText(ws);
end;
class procedure TlkJSONstreamed.SaveToFile(obj: TlkJSONbase;
dstname: string);
var
fs: TFileStream;
begin
if not assigned(obj) then exit;
try
fs := TFileStream.Create(dstname, fmCreate);
SaveToStream(obj, fs);
finally
if Assigned(fs) then FreeAndNil(fs);
end;
end;
class procedure TlkJSONstreamed.SaveToStream(obj: TlkJSONbase;
dst: TStream);
var
ws: string;
begin
if not assigned(obj) then exit;
if not assigned(dst) then exit;
ws := GenerateText(obj);
dst.Write(pchar(ws)^, length(ws));
end;
{$ENDIF}
{ TlkJSONdotnetclass }
{$IFDEF DOTNET}
procedure TlkJSONdotnetclass.AfterConstruction;
begin
end;
procedure TlkJSONdotnetclass.BeforeDestruction;
begin
end;
constructor TlkJSONdotnetclass.Create;
begin
inherited;
AfterConstruction;
end;
destructor TlkJSONdotnetclass.Destroy;
begin
BeforeDestruction;
inherited;
end;
{$ENDIF DOTNET}
{$ifndef THREADSAFE}
initialization
init_rnd;
{$ENDIF}
end.
?? 快捷鍵說明
復(fù)制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -