Vídeo

Solução

TODA A DESCOBERTA DA CIENCIA PURA E POTENCIALMENTE SUBVERSIVA POR VEZES A CIENCIA DEVE SER TRATADA COMO UM INIMIGO POSSIVEL

Baseado no Internet Relay Chat (IRC) o Discord é uma plataforma de bate-papo que conta atualmente com 25 milhões de usuários. Durante a pandemia de coronavírus no Brasil, usuários recriaram a BrasNET.

Acesse agora:
https://discord.gg/F8HnKpw

O que é o Discord?

Discord é uma plataforma para quem busca conversar na internet. Com diversas melhorias em relação ao IRC, o Discord conta também com voz e vídeo, além do tradicional texto. Atualmente ele é muito utilizado para bate-papo durante jogos online ou gravações de podcasts.

Disponível em todas plataformas e gratuito paraaaa nossssaaaaa alegria =P

uLkJSON é uma biblioteca para interpretação de JSON (www.json.org) em linguagem C++ ou Delphi/FPC. Ela foi desenvolvida originalmente por Leonid Koninin <leon_kon@users.sourceforge.net> em 2006 e foi descontinuada pelo desenvolvedor em 2009.

Descontinuada, embora muito utilizada! E estarei compartilhando com a comunidade as correções e implementações que farei fazer nesta biblioteca a partir de agora, afim de atender nossos projetos.

DOWNLOAD VERSÃO 1.08 (com exemplos)

{
  LkJSON v1.08

  27 june 2020

* Copyright (c) 2006,2007,2008,2009 Leonid Koninin
* leon_kon@users.sourceforge.net
* All rights reserved.
*
* New versions (>=1.08) by Nataniel Kegles <nataniel@kegles.com.br>
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*     * Redistributions of source code must retain the above copyright
*       notice, this list of conditions and the following disclaimer.
*     * Redistributions in binary form must reproduce the above copyright
*       notice, this list of conditions and the following disclaimer in the
*       documentation and/or other materials provided with the distribution.
*     * Neither the name of the <organization> nor the
*       names of its contributors may be used to endorse or promote products
*       derived from this software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY Leonid Koninin ``AS IS'' AND ANY
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL Leonid Koninin BE LIABLE FOR ANY
* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

  changes:

  v1.08 27/06/2020 * fixed a bug in getString() when getting a null value from
                   json
  v1.07 06/11/2009 * fixed a bug in js_string - thanks to Andrew G. Khodotov
                   * fixed error with double-slashes - thanks to anonymous user
                   * fixed a BOM bug in parser, thanks to jasper_dale
  v1.06 13/03/2009 * fixed a bug in string parsing routine
                   * looked routine from the Adrian M. Jones, and get some
                     ideas from it; thanks a lot, Adrian!
                   * checked error reported by phpop and fix it in the string
                     routine; also, thanks for advice.
  v1.05 26/01/2009 + added port to D2009 by Daniele Teti, thanx a lot! really,
                     i haven't the 2009 version, so i can't play with it. I was
                     add USE_D2009 directive below, disabled by default
                   * fixed two small bugs in parsing object: errors with empty
                     object and list; thanx to RSDN's delphi forum members
                   * fixed "[2229135] Value deletion is broken" tracker
                     issue, thanx to anonymous sender provided code for
                     tree version
                   * fixed js_string according to "[1917047] (much) faster
                     js_string Parse" tracker issue by Joao Inacio; a lot of
                     thanx, great speedup!

  v1.04 05/04/2008 + a declaration of Field property moved from TlkJSONobject
                     to TlkJSONbase; thanx for idea to Andrey Lukyanov; this
                     improve objects use, look the bottom of SAMPLE2.DPR
                   * fixed field name in TlkJSONobject to WideString
  v1.03 14/03/2008 + added a code for generating readable JSON text, sended to
                     me by Kusnassriyanto Saiful Bahri, thanx to him!
                   * from this version, library distributed with BSD
                     license, more pleasure for commercial programmers :)
                   * was rewritten internal storing of objects, repacing
                     hash tables with balanced trees (AA tree, by classic
                     author's variant). On mine machine, with enabled fastmm,
                     tree variant is about 30% slower in from-zero creation,
                     but about 50% faster in parsing; also deletion of
                     objects will be much faster than a hash-one.
                     Hashes (old-style) can be switched on by enabling
                     USE_HASH directive below
  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 it 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)
  ...
}

{$WARNINGS OFF}
{$HINTS OFF}

unit uLkJSON;

{$IFDEF fpc}
  {$MODE objfpc}
  {$H+}
  {.$DEFINE HAVE_FORMATSETTING}
{$ELSE}
  {$IF RTLVersion > 14.00}
    {$DEFINE HAVE_FORMATSETTING}
    {$IF RTLVersion > 19.00}
      {$DEFINE USE_D2009}
    {$IFEND}
  {$IFEND}
{$ENDIF}

interface

{.$DEFINE USE_D2009}
{.$DEFINE KOL}
{.$define DOTNET}
{$DEFINE THREADSAFE}
{$DEFINE NEW_STYLE_GENERATE}
{.$DEFINE USE_HASH}
{.$DEFINE TCB_EXT}

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;
    function GetField(AName: Variant):TlkJSONbase; virtual;
  public
    property Field[AName: Variant]: TlkJSONbase read GetField;
    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 GetField(AName: Variant):TlkJSONbase; override;

    function _Add(obj: TlkJSONbase): Integer; virtual;
    procedure _Delete(iIndex: Integer); virtual;
    function _IndexOf(obj: TlkJSONbase): Integer; virtual;
  public
    procedure ForEach(fnCallBack: TlkJSONFuncEnum; pUserData:
      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)
  protected
  public
    function Add(obj: TlkJSONbase): Integer; overload;

    function Add(aboolean: 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
    property ObjValue: TlkJSONbase read FValue;
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    property Name: WideString read FName write SetName;
    class function Generate(const aname: WideString; aobj: TlkJSONbase):
      TlkJSONobjectmethod;
  end;

{$IFDEF USE_HASH}
  PlkHashItem = ^TlkHashItem;
  TlkHashItem = packed record
    hash: cardinal;
    index: Integer;
  end;

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

  TlkHashTable = class
  private
    FParent: TObject; // TCB:parent for check chaining op.
    FHashFunction: TlkHashFunction;
    procedure SetHashFunction(const AValue: TlkHashFunction);
  protected
    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;

{$ELSE}

// implementation based on "Arne Andersson, Balanced Search Trees Made Simpler"

  PlkBalNode = ^TlkBalNode;
  TlkBalNode = packed record
    left,right: PlkBalNode;
    level: byte;
    key: Integer;
    nm: WideString;
  end;

  TlkBalTree = class
  protected
    fdeleted,flast,fbottom,froot: PlkBalNode;
    procedure skew(var t:PlkBalNode);
    procedure split(var t:PlkBalNode);
  public
    function counters: string;

    procedure Clear;

    function Insert(const ws: WideString; x: Integer): Boolean;
    function Delete(const ws: WideString): Boolean;

    function IndexOf(const ws: WideString): Integer;

    constructor Create;
    destructor Destroy; override;
  end;
{$ENDIF USE_HASH}

  TlkJSONobject = class(TlkJSONcustomlist)
  protected
{$IFDEF USE_HASH}
    ht: TlkHashTable;
{$ELSE}
    ht: TlkBalTree;
{$ENDIF USE_HASH}
    FUseHash: Boolean;
    function GetFieldByIndex(idx: Integer): TlkJSONbase;
    function GetNameOf(idx: Integer): WideString;
    procedure SetFieldByIndex(idx: Integer; const AValue: TlkJSONbase);
{$IFDEF USE_HASH}
    function GetHashTable: TlkHashTable;
{$ELSE}
    function GetHashTable: TlkBalTree;
{$ENDIF USE_HASH}
    function ForEachElement(idx: Integer; var nm: string): TlkJSONbase;
      override;
    function GetField(AName: Variant):TlkJSONbase; override;
  public
    property UseHash: Boolean read FUseHash;
{$IFDEF USE_HASH}
    property HashTable: TlkHashTable read GetHashTable;
{$ELSE}
    property HashTable: TlkBalTree read GetHashTable;
{$ENDIF USE_HASH}

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

    function OldGetField(nm: WideString): TlkJSONbase;
    procedure OldSetField(nm: WideString; const AValue: TlkJSONbase);

    function Add(const aname: WideString; aboolean: 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: WideString]: TlkJSONbase read OldGetField
      write OldSetField; 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 {$ifdef TCB_EXT}getDoubleFromName{$else}getDouble{$endif}
      (nm: string): Double; overload;
    function {$ifdef TCB_EXT}getIntFromName{$else}getInt{$endif}
      (nm: string): Integer; overload;
    function {$ifdef TCB_EXT}getStringFromName{$else}getString{$endif}
      (nm: string): string; overload;
    function {$ifdef TCB_EXT}getWideStringFromName{$else}getWideString{$endif}
      (nm: string): WideString; overload;
    function {$ifdef TCB_EXT}getBooleanFromName{$else}getBoolean{$endif}
      (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}

function GenerateReadableText(vObj: TlkJSONbase; var vLevel:
  Integer): string;

implementation

uses math,strutils;

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

// author of next two functions is Kusnassriyanto Saiful Bahri

function Indent(vTab: Integer): string;
begin
  result := DupeString('  ', vTab);
end;

function GenerateReadableText(vObj: TlkJSONbase; var vLevel:
  Integer): string;
var
  i: Integer;
  vStr: string;
  xs: TlkJSONstring;
begin
  vLevel := vLevel + 1;
  if vObj is TlkJSONObject then
    begin
      vStr := '';
      for i := 0 to TlkJSONobject(vObj).Count - 1 do
        begin
          if vStr <> '' then
            begin
              vStr := vStr + ','#13#10;
            end;
          vStr := vStr + Indent(vLevel) +
            GenerateReadableText(TlkJSONobject(vObj).Child[i], vLevel);
        end;
      if vStr <> '' then
        begin
          vStr := '{'#13#10 + vStr + #13#10 + Indent(vLevel - 1) + '}';
        end
      else
        begin
          vStr := '{}';
        end;
      result := vStr;
    end
  else if vObj is TlkJSONList then
    begin
      vStr := '';
      for i := 0 to TlkJSONList(vObj).Count - 1 do
        begin
          if vStr <> '' then
            begin
              vStr := vStr + ','#13#10;
            end;
          vStr := vStr + Indent(vLevel) +
              GenerateReadableText(TlkJSONList(vObj).Child[i], vLevel);
        end;
      if vStr <> '' then
        begin
          vStr := '['#13#10 + vStr + #13#10 + Indent(vLevel - 1) + ']';
        end
      else
        begin
          vStr := '[]';
        end;
      result := vStr;
    end
  else if vObj is TlkJSONobjectmethod then
    begin
      vStr := '';
      xs := TlkJSONstring.Create;
      try
        xs.Value := TlkJSONobjectMethod(vObj).Name;
        vStr := GenerateReadableText(xs, vLevel);
        vLevel := vLevel - 1;
        vStr := vStr + ':' + GenerateReadableText(TlkJSONbase(
          TlkJSONobjectmethod(vObj).ObjValue), vLevel);
      //vStr := vStr + ':' + GenerateReadableText(TlkJSONbase(vObj), vLevel);
        vLevel := vLevel + 1;
        result := vStr;
      finally
        xs.Free;
      end;
    end
  else
    begin
      if vObj is TlkJSONobjectmethod then
        begin
          if TlkJSONobjectMethod(vObj).Name <> '' then
            begin
            end;
        end;
      result := TlkJSON.GenerateText(vObj);
    end;
  vLevel := vLevel - 1;
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.GetField(AName: Variant):TlkJSONbase;
begin
  result := self;
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;

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

class function TlkJSONboolean.SelfType: TlkJSONtypes;
begin
  Result := jsBoolean;
end;

class function TlkJSONboolean.SelfTypeName: string;
begin
  Result := 'jsBoolean';
end;

procedure TlkJSONboolean.SetValue(const AValue: Variant);
begin
  FValue := boolean(AValue);
end;

{ TlkJSONnull }

function TlkJSONnull.Generate: TlkJSONnull;
begin
  result := TlkJSONnull.Create;
end;

function TlkJSONnull.GetValue: Variant;
begin
  result := variants.Null;
end;

class function TlkJSONnull.SelfType: TlkJSONtypes;
begin
  result := jsNull;
end;

class function TlkJSONnull.SelfTypeName: string;
begin
  result := 'jsNull';
end;

{ TlkJSONcustomlist }

function TlkJSONcustomlist._Add(obj: TlkJSONbase): Integer;
begin
  if not Assigned(obj) then
    begin
      result := -1;
      exit;
    end;
  result := fList.Add(obj);
end;

procedure TlkJSONcustomlist.AfterConstruction;
begin
  inherited;
  fList := TList.Create;
end;

procedure TlkJSONcustomlist.BeforeDestruction;
var
  i: Integer;
begin
  for i := (Count - 1) downto 0 do _Delete(i);
  fList.Free;
  inherited;
end;

// renamed

procedure TlkJSONcustomlist._Delete(iIndex: Integer);
var
  idx: Integer;
begin
  if not ((iIndex < 0) or (iIndex >= Count)) then
    begin
      if fList.Items[iIndex] <> nil then
        TlkJSONbase(fList.Items[iIndex]).Free;
      idx := pred(fList.Count);
      if iIndex<idx then
        begin
          fList.Items[iIndex] := fList.Items[idx];
          fList.Delete(idx);
        end
      else
        begin
          fList.Delete(iIndex);
        end;
    end;
end;

function TlkJSONcustomlist.GetChild(idx: Integer): TlkJSONbase;
begin
  if (idx < 0) or (idx >= Count) then
    begin
      result := nil;
    end
  else
    begin
      result := fList.Items[idx];
    end;
end;

function TlkJSONcustomlist.GetCount: Integer;
begin
  result := fList.Count;
end;

function TlkJSONcustomlist._IndexOf(obj: TlkJSONbase): Integer;
begin
  result := fList.IndexOf(obj);
end;

procedure TlkJSONcustomlist.SetChild(idx: Integer; const AValue:
  TlkJSONbase);
begin
  if not ((idx < 0) or (idx >= Count)) then
    begin
      if fList.Items[idx] <> nil then
        TlkJSONbase(fList.Items[idx]).Free;
      fList.Items[idx] := AValue;
    end;
end;

procedure TlkJSONcustomlist.ForEach(fnCallBack: TlkJSONFuncEnum;
  pUserData:
  pointer);
var
  iCount: Integer;
  IsContinue: Boolean;
  anJSON: TlkJSONbase;
  wsObject: string;
begin
  if not assigned(fnCallBack) then exit;
  IsContinue := true;
  for iCount := 0 to GetCount - 1 do
    begin
      anJSON := ForEachElement(iCount, wsObject);
      if assigned(anJSON) then
        fnCallBack(wsObject, anJSON, pUserData, IsContinue);
      if not IsContinue then break;
    end;
end;

///---- renamed to here

function TlkJSONcustomlist.GetField(AName: Variant):TlkJSONbase;
var
  index: Integer;
begin
  if VarIsNumeric(AName) then
    begin
      index := integer(AName);
      result := GetChild(index);
    end
  else
    begin
      result := inherited GetField(AName);
    end;
end;

function TlkJSONcustomlist.ForEachElement(idx: Integer; var nm:
  string): TlkJSONbase;
begin
  nm := inttostr(idx);
  result := GetChild(idx);
end;

function TlkJSONcustomlist.getDouble(idx: Integer): Double;
var
  jn: TlkJSONnumber;
begin
  jn := Child[idx] as TlkJSONnumber;
  if not assigned(jn) then result := 0
  else result := jn.Value;
end;

function TlkJSONcustomlist.getInt(idx: Integer): Integer;
var
  jn: TlkJSONnumber;
begin
  jn := Child[idx] as TlkJSONnumber;
  if not assigned(jn) then result := 0
  else result := round(int(jn.Value));
end;

function TlkJSONcustomlist.getString(idx: Integer): string;
var
  js: TlkJSONstring;
begin
  js := Child[idx] as TlkJSONstring;
  if not assigned(js) then result := ''
  else result := VarToStr(js.Value);
end;

function TlkJSONcustomlist.getWideString(idx: Integer): WideString;
var
  js: TlkJSONstring;
begin
  js := Child[idx] as TlkJSONstring;
  if not assigned(js) then result := ''
  else result := VarToWideStr(js.Value);
end;

function TlkJSONcustomlist.getBoolean(idx: Integer): Boolean;
var
  jb: TlkJSONboolean;
begin
  jb := Child[idx] as TlkJSONboolean;
  if not assigned(jb) then result := false
  else result := jb.Value;
end;

{ TlkJSONobjectmethod }

procedure TlkJSONobjectmethod.AfterConstruction;
begin
  inherited;
  FValue := nil;
  FName := '';
end;

procedure TlkJSONobjectmethod.BeforeDestruction;
begin
  FName := '';
  if FValue <> nil then
    begin
      FValue.Free;
      FValue := nil;
    end;
  inherited;
end;

class function TlkJSONobjectmethod.Generate(const aname: WideString;
  aobj: TlkJSONbase): TlkJSONobjectmethod;
begin
  result := TlkJSONobjectmethod.Create;
  result.FName := aname;
  result.FValue := aobj;
end;

procedure TlkJSONobjectmethod.SetName(const AValue: WideString);
begin
  FName := AValue;
end;

{ TlkJSONlist }

function TlkJSONlist.Add(obj: TlkJSONbase): Integer;
begin
  result := _Add(obj);
end;

function TlkJSONlist.Add(nmb: double): Integer;
begin
  Result := self.Add(TlkJSONnumber.Generate(nmb));
end;

function TlkJSONlist.Add(aboolean: Boolean): Integer;
begin
  Result := self.Add(TlkJSONboolean.Generate(aboolean));
end;

function TlkJSONlist.Add(inmb: Integer): Integer;
begin
  Result := self.Add(TlkJSONnumber.Generate(inmb));
end;

function TlkJSONlist.Add(const ws: WideString): Integer;
begin
  Result := self.Add(TlkJSONstring.Generate(ws));
end;

function TlkJSONlist.Add(s: string): Integer;
begin
  Result := self.Add(TlkJSONstring.Generate(s));
end;

procedure TlkJSONlist.Delete(idx: Integer);
begin
  _Delete(idx);
end;

class function TlkJSONlist.Generate: TlkJSONlist;
begin
  result := TlkJSONlist.Create;
end;

function TlkJSONlist.IndexOf(obj: TlkJSONbase): Integer;
begin
  result := _IndexOf(obj);
end;

class function TlkJSONlist.SelfType: TlkJSONtypes;
begin
  result := jsList;
end;

class function TlkJSONlist.SelfTypeName: string;
begin
  result := 'jsList';
end;

{ TlkJSONobject }

function TlkJSONobject.Add(const aname: WideString; aobj:
  TlkJSONbase):
  Integer;
var
  mth: TlkJSONobjectmethod;
begin
  if not assigned(aobj) then
    begin
      result := -1;
      exit;
    end;
  mth := TlkJSONobjectmethod.Create;
  mth.FName := aname;
  mth.FValue := aobj;
  result := self._Add(mth);
  if FUseHash then
{$IFDEF USE_HASH}
    ht.AddPair(aname, result);
{$ELSE}
    ht.Insert(aname, result);
{$ENDIF USE_HASH}
end;

procedure TlkJSONobject.Delete(idx: Integer);
var
  i,j,k:cardinal;
  mth: TlkJSONobjectmethod;
begin
  if (idx >= 0) and (idx < Count) then
    begin
//      mth := FValue[idx] as TlkJSONobjectmethod;
      mth := TlkJSONobjectmethod(fList.Items[idx]);
      if FUseHash then
        begin
          ht.Delete(mth.FName);
        end;
    end;
  _Delete(idx);
{$ifdef USE_HASH}
  if (idx<Count) and (FUseHash) then
    begin
      mth := TlkJSONobjectmethod(fList.Items[idx]);
      ht.AddPair(mth.FName,idx);
    end;
{$endif}
end;

class function TlkJSONobject.Generate(AUseHash: Boolean = true):
  TlkJSONobject;
begin
  result := TlkJSONobject.Create(AUseHash);
end;

function TlkJSONobject.OldGetField(nm: WideString): TlkJSONbase;
var
  mth: TlkJSONobjectmethod;
  i: Integer;
begin
  i := IndexOfName(nm);
  if i = -1 then
    begin
      result := nil;
    end
  else
    begin
//      mth := TlkJSONobjectmethod(FValue[i]);
      mth := TlkJSONobjectmethod(fList.Items[i]);
      result := mth.FValue;
    end;
end;

function TlkJSONobject.IndexOfName(const aname: WideString): Integer;
var
  mth: TlkJSONobjectmethod;
  i: Integer;
begin
  if not FUseHash then
    begin
      result := -1;
      for i := 0 to Count - 1 do
        begin
//          mth := TlkJSONobjectmethod(FValue[i]);
          mth := TlkJSONobjectmethod(fList.Items[i]);
          if mth.Name = aname then
            begin
              result := i;
              break;
            end;
        end;
    end
  else
    begin
      result := ht.IndexOf(aname);
    end;
end;

function TlkJSONobject.IndexOfObject(aobj: TlkJSONbase): Integer;
var
  mth: TlkJSONobjectmethod;
  i: Integer;
begin
  result := -1;
  for i := 0 to Count - 1 do
    begin
//      mth := TlkJSONobjectmethod(FValue[i]);
      mth := TlkJSONobjectmethod(fList.Items[i]);
      if mth.FValue = aobj then
        begin
          result := i;
          break;
        end;
    end;
end;

procedure TlkJSONobject.OldSetField(nm: WideString; const AValue:
  TlkJSONbase);
var
  mth: TlkJSONobjectmethod;
  i: Integer;
begin
  i := IndexOfName(nm);
  if i <> -1 then
    begin
//      mth := TlkJSONobjectmethod(FValue[i]);
      mth := TlkJSONobjectmethod(fList.Items[i]);
      mth.FValue := AValue;
    end;
end;

function TlkJSONobject.Add(const aname: WideString; nmb: double):
  Integer;
begin
  Result := self.Add(aname, TlkJSONnumber.Generate(nmb));
end;

function TlkJSONobject.Add(const aname: WideString; aboolean: Boolean):
  Integer;
begin
  Result := self.Add(aname, TlkJSONboolean.Generate(aboolean));
end;

function TlkJSONobject.Add(const aname: WideString; s: string):
  Integer;
begin
  Result := self.Add(aname, TlkJSONstring.Generate(s));
end;

function TlkJSONobject.Add(const aname: WideString; inmb: Integer):
  Integer;
begin
  Result := self.Add(aname, TlkJSONnumber.Generate(inmb));
end;

function TlkJSONobject.Add(const aname, ws: WideString): Integer;
begin
  Result := self.Add(aname, TlkJSONstring.Generate(ws));
end;

class function TlkJSONobject.SelfType: TlkJSONtypes;
begin
  Result := jsObject;
end;

class function TlkJSONobject.SelfTypeName: string;
begin
  Result := 'jsObject';
end;

function TlkJSONobject.GetFieldByIndex(idx: Integer): TlkJSONbase;
var
  nm: WideString;
begin
  nm := GetNameOf(idx);
  if nm <> '' then
    begin
      result := Field[nm];
    end
  else
    begin
      result := nil;
    end;
end;

function TlkJSONobject.GetNameOf(idx: Integer): WideString;
var
  mth: TlkJSONobjectmethod;
begin
  if (idx < 0) or (idx >= Count) then
    begin
      result := '';
    end
  else
    begin
      mth := Child[idx] as TlkJSONobjectmethod;
      result := mth.Name;
    end;
end;

procedure TlkJSONobject.SetFieldByIndex(idx: Integer;
  const AValue: TlkJSONbase);
var
  nm: WideString;
begin
  nm := GetNameOf(idx);
  if nm <> '' then
    begin
      Field[nm] := AValue;
    end;
end;

function TlkJSONobject.ForEachElement(idx: Integer;
  var nm: string): TlkJSONbase;
begin
  nm := GetNameOf(idx);
  result := GetFieldByIndex(idx);
end;

function TlkJSONobject.GetField(AName: Variant):TlkJSONbase;
begin
  if VarIsStr(AName) then
    result := OldGetField(VarToWideStr(AName))
  else
    result := inherited GetField(AName);
end;

{$IFDEF USE_HASH}
function TlkJSONobject.GetHashTable: TlkHashTable;
{$ELSE}
function TlkJSONobject.GetHashTable: TlkBalTree;
{$ENDIF USE_HASH}
begin
  result := ht;
end;

constructor TlkJSONobject.Create(bUseHash: Boolean);
begin
  inherited Create;
  FUseHash := bUseHash;
{$IFDEF USE_HASH}
  ht := TlkHashTable.Create;
  ht.FParent := self;
{$ELSE}
  ht := TlkBalTree.Create;
{$ENDIF}
end;

destructor TlkJSONobject.Destroy;
begin
  if assigned(ht) then FreeAndNil(ht);
  inherited;
end;

function TlkJSONobject.getDouble(idx: Integer): Double;
var
  jn: TlkJSONnumber;
begin
  jn := FieldByIndex[idx] as TlkJSONnumber;
  if not assigned(jn) then result := 0
  else result := jn.Value;
end;

function TlkJSONobject.getInt(idx: Integer): Integer;
var
  jn: TlkJSONnumber;
begin
  jn := FieldByIndex[idx] as TlkJSONnumber;
  if not assigned(jn) then result := 0
  else result := round(int(jn.Value));
end;

function TlkJSONobject.getString(idx: Integer): string;
var
  js: TlkJSONstring;
begin
  if VarType(FieldByIndex[idx].Value) = varString then
  begin
    js := FieldByIndex[idx] as TlkJSONstring;
    if not assigned(js) then result := ''
    else result := vartostr(js.Value);
  end
  else
  result:=''
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;

{$ifdef TCB_EXT}
function TlkJSONobject.getDoubleFromName(nm: string): Double;
{$else}
function TlkJSONobject.getDouble(nm: string): Double;
{$endif}
begin
  result := getDouble(IndexOfName(nm));
end;

{$ifdef TCB_EXT}
function TlkJSONobject.getIntFromName(nm: string): Integer;
{$else}
function TlkJSONobject.getInt(nm: string): Integer;
{$endif}
begin
  result := getInt(IndexOfName(nm));
end;

{$ifdef TCB_EXT}
function TlkJSONobject.getStringFromName(nm: string): string;
{$else}
function TlkJSONobject.getString(nm: string): string;
{$endif}
begin
  result := getString(IndexOfName(nm));
end;

{$ifdef TCB_EXT}
function TlkJSONobject.getWideStringFromName(nm: string): WideString;
{$else}
function TlkJSONobject.getWideString(nm: string): WideString;
{$endif}
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;

{$ifdef TCB_EXT}
function TlkJSONobject.getBooleanFromName(nm: string): Boolean;
{$else}
function TlkJSONobject.getBoolean(nm: string): Boolean;
{$endif}
begin
  result := getBoolean(IndexOfName(nm));
end;

{ TlkJSON }

class function TlkJSON.GenerateText(obj: TlkJSONbase): string;
var
{$IFDEF HAVE_FORMATSETTING}
  fs: TFormatSettings;
{$ENDIF}
  pt1, pt0, pt2: PChar;
  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: cardinal;
  begin
    delta := 50000;
    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
{$IFDEF USE_HASH}
              TlkJSONobject(o).ht.AddPair(TlkJSONobjectmethod(c).Name, i);
{$ELSE}
              TlkJSONobject(o).ht.Insert(TlkJSONobjectmethod(c).Name, i);
{$ENDIF USE_HASH}
          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;

    function strSpecialChars(const s: string): string;
    var
      i, j : integer;
    begin
      i := Pos('\', s);
      if (i = 0) then
        Result := s
      else
      begin
        Result := Copy(s, 1, i-1);
        j := i;
        repeat
          if (s[j] = '\') then
          begin
            inc(j);
            case s[j] of
              '\': Result := Result + '\';
              '"': Result := Result + '"';
              '''': Result := Result + '''';
              '/': Result := Result + '/';
              'b': Result := Result + #8;
              'f': Result := Result + #12;
              'n': Result := Result + #10;
              'r': Result := Result + #13;
              't': Result := Result + #9;
              'u':
                begin
                  Result := Result + code2utf(strtoint('$' + copy(s, j + 1, 4)));
                  inc(j, 4);
                end;
            end;
          end
          else
            Result := Result + s[j];
          inc(j);
        until j > length(s);
      end;
    end;

  var
    js: TlkJSONstring;
    fin: Boolean;
    ws: String;
    i,j,widx: Integer;
  begin
    skip_spc(idx);

    result := xe(idx) and (txt[idx] = '"');
    if not result then exit;

    inc(idx);
    widx := idx;

    fin:=false;
    REPEAT
      i := 0;
      j := 0;
      while (widx<=length(txt)) and (j=0) do
        begin
          if (i=0) and (txt[widx]='\') then i:=widx;
          if (j=0) and (txt[widx]='"') then j:=widx;
          inc(widx);
        end;
// incorrect string!!!
      if j=0 then
        begin
          result := false;
          exit;
        end;
// if we have no slashed chars in string
      if (i=0) or (j<i) then
        begin
          ws := copy(txt,idx,j-idx);
          idx := j;
          fin := true;
        end
// if i>0 and j>=i - skip slashed char
      else
        begin
          widx:=i+2;
        end;
    UNTIL fin;

    ws := strSpecialChars(ws);
    inc(idx);

    js := TlkJSONstring.Create;
{$ifdef USE_D2009}
    js.FValue := UTF8ToString(ws);
{$else}
    js.FValue := UTF8Decode(ws);
{$endif}
    add_child(o, TlkJSONbase(js));
    ridx := idx;
  end;

  function js_list(idx: Integer; var ridx: Integer; var o:
    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;
      skip_spc(idx);
      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;
      skip_spc(idx);  
      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;
    // skip a BOM utf8 marker
    if copy(txt,idx,3)=#239#187#191 then
      begin
        inc(idx,3);
    // if there are only a BOM - exit;
        if idx>length(txt) then exit;
      end;
    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 }

{$IFDEF USE_HASH}
procedure TlkHashTable.AddPair(const ws: WideString; idx: Integer);
var
  i, j, k: cardinal;
  p: PlkHashItem;
  find: boolean;
begin
  find := false;
  if InTable(ws, i, j, k) then
    begin
// if string is already in table, changing index
      if TlkJSONobject(FParent).GetNameOf(PlkHashItem(a_x[j].Items[k])^.index) = ws then
        begin
           PlkHashItem(a_x[j].Items[k])^.index := idx;
           find := true;
        end;
    end;
  if find = false then
    begin
      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;
{using "binary" search always, because array is sorted}
  if a_x[j].Count-1 >= 0 then
    begin
      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;

// verify k index in chain
  if result = true then
    begin
      while (k > 0) and (PlkHashItem(a_x[j].Items[k])^.hash = PlkHashItem(a_x[j].Items[k-1])^.hash) do dec(k);
      repeat
        fin := true;
        if TlkJSONobject(FParent).GetNameOf(PlkHashItem(a_x[j].Items[k])^.index) <> ws then
          begin
            if k < a_x[j].Count-1 then
              begin
                inc(k);
                fin := false;
              end
            else
              begin
                result := false;
              end;
          end
        else
          begin
            result := true;
          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;
{$ENDIF USE_HASH}

{ 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}

{ TlkBalTree }

{$IFNDEF USE_HASH}
procedure TlkBalTree.Clear;

  procedure rec(t: PlkBalNode);
  begin
    if t.left<>fbottom then rec(t.left);
    if t.right<>fbottom then rec(t.right);
    t.nm := '';
    dispose(t);
  end;

begin
  if froot<>fbottom then rec(froot);
  froot := fbottom;
  fdeleted := fbottom;
end;

function TlkBalTree.counters: string;
begin
  result := format('Balanced tree root node level is %d',[froot.level]);
end;

constructor TlkBalTree.Create;
begin
  inherited Create;
  new(fbottom);
  fbottom.left := fbottom;
  fbottom.right := fbottom;
  fbottom.level := 0;
  fdeleted := fbottom;
  froot := fbottom;
end;

function TlkBalTree.Delete(const ws: WideString): Boolean;

  procedure UpdateKeys(t: PlkBalNode; idx: integer);
  begin
    if t <> fbottom then begin
      if t.key > idx then
        t.key := t.key - 1;
      UpdateKeys(t.left, idx);
      UpdateKeys(t.right, idx);
    end;
  end;

  function del(var t: PlkBalNode): Boolean;
  begin
    result := false;
    if t<>fbottom then begin
      flast := t;
      if ws<t.nm then
        result := del(t.left)
      else begin
        fdeleted := t;
        result := del(t.right);
      end;
      if (t = flast) and (fdeleted <> fbottom) and (ws = fdeleted.nm) then begin
        UpdateKeys(froot, fdeleted.key);
        fdeleted.key := t.key;
        fdeleted.nm := t.nm;
        t := t.right;
        flast.nm := '';
        dispose(flast);
        result := true;
      end
      else if (t.left.level < (t.level - 1)) or (t.right.level < (t.level - 1)) then begin
        t.level := t.level - 1;
        if t.right.level > t.level then
          t.right.level := t.level;
        skew(t);
        skew(t.right);
        skew(t.right.right);
        split(t);
        split(t.right);
      end;
    end;
  end;

{
// mine version, buggy, see tracker message
// [ 2229135 ] Value deletion is broken by "Nobody/Anonymous - nobody"

  function del(var t: PlkBalNode): Boolean;
  begin
    result := false;
    if t<>fbottom then
      begin
        flast := t;
        if ws<t.nm then
          result := del(t.left)
        else
          begin
            fdeleted := t;
            result := del(t.right);
          end;
        if (t = flast) and (fdeleted<>fbottom) and (ws = t.nm) then
          begin
            fdeleted.key := t.key;
            fdeleted.nm := t.nm;
            t := t.right;
            flast.nm := '';
            dispose(flast);
            result := true;
          end
        else if (t.left.level<(t.level-1)) or (t.right.level<(t.level-1)) then
          begin
            t.level := t.level-1;
            if t.right.level>t.level then t.right.level := t.level;
            skew(t);
            skew(t.right);
            skew(t.right.right);
            split(t);
            split(t.right);
          end;
      end;
  end;
}

begin
  result := del(froot);
end;

destructor TlkBalTree.Destroy;
begin
  Clear;
  dispose(fbottom);
  inherited;
end;

function TlkBalTree.IndexOf(const ws: WideString): Integer;
var
  tk: PlkBalNode;
begin
  result := -1;
  tk := froot;
  while (result=-1) and (tk<>fbottom) do
    begin
      if tk.nm = ws then result := tk.key
      else if ws<tk.nm then tk := tk.left
      else tk := tk.right;
    end;
end;

function TlkBalTree.Insert(const ws: WideString; x: Integer): Boolean;

  function ins(var t: PlkBalNode): Boolean;
  begin
    if t = fbottom then
      begin
        new(t);
        t.key := x;
        t.nm := ws;
        t.left := fbottom;
        t.right := fbottom;
        t.level := 1;
        result := true;
      end
    else
      begin
        if ws < t.nm then
          result := ins(t.left)
        else if ws > t.nm then
          result := ins(t.right)
        else result := false;
        skew(t);
        split(t);
      end;
  end;

begin
  result := ins(froot);
end;

procedure TlkBalTree.skew(var t: PlkBalNode);
var
  temp: PlkBalNode;
begin
  if t.left.level = t.level then
    begin
      temp := t;
      t := t.left;
      temp.left := t.right;
      t.right := temp;
    end;
end;

procedure TlkBalTree.split(var t: PlkBalNode);
var
  temp: PlkBalNode;
begin
  if t.right.right.level = t.level then
    begin
      temp := t;
      t := t.right;
      temp.right := t.left;
      t.left := temp;
      t.level := t.level+1;
    end;
end;
{$ENDIF USE_HASH}

initialization
{$IFNDEF THREADSAFE}
{$IFDEF USE_HASH}
  init_rnd;
{$ENDIF USE_HASH}
{$ENDIF THREADSAFE}
end.

Este foi um script que utilizei para fazer backup de um cliente durante vários anos. Atualmente está escrito para o software Imobiliar, de controle imobiliário e o SAGE de controle financeiro. Mas pode ser adaptado a qualquer software.

O software roda em servidor Windows, utiliza o software WinSCP para conectar nas instâncias remotas e o WinRAR para compactar tudo.

set winscp=”C:\Program Files (x86)\WinSCP\WinSCP.com”
set winrar=”C:\Program Files\WinRAR\RAR.exe”

if not exist “D:\Backups\PROPER\” mkdir D:\Backups\PROPER\

if not exist “D:\Backups\PROPER\IMOBILIAR\” mkdir D:\Backups\PROPER\IMOBILIAR\
echo option batch continue > proper.tmp
echo option confirm off >> proper.tmp
echo open sftp://root:inetsoft@proper.hopto.org:5022 -hostkey=”ssh-rsa 2048 92:52:c4:36:d0:d9:8f:b7:dc:31:e3:3a:bb:a7:40:f2″ >> proper.tmp
echo synchronize local D:\Backups\PROPER\IMOBILIAR\ /imobiliar/servicos/Backup >> proper.tmp
echo exit >> proper.tmp
%winscp% /script=proper.tmp
del /Q proper.tmp

if not exist “D:\Backups\PROPER\SAGE\” mkdir D:\Backups\PROPER\SAGE\
if not exist “D:\Backups\PROPER\SAGE\ESPELHO\” mkdir D:\Backups\PROPER\SAGE\ESPELHO\
echo option batch continue > proper2.tmp
echo option confirm off >> proper2.tmp
echo open sftp://PROPER:”senhaocultada”@proper.hopto.org:5023 -hostkey=”ssh-rsa 2048 05:2c:39:16:83:ba:6a:2b:67:f1:36:fd:0e:4d:2a:a2″ >> proper2.tmp
echo synchronize local D:\Backups\PROPER\SAGE\ESPELHO\ “/drives/c/Arquivos de programas/Sage Start/database” >> proper2.tmp
echo exit >> proper2.tmp
%winscp% /script=proper2.tmp
del /Q proper2.tmp
%winrar% a -agYYYY-MM-DD -cfg- -ep1 -inul -m5 -r -y D:\Backups\PROPER\SAGE\BACKUP-.rar D:\Backups\PROPER\SAGE\ESPELHO\

Desenvolvi o seguinte conjunto de consultas que podem ser executadas a partir do Microsoft Access, abrindo o arquivo de banco de dados do GasExpert 2016. No geral, este arquivo se encontra localizado em C:\Maikonlyne\Gas Expert 2016\sistema.mdb

Essa consulta é capaz de apagar dados antigos, neste caso, antes de 2019 (que você pode alterar conforme sua necessidade e o ano que estiver lendo este artigo).

DELETE FROM Contas WHERE (NOT ISNULL(dt_pgto) AND YEAR(dt_doc)<2019) OR (YEAR(dt_pgto)<2020 AND NOT ISNULL(dt_pgto)) OR (tipo = “CARTAO DE CRED / DEB”);

DELETE a.* FROM Clientes AS a WHERE ( a.codigo_cliente NOT IN( SELECT b.codigo_cliente FROM Vendas AS b INNER JOIN Vendas_Capa AS c ON c.codigo_venda = b.codigo_venda WHERE YEAR(c.data) >= 2019 GROUP BY b.codigo_cliente ) ) AND ( a.codigo_cliente NOT IN(SELECT d.codigo_cliente FROM Contas AS d) );

DELETE a.* FROM Vendas AS a WHERE EXISTS( SELECT b.codigo_venda FROM Vendas_Capa AS b WHERE a.codigo_venda = b.codigo_venda AND YEAR(b.data) < 2019 );

DELETE FROM Vales WHERE YEAR(data) < 2019;

DELETE FROM Tele_Capa WHERE YEAR(data) < 2019;

DELETE FROM MovVeiculos WHERE YEAR(data) < 2019;

DELETE FROM MovProdutos WHERE YEAR(data) < 2019;

DELETE FROM Ligacoes WHERE YEAR(data) < 2019;

DELETE FROM Historicos WHERE YEAR(data) < 2019;

DELETE FROM Caixa WHERE YEAR(data) < 2019;

Veja como migrar seus contatos registrados no seu e-mail da UOL para outro servidor de sua preferência.

Esta semana, um cliente solicitou que realizasse a migração de diversos e-mails estabelecidos no UOL para um provedor particular. Pois bem, por surpresa minha e também de outras pessoas, o UOL não fornece nenhuma opção de exportação de contatos, o que tem suscitado críticas inclusive no site do Reclame Aqui.

Sem entrar na análise ética disso, vamos logo ao que fazer.

1 – Acesse o e-mail da UOL que deseja exportar, depois vá até “Contatos”.

2 – Selecione todos os contatos na lista de endereços usando o botão “selecionar todos”, no canto superior esquerdo

3 – Clique na opção “Enviar e-mail”, botão branco acima do botão de selecionar todos.

4 – Na lista de endereços para enviar e-mail, clique com o botão direito do mouse e depois em “Inspecionar”.

5 – Em seguida, role o código HTML até o cabeçalho da tag <ul id=”input_type_tags__field-to” class=”container compose_tags input-type-tags field-text ng-scope”>, clique com o botão direito e depois em “Copy” e “Copy element”.

6 – Vá até o site
https://email-checker.net/email-extractor e cole o conteúdo copiado do HTML do e-mail, depois clique em “Extract Email”

7 – Pronto, seus contatos de e-mail estarão a disposição para importar em outro e-mail.

Se você conseguiu extrair seus contatos deixe um comentário abaixo 😉