* utDBFDOM.prg
* Call : "DO utDBFDOM with "MyAlias"
* DO utDBFDOM with cAliasName, transmitmemos,transmitautos
* PARAMETERS ucDBF,llIgnoreMemos,llIgnoreAutos
PARAMETERS ucDBF
ON ERROR DO errhand WITH ERROR( ), MESSAGE( ),;
                    MESSAGE(1), PROGRAM( ), LINENO( )
?[Started: ]+TIME()
********************************************************************
** XML Packager - Builds vfp Replacement command,cursor structure **
** and XML Data roes                                              **
********************************************************************
llIgnoreMemos=.t. && Don't parse memos
llIgnoreAutos=.t. && Don't parse AutoIncrements
CLOSE DATABASES ALL 
* XML Store = the XML string will store in strXML
CREATE CURSOR curXML (strXML m)
* The File to be converted to an XML Packa
USE (ucDBF) IN 0
SELECT (ucDBF)
lcStructureHandle=SYS(2015)
lcdelStructureHandle=lcStructureHandle+[.*]
* There may be a better way to access the DBF header 
COPY STRUCTURE EXTENDED TO (lcStructureHandle)
USE (lcStructureHandle) IN 0
SELECT (lcStructureHandle)
IF llIgnoreMemos && Delete the memo fields from the structure
   DELETE ALL FOR ALLTRIM(field_type)$[G,M];
                  OR ALLTRIM(field_type)=[C] AND field_nocp
   PACK
ELSE 
ENDIF
IF llIgnoreAutos && Delete the memo fields from the structure
   DELETE ALL FOR ALLTRIM(field_type)$[I] AND field_next+field_step>0
   PACK
ELSE 
ENDIF
GO TOP 
* The cursor structure to be sent to the XML Receiver so that
* an EXECSCRIPT can create the cursors
lcTransmitStructure=[CREATE CURSOR curReceived (] 
* lcDBF_TO_XMLTags is used to convert the DBF being transmitted to
* a string for each record of field ptrs and values
lcDBF_TO_XMLTags=["<row>"]
* lcReplaceReceivedWith = will be used to update the cursor
* in the XML Receiver with the data inside the <row> tags
lcReplaceReceivedWith=[replace ]
* Build the Transmit Cusor Structure, The DBF 2 XML Parser
DO WHILE !EOF() &&Create a cursor create string from passed alias
                && Alias structure
* Build cursor structure 
lcTransmitStructure=lcTransmitStructure;
                  +ALLTRIM(field_name)+[ ]+ALLTRIM(field_type)+[(];
                  +TRANSFORM(field_len)+IIF([B]$field_type,[)],[,]+TRANSFORM(field_dec)+[)])
* Build DBF To XML Parser
lcDBF_TO_XMLTags=lcDBF_TO_XMLTags;
                +[+"<F]+TRANSFORM(RECNO())+[>"+ALLTRIM(TRANSFORM(]+ALLTRIM(field_name)+[));
                +"</F>"]
* Build Replacement String for curReceived
lcReplaceReceivedWith=lcReplaceReceivedWith+ALLTRIM(field_name)+[ with ]
if ALLTRIM(field_type)$[YLFNBI]
   * use EVALUATE for logical and numeric
   lcFieldOp=[EVALUATE(oRow.childNodes(]+TRANSFORM(RECNO()-1)+[).text)]
ELSE 
if ALLTRIM(field_type)$[D]
   * CTOD for Date types
   lcFieldOp=[CTOD(oRow.childNodes(]+TRANSFORM(RECNO()-1)+[).text)]
ELSE
if ALLTRIM(field_type)$[T]
   * CTOT for date times
   lcFieldOp=[CTOT(oRow.childNodes(]+TRANSFORM(RECNO()-1)+[).text)]
ELSE
   * FOr all others just the text
   lcFieldOp=[oRow.childNodes(]+TRANSFORM(RECNO()-1)+[).text]
ENDIF &&ALLTRIM(field_type)$[T] // Else
ENDIF &&ALLTRIM(field_type)$[D]
ENDIF &&ALLTRIM(field_type)$[YLFNBI]
lcReplaceReceivedWith=lcReplaceReceivedWith+lcFieldOp
SKIP
IF EOF()
   lcTransmitStructure=lcTransmitStructure+[)]
   lcDBF_TO_XMLTags=lcDBF_TO_XMLTags+[+"</row>"]
   lcReplaceReceivedWith=lcReplaceReceivedWith+[ IN curReceived]
ELSE
   lcTransmitStructure=lcTransmitStructure+[,]
   lcReplaceReceivedWith=lcReplaceReceivedWith+[,]
ENDIF
ENDDO
USE && close lcStructHandle
ERASE (lcdelStructureHandle)
lcXML=[<?xml version="1.0"?><dbf2xml>];
     +[<cursor>]+lcTransmitStructure+[</cursor>];
     +[<update>]+lcReplaceReceivedWith+[</update><rows>]
SELECT (ucDBF)
GO TOP 
DO WHILE !EOF()
* This parses the DBF fields to a <row> container
lcXML=lcXML+EVALUATE(lcDBF_TO_XMLTags)
SKIP
ENDDO
lcXML=lcXML+[</rows></dbf2xml>]
SELECT curXML
APPEND BLANK
* Our XML string is in a memo/notes field. An XML Message
* (HTTP GET) can retrieve from a foxISAPI MTDLL or ASP
REPLACE strXML WITH STRTRAN(lcXML,[&],[&amp;]) IN curXML
* END OF PACKAGER
XML2Cursor(curXML.strXML)

********************************************************************
**  Receiver Method - Loads XML From Packager - Creates a cursor  **
**  And parses embedded Tags to cursor "curReceived" packaged in  **
** <cursor> tag with VFP statements in update Node                **
********************************************************************
PROCEDURE XML2Cursor(lcXML)
* the XML object
lcErrorHandler=ON('error')
ON ERROR oXML=.NULL.
oXML=CREATEOBJECT("MSXML2.DOMDocument.4.0") &&Try an implicit connect to 4.0
ON ERROR &lcErrorHandler
IF ISNULL(oXML) && Can't get 4.0
   oXML=CREATEOBJECT("MSXML.DOMDocument") && Generic
ENDIF 
oXML.async=.f.
oXML.setProperty("SelectionLanguage","XPath")
oXML.loadXML(lcXML)
lcCreateCursorScript=;
  oXML.selectSingleNode("dbf2xml").selectSingleNode("cursor").text
* Create a receiving Cursor  
EXECSCRIPT(lcCreateCursorScript)
* The EXECSCRIPT "replace" cmd line
lcUpdate=oXML.selectSingleNode("dbf2xml").selectSingleNode("update").text
* oRows has the records each in it's own <row> node
oRows=oXML.selectSingleNode("dbf2xml").selectSingleNode("rows")
nMaxRows=oRows.childNodes.length-1 && Assuming no empty cursor
SELECT curReceived
FOR C=0 TO nMaxRows
oRow=oRows.childNodes(C)
APPEND BLANK
EXECSCRIPT(lcUpdate) && Beautiful
ENDFOR &&C=0 TO nMaxRows
* Cursor Complete
?[ENDED : ]+TIME()
BROWSE && THe received Cursor

********************************************************************
**                           Error Procedure                      **
********************************************************************
PROCEDURE errhand (merror, mess, mess1, mprog, mlineno) &&----------
on error
if messagebox('Error number           :'+LTRIM(STR(merror))+chr(13);
              +'Error message          :'+ mess+chr(13);
              +'Line of code with error:'+mess1+chr(13);
              +'Line number of error   :'+LTRIM(STR(mlineno))+chr(13);
              +'Alias                  :'+alias()+chr(13);
              +'Order()                :'+Order()+chr(13);
              +'Program with error     :'+mprog,1+48,[R6 Tape Error Trapped!])=2
   CANCEL
else
   ON ERROR DO errhand WITH ERROR( ), MESSAGE( ), MESSAGE(1), PROGRAM( ), LINENO( )
endif
ENDPROC && errhand
* END utDBFDOM