{
  LkJSON v1.02

  14 september 2007

  Copyright (C) 2006,2007 Leonid Koninin
  leon_kon@users.sourceforge.net

  This library is free software; you can redistribute it and/or
  modify it under the terms of the GNU Lesser General Public
  License as published by the Free Software Foundation; either
  version 2.1 of the License, or (at your option) any later version.

  This library 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.  See the GNU
  Lesser General Public License for more details.

  You should have received a copy of the GNU Lesser General Public
  License along with this library; if not, write to the Free Software
  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

  changes:

  v1.02 14/09/2007 * fix mistypes in diffrent places; thanx for reports
                     to Aleksandr Fedorov and Tobias Wrede
  v1.01 18/05/2007 * fix small bug in new text generation routine, check
                     library for leaks by fastmm4; thanx for idea and comments
                     for Glynn Owen
  v1.00 12/05/2007 * some fixes in new code (mistypes, mistypes...)
                   * also many fixes by ideas of Henri Gourvest - big thanx
                     for him again; he send me code for thread-safe initializing
                     of hash table, some FPC-compatible issues (not tested by
                     myself) and better code for localization in latest
                     delphi versions; very, very big thanx!
                   * rewritten procedure of json text generating, with wich
                     work of it speeds up 4-5 times (on test) its good for
                     a large objects
                   * started a large work for making source code self-doc
                     (not autodoc!)
  v0.99 10/05/2007 + add functions to list and object:
                      function getInt(idx: Integer): Integer;
                      function getString(idx: Integer): String;
                      function getWideString(idx: Integer):WideString;
                      function getDouble(idx: Integer): Double;
                      function getBoolean(idx: Integer): Boolean;
                   + add overloaded functions to object:
                      function getDouble(nm: String): Double; overload;
                      function getInt(nm: String): Integer; overload;
                      function getString(nm: String): String; overload;
                      function getWideString(nm: String): WideString; overload;
                      function getBoolean(nm: String): Boolean; overload;
                   * changed storing mech of TlkJSONcustomlist descendants from
                     dynamic array to TList; this gives us great speedup with
                     lesser changes; thanx for idea to Henri Gourvest
                   * also reworked hashtable to work with TList, so it also
                     increase speed of work
  v0.98 09/05/2007 * fix small bug in work with WideStrings(UTF8), thanx to
                     IVO GELOV to description and sources
  v0.97 10/04/2007 + add capabilities to work with KOL delphi projects; for
                     this will define KOL variable in begin of text; of course,
                     in this case object TlkJSONstreamed is not compiled.
  v0.96 03/30/2007 + add TlkJSONFuncEnum and method ForEach in all
                     TlkJSONcustomlist descendants
                   + add property UseHash(r/o) to TlkJSONobject, and parameter
                     UseHash:Boolean to object constructors; set ti to false
                     allow to disable using of hash-table, what can increase
                     speed of work in case of objects with low number of
                     methods(fields); [by default it is true]
                   + added conditional compile directive DOTNET for use in .Net
                     based delphi versions; remove dot in declaration below
                     (thanx for idea and sample code to Tim Radford)
                   + added property HashOf to TlkHashTable to allow use of
                     users hash functions; on enter is widestring, on exit is
                     cardinal (32 bit unsigned). Original HashOf renamed to
                     DefaultHashOf
                   * hash table object of TlkJSONobject wrapped by property called
                     HashTable
                   * fixed some minor bugs
  v0.95 03/29/2007 + add object TlkJSONstreamed what descendant of TlkJSON and
                     able to load/save JSON objects from/to streams/files.
                   * fixed small bug in generating of unicode strings representation
  v0.94 03/27/2007 + add properties NameOf and FieldByIndex to TlkJSONobject
                   * fix small error in parsing unicode chars
                   * small changes in hashing code (try to speed up)
  v0.93 03/05/2007 + add overloaded functions to list and object
                   + add enum type TlkJSONtypes
                   + add functions: SelfType:TlkJSONtypes and
                     SelfTypeName: String to every TlkJSONbase child
                   * fix mistype 'IndefOfName' to 'IndexOfName'
                   * fix mistype 'IndefOfObject' to 'IndexOfObject'
  v0.92 03/02/2007 + add some fix to TlkJSON.ParseText to fix bug with parsing
                     objects - object methods not always added properly
                     to hash array (thanx to Chris Matheson)
  ...
}

unit uLkJSON;
{$ifdef fpc}
  {$mode objfpc}{$H+}
  {.$DEFINE HAVE_FORMATSETTING}
{$else}
  {$if RTLVersion > 14.00}
    {$DEFINE HAVE_FORMATSETTING}
  {$ifend}
{$endif}

interface

{.$DEFINE KOL}
{.$define DOTNET}
{$define THREADSAFE}
{$define NEW_STYLE_GENERATE}

uses windows,
  SysUtils,
{$IFNDEF KOL}
  classes,
{$ELSE}
  kol,
{$ENDIF}
  variants;

type
  TlkJSONtypes = (jsBase, jsNumber, jsString, jsBoolean, jsNull,
    jsList, jsObject);

{$IFDEF DOTNET}

  TlkJSONdotnetclass = class
  public
    constructor Create;
    destructor Destroy; override;
    procedure AfterConstruction; virtual;
    procedure BeforeDestruction; virtual;
  end;

{$ENDIF DOTNET}

  TlkJSONbase = class{$IFDEF DOTNET}(TlkJSONdotnetclass){$ENDIF}
  protected
    function GetValue: variant; virtual;
    procedure SetValue(const AValue: variant); virtual;
    function GetChild(idx: Integer): TlkJSONbase; virtual;
    procedure SetChild(idx: Integer; const AValue: TlkJSONbase);
      virtual;
    function GetCount: Integer; virtual;
  public
    property Count: Integer read GetCount;
    property Child[idx: Integer]: TlkJSONbase read GetChild write SetChild;
    property Value: variant read GetValue write SetValue;
    class function SelfType: TlkJSONtypes; virtual;
    class function SelfTypeName: string; virtual;
  end;

  TlkJSONnumber = class(TlkJSONbase)
  protected
    FValue: extended;
    function GetValue: Variant; override;
    procedure SetValue(const AValue: Variant); override;
  public
    procedure AfterConstruction; override;
    class function Generate(AValue: extended = 0): TlkJSONnumber;
    class function SelfType: TlkJSONtypes; override;
    class function SelfTypeName: string; override;
  end;

  TlkJSONstring = class(TlkJSONbase)
  protected
    FValue: WideString;
    function GetValue: Variant; override;
    procedure SetValue(const AValue: Variant); override;
  public
    procedure AfterConstruction; override;
    class function Generate(const wsValue: WideString = ''): TlkJSONstring;
    class function SelfType: TlkJSONtypes; override;
    class function SelfTypeName: string; override;
  end;

  TlkJSONboolean = class(TlkJSONbase)
  protected
    FValue: Boolean;
    function GetValue: Variant; override;
    procedure SetValue(const AValue: Variant); override;
  public
    procedure AfterConstruction; override;
    class function Generate(AValue: Boolean = true): TlkJSONboolean;
    class function SelfType: TlkJSONtypes; override;
    class function SelfTypeName: string; override;
  end;

  TlkJSONnull = class(TlkJSONbase)
  protected
    function GetValue: Variant; override;
    function Generate: TlkJSONnull;
  public
    class function SelfType: TlkJSONtypes; override;
    class function SelfTypeName: string; override;
  end;

  TlkJSONFuncEnum = procedure(ElName: string; Elem: TlkJSONbase;
    data: pointer; var Continue: Boolean) of object;

  TlkJSONcustomlist = class(TlkJSONbase)
  protected
//    FValue: array of TlkJSONbase;
    fList:TList;
    function GetCount: Integer; override;
    function GetChild(idx: Integer): TlkJSONbase; override;
    procedure SetChild(idx: Integer; const AValue: TlkJSONbase);
      override;
    function ForEachElement(idx: Integer; var nm: string):
      TlkJSONbase; virtual;

    function _Add(obj: TlkJSONbase): Integer; virtual;
    procedure _Delete(idx: Integer); virtual;
    function _IndexOf(obj: TlkJSONbase): Integer; virtual;
  public
    procedure ForEach(cb: TlkJSONFuncEnum; data: pointer);
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;

    function getInt(idx: Integer): Integer; virtual;
    function getString(idx: Integer): String; virtual;
    function getWideString(idx: Integer):WideString; virtual;
    function getDouble(idx: Integer): Double; virtual;
    function getBoolean(idx: Integer): Boolean; virtual;
  end;

  TlkJSONlist = class(TlkJSONcustomlist)
  public
    function Add(obj: TlkJSONbase): Integer; overload;

    function Add(bool: Boolean): Integer; overload;
    function Add(nmb: double): Integer; overload;
    function Add(s: string): Integer; overload;
    function Add(const ws: WideString): Integer; overload;
    function Add(inmb: Integer): Integer; overload;

    procedure Delete(idx: Integer);
    function IndexOf(obj: TlkJSONbase): Integer;
    class function Generate: TlkJSONlist;
    class function SelfType: TlkJSONtypes; override;
    class function SelfTypeName: string; override;

  end;

  TlkJSONobjectmethod = class(TlkJSONbase)
  protected
    FValue: TlkJSONbase;
    FName: WideString;
    procedure SetName(const AValue: WideString);
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    property Name: WideString read FName write SetName;
    class function Generate(const aname: WideString; aobj: TlkJSONbase):
      TlkJSONobjectmethod;
  end;

  PlkHashItem = ^TlkHashItem;
  TlkHashItem = packed record
    hash: cardinal;
    index: Integer;
  end;

  TlkHashFunction = function(const ws: WideString): cardinal of object;

  TlkHashTable = class
  private
    FHashFunction: TlkHashFunction;
    procedure SetHashFunction(const AValue: TlkHashFunction);
  protected
//    a_h: array[0..255] of array of TlkHashItem;
    a_x: array[0..255] of TList;
    procedure hswap(j, k, l: Integer);
    function InTable(const ws: WideString; var i, j, k: cardinal): Boolean;
  public
    function counters: string;

    function DefaultHashOf(const ws: WideString): cardinal;
    function SimpleHashOf(const ws: WideString): cardinal;

    property HashOf: TlkHashFunction read FHashFunction write
      SetHashFunction;

    function IndexOf(const ws: WideString): Integer;

    procedure AddPair(const ws: WideString; idx: Integer);
    procedure Delete(const ws: WideString);

    constructor Create;
    destructor Destroy; override;
  end;

  TlkJSONobject = class(TlkJSONcustomlist)
  protected
    ht: TlkHashTable;
    FUseHash: Boolean;
    function GetFieldByIndex(idx: Integer): TlkJSONbase;
    function GetNameOf(idx: Integer): WideString;
    procedure SetFieldByIndex(idx: Integer; const AValue:
      TlkJSONbase);
    function GetHashTable: TlkHashTable;
    function ForEachElement(idx: Integer; var nm: string):
      TlkJSONbase;
      override;
  public
    property UseHash: Boolean read FUseHash;
    property HashTable: TlkHashTable read GetHashTable;
    function GetField(nm: string): TlkJSONbase;
    procedure SetField(nm: string; const AValue: TlkJSONbase);

    function Add(const aname: WideString; aobj: TlkJSONbase): Integer;
      overload;

    function Add(const aname: WideString; bool: Boolean): Integer;
      overload;
    function Add(const aname: WideString; nmb: double): Integer; overload;
    function Add(const aname: WideString; s: string): Integer; overload;
    function Add(const aname: WideString; const ws: WideString): Integer;
      overload;
    function Add(const aname: WideString; inmb: Integer): Integer;
      overload;

    procedure Delete(idx: Integer);
    function IndexOfName(const aname: WideString): Integer;
    function IndexOfObject(aobj: TlkJSONbase): Integer;
    property Field[nm: string]: TlkJSONbase read GetField write SetField; default;

    constructor Create(bUseHash: Boolean = true);
    destructor Destroy; override;

    class function Generate(AUseHash: Boolean = true): TlkJSONobject;
    class function SelfType: TlkJSONtypes; override;
    class function SelfTypeName: string; override;

    property FieldByIndex[idx: Integer]: TlkJSONbase read GetFieldByIndex write SetFieldByIndex;
    property NameOf[idx: Integer]: WideString read GetNameOf;

    function getDouble(idx: Integer): Double; overload; override;
    function getInt(idx: Integer): Integer; overload; override;
    function getString(idx: Integer): String; overload; override;
    function getWideString(idx: Integer): WideString; overload; override;
    function getBoolean(idx: Integer): Boolean; overload; override;

    function getDouble(nm: String): Double; overload;
    function getInt(nm: String): Integer; overload;
    function getString(nm: String): String; overload;
    function getWideString(nm: String): WideString; overload;
    function getBoolean(nm: String): Boolean; overload;
  end;

  TlkJSON = class
  public
    class function ParseText(const txt: string): TlkJSONbase;
    class function GenerateText(obj: TlkJSONbase): string;
  end;

{$IFNDEF KOL}
  TlkJSONstreamed = class(TlkJSON)
    class function LoadFromStream(src: TStream): TlkJSONbase;
    class procedure SaveToStream(obj: TlkJSONbase; dst: TStream);
    class function LoadFromFile(srcname: string): TlkJSONbase;
    class procedure SaveToFile(obj: TlkJSONbase; dstname: string);
  end;
{$ENDIF}

implementation

uses math;

type
  ElkIntException = class(Exception)
  public
    idx: Integer;
    constructor Create(idx: Integer; msg: string);
  end;

// author of this routine is IVO GELOV
function code2utf(iNumber: Integer): UTF8String;
begin
  if iNumber < 128 then Result := chr(iNumber)
  else if iNumber < 2048 then
    Result := chr((iNumber shr 6) + 192) + chr((iNumber and 63) + 128)
  else if iNumber < 65536 then
    Result := chr((iNumber shr 12) + 224) + chr(((iNumber shr 6) and 63) + 128)
    + chr((iNumber and 63) + 128)
  else if iNumber < 2097152 then
    Result := chr((iNumber shr 18) + 240) + chr(((iNumber shr 12) and 63) + 128)
    + chr(((iNumber shr 6) and 63) + 128) + chr((iNumber and 63) + 128);
end;

{ TlkJSONbase }

function TlkJSONbase.GetChild(idx: Integer): TlkJSONbase;
begin
  result := nil;
end;

function TlkJSONbase.GetCount: Integer;
begin
  result := 0;
end;

function TlkJSONbase.GetValue: variant;
begin
  result := variants.Null;
end;

class function TlkJSONbase.SelfType: TlkJSONtypes;
begin
  result := jsBase;
end;

class function TlkJSONbase.SelfTypeName: string;
begin
  result := 'jsBase';
end;

procedure TlkJSONbase.SetChild(idx: Integer; const AValue:
  TlkJSONbase);
begin

end;

procedure TlkJSONbase.SetValue(const AValue: variant);
begin

end;

{ TlkJSONnumber }

procedure TlkJSONnumber.AfterConstruction;
begin
  inherited;
  FValue := 0;
end;

class function TlkJSONnumber.Generate(AValue: extended): TlkJSONnumber;
begin
  result := TlkJSONnumber.Create;
  result.FValue := AValue;
end;

function TlkJSONnumber.GetValue: Variant;
begin
  result := FValue;
end;

class function TlkJSONnumber.SelfType: TlkJSONtypes;
begin
  result := jsNumber;
end;

class function TlkJSONnumber.SelfTypeName: string;
begin
  result := 'jsNumber';
end;

procedure TlkJSONnumber.SetValue(const AValue: Variant);
begin
  FValue := VarAsType(AValue, varDouble);
end;

{ TlkJSONstring }

procedure TlkJSONstring.AfterConstruction;
begin
  inherited;
  FValue := '';
end;

class function TlkJSONstring.Generate(const wsValue: WideString): TlkJSONstring;
begin
  result := TlkJSONstring.Create;
  result.FValue := wsValue;
end;

function TlkJSONstring.GetValue: Variant;
begin
  result := FValue;
end;

class function TlkJSONstring.SelfType: TlkJSONtypes;
begin
  result := jsString;
end;

class function TlkJSONstring.SelfTypeName: string;
begin
  result := 'jsString';
end;

procedure TlkJSONstring.SetValue(const AValue: Variant);
begin
  FValue := VarToWideStr(AValue);
end;

{ TlkJSONboolean }

procedure TlkJSONboolean.AfterConstruction;
begin
  FValue := false;
end;

class function TlkJSONboolean.Generate(AValue: Boolean): TlkJSONboolean;
begin
  result := TlkJSONboolean.Create;
  result.Value := AValue;
end;