home *** CD-ROM | disk | FTP | other *** search
/ Total C++ 2 / TOTALCTWO.iso / vfp5.0 / vfp / tools / inetwiz / server / server.prg < prev    next >
Text File  |  1996-08-21  |  33KB  |  1,199 lines
  1. #DEFINE CRLF CHR(13)+CHR(10)
  2.  
  3. LOCAL lcProgram,lcFullPath,lnAtPos,lcFoxTools,lcError,lcFileName
  4. LOCAL lcScreenIcon,lcScreenCaption,lcSetPath,lnSelect
  5. PRIVATE gcINIFile,gcHTTPRoot,gcScriptRoot,gcSemaphoreRoot,gcPath
  6. EXTERNAL ARRAY JustPath,JustStem,AddBS
  7.  
  8.  
  9. SET TALK OFF
  10. SET ESCAPE OFF
  11. SET COLLATE TO 'MACHINE'
  12. SET COMPATIBLE OFF
  13. SET CONFIRM ON
  14. SET DECIMALS TO 9
  15. SET EXACT OFF
  16. SET EXCLUSIVE OFF
  17. SET MEMOWIDTH TO 1024
  18. SET MULTILOCKS ON
  19. SET POINT TO '.'
  20. SET SAFETY OFF
  21. SET UDFPARMS TO VALUE
  22. SET MESSAGE TO ' '
  23. lcProgram=SYS(16)
  24. lnAtPos=RAT('\',lcProgram)
  25. lcFullPath=LEFT(lcProgram,lnAtPos)
  26. CD (lcFullPath)
  27. lcFoxTools='foxtools.fll'
  28. IF NOT FILE(lcFoxTools)
  29.     lcFoxTools=HOME()+lcFoxTools
  30. ENDIF
  31. IF NOT FILE(lcFoxTools)
  32.     =MESSAGEBOX('Missing FOXTOOLS.FLL',16,_screen.Caption)
  33.     RETURN .F.
  34. ENDIF
  35. ON ERROR
  36. ERASE ERROR.txt
  37. SET LIBRARY TO (lcFoxTools) ADDITIVE
  38.  
  39. lnSelect=SELECT()
  40. lcSetPath=SET('PATH')
  41. lcOnError=ON('ERROR')
  42. lcScreenIcon=_screen.Icon
  43. _screen.Icon='net13.ico'
  44. lcScreenCaption=_screen.Caption
  45. _screen.Caption='WWW Data Server'
  46.  
  47. gcINIFile="vfpis.ini"
  48. gcHTTPRoot=""
  49. gcScriptRoot=""
  50. gcSemaphoreRoot=FULLPATH('\temp\')
  51. ON ERROR =.F.
  52. MD (gcSemaphoreRoot)
  53. ON ERROR
  54. gcPath=""
  55.  
  56. ON ERROR DO ErrorHandler WITH ERROR(),MESSAGE(),PROGRAM(),LINENO(),MESSAGE(1)
  57.  
  58. *Read the initialization file and set up root paths.  If the
  59. *INI file doesn't exist or is empty, ask the user to set one up.
  60.  
  61. IF FILE(gcINIFile)
  62.     =readini(gcINIFile)
  63. ENDIF
  64. IF EMPTY(gcHTTPRoot)
  65.     DO FORM SpecRoot
  66. ENDIF
  67. IF EMPTY(gcScriptRoot)
  68.     gcScriptRoot=gcHTTPRoot
  69. ENDIF
  70. SET PATH TO (gcPath)
  71. CLOSE ALL DATABASES
  72. CLOSE ALL
  73. lcFileName=LOWER(FULLPATH('querylog.dbf',lcProgram))
  74. IF NOT FILE(lcFileName)
  75.     CREATE TABLE (lcFileName) (TimeStamp T, IDCFile C(32), Parameters M)
  76.     USE
  77. ENDIF
  78. USE (lcFileName) ALIAS QueryLog EXCLUSIVE
  79.  
  80. DO FORM server
  81. CLOSE ALL DATABASES
  82. CLOSE ALL
  83. SELECT (lnSelect)
  84. IF NOT EMPTY(lcScreenCaption)
  85.     _screen.Caption=lcScreenCaption
  86. ENDIF
  87. IF NOT EMPTY(lcScreenIcon)
  88.     _screen.Icon=lcScreenIcon
  89. ENDIF
  90. SET MESSAGE TO
  91. SET PATH TO (lcSetPath)
  92. IF EMPTY(lcError)
  93.     ON ERROR
  94. ELSE
  95.     ON ERROR &lcError
  96. ENDIF
  97.  
  98. RETURN
  99.  
  100.  
  101.  
  102. FUNCTION executeprocess(tcFileName)
  103. LOCAL lcDataFile,lcAckFile,lnDFH,lnAFH,lcParameter
  104.  
  105.     lcDataFile=gcSemaphoreRoot+JustStem(ALLTRIM(tcFileName))+".dat"
  106.     lcAckFile=gcSemaphoreRoot+JustStem(ALLTRIM(tcFileName))+".ack"
  107.     lnDFH=FOPEN(lcDataFile)
  108.     lcParameter=""
  109.     IF lnDFH > 0
  110.         DO WHILE NOT FEOF(lnDFH)
  111.             lcParameter=lcParameter+FREAD(lnDFH,1000)
  112.         ENDDO
  113.         =FCLOSE(lnDFH)
  114.         ERASE (lcDataFile)
  115.         lcResultPage=GenPage(lcParameter)
  116.         lnDFH=FCREATE(lcDataFile)
  117.         =FWRITE(lnDFH,lcResultPage)
  118.         =FCLOSE(lnDFH)
  119.         lnAFH=FCREATE(lcAckFile)
  120.         * Create Acknowledgement file
  121.         =FCLOSE(lnAFH)
  122.     ELSE
  123.         * Error opening data file
  124.     ENDIF
  125. ENDFUNC
  126.  
  127.  
  128. * HTML Page Generation Program
  129. * This program takes a SQL Query, and several other parameters and
  130. * generates an output document in HTML which can be used by a WWW
  131. * Browser.
  132. * This function goes for bulletproof simple error handling when it is interpreting
  133. * an .HTX file.  If it runs into a logical error, it will simply attempt to continue.
  134. ****************
  135. FUNCTION genpage(cParameters)
  136.  
  137.     LOCAL lnAtPos,lcFileName,lcAlias
  138.     LOCAL lFailure, cResultPage, lcError, lnSelect
  139.     LOCAL cSQLStatement, cKeyColumn, cDescriptColumn, ;
  140.         cBackgroundImg, iCount, cTmpString, cPrevNext, ;
  141.         IDCFile, lcTemplate, lcLine, lcTmpLine, ;
  142.         lcLineCopy, lFailure, cExecSQLString, lhTemplate, llDone, ;
  143.         llGetNewLine, lcTmpExp, lcExp1, lcExp2, lcOperator, lcIfStatement, ;
  144.         lcTrueStatement, lcFalseStatement, lcHTMLPath, lcIDCFile, ;
  145.         lcDefErr, llDefaultError, lcReturnData, llReturnData
  146.  
  147.     *These symbols, we want available in the sub programs.  They will all be available,
  148.     *along with all of the parsed in environment variables, to the functions that execute
  149.     *conditionals and detail lines.  This allows those functions to simply utilize their
  150.     *environment.
  151.  
  152.     PRIVATE laEnvVariables, lnEnvVariables, IDC_DataSource, IDC_Template, ;
  153.         IDC_SQLStatement, IDC_DefaultParameters, IDC_Expires, IDC_MaxFieldSize, ;
  154.         IDC_Password, IDC_RequiredParameters, IDC_Username, laDefaultParameters, ;
  155.         laRequiredParameters, CurrentRecord, laTables, CommandSuccess, ;
  156.         lnRecordsReturned, IDC_MaxRecords
  157.  
  158.     CommandSuccess="FALSE"
  159.     lcAlias=''
  160.  
  161.     *Parse out all of the environment variables and HTML variables that are
  162.     *sent to us via the CGI script (contained in cParameters) and place them
  163.     *in an array for ease of reference.  The variables are placed in an array
  164.     *as VARIABLE_NAME, VALUE pairs.
  165.     lnEnvVariables=0
  166.     DIMENSION laEnvVariables[1,2]
  167.  
  168.     IF LEFT(cParameters,1)=='&'
  169.         cParameters=ALLTRIM(SUBSTR(cParameters,2))
  170.     ENDIF
  171.  
  172.     lnEnvVariables=ParseVars(cParameters,@laEnvVariables,.T.)
  173.  
  174.     *Parse out the contents of QUERY_STRING if it is not empty.
  175.     IF NOT EMPTY(getparam("QUERY_STRING"))
  176.         lnEnvVariables=ParseVars(getparam("QUERY_STRING"),@laEnvVariables)
  177.     ENDIF
  178.  
  179.     *Find out if the user has turned off default error processing for the
  180.     *executable command.
  181.     lcDefErr=getparam("DefError")
  182.     IF UPPER(ALLT(lcDefErr))=="OFF"
  183.         llDefaultError=.F.
  184.     ELSE
  185.         llDefaultError=.T.
  186.     ENDIF
  187.  
  188.     *Find out if the user would like the data back as a block of data.
  189.     lcReturnData=getparam("ReturnAsFile")
  190.     IF UPPER(ALLT(lcReturnData))=="ON"
  191.         llReturnData=.T.
  192.     ELSE
  193.         llReturnData=.F.
  194.     ENDIF
  195.  
  196.     *Build an absolute path representing where the calling HTML page was located.
  197.     lcHTMLPath=BldPath()
  198.  
  199.     *Get pointer to .IDC file via passed in HTML parameter
  200.     IDCFile=getparam("IDCFile")
  201.  
  202.     lcIDCFile=getparam("IDCFile")
  203.     IF NOT EMPTY(IDCFile)
  204.         IDCFile=LOWER(FULLPATH(lcIDCFile))
  205.         IF NOT FILE(IDCFile)
  206.             IDCFile=LOWER(FULLPATH(gcScriptRoot+lcIDCFile))
  207.             IF NOT FILE(IDCFile)
  208.                 IDCFile=LOWER(FULLPATH(lcHTMLPath+lcIDCFile))
  209.                 IF NOT FILE(IDCFile)
  210.                     IDCFile=LOWER(FULLPATH(gcHTTPRoot+lcIDCFile))
  211.                 ENDIF
  212.             ENDIF
  213.         ENDIF
  214.         IDCFile=LOWER(FULLPATH(IDCFile))
  215.     ENDIF
  216.  
  217.     *Append query log
  218.     lnSelect=SELECT()
  219.     SELECT QueryLog
  220.     IF RECCOUNT()>=1000
  221.         ZAP
  222.     ENDIF
  223.     INSERT INTO QueryLog (TimeStamp, IDCFile, Parameters) ;
  224.             VALUES (DATETIME(), lcIDCFile, cParameters)
  225.     SELECT 0
  226.  
  227.     IF EMPTY(IDCFile)
  228.         =Cleanup()
  229.         RETURN errorpage("No .IDC file was specified.  The server cannot continue.")
  230.     ENDIF
  231.     IF NOT FILE(IDCFile)
  232.         =Cleanup()
  233.         RETURN errorpage("Specified .IDC file ("+lcIDCFile+") not found.  The server cannot continue.")
  234.     ENDIF
  235.  
  236.     *Verify required IDC information
  237.     IDC_DataSource=parmsub(getidcp(IDCFile,"DataSource"))
  238.     IDC_Template=parmsub(getidcp(IDCFile,"Template"))
  239.     IF EMPTY(IDC_Template)
  240.         =Cleanup()
  241.         RETURN errorpage("Specified .IDC file ("+IDCFile+ ;
  242.             ") does not contain correct data or cannot be accessed."+ ;
  243.             "  The template entry could not be located.  The server cannot continue.")
  244.     ENDIF
  245.     IDC_SQLStatement=parmsub(getidcp(IDCFile,"SQLStatement"))
  246.     IF EMPTY(IDC_SQLStatement)
  247.         =Cleanup()
  248.         RETURN errorpage("Specified .IDC file ("+IDCFile+ ;
  249.             ") does not contain correct data or cannot be accessed."+ ;
  250.             "  The SQL statement entry could not be located.  The server cannot continue.")
  251.     ENDIF
  252.     DIMENSION laDefaultParameters(1,2)
  253.     IDC_DefaultParameters=getidcp(IDCFile,"DefaultParameters",@laDefaultParameters)
  254.     IDC_MaxRecords=VAL(parmsub(getidcp(IDCFile,"MaxRecords")))
  255.     IDC_UserName=parmsub(getidcp(IDCFile,"UserName"))
  256.     IDC_Password=parmsub(getidcp(IDCFile,"Password"))
  257.     IDC_Expires=parmsub(getidcp(IDCFile,"Expires"))
  258.     IDC_MaxFieldSize=parmsub(getidcp(IDCFile,"MaxFieldSize"))
  259.     DIMENSION laRequiredParameters(1,2)
  260.     IDC_RequiredParameters=getidcp(IDCFile,"RequiredParameters",@laRequiredParameters)
  261.     lcSQLStatement=IDC_SQLStatement
  262.     lcTemplate=IDC_Template
  263.  
  264.     *Save server settings
  265.     lcError = ON('ERROR')
  266.  
  267.     *Initialize result page
  268.     cResultPage = 'Content-Type: text/html'+CRLF+CRLF
  269.  
  270.     lFailure = .F.
  271.  
  272.     *Check to see whether we will be accessing an ODBC datasource or native data
  273.     IF EMPTY(IDC_DataSource)
  274.         *NATIVE DATA
  275.         cExecSQLString=lcSQLStatement
  276.         IF EMPTY(cExecSQLString)
  277.             =Cleanup()
  278.             RETURN errorpage("The SQL statement supplied by the IDC file could not be understood.  The server cannot continue.")
  279.         ENDIF
  280.  
  281.         *Execute SQL String and trap for a failure
  282.         _TALLY=0
  283.         lFailure = .F.
  284.         cSQLStatement=cExecSQLString
  285.         *Convert string to UPPERCASE, TRIM, and remove TABs for easy
  286.         *syntax checking.
  287.         cExecSQLString=UPPER(ALLTRIM(STRTRAN(cExecSQLString,CHR(9),' ')))
  288.         *Special case the general SELECT statement without an INTO (the default
  289.         *for Wizard generated stuff.)
  290.         IF cExecSQLString="SELECT " AND ATC(" INTO ",cExecSQLString)=0
  291.             * cExecSQLString needs to carry through the case sensitivity of the
  292.             * original SQL SELECT
  293.             cExecSQLString = cSQLStatement + " INTO CURSOR TempResult"
  294.         ELSE
  295.             IF cExecSQLString="SELECT " OR;
  296.                     cExecSQLString="DELETE " OR;
  297.                     cExecSQLString="INSERT " OR;
  298.                     cExecSQLString="UPDATE " OR;
  299.                     cExecSQLString="ALTER TABLE " OR;
  300.                     cExecSQLString="CREATE CURSOR " OR;
  301.                     cExecSQLString="CREATE TABLE "
  302.                 * cExecSQLString needs to carry through the case sensitivity of the
  303.                 * original SQL SELECT
  304.                 cExecSQLString = cSQLStatement
  305.             ELSE
  306.                 lFailure = .T.
  307.             ENDIF
  308.         ENDIF
  309.         * At this point, if there has been some error evaluating the SQL statement,
  310.         * or if the SQL statement is not one of the above valid types, the lFailure
  311.         * flag is set, and the SQL statement will not be executed.
  312.         IF NOT lFailure
  313.             lnAtPos=ATC(' FROM ',cExecSQLString)
  314.             IF lnAtPos>0
  315.                 lcAlias=ALLTRIM(SUBSTR(cExecSQLString,lnAtPos+6))
  316.                 lnAtPos=AT(' ',lcAlias)
  317.                 IF lnAtPos>0
  318.                     lcAlias=ALLTRIM(LEFT(lcAlias,lnAtPos-1))
  319.                 ENDIF
  320.                 IF LEFT(lcAlias,1)=="'" OR LEFT(lcAlias,1)=='"' OR ;
  321.                         LEFT(lcAlias,1)=='['
  322.                     lcAlias=EVALUATE(lcAlias)
  323.                 ENDIF
  324.                 lcAlias=UPPER(lcAlias)
  325.                 lcFileName=LOWER(lcAlias)
  326.                 lnAtPos=AT('.',lcAlias)
  327.                 IF lnAtPos>0
  328.                     lcAlias=ALLTRIM(LEFT(lcAlias,lnAtPos-1))
  329.                 ENDIF
  330.                 IF NOT '.'$lcFileName
  331.                     lcFileName=lcFileName+'.dbf'
  332.                 ENDIF
  333.                 lcFileName=LOWER(lcFileName)
  334.                 IF NOT FILE(lcFileName)
  335.                     =Cleanup()
  336.                     RETURN errorpage('The SQL statement FROM table ['+lcFileName+'] not found.<BR>'+ ;
  337.                         'Table specified must be in PATH of data server specified in VFPIS.INI.<BR>'+CRLF+ ;
  338.                         'SQL String: <HR>'+cSQLStatement)
  339.                 ENDIF
  340.             ENDIF
  341.             ON ERROR lFailure = .T.
  342.             &cExecSQLString
  343.             ON ERROR &lcError
  344.             IF USED(lcAlias)
  345.                 USE IN (lcAlias)
  346.             ENDIF
  347.         ENDIF
  348.  
  349.  
  350.         IF lFailure = .T.
  351.             IF llDefaultError
  352.                 =Cleanup()
  353.                 RETURN errorpage('The command generated an error.<BR>'+ ;
  354.                     'Please Contact the system administrator.<BR>'+CRLF+ ;
  355.                     'SQL String: <HR>'+cSQLStatement)
  356.             ELSE
  357.                 CommandSuccess="FALSE"
  358.             ENDIF
  359.         ELSE
  360.             CommandSuccess="TRUE"
  361.         ENDIF
  362.  
  363.         lnRecordsReturned=_TALLY
  364.         IF lnRecordsReturned = 0
  365.             CurrentRecord=0
  366.         ELSE
  367.             CurrentRecord=1
  368.             IF llReturnData
  369.                 RETURN makedata()
  370.             ENDIF
  371.         ENDIF
  372.  
  373.     ELSE
  374.         cExecSQLString=lcSQLStatement
  375.         IF EMPTY(cExecSQLString)
  376.             =Cleanup()
  377.             RETURN errorpage("The SQL statement supplied by the IDC file could not be understood.  The server cannot continue.")
  378.         ENDIF
  379.  
  380.         lnConn=SQLCONNECT(IDC_DataSource,IDC_Username,IDC_Password)
  381.         IF lnConn <= 0
  382.             =Cleanup()
  383.             RETURN errorpage("The connection to "+IDC_DataSource+" as "+IDC_Username+" could not be made.  The server cannot continue.")
  384.         ENDIF
  385.  
  386.         *Execute SQL String and trap for a failure
  387.         cSQLStatement=cExecSQLString
  388.  
  389.         lnExecRet=0
  390.         DO WHILE lnExecRet=0
  391.             lnExecRet = SQLEXEC(lnConn,cSQLStatement,'TempResult')
  392.         ENDDO
  393.  
  394.         IF lnExecRet < 0
  395.             lFailure = .T.
  396.         ENDIF
  397.  
  398.         =SQLDISCONNECT(lnConn)
  399.  
  400.         IF lFailure = .T.
  401.             IF llDefaultError
  402.                 =Cleanup()
  403.                 RETURN errorpage('The command generated an error.<BR>'+ ;
  404.                     'Please Contact the system administrator.<BR>'+CRLF+ ;
  405.                     'SQL String: <HR>'+cSQLStatement)
  406.             ELSE
  407.                 CommandSuccess="FALSE"
  408.             ENDIF
  409.         ELSE
  410.             CommandSuccess="TRUE"
  411.         ENDIF
  412.  
  413.         lnRecordsReturned=RECCOUNT('TempResult')
  414.         IF lnRecordsReturned = 0
  415.             CurrentRecord=0
  416.         ELSE
  417.             CurrentRecord=1
  418.             IF llReturnData
  419.                 =Cleanup()
  420.                 RETURN makedata()
  421.             ENDIF
  422.         ENDIF
  423.  
  424.     ENDIF
  425.  
  426.     *Create HTML return page from .HTX and data
  427.  
  428.     *Verify the existence of the Template (.HTX) file.  It must be next to the .IDC file,
  429.     *pathed relative to the .IDC file, or in the Script root.
  430.     lcTmpFile=lcTemplate
  431.     lcTemplate=addbs(justpath(IDCFile))+lcTemplate
  432.     IF NOT FILE(lcTemplate)
  433.         lcTemplate=gcScriptRoot+lcTmpFile
  434.         IF NOT FILE(lcTemplate)
  435.             =Cleanup()
  436.             RETURN errorpage('The template file could not be located.  The server cannot continue.')
  437.         ENDIF
  438.     ENDIF
  439.  
  440.     lhTemplate=FOPEN(lcTemplate)
  441.     IF lhTemplate < 0
  442.         =Cleanup()
  443.         RETURN errorpage('The template file ('+lcTemplate+') could not be opened successfully.  The server cannot continue.')
  444.     ENDIF
  445.  
  446.     llGetNewLine=.T.
  447.  
  448.     DO WHILE NOT FEOF(lhTemplate)
  449.         IF llGetNewLine
  450.             lcLine=FGETS(lhTemplate)
  451.         ELSE
  452.             *Toggle GetNewLine back to True
  453.             llGetNewLine=.T.
  454.         ENDIF
  455.         lcLineCopy=UPPER(lcLine)
  456.         DO CASE
  457.             *The BeginDetail structure is linear, but must be repeated for
  458.             *each record in the return set.  IFs can be nested within a Detail
  459.             *section, so, once the detail section is loaded, it must be parsed
  460.             *for IFs.  However
  461.         CASE "<%BEGINDETAIL%>" $ lcLineCopy
  462.             *If the BEGINDETAIL is not at the beginning of the line, put the
  463.             *prefix into the Result page.  Then work on the detail chunk.
  464.             IF lcLineCopy != "<%BEGINDETAIL%>"
  465.                 cResultPage=cResultPage+SUBSTR(lcLine,1,AT("<%BEGINDETAIL%>",lcLineCopy)-1)
  466.                 lcLine=SUBSTR(lcLine,AT("<%BEGINDETAIL%>",lcLineCopy)+15)+CRLF
  467.             ELSE
  468.                 *If there's stuff after the BEGINDETAIL symbol, stuff it into the lcLine
  469.                 IF LEN(lcLine)>LEN("<%BEGINDETAIL%>")
  470.                     lcLine=SUBSTR(lcLine,16)
  471.                 ELSE
  472.                     lcLine=""
  473.                 ENDIF
  474.             ENDIF
  475.             llDone=.F.
  476.             IF NOT EMPTY(lcLine)
  477.                 IF "<%ENDDETAIL%>" $ UPPER(lcLine)
  478.                     lcTmpLine=lcLine
  479.                     IF UPPER(lcTmpLine)!="<%ENDDETAIL%>"
  480.                         lcLine=SUBSTR(lcTmpLine,1,AT("<%ENDDETAIL%>",UPPER(lcTmpLine))-1)
  481.                     ENDIF
  482.                     IF LEN(lcTmpLine)>LEN("<%ENDDETAIL%>")
  483.                         lcSuffix=SUBSTR(lcTmpLine,AT("<%ENDDETAIL%>",UPPER(lcTmpLine))+13)
  484.                     ELSE
  485.                         lcSuffix=""
  486.                     ENDIF
  487.                     llDone=.T.
  488.                 ENDIF
  489.             ENDIF
  490.             DO WHILE NOT llDone AND NOT FEOF(lhTemplate)
  491.                 lcTmpLine=FGETS(lhTemplate)
  492.                 IF NOT("<%ENDDETAIL%>" $ UPPER(lcTmpLine))
  493.                     *Add to the block until you hit an ENDDETAIL
  494.                     lcLine=lcLine+lcTmpLine+CRLF
  495.                 ELSE
  496.                     *Add everything up to the beginning of the ENDDETAIL and store everything
  497.                     *afterward in lcSuffix for processing later.
  498.                     IF UPPER(lcTmpLine)!="<%ENDDETAIL%>"
  499.                         lcLine=lcLine+SUBSTR(lcTmpLine,1,AT("<%ENDDETAIL%>",UPPER(lcTmpLine))-1)
  500.                     ENDIF
  501.                     IF LEN(lcTmpLine)>LEN("<%ENDDETAIL%>")
  502.                         lcSuffix=SUBSTR(lcTmpLine,AT("<%ENDDETAIL%>",UPPER(lcTmpLine))+13)
  503.                     ELSE
  504.                         lcSuffix=""
  505.                     ENDIF
  506.                     llDone=.T.
  507.                 ENDIF
  508.             ENDDO
  509.             IF NOT llDone
  510.                 *Error: Mismatched Begin/EndDetail, close template file and exit
  511.                 =FCLOSE(lhTemplate)
  512.                 =Cleanup()
  513.                 RETURN errorpage("The template file ("+lcTemplate+") contained a mismatched BeginDetail/EndDetail structure.  The server cannot continue.")
  514.             ENDIF
  515.             IF lnRecordsReturned > 0
  516.                 lcDetailExec=''
  517.                 DO WHILE AT("<%",lcLine) > 0
  518.                     lcDetailExec=lcDetailExec+'"'+STRTRAN(SUBSTR(lcLine,1,AT("<%",lcLine)-1),'"','"+["]+"')+'"+'
  519.                     lcLine=SUBSTR(lcLine,AT("<%",lcLine))
  520.                     IF UPPER(lcLine)="<%IF "
  521.                         *Process the IF structure into an IIF
  522.                         *Trim the IF and ENDIF symbols.
  523.                         lcIfStatement=SUBSTR(lcLine,6,AT("<%ENDIF%>",UPPER(lcLine))-6)
  524.                         *Strip out Expression 1, Expression 2, and the Operator
  525.                         lcExp1=ALLT(SUBSTR(lcIfStatement,1,AT(" ",lcIfStatement)-1))
  526.                         lcIfStatement=ALLT(SUBSTR(lcIfStatement,AT(" ",lcIfStatement)))
  527.                         lcOperator=ALLT(SUBSTR(lcIfStatement,1,AT(" ",lcIfStatement)-1))
  528.                         lcIfStatement=ALLT(SUBSTR(lcIfStatement,AT(" ",lcIfStatement)))
  529.                         lcExp2=ALLT(SUBSTR(lcIfStatement,1,AT("%>",lcIfStatement)-1))
  530.                         lcIfStatement=SUBSTR(lcIfStatement,AT("%>",lcIfStatement)+2)
  531.                         IF NOT('"'$lcExp1 OR "'"$lcExp1 OR '['$lcExp1)
  532.                             lcExp1=UPPER(lcExp1)
  533.                             lcExp1=STRTRAN(lcExp1,"IDC.","IDC_")
  534.                         ENDIF
  535.                         IF NOT('"'$lcExp2 OR "'"$lcExp2 OR '['$lcExp2)
  536.                             lcExp2=UPPER(lcExp2)
  537.                             lcExp2=STRTRAN(lcExp2,"IDC.","IDC_")
  538.                         ENDIF
  539.                         lcOperator=UPPER(lcOperator)
  540.                         DO CASE
  541.                         CASE lcOperator="CONTAINS"
  542.                             lcTmpExp=lcExp2
  543.                             lcExp2=lcExp1
  544.                             lcExp1=lcTmpExp
  545.                             lcOperator="$"
  546.                         CASE lcOperator="EQ"
  547.                             lcOperator="="
  548.                         CASE lcOperator="GT"
  549.                             lcOperator=">"
  550.                         CASE lcOperator="LT"
  551.                             lcOperator="<"
  552.                         ENDCASE
  553.                         IF "<%ELSE%>"$UPPER(lcIfStatement)
  554.                             lcTrueStatement=SUBSTR(lcIfStatement,1,AT("<%ELSE%>",UPPER(lcIfStatement))-1)
  555.                             lcIfStatement=SUBSTR(lcIfStatement,AT("<%ELSE%>",UPPER(lcIfStatement))+8)
  556.                             lcFalseStatement=lcIfStatement
  557.                             lcFalseStatement=STRTRAN(lcFalseStatement,'"','"+["]+"')
  558.                         ELSE
  559.                             lcTrueStatement=lcIfStatement
  560.                             lcFalseStatement=""
  561.                         ENDIF
  562.                         lcTrueStatement=STRTRAN(lcTrueStatement,'"','"+["]+"')
  563.                         lcIIF='IIF('+lcExp1+lcOperator+lcExp2+',"'+lcTrueStatement+'","'+lcFalseStatement+'")+'
  564.                         lcDetailExec=lcDetailExec+lcIIF
  565.                         IF LEN(lcLine)>AT("<%ENDIF%>",UPPER(lcLine))+9
  566.                             lcLine=SUBSTR(lcLine,AT("<%ENDIF%>",UPPER(lcLine))+9)
  567.                         ELSE
  568.                             lcLine=""
  569.                         ENDIF
  570.                     ELSE
  571.                         *This is a symbol structure.  If it is valid, extract the symbol and place it into
  572.                         *the executable line.
  573.                         IF AT("%>",lcLine)=0
  574.                             =FCLOSE(lhTemplate)
  575.                             =Cleanup()
  576.                             RETURN errorpage("The detail line in "+lcTemplate+" contains a mismatched symbol structure.  The server cannot continue.")
  577.                         ENDIF
  578.                         lcSymbol=SUBSTR(lcLine,3,AT("%>",lcLine)-3)
  579.                         lcDetailExec=lcDetailExec+'EXPTOC('+ALLT(lcSymbol)+')+'
  580.                         IF LEN(lcLine)>LEN(lcSymbol)+4
  581.                             lcLine=SUBSTR(lcLine,AT("%>",lcLine)+2)
  582.                         ELSE
  583.                             lcLine=""
  584.                         ENDIF
  585.                     ENDIF
  586.                 ENDDO
  587.                 lcDetailExec=lcDetailExec+'"'+STRTRAN(lcLine,'"','"+["]+"')+'"'
  588.                 =DetailEx(lcDetailExec,@laEnvVariables,@cResultPage)
  589.             ENDIF
  590.             *If the suffix has stuff to process, then don't get a new file line, start with the suffix.
  591.             IF NOT EMPTY(lcSuffix)
  592.                 llGetNewLine=.F.
  593.                 lcLine=lcSuffix
  594.             ENDIF
  595.         CASE "<%IF" $ lcLineCopy
  596.             IF lcLineCopy != "<%IF "
  597.                 cResultPage=cResultPage+SUBSTR(lcLine,1,AT("<%IF ",lcLineCopy)-1)
  598.                 lcLine=SUBSTR(lcLine,AT("<%IF ",lcLineCopy)+5)+CRLF
  599.             ELSE
  600.                 IF LEN(lcLine)>LEN("<%IF ")
  601.                     lcLine=SUBSTR(lcLine,5)
  602.                 ELSE
  603.                     =FCLOSE(lhTemplate)
  604.                     =Cleanup()
  605.                     RETURN errorpage("The template file contained an improperly formed IF construct.  The server cannot continue.")
  606.                 ENDIF
  607.             ENDIF
  608.             llDone=.F.
  609.             DO WHILE NOT llDone AND NOT FEOF(lhTemplate)
  610.                 lcTmpLine=FGETS(lhTemplate)
  611.                 IF NOT("<%ENDIF%>" $ UPPER(lcTmpLine))
  612.                     lcLine=lcLine+lcTmpLine+CRLF
  613.                 ELSE
  614.                     *Add everything up to the beginning of the ENDIF and store everything
  615.                     *afterward in lcSuffix for processing later.
  616.                     IF UPPER(lcTmpLine)!="<%ENDIF%>"
  617.                         lcLine=lcLine+SUBSTR(lcTmpLine,1,AT("<%ENDIF%>",UPPER(lcTmpLine))-1)
  618.                     ENDIF
  619.                     IF LEN(lcTmpLine)>LEN("<%ENDIF%>")
  620.                         lcSuffix=SUBSTR(lcTmpLine,AT("<%ENDIF%>",UPPER(lcTmpLine))+9)
  621.                     ELSE
  622.                         lcSuffix=""
  623.                     ENDIF
  624.                     llDone=.T.
  625.                 ENDIF
  626.             ENDDO
  627.             IF NOT llDone
  628.                 *Error: Mismatched If/Endif, close template file and exit
  629.                 =FCLOSE(lhTemplate)
  630.                 =Cleanup()
  631.                 RETURN errorpage("The template file ("+lcTemplate+") contained a mismatched If/EndIf structure.  The server cannot continue.")
  632.             ENDIF
  633.             *At this point, the entire structure between the <%IF and the <%ENDIF%> non inclusive is
  634.             *in lcLine.  This will include the conditional parameters and an <%ELSE%> if such a thing exists.
  635.             *In addition, everything after the structure will be contained in lcSuffix.
  636.             lcIfStatement=LTRIM(lcLine)
  637.             *Strip out Expression 1, Expression 2, and the Operator
  638.             lcExp1=ALLT(SUBSTR(lcIfStatement,1,AT(" ",lcIfStatement)-1))
  639.             lcIfStatement=ALLT(SUBSTR(lcIfStatement,AT(" ",lcIfStatement)))
  640.             lcOperator=ALLT(SUBSTR(lcIfStatement,1,AT(" ",lcIfStatement)-1))
  641.             lcIfStatement=ALLT(SUBSTR(lcIfStatement,AT(" ",lcIfStatement)))
  642.             lcExp2=ALLT(SUBSTR(lcIfStatement,1,AT("%>",lcIfStatement)-1))
  643.             lcIfStatement=SUBSTR(lcIfStatement,AT("%>",lcIfStatement)+2)
  644.             *If the expressions aren't character literals, make them uppercase
  645.             *for case insensitivity.  Also check to see if they reference IDC.
  646.             *variables at this point.
  647.             IF NOT('"'$lcExp1 OR "'"$lcExp1 OR '['$lcExp1)
  648.                 lcExp1=UPPER(lcExp1)
  649.                 lcExp1=STRTRAN(lcExp1,"IDC.","IDC_")
  650.             ENDIF
  651.             IF NOT('"'$lcExp2 OR "'"$lcExp2 OR '['$lcExp2)
  652.                 lcExp2=UPPER(lcExp2)
  653.                 lcExp2=STRTRAN(lcExp2,"IDC.","IDC_")
  654.             ENDIF
  655.             lcOperator=UPPER(lcOperator)
  656.             DO CASE
  657.             CASE lcOperator="CONTAINS"
  658.                 lcTmpExp=lcExp2
  659.                 lcExp2=lcExp1
  660.                 lcExp1=lcTmpExp
  661.                 lcOperator="$"
  662.             CASE lcOperator="EQ"
  663.                 lcOperator="="
  664.             CASE lcOperator="GT"
  665.                 lcOperator=">"
  666.             CASE lcOperator="LT"
  667.                 lcOperator="<"
  668.             ENDCASE
  669.             IF "<%ELSE%>"$UPPER(lcIfStatement)
  670.                 lcTrueStatement=SUBSTR(lcIfStatement,1,AT("<%ELSE%>",UPPER(lcIfStatement))-1)
  671.                 lcIfStatement=SUBSTR(lcIfStatement,AT("<%ELSE%>",UPPER(lcIfStatement))+8)
  672.                 lcFalseStatement=lcIfStatement
  673.             ELSE
  674.                 lcTrueStatement=lcIfStatement
  675.                 lcFalseStatement=""
  676.             ENDIF
  677.             IF EvalCond(lcExp1+lcOperator+lcExp2,@laEnvVariables)
  678.                 lcLine=lcTrueStatement+lcSuffix
  679.             ELSE
  680.                 lcLine=lcFalseStatement+lcSuffix
  681.             ENDIF
  682.             IF NOT EMPTY(lcLine)
  683.                 llGetNewLine=.F.
  684.             ENDIF
  685.         OTHERWISE
  686.             cResultPage=cResultPage+lcLine+CRLF
  687.         ENDCASE
  688.     ENDDO
  689.     IF lnRecordsReturned=0
  690.         cResultPage=cResultPage+'No matches found.'+CRLF
  691.     ENDIF
  692.  
  693.     *Append query log
  694.     lnSelect=SELECT()
  695.     SELECT QueryLog
  696.     INSERT INTO QueryLog (TimeStamp, IDCFile, Parameters) ;
  697.             VALUES (DATETIME(), lcIDCFile, 'Returned')
  698.     SELECT 0
  699.  
  700.     =FCLOSE(lhTemplate)
  701.  
  702.     =Cleanup()
  703.     RETURN cResultPage
  704.  
  705. PROCEDURE Cleanup()
  706.     LOCAL lnCount
  707.  
  708.     IF USED('TempResult')
  709.         USE IN TempResult
  710.     ENDIF
  711.  
  712. PROCEDURE errorpage (lcErrorMessage)
  713.     LOCAL cResultPage
  714.     cResultPage = 'Content-Type: text/html'+CRLF+CRLF
  715.  
  716.     cResultPage = cResultPage + ;
  717.         '<html><head><title>FoxPro Search Failed</title></head>'+ ;
  718.         CRLF
  719.     cResultPage = cResultPage + ;
  720.         '<body>'+CRLF
  721.     cResultPage = cResultPage + ;
  722.         '<h1>FoxPro Search Failed</h1>'+CRLF
  723.  
  724.     cResultPage = cResultPage + ;
  725.         ' '+ALLT(lcErrorMessage)+'<hr></body></html>'+CRLF
  726.  
  727.     RETURN cResultPage
  728.  
  729. FUNCTION FormFld(FldValue)
  730.     FldValue=STRTRAN(FldValue,CRLF,"<BR>")
  731.     IF RIGHT(FldValue,4)="<BR>"
  732.         FldValue=SUBSTR(FldValue,1,LEN(FldValue)-4)
  733.     ENDIF
  734.     RETURN FldValue
  735.  
  736. FUNCTION Findmkl(cKeyColumn)
  737.     PRIVATE Curlen, MAXLEN
  738.     Curlen=0
  739.     MAXLENGTH=0
  740.  
  741.     SCAN
  742.         Curlen=LEN(ALLT(EVAL(cKeyColumn)))
  743.         IF Curlen > MAXLEN
  744.             MAXLENGTH=Curlen
  745.         ENDIF
  746.     ENDSCAN
  747.     GO TOP
  748.  
  749.     RETURN MAXLEN
  750.  
  751. FUNCTION MakeData
  752.     LOCAL cResultPage,cFileName,nFH,nFSize
  753.     cResultPage="<Content-type:text/plain>"+CRLF
  754.     cFileName=SYS(3)+'.TXT'
  755.     SELECT TempResult
  756.     IF IDC_MaxRecords > 0
  757.         LIST NEXT IDC_MaxRecords TO FILE (cFileName) NOCONSOLE
  758.     ELSE
  759.         LIST TO FILE (cFileName) NOCONSOLE
  760.     ENDIF
  761.     nFH=FOPEN(cFileName)
  762.  
  763.     IF nFH > 0
  764.         nFSize=FSEEK(nFH,0,2)
  765.         =FSEEK(nFH,0,0)
  766.         cResultPage=cResultPage+FREAD(nFH,nFSize)
  767.     ELSE
  768.         RETURN ErrorPage("An error occurred trying to create your data stream.  The server cannot continue.")
  769.     ENDIF
  770.     =FCLOSE(nFH)
  771.     ERASE (cFileName)
  772.     RETURN cResultPage
  773.  
  774.  
  775.  
  776. FUNCTION bldpath
  777.     LOCAL lcPath, lcRefer, lcSubPath
  778.  
  779.     lcPath=gcHTTPRoot
  780.  
  781.     lcRefer=getparam("HTTP_REFERER")
  782.     IF NOT EMPTY(lcRefer)
  783.         lcRefer=STRTRAN(lcRefer,"//","")
  784.         lcRefer=STRTRAN(lcRefer,"/","\")
  785.         lcRefer=SUBSTR(lcRefer,AT("\",lcRefer)+1)
  786.         lcRefer=LEFT(lcRefer,RAT("\",lcRefer))
  787.     ENDIF
  788.  
  789.     lcPath=lcPath+lcRefer
  790.  
  791.     RETURN lcPath
  792.  
  793.  
  794.  
  795. FUNCTION DetailEx(lcDetailLine,laSymbolTable,cResultPage)
  796.     EXTERNAL ARRAY laSymbolTable
  797.     LOCAL lnMaxRecords,lnCount
  798.  
  799.     IF IDC_MaxRecords > 0
  800.         lnMaxRecords=MIN(IDC_MaxRecords,lnRecordsReturned)
  801.     ELSE
  802.         lnMaxRecords=lnRecordsReturned
  803.     ENDIF
  804.  
  805.     *Execute IIF with local environment
  806.     lcDetailLine=STRTRAN(lcDetailLine,CRLF,"")
  807.  
  808.     SELECT TempResult
  809.  
  810.     lnCount=0
  811.     SCAN REST
  812.         IF lnCount>=lnMaxRecords
  813.             EXIT
  814.         ENDIF
  815.         lnCount=lnCount+1
  816.         cResultPage=cResultPage+EVALUATE(lcDetailLine)
  817.         cResultPage=cResultPage+CRLF
  818.         CurrentRecord=CurrentRecord+1
  819.     ENDSCAN
  820.  
  821.     IF CurrentRecord > 0
  822.         CurrentRecord=1
  823.     ENDIF
  824.  
  825.     RETURN
  826.  
  827.  
  828.  
  829.     *This function takes a conditional statement and evaluates it based on the
  830.     *entire environment state at this time.
  831.  
  832. FUNCTION EvalCond(lcConditional,laSymbolTable)
  833.     EXTERNAL ARRAY laSymbolTable
  834.  
  835.     RETURN EVALUATE(lcConditional)
  836.  
  837.  
  838.  
  839. FUNCTION exptoc(eExprVal)
  840.  
  841.     DO CASE
  842.     CASE ISNULL(eExprVal)
  843.         RETURN 'NULL'
  844.     CASE TYPE('eExprVal') $ 'CM'
  845.         RETURN ALLTRIM(eExprVal)
  846.     CASE TYPE('eExprVal') $ 'NFYB'
  847.         RETURN ALLTRIM(STR(eExprVal))
  848.     CASE TYPE('eExprVal') $ 'L'
  849.         RETURN ALLTRIM(IIF(eExprVal,'TRUE','FALSE'))
  850.     CASE TYPE('eExprVal') $ 'D'
  851.         RETURN ALLTRIM(DTOC(eExprVal))
  852.     CASE TYPE('eExprVal') $ 'T'
  853.         RETURN ALLTRIM(TTOC(eExprVal))
  854.     OTHERWISE
  855.         RETURN '*****'
  856.     ENDCASE
  857.  
  858.  
  859.  
  860.     * Function GETIDCP (Get IDC Parameters)
  861.     * Fetches requested parameter from the IDC file and returns the
  862.     * value as a character string.  This function has a polymorphic
  863.     * return type: in the case where the DefaultParameters parameter is
  864.     * fetched, the function returns a numeric value indicating how many
  865.     * default parameters were fetched.  The parameters and values are stored
  866.     * in the passed-by-reference array as a parameter,value pair.
  867.     * Errors result in the null string being returned.
  868.  
  869. FUNCTION getidcp(cIDCFile,cParameter,aDefArray)
  870.  
  871.     IF PARAMETERS()<2
  872.         RETURN ""
  873.     ENDIF
  874.  
  875.     llFound=.F.
  876.  
  877.     cParameter=ALLT(cParameter)
  878.     cIDCFile=ALLT(cIDCFile)
  879.  
  880.     lhIDC=FOPEN(cIDCFile)
  881.  
  882.     IF lhIDC < 0
  883.         RETURN ""
  884.     ENDIF
  885.  
  886.     DO WHILE NOT llFound AND NOT FEOF(lhIDC)
  887.         lcLine=FGETS(lhIDC)
  888.         IF NOT EMPTY(lcLine)
  889.             lcLineTok=UPPER(STRTRAN(lcLine," ",""))
  890.             IF (UPPER(cParameter)+":")$lcLineTok
  891.                 llFound=.T.
  892.             ENDIF
  893.         ENDIF
  894.     ENDDO
  895.  
  896.     IF NOT llFound
  897.         =FCLOSE(lhIDC)
  898.         RETURN ""
  899.     ENDIF
  900.  
  901.     llDone=.F.
  902.     DO WHILE NOT llDone AND NOT FEOF(lhIDC)
  903.         lcAddLine=ALLT(FGETS(lhIDC))
  904.         IF LEFT(lcAddLine,1) = "+"
  905.             lcLine=lcLine+" "+ALLT(SUBSTR(lcAddLine,2))
  906.         ELSE
  907.             llDone=.T.
  908.         ENDIF
  909.     ENDDO
  910.  
  911.     =FCLOSE(lhIDC)
  912.  
  913.     *Add filler so AT will never fail.
  914.     lcLine=lcLine+" "
  915.  
  916.     lcValue=LTRIM(SUBSTR(lcLine,AT(":",lcLine)+1))
  917.  
  918.     IF UPPER(cParameter)="DEFAULTPARAMETERS" OR UPPER(cParameter)="REQUIREDPARAMETERS"
  919.         lnParameters=0
  920.         DO WHILE AT("=",lcValue)>0
  921.             * Add filler so loop works in 0 case
  922.             lcValue=lcValue+", "
  923.             lnParameters=lnParameters+1
  924.             DIMENSION aDefArray(lnParameters,2)
  925.             aDefArray(lnParameters,1)=ALLT(SUBSTR(lcValue,1,AT("=",lcValue)-1))
  926.             aDefArray(lnParameters,2)=ALLT(SUBSTR(lcValue,AT("=",lcValue)+1,AT(",",lcValue)-(AT("=",lcValue)+1)))
  927.             lcValue=SUBSTR(lcValue,AT(",",lcValue)+1)
  928.         ENDDO
  929.         RETURN lnParameters
  930.     ENDIF
  931.  
  932.     RETURN lcValue
  933.  
  934.  
  935.  
  936. FUNCTION getparam
  937.     LPARAMETER cVar
  938.     EXTERNAL ARRAY laEnvVariables
  939.  
  940.     LOCAL nLocation, llDone, nFrom
  941.  
  942.     llDone=.F.
  943.     nFrom=1
  944.  
  945.     *Find the given variable in the first column of the environment variables array if
  946.     *it's there at all.
  947.     DO WHILE llDone=.F.
  948.         nLocation=ASCAN(laEnvVariables,cVar,nFrom)
  949.         IF nLocation=0
  950.             llDone=.T.
  951.         ELSE
  952.             IF ASUBSCRIPT(laEnvVariables,nLocation,2) = 1
  953.                 llDone=.T.
  954.             ELSE
  955.                 nFrom=nLocation+1
  956.             ENDIF
  957.         ENDIF
  958.     ENDDO
  959.  
  960.     IF nLocation > 0
  961.         RETURN laEnvVariables[ASUBSCRIPT(laEnvVariables,nLocation+1,1),ASUBSCRIPT(laEnvVariables,nLocation+1,2)]
  962.     ELSE
  963.         RETURN ""
  964.     ENDIF
  965.  
  966.  
  967.  
  968. FUNCTION GetToken(INSTR,innum,insep)
  969.     **  GetToken.
  970.     **    Parameters:
  971.     **    1) Input string to be parsed.
  972.     **  2) Number of token to return.
  973.     **    3) The delimiter that seperates tokens.  (Default ",")
  974.     PRIVATE ALL
  975.  
  976.     IF PARAM() < 2
  977.         RETURN ""
  978.     ENDIF
  979.  
  980.     IF PARAM() < 3
  981.         insep = ","
  982.     ENDIF
  983.  
  984.     maxnum = OCCURS(insep,INSTR)
  985.  
  986.     DO CASE
  987.     CASE innum <= 0
  988.         rval = ""
  989.     CASE maxnum = 0 AND innum = 1
  990.         rval = INSTR
  991.     CASE maxnum = 0 AND innum > 1
  992.         rval = ""
  993.     CASE maxnum > 0 AND innum = 1
  994.         rval = SUBSTR(INSTR,1,ATC(insep,INSTR)-1)
  995.     CASE innum = maxnum + 1 AND LEN(INSTR) < ATC(insep,INSTR,maxnum)+1
  996.         rval = ""
  997.     CASE innum = maxnum + 1
  998.         start = ATC(insep,INSTR,maxnum)+1
  999.         stop = LEN(INSTR)
  1000.         rval = SUBSTR(INSTR,start,stop-start+1)
  1001.     CASE innum < maxnum + 1
  1002.         start = ATC(insep,INSTR,innum-1)+1
  1003.         stop = ATC(insep,INSTR,innum)-1
  1004.         rval = SUBSTR(INSTR,start,stop-start+1)
  1005.     CASE innum > maxnum + 1
  1006.         rval = ""
  1007.  
  1008.     ENDCASE
  1009.     RETURN rval
  1010.  
  1011.  
  1012.  
  1013. FUNCTION isnum(lcNumber)
  1014.  
  1015.     IF EMPTY(lcNumber)
  1016.         RETURN .F.
  1017.     ENDIF
  1018.  
  1019.     lcNumber=UPPER(lcNumber)
  1020.  
  1021.     *Make sure there's not more than one of each E,-, and .
  1022.  
  1023.     IF STRTRAN(lcNumber,".","",1,1)!=STRTRAN(lcNumber,".","")
  1024.         RETURN .F.
  1025.     ENDIF
  1026.     IF STRTRAN(lcNumber,"E","",1,1)!=STRTRAN(lcNumber,"E","")
  1027.         RETURN .F.
  1028.     ENDIF
  1029.     IF STRTRAN(lcNumber,"-","",1,1)!=STRTRAN(lcNumber,"-","")
  1030.         RETURN .F.
  1031.     ENDIF
  1032.  
  1033.     IF CHRTRAN(lcNumber,"0123456789.E-",REPL(CHR(0),13))==REPL(CHR(0),LEN(lcNumber))
  1034.         RETURN .T.
  1035.     ELSE
  1036.         RETURN .F.
  1037.     ENDIF
  1038.  
  1039.  
  1040.  
  1041. FUNCTION parmsub(lcRootString)
  1042.     EXTERNAL ARRAY laEnvVariables
  1043.  
  1044.     lcFilledString=lcRootString
  1045.  
  1046.     *Iterate through for each possible environment variable.  Faster than parsing everything out.
  1047.  
  1048.     FOR nCnt=1 TO lnEnvVariables
  1049.         lcFilledString=STRTRAN(lcFilledString,"%"+ALLT(laEnvVariables[nCnt,1])+"%",laEnvVariables[nCnt,2])
  1050.     ENDFOR
  1051.  
  1052.     RETURN lcFilledString
  1053.  
  1054.  
  1055.  
  1056. FUNCTION ParseVars(cParameters,laEnvVariables,llCreate)
  1057.  
  1058.     LOCAL nVCount, cToken
  1059.  
  1060.     IF EMPTY(cParameters)
  1061.         RETURN 0
  1062.     ENDIF
  1063.  
  1064.     IF llCreate
  1065.         nVCount=1
  1066.     ELSE
  1067.         nVCount=ALEN(laEnvVariables,1)+1
  1068.     ENDIF
  1069.     cToken=GETTOKEN(cParameters,1,"&")
  1070.     DO WHILE NOT EMPTY(cToken)
  1071.         DIMENSION laEnvVariables[nVCount,2]
  1072.         laEnvVariables[nVCount,1]=ALLT(SUBSTR(cToken,1,ATC("=",cToken)-1))
  1073.         IF ATC("=",cToken)=LEN(cToken)
  1074.             laEnvVariables[nVCount,2]=""
  1075.         ELSE
  1076.             cToken = SUBSTR(cToken,ATC("=",cToken)+1)
  1077.             cToken = StripASCII(cToken)
  1078.             laEnvVariables[nVCount,2] = STRTRAN(cToken,"+"," ")
  1079.         ENDIF
  1080.         nVCount=nVCount+1
  1081.         cToken=GETTOKEN(cParameters,nVCount,"&")
  1082.     ENDDO
  1083.  
  1084.     nVCount=nVCount-1
  1085.  
  1086.     RETURN nVCount
  1087.  
  1088. FUNCTION StripASCII
  1089.     LPARAMETER clString
  1090.     * clString is ASCII, but could contain hex of DBCS
  1091.     LOCAL m.cstr
  1092.     m.cStr = ""
  1093.     DO WHILE !EMPTY(m.clString)
  1094.         IF LEFT(m.clString,1)  = "%"
  1095.             m.cStr = m.cStr + gethex(m.clString)
  1096.             m.clString = IIF(LEN(m.clString) = 3,"",SUBSTR(m.clString,4))
  1097.         ELSE
  1098.             m.cStr = m.cStr + LEFT(m.clString,1)    && must be ascii
  1099.             m.clString = IIF(LEN(m.clString) = 1,"",SUBSTR(m.clString,2))
  1100.         ENDIF
  1101.     ENDDO
  1102.  
  1103.  
  1104.     RETURN m.cStr
  1105.  
  1106.  
  1107.  
  1108. FUNCTION gethex(cHex)
  1109.  
  1110.     nRval = getval(SUBSTR(cHex,2,1))*16+getval(SUBSTR(cHex,3,1))
  1111.  
  1112.     RETURN CHR(nRval)
  1113.  
  1114.  
  1115.  
  1116. FUNCTION getval(cVal)
  1117.  
  1118.     DO CASE
  1119.     CASE ASC(cVal) >= 65
  1120.         nRval = ASC(cVal)-55
  1121.     CASE ASC(cVal) >= 48
  1122.         nRval = ASC(cVal)-48
  1123.     ENDCASE
  1124.  
  1125.     RETURN nRval
  1126.  
  1127.  
  1128.  
  1129. FUNCTION readini(filename)
  1130.  
  1131.     PRIVATE pcfg,prdline,ptoken,pvalue
  1132.  
  1133.     pcfg = FOPEN(filename)
  1134.  
  1135.     IF pcfg < 0
  1136.         RETURN .F.
  1137.     ENDIF
  1138.  
  1139.     DO WHILE NOT(FEOF(pcfg))
  1140.         prdline = FGETS(pcfg)
  1141.         IF NOT EMPTY(prdline)
  1142.             ptoken = UPPER(ALLTRIM(SUBSTR(prdline,1,AT("=",prdline)-1)))
  1143.             pvalue = UPPER(ALLTRIM(SUBSTR(prdline,AT("=",prdline)+1)))
  1144.             DO CASE
  1145.             CASE ptoken == "HTTPROOT"
  1146.                 gcHTTPRoot = pvalue
  1147.             CASE ptoken == "SCRIPTROOT"
  1148.                 gcScriptRoot = pvalue
  1149.             CASE ptoken == "SEMAPHORE"
  1150.                 gcSemaphoreRoot = pvalue
  1151.             CASE ptoken == "PATH"
  1152.                 gcPath = pvalue
  1153.             ENDCASE
  1154.         ENDIF
  1155.     ENDDO
  1156.  
  1157.     =FCLOSE(pcfg)
  1158.  
  1159.     RETURN .T.
  1160.  
  1161.  
  1162.  
  1163. FUNCTION runspec
  1164.     gcINIFile='is.ini'
  1165.     gcHTTPRoot=""
  1166.     gcScriptRoot=""
  1167.  
  1168.     DO FORM specroot
  1169.     RETURN
  1170.  
  1171.  
  1172.  
  1173. FUNCTION ErrorHandler(tnErrorNo,tcMsg,tcProgramName,tnLineNo,tcCodeLine)
  1174. LOCAL laDir[1]
  1175.  
  1176.     IF ADIR(laDir,'error.txt')>0
  1177.         IF laDir[2]>65535 OR (DATE()-laDir[3])>14
  1178.             ERASE error.txt
  1179.         ENDIF
  1180.     ENDIF
  1181.     SET TEXTMERGE OFF
  1182.     SET TEXTMERGE TO ERROR ADDITIVE
  1183.     SET TEXTMERGE ON NOSHOW
  1184. \Error occured :  <<DATE()>> at <<TIME()>>
  1185. \Error message :  <<tcMsg>>
  1186. \Error number  :  <<tnErrorNo>>
  1187. \Procedure name:  <<PROPER(tcProgramName)>>
  1188. \Line number   :  <<tnLineNo>>
  1189.     IF NOT EMPTY(ALIAS())
  1190.   \Alias         :  [<<ALIAS()>>]
  1191.   \Record number :  <<RECNO()>>
  1192.     ENDIF
  1193. \<<tcCodeLine>>
  1194. \
  1195. \
  1196.     SET TEXTMERGE OFF
  1197.     SET TEXTMERGE TO
  1198. ENDFUNC
  1199.