zuerst einmal danke, das ihr euch mit meinem Problem beschäftigt. Ich hab mir jetzt einen Testzugang einrichten lassen, aber ich mache definitiv etwas falsch. Hier ist der Quellcode (etwas bereinigt):
Code: Alles auswählen
// Funktionen zur automatischen šbermittlung des G„stmeldemblatts
#include "LBHOTEL.CH"
#include "OT4XB.CH"
#include "common.ch"
#include "inkey.ch"
#include "achoice.ch"
#INCLUDE "dcdialog.ch"
#include "xb2net.ch"
#include "xbpcre.ch"
#pragma Library("dcxml.lib")
#pragma library("xb2net.lib")
#define CRLF (Chr(13)+Chr(10))
#xtranslate NTrim(<n>) => LTrim(Str(<n>))
FUNCTION MakeXML(AUFTRAG, labreise, cAufnr)
LOCAL oXml
LOCAL oSSLContext := XbSSLContext():New(TLS_client_method)
LOCAL oRequest
LOCAL oHeader := {}
LOCAL oBody
LOCAL oResponse
LOCAL nHandle
LOCAL cMeldnr := ""
LOCAL cMail := ""
LOCAL cXMLFile := ""
LOCAL cRespondFile := xPath + "RESULT" + ".XML"
LOCAL cXMLText := ""
LOCAL leer := space(3)
LOCAL oInfo
LOCAL GA_STAMM, STATIS
LOCAL nOldSel := SELECT()
LOCAL cPLZ := ""
LOCAL nZahl := 1
LOCAL cFehler := cFehler1 := cFehler2 := ""
LOCAL nAnzBesuch := 0
LOCAL nGastartF := 0
LOCAL nGastartJ := 0
LOCAL nGastartP := 0
LOCAL nGastartS := 0
LOCAL nGastzahl := 0
LOCAL nMitzahl := 2
LOCAL cLaenderschluessel := "1"
LOCAL cErg := ""
// TESTZUGANG FERATEL 2.7.2018
LOCAL KWgaesteblattGkz := "41503"
LOCAL KWgaesteblattBnr := "7431"
LOCAL KWmcnummer := "35603"
LOCAL KWgaesteblattUser := "User35603"
LOCAL KWgaesteblattPwd := "berger7431"
LOCAL KWgaesteblattHotelsw := "LBHOTEL"
LOCAL cContent := "Content-Type: application/x-www-form-urlencoded"
LOCAL cPattern
LOCAL oReg
LOCAL nResult
LOCAL aSet
LOCAL nStart
if empty((AUFTRAG)->NAME) .or. empty((AUFTRAG)->KDNR)
w_error("Kein Kundenname oder keine Kundennummer vorhanden!")
RETURN .t.
endif
if empty(cAufnr)
w_error("Keine Buchung zur Meldung vorhanden!")
RETURN .t.
endif
IF (LK_STAMM := NetUse("LK_STAMM")) = 0 // Kundenstamm ”ffnen
DbSelectArea( nOldSel )
MsgBox( "Datei kann nicht ge”ffnet werden" )
RETURN .f.
ELSE
SET INDEX TO LKSTAMMA
DbGoTop()
ENDIF
IF (GA_STAMM := NetUse("GA_STAMM")) = 0 // Kundenstamm ”ffnen
DbSelectArea( nOldSel )
MsgBox( "Datei kann nicht ge”ffnet werden" )
RETURN .f.
ELSE
SET INDEX TO GA_STAMMA
DbGoTop()
ENDIF
IF (STATIS := NetUse("STATIS")) = 0 // Kundenstamm ”ffnen
DbSelectArea( nOldSel )
MsgBox( "Datei kann nicht ge”ffnet werden" )
RETURN .f.
ELSE
SET INDEX TO STATISR
DbGoTop()
ENDIF
if (STATIS)->(DbSeek((AUFTRAG)->KDNR))
DO WHILE str((STATIS)->A_MITNR,6) = (AUFTRAG)->KDNR .and. !eof()
nAnzBesuch += 1
(STATIS)->(DbSkip())
ENDDO
if labreise
nAnzBesuch -= 1
if nAnzBesuch < 0
nAnzBesuch := 0
endif
endif
endif
if (GA_STAMM)->(DbSeek(val((AUFTRAG)->KDNR)))
cLaenderschluessel := alltrim((GA_STAMM)->M_REGCODE)
endif
SELECT(nOldSel)
if !empty((AUFTRAG)->MSCHEINNR)
cMeldnr := alltrim((AUFTRAG)->MSCHEINNR)
else
cMeldnr := GetMeldeNr()
endif
if !empty((AUFTRAG)->NAME)
if (AUFTRAG)->KURTAXE != "S"
nGastartP +=1
else
nGastartS +=1
endif
endif
if !empty((AUFTRAG)->MITREISEND)
nGastartP +=1
endif
if !empty((AUFTRAG)->MITREISEN2)
nGastartP +=1
endif
if !empty((AUFTRAG)->MITREISEN3)
nGastartP +=1
endif
if !empty((AUFTRAG)->MITREISEN4)
nGastartP +=1
endif
if !empty((AUFTRAG)->MITREISEN5)
nGastartP +=1
endif
if !empty((AUFTRAG)->MITREISEN6)
nGastartP +=1
endif
if !empty((AUFTRAG)->NAMEKIND1)
if (AUFTRAG)->ALTERKIND1 >= 0 .and. (AUFTRAG)->ALTERKIND1 <= 10
nGastartF +=1
elseif (AUFTRAG)->ALTERKIND1 >= 11 .and. (AUFTRAG)->ALTERKIND1 <= 16
nGastartJ +=1
endif
endif
if !empty((AUFTRAG)->NAMEKIND2)
if (AUFTRAG)->ALTERKIND2 >= 0 .and. (AUFTRAG)->ALTERKIND2 <= 10
nGastartF +=1
elseif (AUFTRAG)->ALTERKIND2 >= 11 .and. (AUFTRAG)->ALTERKIND2 <= 16
nGastartJ +=1
endif
endif
if !empty((AUFTRAG)->NAMEKIND3)
if (AUFTRAG)->ALTERKIND3 >= 0 .and. (AUFTRAG)->ALTERKIND3 <= 10
nGastartF +=1
elseif (AUFTRAG)->ALTERKIND3 >= 11 .and. (AUFTRAG)->ALTERKIND3 <= 16
nGastartJ +=1
endif
endif
if !empty((AUFTRAG)->NAMEKIND4)
if (AUFTRAG)->ALTERKIND4 >= 0 .and. (AUFTRAG)->ALTERKIND4 <= 10
nGastartF +=1
elseif (AUFTRAG)->ALTERKIND4 >= 11 .and. (AUFTRAG)->ALTERKIND4 <= 16
nGastartJ +=1
endif
endif
nGastzahl := nGastartP + nGastartS + nGastartF + nGastartJ
cXMLFile := xPath + cMeldnr + ".XML"
oInfo := ShowInfo():New()
oInfo:Show("Datenexport", "Die Meldescheindaten werden bertragen, bitte warten...")
oXml := xbXMLDocument():new()
oReq := xbComplexType():new("Request")
// TESTZUGANG FERATEL 2.7.2018
aadd(oHeader, {"KWmcnummer", "35603"})
aadd(oHeader, {"KWgaesteblattUser", "User35603"})
aadd(oHeader, {"KWgaesteblattPwd", "berger7431"})
aadd(oHeader, {"KWgaesteblattGkz", "41503"})
aadd(oHeader, {"KWgaesteblattBnr", "7431"})
aadd(oHeader, {"KWgaesteblattHotelsw", "LBHOTEL"})
aadd(oHeader, {"Content-Type","application/x-www-form-urlencoded"})
cXMLText := '<?xml version="1.0" encoding="UTF-8"?>' + CRLF
cXMLText += "<gemeinde oestat="+HK(KWgaesteblattGkz) + " " +;
"version="+HK("5")+ ">" + CRLF
cXMLText += leer+"<betrieb betriebnr="+HK(KWgaesteblattBnr) + ">" +CRLF
cXMLText += leer+leer+"<meldeblatt mblattnr="+HK(cMeldnr)+ " "+;
"reservierung=="+HK("0")+" "+;
"bearbeiter="+HK("Eigenbauer")+" "+;
"aufenthalte="+HK(alltrim(str(nAnzBesuch)))+" "+;
"ankunft="+HK(XMLDatum((AUFTRAG)->ANREISE))+" "+;
if(labreise=.t.,"abreise="+HK(XMLDatum((AUFTRAG)->ABREISE))+" ","")+;
"abgeplant="+HK(XMLDatum((AUFTRAG)->ABREISE))+" "+;
"reisegruppe="+HK("0")+">" + CRLF
cXMLText += leer+leer+leer+"<landschl lschlnr="+HK(cLaenderschluessel)+ " "+;
"anzpers="+HK(alltrim(str(nGastzahl)))+"/>" + CRLF
if nGastartP > 0
cXMLText += leer+leer+leer+"<gastart gastart="+HK("P")+ " "+;
"anzpers="+HK(alltrim(str(nGastartP)))+"/>" + CRLF
endif
if nGastartJ > 0
cXMLText += leer+leer+leer+"<gastart gastart="+HK("J")+ " "+;
"anzpers="+HK(alltrim(str(nGastartJ)))+"/>" + CRLF
endif
if nGastartF > 0
cXMLText += leer+leer+leer+"<gastart gastart="+HK("F")+ " "+;
"anzpers="+HK(alltrim(str(nGastartF)))+"/>" + CRLF
endif
if nGastartS > 0
cXMLText += leer+leer+leer+"<gastart gastart="+HK("S")+ " "+;
"anzpers="+HK(alltrim(str(nGastartS)))+"/>" + CRLF
endif
*cXMLText += leer+leer+leer+"<aufenthaltsmotiv motiv="+HK("Motiv")+ "/>" + CRLF
*cXMLText += leer+leer+leer+"<hobbys hobby="+HK("Hobby")+ "/>" + CRLF
*cXMLText += leer+leer+leer+"<resonanz resonanz="+HK("Resonanz")+ "/>" + CRLF
if (GA_STAMM)->(DbSeek(val((AUFTRAG)->KDNR)))
cPLZ := alltrim((GA_STAMM)->M_PLZ)
cMail := alltrim((GA_STAMM)->M_EMAIL)
cMail := strtran(cMail,"<", "<")
cMail := strtran(cMail,">", ">")
cMail := strtran(cMail,"&", "&")
cMail := strtran(cMail,'"', """)
cMail := strtran(cMail,"'", "'")
cXMLText += leer+leer+leer+"<gast gastlfdnr="+HK("1")+ " "+;
"gasttyp="+HK("HG")+" "+;
"anrede="+HK(alltrim((GA_STAMM)->M_ANREDE))+" "+;
"titel="+HK(alltrim((GA_STAMM)->M_TITEL))+" "+;
"vorname="+HK(alltrim((GA_STAMM)->M_VORNAME))+" "+;
"name="+HK(alltrim((GA_STAMM)->M_NAME))+" "+;
"strasse="+HK(alltrim((GA_STAMM)->M_STRASSE))+ CRLF+;
leer+leer+leer+space(6)+;
"nation="+HK(alltrim((GA_STAMM)->M_LK))+" "+;
"plz="+HK(alltrim((GA_STAMM)->M_PLZ))+" "+;
"ort="+HK(alltrim((GA_STAMM)->M_ORT))+" "+;
"gebdatum="+HK(XMLDatum((GA_STAMM)->M_GEBDATUM))+" "+;
"geschlecht="+HK(XMLSex((GA_STAMM)->M_SEX))+" "+;
"reisedokument="+HK(alltrim((GA_STAMM)->M_ID))+" "+;
"staatsang="+HK(alltrim((GA_STAMM)->M_NATCODE))+" "+;
"herkunftsland="+HK(cLaenderschluessel)+ CRLF+;
leer+leer+leer+space(6)+;
"beruf="+HK(alltrim((AUFTRAG)->BERUF))+" "+;
"email="+HK(cMail)+" "+;
"telefon="+HK(alltrim((GA_STAMM)->M_TEL1))+" "+;
"motiv="+HK(alltrim((AUFTRAG)->MOTIV))+" "+;
"hobby="+HK(alltrim((AUFTRAG)->HOBBY))+"/>" + CRLF
endif
cXMLText += leer+leer+"</meldeblatt>" + CRLF
cXMLText += leer+"</betrieb>" + CRLF
cXMLText += "</gemeinde>" + CRLF
cXMLText = MakeUTF8(cXMLText)
ferase(cXMLFile)
ferase(cRespondFile)
nHandle := fcreate(cXMLFile, FC_NORMAL)
fwrite(nHandle, cXMLText)
fclose(nHandle)
* if file(cXMLFile)
* DCMsgBox ;
* "Die Meldedatei " + cXMLFile + " wurde erstellt!";
* TITLE "Gastmeldeschein";
* BUTTONS {"~Ok"} ;
* HORIZONTAL;
* FONT "12.Arial"
* endif
// 02.07.2018 LB SSL Context einbinden
oXml:SetSSLContext( oSSLContext)
// TESTZUGANG FERATEL 2.7.2018
oResponse := oXml:Execute("https://meldeclient.feratel.at/meldeclient/MCLInterfaceServlet/XML.In?mcnummer=35603&username=User35603&password=berger7431", cXMLText, oHeader, cRespondFile)
oInfo:Destroy()
if oResponse == NIL
w_error("Fehler:" + str(oXml:ErrorCode,5),;
oXml:ErrorSource,;
oXml:ErrorMessage)
else
nHandle := fOpen(cRespondFile)
IF nHandle < 1
RETU(.F.)
ENDIF
nSize := fSize(nHandle)
cLine := Space(nSize)
fRead(nHandle, @cLine, nSize)
fClose(nHandle)
nStart := 1
nOptions := PCRE_CASELESS + PCRE_MULTILINE + PCRE_DOTALL
cPattern := '<error>(.+?)<'
oReg := RegExp():new(cPattern, nOptions)
nResult := oReg:exec(cLine, nStart)
WHILE nResult > 0
aSet := oReg:result(1)
nStart := aSet[1] + aSet[2]
aSet := oReg:result(2)
cErg := Substr(cLine, aSet[1], aSet[2])
nResult := oReg:exec(cLine, nStart)
END
cFehler1 := cErg
cFehler := "Fehlercode: "+cFehler1
cPattern := '<description>(.+?)<'
oReg := RegExp():new(cPattern, nOptions)
nResult := oReg:exec(cLine, nStart)
WHILE nResult > 0
aSet := oReg:result(1)
nStart := aSet[1] + aSet[2]
aSet := oReg:result(2)
cErg := Substr(cLine, aSet[1], aSet[2])
nResult := oReg:exec(cLine, nStart)
END
cFehler2 := MakeOem(cErg)
*cFehler += ", Beschreibung: "+cFehler2
if val(cFehler1) = 0
*w_error("Der Meldeschein wurde erfolgreich bertragen.")
if empty((AUFTRAG)->MSCHEINNR)
(AUFTRAG)->(DbRlock())
(AUFTRAG)->MSCHEINNR := cMeldnr
(AUFTRAG)->MELDEDATUM := date()
(AUFTRAG)->MELDEZEIT := substr(time(),1,8)
(AUFTRAG)->(UUnlock())
SetMeldeNr(cMeldnr)
else
(AUFTRAG)->(DbRlock())
(AUFTRAG)->MELDEDATUM := date()
(AUFTRAG)->MELDEZEIT := substr(time(),1,8)
(AUFTRAG)->(UUnlock())
endif
else
w_error("Fehler beim šbertragen des Meldeblattes!", "", cFehler,"Beschreibung: "+ cFehler2)
endif
endif
NetClose(STATIS)
NetClose(GA_STAMM)
NetClose(LK_STAMM)
SELECT(nOldSel)
RETURN .t.
FUNCTION XMLDatum(dDatum)
LOCAL cTempDatum := dtos(dDatum)
RETURN substr(cTempDatum,1,4)+"-"+substr(cTempDatum,5,2)+"-"+substr(cTempDatum,7,2)
FUNCTION XMLSex(cSex)
LOCAL nSex := "1"
DO CASE
CASE upper(cSex) = "M"
nSex := "1"
CASE upper(cSex) = "W"
nSex := "2"
CASE upper(cSex) = "X"
nSex := "0"
ENDCASE
RETURN nSex
FUNCTION HK(cString)
RETURN '"' + cString + '"'
FUNCTION GetMeldeNr()
LOCAL cMdnr := ""
LOCAL MELD
LOCAL nOldSel := Select()
if dtos(date()) >= "20180701"
IF (MELD := NetUse("MELDENRN")) = 0
DbSelectArea( nOldSel )
MsgBox( "Auftragsnummerdatei kann nicht ge”ffnet werden" )
RETURN cMdnr
ELSE
cMdnr := alltrim(str(val((MELD)->MSCHEINNR)+1))
NetClose(MELD)
ENDIF
else
IF (MELD := NetUse("MELDENR")) = 0
DbSelectArea( nOldSel )
MsgBox( "Auftragsnummerdatei kann nicht ge”ffnet werden" )
RETURN cMdnr
ELSE
cMdnr := alltrim(str(val((MELD)->MSCHEINNR)+1))
NetClose(MELD)
ENDIF
endif
Select(nOldSel)
RETURN cMdnr
FUNCTION SetMeldeNr(cMdnr)
LOCAL MELD
LOCAL nOldSel := Select()
if dtos(date()) >= "20180701"
IF (MELD := NetUse("MELDENRN")) = 0
DbSelectArea( nOldSel )
MsgBox( "Auftragsnummerdatei kann nicht ge”ffnet werden" )
RETURN cMdnr
ELSE
(MELD)->(DbRlock())
(MELD)->MSCHEINNR := padr(cMdnr,10)
(MELD)->(UUnlock())
NetClose(MELD)
ENDIF
else
IF (MELD := NetUse("MELDENR")) = 0
DbSelectArea( nOldSel )
MsgBox( "Auftragsnummerdatei kann nicht ge”ffnet werden" )
RETURN cMdnr
ELSE
(MELD)->(DbRlock())
(MELD)->MSCHEINNR := padr(cMdnr,10)
(MELD)->(UUnlock())
NetClose(MELD)
ENDIF
endif
Select(nOldSel)
RETURN .t.
FUNCTION MakeUTF8(cString)
RETURN cOemToUTF8(cString)
FUNCTION MakeOem(cString)
RETURN cUTF8ToOem(cString)
FUNCTION GetName(cMitreisend, lVorname)
LOCAL cName := ""
if lVorname = .t.
cName := Token(cMitreisend,2)
if empty(cName)
cName := Token(cMitreisend,1)
endif
else
cName := Token(cMitreisend,1)
if empty(Token(cMitreisend,2))
cName := ""
endif
endif
RETURN alltrim(cName)
FUNCTION MakeAnsi(cString)
RETURN ConvToAnsiCP(cString)
FUNCTION UIDCheck(cUid)
Local oSoap, oResult := ""
LOCAL oInfo
LOCAL lUid := .f.
LOCAL lReturn := .t.
if empty(cUid)
RETURN lReturn
endif
oInfo := ShowInfo():New()
oInfo:Show("UID-Prfung", "Die UID-Nummer wird berprft, bitte warten...")
cUid := strtran(cUid," ","")
oSoap := xbSOAPEnvelope():new()
oSoap:SetStyle( SOAP_STYLE_DOCUMENT )
oSoap:SetProxy(scProxyHost, snProxyPort, scProxyUserID, scProxyPassword)
oSoap:SendTimeout(8000)
oSoap:RecvTimeout(8000)
oSoap:NameSpace := "urn:ec.europa.eu:taxud:vies:services:checkVat:types"
oSoap:SetVar("countryCode", upper(substr(cUid,1,2)))
oSoap:SetVar("vatNumber" , upper(substr(cUid,3)))
oResult := oSoap:Execute("http://ec.europa.eu/taxation_customs/vies/services/checkVatService", "checkVat")
oInfo:Destroy()
lUid := iif(Empty(oResult:Action) .or. Upper(oResult:Action) == "FAULT", .f., .t.)
if lUid = .f.
w_error("ACHTUNG! Keine Verbindung zum EU-Server!")
else
aTxt := ExpandVars(oResult)
if aScan(aTxt, {|x| "true" $ x }) > 0
lUid := .t.
w_error("Die UID-Nummer ist gltig!")
lReturn := .t.
else
w_error("ACHTUNG!",;
"Die UID-Nummer ist ungltig!",;
"Kontrollieren Sie bitte die eingegeben Daten!")
lReturn := .f.
endif
endif
Return lReturn
STATIC FUNCTION ExpandVars(oData, nIndent)
Local i, xVal
Local aVarList := oData:GetVar()
Local imax := len(aVarList)
Local cRet := ""
Local aTxt := {}
DEFAULT nIndent TO 0
for i := 1 to imax
xVal := aVarList[i,VAR_VALUE]
if ValType(xVal) == "O" .and. xVal:isDerivedFrom("xbComplexType")
aadd( aTxt, aVarList[i,VAR_NAME])
//aadd( ExpandVars(xVal,nIndent+2)
else
aadd( aTxt, var2char(aVarList[i]) )
endif
next
Return aTxt
// ** L¡nea 2 de c:\dos\SYGA.SYS
/*****************************
* Source : xmlparser.prg
* System : <unkown>
* Author : Phil Ide
* Created: 12/02/2004
*
* Purpose:
* ----------------------------
* History:
* ----------------------------
* 12/02/2004 13:14 PPI - Created
*****************************/
#include "Xbp.ch"
#include "error.ch"
#include "Common.ch"
#define PIXML_SCAN_SHALLOW 0
#define PIXML_SCAN_DEEPSCAN 1
#define CRLF Chr(13)+Chr(10)
#define WS_INTAG ' '+Chr(9)+Chr(0)+CRLF
#define WS_OUTTAG WS_INTAG
#define WS_CONTENT ''
#define OUT_TAG 0
#define IN_TAG 1
#define IN_CONTENT 2
// TAG_PAD provides indentation on output
#define TAG_PAD 2 // estaba 0 en lugar de 4
#ifdef _TEST_
Function Main(cFile, cFile2)
local oXml
local nH
if ( upper(cFile) == upper( appname() ) .or. ;
upper(cFile +'.exe') == upper( appname() ) ) .and. !empty(cFile2)
cFile := cFile2
end
if FExists("test.xml")
ferase("test.xml")
endif
if FExists(cFile)
oXml := ParseXml( memoread(cFile) )
if !oXml == NIL
nH := FCreate('test.xml')
FWrite(nH,oXml:asString())
FClose(nH)
endif
endif
return nil
#endif
Function ParseXml( cStream )
local oParser := XmlParser():new(cStream)
local oXml
oXml := oParser:parse()
return oXml
// ------------------------------------------------------------------------
CLASS XMLParser
EXPORTED:
VAR cData
VAR iPos
VAR inTag
VAR nEnd
VAR inString
VAR inComent
VAR stringDelim
VAR LineNum
VAR oTree
VAR lastPos
METHOD init
METHOD parse
PROTECTED:
METHOD XMLParse
METHOD getNextToken
METHOD lookAhead
METHOD strip
METHOD ungetToken
METHOD xmlError
METHOD getTag
ENDCLASS
METHOD XMLParser:init(cStream)
::cData := cStream
::iPos := 1
::inTag := OUT_TAG
::nEnd := Len(::cData)
::inString := FALSE // parser en un string
::inComent := FALSE // parser en un comentario
::stringDelim := {}
::LineNum := 1
::oTree := {}
return self
METHOD XMLParser:parse()
local oDoc
// call lexical analyser
::XmlParse()
if !Empty(::oTree)
oDoc := ::oTree[1]
endif
return oDoc
METHOD XMLParser:XmlParse()
local cToken := '0'
local oDoc
local n
While !Empty( cToken := ::getNextToken() )
if cToken == '<'
::getTag() // call lexical parser
elseif ::inTag == OUT_TAG .and. !Empty(::oTree)
// reset pointer
::iPos = ::lastPos
n := ::lookAhead()
cToken := SubStr( ::cData, ::iPos, n )
if !Empty(::Strip(cToken,WS_OUTTAG)) // is there only white-space?
ATail(::oTree):content := cToken // keep white-space if there is data
endif
::iPos += n
else
::xmlError(cToken)
endif
Enddo
return nil
METHOD XMLParser:getTag()
local oTag := Xml():new()
local cAttrName
local cAttrVal
local cName
local cToken
oTag:name := ::getNextToken()
if oTag:name == '?' .or. oTag:name == '!' .or. oTag:name == '/'
oTag:name += ::getNextToken() // ?xml
endif
if left( oTag:name , 3) = "!--"
::inComent := TRUE // Comentario hasta -->
end
While !(::cData[::iPos] == '>')
cAttrName := ::getNextToken()
cAttrVal := NIL
if ::inComent
aadd( oTag:attribute, {cAttrName, NIL} )
elseif !(cAttrName == '?' .or. cAttrName == '/')
cToken := ::getNextToken() // remove '='
if cToken == '='
cAttrVal := ::getNextToken()
// las comillas se pueden quitar o no JSV
// strip out quotes
if cAttrVal[1] $'"'+"'"
cAttrVal := SubStr(cAttrVal,2)
endif
if cAttrVal[-1] $'"'+"'"
cAttrVal := Left(cAttrVal,Len(cAttrVal)-1)
endif
else
::ungetToken(cToken)
endif
aadd( oTag:attribute, {cAttrName, cAttrVal} )
elseif cAttrName == '/' // termina con />
oTag:hasEndTag := FALSE // y no finaliza con tag </tag>
else
aadd( oTag:attribute, {cAttrName, NIL} )
endif
enddo
if !(oTag:name[1] == '/')
if ::inComent
oTag:hasEndTag := TRUE
if !Empty(::oTree)
oTag:parent := ATail(::oTree)
aadd( ATail(::oTree):children, oTag )
endif
// aadd(::oTree,oTag) No se a¤ade al rbol pero no s‚ porqu‚.
elseif !(cAttrName == '?' .or. cAttrName == '/')
if !Empty(::oTree)
oTag:parent := ATail(::oTree)
aadd( ATail(::oTree):children, oTag )
endif
aadd(::oTree, oTag)
elseif cAttrName == '?' .and. Empty(::oTree)
oTag:hasEndTag := FALSE
aadd(::oTree,oTag)
elseif lower(oTag:name) == '?xml'
aadd(::oTree,oTag)
elseif oTag:name[1] == '!'
oTag:hasEndTag := FALSE
elseif cAttrName[1] == '/'
oTag:hasEndTag := FALSE
oTag:parent := ATail(::oTree)
aadd( ATail(::oTree):children, oTag )
endif
else
oTag:hasEndTag := FALSE
ASize(::oTree, Len(::oTree)-1)
endif
::inComent := FALSE // Comentario hasta -->
::getNextToken() // clear '>'
return oTag
METHOD XMLParser:getNextToken()
local cToken := ''
local cA
::lastPos := ::iPos
While ::iPos <= ::nEnd
cA := ::cData[::iPos]
if cA == Chr(10)
::LineNum++
endif
do case
case ::inComent // Comentario hasta -->
if cA == '>' .and. right(cToken,2) = '--'
// ::inComent := FALSE
exit
else
cToken += cA
endif
case cA == "/" .and. !::inString .and. len(cToken) > 0
::iPos++
exit
case ::inString .and. !(::cData[::iPos] == ATail(::stringDelim))
cToken += ::cData[::iPos]
case ::cData[::iPos] == '?' .and. ::inTag == IN_TAG .and. !::inString
if Len(cToken) > 0
exit
else
cToken := '?'
::iPos++
exit
endif
case ::cData[::iPos] == '=' .and. ::inTag == IN_TAG
if Len(cToken) > 0
exit
else
cToken := '='
::iPos++
exit
endif
case ::inTag == OUT_TAG .and. ::cData[::iPos] == '<' .and. !::inString
if Len(cToken) > 0
exit
else
cToken := '<'
::inTag := IN_TAG
::iPos++
exit
endif
case ::inTag == OUT_TAG .and. !(::cData[::iPos] $ '"'+"'") .and. !(::cData[::iPos] $ WS_OUTTAG)
cToken += ::cData[::iPos]
case ::cData[::iPos] == '>' .and. !::inString
if Len(cToken) > 0
exit
else
cToken := '>'
::inTag := OUT_TAG
::iPos++
exit
endif
case ::cData[::iPos] == '"' // .or. ::cData[::iPos] == "'"
cToken += ::cData[::iPos]
if !::inString
aadd(::stringDelim, ::cData[::iPos])
::inString := TRUE
elseif ::cData[::iPos] == ATail(::stringDelim)
ASize(::stringDelim, Len(::stringDelim)-1)
::inString := FALSE
if Len(cToken) > 0
::iPos++
exit
endif
endif
case ::inTag == IN_TAG .and. ::cData[::iPos] $ WS_INTAG
if Len(cToken) > 0
::iPos++
exit
endif
case ::inTag == OUT_TAG .and. ::cData[::iPos] $ WS_OUTTAG
if Len(cToken) > 0
::iPos++
exit
endif
otherwise
cToken += ::cData[::iPos]
endcase
::iPos++
Enddo
return cToken
METHOD XMLParser:lookAhead()
local i := ::iPos+1
local n := 1
local aDelim := {}
While i <= ::nEnd
if ::cData[i] $ '"'+"'"
if !Empty(aDelim) .and. ::cData[i] == ATail(aDelim)
ASize(aDelim, Len(aDelim)-1)
else
aadd(aDelim, ::cData[i])
endif
elseif ::cData[i] $ '<'
exit
endif
i++
Enddo
return i-::iPos
METHOD XMLParser:Strip(cToken,cStrip)
local i
local n := Len(cToken)
local c := ''
for i := 1 to n
if !(cToken[i] $ cStrip)
c += cToken[i]
endif
next
return c
METHOD XMLParser:ungetToken()
::iPos := ::lastPos
return NIL
METHOD XMLParser:XmlError(cToken)
local o := Error():new()
o:args := {cToken, ::LineNum, ::iPos-1}
o:description := "XML Parsing error - Error in Input"
o:severity := XPP_ES_FATAL
o:subSystem := "XML"
Eval( ErrorBlock(), o)
return nil
// ================================================================
CLASS XML
EXPORTED:
VAR parent
VAR name
VAR attribute
VAR content
VAR children
VAR hasEndTag
VAR childID
METHOD init
METHOD asString
METHOD compose IS asString
METHOD parent
METHOD children
METHOD getChild
METHOD allSiblings
METHOD siblings
METHOD getSibling
METHOD getPreviousSibling
METHOD getNextSibling
METHOD isOrphan
METHOD getAttribute
METHOD setAttribute
METHOD findAttribute
METHOD findChildFromName
METHOD findChildFromAttribute
METHOD findAllChildrenFromName
METHOD findSiblingFromName
METHOD findSiblingFromAttribute
ENDCLASS
METHOD Xml:init()
::name := ''
::attribute := {}
::children := {}
::hasEndTag := TRUE
return self
METHOD Xml:parent()
return ::parent
METHOD Xml:children() // Todos los hijos
return ::children
METHOD Xml:getChild(n) // el hijo n
local oRet
if valType(n) == 'N' .and. n > 0 .and. n <= len(::Children)
oRet := ::Children[n]
endif
return oRet
METHOD Xml:allSiblings() // Todos los hermanos - incluido el mismo -
return ::parent:children
METHOD Xml:siblings() // S¢lo los hermanos (no se incluye el mismo)
local oParent := ::parent
local i
local aRet := {}
for i := 1 to len(oParent:children)
if !(oParent:children[i] == self)
aadd( aRet, oParent:children[i] )
endif
next
return aRet
METHOD Xml:getSibling(n) // el hermano n
local oRet
if ValType(n) == 'N' .and. n > 0 .and. n <= len(::parent:children)
oRet := ::parent:children[n]
endif
return oRet
METHOD Xml:getPreviousSibling(nId) // el hermano anterior - si existe
local i // el nId no se emplea
local oRet
default nId to ::id
i := AScan(::parent:children, {|o| o == self })
if i > 1
oRet := ::parent:children[i-1]
endif
return (oRet)
METHOD Xml:getNextSibling(nId) // el hermano siguiente - si existe
local i // el nId no se emplea
local oRet
default nId to ::id
i := AScan(::parent:children, {|o| o == self })
if i < len(::parent:children)
oRet := ::parent:children[i+1]
endif
return (oRet)
METHOD Xml:isOrphan() // es huerfano (no tiene padre)?
return ::parent == NIL
METHOD Xml:getAttribute(x) // devuelve el atributo n£mero x
local cRet
cRet := ::attribute[x]
return cRet
METHOD Xml:setAttribute(x, xValue) // fija el atributo x
local aRet // si x es un n£mero , el atributo x
local i // si es un caracter , se busca el
// atributo a¤adiendose si no existe
do case
case ValType(x) == 'N'
if x > 0 .and. x <= len(::attribute)
::attribute[x][2] := Var2Char(xValue)
aRet := ::attribute[x]
endif
case ValType(x) == 'C'
i := Ascan( ::attribute, {|e| lower(e[1]) == lower(x) } )
if i == 0
aadd(::attribute,{x,Var2Char(xValue)})
i := len(::attribute)
else
::attribute[i][2] := Var2Char(xValue)
endif
aRet := ::attribute[i]
endcase
return aRet
METHOD Xml:findAttribute(c) // busca el atributo c y devuelve el valor
local i := Ascan( ::attribute, {|e| lower(e[1]) == lower(c) } )
local cRet
if i > 0
cRet := ::attribute[i][2]
endif
return cRet
METHOD Xml:findChildFromName( cName, nScanLevel ) // busca un hijo por nombre
local nDepth := 0 // si nScanLevel es PIXML_SCAN_DEEPSCAN
local oRet // busca en los hijos sucesivos
local i
for i := 1 to len(::children)
if lower(::children[i]:name) == lower(cName)
oRet := ::children[i]
elseif nScanLevel == PIXML_SCAN_DEEPSCAN
oRet := ::children[i]:findChildFromName( cName, nScanLevel )
endif
if !(oRet == NIL)
exit
endif
next
return oRet
METHOD Xml:findChildFromAttribute( cAttr, nScanLevel ) // busca un hijo con ..
local nDepth := 0 // .. un atributo determinado
local oRet
local aRet
local i
for i := 1 to len(::children)
aRet := ::children[i]:findAttribute(cAttr)
if aRet == NIL .and. nScanLevel == PIXML_SCAN_DEEPSCAN
oRet := ::children[i]:findChildFromAttribute( cAttr, nScanLevel )
else
oRet := ::children[i]
endif
if !(oRet == NIL)
exit
endif
next
return oRet
METHOD Xml:findSiblingFromName(cName) // busca un hermano por nombre
local aSiblings := ::siblings()
local i
local oRet
for i := 1 to len(aSiblings)
if lower(aSiblings[i]:name) == lower(cName)
oRet := aSiblings[i]
exit
endif
next
return oRet
METHOD Xml:findSiblingFromAttribute(cAttr) // busca un hermano con un determinado atributo
local aSiblings := ::siblings()
local i
local c
local oRet
for i := 1 to len(aSiblings)
c := aSiblings[i]:findAttribute(cAttr)
if !(c == NIL)
oRet := aSiblings[i]
exit
endif
next
return oRet
METHOD Xml:findAllChildrenFromName(cName) // busca todos los hijos y descendientes
local aRet := {} // con un nombre determinado
local i
local n
local aTmp
for i := 1 to len(::children)
if lower(::children[i]:name) == lower(cName)
aadd( aRet, ::children[i] )
else
aTmp := ::children[i]:findAllChildrenFromName(cName)
for n := 1 to len(aTmp)
aadd( aRet, aTmp[n] )
next
endif
next
return aRet
METHOD Xml:asString(nDepth) // pasa el XML a string para poderlo grabar
local cRet := ""
local i
local v
local n
local o
default nDepth to 0
if len( ::name ) > 0
if ::name[1] == '?'
cRet := '<'
else
cRet := Space(TAG_PAD*nDepth)+'<'
end
cRet += ::name
v := Len(::attribute)
for i := 1 to v
cRet += ' '+::attribute[i][1]
if !(::attribute[i][2] == NIL)
cRet += '="'+::attribute[i][2]+'"'
endif
next
if ::hasEndTag .or. ::name[1] == '?'
cRet += '>'
endif
if !Empty(::content)
cRet += ::content
endif
if !Empty(::children)
cRet += CRLF
endif
if ::hasEndTag .and. ;
Empty(::content) .and. ;
Empty(::children)
cRet += CRLF
endif
else
if len( ::attribute ) > 0 .or. ;
!Empty(::content)
o := Error():new()
o:args := {"sin nombre", ;
"con " + alltrim(str( len( ::attribute ) ) ) + " atributos" , ;
}
o:description := "XML error - Error en asString "
o:severity := XPP_ES_FATAL
o:subSystem := "XML"
Eval( ErrorBlock(), o)
end
end
for i := 1 to Len(::children)
n := iif( lower(::name) == '?xml', 0, nDepth+1 )
cRet += ::children[i]:asString(n)
next
if len( ::name ) > 0
if !(::name[1] $ '?!')
if ::hasEndTag
if !Empty(::children)
cRet += Space(TAG_PAD*nDepth)+'</'
else
cRet += '</'
endif
cRet += ::name+'>' + CRLF
else
cRet += ' />' + CRLF
endif
endif
endif
return cRet
// ========================================= eof ==============================