Vídeo
Solução
TODA A DESCOBERTA DA CIENCIA PURA E POTENCIALMENTE SUBVERSIVA POR VEZES A CIENCIA DEVE SER TRATADA COMO UM INIMIGO POSSIVEL
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\
Desenvolvi o seguinte conjunto de consultas que podem ser executadas a partir do Microsoft Access, abrindo o arquivo de banco de dados do GasExpert 2016. No geral, este arquivo se encontra localizado em C:\Maikonlyne\Gas Expert 2016\sistema.mdb
Essa consulta é capaz de apagar dados antigos, neste caso, antes de 2019 (que você pode alterar conforme sua necessidade e o ano que estiver lendo este artigo).
DELETE FROM Contas WHERE (NOT ISNULL(dt_pgto) AND YEAR(dt_doc)<2019) OR (YEAR(dt_pgto)<2020 AND NOT ISNULL(dt_pgto)) OR (tipo = “CARTAO DE CRED / DEB”);
DELETE a.* FROM Clientes AS a WHERE ( a.codigo_cliente NOT IN( SELECT b.codigo_cliente FROM Vendas AS b INNER JOIN Vendas_Capa AS c ON c.codigo_venda = b.codigo_venda WHERE YEAR(c.data) >= 2019 GROUP BY b.codigo_cliente ) ) AND ( a.codigo_cliente NOT IN(SELECT d.codigo_cliente FROM Contas AS d) );
DELETE a.* FROM Vendas AS a WHERE EXISTS( SELECT b.codigo_venda FROM Vendas_Capa AS b WHERE a.codigo_venda = b.codigo_venda AND YEAR(b.data) < 2019 );
DELETE FROM Vales WHERE YEAR(data) < 2019;
DELETE FROM Tele_Capa WHERE YEAR(data) < 2019;
DELETE FROM MovVeiculos WHERE YEAR(data) < 2019;
DELETE FROM MovProdutos WHERE YEAR(data) < 2019;
DELETE FROM Ligacoes WHERE YEAR(data) < 2019;
DELETE FROM Historicos WHERE YEAR(data) < 2019;
DELETE FROM Caixa WHERE YEAR(data) < 2019;
A Cobra era de propriedade da Dynascan quando o primeiro 148 foi produzido nos anos 70. Então a propriedade passou para a Uniden. Depois disso, a Cobra se separou da Uniden comprando a empresa imediatamente e a Cobra se tornou sua dona.
Os rádios Cobra produzidos pela Dynascan e pela Uniden são geralmente considerados de qualidade superior.
Malásia e Taiwan (por Uniden), 1975-1989. (descontinuado). A fábrica de Uniden tinha uma reputação de melhor controle de qualidade nos negócios quando eles mudaram a produção de CB de Taiwan no final de 1989.
Veja como migrar seus contatos registrados no seu e-mail da UOL para outro servidor de sua preferência.
Esta semana, um cliente solicitou que realizasse a migração de diversos e-mails estabelecidos no UOL para um provedor particular. Pois bem, por surpresa minha e também de outras pessoas, o UOL não fornece nenhuma opção de exportação de contatos, o que tem suscitado críticas inclusive no site do Reclame Aqui.
Sem entrar na análise ética disso, vamos logo ao que fazer.
1 – Acesse o e-mail da UOL que deseja exportar, depois vá até “Contatos”.
2 – Selecione todos os contatos na lista de endereços usando o botão “selecionar todos”, no canto superior esquerdo
3 – Clique na opção “Enviar e-mail”, botão branco acima do botão de selecionar todos.
4 – Na lista de endereços para enviar e-mail, clique com o botão direito do mouse e depois em “Inspecionar”.
5 – Em seguida, role o código HTML até o cabeçalho da tag <ul id=”input_type_tags__field-to” class=”container compose_tags input-type-tags field-text ng-scope”>, clique com o botão direito e depois em “Copy” e “Copy element”.
6 – Vá até o site
https://email-checker.net/email-extractor e cole o conteúdo copiado do HTML do e-mail, depois clique em “Extract Email”
7 – Pronto, seus contatos de e-mail estarão a disposição para importar em outro e-mail.
Se você conseguiu extrair seus contatos deixe um comentário abaixo 😉