Placar Poliesportivo (ESEF – UFPel)

Como forma de ajudar no desenvolvimento das atividades acadêmicas da UFPel, em 2018, doei para a Escola Superior de Educação Física (ESEF) um software que pode ser utilizado em qualquer televisão para torná-lo um placar eletrônico.

O software está disponível para download gratuito, clique aqui.

Veja imagens do placar em funcionamento no ginásio da escola:

* NSEC é a marca da empresa que empreendi até 2018

Ar-SandBox UFPel

Nenhuma descrição de foto disponível.

O ArSandBox é um projeto colaborativo desenvolvido pela UC Davis’ W.M. Keck Center for Active Visualization in the Earth Sciences (KeckCAVES), junto com o UC Davis Tahoe Environmental Research Center, o Lawrence Hall of Science e o ECHO Lake Aquarium and Science Center.

Fizemos a implementação do projeto na Universidade Federal de Pelotas em 2017 sob a coordenação de mestrandos e doutorandos do curso de Engenharia Hídrica.

O projeto consiste em um sensor do Microsoft Kinect ligado a um computador e um projetor apontado para uma caixa de areia. O software instalado no Linux controla o sensor do Kinect projetando a topografia da caixa de areia conforme seu relevo.

Veja na prática seu funcionamento:

*NSEC é a marca da empresa que empreendi até 2018.

Instalando TQSL (atualizado) no RaspBerry PI

Para instalar o TQSL da ARRL no rasp, precisamos baixar e compilar o aplicativo. Há uma versão disponível no repositório APT (pacote trustedqsl), mas ela nem sempre é atualizada, deixando de funcionar por períodos.

Primeiro, precisamos instalar as bibliotecas de desenvolvimento e compilação utilizadas pelo TQSL.

$apt-get install build-essential libcurl4-openssl-dev libdb-dev libexpat1-dev liblmdb-dev libssl-dev libwxgtk3.0-dev zlib1g-dev

Agora, baixe o pacote mais atualizado no site da ARRL:

http://www.arrl.org/tqsl-download

Descompacte e um diretório e vamos compilar e instalar.

$cmake .
$make
$make install

Solução da FRASE 1 – Aprenda CW

Vídeo

Solução

NAO ACREDITE EM ALGO SIMPLESMENTE PORQUE OUVIU NAO ACREDITE EM ALGO SIMPLESMENTE PORQUE TODOS FALAM A RESPEITO NAO ACREDITE EM ALGO SIMPLESMENTE PORQUE ESTA ESCRITO EM SEUS LIVROS RELIGIOSOS NAO ACREDITE EM ALGO SO PORQUE SEUS PROFESSORES E MESTRES DIZEM QUE E VERDADE NAO ACREDITE EM TRADICOES SO PORQUE FORAM PASSADAS DE GERACAO EM GERACAO MAS DEPOIS DE MUITA ANALISE E OBSERVACAO SE VOCE VE QUE ALGO CONCORDA COM A RAZAO E QUE CONDUZ AO BEM E BENEFICIO DE TODOS ACEITAO E VIVAO

Código Morse (CW)

Neste final de 2020 iniciei minha trajetória de estudos para aprender o tão temido CW e prestar prova para progressão para a Classe B na Anatel. Para abrir uma nova sessão aqui no blog sobre meu hobby predileto, o radioamadorismo, gostaria de compartilhar com todos algumas facilidades que me ajudaram neste estudo e algumas ferramentas que desenvolvi para auxiliar no aprendizado.

Aplicativos

Dois aplicativos criados por mim (um aperfeiçoado do Rádio Regular) para auxiliar no estudo do CW:

Conversor de TEXTO para CW (Código Morse)

Gerador de FRASES em CW

Outros aplicativos úteis

Aplicativo (Android) para decorar as letras: https://play.google.com/store/apps/details?id=net.countrymania.morse&hl=pt_BR

Aplicativo (Web) da Google para treinar online – Palavras em inglês: https://morse.withgoogle.com/learn/

Áudios

Áudios para ajudar você a decorar as letras do Código Morse

Letras:

Números:

Textos da prova

Textos usados pela Anatel nas provas (disponibilizado no site da agência):

Texto 01: SERVICO DE RADIODIFUSAO EH DEFINIDO COMO UM SERVICO DE RADIOCOMUNICACAO CUJAS EMISSOES ESTAO DESTINADAS A RECEPCAO DIRETA PELO PUBLICO EM GERAL PT

Texto 02: A ARCA DE NOE QUE PODE NOS SALVAR DO DILUVIO DE PAPEL EH O MICROFILME, QUE TEM O CONDAO NAO APENAS DE RESOLVER ESTE, MAS TODOS OS PROBLEMAS DE ARQUIVO.


Texto 03: EH NECESSARIO O USO DE RADIOFAROIS, ESTACOES DE EMBARCACOES E DISPOSITIVOS DE SALVAMENTO PARA SEGURANCA DA NAVEGACAO E SALVAR VIDAS HUMANAS NO MAR PT


Texto 04: EXISTINDO COMUNICACAO ENTRE DOIS PONTOS PODEMOS TRANSMITIR A MENSAGEM DESEJADA ATRAVES DE CODIGOS OU DA PROPRIA VOZ USANDO VOZ TEMOS A TELEFONIA.


Texto 05: A HISTORIA TEM NOS ENSINADO QUE UM LIBERALISMO EXCESSIVO CONDUZ A DESORDEM E A INTRANQUILIDADE, PELO MENOS ATE O ATUAL ESTAGIO DA EVOLUCAO HUMANA PT


Texto 06: ADMINISTRAR ESPECTRO DE RADIOFREQUENCIA IMPLICA EM GERIR RACIONALMENTE A UTILIZACAO DE DIVERSAS FREQUENCIAS DISTRIBUIDAS PELOS SEUS USUARIOS.


Texto 07: A ULTIMA CONFERENCIA DA U.I.T VG QUE REVISOU O PLANO DE DISTRIBUICAO DE FREQUENCIAS PARA O SERVICO MOVEL AERONAUTICO VG FOI REALIZADA NO ANO DE 1966.


Texto 08: NUM RITUAL QUE SE REPETE TODOS OS ANOS, EM OLIMPIA, NA GRECIA, A TOCHA OLIMPICA EH ACESA, PARTINDO LOGO EM SEGUIDA PARA O PAIS SEDE DOS JOGOS OLIMPICOS PT


Texto 09: A INDEXACAO EH O FATOR BASICO VG FUNDAMENTAL VG INDISPENSAVEL VG PARA O EXITO DE QUALQUER SISTEMA DE MICROFILMAGEM OU DE ARMAZENAMENTO EM COMPUTADOR.


Texto 10: MEIO UTILIZADO PARA A PROPAGACAO DAS ONDAS ELETROMAGNETICAS VG EH A CAMADA ATMOSFERICA ADJACENTE A SUPERFICIE TERRESTRE DENOMINADA TROPOSFERA PT


Texto 11: A FIBRA OTICA CONSISTE, EM PRINCIPIO, NUM NUCLEO INTERNO DE VIDRO DE ALTISSIMO GRAU DE PUREZA ENVOLVIDO POR UMA CAMADA EXTERNA OU INVOLUCRO DE VIDRO.


Texto 12: REGULAMENTO DE RADIOCOMUNICACOES DA UIT, COBRE A FAIXA DE ESPECTRO ELETRICO DE 1O KHZ A 275 KHZ E ESTABELECE ATRIBUICOES A 41 DIFERENTES SERVICOS PT


Texto 13: A VOZ DO COMANDO SOH CHEGA ATE ONDE VAI O FIO TELEFONICO OU ONDE CHEGAM AS ONDAS ELETROMAGNETICAS DOS CONJUNTOS RADIO E EQUIPAMENTOS DE MULTICANAIS PT


Texto 14: RADIO, NO BRASIL, FOI UTILIZADO ANTES DA PRIMEIRA GUERRA MUNDIAL, PELA REPARTICAO GERAL DOS TELEGRAFOS, PELO EXERCITO E PELA MARINHA BRASILEIRA.


Texto 15: VIVER EH ATRAVES DE UM SORRISO BUSCAR O OUTRO. EH SABER PARTIR E SABER VOLTAR. EH TRANSFORMAR SONHOS EM REALIDADES CERTOS DE QUE SERIA TOLICE INVERTE-LOS.


Texto 16: VOCE SABIA QUE: EM 1874 FOI LANCADO O PRIMEIRO CABO SUBMARINO E QUE ESTE LIGAVA RECIFE E LISBOA? QUE O BRASIL FOI O PRIMEIRO PAIS DO MUNDO A EMITIR SELOS?


Texto 17: VOCE SABIA QUE: O TELEGRAFO FOI INVENTADO NO ANO DE 1838 POR SAMUEL MORRE E QUE A PRIMEIRA MENSAGEM TRANSMITIDA ATRAVES DELE FOI: ATENCAO UNIVERSO?


Texto 18: A COMUNICACAO PODE SER DEFINIDA COMO A EMISSAO E A RECEPCAO DE INFORMACOES, IDEIAS, EMOCOES, ETC, POR MEIO DO USO DE SIMBOLOS, DE IMAGENS, SONS, ETC PT


Texto 19: VIVER EH IR CONSUMINDO O AMANHA, NA EXPECTATIVA DE UM OUTRO AMANHA. EH PERCORRER CAMINHOS E ESTRADAS ABRACANDO A CADA CHEGADA O MEDO E A CORAGEM.


Texto 20: CADA UM DEVE FABRICAR SEU SEGREDO E GUARDA-LO O PERFUME DA FLOR, POR EXEMPLO, EH UM SEGREDO. SE A ARRANCAMOS DO JARDIM ELA MORRE. E MORTA AINDA PERFUMA.


Texto 21: SABER VIVER NAO EH VIAJAR PELO ESPACO QUANDO NO CHAO SE TEM TANTO PARA ENSINAR TANTO PARA APRENDER. SABER VIVER EH SONHAR SEM SE AFASTAR, SEM SE ESQUECER.


Texto 22: SISTEMA DE TELECOMUNICACOES VG EM NOSSO PAIS VG DEPENDE DE UM GRANDE NUMERO DE FATORES DISTINTOS VG IMPLICANDO EM CONTINUA REVISAO E ATUALIZACAO PT


Texto 23: ATRAVES DAS COMUNICACOES, O HOMEM EVITA A SOLIDAO FRUSTRANTE DO ISOLAMENTO E, AINDA, ENCONTRA UM MEIO DE SATISFAZER AS SUAS NECESSIDADES E DESEJOS.


Texto 24: A INCAPACIDADE PARA AFIRMAR A SUPREMACIA DA POLITICA SOBRE A TECNOLOGIA, EH UM FENOMENO BASTANTE ALARMANTE E CADA VEZ MAIS PERIGOSO NO MUNDO MODERNO.


Texto 25: COMPUTADOR CONTINUARA INVADINDO TODOS OS DOMINIOS DA VIDA HUMANA E, PARTICULARMENTE AS TELECOMUNICACOES. SERA BOM QUE TODOS APRENDAM A PALAVRA.


Texto 26: ORA AQUI TENS, MEU CARO CIDADAO: SUPOE QUE TU QUERES TER NA TUA SALA A IMAGEM DE NAPOLEAO I PASSANDO PELOS ALPES (ESTAS FANTASIAS SAO-TE PERMITIDAS) PT


Texto 27: VIDA NAO EH O QUE GERA NO VENTRE E FINALIZA NO TUMULO, PORQUE ESTES ESPACOS DE ANO SAO INSTANTES DE UMA VIDA SECULAR E ETERNA EH ESTA MESQUINHA EXISTENCIA.


Texto 28: NINGUEM SERA SUJEITO A INTERFERENCIA EM SUA VIDA PRIVADA, SUA FAMILIA, EM SEU LUGAR OU SUA CORRESPONDENCIA, NEM A ATAQUES A SUA HONRA E SUA REPUTACAO.


Texto 29: MINUTO DIVIDE O CRESCER DA EXISTENCIA E O SEU ACORDAR; EH A PRIMEIRA CHAMA QUE ILUMINA OS RECANTOS DA ALMA E O PRIMEIRO SOM ENCANTADO NA PRIMEIRA CORDA.


Texto 30: A SOCIEDADE DA INFORMACAO IRA DEFLAGRAR VG NECESSARIAMENTE VG CONFLITOS CULTURAIS PT O PRIMEIRO DELES VG SERA AS AMEACAS DA INVASAO DA PRIVACIDADE PT

Texto 31: OS PRODUTOS ARTESANAIS ESTAO INVADINDO O MERCADO E OS ARTESOES, QUE, ALEM DA ADMIRACAO, ESTAO GANHANDO MAIS DINHEIRO, MUITO MAIS DO QUE PLANEJARAM.

Texto 32: OS BRASILEIROS FICARAM DESCONFIADOS, EM MARCO DE 1994. QUANDO O GOVERNO FEDERAL ANUNCIOU UM PACOTE DE MEDIDAS, QUE MUDAVA NOVAMENTE O NOME DA MOEDA.

Texto 33: EM 1984, ARMACAO DE BUZIOS ERA APENAS UM COLAR DE PRAIAS, ILHAS E ENSEADAS, NÃO MUITO DIFERENTE DOS TEMPOS EM QUE FORA UM PORTO DE PIRATAS E BALEEIROS.

Texto 34: SAI ANO, ENTRA ANO E A TELEVISAO BRASILEIRA NÃO CONSEGUE DAR CABO DE UM TIPO DE ATRACAO QUE REMONTA A EPOCA DE OURO DO RADIO: O PROGRAMA DE CALOUROS AO VIVO.

Texto 35: O PROGRAMA SITIO DO PICA-PAU AMARELO VIRA MANIA ENTRE AS CRIANCAS. PROFESSORES APROVEITAM PARA ENSINAR MITOLOGIA, HISTORIA E CULTURA BRASILEIRA.

Texto 36: MONTEIRO LOBATO ESCREVEU 17 OBRAS E CONQUISTA AS CRIANCAS MESMO NA ERA POKEMON, E AINDA AJUDA PROFESSORES A ENSINAR TEMAS COMPLEXOS COMO FOLCLORE.

Métodos

O método utilizado pela Marinha do Brasil na instrução de Código Morse é associar as letras a palavras com sons musicais parecidos, da seguinte forma:

A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q
R
S
T
U
V
W
X
Y
Z

DI DÁ
DÁ DI DI DI
DA DI DA DI
DÁ DI DI
DI
DI DI DA DI
DA DA DI
DI DI DI DI
DI DI
DI DA DA DA
DA DI DA
DI DA DI DI
DA DA
DA DI
DA DA DA
DI DA DA DI
DA DA DI DA
DI DA DI
DI DI DI
DA
DI DI DA
DI DI DI DA
DI DA DA
DA DI DI DA
DA DI DA DA
DA DA DI DI

É Á
BOM DI XI XI
DA CIL DA DI
GOL DI DI
DI
FI TI PAL DI
GUA RÂ NI
HI RÍ RI RI
DI DI
JI PÁ RA NÁ
KA DE KÁ
VIM CÁ LI LI
MA MÁ
NA VI
O RO RÓ
PI RÁ CAM BI
QUA RÁ TI BÁ
RI COR DI
SI RI RI

U RU BU
VIM TI BUS CÁ
DI DA DÁ
XOU DI KI PÁ
GOL DI VA VÁ
VAI LÁ ZI ZI

Rodando o NanoVNASaver na Raspberry

O NanoVNASaver é um utilitário desktop que faz uma interface melhorada para acessar funcionalidades do NanoVNA. Para utilizar o NanoVNASaver é necessário que seu Nano esteja corretamente atualizado e conectado em uma porta USB da sua Raspberry ou Computador (Windows ou Mac).

No site do NanoVNASaver encontramos diversas versões, para Windows, Mac e Linux, no entanto, a versão executável disponível para Linux é compilada para processadores baseados em arquitetura Intel, portanto, não funciona no RaspBerry.

Rodando o NanoVNASaver no Raspberry

Passo 1 – Faça o download do código fonte do NanoVNASaver no site https://www.nanovna.com

Passo 2 – Descompacte o código fonte em uma pasta da sua Raspberry (aqui, descompactei em /home/pi/NanoVNASaver/)

Passo 3 – Agora, precisamos instalar alguns pacotes para que o programa funcione corretamente, vamos lá:

$apt-get install python3-pyqt5
$apt-get install pyqt5-dev-tools
$pip3 install scipy
$apt-get install libatlas-base-dev

Instalados estes pacotes corretamente, basta acessar o diretório onde você descompactou o código fonte do NanoVNASaver e executar.

$python3 nanovna-saver.py

Prontinho! O software deve executar com perfeição.

Tudo sobre NanoVNA

Canal no YouTube do Igor (PY3IG): Igor Jobim – YouTube

Grupo no Whatsapp (estou lá): https://api.whatsapp.com/send?phone=5…

O “IRC” está de volta!

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 v1.08 UNOFFICIAL

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 (&gt;=1.08) by Nataniel Kegles &lt;nataniel@kegles.com.br&gt;
*
* 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 &lt;organization&gt; 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 &gt; 14.00}
    {$DEFINE HAVE_FORMATSETTING}
    {$IF RTLVersion &gt; 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 &lt;&gt; '' then
            begin
              vStr := vStr + ','#13#10;
            end;
          vStr := vStr + Indent(vLevel) +
            GenerateReadableText(TlkJSONobject(vObj).Child[i], vLevel);
        end;
      if vStr &lt;&gt; '' 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 &lt;&gt; '' then
            begin
              vStr := vStr + ','#13#10;
            end;
          vStr := vStr + Indent(vLevel) +
              GenerateReadableText(TlkJSONList(vObj).Child[i], vLevel);
        end;
      if vStr &lt;&gt; '' 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 &lt;&gt; '' 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 &lt; 128 then Result := chr(iNumber)
  else if iNumber &lt; 2048 then
    Result := chr((iNumber shr 6) + 192) + chr((iNumber and 63) + 128)
  else if iNumber &lt; 65536 then
    Result := chr((iNumber shr 12) + 224) + chr(((iNumber shr 6) and
      63) + 128) + chr((iNumber and 63) + 128)
  else if iNumber &lt; 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 &lt; 0) or (iIndex &gt;= Count)) then
    begin
      if fList.Items[iIndex] &lt;&gt; nil then
        TlkJSONbase(fList.Items[iIndex]).Free;
      idx := pred(fList.Count);
      if iIndex&lt;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 &lt; 0) or (idx &gt;= 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 &lt; 0) or (idx &gt;= Count)) then
    begin
      if fList.Items[idx] &lt;&gt; 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 &lt;&gt; 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 &gt;= 0) and (idx &lt; 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&lt;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 &lt;&gt; -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 &lt;&gt; '' then
    begin
      result := Field[nm];
    end
  else
    begin
      result := nil;
    end;
end;

function TlkJSONobject.GetNameOf(idx: Integer): WideString;
var
  mth: TlkJSONobjectmethod;
begin
  if (idx &lt; 0) or (idx &gt;= 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 &lt;&gt; '' 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 &lt;&gt; '.') and (i &gt; 0) then
          result[i] := '.';
{$ENDIF}
      end
    else if obj is TlkJSONstring then
      begin
        ws := UTF8Encode(TlkJSONstring(obj).FValue);
        i := 1;
        result := '"';
        while i &lt;= 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]) &lt; 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 &gt; 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 &gt; 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 &gt;= 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 &gt;= 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 &lt;&gt; '.') and (i &gt; 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 &lt;= 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]) &lt; 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 &gt; 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 &gt; 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 &lt;= length(txt);
  end;

  procedure skip_spc(var idx: Integer);
  {$IFDEF FPC}inline;
  {$ENDIF}
  begin
    while (xe(idx)) and (ord(txt[idx]) &lt; 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 &lt;&gt; '.') and (i &gt; 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 &gt; 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&lt;=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&lt;i) then
        begin
          ws := copy(txt,idx,j-idx);
          idx := j;
          fin := true;
        end
// if i&gt;0 and j&gt;=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 &lt;&gt; 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&gt;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&gt;0) and (PlkHashItem(a_x[j].Items[k])^.hash &lt; 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 &lt; 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^ &lt;&gt; #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 &gt;= 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) &gt; 1 then
          begin
            fin := false;
            x := (wl + wu) shr 1;
            if PlkHashItem(a_x[j].Items[x])^.hash &gt; 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 &gt; 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) &lt;&gt; ws then
          begin
            if k &lt; 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&lt;&gt;fbottom then rec(t.left);
    if t.right&lt;&gt;fbottom then rec(t.right);
    t.nm := '';
    dispose(t);
  end;

begin
  if froot&lt;&gt;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 &lt;&gt; fbottom then begin
      if t.key &gt; 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&lt;&gt;fbottom then begin
      flast := t;
      if ws&lt;t.nm then
        result := del(t.left)
      else begin
        fdeleted := t;
        result := del(t.right);
      end;
      if (t = flast) and (fdeleted &lt;&gt; 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 &lt; (t.level - 1)) or (t.right.level &lt; (t.level - 1)) then begin
        t.level := t.level - 1;
        if t.right.level &gt; 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&lt;&gt;fbottom then
      begin
        flast := t;
        if ws&lt;t.nm then
          result := del(t.left)
        else
          begin
            fdeleted := t;
            result := del(t.right);
          end;
        if (t = flast) and (fdeleted&lt;&gt;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&lt;(t.level-1)) or (t.right.level&lt;(t.level-1)) then
          begin
            t.level := t.level-1;
            if t.right.level&gt;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&lt;&gt;fbottom) do
    begin
      if tk.nm = ws then result := tk.key
      else if ws&lt;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 &lt; t.nm then
          result := ins(t.left)
        else if ws &gt; 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.

Script de Backup (Imobiliar/SAGE)

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\