Web Services em AdvPL – Parte 01

Introdução

Quem não conhece, já ouviu falar de Web Services. Traduzindo em pouquíssimas palavras, Web Services é um padrão de comunicação entre sistemas, onde o provedor ( ou “servidor” ) de um Web Service, possui uma camada de publicação de classes e métodos, descritos em um documento baseado em XML, chamado de WSDL ( Web Services Description Language ), através do qual uma linguagem ou plataforma de desenvolvimento pode criar uma classe ou camada de “proxy” para acessar as funcionalidades descritas no WSDL. Normalmente os Web Services utilizam o protocolo HTTP para trocas de mensagens entre a aplicação cliente e o servidor, e são utilizados entre sistemas que podem ou não ser baseados na mesma plataforma ou tecnologia, e as aplicações client e server podem estar na mesma rede ( intranet ) ou na Internet.

WSDL

A especificação da descrição de um Web Service é bem ampla, ela prevê a descrição detalhada das classes e métodos disponíveis, descrição das estruturas de parâmetros e retornos, até mesmo a documentação textual de cada método pode ser especificada dentro do WSDL. Normalmente uma plataforma de desenvolvimento que trabalha com orientação a objetos e é compatível nativamente com Web Services, provê um tipo de classe diferenciada para permitir a publicação de uma classe implementada no formato nativo da linguagem para ser acessada como um Web Service.

SOAP

Soap é um acrônimo para Simple Object Access Protocol, trata-se de uma especificação para troca de informações estruturadas, baseado em XML. O WSDL fornecido descreve como devem ser os pacotes SOAP de envio e retorno de informações de um Web Service. A especificação das mensagens normalmente são simples, porém a especificação permite criar camadas complexas, chegando até mesmo ao nível de declaração de mensagens com herança e utilização de mais de um arquivo de definições, especificados como “includes” ou “imports” dentro dos WSDL(s).

Vantagens

Quando você usa uma plataforma ou ambiente de desenvolvimento que cria uma classe “proxy” para você consumir um Web Service, o mundo é maravilhoso, o céu é azul, tudo é lindo. Você não precisa saber ou entender o que vai dentro do XML, a classe monta tudo para você, basta alimentar os dados nas estruturas de parâmetro e consumir o serviço, e em caso de sucesso a(s) estrutura(s) de retorno estarão preenchidas. Com o detalhamento do WSDL, a classe proxy gerada pode até já vir documentada. A utilização do protocolo HTTP para envio de requisições torna mais fácil a criação de integrações de sistemas baseados em SOA (Service-Oriented Architecture), ou Arquitetura Orientada a Serviços.

Desvantagens

Quando falamos de transações curtas, requisições pequenas, Web Services é ótimo. Mas se você vai enfiar em uma única requisição um caminhão de dados, ou mesmo arquivos, a natureza de parser de XML — que normalmente exige que o documento inteiro seja parseado ou analisado antes do método chamado ser efetivamente executado — ou mesmo qualquer instabilidade no HTTP, ou picos de latência, podem tornar o processamento mais lento, devido ao overhead das camadas utilizadas, e com isso deixar o cliente do serviço esperando por muito tempo, o que não é uma boa prática. Como toda a solução tecnológica, seu uso deve ser mediante a necessidade, quando aplicável ao cenário proposto. Se você precisa transferir arquivos grandes para um processamento, faça-o via FTP, e utilize um WebService apenas para solicitar a requisição de processamento, informando o arquivo a ser utilizado. Lembrando que esta é uma prerrogativa que o desenvolvedor da parte “Server” do Web Service deve ser responsável.

Web Services no AdvPL

Desde 2002, o Protheus permite a criação de Web Services Server no repositório, bastando para isso escrever uma classe do tipo WSSERVER, e um FrameWork da LIB do ERP Microsiga provê a camada WEB de publicação ( WSDL ) e consumo. E, para a geração de uma classe proxy de um WebService, o IDE e o TDS possuem uma ferramenta de geração de código, que gera a classe client AdvPL ( WSCLIENT ), também utilizando um FrameWork da LIB do ERP Microsiga, para consumir o serviço.

A implementação dos Web Services em AdvPL (client-side) não consegue atender a especificação inteira de todas as versões de SOAP, mas atende a maioria das partes mais utilizadas das especificações. Existem algumas dificuldades com o uso de WebServices onde o WSDL “mescla” namespaces distintos nos serviços, e às vezes alguma propriedade específica da especificação é utilizada, e exige um pacote diferenciado. Uma vez que a classe proxy seja gerada em AdvPL, é possível customizá-la para atender estas necessidades, mas o desenvolvedor deve lembrar-se de que: Se ele precisar re-gerar a classe proxy, as alterações feitas por ele no código serão perdidas, portanto quando isso for mesmo necessário, cabe ao desenvolvedor manter um histórico do que ele precisou mexer na classe client, para ele refazer as mesmas alterações caso a classe client venha a ser re-gerada.

No TDN, existe uma árvore de tópicos sobre Web Services, dispinível a partir do Link http://tdn.totvs.com/display/tec/Web+Services+–+23597, onde inclusive é abordado um outro tipo de Web Service, chamado REST, que não usa XML para a troca de dados entre a aplicação cliente e servidora. Este post não substitui a documentação da TDN, apenas procura colocar alguns detalhes a mais, em uma linguagem um pouco mais informal, sobre a tecnologia envolvida.

Nova classe Client no AdvPL

Nas builds do TOTVS|Application Server, a partir da 7.00.121227P, foi publicada uma nova classe client de Web Services na linguagem AdvPL, chamada tWSDLManager. Ela é uma classe proxy dinâmica, onde você fornece para ela o WSDL do serviço, ela identifica na hora todas as classes e métodos disponíveis para serem consumidas, e provê métodos para que você consuma o serviço diretamente pela classe, ou utilize a classe como “core” de WebSErvices, para montar o pacote com a requisição, e o desenvolvedor poder utilizar outro meio de transporte além do HTTP para a transmissão dos dados.

Ela não é tão prática quanto a implementação anterior, onde uma classe proxy em AdvPL era gerada e compilada no repositório de objetos do ERP, porém ela foi construída com um núcleo mais robusto, e compatível com elementos não suportados pela classe proxy WSCLIENT. Então, este tópico vamos ver como usar esta classe para, por exemplo, consumir um Web Service publico na Internet.

Usando um Web Service na Internet

Vamos usar um serviço de conversão de moedas, disponível no endereço http://www.webservicex.net/CurrencyConvertor.asmx. Ao acessar esta página,
vemos que não se trata de um Web Site tradicional, mas uma página de publicação com detalhes do serviço. O provedor deste serviço utilizou o ASP .NET para fazê-lo. O que nos interessa para consumir o serviço é o WSDL, disponivel no link da página onde é mostrado em destaque “Service Description”. Clique neste link, e o WSDL será mostrado no seu Browser. Agora, pegue a URL mostrada no Browse ( http://www.webservicex.net/CurrencyConvertor.asmx?WSDL ) e copie para a área de transferência do Windows ( o famoso Control+C ).

Gerando a classe Client em AdvPL

Pelo método tradicional, usando o TDS, vamos gerar a classe client em AdvPL para consumir este serviço. Antes de mais nada, após abrir o TDS, entre na perspectiva de “Administrador TOTVS”, e na aba “Servidor”, configure ou selecione um servidor do TOTVS Application Server previamente configurado e conecte nele. Sem a conexão com um Application Server, a geração de código AdvPL para WebServices não funciona.

Utilizando o TDS 11.3, na perspectiva “Desenvolvedor Totvs”, localize a janela “Explorador de Projetos”, normalmente do lado esquerdo do vídeo, escolha ou crie uma pasta no projeto para acomodar o fonte gerado, e clicando com o botão direito sobre a pasta, escolha a opção Novo -> Outras, e na tela apresentada, escolha Advpl -> Novo fonte WSDL AdvPL.

Clique em “avançar”, e será mostrado uma tela perguntando os dados pertinentes do serviço. Na primeira informação (local), é mostrada a pasta do projeto onde o fonte será criado. Pode ser mantida a informação lá existente. Na segunda informação (nome do fonte), devemos informar o nome do fonte AdvPL que será criado com a classe client. No nosso exemplo, informe “ConvMoedas”, e no campo “url”, cole a URL do WSDL do serviço, anteriormente copiada para a área de transferência do Windows na etapa anteriormente descrita. Então, clique no botão “Concluir”.

Se não houver nenhum problema com a conexão com a Internet, o fonte “ConvMoedas.prw” deverá ser criado, e adicionado automaticamente ao Projeto aberto no TDS. PAra compilar o fonte, basta estar com o foco na janela do editor de código deste fonte, e pressionar as teclas Control+F9. Vamos ver o fonte gerado no meu ambiente de testes:

#INCLUDE "PROTHEUS.CH"
#INCLUDE "APWEBSRV.CH"
/* ===============================================================================
WSDL Location http://www.webservicex.net/CurrencyConvertor.asmx?WSDL
Gerado em 03/27/15 21:22:35
Observações Código-Fonte gerado por ADVPL WSDL Client 1.120703
 Alterações neste arquivo podem causar funcionamento incorreto
 e serão perdidas caso o código-fonte seja gerado novamente.
=============================================================================== */
User Function _HKRQIVL ; Return // "dummy" function - Internal Use
/* -------------------------------------------------------------------------------
WSDL Service WSCurrencyConvertor
------------------------------------------------------------------------------- */
WSCLIENT WSCurrencyConvertor
WSMETHOD NEW
 WSMETHOD INIT
 WSMETHOD RESET
 WSMETHOD CLONE
 WSMETHOD ConversionRate
WSDATA _URL AS String
 WSDATA _HEADOUT AS Array of String
 WSDATA _COOKIES AS Array of String
 WSDATA oWSFromCurrency AS CurrencyConvertor_Currency
 WSDATA oWSToCurrency AS CurrencyConvertor_Currency
 WSDATA nConversionRateResult AS double
ENDWSCLIENT
WSMETHOD NEW WSCLIENT WSCurrencyConvertor
::Init()
If !FindFunction("XMLCHILDEX")
 UserException("O Código-Fonte Client atual requer os executáveis do Protheus Build [7.00.131227A-20150220] ou superior. Atualize o Protheus ou gere o Código-Fonte novamente utilizando o Build atual.")
EndIf
If val(right(GetWSCVer(),8)) < 1.040504
 UserException("O Código-Fonte Client atual requer a versão de Lib para WebServices igual ou superior a ADVPL WSDL Client 1.040504. Atualize o repositório ou gere o Código-Fonte novamente utilizando o repositório atual.")
EndIf
Return Self
WSMETHOD INIT WSCLIENT WSCurrencyConvertor
 ::oWSFromCurrency := CurrencyConvertor_CURRENCY():New()
 ::oWSToCurrency := CurrencyConvertor_CURRENCY():New()
Return
WSMETHOD RESET WSCLIENT WSCurrencyConvertor
 ::oWSFromCurrency := NIL 
 ::oWSToCurrency := NIL 
 ::nConversionRateResult := NIL 
 ::Init()
Return
WSMETHOD CLONE WSCLIENT WSCurrencyConvertor
Local oClone := WSCurrencyConvertor():New()
 oClone:_URL := ::_URL 
 oClone:oWSFromCurrency := IIF(::oWSFromCurrency = NIL , NIL ,::oWSFromCurrency:Clone() )
 oClone:oWSToCurrency := IIF(::oWSToCurrency = NIL , NIL ,::oWSToCurrency:Clone() )
 oClone:nConversionRateResult := ::nConversionRateResult
Return oClone
// WSDL Method ConversionRate of Service WSCurrencyConvertor
WSMETHOD ConversionRate WSSEND oWSFromCurrency,oWSToCurrency WSRECEIVE nConversionRateResult WSCLIENT WSCurrencyConvertor
Local cSoap := "" , oXmlRet
BEGIN WSMETHOD
cSoap += ''
cSoap += WSSoapValue("FromCurrency", ::oWSFromCurrency, oWSFromCurrency , "Currency", .T. , .F., 0 , NIL, .F.) 
cSoap += WSSoapValue("ToCurrency", ::oWSToCurrency, oWSToCurrency , "Currency", .T. , .F., 0 , NIL, .F.) 
cSoap += ""
oXmlRet := SvcSoapCall( Self,cSoap,; 
 "http://www.webserviceX.NET/ConversionRate",; 
 "DOCUMENT","http://www.webserviceX.NET/",,,; 
 "http://www.webservicex.net/CurrencyConvertor.asmx")
::Init()
::nConversionRateResult := WSAdvValue( oXmlRet,"_CONVERSIONRATERESPONSE:_CONVERSIONRATERESULT:TEXT","double",NIL,NIL,NIL,NIL,NIL,NIL)
END WSMETHOD
oXmlRet := NIL
Return .T.
// WSDL Data Enumeration Currency
WSSTRUCT CurrencyConvertor_Currency
 WSDATA Value AS string
 WSDATA cValueType AS string
 WSDATA aValueList AS Array Of string
 WSMETHOD NEW
 WSMETHOD CLONE
 WSMETHOD SOAPSEND
 WSMETHOD SOAPRECV
ENDWSSTRUCT
WSMETHOD NEW WSCLIENT CurrencyConvertor_Currency
 ::Value := NIL
 ::cValueType := "string"
 ::aValueList := {}
 aadd(::aValueList , "AFA" )
 aadd(::aValueList , "ALL" )
 aadd(::aValueList , "DZD" )
 aadd(::aValueList , "ARS" )
 aadd(::aValueList , "AWG" )
 aadd(::aValueList , "AUD" )
 aadd(::aValueList , "BSD" )
 aadd(::aValueList , "BHD" )
 aadd(::aValueList , "BDT" )
 aadd(::aValueList , "BBD" )
 aadd(::aValueList , "BZD" )
 aadd(::aValueList , "BMD" )
 aadd(::aValueList , "BTN" )
 aadd(::aValueList , "BOB" )
 aadd(::aValueList , "BWP" )
 aadd(::aValueList , "BRL" )
 aadd(::aValueList , "GBP" )
 aadd(::aValueList , "BND" )
 aadd(::aValueList , "BIF" )
 aadd(::aValueList , "XOF" )
 aadd(::aValueList , "XAF" )
 aadd(::aValueList , "KHR" )
 aadd(::aValueList , "CAD" )
 aadd(::aValueList , "CVE" )
 aadd(::aValueList , "KYD" )
 aadd(::aValueList , "CLP" )
 aadd(::aValueList , "CNY" )
 aadd(::aValueList , "COP" )
 aadd(::aValueList , "KMF" )
 aadd(::aValueList , "CRC" )
 aadd(::aValueList , "HRK" )
 aadd(::aValueList , "CUP" )
 aadd(::aValueList , "CYP" )
 aadd(::aValueList , "CZK" )
 aadd(::aValueList , "DKK" )
 aadd(::aValueList , "DJF" )
 aadd(::aValueList , "DOP" )
 aadd(::aValueList , "XCD" )
 aadd(::aValueList , "EGP" )
 aadd(::aValueList , "SVC" )
 aadd(::aValueList , "EEK" )
 aadd(::aValueList , "ETB" )
 aadd(::aValueList , "EUR" )
 aadd(::aValueList , "FKP" )
 aadd(::aValueList , "GMD" )
 aadd(::aValueList , "GHC" )
 aadd(::aValueList , "GIP" )
 aadd(::aValueList , "XAU" )
 aadd(::aValueList , "GTQ" )
 aadd(::aValueList , "GNF" )
 aadd(::aValueList , "GYD" )
 aadd(::aValueList , "HTG" )
 aadd(::aValueList , "HNL" )
 aadd(::aValueList , "HKD" )
 aadd(::aValueList , "HUF" )
 aadd(::aValueList , "ISK" )
 aadd(::aValueList , "INR" )
 aadd(::aValueList , "IDR" )
 aadd(::aValueList , "IQD" )
 aadd(::aValueList , "ILS" )
 aadd(::aValueList , "JMD" )
 aadd(::aValueList , "JPY" )
 aadd(::aValueList , "JOD" )
 aadd(::aValueList , "KZT" )
 aadd(::aValueList , "KES" )
 aadd(::aValueList , "KRW" )
 aadd(::aValueList , "KWD" )
 aadd(::aValueList , "LAK" )
 aadd(::aValueList , "LVL" )
 aadd(::aValueList , "LBP" )
 aadd(::aValueList , "LSL" )
 aadd(::aValueList , "LRD" )
 aadd(::aValueList , "LYD" )
 aadd(::aValueList , "LTL" )
 aadd(::aValueList , "MOP" )
 aadd(::aValueList , "MKD" )
 aadd(::aValueList , "MGF" )
 aadd(::aValueList , "MWK" )
 aadd(::aValueList , "MYR" )
 aadd(::aValueList , "MVR" )
 aadd(::aValueList , "MTL" )
 aadd(::aValueList , "MRO" )
 aadd(::aValueList , "MUR" )
 aadd(::aValueList , "MXN" )
 aadd(::aValueList , "MDL" )
 aadd(::aValueList , "MNT" )
 aadd(::aValueList , "MAD" )
 aadd(::aValueList , "MZM" )
 aadd(::aValueList , "MMK" )
 aadd(::aValueList , "NAD" )
 aadd(::aValueList , "NPR" )
 aadd(::aValueList , "ANG" )
 aadd(::aValueList , "NZD" )
 aadd(::aValueList , "NIO" )
 aadd(::aValueList , "NGN" )
 aadd(::aValueList , "KPW" )
 aadd(::aValueList , "NOK" )
 aadd(::aValueList , "OMR" )
 aadd(::aValueList , "XPF" )
 aadd(::aValueList , "PKR" )
 aadd(::aValueList , "XPD" )
 aadd(::aValueList , "PAB" )
 aadd(::aValueList , "PGK" )
 aadd(::aValueList , "PYG" )
 aadd(::aValueList , "PEN" )
 aadd(::aValueList , "PHP" )
 aadd(::aValueList , "XPT" )
 aadd(::aValueList , "PLN" )
 aadd(::aValueList , "QAR" )
 aadd(::aValueList , "ROL" )
 aadd(::aValueList , "RUB" )
 aadd(::aValueList , "WST" )
 aadd(::aValueList , "STD" )
 aadd(::aValueList , "SAR" )
 aadd(::aValueList , "SCR" )
 aadd(::aValueList , "SLL" )
 aadd(::aValueList , "XAG" )
 aadd(::aValueList , "SGD" )
 aadd(::aValueList , "SKK" )
 aadd(::aValueList , "SIT" )
 aadd(::aValueList , "SBD" )
 aadd(::aValueList , "SOS" )
 aadd(::aValueList , "ZAR" )
 aadd(::aValueList , "LKR" )
 aadd(::aValueList , "SHP" )
 aadd(::aValueList , "SDD" )
 aadd(::aValueList , "SRG" )
 aadd(::aValueList , "SZL" )
 aadd(::aValueList , "SEK" )
 aadd(::aValueList , "CHF" )
 aadd(::aValueList , "SYP" )
 aadd(::aValueList , "TWD" )
 aadd(::aValueList , "TZS" )
 aadd(::aValueList , "THB" )
 aadd(::aValueList , "TOP" )
 aadd(::aValueList , "TTD" )
 aadd(::aValueList , "TND" )
 aadd(::aValueList , "TRL" )
 aadd(::aValueList , "USD" )
 aadd(::aValueList , "AED" )
 aadd(::aValueList , "UGX" )
 aadd(::aValueList , "UAH" )
 aadd(::aValueList , "UYU" )
 aadd(::aValueList , "VUV" )
 aadd(::aValueList , "VEB" )
 aadd(::aValueList , "VND" )
 aadd(::aValueList , "YER" )
 aadd(::aValueList , "YUM" )
 aadd(::aValueList , "ZMK" )
 aadd(::aValueList , "ZWD" )
 aadd(::aValueList , "TRY" )
Return Self
WSMETHOD SOAPSEND WSCLIENT CurrencyConvertor_Currency
 Local cSoap := "" 
 cSoap += WSSoapValue("Value", ::Value, NIL , "string", .F. , .F., 3 , NIL, .F.) 
Return cSoap
WSMETHOD SOAPRECV WSSEND oResponse WSCLIENT CurrencyConvertor_Currency
 ::Value := NIL
 If oResponse = NIL ; Return ; Endif 
 ::Value := oResponse:TEXT
Return
WSMETHOD CLONE WSCLIENT CurrencyConvertor_Currency
Local oClone := CurrencyConvertor_Currency():New()
 oClone:Value := ::Value
Return oClone

Agora, para consumir este serviço, precisamos dar uma olhada com calma na classe proxy gerada. Primeiro, vejamos os métodos disponíveis:

WSMETHOD NEW
 WSMETHOD INIT
 WSMETHOD RESET
 WSMETHOD CLONE
 WSMETHOD ConversionRate

Os quatro primeiros métodos fazem parte da manutenção da instância da classe client. Por hora o que nos interessa é o construtor (NEW), e o método ConversionRate, que é o único método disponibilizado por este serviço. Vamos procurar pela declaração deste método.

WSMETHOD ConversionRate WSSEND oWSFromCurrency,oWSToCurrency WSRECEIVE nConversionRateResult WSCLIENT WSCurrencyConvertor

Ao avaliarmos a implementação do método, vemos que ele têm dois parâmetros, do tipo Objeto, e um resultado numérico. Vamos procurar no fonte pela definição de cada um destes parâmetros (oWSFromCurrency e oWSToCurrency).

WSDATA oWSFromCurrency AS CurrencyConvertor_Currency
WSDATA oWSToCurrency AS CurrencyConvertor_Currency

Cada um dos parâmetros do WebService é declarado como uma propriedade da classe Proxy. Neste caso, ambos são objetos do mesmo tipo ( CurrencyConvertor_Currency ). Vamos ver definição deste objeto:

// WSDL Data Enumeration Currency
WSSTRUCT CurrencyConvertor_Currency
 WSDATA Value AS string
 WSDATA cValueType AS string
 WSDATA aValueList AS Array Of string
 WSMETHOD NEW
 WSMETHOD CLONE
 WSMETHOD SOAPSEND
 WSMETHOD SOAPRECV
ENDWSSTRUCT

Então, este objeto é um “Enumeration”, com base em uma String. Isto permite o código Client do Web Services verificar se o conteúdo informado é válido antes mesmo da requisição ser realizada.

Com estas informações, vamos montar o fonte Client em AdvPL que vai consumir esta classe.

#include "protheus.ch"
/* -------------------------------------------------------------------
Função U_MOEDAS
Autor Júlio Wittwer
Data 28/03/2015
Descrição Fonte de exemplo consumingo um Web Service publico
 de fator de conversão de moedas, utilizando a 
 geração de classe Client de Web Services do AdvPL
Url http://www.webservicex.net/CurrencyConvertor.asmx?WSDL
------------------------------------------------------------------- */
User Function Moedas()
Local oWS
// Cria a instância da classe client
oWs := WSCurrencyConvertor():New()
// Alimenta as propriedades de envio 
oWS:oWSFromCurrency:Value := 'BRL' // Real ( Brasil )
oWS:oWSToCurrency:Value := 'USD' // United States Dollar
// Habilita informações de debug no log de console
WSDLDbgLevel(3)
// Chama o método do Web Service
If oWs:ConversionRate()
 // Retorno .T. , solicitação enviada e recebida com sucesso
 MsgStop("Fator de conversão: "+cValToChar(oWS:nConversionRateResult),"Requisição Ok")
 MsgStop("Por exemplo, 100 reais compram "+cValToChar(100 * oWS:nConversionRateResult )+" Dólares Americanos.")
Else
 // Retorno .F., recupera e mostra string com detalhes do erro 
 MsgStop(GetWSCError(),"Erro de Processamento")
Endif
Return
Ao executar este fonte, o retorno esperado é uma sequência de duas janelas de informações, contendo o fator de conversão, e um exemplo de uso deste fator convertendo 100 reais para dólares americanos.
Agora, vamos ver como este exemplo seria escrito usando a classe tWSDLManager(), da forma mais minimalista possível.
#include "protheus.ch"
/* -------------------------------------------------------------------
Função U_MOEDAS2
Autor Júlio Wittwer
Data 28/03/2015
Descrição Fonte de exemplo consumingo um Web Service publico
 de fator de conversão de moedas, utilizando a 
 classe tWSDLManager()
Url http://www.webservicex.net/CurrencyConvertor.asmx?WSDL
------------------------------------------------------------------- */
User Function Moedas2()
Local oWSDL
Local lOk, cResp, aElem, nPos
oWSDL := tWSDLManager():New()
// Seta o modo de trabalho da classe para "verbose"
oWSDL:lVerbose := .T.
// Primeiro faz o parser do WSDL a partir da URL
lOk := oWsdl:ParseURL( "http://www.webservicex.net/CurrencyConvertor.asmx?WSDL" )
if !lOk 
 MsgStop( oWsdl:cError , "ParseURL() ERROR")
 Return
endif
// Seta a operação a ser utilizada
lOk := oWsdl:SetOperation( "ConversionRate" )
if !lOk
 MsgStop( oWsdl:cError , "SetOperation(ConversionRate) ERROR")
 Return
endif
// Setar um valor para conversão
lOk := oWsdl:SetFirst('FromCurrency','BRL')
if !lOk
 MsgStop( oWsdl:cError , "SetFirst(FromCurrency) ERROR")
 Return
endif
lOk := oWsdl:SetFirst('ToCurrency','USD')
if !lOk
 MsgStop( oWsdl:cError , "SetFirst (ToCurrency) ERROR")
 Return
endif/
// Faz a requisição ao WebService 
lOk := oWsdl:SendSoapMsg()
if !lOk
 MsgStop( oWsdl:cError , "SendSoapMsg() ERROR")
 Return
endif
// Recupera os elementos de retorno, já parseados
cResp := oWsdl:GetParsedResponse()
// Monta um array com a resposta parseada, considerando
// as quebras de linha ( LF == Chr(10) ) 
aElem := StrTokArr(cResp,chr(10))
nPos := ascan(aElem,{|x| left(x,21) == 'ConversionRateResult:'}) 
If nPos > 0 
 nFator := val( substr(aElem[nPos],22) )
 MsgStop("Fator de conversão: "+cValToChar(nFator),"Requisição Ok")
 MsgStop("Por exemplo, 100 reais compram "+cValToChar(100 * nFator )+" Dólares Americanos.")
Else
 MsgStop("Resposta não encontrada ou inválida.")
Endif
Return

Para utilizar este exemplo, é necessário criar um arquivo para conter o Fonte Client da classe AdvPL gerada, e outro para compilar o fonte que consome esta classe client, e para executar, basta chamar os fontes U_Moedas e U_Moedas2 a partir do SmartClient.

A classe tWSDLManager, embora seja superior em relação ao SOAP, ainda precisa de algumas informações adicionais para se tornar mais prática para uso. Para montar o exemplo acima, foi necessário codificar um fonte um pouco maior, chamando os métodos adicionais da classe para obter os nomes dos serviços publicados, os nomes dos elementos de parâmetro e retorno do serviço desejado, e verificar o formato de retorno parseado para extrair o valor retornado pelo Web Service.

Nos próximos tópicos sobre Web Services, vamos abordar entre outras coisas a utilização de serviços que requerem autenticação e/ou conexão segura (SSL) utilizando chaves criptográficas, e como tratar de forma adequada as falhas que podem ocorrer no lado de uma aplicação client de Web Services.

Conclusão

Este post foi só pra abrir o apetite, têm muito mais a ser explorado neste universo. Mais uma vez, agradeço a todos pela audiência do Blog, e espero vê-los por aqui mais vezes. Até o próximo post, pessoal 😉

Anúncios

Tetris Orientado a Objetos em AdvPL

Introdução

Nada mais providencial do que ter em mãos um fonte relativamente complexo, escrito utilizando funções e variáveis estáticas e construído totalmente amarrado à camada de interface, para usar de exemplo para aplicar a orientação a objetos.

Tetris em AdvPL

No post sobre o clone do jogo Tetris escrito em AdvPL, ao analisarmos o código-fonte, percebemos que ele se encaixa perfeitamente na introdução deste tópico.

Embora o núcleo do jogo trabalhe com um array de strings contento a representação da tela do jogo, onde cada caractere dentro do array representa um espaço em branco ou um espaço ocupado pela parte de uma peça de uma determinada cor, as funções do jogo que lidam com os eventos de atualização de interface estão amarrados às características e objetos de interface, tanto os resources para a pintura da tela, quando o objeto tTimer, usado para movimentar a peça em jogo uma linha para baixo em intervalos de um segundo.

Utilizando a orientação a objetos, e segmentando um pouco o código, é possível separar boa parte das variáveis e funçoes estáticas em propriedades e métodos de uma classe ApTetris, que será responsável pelo processamento do “core” (ou núcleo) do jogo. E, indo um pouco mais além, podemos desamarrar a interface do jogo, fornecendo algumas propriedades para a classe, para esta ser capaz de chamar as funções apropriadas para compor a interface do jogo quando e como necessário.

Segmentação e refatoração

A primeira parte da refatoração do código foi criar a classe APTetris, transformando todas as variáveis STATIC em propriedades da classe, e praticamente todas as funções STATIC em métodos. Neste primeiro momento, em 10 minutos o jogo já estava operacional novamente, porém as propriedades da classe armazenavam e lidavam diretamente com a pintura da interface.

Num segundo momento, este um pouco mais demorado, os métodos que lidavam estritamente com as tarefas de pintar o grid, score, timer e mensagens do jogo, bem como as mudanças de estado (running, pause, game over), passaram a chamar CodeBlocks para estas tarefas. Cada code-block é chamado em um momento distinto, para atender a um tipo de evento disparado pelo Core do Jogo. Todos os CodeBlocks foram implementados como propriedades da classe principal, e devem ser alimentados após a construção da instância. E, os métodos ligados diretamente a interface voltaram a ser STATIC FUNCTIONS do código, que recebem como parâmetro informações do core do jogo e da interface em uso, para interagir com ela.

Vamos ao código

Após estas duas etapas completas com sucesso, algumas correções na lógica do jogo inicial foram realizadas, commo por exemplo a funçao de “Pause” agora apaga a tela do jogo, para o jogador não se aproveitar da pausa para ficar estudando onde melhor encaixar a peça, entre outros ajustes menores. A última etapa foi isolar as constantes usadas para alguns elementos de arrays e status do core do jogo para um arquivo de #include separado, e a classe do jogo, totalmente desamarrada de interface ser isolada em um código-fonte separado.

O projeto final está no GitHub https://github.com/siga0984/Tetris-OO, que contém os resources (imagens) das pedras, e os fontes “Tetris-OO.PRW” (fonte da interface do jogo para SmartClient), e o fonte “Tetris-Core.prw”, que agora contém apenas o núcleo do jogo, sem a interface. Da mesma forma que o jogo anterior, basta criar um projeto AdvPL no IDE ou TDS, acrescentar os fontes e imagens, compilar e executar. a função U_TetrisOO diretamente a partir do SmartClient.

Segue abaixo o fonte client, responsável pela interface e utilização da classe ApTetris.

#include 'protheus.ch'
#include 'tetris-core.ch'
/* ========================================================
Função U_TETRISOO
Autor Júlio Wittwer
Data 21/03/2015
Versão 1.150321
Descriçao Réplica do jogo Tetris, feito em AdvPL
Remake reescrito a partir do Tetris.PRW, utiliando Orientação a Objetos
Para jogar, utilize as letras :
A ou J = Move esquerda
D ou L = Move Direita
S ou K = Para baixo
W ou I = Rotaciona sentido horario
Barra de Espaço = Dropa a peça
======================================================== */
 
// =======================================================
USER Function TetrisOO()
Local oDlg, oBGGame , oBGNext
Local oFont , oLabel 
Local oScore , oTimer
Local nC , nL
Local oTetris 
Local aBMPGrid 
Local aBMPNext 
Local aResources
// Arrays de componentes e recursos de Interface
aBMPGrid := array(20,10) // Array de bitmaps de interface do jogo 
aBMPNext := array(4,5) // Array de bitmaps da proxima peça
aResources := { "BLACK","YELOW2","LIGHTBLUE2","ORANGE2","RED2","GREEN2","BLUE2","PURPLE2" }
// Fonte default usada na caixa de diálogo 
// e respectivos componentes filhos
oFont := TFont():New('Courier new',,-16,.T.,.T.)
// Interface principal do jogo
DEFINE DIALOG oDlg TITLE "Object Oriented Tetris AdvPL" FROM 10,10 TO 450,365 ;
 FONT oFont COLOR CLR_WHITE,CLR_BLACK PIXEL
// Cria um fundo cinza, "esticando" um bitmap
@ 8, 8 BITMAP oBGGame RESOURCE "GRAY" ;
 SIZE 104,204 Of oDlg ADJUST NOBORDER PIXEL
// Desenha na tela um grid de 20x10 com Bitmaps
// para desenhar o Game
For nL := 1 to 20
 For nC := 1 to 10
 
 @ nL*10, nC*10 BITMAP oBmp RESOURCE "BLACK" ;
 SIZE 10,10 Of oDlg ADJUST NOBORDER PIXEL
 
 aBMPGrid[nL][nC] := oBmp
 
 Next
Next
 
// Monta um Grid 4x4 para mostrar a proxima peça
// ( Grid deslocado 110 pixels para a direita )
@ 8, 118 BITMAP oBGNext RESOURCE "GRAY" ;
 SIZE 54,44 Of oDlg ADJUST NOBORDER PIXEL
For nL := 1 to 4
 For nC := 1 to 5
 
 @ nL*10, (nC*10)+110 BITMAP oBmp RESOURCE "BLACK" ;
 SIZE 10,10 Of oDlg ADJUST NOBORDER PIXEL
 
 aBMPNext[nL][nC] := oBmp
 
 Next
Next
// Label fixo, Pontuação do Jogo 
@ 80,120 SAY oLabel1 PROMPT "[Score]" SIZE 60,20 OF oDlg PIXEL
 
// Label para Mostrar score
@ 90,120 SAY oScore PROMPT " " SIZE 60,120 OF oDlg PIXEL
// Label fixo, Tempo de Jogo
@ 110,120 SAY oLabel2 PROMPT "[Time]" SIZE 60,20 OF oDlg PIXEL
 
// Label para Mostrar Tempo de Jogo
@ 120,120 SAY oElapTime PROMPT " " SIZE 60,120 OF oDlg PIXEL
// Label para Mostrar Status do Jogo 
@ 140,120 SAY oGameMsg PROMPT " " SIZE 60,120 OF oDlg PIXEL
// Botões com atalho de teclado
// para as teclas usadas no jogo
// colocados fora da area visivel da caixa de dialogo
@ 480,10 BUTTON oDummyB0 PROMPT '&A' ACTION ( oTetris:DoAction('A') ) SIZE 1, 1 OF oDlg PIXEL
@ 480,20 BUTTON oDummyB1 PROMPT '&S' ACTION ( oTetris:DoAction('S') ) SIZE 1, 1 OF oDlg PIXEL
@ 480,20 BUTTON oDummyB2 PROMPT '&D' ACTION ( oTetris:DoAction('D') ) SIZE 1, 1 OF oDlg PIXEL
@ 480,20 BUTTON oDummyB3 PROMPT '&W' ACTION ( oTetris:DoAction('W') ) SIZE 1, 1 OF oDlg PIXEL
@ 480,20 BUTTON oDummyB4 PROMPT '&J' ACTION ( oTetris:DoAction('J') ) SIZE 1, 1 OF oDlg PIXEL
@ 480,20 BUTTON oDummyB5 PROMPT '&K' ACTION ( oTetris:DoAction('K') ) SIZE 1, 1 OF oDlg PIXEL
@ 480,20 BUTTON oDummyB6 PROMPT '&L' ACTION ( oTetris:DoAction('L') ) SIZE 1, 1 OF oDlg PIXEL
@ 480,20 BUTTON oDummyB7 PROMPT '&I' ACTION ( oTetris:DoAction('I') ) SIZE 1, 1 OF oDlg PIXEL
@ 480,20 BUTTON oDummyB8 PROMPT '& ' ACTION ( oTetris:DoAction(' ') ) SIZE 1, 1 OF oDlg PIXEL
@ 480,20 BUTTON oDummyB9 PROMPT '&P' ACTION ( oTetris:DoPause() ) SIZE 1, 1 OF oDlg PIXEL
// Inicializa o objeto do core do jogo 
oTetris := APTetris():New()
// Define um timer, para fazer a peça em jogo
// descer uma posição a cada um segundo
// ( Nao pode ser menor, o menor tempo é 1 segundo )
// A ação '#' é diferente de "S" ou "K", pois nao atualiza 
// o score quando a peça está descento "sozinha" por tempo 
oTimer := TTimer():New(1000, {|| oTetris:DoAction('#') }, oDlg )
// Registra evento para atualização de score
// Apos uma ação ser processada pelo objeto Tetris, caso o score 
// tenha mudado, este codeclobk será disparado com o novo score 
oTetris:bShowScore := {|cMsg| oScore:SetText(cMsg) }
// Registra evento para atualização do tempo decorrido de jogo 
// Apos uma ação ser processada pelo objeto Tetris, caso o tempo 
// de jogo tenha mudado, este codeclobk será disparado com o tempo 
// decorrido de jogo atualizado. 
oTetris:bShowElap := {|cMsg| oElapTime:SetText(cMsg) }
// Registra evento de mudança de estado do jogo 
// Running , Pause, Game Over. Caso seja disparado um
// pause ou continue, ou mesmo a última peça nao caber 
// na TEla ( Game Over ), este bloco é disparado, informando o novo 
// estado de jogo 
oTetris:bChangeState := {|nStat| GameState( nStat , oTimer , oGameMsg ) }
// Registra evento de pintura do grid 
// Apos processamento de ação, caso o grid precise ser repintado, 
// este bloco de código será disparado
oTetris:bPaintGrid := {|aGameGrid| PaintGame( aGameGrid, aBmpGrid , aResources ) }
// Registra evento de pintura da proxima peça 
// Apos processamento de ação, caso seja sorteada uma nova próxima peça, 
// este bloco de código será disparado para pintar a proxima peça na interface
oTetris:bPaintNext := {|aNextPiece| PaintNext(aNextPiece, aBMPNext, aResources) }
// Na inicialização do Dialogo, começa o jogo 
oDlg:bInit := {|| oTetris:Start() }
ACTIVATE DIALOG oDlg CENTER
Return
/* -------------------------------------------------------
Notificação de mudança de estado de jogo
GAME_RUNNING, GAME_PAUSED ou GAME_OVER
------------------------------------------------------- */
STATIC Function GameState( nStat , oTimer , oGameMsg ) 
Local cMsg
If nStat == GAME_RUNNING
// Jogo em execuçao, ativa timer de interface
 oTimer:Activate()
cMsg := "*********"+CRLF+;
 "* PLAY *"+CRLF+;
 "*********"
ElseIf nStat == GAME_PAUSED
// Jogo em pausa
 // desativa timer de interface 
 oTimer:DeActivate()
 
 // e acrescenta mensagem de pausa
 cMsg := "*********"+CRLF+;
 "* PAUSE *"+CRLF+;
 "*********"
ElseIf nStat == GAME_OVER
// Game Over
 // desativa timer de interface 
 oTimer:DeActivate()
// e acresenta a mensagem de "GAME OVER"
 cMsg := "********"+CRLF+;
 "* GAME *"+CRLF+; 
 "********"+CRLF+;
 "* OVER *"+CRLF+;
 "********"
Endif
// Atualiza a mensagem na interface
oGameMsg:SetText(cMsg)
Return
/* ----------------------------------------------------------
Função PaintGame()
Pinta o Grid do jogo da memória para a Interface
Chamada pelo objeto Tetris via code-block
Optimizada para apenas trocar os resources diferentes
---------------------------------------------------------- */
STATIC Function PaintGame( aGameGrid, aBmpGrid , aResources ) 
Local nL, nc , cLine, nPeca
For nL := 1 to 20
 cLine := aGameGrid[nL+1]
 For nC := 1 to 10
 nPeca := val(substr(cLine,nC+2,1))
 If aBmpGrid[nL][nC]:cResName != aResources[nPeca+1]
 // Somente manda atualizar o bitmap se houve
 // mudança na cor / resource desta posição
 aBmpGrid[nL][nC]:SetBmp(aResources[nPeca+1])
 endif
 Next
Next
Return
/* -----------------------------------------------------------------
Pinta na interface a próxima peça a ser usada no jogo 
Chamada pelo objeto Tetris via code-block
Optimizada para apenas trocar os resources diferentes
----------------------------------------------------------------- */
STATIC Function PaintNext(aNext,aBMPNext,aResources) 
Local nL, nC, cLine , nPeca
For nL := 1 to 4
 cLine := aNext[nL]
 For nC := 1 to 5
 nPeca := val(substr(cLine,nC,1))
 If aBMPNext[nL][nC]:cResName != aResources[nPeca+1]
 aBMPNext[nL][nC]:SetBmp(aResources[nPeca+1])
 endif
 Next
Next

Return

E, agora segue abaixo o fonte Tetris-Core.PRW, que contém a classe core do clone do Tetris.

#include 'protheus.ch' 
#include 'tetris-core.ch'
// ============================================================================
// Classe "CORE" do Jogo Tetris
// ============================================================================
CLASS APTETRIS
 
 // Propriedades publicas
 
 DATA aGamePieces // Peças que compoe o jogo 
 DATA nGameStart // Momento de inicio de jogo 
 DATA nGameTimer // Tempo de jogo em segundos
 DATA nGamePause // Controle de tempo de pausa
 DATA nNextPiece // Proxima peça a ser usada
 DATA nGameStatus // 0 = Running 1 = PAuse 2 == Game Over
 DATA aNextPiece // Array com a definição e posição da proxima peça
 DATA aGameCurr // Array com a definição e posição da peça em jogo
 DATA nGameScore // pontuação da partida
 DATA aGameGrid // Array de strings com os blocos da interface representados em memoria
// Eventos disparados pelo core do Jogo 
 
 DATA bShowScore // CodeBlock para interface de score 
 DATA bShowElap // CodeBlock para interface de tempo de jogo 
 DATA bChangeState // CodeBlock para indicar mudança de estado ( pausa / continua /game over )
 DATA bPaintGrid // CodeBlock para evento de pintura do Grid do Jogo
 DATA bPaintNext // CodeBlock para evento de pintura da Proxima peça em jogo
 
 // Metodos Publicos
 
 METHOD New() // Construtor
 METHOD Start() // Inicio de Jogo
 METHOD DoAction(cAct) // Disparo de ações da Interface
 METHOD DoPause() // Dispara Pause On/Off
// Metodos privados ( por convenção, prefixados com "_" )
METHOD _LoadPieces() // Carga do array de peças do Jogo 
 METHOD _MoveDown() // Movimenta a peça corrente uma posição para baixo
 METHOD _DropDown() // Movimenta a peça corrente direto até onde for possível
 METHOD _SetPiece(aPiece,aGrid) // Seta uma peça no Grid em memoria do jogo 
 METHOD _DelPiece(aPiece,aGrid) // Remove uma peça no Grid em memoria do jogo 
 METHOD _FreeLines() // Verifica e eliminha linhas totalmente preenchidas 
 METHOD _GetEmptyGrid() // Retorna um Grid em memoria inicializado vazio
ENDCLASS
/* ----------------------------------------------------------
Construtor da classe
---------------------------------------------------------- */
METHOD NEW() CLASS APTETRIS
::aGamePieces := ::_LoadPieces()
::nGameTimer := 0
::nGameStart := 0
::aNextPiece := {}
::aGameCurr := {}
::nGameScore := 0
::aGameGrid := {}
::nGameStatus := GAME_RUNNING
Return self
/* ----------------------------------------------------------
Inicializa o Grid na memoria
Em memoria, o Grid possui 14 colunas e 22 linhas
Na tela, são mostradas apenas 20 linhas e 10 colunas
As 2 colunas da esquerda e direita, e as duas linhas a mais
sao usadas apenas na memoria, para auxiliar no processo
de validação de movimentação das peças.
---------------------------------------------------------- */
METHOD Start() CLASS APTETRIS
Local aDraw, nPiece, cScore
// Inicializa o grid de imagens do jogo na memória
// Sorteia a peça em jogo
// Define a peça em queda e a sua posição inicial
// [ Peca, rotacao, linha, coluna ]
// e Desenha a peça em jogo no Grid
// e Atualiza a interface com o Grid
// Inicializa o grid do jogo "vazio"
::aGameGrid := aClone(::_GetEmptyGrid())
// Sorteia peça em queda do inicio do jogo
nPiece := randomize(1,len(::aGamePieces)+1)
// E coloca ela no topo da tela
::aGameCurr := {nPiece,1,1,6}
::_SetPiece(::aGameCurr,::aGameGrid)
// Dispara a pintura do Grid do Jogo
Eval( ::bPaintGrid , ::aGameGrid)
// Sorteia a proxima peça e desenha
// ela no grid reservado para ela
::aNextPiece := array(4,"00000")
::nNextPiece := randomize(1,len(::aGamePieces)+1)
aDraw := {::nNextPiece,1,1,1}
::_SetPiece(aDraw,::aNextPiece)
// Dispara a pintura da próxima peça
Eval( ::bPaintNext , ::aNextPiece )
// Marca timer do inicio de jogo
::nGameStart := seconds()
// Chama o codeblock de mudança de estado - Jogo em execução
Eval(::bChangeState , ::nGameStatus )
// E chama a pintura do score inicial 
cScore := str(::nGameScore,7)
Eval( ::bShowScore , cScore )
Return
/* ----------------------------------------------------------
Recebe uma ação de movimento de peça, e realiza o movimento
da peça corrente caso exista espaço para tal.
---------------------------------------------------------- */
METHOD DoAction(cAct) CLASS APTETRIS
Local aOldPiece
Local cScore, cElapTime 
Local cOldScore, cOldElapTime
If ::nGameStatus != GAME_RUNNING
 // Jogo não está rodando, nao aceita ação nenhuma
 Return .F. 
Endif
// Pega pontuação e tempo decorridos agora 
cOldScore := str(::nGameScore,7)
cOldElapTime := STOHMS(::nGameTimer)
// Clona a peça em queda
aOldPiece := aClone(::aGameCurr)
if cAct $ 'AJ'
 
 // Movimento para a Esquerda (uma coluna a menos)
 // Remove a peça do grid
 ::_DelPiece(::aGameCurr,::aGameGrid)
 ::aGameCurr[PIECE_COL]--
 If !::_SetPiece(::aGameCurr,::aGameGrid)
 // Se nao foi feliz, pinta a peça de volta
 ::aGameCurr := aClone(aOldPiece)
 ::_SetPiece(::aGameCurr,::aGameGrid)
 Endif
 
Elseif cAct $ 'DL'
 
 // Movimento para a Direita ( uma coluna a mais )
 // Remove a peça do grid
 ::_DelPiece(::aGameCurr,::aGameGrid)
 ::aGameCurr[PIECE_COL]++
 If !::_SetPiece(::aGameCurr,::aGameGrid)
 // Se nao foi feliz, pinta a peça de volta
 ::aGameCurr := aClone(aOldPiece)
 ::_SetPiece(::aGameCurr,::aGameGrid)
 Endif
 
Elseif cAct $ 'WI'
 
 // Movimento para cima ( Rotaciona sentido horario )
 
 // Remove a peça do Grid
 ::_DelPiece(::aGameCurr,::aGameGrid)
 
 // Rotaciona a peça 
 ::aGameCurr[PIECE_ROTATION]--
 If ::aGameCurr[PIECE_ROTATION] < 1
 ::aGameCurr[PIECE_ROTATION] := len(::aGamePieces[::aGameCurr[PIECE_NUMBER]])-1
 Endif
 
 If !::_SetPiece(::aGameCurr,::aGameGrid)
 // Se nao consegue colocar a peça no Grid
 // Nao é possivel rotacionar. Pinta a peça de volta
 ::aGameCurr := aClone(aOldPiece)
 ::_SetPiece(::aGameCurr,::aGameGrid)
 Endif
 
ElseIF cAct $ 'SK#'
 
 // Desce a peça para baixo uma linha intencionalmente
 ::_MoveDown()
 
 If cAct $ 'SK'
 // se o movimento foi intencional, ganha + 1 ponto
 ::nGameScore++
 Endif
 
ElseIF cAct == ' '
 
 // Dropa a peça - empurra para baixo até a última linha
 // antes de bater a peça no fundo do Grid. Isto vai permitir
 // movimentos laterais e roração, caso exista espaço
If !::_DropDown()
 // Se nao tiver espaço para o DropDown, faz apenas o MoveDown 
 // e "assenta" a peça corrente
 ::_MoveDown()
 Endif
 
Else
UserException("APTETRIS:DOACTION() ERROR: Unknow Action ["+cAct+"]")
 
Endif
// Dispara a repintura do Grid
Eval( ::bPaintGrid , ::aGameGrid)
// Calcula tempo decorrido
::nGameTimer := seconds() - ::nGameStart
 
If ::nGameTimer < 0
 // Ficou negativo, passou da meia noite
 ::nGameTimer += 86400
Endif
// Pega Score atualizado e novo tempo decorrido
cScore := str(::nGameScore,7)
cElapTime := STOHMS(::nGameTimer)
If ( cOldScore <> cScore ) 
 // Dispara o codeblock que atualiza o score
 Eval( ::bShowScore , cScore )
Endif
If ( cOldElapTime <> cElapTime ) 
 // Dispara atualizaçao de tempo decorrido
 Eval( ::bShowElap , cElapTime )
Endif
Return .T.
/* ----------------------------------------------------------
Coloca e retira o jog em pausa
Este metodo foi criado isolado, pois é o unico 
que poderia ser chamado dentro de uma pausa
---------------------------------------------------------- */
METHOD DoPause() CLASS APTETRIS
Local lChanged := .F.
Local nPaused
Local cElapTime 
Local cOldElapTime
cOldElapTime := STOHMS(::nGameTimer)
If ::nGameStatus == GAME_RUNNING
 // Jogo em execução = Pausa : Desativa o timer
 lChanged := .T.
 ::nGameStatus := GAME_PAUSED
 ::nGamePause := seconds()
ElseIf ::nGameStatus == GAME_PAUSED
 // Jogo em pausa = Sai da pausa : Ativa o timer
 lChanged := .T.
 ::nGameStatus := GAME_RUNNING
 // Calcula quanto tempo o jogo ficou em pausa
 // e acrescenta esse tempo do start do jogo
 nPaused := seconds()-::nGamePause
 If nPaused < 0
 nPaused += 86400
 Endif
 ::nGameStart += nPaused
Endif
If lChanged
 
 // Chama o codeblock de mudança de estado - Entrou ou saiu de pausa
 Eval(::bChangeState , ::nGameStatus )
 
 If ::nGameStatus == GAME_PAUSED
 // Em pausa, Dispara a pintura do Grid do Jogo vazio
 Eval( ::bPaintGrid , ::_GetEmptyGrid() )
 Else
 // Game voltou da pausa, pinta novamente o Grid
 Eval( ::bPaintGrid , ::aGameGrid)
 Endif
 
 // Calcula tempo de jogo sempre ao entrar ou sair de pausa
 ::nGameTimer := seconds() - ::nGameStart
 
 If ::nGameTimer < 0
 // Ficou negativo, passou da meia noite
 ::nGameTimer += 86400
 Endif
// Pega novo tempo decorrido
 cElapTime := STOHMS(::nGameTimer)
If ( cOldElapTime <> cElapTime ) 
 // Dispara atualizaçao de tempo decorrido
 Eval( ::bShowElap , cElapTime )
 Endif
Endif
Return
/* ----------------------------------------------------------
Metodo SetGridPiece
Aplica a peça informada no array do Grid.
Retorna .T. se foi possivel aplicar a peça na posicao atual
Caso a peça não possa ser aplicada devido a haver
sobreposição, a função retorna .F. e o grid não é atualizado
Serve tanto para o Grid do Jogo quando para o Grid da próxima peça
---------------------------------------------------------- */
METHOD _SetPiece(aPiece,aGrid) CLASS APTETRIS
Local nPiece := aPiece[PIECE_NUMBER] // Numero da peça
Local nRotate := aPiece[PIECE_ROTATION] // Rotação
Local nRow := aPiece[PIECE_ROW] // Linha no Grid
Local nCol := aPiece[PIECE_COL] // Coluna no Grid
Local nL , nC
Local aTecos := {}
Local cTecoGrid, cPeca , cPieceId
conout("_SetPiece on COL "+cValToChar(nCol))
cPieceId := str(nPiece,1)
For nL := nRow to nRow+3
 cPeca := ::aGamePieces[nPiece][1+nRotate][nL-nRow+1]
 If nL > len(aGrid) 
 // Se o grid acabou, verifica se o teco 
 // da peça tinha alguma coisa a ser ligada
 // Se tinha, nao cabe, se não tinha, beleza
 If '1' $ cPeca 
 Return .F.
 Else
 EXIT
 Endif
 Endif
 cTecoGrid := substr(aGrid[nL],nCol,4)
 For nC := 1 to 4
 If Substr(cPeca,nC,1) == '1'
 If SubStr(cTecoGrid,nC,1) != '0'
 // Vai haver sobreposição,
 // a peça nao cabe ...
 Return .F.
 Endif
 cTecoGrid := Stuff(cTecoGrid,nC,1,cPieceId)
 Endif
 Next
 // Array temporario com a peça já colocada
 aadd(aTecos,cTecoGrid)
Next
// Aplica o array temporario no array do grid
For nL := nRow to nRow+len(aTecos)-1
 aGrid[nL] := stuff(aGrid[nL],nCol,4,aTecos[nL-nRow+1])
Next
// A peça "coube", retorna .T.
Return .T.
/* -----------------------------------------------------------------
Carga do array de peças do jogo
Array multi-dimensional, contendo para cada
linha a string que identifica a peça, e um ou mais
arrays de 4 strings, onde cada 4 elementos
representam uma matriz binaria de caracteres 4x4
para desenhar cada peça
Exemplo - Peça "O"
aLPieces[1][1] C "O"
aLPieces[1][2][1] "0000"
aLPieces[1][2][2] "0110"
aLPieces[1][2][3] "0110"
aLPieces[1][2][4] "0000"
----------------------------------------------------------------- */
METHOD _LoadPieces() CLASS APTETRIS
Local aLPieces := {}
// Peça "O" , uma posição
aadd(aLPieces,{'O', { '0000','0110','0110','0000'}})
// Peça "I" , em pé e deitada
aadd(aLPieces,{'I', { '0000','1111','0000','0000'},;
 { '0010','0010','0010','0010'}})
// Peça "S", em pé e deitada
aadd(aLPieces,{'S', { '0000','0011','0110','0000'},;
 { '0010','0011','0001','0000'}})
// Peça "Z", em pé e deitada
aadd(aLPieces,{'Z', { '0000','0110','0011','0000'},;
 { '0001','0011','0010','0000'}})
// Peça "L" , nas 4 posições possiveis
aadd(aLPieces,{'L', { '0000','0111','0100','0000'},;
 { '0010','0010','0011','0000'},;
 { '0001','0111','0000','0000'},;
 { '0110','0010','0010','0000'}})
// Peça "J" , nas 4 posições possiveis
aadd(aLPieces,{'J', { '0000','0111','0001','0000'},;
 { '0011','0010','0010','0000'},;
 { '0100','0111','0000','0000'},;
 { '0010','0010','0110','0000'}})
// Peça "T" , nas 4 posições possiveis
aadd(aLPieces,{'T', { '0000','0111','0010','0000'},;
 { '0010','0011','0010','0000'},;
 { '0010','0111','0000','0000'},;
 { '0010','0110','0010','0000'}})
Return aLPieces
/* ----------------------------------------------------------
Função _MoveDown()
Movimenta a peça em jogo uma posição para baixo.
Caso a peça tenha batido em algum obstáculo no movimento
para baixo, a mesma é fica e incorporada ao grid, e uma nova
peça é colocada em jogo. Caso não seja possivel colocar uma
nova peça, a pilha de peças bateu na tampa -- Game Over
---------------------------------------------------------- */
METHOD _MoveDown() CLASS APTETRIS
Local aOldPiece
Local nMoved := 0
If ::nGameStatus != GAME_RUNNING
 Return
Endif
// Clona a peça em queda na posição atual
aOldPiece := aClone(::aGameCurr)
// Primeiro remove a peça do Grid atual
::_DelPiece(::aGameCurr,::aGameGrid)
// Agora move a peça apenas uma linha pra baixo
::aGameCurr[PIECE_ROW]++
// Recoloca a peça no Grid
If ::_SetPiece(::aGameCurr,::aGameGrid)
 
 // Nao bateu em nada, beleza. 
 // Retorna aqui mesmo 
 Return
 
Endif
// Opa ... Esbarrou em alguma peça ou fundo do grid
// Volta a peça pro lugar anterior e recoloca a peça no Grid
::aGameCurr := aClone(aOldPiece)
::_SetPiece(::aGameCurr,::aGameGrid)
// Encaixou uma peça .. Incrementa o score em 4 pontos
// Nao importa a peça ou como ela foi encaixada
::nGameScore += 4
// Verifica apos a pea encaixada, se uma ou mais linhas
// foram preenchidas e podem ser eliminadas
::_FreeLines()
// Pega a proxima peça e coloca em jogo
nPiece := ::nNextPiece
::aGameCurr := {nPiece,1,1,6} // Peca, direcao, linha, coluna
If !::_SetPiece(::aGameCurr,::aGameGrid)
 
 // Acabou, a peça nova nao entra (cabe) no Grid
 // "** GAME OVER** "
 ::nGameStatus := GAME_OVER
 
 // Chama o codeblock de mudança de estado - Game Over
 Eval(::bChangeState , ::nGameStatus )
 
 // E retorna aqui mesmo
 Return
 
Endif
// Inicializa proxima peça em branco
::aNextPiece := array(4,"00000")
// Sorteia a proxima peça que vai cair
::nNextPiece := randomize(1,len(::aGamePieces)+1)
::_SetPiece( {::nNextPiece,1,1,1} , ::aNextPiece)
// Dispara a pintura da próxima peça
Eval( ::bPaintNext , ::aNextPiece )
// e retorna para o processamento de ações
Return
METHOD _DropDown() CLASS APTETRIS
Local aOldPiece
Local nMoved := 0
If ::nGameStatus != GAME_RUNNING
 Return .F.
Endif
// Clona a peça em queda na posição atual
aOldPiece := aClone(::aGameCurr)
// Dropa a peça até bater embaixo
// O Drop incrementa o score em 1 ponto
// para cada linha percorrida. Quando maior a quantidade
// de linhas vazias, maior o score acumulado com o Drop
// Remove a peça do Grid atual
::_DelPiece(::aGameCurr,::aGameGrid)
// Desce uma linha pra baixo
::aGameCurr[PIECE_ROW]++
While ::_SetPiece(::aGameCurr,::aGameGrid)
 
 // Peça desceu mais uma linha
 // Incrementa o numero de movimentos dentro do Drop
 nMoved++
// Incrementa o Score
 ::nGameScore++
// Remove a peça da interface
 ::_DelPiece(::aGameCurr,::aGameGrid)
 
 // Guarda a peça na posição atual
 aOldPiece := aClone(::aGameCurr)
 
 // Desce a peça mais uma linha pra baixo
 ::aGameCurr[PIECE_ROW]++
 
Enddo
// Volta a peça na última posição válida, 
::aGameCurr := aClone(aOldPiece)
::_SetPiece(::aGameCurr,::aGameGrid)
 
// Se conseguiu mover a peça com o Drop
// pelo menos uma linha, retorna .t. 
Return (nMoved > 0)
/* -----------------------------------------------------------------------
Remove a peça informada do grid informado
----------------------------------------------------------------------- */
METHOD _DelPiece(aPiece,aGrid) CLASS APTETRIS
Local nPiece := aPiece[PIECE_NUMBER]
Local nRotate := aPiece[PIECE_ROTATION]
Local nRow := aPiece[PIECE_ROW]
Local nCol := aPiece[PIECE_COL]
Local nL, nC
Local cTecoGrid, cTecoPeca
// Como a matriz da peça é 4x4, trabalha em linhas e colunas
// Separa do grid atual apenas a área que a peça está ocupando
// e desliga os pontos preenchidos da peça no Grid.
// Esta função não verifica se a peça que está sendo removida
// é a correta, apenas apaga do grid os pontos ligados que
// a peça informada ocupa nas coordenadas especificadas
For nL := nRow to nRow+3
 cTecoPeca := ::aGamePieces[nPiece][1+nRotate][nL-nRow+1]
 If nL > len(aGrid)
 // O Grid acabou, retorna
 Return
 Endif
 cTecoGrid := substr(aGrid[nL],nCol,4)
 For nC := 1 to 4
 If Substr(cTecoPeca,nC,1)=='1'
 cTecoGrid := Stuff(cTecoGrid,nC,1,'0')
 Endif
 Next
 aGrid[nL] := stuff(aGrid[nL],nCol,4,cTecoGrid)
Next
Return
/* -----------------------------------------------------------------------
Verifica e elimina as linhas "completas"
após uma peça ser encaixada no Grid
----------------------------------------------------------------------- */
METHOD _FreeLines() CLASS APTETRIS
Local nErased := 0
Local cTecoGrid
For nL := 21 to 2 step -1
 
 // Sempre varre de baixo para cima
 cTecoGrid := substr(::aGameGrid[nL],3)
 
 If !('0'$cTecoGrid)
 // Se a linha nao tem nenhum espaço em branco
 // Elimina esta linha e acrescenta uma nova linha
 // em branco no topo do Grid
 adel(::aGameGrid,nL)
 ains(::aGameGrid,1)
 ::aGameGrid[1] := GRID_EMPTY_LINE
 nL++
 nErased++
 Endif
 
Next
// Pontuação por linhas eliminadas
// Quanto mais linhas ao mesmo tempo, mais pontos
If nErased == 4
 ::nGameScore += 100
ElseIf nErased == 3
 ::nGameScore += 50
ElseIf nErased == 2
 ::nGameScore += 25
ElseIf nErased == 1
 ::nGameScore += 10
Endif
Return
/* ------------------------------------------------------
Retorna um grid de jogo vazio / inicializado
O Grid no core do tetris contem 21 linhas por 14 colunas
As limitações nas laterais esquerda e direita para 
facilitar os algoritmos para fazer a manutenção no Grid 
A área visivel nas colunas do Grid está indicada usando 
"." Logo, mesmo que o grid em memoria 
tenha 21x14, o grid de bitmaps de interface tem apenas 20x10, 
a partir da coordenada 2,3 ( linha,coluna ) do Grid do Jogo
"11000000000011" -- Primeira linha, não visivel 
"11..........11" -- demais 20 linhas, visiveis da coluna 2 a 11
------------------------------------------------------ */
METHOD _GetEmptyGrid() CLASS APTETRIS
Local aEmptyGrid 
aEmptyGrid := array(21,GRID_EMPTY_LINE)
Return aEmptyGrid
/* ------------------------------------------------------
Função auxiliar de conversão de segundos para HH:MM:SS
------------------------------------------------------ */
STATIC Function STOHMS(nSecs)
Local nHor
Local nMin
nHor := int(nSecs/3600)
nSecs -= (3600*nHor)
nMin := int(nSecs/60)
nSecs -= (60*nMin)
Return strzero(nHor,2)+':'+Strzero(nMin,2)+':'+strzero(nSecs,2)

Conclusão

A implementação realizada poderia ser mais refinada ou flexível, mas atende a esta necessidade. Uma outra alternativa interessante, ao invés de criar vários CodeBlocks, um para cada evento, seria criar apenas um CodeBlock e passar ele em uma propriedade da classe, e através dele fazer todas as chamadas de interface, passando como parâmetros a instância do jogo (self), um código para indicar qual evento está sendo disparado, e um ou mais parâmetros especificos do evento. Neste caso, o fonte de interface teria que construir uma função única de “CallBack”, onde dentro dela cada evento seria tratado em um DO CASE…END CASE, por exemplo.

Agora, dêem uma olhada no código antigo, todo “amarrado”, e no código novo. Pra mim é visivelmente mais fácil dar manutenção no código orientado a objetos do que no código procedural, pois cada coisa está visivelmente em seu lugar, e cada parte do código têm a sua responsabilidade e atribuições bem definidas. Espero que vocês tirem proveito da orientação a objeto, com tanta satisfação como a que eu tenho em escrever estes códigos !!

Até o próximo post, pessoal 😉 E obrigado pela audiência 😀

Imagens no SGDB via DBAccess

Introdução

Recebi um e-mail, ou mensagem, ou post (não lembro agora) com uma sugestão interessante, para este tema (Imagens no SGDB) fosse abordado aqui no Blog. E, é totalmente possível de ser feito, de forma relativamente simples.

Imagens, por dentro

Um arquivo em disco que contém uma imagem pode ser salvo em diversos formatos: BMP (Bitmap Image File), JPEG (Joint Photographic Experts Group), PNG (Portable Network Graphics), entre outros. Cada formato consiste em uma especificação para a representação binária de uma imagem. Trocando em miúdos, um arquivo de imagem contém um determinado número de bytes, usando códigos ASCII de 0 a 255 (conteúdo binário), que são interpretados por uma aplicação capaz de mostrar seu conteúdo em uma interface. Cada tipo de imagem possui algumas características, como resolução, compressão, mas por dentro são apenas uma sequência de bytes.

Imagens no SGDB

Existem bancos de dados que possuem um tipo de campo próprio para imagens, como o Microsoft SQL Server (campo image), mas a grosso modo praticamente todos os bancos de dados comerciais possuem um tipo de campo conhecido por “BLOB” (Binary Large OBject), capaz de suportar conteúdo binário.

Acesso pelo DBAccess

Como é de conhecimento de todos que trabalham com o ERP Microsiga, todo o accesso a Banco de Dados relacional no Protheus é feito através do DBAccess, um gateway de acesso para bancos relacionais, que também é capaz de emular o acesso ISAM, ainda usado por boa parte do código legado do ERP.

O DBAccess não permite acesso direto a campos IMAGE, BLOB ou CLOB, mas internamente ele se utiliza destes campos para emular o campo do tipo “M” memo do AdvPL. Logo, para nos utilizarmos destes tipos de campo, devemos criar uma tabela no SGDB usando o tipo de campo “M” (Memo) do AdvPL.

Atenção, no ERP existe o conceito de campo Memo virtual, criado no dicionário de dados do ERP (SX3), que na prática utiliza um arquivo auxiliar (SYP) na Base de Dados principal, com acesso através de uma API Advpl, ao qual esse exemplo não se aplica. O campo Memo que será criado é um Memo “real” no SGDB.

Características e Limites

O AdvPL possui um limite de 1MB de tamanho máximo de String, logo ainda não é possível armazenar no SGDB uma imagem maior que isso. E, como o acesso ao conteúdo do campo é feito pelo DBAccess, não é possível fazer uma Query que recupere diretamente o conteúdo de um campo BLOB, CLOB ou IMAGE.

Para acessar o conteúdo de um campo “M” Memo criado em uma tabela, devemos abrir a tabela no AdvPL usando DbUseArea() — ou ChkFile(), para uma tabela de dados do ERP –, posicionar no registro desejado e ler o valor do campo do registro atual através da expressão cVARIAVEL := ALIAS->CAMPOMEMO, e o DBAccess irá fazer uma requisição exclusiva para trazer o conteúdo deste campo e colocá-lo na variável de memória.

Adicionalmente, o campo “M” Memo originalmente no AdvPL foi projetado para suportar apenas 64 KB de dados, e somente conseguimos aumentar esse limite para 1MB habilitando a configuração TOPMEMOMEGA=1 na configuração do environment desejado no arquivo de configuração do TOTVS Application Server (appserver.ini) — Vide TDN, no link http://tdn.totvs.com/pages/viewpage.action?pageId=6065746 )

Como as imagens gravadas costumam ser bem maiores que os registros gravados em tabelas de dados do ERP, deve-se tomar cuidado quando a leitura destes campos for realizada por muitos processos simultaneamente, isto pode gerar um gargalo na camada de rede entre as aplicações TOTVS Application Server, DBACcess e o SGDB.

E, existem alguns bancos de dados homologados que por default não se utilizam de campos BLOB ou similares para armazenar os dados de campo “M” Memo. Para ter certeza que a implementação vai funcionar em todos os bancos homologados, podemos limitar o tamanho da imagem em 745 KB, e converter o buffer binário da imágem para BASE64, onde são usadas strings de texto normal para a representação dos dados, e fazer as conversões em memória para Ler e Gravar o buffer binário.

Mãos à obra

Basicamente, armazenar uma imagem no SGDB requer no mínimo 2 campos na tabela de imagens: Um campo caractere, identificador único da imagem, indexado, e um campo “M” Memo do AdvPL, para armazenar a imagem. Podemos encapsular isso em uma classe — vamos chamá-la ApDbImage() — e implementar os métodos de leitura e gravação, manutenção e status, além de dois métodos adicionais para ler imagens de um arquivo no disco para a memória, e gravar a imagem da memória para o disco.

A classe APDBIMAGE() foi implementada com este propósito, mas ela têm ainda alguns detalhes adicionais, ela guarda um HASH MD5 gerado a partir da imagem original, um campo separado para o tipo da imagem, e permite as operações básicas de inclusão, leitura, alteração e exclusão.

Exemplo de uso e fontes

O programa de exemplo funciona como um manager simples de imagens, permitindo abrir os formatos suportados de imagens do disco, para serem mostrados na tela, ou do próprio repositório, ou também da tabela de imagens do Banco de Dados. Uma vez visualizada uma imagem na interface, ela pode ser gravada em disco (ou exportada), no mesmo formato que foi aberto — o programa não realiza conversões — , e também pode ser inserida no DBimage com um nome identificador qualquer, ou usada para alterar uma imagem já existente na tabela de imagens.

O fonte da classe APDBImage() pode ser baixado no link https://github.com/siga0984/Blog/blob/master/ApDBImage.prw , e o fonte de exemplo que usa a classe está no link https://github.com/siga0984/Blog/blob/master/TSTDBIMG.prw , ambos no GitHub do Blog ( https://github.com/siga0984/blog ). Basta baixar os fontes, compilá-los com o IDE ou o TDS, e executar a função U_TSTDBIMG para acionar o programa de testes da classe ApDbImage().

E, para os curiosos e ávidos por código, segue o fonte da Classe APDBIMAGE logo abaixo:

#include "protheus.ch"
/* ---------------------------------------------------
Classe ApDBImage
Autor Júlio Wittwer
Data 27/02/2015 
Versão 1.150308
Descrição Classe para encapsular leitura e gravação de 
 imagens em tabela do SGDB através do DBACCESS
Observação
Como apenas o banco MSSQL aceita conteúdo binário ( ASCII 0 a 255 )
para campos MEMO, e os bancos ORACLE e DB2 ( quando usado BLOB ), 
para servir para todos os bancos, a imagem é gravada no banco 
usando Encode64 -- para converter conteúdo binário em Texto 
codificado em Base64, a maior imagem nao pode ter mais de 745000 bytes
Referências
http://tdn.totvs.com/display/tec/Acesso+ao+banco+de+dados+via+DBAccess
http://tdn.totvs.com/pages/viewpage.action?pageId=6063692
http://tdn.totvs.com/display/tec/Encode64
http://tdn.totvs.com/display/tec/Decode64
--------------------------------------------------- */
#define MAX_IMAGE_SIZE 745000
CLASS APDBIMAGE
// Propriedades
 DATA bOpened 
 DATA cError
// Métodos 
 METHOD New() 
 METHOD Open()
 METHOD Close() 
 METHOD ReadStr( cImgId , /* @ */ cImgType , /* @ */ cImgBuffer ) 
 METHOD Insert( cImgId , cImgType , /* @ */ cImgBuffer ) 
 METHOD Update( cImgId , cImgType , /* @ */ cImgBuffer ) 
 METHOD Delete( cImgId ) 
 METHOD Status()
// Metodos de acesso de imagens no disco
 METHOD LoadFrom( cFile, cImgBuffer )
 METHOD SaveTo( cFile, cImgBuffer )
 
ENDCLASS
/* ---------------------------------------------------------
Construtor da classe de Imagens no SGDB
Apenas inicializa propriedades
-------------------------------------------------------- */
METHOD New() CLASS APDBIMAGE
::bOpened := .F.
::cError := ''
Return self
/* ---------------------------------------------------------
Abre a tabela de imagens no SGDB
Conecta no DBAccess caso nao haja conexão
--------------------------------------------------------- */
METHOD Open( ) CLASS APDBIMAGE
Local nDBHnd := -1
Local aStru := {}
Local cOldAlias := Alias()
::cError := ''
IF ::bOpened 
 // Ja estava aberto, retorna direto
 Return .T.
Endif
If !TcIsConnected() 
 // Se não tem conexão com o DBAccess, cria uma agora
 // Utiliza as configurações default do appserver.ini
 nDBHnd := tcLink()
 If nDBHnd < 0
 ::cError := "TcLink() error "+cValToChar(nDbHnd)
 Return .F.
 Endif
Endif
If !TCCanOpen("ZDBIMAGE")
 
 // Cria array com a estrutura da tabela
 aAdd(aStru,{"ZDB_IMGID" ,"C",40,0})
 aAdd(aStru,{"ZDB_TYPE" ,"C",3,0}) // BMP JPG PNG 
 aAdd(aStru,{"ZDB_HASH" ,"C",32,0}) 
 aAdd(aStru,{"ZDB_SIZE" ,"N",8,0})
 aAdd(aStru,{"ZDB_MEMO" ,"M",10,0})
// Cria a tabela direto no SGDB
 DBCreate("ZDBIMAGE",aStru,"TOPCONN")
 
 // Abre em modo exclusivo para criar o índice de ID
 USE ("ZDBIMAGE") ALIAS ZDBIMAGE EXCLUSIVE NEW VIA "TOPCONN"
 
 If NetErr()
 ::cError := "Failed to open [ZDBIMAGE] on EXCLUSIVE Mode"
 Return
 Endif
 
 // Cria o índice por ID da imagem 
 INDEX ON ZDB_IMGID TO ("ZDBIMAGE1")
 
 // Fecha a tabela
 USE
 
Endif
 
// Abre em modo compartilhado
USE ("ZDBIMAGE") ALIAS ZDBIMAGE SHARED NEW VIA "TOPCONN"
If NetErr()
 ::cError := "Failed to open [ZDBIMAGE] on SHARED Mode"
 Return .F.
Endif
DbSetIndex("ZDBIMAGE1")
DbSetOrder(1)
::bOpened := .T.
If !Empty(cOldAlias) .and. Select(cOldAlias) > 0
 DbSelectArea(cOldAlias)
Endif
Return ::bOpened
/* ---------------------------------------------------------
Le uma imagem do banco para a memoria
recebe o nome da imgem, retorna por referencia o tipo
da imagem e seu conteudo 
-------------------------------------------------------- */
METHOD ReadStr( cImgId , /* @ */cImgType, /* @ */ cImgBuffer ) CLASS APDBIMAGE
::cError := ''
If !::bOpened
 ::cError := "APDBIMAGE:ReadStr() Error: Instance not opened."
 Return .F.
Endif
If empty(cImgId)
 ::cError := "APDBIMAGE:ReadStr() Error: ImageId not specified."
 Return .F. 
Endif
cImgId := Lower(cImgId)
If !ZDBIMAGE->(DbSeek(cImgId))
 ::cError := "APDBIMAGE:ReadStr() ImageId ["+cImgId+"] not found."
 Return .F.
Endif
// Caso a imagem com o ID informado seja encontrada
// Carrega o buffer da imagem para a variável de memória
cImgBuffer := Decode64(ZDBIMAGE->ZDB_MEMO)
cImgType := ZDBIMAGE->ZDB_TYPE
Return .T.
/* ---------------------------------------------------------
Insere uma imagem na tabela de imagens do SGDB
Recebe o ID da imagem, o tipo e o buffer 
-------------------------------------------------------- */
METHOD Insert( cImgId , cImgType, cImgBuffer ) CLASS APDBIMAGE
Local bOk := .F.
::cError := ''
If !::bOpened
 ::cError := "APDBIMAGE:Insert() Error: Instance not opened."
 Return .F. 
Endif
If empty(cImgId)
 ::cError := "APDBIMAGE:Insert() Error: ImageId not specified."
 Return .F. 
Endif
If empty(cImgType)
 ::cError := "APDBIMAGE:Insert() Error: ImageType not specified."
 Return .F. 
Endif
cImgId := Lower(cImgId)
cImgType := Lower(cImgType)
If !ZDBIMAGE->(DbSeek(cImgId))
 // Se a imagem não existe, insere
 ZDBIMAGE->(DBAppend(.T.))
 ZDBIMAGE->ZDB_IMGID := cImgId
 ZDBIMAGE->ZDB_TYPE := cImgType
 ZDBIMAGE->ZDB_SIZE := len(cImgBuffer)
 ZDBIMAGE->ZDB_HASH := Md5(cImgBuffer,2) // Hash String Hexadecimal
 ZDBIMAGE->ZDB_MEMO := Encode64(cImgBuffer)
 ZDBIMAGE->(DBRUnlock())
 bOk := .T.
else
 ::cError := 'Image Id ['+cImgId+'] already exists.'
Endif
Return bOk
/* ---------------------------------------------------------
Atualiza uma imagem ja existente no banco de imagens
Recebe ID, tipo e buffer
-------------------------------------------------------- */
METHOD Update( cImgId , cImgType, cImgBuffer ) CLASS APDBIMAGE
::cError := ''
If !::bOpened
 ::cError := "APDBIMAGE:Update() Error: Instance not opened."
 Return .F. 
Endif
If empty(cImgId)
 ::cError := "APDBIMAGE:Update() Error: ImageId not specified."
 Return .F. 
Endif
If empty(cImgType)
 ::cError := "APDBIMAGE:Update() Error: ImageType not specified."
 Return .F. 
Endif
cImgId := Lower(cImgId)
cImgType := Lower(cImgType)
 
If !ZDBIMAGE->(DbSeek(cImgId))
 ::cError := 'Image Id ['+cImgId+'] not found.'
 Return .F.
Endif
// Se a imagem existe, atualiza
IF !ZDBIMAGE->(DbrLock(recno()))
 ::cError := 'Image Id ['+cImgId+'] update lock failed.'
 Return .F.
Endif
ZDBIMAGE->ZDB_TYPE := cImgType
ZDBIMAGE->ZDB_SIZE := len(cImgBuffer)
ZDBIMAGE->ZDB_HASH := MD5(cImgBuffer,2) // Hash String Hexadecimal
ZDBIMAGE->ZDB_MEMO := Encode64(cImgBuffer)
ZDBIMAGE->(DBRUnlock())
Return .T.
/* ---------------------------------------------------------
Deleta fisicamente uma imagem da Tabela de Imagens
-------------------------------------------------------- */
METHOD Delete( cImgId , lHard ) CLASS APDBIMAGE
Local nRecNo
::cError := ''
If !::bOpened
 ::cError := "APDBIMAGE:Delete() Error: Instance not opened."
 Return .F. 
Endif
If empty(cImgId)
 ::cError := "APDBIMAGE:Delete() Error: ImageId not specified."
 Return .F. 
Endif
If !ZDBIMAGE->(DbSeek(cImgId))
 ::cError := 'Image Id ['+cImgId+'] not found.'
 Return .F.
Endif
// Se a imagem existe, marca o registro para deleção
nRecNo := ZDBIMAGE->(recno())
// Mesmo que a deleção seja fisica, eu garanto 
// o lock do registro na camada do dbaccess
If !ZDBIMAGE->(DbrLock(nRecNo))
 ::cError := 'Image Id ['+cImgId+'] delete lock failed.'
 Return .F.
Endif
// Deleta fisicamente no SGBD
nErr := TcSqlExec("DELETE FROM ZDBIMAGE WHERE R_E_C_N_O_ = " + cValToChar(nRecNo) )
If nErr < 0
 ::cError := 'Image Id ['+cImgId+'] delete error: '+TcSqlError()
Endif
// Solto o lock do registro no DBAccess
ZDBIMAGE->(DBRUnlock())
Return .T.
/* ---------------------------------------------------------
Fecha a tabela de imagens
-------------------------------------------------------- */
METHOD Close() CLASS APDBIMAGE
If Select('ZDBIMAGE') > 0
 ZDBIMAGE->(DbCloseArea())
Endif
::cError := '' 
::bOpened := .F.
Return .T.
/* ---------------------------------------------------------
Metodo Status()
Classe APDBIMAGE
Descrição Monta array por referencia contendo as informações da base 
 de imagens: Quantidade de registros total, tamanho estimado 
 total das imagens, quantidade de registros marcados para 
 deleção e tamanho estimado de imagens marcadas para deleçao 
-------------------------------------------------------- */
METHOD Status( /* @ */ aStat ) CLASS APDBIMAGE
Local cOldAlias := Alias()
Local cQuery 
Local nCountAll := 0
Local nSizeAll := 0
::cError := '' 
aStat := {}
If !::bOpened
 ::cError := "APDBIMAGE:Status() Error: Instance not opened."
 Return .F. 
Endif
// Conta quantas imagens tem na tabela, por tipo 
cQuery := "SELECT ZDB_TYPE, count(*) AS TOTAL"+;
 " FROM ZDBIMAGE GROUP BY ZDB_TYPE ORDER BY ZDB_TYPE"
 
USE (TcGenQry(,,cQuery)) ALIAS QRY EXCLUSIVE NEW VIA "TOPCONN"
While !eof()
 aadd(aStat , {"TOTAL_COUNT_"+QRY->ZDB_TYPE,QRY->TOTAL})
 nCountAll += QRY->TOTAL
 DbSkip()
Enddo
USE
// Acrescenta total de imagens
aadd(aStat , {"TOTAL_COUNT_ALL",nCountAll})
 
// Levanta o total de bytes usados por tipo de imagem
cQuery := "SELECT ZDB_TYPE, SUM(ZDB_SIZE) AS TOTAL"+;
 " FROM ZDBIMAGE GROUP BY ZDB_TYPE ORDER BY ZDB_TYPE"
 
USE (TcGenQry(,,cQuery)) ALIAS QRY EXCLUSIVE NEW VIA "TOPCONN"
While !eof()
 aadd(aStat , {"TOTAL_SIZE_"+QRY->ZDB_TYPE,QRY->TOTAL})
 nSizeAll += QRY->TOTAL
 DbSkip()
Enddo
USE
// Acrescenta total de bytes usados 
aadd(aStat , {"TOTAL_SIZE_ALL",nSizeAll})
If !Empty(cOldAlias)
 DbSelectArea(cOldAlias)
Endif
Return .T.
/* ---------------------------------------------------------
Ler um arquivo de imagem do disco para a memoria
Nao requer que a instancia esteja inicializada / Aberta
--------------------------------------------------------- */
METHOD LoadFrom( cFile, /* @ */ cImgBuffer ) CLASS APDBIMAGE
Local nH, nSize, nRead
::cError := ''
If !file(cFile)
 ::cError := "APDBIMAGE:LoadFrom() Error: File ["+cFile+"]not found."
 Return .F. 
Endif
nH := Fopen(cFile,0)
If nH == -1 
 ::cError := "APDBIMAGE:LoadFrom() File Open Error ( FERROR "+cValToChar( Ferror() )+")" 
 Return .F. 
Endif
nSize := fSeek(nH,0,2)
fSeek(nH,0)
If nSize <= 0 
 ::cError := "APDBIMAGE:LoadFrom() File Size Error : Empty File" 
 fClose(nH)
 Return .F. 
Endif
If nSize > MAX_IMAGE_SIZE
 ::cError := "APDBIMAGE:LoadFrom() File TOO BIG ("+ cValToChar(nSize) +" bytes)" 
 fClose(nH)
 Return .F. 
Endif
// Aloca buffer para ler o arquivo do disco 
// e le o arquivo para a memoria
cImgBuffer := space(nSize)
nRead := fRead(nH,@cImgBuffer,nSize)
// e fecha o arquivo no disco 
fClose(nH)
If nRead < nSize
 cImgBuffer := ''
 ::cError := "APDBIMAGE:LoadFrom() Read Error ( FERROR "+cValToChar( Ferror() )+")" 
 Return .F. 
Endif
Return .T.
/* ---------------------------------------------------------
Gravar um arquivo de imagem no disco a partir de uma imagem na memoria
Nao requer que a instancia esteja inicializada / Aberta
--------------------------------------------------------- */
METHOD SaveTo( cFile, cImgBuffer ) CLASS APDBIMAGE
Local nH, nSize , nSaved 
::cError := ''
If file(cFile)
 ::cError := "APDBIMAGE:SaveTo() Error: File ["+cFile+"] alreay exists."
 Return .F. 
Endif
// Cria o arquivo no disco 
nH := fCreate(cFile)
If nH == -1 
 ::cError := "APDBIMAGE:SaveTo() File Create Error ( FERROR "+cValToChar( Ferror() )+")" 
 Return .F. 
Endif
 
// Calcula tamanho do buffer de memoria
// e grava ele no arquivo 
nSize := len(cImgBuffer)
nSaved := fWrite(nH,cImgBuffer)
// Fecha o arquivo 
fClose(nH)
If nSaved < nSize
 ::cError := "APDBIMAGE:SaveTo() Write Error ( FERROR "+cValToChar( Ferror() )+")" 
 Return .F. 
Endif
Return .T.
Conclusão

Esta classe é só um esboço, com alguns parafusos a mais ela pode ser usada para construir um assistente para, por exemplo, importar uma pasta cheia de imagens para o banco de dados, dando o nome das imagens automaticamente baseado no nome do arquivo original, e o fato dela gerar o MD5 Hash a partir do buffer binário original pode permitir uma busca mais rápida por imagens idênticas repetidas dentro do banco, fazendo apenas uma Query para mostrar quais os ImageID´s que possuem o mesmo HASH !!!

Pessoal, novamente agradeço a audiência, espero que gostem do Post. Já tenho alguma coisa no forno para os próximos posts, mas continuo aceitando sugestões !! Até o próximo post, pessoal 😉