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
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.
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
TODA A DESCOBERTA DA CIENCIA PURA E POTENCIALMENTE SUBVERSIVA POR VEZES A CIENCIA DEVE SER TRATADA COMO UM INIMIGO POSSIVEL
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
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.
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)
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 para ajudar você a decorar as letras do Código Morse
Letras:
Números:
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.
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
TÁ
U RU BU
VIM TI BUS CÁ
DI DA DÁ
XOU DI KI PÁ
GOL DI VA VÁ
VAI LÁ ZI ZI
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.
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.
Canal no YouTube do Igor (PY3IG): Igor Jobim – YouTube
Grupo no Whatsapp (estou lá): https://api.whatsapp.com/send?phone=5…
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
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.tmpif 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\