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