Resta1 em AdvPL

Introdução

Seguindo a linha de jogos em AdvPL, hoje o post traz para vocês a contribuição do desenvolvedor e nobre colega Flávio Luiz Vicco, que fez um porte do jogo “Resta 1” para o AdvPL, usando orientação a objeto em AdvPL.

O Jogo

Resta 1 é um quebra-cabeças, cujo objetivo é retirar todas as peças do tabuleiro, até que reste somente uma. No início do jogo, há 32 peças no tabuleiro, deixando vazia a posição central. Um movimento consiste em pegar uma peça e fazê-la “saltar” sobre outra peça, sempre na horizontal ou na vertical, terminando em um espaço vazio. A peça que foi “saltada” é retirada do tabuleiro. O jogo termina quando não mais é possível fazer nenhum outro movimento. Nesta ocasião, o jogador ganha se restar apenas uma peça no tabuleiro.

resta1

Com apenas 250 linhas a classe com o “core” do jogo foi implementada, e usando menos de 50 linhas, foi implementada a função executora do Jogo. Internamente, o jogo usa a classe tPaintPanel, e a classe executora monta o jogo usando uma caixa de diálogo e um menu superior. Os objetos correspondentes às peças do quebra-cabeça são criados nas respectivas posições, disparando um bloco de código a cada clique do mouse em cada posição. Ao clicar em uma posição ocupada por uma pedra, a respectiva posição é selecionada. Ao clicar em uma nova pedra, esta passa ser a pedra selecionada. Uma vez havendo a seleção de uma pedra, caso você clique em uma posição livre localizada a 2 pedras de distância da pedra selecionada, e entre elas existe uma pedra, a pedra selecionada é movida para a nova posição selecionada, e a pedra entre elas é removida.

Compilando e Executando

Para compilar e executar o Resta Um, basta baixar os fontes e imagens do GitHub, no endereço “https://github.com/siga0984/Resta1-OO“, criar um projeto no IDE/TDS, acrescentar os dois fontes PRW no projeto, acrescentar todas as imagens no projeto como recursos do Projeto, compilar tudo, e chamar a função “U_RESTA1” através do SmartClient.

O Código

Um jogo de tabuleiro, sem adversário ou contagem de tempo, deve ter uma representação em memória do estado do tabuleiro, uma interface que represente graficamente esta representação, e permita ao jogador imputar um movimento, e ser capaz de criticar um movimento inválido, e aplicar um movimento válido na representação do tabuleiro em memória.

Para desempenhar estas tarefas, o jogo foi implementado como uma classe em AdvPL, chamada “TResta1”, onde o construtor “New()” recebe como parâmetro o “container” de interface do Jogo — no nosso caso o objeto da janela de diálogo — e inicia a execução do jogo através do método Activete() da classe “TResta1”.

Na classe TRESTA1, a propriedade “aShape” contem todas as peças do quebra-cabeças. Como o tabuleiro é basicamente a união de um array 3×7 e outro 7×3, compartilhando a área central ( 3×3 ), o array é criado baseado em um loop de 7×7 elementos, onde as posições onde não entraria nenhuma pedra nao são ocupadas não criam nenhum novo elemento. São 16 posicoes ignoradas, 4 de cada quadrante. Sabendo que uma matriz 7×7 tem 49 elementos, e 16 serão ignorados, serão criadas 33 posições no tabuleiro, onde para cada uma será atribuído um status ( vazio / ocupado / selecionado ) e uma imagem correspondente ao estado.

Partindo de um loop 7×7, numerando cada elemento sequencialmente, eu teria as seguintes posições numeradas:

01 02 03 04 05 06 07
08 09 10 11 12 13 14
15 16 17 18 19 20 21
22 23 24 25 26 27 28
29 30 31 32 33 34 35
36 37 38 39 40 41 42
43 44 45 46 47 48 49

Somente serão criados elementos para as posições onde podem haver pedras no quebra-cabeça. Logo, as 4 pedras de cada extremidade deste quadrado não serão usadas — repare que as posições a serem usadas estão em negrito. Cada pedra é criada como um “Shape” dentro do tPaintPanel, e cada uma delas recebe um identificador único, sendo criadas 33 pedras ( ou shapes ), no loop abaixo — vide método Activate() da classe tResta1.

For nX := 1 To 7
 For nY := 1 To 7
  nZ ++
  If !StrZero(nZ,2) $ "01|02|06|07|08|09|13|14|36|37|41|42|43|44|48|49"
   ::Create( ::oTPanel, nX, nY, "P"+StrZero(nZ,2), IIf(nZ==25,0,1) )
  EndIf
 Next nY
Next nX

O evento interessante tratado no jogo é o Click() … A classe tPaintPanel() tem uma propriedade que permite informar um bloco de código, que será disparado quando o usuário da aplicação clicar com o mouse dentro da área do tPaintPanel. Ao ver o fonte, reparamos que o evento em si não recebe nenhum parâmetro, mas isso não impede do método ‘descobrir’ se o evento de clique do mouse foi feito em cima de um determinado Shape. Ao ser criado, cada shape possui um “ID”, informado pela aplicação como um valor numérico. Quando um evento de clique do mouse é realizado sobre um shape, a propriedade ShapeAtu da instância do tPaintPanel é atualizada. Logo, o método somente precisa procurar no array de Shapes qual o shape que foi clicado. Se não foi clicado em nenhum shape, o evento é ignorado.

//-- Identifica obj. shape clicado.
nDestino := aScan(::aShape,{ |x|(x[1] == ::oTPanel:ShapeAtu)})

Ainda dentro do método Click(), existe todo o tratamento para avaliar como o clique deve ser tratado. Para realizar um “pulo”, você deve selecionar uma pedra, criando sobre ela, e depois clicando em um espaço em branco, indicando que você quer movê-la para aquela posição. Seu movimento somente será realizado se, a posição escolhida tiver a distancia de 2 casas, na horizontal ou vertical — diagonal não pode — , e entre a posição selecionada e a posição escolhida, exista uma pedra — que será removida.

E, da forma que o jogo foi idealizado, existe um programa “base”, ou “executor”, que é responsável por prover a interface externa do jogo — A janela de diálogo onde o jogo será montado e o menu de opções — Iniciar Novo Jogo, Ajuda, Sair, barra de status inferior, etc. Reparem que apenas uma instância do jogo é criada e armazenada na variável oResta1, e a partir deste ponto todas as ações externas que podem ser realizadas com o Jogo ( iniciar, reiniciar, mostrar ajuda) são feitas a partir dos métodos publicados.

#INCLUDE "PROTHEUS.CH"

/* -----------------------------------------------------
Fonte RESTA1.PRW
Programa Resta 1 - executor
Autor Flavio Luiz Vicco
Data 11/2016
----------------------------------------------------- */

User Function Resta1()
 Local oDlg
 Local oResta1
 DEFINE DIALOG oDlg TITLE "Resta1" From 180,180 TO 550,700 PIXEL COLOR CLR_BLACK,CLR_WHITE
 oDlg:lEscClose := .F.
 //-- Cria Resta1
 oResta1:= TResta1():New(oDlg)
 //-- Cria Menu superior
 CreateMenuBar(oDlg,oResta1)
 //-- Cria Barra de Status inferior
 CreateMsgBar(oDlg)
 // Na ativação do dialogo, ativa o jogo 
 ACTIVATE DIALOG oDlg CENTERED ON INIT oResta1:Activate()
Return Nil

//-- Cria Menu superior
Static Function CreateMenuBar(oDlg,oResta1)
 oTMenuBar:= TMenuBar():New(oDlg)
 oTMenuBar:SetCss("QMenuBar{background-color:#eeeddd;}")
 oTMenuBar:Align := CONTROL_ALIGN_TOP
 oTMenuBar:nClrPane := RGB(238,237,221)
 oTMenuBar:bRClicked := {||}
 oFile:= TMenu():New(0,0,0,0,.T.,,oDlg)
 oHelp:= TMenu():New(0,0,0,0,.T.,,oDlg)
 oTMenuBar:AddItem("&Arquivo",oFile,.T.)
 oTMenuBar:AddItem("Aj&uda" ,oHelp,.T.)
 oFile:Add(TMenuItem():New(oDlg,"&Novo Jogo",,,,{|| oResta1:NewGame()},,"",,,,,,,.T.))
 oFile:Add(TMenuItem():New(oDlg,"Sai&r",,,,{|| If(MsgYesNo("Deseja realmente sair do jogo?"),oDlg:End(),)},,"FINAL",,,,,,,.T.))
 oHelp:Add(TMenuItem():New(oDlg,"&Sobre... F1",,,,{|| oResta1:Help() },,"RPMPERG",,,,,,,.T.))
Return

//-- Cria Barra de Status inferior
Static Function CreateMsgBar(oDlg)
 oTMsgBar := TMsgBar():New(oDlg, "Resta1",.F.,.F.,.F.,.F., RGB(116,116,116),,,.F.) 
 oTMsgItem1 := TMsgItem():New( oTMsgBar,"2014", 100,,,,.T., {||} ) 
 oTMsgItem2 := TMsgItem():New( oTMsgBar,"V.1.00", 100,,,,.T., {||} )
Return


//----------------------------------------------------------------------------

E, segue abaixo o fonte da classe do jogo .

#INCLUDE "PROTHEUS.CH"

/* -----------------------------------------------------
Fonte TRESTA1.PRW
Programa Resta 1 - objetos
Autor Flavio Luiz Vicco
Data 11/2016
----------------------------------------------------- */

Class TResta1

Data nId AS INTEGER
 Data nOrigem AS INTEGER // Numero da posicao selecionada
 Data aShape AS ARRAY INIT {}
 DATA oTPanel AS OBJECT // tPaintPanel

Method New(oDlg) CONSTRUCTOR
 Method Activate()
 Method NewGame()
 Method Create()
 Method Click( x, y, oTPanel )
 Method Change( oTPanel, nItem, nStatus )
 Method SetId()
 Method ExportImage()
 Method Help()
EndClass

Method New(oDlg) Class TResta1
 ::nId := 0 
 ::nOrigem := 0 
 ::aShape := {} 
 ::oTPanel:= TPaintPanel():new(0,0,0,0,oDlg,.f.)
 ::oTPanel:Align := CONTROL_ALIGN_ALLCLIENT
 ::oTPanel:bLClicked := {|x,y| ::Click()}
 ::ExportImage()
Return Self

Method Activate() Class TResta1
 Local nX := 0
 Local nY := 0
 Local nZ := 0
 Local cImg := "backg.png"
 Local cId := ""
 //-- Tamanho da tabuleiro
 cTabLarg := cValToChar(400)
 cTabAlt := cValToChar(450)
 //-- Ajusta tela conforme tabuleiro
 ::oTPanel:oWnd:nHeight := Val(cTabAlt)
 ::oTPanel:oWnd:nWidth := Val(cTabLarg)
 //-- Altura largura do tabuleiro
 cAltura := '0'
 cLargura := '0'
 //-- Cria Container
 ::oTPanel:addShape( "id="+::SetId()+";type=1;left=0;top=0;width="+cValToChar(Val(cTabLarg))+;
   ";height="+cValToChar(Val(cTabAlt))+";"+;
   "gradient=1,0,0,0,0,0.0,#FFFFFF;pen-width=0;pen-color=#FFFFFF"+;
   ";can-move=0;can-mark=0;is-container=1;")
 //-- Cria shape com imagem do tabuleiro
 cId := ::SetId()
 ::oTPanel:addShape( "id="+cId+";type=8;left="+cLargura+";top="+cAltura+";width="+cTabLarg+;
   ";height="+cTabAlt+";image-file="+::GetTempPath()+cImg+";tooltip=Resta1"+;
   ";can-move=0;can-deform=0;can-mark=0;is-container=1")
 For nX := 1 To 7
  For nY := 1 To 7
   nZ ++
   If !StrZero(nZ,2) $ "01|02|06|07|08|09|13|14|36|37|41|42|43|44|48|49"
    ::Create( ::oTPanel, nX, nY, "P"+StrZero(nZ,2), IIf(nZ==25,0,1) )
   EndIf
  Next nY
 Next nX
Return

Method NewGame() Class TResta1
 Local nX := 0
 Local nY := 0
 Local nZ := 0
 For nZ := 1 To Len(::aShape)
  nX := ::aShape[nZ,3]
  nY := ::aShape[nZ,4]
  If ::aShape[nZ,5] <> IIf(nX==4.And.nY==4,0,1)
   ::Change( ::oTPanel, nZ, IIf(nX==4.And.nY==4,0,1 ) )
  EndIf
 Next nZ
Return

Method Create( oPanel, nImgX, nImgY, cCodigo, nStatus, nShape, cImgId ) Class TResta1
 Local cWidth := "30"
 Local cHeight := "30"
 Local cImg := ""
 Local cToolTip := AllTrim(cCodigo)+" X= "+AllTrim(Str(nImgX))+" Y= "+AllTrim(Str(nImgY))
 Default nShape := 0
 Default cImgId := ::SetId()

 //-- Define imagem para cada status
 // 0 = Nao há pedra - vazio
 // 1 - Espaço ocupado com uma pedra
 // 2 - Pedra atualmente selecionada
 Do Case
 Case nStatus == 0
   cImg := "empty.png"
 Case nStatus == 1
   cImg := "full.png"
 Case nStatus == 2
   cImg := "select.png"
 EndCase
 //-- criacao do obj
 If nShape == 0
  aAdd(::aShape,Array(5))
  nShape := Len(::aShape)
 EndIf
 //-- config. do obj
 ::aShape[nShape,1] := Val(cImgId) //CODIGO DO SHAPE
 ::aShape[nShape,2] := cCodigo //CODIGO
 ::aShape[nShape,3] := nImgX //POSICAO X
 ::aShape[nShape,4] := nImgY //POSICAO Y
 ::aShape[nShape,5] := nStatus //STATUS

oPanel:addShape("id="+cImgId+";type=8;left="+Str(nImgY*45)+;
 ";top="+Str(nImgX*45)+";width="+cWidth+";height="+cHeight+;
 ";image-file="+::GetTempPath()+cImg+";tooltip="+cToolTip+;
 ";can-move=0;can-deform=1;can-mark=0;is-container=0")
Return

Method Click() Class TResta1
 Local nDestino := 0
 Local nSalto := 0
 Local nIdImg := 0
 Local nX := 0
 Local nY := 0
 Local nIdClk := 0
 Local nStatus := 0
 Local lOk := .F.

//-- Identifica obj. shape clicado.
 nDestino := aScan(::aShape,{ |x|(x[1] == ::oTPanel:ShapeAtu)})
 If nDestino > 0
  nStatus := ::aShape[nDestino,5]
  Do Case
  Case nStatus == 0
  If ::nOrigem > 0
  nX0 := ::aShape[::nOrigem ,3]
  nY0 := ::aShape[::nOrigem ,4]
  nX1 := ::aShape[ nDestino,3]
  nY1 := ::aShape[ nDestino,4]
  //-- Verifica se movimento horizontal valido...
  If (nX0 == nX1 .And. Abs(nDif := nY0 - nY1) == 2)
   If nDif == 2
    nDif := -1
   Else
    nDif := 1
   EndIf
   lOk := (nSalto:=aScan(::aShape,{|x| x[3]==nX0 .And. x[4]==nY0+nDif .And. x[5]==1})) > 0
  EndIf
  //-- Verifica se movimento vertical valido...
  If (nY0 == nY1 .And. Abs(nDif := nX0 - nX1) == 2)
   If nDif == 2
    nDif := -1
   Else
    nDif := 1
   EndIf
   lOk := (nSalto:=aScan(::aShape,{|x| x[3]==nX0+nDif .And. x[4]==nY0 .And. x[5]==1})) > 0
  EndIf
  If lOk
   nStatus := 1
   //-- Retira da posicao saltada
   ::Change( ::oTPanel, nSalto, 0 )
   //-- Retira da posicao anterior
   ::Change( ::oTPanel, ::nOrigem, 0 )
   ::nOrigem := 0
  EndIf
 EndIf
 Case nStatus == 1
 If ::nOrigem > 0
  //-- Retira da posicao anterior
  ::Change( ::oTPanel, ::nOrigem, 1 )
 EndIf
 nStatus := 2
 ::nOrigem:= nDestino
 lOk := .T.
 Case nStatus == 2
  nStatus := 1
  ::nOrigem:= 0
  lOk := .T.
 EndCase
 //-- Troca figura da posicao atual
 If lOk
  ::Change( ::oTPanel, nDestino, nStatus )
 EndIf
 EndIf
Return

//-- Realiza uma mudança de status de um elemento ( pedra ) do jogo 
Method Change( oTPanel, nItem, nStatus ) Class TResta1
 Local nIdImg := 0
 Local cCodigo := ""
 Local nX := 0
 Local nY := 0
 nIdImg := ::aShape[nItem,1]
 cCodigo := ::aShape[nItem,2]
 nX := ::aShape[nItem,3]
 nY := ::aShape[nItem,4]
 //-- Excluir shape com status anterior
 ::oTPanel:DeleteItem(nIdImg)
 //-- Recriar shape com status atual
 ::Create( ::oTPanel, nX, nY, cCodigo, nStatus, nItem, Str(nIdImg) )
Return

//-- CRia identificador sequencial para objetos
Method SetId() Class TResta1
Return cValToChar(++::nId)

//-- Exporta as imagens do RPO para o temporario %TEMP%
Method ExportImage() Class TResta1
 Local aImage := { "backg.png" , "empty.png" , "full.png" , "select.png" }
 Local nImage, cImageTo
 For nImage := 1 To Len(aImage)
  cImageTo := ::GetTempPath()+aImage[nImage]
  If !Resource2File(aImage[nImage],cImageTo)
   MsgStop("Image not found: " + aImage[nImage])
   QUIT
  EndIf
 Next nImage
Return

Method Help() Class TResta1
 MsgInfo( "Resta1 em ADVPL.","Bem Vindo!")
Return

Conclusão

Agradeço novamente a colaboração do Fávio Vicco, neste momento em que eu estou enfrentando um breve “bloqueio criativo” ..risos.. e desejo a todos TERABYTES DE SUCESSO !!!

Referências

https://github.com/siga0984/Resta1-OO
http://tdn.totvs.com/display/tec/TPaintPanel
https://pt.wikipedia.org/wiki/Resta_um

Web Services em AdvPL – Parte 02

Introdução

No tópico anterior sobre Web Services em AdvPL, foi apresentado um overview dos Web Services, e dois exemplos de código AdvPL para atuar como client de Web Services, utilizando um serviço publico na Internet para previsão do tempo.

Hoje, vamos criar um exemplo de um Web Service SERVER em AdvPL, que receberá como parâmetro uma estrutura complexa (ComplexType), e dentro dele um array de estruturas complexas. A idéia inicial era criar um exemplo completo de envio e retorno, mas o tópico ficaria muito grande, então optei por dividí-lo.

Web Service SERVER em AdvPL

Existe um tópico na TDN, que engloba todos os aspectos de criação de um Web Services SERVER em AdvPL, desde a configuração até o deploy de um serviço. Ele está disponível no link http://tdn.totvs.com/pages/viewpage.action?pageId=6064936 . O conteúdo do post atual no blog complementa algumas definições e parte para um exemplo onde é recomendável que você já tenha lido a TDN.

Resumindo em poucas linhas, um Web Service SERVER em AdvPL consiste na declaração de uma classe diferenciada (WSSERVICE), onde configuramos uma interface de publicação para Web Services no TOTVS Application Server, que a partir das classes WSSERVICE compiladas no RPO, consegue disponibilizar uma interface de chamada, consulta e testes via HTTP, bem como a definição (WSDL) da classe para que outras linguagens que trabalham nativamente com Web Services sejam capazes de gerar uma classe Client para consumir este Web Service.

Parâmetros e retornos

Na declaração de um Web Services SERVER em AdvPL, os parâmetros e retornos dos métodos devem ser declarados como propriedades da classe. O tipo destes parâmetros podem ser tipos simples ( http://tdn.totvs.com/pages/viewpage.action?pageId=6064941 ) ou tipos complexos ( http://tdn.totvs.com/display/tec/05.+Estruturas+-+Tipos+complexos ). Quando a quantidade de elementos de um parametro (simples ou compexo) for maior que 1, podemos declarar a propriedade como um ARRAY OF , onde o tipo pode ser simples ou complexo.

Na prática, um tipo complexo não passa de um agrupamento de um ou mais tipos simples ou complexos, como se fosse uma estrutura (classe sem métodos). Em um Web Service AdvPL, é possível declarar metodos para as estruturas, mas os métodos das estruturas não são publicados no WSDL, podem ser usados apenas dentro da classe de Web Service SERVER.

Projeto Web Services TORNEIOS

Vamos partir de um exemplo didático da criação de um WebServices para cadastrar um torneio esportivo. Os dados relevantes do torneio são as datas de inicio e final, uma descrição, e uma lista de atletas participantes. Cada atleta deve informar seu CPF, nome e data de nascimento. Opcionalmente, o atleta pode informar seu peso (em Kg) e altura (em metros).

Logo, precisamos de uma estrutura para os dados de um torneio e outra para os dados do atleta. Como um torneio pode ter vários atletas, a estrutura do atleta deve ser declarada como uma propriedade do tipo ARRAY OF ATLETA na estrutura de torneios. Vamos à primeira parte do código:

( Fonte WSSRV01.PRW )

#include "protheus.ch"
#include "apwebsrv.ch"
/* -------------------------------------------------------------
Fonte WSSRV01.PRW 
Autor Julio Wittwer
Data 10/06/2015
Descrição Fonte de exemplo de Web Services Server com 
 recebimento e retorno de tipos complexos 
 e array de tipos complexos
------------------------------------------------------------- */
// Estutura de dados de um atleta
// CPF, Nome, Aniversário ( obrigatorios ) 
// peso e altura ( opcionais )
WSSTRUCT ATLETA
 
 WSDATA CPF as STRING
 WSDATA Nome as STRING
 WSDATA Nascim as DATE 
 WSDATA PesoKg as FLOAT OPTIONAL
 WSDATA Altura as FLOAT OPTIONAL
ENDWSSTRUCT
// Estrutura de dados de um torneio 
// Descrição, data de inicio e término, e array de atletas participantes
WSSTRUCt TORNEIO
WSDATA Descricao as STRING
 WSDATA Inicio as DATE
 WSDATA Final as DATE 
 WSDATA Atletas as ARRAY OF ATLETA
 
ENDWSSTRUCT

Todas as propriedades declaradas nas estruturas (WSDATA) por default são obrigatórias. Para tornar uma propriedade opcional, usamos a palavra reservada “OPTIONAL” após o tipo da propriedade. Feita a declaração das estruturas, vamos agora para a prototipação da classe.

// Prototipação do WebServices
// Serviço de cadastro de torneios esportivos
WSSERVICE TORNEIOS DESCRIPTION "Torneios Esportivos"
 
 // propriedades de entrada e retorno, usados 
 // como parametros ou retornos nos metodos
 
 WSDATA TorneioIn AS TORNEIO 
 WSDATA Status as INTEGER 
 
 // Metodos do WebService
 WSMETHOD Incluir
ENDWSSERVICE

Por enquanto o WebService vai apenas receber os dados completos de um torneio. O foco do exemplo é justamente como os dados serão recebidos, e como você poderá enviá-los através de um Web Service client em AdvPL criado pela geração de classe client do TDS ou pela nova classe tWSDLManager. O exemplo não abrange a persistência das informações em base de dados. Agora, vamos implementar o método “Incluir” neste fonte:

// Metodo de inclusao. Recebe um Torneio com todos os dados 
// e o array de atletas, e retorna um status numerico ( 0 = sucesso )
WSMETHOD Incluir WSRECEIVE TorneioIn WSSEND Status WSSERVICE TORNEIOS 
 
// Vamos ver tudo o que chegou como parametro
// varinfo("TorneioIn",::TorneioIn) 
 
/*
TorneioIn -> OBJECT ( 4) [...]
 TorneioIn:ATLETAS -> ARRAY ( 2) [...]
 TorneioIn:ATLETAS[1] -> OBJECT ( 5) [...]
 TorneioIn:ATLETAS[1]:ALTURA -> U ( 1) [ ]
 TorneioIn:ATLETAS[1]:CPF -> C ( 12) [123456789-09]
 TorneioIn:ATLETAS[1]:NASCIM -> D ( 8) [02/02/81]
 TorneioIn:ATLETAS[1]:NOME -> C ( 13) [Joao da Silva]
 TorneioIn:ATLETAS[1]:PESOKG -> N ( 15) [ 72.5000]
 TorneioIn:ATLETAS[2] -> OBJECT ( 5) [...]
 TorneioIn:ATLETAS[2]:ALTURA -> U ( 1) [ ]
 TorneioIn:ATLETAS[2]:CPF -> C ( 12) [111111111-11]
 TorneioIn:ATLETAS[2]:NASCIM -> D ( 8) [03/03/80]
 TorneioIn:ATLETAS[2]:NOME -> C ( 13) [Jose da Silva]
 TorneioIn:ATLETAS[2]:PESOKG -> N ( 15) [ 75.2000]
 TorneioIn:DESCRICAO -> C ( 16) [Torneio de Teste]
 TorneioIn:FINAL -> D ( 8) [06/29/15]
 TorneioIn:INICIO -> D ( 8) [06/28/15]
*/
 
// com isso conseguimos montar facilmente o codigo AdvPl para tratar os dados 
// recebidos nesta propriedade. Logo abaixo, eu mostro na tela de console do 
// TOTVS App server a descricao do torneio recebida, e o nome dos atletas recebidos
conout("Torneio : "+TorneioIn:DESCRICAO)
conout("Atletas : "+cValToChar( len(TorneioIn:ATLETAS) ))
For nI := 1 to len(TorneioIn:ATLETAS)
 conout(TorneioIn:ATLETAS[nI]:Nome)
Next
// Caso o processamento seja concluido com sucesso, 
// alimentamos a propriedade de retorno com 0
// em caso de falha, podemos usar um ou mais numeros negativos para indicar
// uma impossibilidade de processamento, como um torneio na mesma data....
::Status := 0
Return .T.

Uma vez criado o fonte e compilado no RPO, e configurado adequadamente o APPServer para ser um servidor de HTTP para WEB Services (vide documentação da TDN), podemos partir para a geração do fonte client em AdvPL.

Exemplo gerando o fonte client de Web Services

Primeiro, vamos gerar um fonte client AdvPL usando o IDE ou TDS. Usando o endereço HTTP onde foi disponibilizado o WSDL deste serviço, o código fonte client gerado deve ficar assim:

( Fonte WSCLI01.PRW )

#INCLUDE "PROTHEUS.CH"
#INCLUDE "APWEBSRV.CH"
/* ===============================================================================
WSDL Location http://localhost/ws/TORNEIOS.apw?WSDL
Gerado em 06/28/15 15:31:26
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 _SSLXTLW ; Return // "dummy" function - Internal Use
/* -------------------------------------------------------------------------------
WSDL Service WSTORNEIOS
------------------------------------------------------------------------------- */
WSCLIENT WSTORNEIOS
WSMETHOD NEW
 WSMETHOD INIT
 WSMETHOD RESET
 WSMETHOD CLONE
 WSMETHOD INCLUIR
WSDATA _URL AS String
 WSDATA _HEADOUT AS Array of String
 WSDATA _COOKIES AS Array of String
 WSDATA oWSTORNEIOIN AS TORNEIOS_TORNEIO
 WSDATA nINCLUIRRESULT AS integer
// Estruturas mantidas por compatibilidade - NÃO USAR
 WSDATA oWSTORNEIO AS TORNEIOS_TORNEIO
ENDWSCLIENT
WSMETHOD NEW WSCLIENT WSTORNEIOS
::Init()
If !FindFunction("XMLCHILDEX")
 UserException("O Código-Fonte Client atual requer os executáveis do Protheus Build [7.00.131227A-20150620] ou superior. Atualize o Protheus ou gere o Código-Fonte novamente utilizando o Build atual.")
EndIf
Return Self
WSMETHOD INIT WSCLIENT WSTORNEIOS
 ::oWSTORNEIOIN := TORNEIOS_TORNEIO():New()
// Estruturas mantidas por compatibilidade - NÃO USAR
 ::oWSTORNEIO := ::oWSTORNEIOIN
Return
WSMETHOD RESET WSCLIENT WSTORNEIOS
 ::oWSTORNEIOIN := NIL 
 ::nINCLUIRRESULT := NIL
// Estruturas mantidas por compatibilidade - NÃO USAR
 ::oWSTORNEIO := NIL
 ::Init()
Return
WSMETHOD CLONE WSCLIENT WSTORNEIOS
Local oClone := WSTORNEIOS():New()
 oClone:_URL := ::_URL 
 oClone:oWSTORNEIOIN := IIF(::oWSTORNEIOIN = NIL , NIL ,::oWSTORNEIOIN:Clone() )
 oClone:nINCLUIRRESULT := ::nINCLUIRRESULT
// Estruturas mantidas por compatibilidade - NÃO USAR
 oClone:oWSTORNEIO := oClone:oWSTORNEIOIN
Return oClone
// WSDL Method INCLUIR of Service WSTORNEIOS
WSMETHOD INCLUIR WSSEND oWSTORNEIOIN WSRECEIVE nINCLUIRRESULT WSCLIENT WSTORNEIOS
Local cSoap := "" , oXmlRet
BEGIN WSMETHOD
cSoap += 'xmlns="http://localhost/">'
cSoap += WSSoapValue("TORNEIOIN", ::oWSTORNEIOIN, oWSTORNEIOIN , "TORNEIO", .T. , .F., 0 , NIL, .F.) 
cSoap += "</INCLUIR>"
oXmlRet := SvcSoapCall( Self,cSoap,; 
 "http://localhost/INCLUIR",; 
 "DOCUMENT","http://localhost/",,"1.031217",; 
 "http://localhost/ws/TORNEIOS.apw")
::Init()
::nINCLUIRRESULT := WSAdvValue( oXmlRet,"_INCLUIRRESPONSE:_INCLUIRRESULT:TEXT","integer",NIL,NIL,NIL,NIL,NIL,NIL)
END WSMETHOD
oXmlRet := NIL
Return .T.
// WSDL Data Structure TORNEIO
WSSTRUCT TORNEIOS_TORNEIO
 WSDATA oWSATLETAS AS TORNEIOS_ARRAYOFATLETA
 WSDATA cDESCRICAO AS string
 WSDATA dFINAL AS date
 WSDATA dINICIO AS date
 WSMETHOD NEW
 WSMETHOD INIT
 WSMETHOD CLONE
 WSMETHOD SOAPSEND
 WSMETHOD SOAPRECV
ENDWSSTRUCT
WSMETHOD NEW WSCLIENT TORNEIOS_TORNEIO
 ::Init()
Return Self
WSMETHOD INIT WSCLIENT TORNEIOS_TORNEIO
Return
WSMETHOD CLONE WSCLIENT TORNEIOS_TORNEIO
 Local oClone := TORNEIOS_TORNEIO():NEW()
 oClone:oWSATLETAS := IIF(::oWSATLETAS = NIL , NIL , ::oWSATLETAS:Clone() )
 oClone:cDESCRICAO := ::cDESCRICAO
 oClone:dFINAL := ::dFINAL
 oClone:dINICIO := ::dINICIO
Return oClone
WSMETHOD SOAPSEND WSCLIENT TORNEIOS_TORNEIO
 Local cSoap := ""
 cSoap += WSSoapValue("ATLETAS", ::oWSATLETAS, ::oWSATLETAS , "ARRAYOFATLETA", .T. , .F., 0 , NIL, .F.) 
 cSoap += WSSoapValue("DESCRICAO", ::cDESCRICAO, ::cDESCRICAO , "string", .T. , .F., 0 , NIL, .F.) 
 cSoap += WSSoapValue("FINAL", ::dFINAL, ::dFINAL , "date", .T. , .F., 0 , NIL, .F.) 
 cSoap += WSSoapValue("INICIO", ::dINICIO, ::dINICIO , "date", .T. , .F., 0 , NIL, .F.) 
Return cSoap
WSMETHOD SOAPRECV WSSEND oResponse WSCLIENT TORNEIOS_TORNEIO
 Local oNode1
 ::Init()
 If oResponse = NIL ; Return ; Endif 
 oNode1 := WSAdvValue( oResponse,"_ATLETAS","ARRAYOFATLETA",NIL,"Property oWSATLETAS as s0:ARRAYOFATLETA on SOAP Response not found.",NIL,"O",NIL,NIL) 
 If oNode1 != NIL
 ::oWSATLETAS := TORNEIOS_ARRAYOFATLETA():New()
 ::oWSATLETAS:SoapRecv(oNode1)
 EndIf
 ::cDESCRICAO := WSAdvValue( oResponse,"_DESCRICAO","string",NIL,"Property cDESCRICAO as s:string on SOAP Response not found.",NIL,"S",NIL,NIL) 
 ::dFINAL := WSAdvValue( oResponse,"_FINAL","date",NIL,"Property dFINAL as s:date on SOAP Response not found.",NIL,"D",NIL,NIL) 
 ::dINICIO := WSAdvValue( oResponse,"_INICIO","date",NIL,"Property dINICIO as s:date on SOAP Response not found.",NIL,"D",NIL,NIL) 
Return
// WSDL Data Structure ARRAYOFATLETA
WSSTRUCT TORNEIOS_ARRAYOFATLETA
 WSDATA oWSATLETA AS TORNEIOS_ATLETA OPTIONAL
 WSMETHOD NEW
 WSMETHOD INIT
 WSMETHOD CLONE
 WSMETHOD SOAPSEND
 WSMETHOD SOAPRECV
ENDWSSTRUCT
WSMETHOD NEW WSCLIENT TORNEIOS_ARRAYOFATLETA
 ::Init()
Return Self
WSMETHOD INIT WSCLIENT TORNEIOS_ARRAYOFATLETA
 ::oWSATLETA := {} // Array Of TORNEIOS_ATLETA():New()
Return
WSMETHOD CLONE WSCLIENT TORNEIOS_ARRAYOFATLETA
 Local oClone := TORNEIOS_ARRAYOFATLETA():NEW()
 oClone:oWSATLETA := NIL
 If ::oWSATLETA <> NIL 
 oClone:oWSATLETA := {}
 aEval( ::oWSATLETA , { |x| aadd( oClone:oWSATLETA , x:Clone() ) } )
 Endif 
Return oClone
WSMETHOD SOAPSEND WSCLIENT TORNEIOS_ARRAYOFATLETA
 Local cSoap := ""
 aEval( ::oWSATLETA , {|x| cSoap := cSoap + WSSoapValue("ATLETA", x , x , "ATLETA", .F. , .F., 0 , NIL, .F.) } ) 
Return cSoap
WSMETHOD SOAPRECV WSSEND oResponse WSCLIENT TORNEIOS_ARRAYOFATLETA
 Local nRElem1, oNodes1, nTElem1
 ::Init()
 If oResponse = NIL ; Return ; Endif 
 oNodes1 := WSAdvValue( oResponse,"_ATLETA","ATLETA",{},NIL,.T.,"O",NIL,NIL) 
 nTElem1 := len(oNodes1)
 For nRElem1 := 1 to nTElem1 
 If !WSIsNilNode( oNodes1[nRElem1] )
 aadd(::oWSATLETA , TORNEIOS_ATLETA():New() )
 ::oWSATLETA[len(::oWSATLETA)]:SoapRecv(oNodes1[nRElem1])
 Endif
 Next
Return
// WSDL Data Structure ATLETA
WSSTRUCT TORNEIOS_ATLETA
 WSDATA nALTURA AS float OPTIONAL
 WSDATA cCPF AS string
 WSDATA dNASCIM AS date
 WSDATA cNOME AS string
 WSDATA nPESOKG AS float OPTIONAL
 WSMETHOD NEW
 WSMETHOD INIT
 WSMETHOD CLONE
 WSMETHOD SOAPSEND
 WSMETHOD SOAPRECV
ENDWSSTRUCT
WSMETHOD NEW WSCLIENT TORNEIOS_ATLETA
 ::Init()
Return Self
WSMETHOD INIT WSCLIENT TORNEIOS_ATLETA
Return
WSMETHOD CLONE WSCLIENT TORNEIOS_ATLETA
 Local oClone := TORNEIOS_ATLETA():NEW()
 oClone:nALTURA := ::nALTURA
 oClone:cCPF := ::cCPF
 oClone:dNASCIM := ::dNASCIM
 oClone:cNOME := ::cNOME
 oClone:nPESOKG := ::nPESOKG
Return oClone
WSMETHOD SOAPSEND WSCLIENT TORNEIOS_ATLETA
 Local cSoap := ""
 cSoap += WSSoapValue("ALTURA", ::nALTURA, ::nALTURA , "float", .F. , .F., 0 , NIL, .F.) 
 cSoap += WSSoapValue("CPF", ::cCPF, ::cCPF , "string", .T. , .F., 0 , NIL, .F.) 
 cSoap += WSSoapValue("NASCIM", ::dNASCIM, ::dNASCIM , "date", .T. , .F., 0 , NIL, .F.) 
 cSoap += WSSoapValue("NOME", ::cNOME, ::cNOME , "string", .T. , .F., 0 , NIL, .F.) 
 cSoap += WSSoapValue("PESOKG", ::nPESOKG, ::nPESOKG , "float", .F. , .F., 0 , NIL, .F.) 
Return cSoap
WSMETHOD SOAPRECV WSSEND oResponse WSCLIENT TORNEIOS_ATLETA
 ::Init()
 If oResponse = NIL ; Return ; Endif 
 ::nALTURA := WSAdvValue( oResponse,"_ALTURA","float",NIL,NIL,NIL,"N",NIL,NIL) 
 ::cCPF := WSAdvValue( oResponse,"_CPF","string",NIL,"Property cCPF as s:string on SOAP Response not found.",NIL,"S",NIL,NIL) 
 ::dNASCIM := WSAdvValue( oResponse,"_NASCIM","date",NIL,"Property dNASCIM as s:date on SOAP Response not found.",NIL,"D",NIL,NIL) 
 ::cNOME := WSAdvValue( oResponse,"_NOME","string",NIL,"Property cNOME as s:string on SOAP Response not found.",NIL,"S",NIL,NIL) 
 ::nPESOKG := WSAdvValue( oResponse,"_PESOKG","float",NIL,NIL,NIL,"N",NIL,NIL) 
Return

Agora, podemos montar um novo fonte ( WSTST01.PRW ), que vai usar a classe client gerada no AdvPL para interagir com este serviço. No fonte abaixo, todos os detalhes da implementação e o passo a passo utilizado para entender como usar as estruturas e métodos definidos na classe client do Web Service.

#include "protheus.ch"
/* ===========================================================================
Fonte WSTST01.PRW
Funcoes U_TST01I()
Autor Julio Wittwer
Data 10/06/2015
Descricao Fonte de testes da classe client do WebService "TORNEIOS" em AddPl
=========================================================================== */
User Function Tst01I()
Local oWSClient 
Local oAtleta
SET DATE BRITISH
SET CENTURY ON 
SET EPOCH TO 1960
 
// Cria a instância da classe Client do WebService de Torneios
oWSClient := WSTORNEIOS():New()
/*
Vamos chamar a inclusao de torneios. para isso, primeiro vemos qual foi o metodo 
de inclusao gerado na classe client Advpl
WSMETHOD INCLUIR WSSEND oWSTORNEIOIN WSRECEIVE nINCLUIRRESULT WSCLIENT WSTORNEIOS
*/
// o parametro oWSTorneioIn é uma estrutura nomeada de TORNEIOS_TORNEIO
// Como esta estrutura é um parâmetro de um método, ela já vem 
// criada, mas seus valores nao estao preenchidos 
// vamos preencher as propriedades desta estrutura
// consultamos as propriedades da estrutura no fonte Client Advpl gerado
/*
WSSTRUCT TORNEIOS_TORNEIO
 WSDATA oWSATLETAS AS TORNEIOS_ARRAYOFATLETA
 WSDATA cDESCRICAO AS string
 WSDATA dFINAL AS date
 WSDATA dINICIO AS date
(...)
*/
oWSClient:oWSTORNEIOIN:cDESCRICAO := 'Torneio de Teste'
oWSClient:oWSTORNEIOIN:dInicio := date()+1
oWSClient:oWSTORNEIOIN:dFinal := date()+2
// Dentro da estrutura de torneio, temos tambem a propriedade oWSAtletas
// Como ela nao vem criada, vamos criar uma instância dela
oWSClient:oWSTORNEIOIN:oWSATLETAS := TORNEIOS_ARRAYOFATLETA():New()
// Como a estrutura é um encapsulamento de array de objetos, 
// a propriedade oWSATLETA desta estrutura vem com {} um array vazio 
// ::oWSATLETA := {} // Array Of TORNEIOS_ATLETA():New()
// Para cada atleta a acrescentar, criamos uma nova instancia da estrutura 
// TORNEIOS_ATLETA . Devemos ver a declaração da estrutura para saber 
// quais propriedades devem ser preenchidas
 
/*
WSSTRUCT TORNEIOS_ATLETA
 WSDATA nALTURA AS float OPTIONAL
 WSDATA cCPF AS string
 WSDATA dNASCIM AS date
 WSDATA cNOME AS string
 WSDATA nPESOKG AS float OPTIONAL
(...)
*/
oAtleta := TORNEIOS_ATLETA():New()
oAtleta:cNome := "Joao da Silva"
oAtleta:cCPF := "123456789-09"
oAtleta:dNASCIM := ctod('02/02/1981')
oAtleta:nPESOKG := 72.5
// agora acrescentamos o atleta da propriedade correta
aadd( oWSClient:oWSTORNEIOIN:oWSATLETAS:oWSATLETA , oAtleta ) 
 
// Criamos um novo atleta
oAtleta := TORNEIOS_ATLETA():New()
oAtleta:cNome := "Jose da Silva"
oAtleta:cCPF := "111111111-11"
oAtleta:dNASCIM := ctod('03/03/1980')
oAtleta:nPESOKG := 75.2
// agora acrescentamos o segundo atleta da propriedade correta
aadd( oWSClient:oWSTORNEIOIN:oWSATLETAS:oWSATLETA , oAtleta )
// vamos ver como ficou a estrutura 
// varinfo("oWSClient:oWSTORNEIOIN",oWSClient:oWSTORNEIOIN)
// agora vamos chamar o metodo de inclusao
If oWSClient:Incluir() 
 
 // Chamada realizada com sucesso. 
 // Vamos ver o que chegou na propriedade de retorno
 msgInfo("Codigo de retorno = "+cValToChar(oWSClient:nINCLUIRRESULT),"Chamada realizada.")
Else
// houve algum erro na chamada
 // ou no processamento do webservice 
 MsgStop(getwscerror(3))
Endif
Return

A função de testes de inclusão ( U_TST01I ) pode ser chamada diretamente pelo SmartClient, não precisa colocar ela dentro do Menu do ERP. Os dados utilizados para os atletas estão “chumbados” no fonte. Ao ser executado, o Web Services SERVER deve receber e aceitar o XML enviado por HTTP, e mostrar no LOG de console a descrição do torneio e o nome dos dois atletas informados.

Exemplo usando tWSDLManager

Agora sim, vamos ver como é possível usar a casse nova de Web Services para informar estruturas complexas, e arrays de estruturas complexas.

A classe tWSDLManager permite mapear, a partir do WSDL, as estruturas complexas e tipos simples que precisam ser enviados para uma requisição de WebServices. Como um tipo complexo na verdade é um agrupamento de tipos simples, ao usar o método SimpleInput(), vamos obter um array contendo os identificadores de todos os dados que podem ser enviados, porem a classe considera por default que voce vai enviar apenas uma ocorrencia de um dado ou estrutura. Como nós sabemos que vamos inserir mais de um valor, precisamos dizer para a classe quantos valores serão informados, e somente com estes valores definidos podemos usar o método SimpleInput() para ver como e onde os dados serão informados. Toda a sequencia de identificação está documentada no proprio fonte, em linhas de comentário.

#include "protheus.ch"
/* ===========================================================================
Fonte WSTST02.PRW
Funcoes U_TST02I()
Autor Julio Wittwer
Data 28/06/2015
Descricao Fonte de testes do webService de Torneios, usando a nova classe
 client de websservices "tWSDLManager"
http://tdn.totvs.com/display/tec/Classe+TWsdlManager
=========================================================================== */
User Function TST02I()
Local oWSDL
Local lOk, cResp, aElem, nPos
oWSDL := tWSDLManager():New()
// Seta o modo de trabalho da classe para "verbose"
// apenas para fins de desenvolvimento e depuracao
// oWSDL:lVerbose := .T.
// Primeiro faz o parser do WSDL a partir da URL
lOk := oWsdl:ParseURL( "http://localhost/ws/TORNEIOS.apw?WSDL" )
if !lOk
 MsgStop( oWsdl:cError , "ParseURL() ERROR")
 Return
endif
// Lista as operações disponíveis
// aOps := oWsdl:ListOperations()
// varinfo( "aOps", aOps )
/*
aOps -> ARRAY ( 1) [...]
aOps[1] -> ARRAY ( 2) [...]
aOps[1][1] -> C ( 7) [INCLUIR]
aOps[1][2] -> C ( 0) []
*/
// Seta a operação a ser utilizada
lOk := oWsdl:SetOperation( "INCLUIR" )
if !lOk
 MsgStop( oWsdl:cError , "SetOperation(INCLUIR) ERROR")
 Return
endif
// Agora vamos ver os parametros de chamada da inclusao
// primeiro, devemos verificar os complex types de
// tamanho variavel.
// aParC := oWsdl:ComplexInput()
// varinfo("aParC",aParC)
/*
aParC -> ARRAY ( 1) [...]
aParC[1] -> ARRAY ( 5) [...]
aParC[1][1] -> N ( 15) [ 3.0000] // ID da estrutura complexa variavel
aParC[1][2] -> C ( 6) [ATLETA]
aParC[1][3] -> N ( 15) [ 0.0000] // numero minimo de ocorrencias
aParC[1][4] -> N ( 15) [2147483647.0000] // numero maximo de ocorrencias
aParC[1][5] -> C ( 31) [INCLUIR#1.TORNEIOIN#1.ATLETAS#1] // lista de elementos "pai" desta estrutura
*/
// Como sabemos que vamos enviar 2 atletas,
// definimos esta quantidade usando o metodo SetComplexOccurs
oWSDL:SetComplexOccurs(3,2) // Id do complex type, quantidade a ser enviada
// Apenas depois de definirmos quantos tipos complexos queremos enviar,
// podemos listar os tipos simples.
// aParS := oWsdl:SimpleInput()
// varinfo("aParS",aParS)
/*
aParS -> ARRAY ( 13) [...]
aParS[1] -> ARRAY ( 5) [...]
aParS[1][1] -> N ( 15) [ 0.0000]
aParS[1][2] -> C ( 6) [ALTURA]
aParS[1][3] -> N ( 15) [ 0.0000]
aParS[1][4] -> N ( 15) [ 1.0000]
aParS[1][5] -> C ( 40) [INCLUIR#1.TORNEIOIN#1.ATLETAS#1.ATLETA#1]
aParS[2] -> ARRAY ( 5) [...]
aParS[2][1] -> N ( 15) [ 1.0000]
aParS[2][2] -> C ( 3) [CPF]
aParS[2][3] -> N ( 15) [ 1.0000]
aParS[2][4] -> N ( 15) [ 1.0000]
aParS[2][5] -> C ( 40) [INCLUIR#1.TORNEIOIN#1.ATLETAS#1.ATLETA#1]
aParS[3] -> ARRAY ( 5) [...]
aParS[3][1] -> N ( 15) [ 2.0000]
aParS[3][2] -> C ( 6) [NASCIM]
aParS[3][3] -> N ( 15) [ 1.0000]
aParS[3][4] -> N ( 15) [ 1.0000]
aParS[3][5] -> C ( 40) [INCLUIR#1.TORNEIOIN#1.ATLETAS#1.ATLETA#1]
aParS[4] -> ARRAY ( 5) [...]
aParS[4][1] -> N ( 15) [ 3.0000]
aParS[4][2] -> C ( 4) [NOME]
aParS[4][3] -> N ( 15) [ 1.0000]
aParS[4][4] -> N ( 15) [ 1.0000]
aParS[4][5] -> C ( 40) [INCLUIR#1.TORNEIOIN#1.ATLETAS#1.ATLETA#1]
aParS[5] -> ARRAY ( 5) [...]
aParS[5][1] -> N ( 15) [ 4.0000]
aParS[5][2] -> C ( 6) [PESOKG]
aParS[5][3] -> N ( 15) [ 0.0000]
aParS[5][4] -> N ( 15) [ 1.0000]
aParS[5][5] -> C ( 40) [INCLUIR#1.TORNEIOIN#1.ATLETAS#1.ATLETA#1]
aParS[6] -> ARRAY ( 5) [...]
aParS[6][1] -> N ( 15) [ 5.0000]
aParS[6][2] -> C ( 6) [ALTURA]
aParS[6][3] -> N ( 15) [ 0.0000]
aParS[6][4] -> N ( 15) [ 1.0000]
aParS[6][5] -> C ( 40) [INCLUIR#1.TORNEIOIN#1.ATLETAS#1.ATLETA#2]
aParS[7] -> ARRAY ( 5) [...]
aParS[7][1] -> N ( 15) [ 6.0000]
aParS[7][2] -> C ( 3) [CPF]
aParS[7][3] -> N ( 15) [ 1.0000]
aParS[7][4] -> N ( 15) [ 1.0000]
aParS[7][5] -> C ( 40) [INCLUIR#1.TORNEIOIN#1.ATLETAS#1.ATLETA#2]
aParS[8] -> ARRAY ( 5) [...]
aParS[8][1] -> N ( 15) [ 7.0000]
aParS[8][2] -> C ( 6) [NASCIM]
aParS[8][3] -> N ( 15) [ 1.0000]
aParS[8][4] -> N ( 15) [ 1.0000]
aParS[8][5] -> C ( 40) [INCLUIR#1.TORNEIOIN#1.ATLETAS#1.ATLETA#2]
aParS[9] -> ARRAY ( 5) [...]
aParS[9][1] -> N ( 15) [ 8.0000]
aParS[9][2] -> C ( 4) [NOME]
aParS[9][3] -> N ( 15) [ 1.0000]
aParS[9][4] -> N ( 15) [ 1.0000]
aParS[9][5] -> C ( 40) [INCLUIR#1.TORNEIOIN#1.ATLETAS#1.ATLETA#2]
aParS[10] -> ARRAY ( 5) [...]
aParS[10][1] -> N ( 15) [ 9.0000]
aParS[10][2] -> C ( 6) [PESOKG]
aParS[10][3] -> N ( 15) [ 0.0000]
aParS[10][4] -> N ( 15) [ 1.0000]
aParS[10][5] -> C ( 40) [INCLUIR#1.TORNEIOIN#1.ATLETAS#1.ATLETA#2]
aParS[11] -> ARRAY ( 5) [...]
aParS[11][1] -> N ( 15) [ 10.0000]
aParS[11][2] -> C ( 9) [DESCRICAO]
aParS[11][3] -> N ( 15) [ 1.0000]
aParS[11][4] -> N ( 15) [ 1.0000]
aParS[11][5] -> C ( 21) [INCLUIR#1.TORNEIOIN#1]
aParS[12] -> ARRAY ( 5) [...]
aParS[12][1] -> N ( 15) [ 11.0000]
aParS[12][2] -> C ( 5) [FINAL]
aParS[12][3] -> N ( 15) [ 1.0000]
aParS[12][4] -> N ( 15) [ 1.0000]
aParS[12][5] -> C ( 21) [INCLUIR#1.TORNEIOIN#1]
aParS[13] -> ARRAY ( 5) [...]
aParS[13][1] -> N ( 15) [ 12.0000]
aParS[13][2] -> C ( 6) [INICIO]
aParS[13][3] -> N ( 15) [ 1.0000]
aParS[13][4] -> N ( 15) [ 1.0000]
aParS[13][5] -> C ( 21) [INCLUIR#1.TORNEIOIN#1]
*/
// Analisando o array acima, vemos que os parametros de primeiro nivel
// sao INICIO, FINAL e DESCRICAO. Logo, podemos alimentar estes valores
// diretamente, inclusive pelo nome. Porem precisamos informar tambem o array contendo 
// a sequencia de elementos "pai" de cada valor. Na pratica, pasta pegar a 
// lista de elementos pai identificada no 5o elemento do array de simpleInput
// e criar um array com ele.
lOk := oWsdl:SetValPar("DESCRICAO",{"INCLUIR#1","TORNEIOIN#1"}, "Torneio de Testes")
if !lOk
 MsgStop( oWsdl:cError , procline())
 Return
endif
lOk := oWsdl:SetValPar("INICIO",{"INCLUIR#1","TORNEIOIN#1"}, '20150701')
if !lOk
 MsgStop( oWsdl:cError , procline())
 Return
endif
lOk := oWsdl:SetValPar("FINAL",{"INCLUIR#1","TORNEIOIN#1"}, '20150702')
if !lOk
 MsgStop( oWsdl:cError , procline())
 Return
endif
// Podemos ver tambem que o array de tipos simples foi criado para 2 atletas
// e agora temos IDs para cada um deles. Isto somente aconteceu pois 
// usamos o metodo SetComplexOccurs(). Caso nao tivessemos utilizado 
// este metodo, o array de estruturas simples viria apenas com os 
// identificadores para inserir um altleta.
// Para definir os tipos complexos, uma vez que seus valores
// já estão enumerados na lista de tipos simples, podemos fazer assim :
aParent := {"INCLUIR#1","TORNEIOIN#1","ATLETAS#1","ATLETA#1"}
oWsdl:SetValPar("NOME",aParent,"Romualdo da Silva")
oWsdl:SetValPar("CPF",aParent,"123456789-01")
oWsdl:SetValPar("NASCIM",aParent,"1974-05-08")
oWsdl:SetValPar("PESOKG",aParent,"77,5")
oWsdl:SetValPar("ALTURA",aParent,"1,85")
// Como os atletas são inseridos em sequencia, basta informarmos
// a que alteta a informação se destina, variando o ultimo
// elemento do array dos "pais" de cada informação.
aParent := {"INCLUIR#1","TORNEIOIN#1","ATLETAS#1","ATLETA#2"}
oWsdl:SetValPar("NOME",aParent,"Sinfronio da Silva")
oWsdl:SetValPar("CPF",aParent,"555555555-55")
oWsdl:SetValPar("NASCIM",aParent,"1976-03-12")
oWsdl:SetValPar("PESOKG",aParent,"66,5")
oWsdl:SetValPar("ALTURA",aParent,"1,65")
// Agora executamos a requisição ao WebService
lOk := oWsdl:SendSoapMsg()
if !lOk
 MsgStop( oWsdl:cError , "SendSoapMsg() ERROR")
 Return
endif
// mostra no console o XML Soap devolvido
conout( "--- SOAP RESPONSE ---" , oWsdl:GetSoapResponse() , "-------------------")
// Recupera os elementos de retorno, já parseados
cResp := oWsdl:GetParsedResponse()
/*
Como o retorno é apenas um numero, podemos obtelo diretamente 
parseando a string retornada em cResp
*/
varinfo("cResp",cResp)
Return

Conclusão

A classe tWSDLManager tem uma sequência de operações que precisa ser realizada antes de começar a alimentar as propriedades de envio de dados. Caso existam mais informações que possuem quantidades variáveis, é necessário definir a quantidade de cada uma delas antes de começar a popular os valores para realizar a requisição / chamada do WebService.

Para o próximo post sobre Web Services, eu vou pegar este exemplo didático, e fazer um método de consulta, onde o retorno do Web SErvices server vai ser as informações de um torneio. Esta etapa de tratamento de retorno de tipos complexos é muito simples usando a geração do fonte client em AdvPL, mas é um pouco mais complicada quando usamos a classe tWSDLManager(), e realmente tudo isso de uma vez dentro de apenas uma postagem, ficaria muito grande !

Até a próxima pessoal, e bons Web Services 😀

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 😉

Classes em Advpl – Parte 04

E, para finalizar a a introdução do tópico “Classes em Advpl”, hoje vamos abordar algumas boas práticas da orientação a objeto, com foco no uso com ADVPL.

Simplicidade

A correta representação do domínio do problema deve ser simples, mesmo para um problema complexo. Por exemplo, fazer um jogo de damas ou xadrez no computador pode parecer algo muito complexo, certo ? Com apenas uma classe de tabuleiro, uma classe de jogador, uma classe base (ou abstrata) para uma peça genérica, e uma classe para cada peça do tabuleiro, onde a instância de tabuleiro é responsável por fazer a interface com o usuário e permitir ele mover uma peça de um lugar de origem para um lugar de destino, eu garanto que fica mais simples. A interface recebe o input do jogador, e aciona o método de mover peça do tabuleiro, que verifica se tem uma peça na posição de origem, e chama um método da peça para listar as posições válidas para onde a peça pode ser movida. Cada objeto tem a sua camada de inteligência (métodos) e validações.

A implementação feita desta forma fica isolada em cada peça, afinal você precisa escrever apenas um método para cada peça para determinar as posições possiveis de movimento a partir do tabuleiro em um determinado estado, onde um metodo do tabuleiro se encarrega de varrer a lista de peças em jogo de um dos jogadores e perguntar para cada uma para onde ela pode mover-se. Com isso é mais fácil implementar a mecânica dos movimentos das peças, e até um mecanismo de projeção de movimentos possíveis do adversário.

Nível de abstração e herança adequadas

Quanto maior o detalhamento que você precisa, maior será a quantidade de classes e propriedades necessárias para lhe atender. Atenha-se ao que você precisa, e de forma ordenada. Por exemplo, ao prototipar três classes, A , B, e C, onde B e C herdam A, na classe superior (A) você deve colocar propriedades que são comuns a todas as classes da herança, e nas classes filhas apenas as propriedades e métodos específicos que somente caberiam na instância da classe filha, permanecendo os métodos comuns na classe pai. Muitas vezes implementamos uma herança sem ter propriedades específicas, mas implementações de métodos com comportamentos diferenciados por instância.

Destrutores e limpeza de memória

Uma instância de uma classe na linguagem ADVPL não possui declaração explícita de métodos destrutores, porém o kernel do ADVPL realiza um controle de reaproveitamento de memória da instância da classe, e mantém a instância na memória, mesmo que ela não seja mais referenciável, apenas eliminando a memória consumida pela instância quando a função que cria a instância da classe é chamado e cria uma nova instância. A memória ocupada pela instância envolve todas as propriedades da instância.

Logo, é elegante e saudável para a memória você criar um método “CleanUp” na classe para limpar as propriedades que não estão sendo mais referenciadas desta instância, uma vez que a mesma não seja mais necessária, e após chamar o CleanUp() da instância, você executa a função FreeObj(), passando a variável que contém a instância como parâmetro.

Se você executar um FreeObj() em uma instância de classe ADVPL, mas ela ainda estava sendo referenciada em uma ou mais varíaveis ou propriedades de outras classes, automaticamente estas referências tornam-se nulas (NIL). Caso algum programa tente acessá-las, será gerada uma ocorrência de erro “Variable is not an object”.

A função FreeObj() também serve para eliminar uma classe da interface visual do Advpl. Neste caso, muito cuidado com o seu uso, pois se você por exemplo executar um FreeObj() em uma instância de tWindow, tDialog, tPanel, ou qualquer instância de container de interface, que está ativa na tela e na pilha de execuções, você pode provocar uma invasão de memória ( Access Violation ou Segment Fault ).

A dica de limpeza vale também para funções em Advpl, onde as variáveis locais daquela execução permanecem alocadas na memória, somente sendo desalocadas em uma próxima execução da função. Por exemplo, uma função de processamento intermediário cria um array local dentro do fonte, e popula este array para fazer um cálculo. Se o retorno desta função não for o próprio array, o conteúdo alocado na memória pelos elementos não será necessário e nem acessível quando a função retornar o valor calculado, mas a área de memória ocupada vai permanecer alocada. Neste caso, você deve limpar o array, usando a função de redimensionamento de array da seguinte forma: aSize(aVarArray,0) — onde aVarArray é a variável que contém o array a ser limpo.

Caso as propriedades da classe apontem para arrays de outros objetos, que estão compartilhados com outros componentes e não exatamente devem ser destruídos, é interessante e elegante que você atribua NIL nestas propriedades, para elas deixarem de referenciar os arrays e objetos em questão.

Performance

Existe um overhead na performance na chamada de um método, em comparação com a chamada de uma função. Fiz um teste de performance de chamadas de uma função e de um método de classe, onde a função e a classe realizam um processamento – o retorno de um valor constante. O loop de processamento demorou em média 1,5 segundos para chamar um milhão de vezes uma função, e demorou 3,8 segundos para chamar um milhão de vezes um método. Parece uma grande diferença, certo ? Bem, estamos falando aqui de 666 mil RPS(requisições por segundo) de função, contra 263 mil RPS em chamadas de método, usando uma CPU de 1.8 GHZ.

Lembre-se da Lei de Amdahl, já mencionada aqui em outra postagem sobre escalabilidade e performance: “O ganho de desempenho que pode ser obtido melhorando uma determinada parte do sistema é limitado pela fração de tempo que essa parte é utilizada pelo sistema durante a sua operação.” Logo, a relevância do tempo em uma etapa específica de um processo somente é perceptível caso ela seja representativa no tempo total do processo.

Por exemplo, em uma rotina de processamento onde os métodos realizam tarefas, decisões e manipulações de dados e propriedades, e podem acessar banco de dados ou informações no disco, o tempo de processamento do método vai ser muito maior do que o tempo da chamada. Ao calcularmos o tempo total de processamento de 1 milhão de requisições de um determinado método, onde cada requisição demora em média 1/10 de segundo, serão 166 minutos (duas horas e 46 minutos) de processamento, mais quatro segundos do tempo gasto com as chamadas dos métodos. Se este loop fosse feito com chamadas de função, acrescentaríamos ao tempo total apenas 1,5 segundo. Esta diferença de tempo, em um processo de 166 minutos, não quer dizer nada.

Este overhead somente torna-se significativo quando os métodos são extremamente curtos, como por exemplo operações aritméticas ou apenas encapsulamento para retorno de propriedades. E mesmo assim, são necessárias milhões de requisições para isso tornar-se perceptível.

Conclusão

A orientação a objetos é um paradigma muito interessante de ser explorado, mas como toda a solução em tecnologia da informação, existem casos onde uma abordagem com funções pode ser mais interessante, até mesmo dentro do mesmo aplicativo. Prevalece sempre a análise de caso, use um paradigma ou abordagem para resolver os problemas onde ela apresenta a melhor relação custo x benefício.

Posteriormente eu devo voltar no tema de orientação a objetos, focando mais em exemplos práticos e casos de uso em ADVPL.

Até o próximo post, pessoal 😉

Classes em Advpl – Parte 03

No tópico anterior, vimos um exemplo de uma classe ADVPL herdando outra classe em ADVPL. Vimos também que a herança não pode ser múltipla, isto é, uma classe não pode herdar mais de uma classe pai ao mesmo tempo, e vimos também que é possível herdar uma classe que já possua herança. Agora, vamos criar uma classe ADVPL que herda uma classe básica da linguagem. Vamos criar uma classe de botão diferenciada, herdando a classe básica de botão do ADVPL (tButton).

Desta vez sem muita teoria, os dois tópicos anteriores já cuidaram dessa parte ! Agora, as explicações ficam pro final do tópico, vamos ao código: Crie um fonte novo (extensão .PRW), copie, cole, salve, compile e execute U_APTST03 através do Smartclient.

// --------------------------------------------------
// Fonte de teste da classe APBUTTON herdando tButton
User Function APPTST03() 
Local oDlg , oBtn1, oBtn2
DEFINE DIALOG oDlg TITLE "Exemplo de Herança" FROM 10,10 TO 150,300 COLOR CLR_BLACK,CLR_WHITE PIXEL
// Cria um botao normal
// e seta cor diferenciada para o botão 
@ 10,5 BUTTON oBtn1 PROMPT 'TBUTTON' ;
 ACTION ( oBtn2:Show() , oBtn1:Hide() ) ;
 SIZE 040, 013 OF oDlg PIXEL
// Cria um botao usando a classe implementada
oBtn2 := APBUTTON():NEW(oDlg, "APBUTTON", 30, 5, 40, 13, {|| oBtn1:Show(),oBtn2:Hide() })
ACTIVATE DIALOG oDlg CENTER
Return
// ------------------------------------------------------------
CLASS APBUTTON FROM TBUTTON
METHOD New() CONSTRUCTOR
 METHOD Hide()
 METHOD Show()
 
ENDCLASS
// Construtor da classe inicializa construtor do botão 
// e já seta todas as propriedades e comportamentos desejados
// ( Troca fonte, seta cor e esconde o botão ) 
METHOD New(oParent,cCaption,nTop,nLeft,nWidth,nHeight,bAction) CLASS APBUTTON
:New(nTop,nLeft,cCaption,oParent,bAction,nWidth,nHeight,NIL,NIL,NIL,.T.)
::SetColor(CLR_WHITE,CLR_BLACK)
::SetFont( TFont():New("Courier New",,14))
_Super:Hide()
Return self
METHOD Hide() CLASS APBUTTON
MsgInfo("Escondendo o botão ["+::cCaption+"]")
Return _Super:Hide()
METHOD Show() CLASS APBUTTON
MsgInfo("Mostrando o botão ["+::cCaption+"]")
Return _Super:Show()

As diferenças

Os dois botões são criados de formas diferentes, o botão oBtn1 usando a definição padrão do ADVPL, e o oBtn2 usando a nossa classe APBUTTON, que herda TBUTTON. A primeira diferença é o construtor. A herança de classe básica do ADVPL exige que a primeira linha do método construtor chame o construtor da classe pai da herança, usando apenas “:”+nomedoconstrutor+”(“+parâmetros+”)” . A utilização da diretiva “_Super:” dentro da implementação dos métodos funciona da mesma forma, exceto para a chamada do construtor, que exige a grafia diferenciada.

Ao executar o programa acima, devemos ver um botão do ADVPL, que ao ser clicado mostra o novo botão APBUTTON e esconde o botão pressionado. Antes de mostrar o novo botão, como o método Hide() foi reimplementado, será mostrada uma mensagem informativa. A mesma coisa acontece para o método Show(), porém apenas do botão implementado com a classe APBUTTON. A ação do botão APBUTTON será mostrar novamente o botão ADVPL e esconder-se.

Os limites

Bem, até aqui tudo é lindo, mas estes recursos possuem alguns limites específicos. Atualmente, uma classe ADVPL que herda uma classe do binário não pode ser herdada por outra classe ADVPL. Caso você tente por exemplo criar uma classe APBUTTON2 que herda APBUTTON, a mesma vai compilar, mas na hora de executar será gerado um erro de inicialização do construtor nos níveis superiores. Já a herança de classe ADVPL atualmente suporta apenas 2 níveis de herança. Por exemplo, classe FILHA FROM PAI, NETA FROM FILHA. Se você implementar a classe BISNETA e tentar herdar a classe NETA, ao executar por exemplo o construtor da BISNETA, onde haverá uma cascata de _Super para os construtores das camadas superiores, ( BISNETA -> NETA -> FILHA -> PAI ), a execução dos construtores entra em loop, finalizando o processo em execução com uma ocorrência de erro Advpl “stack depth overflow”.

As boas práticas

Inicialmente, além de procurar respeitar os limites estabelecidos, existem características de retenção de memória ligados ao uso de classes visuais e não-visuais no ADVPLe boas práticas gerais ligadas à orientação a objetos em geral, que devido ao nível de detalhamento e quantidade de tópicos, estes temas serão tratados nos próximos posts.

Conclusão

Estes tópicos servem como uma base, uma introdução ao assunto com alguns detalhes. O que vai fazer a diferença na utilização destes recursos é você pesquisar mais sobre o tema, e começar a usá-los no seu dia a dia, a experiência adquirida com alguns calos nos dedos e neurônios queimados usando estes recursos é que vai fazer a diferença. Na TDN, existe um guia completo das classes de interface visual e não-visual da linguagem Advpl, no link “http://tdn.totvs.com/pages/viewpage.action?pageId=6063177“. Para absorver este conteúdo, ler não é o bastante … é apenas o princípio !

Até o próximo post, pessoal 😉

Classes em Advpl – Parte 02

Continuando de onde paramos nas classes, vamos ver agora como criar duas classes em ADVPL, onde uma classe herdará a outra. Lembrando que ambas são casses cujo fonte é escrito em ADVPL e compilado no Repositório. Posteriormente vamos ver como codificar uma classe ADVPL herdando uma classe básica la linguagem ADVPL, implementada no TOTVS Application Server.

Mais um pouco de teoria

Quando criamos uma classe em Advpl herdando outra classe em Advpl, apenas especificamos na classe filha quem é a classe pai de onde herdamos todos os métodos e propriedades. Como não há escopo restrito para os métodos, todos os métodos são virtuais (isto é, podem ser re-implementados na classe filha).

E, é claro, de dentro de um método da classe filha, podemos chamar qualquer método das classes superiores. Em ADVPL não é permitido o recurso de herança múltipla ( onde uma classe filha pode herdar mais de uma classe pai simultâneamente).

Agora um pouco de código

Vamos implementar duas classes, uma classe pai e uma classe filha herdando a classe pai, e sobrescrevendo um de seus métodos. Vamos implementar um arroz com feijão e depois brincar um pouco com ela.

Partindo da premissa que você tenha acesso a um ambiente do ERP Microsiga Protheus, com um IDE / TDS para compilar código ADVPL, crie um novo fonte para testes, chamado APHELLO.PRW, acrescente-o ao seu projeto ( crie um novo apenas para testes), e entre com o código abaixo. Pode copiar e colar que funciona 😉

#INCLUDE "protheus.ch"
// Fonte de teste da classe com herança
User Function APTST2() 
Local oObj
oObj := APFILHA():New(123)
oObj:SayValue()
Return
// -----------------------------------------------------------
// Classe superior para demonstração de herança
CLASS APPAI
 DATA nValue as Integer
 METHOD New(nNum) CONSTRUCTOR
 METHOD SayValue()
ENDCLASS
// Construtor da classe pai, recebe um valor e guarda. 
METHOD New(nNum) CLASS APPAI
::nValue := nNum
Return self
// Mostra o valor guardado na tela, identificando na tela que 
// o método da classe Pai foi utilizado 
METHOD SayValue() CLASS APPAI
MsgInfo(::nValue,"Classe Pai")
Return
// -----------------------------------------------------------
// Classe Filha, herda a classe pai 
CLASS APFILHA FROM APPAI
 METHOD NEW(nNum) CONSTRUCTOR
 METHOD SayValue( lPai )
ENDCLASS
// Construtor da filha chama construtor da classe pai
METHOD NEW(nNum) CLASS APFILHA
_Super:New(nNum)
return self
// Metodo para mostrar o valor, pergunta ao operador se 
// deve ser chamado o metodo da classe pai ou não. 
METHOD SayValue() CLASS APFILHA
If MsgYesNo("Chamar a classe pai ?")
 _Super:SayValue()
Else
 MsgInfo(::nValue,"Classe Filha")
Endif
Return

Após compilar este fonte, você pode chamar a função U_APTST2 diretamente a partir do Smartclient, e deve ser apresentado na sua interface uma caixa de diálogo perguntando se você quer chamar o método da classe pai. Caso você responda sim, deve ser mostrada uma caixa de diálogo contendo o valor 123 guardado na propriedade nValue da classe pai, onde o título da janela é “Classe Pai”. Caso contrário, será mostrada uma caixa de diálogo com o mesmo valor, onde a propriedade nValue da classe pai foi acessada de dentro do método da classe filha — repare no título diferenciado das caixas de diálogo das duas implementações. Agora vamos olhar com uma lupa.

Na declaração da classe APFILHA, após o nome da classe usarmos a instrução FROM, seguido do nome da classe pai, chamada APPAI. Dada a natureza dinâmica das classes Advpl, a classe APPAI usada na herança pode estar em outro fonte / arquivo.

Para chamar um método da classe superior, usamos a palavra reservada “_Super”. Ela deve ser usada apenas dentro da implementação (corpo) de um método, e deve ser escrita exatamente assim, com as letras maiúsculas e minúsculas desta forma (esta palavra reservada é case-sensitive), e somente pode ser usada para referenciar um método do nível superior (classe pai) da herança.

No caso da herança ADVPL, a classe filha não precisa chamar explicitamente o construtor da classe pai, mas isto é uma boa prática de desenvolvimento na orientação a objetos. Como a herança das classes ADVPL permite você herdar uma classe que herda de outra classe (CLASS APNETA FROM APFILHA), caso a classe APPAI possua um método que não foi reimplementado na classe APFILHA , mas a classe APNETA quer utilizá-lo, basta esta referenciar o método usando _Super. A busca nos níveis superiores da herança é recursiva e automática para métodos e propriedades.

Onde foi parar o self ?

No exemplo de classes do post anterior, dentro da implementação dos métodos, para referenciar uma propriedade da minha instância, foi usada a variável “self”, e no exemplo atual usamos “::”. A única diferença entre eles é a grafia. A sequencia de dois caracteres dois-pontos juntos “::” é um #translate de compilação, que é traduzido para “self:”. Utilizar o “::” ao invés de “self:” é a convenção de grafia mais usual.

Conclusão

A cada passo da orientação a objeto vamos estudar um pouco mais de como ela funciona, bem como as melhores formas de tirar proveito dessa tecnologia! No próximo post sobre Classes em ADVPL vamos ver as diferenças para codificar uma classe ADVPL que herda diretamente de uma classe de objeto de interface visual da linguagem!

Até o próximo post, pessoal 😉