home *** CD-ROM | disk | FTP | other *** search
/ Freesoft 1997 March / Freesoft_1997-03_cd.bin / nerecenz / internet / webexplr / CODEBLCK.PRG < prev    next >
Text File  |  1997-03-04  |  26KB  |  977 lines
  1. * CodeBlck.PRG
  2. *
  3. * FoxPro 2.5a (or later) Code Block Interpreter
  4. *
  5. * Created by: Randy Pearson, CYCLA Corporation
  6. * Modified by: Ken R. Levy
  7. * Revision 1.0(e), October 26, 1996
  8. *
  9. * DO NOT rename this file!  This program uses recursion (i.e.,
  10. * calls itself) to handle nested programming constructs.  If 
  11. * you must rename this file, be sure to revise all lines of code
  12. * that include CodeBlck() calls.
  13. *
  14. * General Strategy:
  15. *   If code were all simple "in-line" code (no SCAN, DO, etc.),
  16. *   it is easy to run uncompiled by simply storing each line to
  17. *   a memory variable and then macro substituting each line.
  18. *
  19. *   Thus, we adopt that approach, but when we encounter any control
  20. *   structure, we capture the actual code block within the structure,
  21. *   create an artificial simulation of the structure, and pass the
  22. *   internal code block recursively to this same routine.  Nesting
  23. *   is handled automatically by this approach.
  24. *
  25. * Limitations: 
  26. *   - Does not support embedded subroutines (PROC or FUNC)
  27. *     within code passed.
  28. *     Performs implied RETURN .T. if subroutine found.
  29. *     To use UDF's, capture each PROC/FUNC as its own code
  30. *     block and call CODEBLCK repeatedly as needed.
  31. *   - Doesn't accept TEXT w/ no ENDTEXT (although FP doc's
  32. *     suggest that this is acceptable to FP.
  33. *
  34. * Notes:
  35. *   All variables declared for usage by this routine have a
  36. *   prefix of _0_q (2 underscores, number zero, letter queue)
  37. *   in an attempt to minimize the chances of conflicts with
  38. *   variables in running programs.
  39. *
  40. *   All FUNCTIONs are similarly named to avoid problems where
  41. *   the users code includes a DO <FunctionName> and that name
  42. *   matches a subroutine herein, which would be higher in the
  43. *   calling stack.
  44. *
  45. *   No subroutines are called during _execution_ phases in order
  46. *   to minimize the depth of DO calls.  FoxPro has a maximum
  47. *   of 32.  My APPS are usually 10-16 levels deep at any time.
  48. *   By keeping all calls at top level, we only use up one level
  49. *   for each level of nesting in the code being processed.
  50. *
  51. *   If your code block begins with a semicolon ";", the block is
  52. *   assumed to be a dBW-style code block, and all semicolons are
  53. *   translated to Cr-Lf pairs for the execution in this routine.
  54. *   (Existing code in files is not altered.)
  55. *
  56. *   You may want to SET TALK OFF when testing this program from 
  57. *   the Command Window.
  58.  
  59. PARAMETER _0_qcCode, _0_qlFile, _0_qlEdit
  60. * _0_qcCode : Text of code to run OR File name with code.
  61. *              If blank, user gets screen to type code.
  62. * _0_qlFile : .T. if 1st parameter is a file name. Internally
  63. *              passed as -1 when recursive call made.
  64. * _0_qlEdit : .T. if user gets to edit code before running. 
  65.  
  66. * Calling Examples:
  67. * 1) Allow direct typing of code to run:
  68. *      DO CodeBlck
  69. * 2) Run the code contained in memo field "TheCode":
  70. *      DO CodeBlck WITH TheCode
  71. * 3) Same as 2, but allow review/edit first:
  72. *      DO CodeBlck WITH TheCode, .f., .T.
  73. * 4) Run the code found in file "TESTRUN.PRG":
  74. *      DO CodeBlck WITH "TESTRUN.PRG", .T.
  75. * 5) Same as 4, but allow user to review/edit:
  76. *      DO CodeBlck WITH "TESTRUN.PRG", .T., .T.
  77. *    [NOTE: The file doesn't get changed.]
  78.  
  79. * Record of Revision
  80. * ==================
  81. * Initials in brackets are credits to testers/users that found
  82. * bugs or provided enhancement requests.
  83. * [KL] = Ken Levy
  84. * [BA] = Bill Anderson
  85. * [TG] = Tom Gehrke
  86. * [RP] = Randy Pearson
  87.  
  88. * 09/21/1994
  89. *  - Supports DO CODEBLCK, etc., from within another code block!
  90. *    Pass 2nd parameter as -1 to indicate recursion, rather than
  91. *    checking the program stack.  Thus a code block can call
  92. *    CODEBLCK and it won't look like recursion. [BA, KL]
  93. *  - Trap for unsupportable commands CLEAR MEMORY, CLEAR ALL and
  94. *    RESTORE FROM w/o ADDITIVE. [BA]
  95. *  - Call error routine manually when unsupported statements found. [RP]
  96. *  - Adjusted SIZE of Edit Region for _MAC screens. [BA]
  97. *  - Added LEFT( , 254) to WAIT WINDOW in error handler, to avoid
  98. *    FP error if total expression exceeds 254 characters. [KL]
  99. *  - Expanded main CASE structure to detect orphaned END statements
  100. *    with no matching beginning statement. [RP]
  101. *  - Revised to RETURN .F. if file not found (or selected by user),
  102. *    or if user presses <Cancel> or doesn't enter any code. [RP]
  103.  
  104. * 09/14/1994
  105. *  - Revised to RETURN .T. if no RETURN <something> found, EXCEPT
  106. *    RETURN .F. if errors occur. [KL]
  107. *  - Revised to intercept dBW-style code blocks begining with
  108. *    and using semicolons as line breaks, and translating them 
  109. *    to Cr-Lf pairs for this routine. [KL]
  110. *  - Removed bell in on error routine. [KL]
  111. *  - Changed all TYPE() function calls to use == operator, because
  112. *    dBW's TYPE() function now returns some 2-character codes (dBW
  113. *    programmers take note!) such as "CB", and we cannot be certain
  114. *    that FP 3.0 won't too.  Existing code like TYPE("myvar") = "C"
  115. *    may break in dBW under some circumstances. [RP]
  116.  
  117. * 09/03/1994
  118. *  - Made determination of whether called recursively bullet-proof
  119. *    by analyzing entire program stack. [RP]
  120. *  - Cleaned up handling of FOR..ENDFOR and eliminated several 
  121. *    unused memory variables. [RP]
  122. *  - Made several changes to streamline EXIT process when errors
  123. *    are encountered. [RP, KL]
  124. *  - Always return .T. if no code passed or file not found. [RP]
  125. *  - Made consistent the handling of "null blocks" (e.g., a SCAN
  126. *    ENDSCAN with no code in between. [RP]
  127. *  - Revised ON ERROR display to clarify that the Line ## is the
  128. *    CODEBLCK.PRG Line ##, not the line in the user's code. [TG]
  129. *
  130. * 09/02/1994
  131. *  - Changed name of program to CODEBLCK.PRG (from ZZRUNPRG.PRG). [KL]
  132. *  - Removed assumption that TEXTMERGE DELIMITERS were set to 
  133. *    default values << >>. [RP]
  134. *  - Fixed bug where TEXT..ENDTEXT only worked correctly when 
  135. *    SET TEXTMERGE was ON. [RP]
  136. *  - Revised font definitions for Mac. [BA]
  137. *  - Changed KEYCOMP to WINDOWS during code edit. [BA]
  138. *  - Localized setting/resetting of MEMOWIDTH in case users code
  139. *    depends on current setting. [RP]
  140. *  - Corrected various typos. [RP, TG]
  141. *  - Revised ON ERROR to send/receive MESSAGE(1), and optionally
  142. *    display it if there is no code being executed (i.e., it's my
  143. *    error rather than the users). [RP]
  144. *  - Revised routines to work properly if user has SET EXACT ON,
  145. *    by SET EXACT OFF when needed and lots of PADR() stuff. [RP]
  146. *  - Corrected bug where user's macro substitution didn't work
  147. *    within CASE, DO WHILE, and FOR.  Lesson: If an expression
  148. *    might contain '&', always & it rather than EVAL() it. [BA, RP]
  149. * 10/26/1996
  150. *  - Changed syntax error on VFP 5.0 compile. [KL]
  151. * 3/4/1997
  152. *  - Added check to ignore HTML comment lines
  153.  
  154. #DEFINE dnMaxNest   32
  155. * Maximum DO nesting.
  156. #DEFINE dnMemWidth 254
  157. #DEFINE crLf       CHR(13) + CHR(10)
  158. * Carriage Return + Line Feed
  159.  
  160. PRIVATE _0_qnLines ;; # lines of code
  161. PRIVATE _0_qnNext  ;; Line # of next line of code
  162. PRIVATE _0_qMemoW  ;; previous SET MEMO setting
  163. PRIVATE _0_qcLine1 ;; current line of code being processed
  164. PRIVATE _0_qcUpper ;; UPPER() of same
  165.  
  166. PRIVATE _0_qxRet   ;; Proposed RETURN value
  167. PRIVATE _0_qcExpr  ;; Fragment of control code line
  168. PRIVATE _0_qnAtPos ;; Result of misc. AT() function calls.
  169. PRIVATE _0_qcBlk   ;; Nested block of code to pass recursively
  170.  
  171. PRIVATE _0_qnCount ;; Counter for misc. loops
  172.  
  173. PRIVATE _0_qlTop   ;; Flag if top of recursion
  174.  
  175. IF TYPE( "m._0_qlFile") == "N" AND m._0_qlFile = -1
  176.     * Program called recursively.
  177.     _0_qlTop = .F.
  178. ELSE
  179.     * First call to program.
  180.     _0_qlTop = .T.
  181.     
  182.     * Establish "thread" control variables:
  183.     PRIVATE _0_qcExit   ;; EXIT/LOOP/RETURN passback variable
  184.     PRIVATE _0_qcError  ;; old ON ERROR process
  185.     _0_qcExit = SPACE(0) 
  186.     _0_qcError = ON( "ERROR")
  187.     IF EMPTY(_0_qcError)
  188.         ON ERROR DO _0_qError WITH ;
  189.             ERROR(), LINENO(), MESSAGE(), MESSAGE(1)
  190.     ENDIF
  191.  
  192.     * --- Deal with different calling methods, only
  193.     * --- applies to first call (not recursion):
  194.     IF m._0_qlFile
  195.         * File name as 1st parameter.
  196.         DO CASE
  197.         CASE EMPTY( m._0_qcCode) OR NOT TYPE("m._0_qcCode") == 'C'
  198.             _0_qcCode = GETFILE( 'PRG|TXT', 'Select File', 'Execute')
  199.         CASE '*' $ m._0_qcCode OR '?' $ m._0_qcCode
  200.             _0_qcCode = GETFILE( m._0_qcCode, 'Select File', 'Execute')
  201.         OTHERWISE
  202.             * Explicit file name sent.
  203.         ENDCASE
  204.     
  205.         IF EMPTY( m._0_qcCode)
  206.             * File not found/selected.
  207.             DO _0_qRestE
  208.             RETURN .F.
  209.         ELSE
  210.             * Store file contents to memvar.
  211.             _0_qcCode = _0_qFile( m._0_qcCode)
  212.         ENDIF
  213.     ENDIF
  214.  
  215.     IF NOT TYPE( "m._0_qcCode") == 'C'
  216.         * No code passed - see if any stored from last run.
  217.         IF PROGRAM(1) == "CODEBLCK" AND TYPE( "m._0_qcPrev") == "C"
  218.             _0_qcCode = m._0_qcPrev
  219.         ELSE
  220.             _0_qcCode = SPACE(0)
  221.         ENDIF
  222.     
  223.         _0_qlEdit = .T.
  224.     ENDIF  [no code passed as parameter]
  225.  
  226.     _0_qcCode = ALLTRIM( m._0_qcCode)
  227.     IF LEFT( m._0_qcCode, 1) == ";"
  228.         * Assume dBW-style code block.  Translate each ;
  229.         * to Cr-Lf so that this routine will run it.
  230.         _0_qcCode = STRTRAN( m._0_qcCode, ";", CrLf)
  231.     ENDIF
  232.     
  233.     IF m._0_qlEdit
  234.         * Allow user to enter/edit code:
  235.         DO _0_qInput
  236.         
  237.         IF NOT EMPTY( m._0_qcCode) AND ;
  238.             PROGRAM(1) == "CODEBLCK"
  239.             *
  240.             * Run from Command Window - save code
  241.             * so user can retry:
  242.             IF TYPE("m._0_qcPrev") == "U"
  243.                 PUBLIC _0_qcPrev
  244.                 _0_qcPrev = m._0_qcCode
  245.             ELSE
  246.                 IF TYPE("m._0_qcPrev") == "C"
  247.                     _0_qcPrev = m._0_qcCode
  248.                 ENDIF
  249.             ENDIF  [program previously used]
  250.         ENDIF  [from Command window]
  251.     ENDIF  [allow user to enter code]
  252.  
  253.     IF EMPTY( m._0_qcCode)
  254.         * Still no code.
  255.         DO _0_qRestE
  256.         RETURN .F.
  257.     ENDIF  [no code supplied to run]
  258. ENDIF  [called recursively]
  259.  
  260. _0_qMemoW = SET("MEMOWIDTH")
  261. SET MEMOWIDTH TO dnMemWidth
  262. _0_qnLines = MEMLINES( m._0_qcCode)
  263. SET MEMOWIDTH TO m._0_qMemoW
  264.  
  265. _0_qnNext = 1
  266. _0_qcLine1 = ""
  267. _0_qxRet = .T.
  268.  
  269. DO WHILE m._0_qnNext <= m._0_qnLines
  270.  
  271.     _0_qcLine1 = _0_qLine()
  272.     _0_qcUpper = UPPER( m._0_qcLine1)
  273.     
  274.     DO CASE
  275.     CASE EMPTY( m._0_qcLine1)
  276.         * Almost assuredly past end.
  277.         LOOP
  278.         
  279.     CASE PADR( m._0_qcUpper, 8) == "DO WHILE"
  280.         _0_qcExpr = SUBSTR( m._0_qcLine1, 9)
  281.         _0_qcBlk = _0_qBlock( 'DO WHILE')
  282.         
  283.         DO WHILE &_0_qcExpr
  284.             IF NOT EMPTY( m._0_qcBlk)
  285.                 _0_qxRet = CodeBlck( m._0_qcBlk, -1)
  286.             ENDIF
  287.             IF NOT EMPTY( m._0_qcExit)
  288.                 IF m._0_qcExit = 'LOOP'
  289.                     _0_qcExit = SPACE(0)
  290.                     LOOP
  291.                 ENDIF
  292.                 IF m._0_qcExit = 'EXIT'
  293.                     _0_qcExit = SPACE(0)
  294.                 ENDIF
  295.                 EXIT
  296.             ENDIF
  297.         ENDDO
  298.  
  299.     CASE PADR( m._0_qcUpper, 4) == "SCAN"
  300.         _0_qcExpr = IIF( ALLTRIM( m._0_qcUpper) == "SCAN", ;
  301.             SPACE(0), ALLTRIM( SUBSTR( m._0_qcLine1, 5)))
  302.         _0_qcBlk = _0_qBlock( 'SCAN')
  303.  
  304.         SCAN &_0_qcExpr
  305.             IF NOT EMPTY( m._0_qcBlk)
  306.                 _0_qxRet = CodeBlck( m._0_qcBlk, -1)
  307.             ENDIF
  308.             IF NOT EMPTY( m._0_qcExit)
  309.                 IF m._0_qcExit = 'LOOP'
  310.                     _0_qcExit = SPACE(0)
  311.                     LOOP
  312.                 ENDIF
  313.                 IF m._0_qcExit = 'EXIT'
  314.                     _0_qcExit = SPACE(0)
  315.                 ENDIF
  316.                 EXIT
  317.             ENDIF
  318.         ENDSCAN
  319.  
  320.     CASE PADR( m._0_qcUpper, 3) == "FOR"
  321.         _0_qcExpr = SUBSTR( m._0_qcLine1, 4)
  322.         _0_qcBlk = _0_qBlock( 'FOR')
  323.  
  324.         FOR &_0_qcExpr
  325.             *
  326.             IF NOT EMPTY( m._0_qcBlk)
  327.                 _0_qxRet = CodeBlck( m._0_qcBlk, -1)
  328.             ENDIF
  329.             IF NOT EMPTY( m._0_qcExit)
  330.                 IF m._0_qcExit = 'LOOP'
  331.                     _0_qcExit = SPACE(0)
  332.                     LOOP
  333.                 ENDIF
  334.                 IF m._0_qcExit = 'EXIT'
  335.                     _0_qcExit = SPACE(0)
  336.                 ENDIF
  337.                 EXIT
  338.             ENDIF
  339.         ENDFOR
  340.  
  341.     CASE PADR( m._0_qcUpper, 2) == "IF"
  342.         _0_qcExpr = ALLTRIM( SUBSTR( m._0_qcLine1, 3))
  343.         IF &_0_qcExpr
  344.             _0_qcBlk = _0_qBlock( "IF")
  345.         ELSE
  346.             _0_qcBlk = _0_qBlock( "ELSE")
  347.         ENDIF
  348.         IF NOT EMPTY( m._0_qcBlk)
  349.             _0_qxRet = CodeBlck( m._0_qcBlk, -1)
  350.         ENDIF
  351.  
  352.     CASE PADR( m._0_qcUpper, 7) == "DO CASE"
  353.         _0_qcBlk = _0_qBlock( "DO CASE")
  354.         * _0_qBlock() figures out which case to use.
  355.         IF NOT EMPTY( m._0_qcBlk)
  356.             _0_qxRet = CodeBlck( m._0_qcBlk, -1)
  357.         ENDIF
  358.         
  359.     CASE PADR( m._0_qcUpper, 4) == "TEXT"
  360.         _0_qcBlk = _0_qBlock( 'TEXT')
  361.         _0_qMemoW = SET("MEMOWIDTH")
  362.         SET MEMOWIDTH TO dnMemWidth
  363.         FOR _0_qnCount = 1 TO MEMLINES( m._0_qcBlk)
  364.             _0_qcExpr = "\" + MLINE( m._0_qcBlk, m._0_qnCount)
  365.             &_0_qcExpr
  366.         ENDFOR
  367.         SET MEMOWIDTH TO m._0_qMemoW
  368.         
  369.     CASE PADR( m._0_qcUpper, 4) == "LOOP"
  370.         _0_qcExit = "LOOP"
  371.         EXIT
  372.         
  373.     CASE PADR( m._0_qcUpper, 4) == "EXIT"
  374.         _0_qcExit = "EXIT"
  375.         EXIT
  376.  
  377. * Prototype for statements to disallow. Remove comments or
  378. * re-write portions if you want to disallow these.        
  379. *
  380. *    CASE INLIST( PADR( m._0_qcUpper, 4), "CANC", "QUIT")
  381. *        _0_qcExit = "ILLEGAL"
  382. *        _0_qxRet  = .F.
  383. *        EXIT
  384.         
  385.     CASE PADR( m._0_qcUpper, 9) == "CLEAR ALL" OR ;
  386.         PADR( m._0_qcUpper, 8) == "CLEA ALL" OR ;
  387.         PADR( m._0_qcUpper, 10) == "CLEAR MEMO" OR ;
  388.         PADR( m._0_qcUpper, 9) == "CLEA MEMO" OR ;
  389.         PADR( m._0_qcUpper, 7) == "RETU TO" OR ;
  390.         PADR( m._0_qcUpper, 8) == "RETUR TO" OR ;
  391.         PADR( m._0_qcUpper, 9) ==  "RETURN TO"
  392.         *
  393.         * These are known to break the system.
  394.         _0_qcExit = "ILLEGAL"
  395.         _0_qxRet  = .F.
  396.         EXIT
  397.  
  398.     CASE PADR( m._0_qcUpper, 4) == "REST" AND ;
  399.         "FROM " $ m._0_qcUpper AND ;
  400.         NOT "ADDI" $ m._0_qcUpper
  401.         *
  402.         * Can't have RESTORE FROM w/o ADDITIVE.
  403.         _0_qcExit = "ILLEGAL"
  404.         _0_qxRet  = .F.
  405.         EXIT
  406.         
  407.     CASE INLIST( PADR( m._0_qcUpper, 4), "PROC", "FUNC")
  408.         * Probably NOT good news, but maybe OK.
  409.         * This program does not support embedded PROC's
  410.         * and FUNC's.  It can only call compiled routines.
  411.         _0_qcExit = "RETURN"
  412.         _0_qxRet = .T.
  413.         
  414.     CASE INLIST( PADR( m._0_qcUpper, 4), ;
  415.         "ENDS", "ENDD", "ENDF", "ENDI", ;
  416.         "NEXT", "ENDC", "ENDT", "ELSE", "CASE")
  417.         *
  418.         * Nesting error in user's code.
  419.         _0_qnAtPos = AT( SPACE(1), m._0_qcUpper)
  420.         _0_qcExpr = LEFT( m._0_qcUpper, ;
  421.             IIF( m._0_qnAtPos = 0, 7, m._0_qnAtPos - 1))
  422.         WAIT WINDOW [Nesting Error - "] + m._0_qcExpr + ;
  423.             [" statement found, ] + CrLf + ;
  424.             [but there was no matching beginning statement.] NOWAIT
  425.         _0_qcExit = "ERROR"
  426.         _0_qxRet = .F.
  427.         EXIT
  428.         
  429.     CASE PADR( m._0_qcUpper, 4) == "RETU"
  430.         _0_qcExit = "RETURN"
  431.         _0_qxRet = .T.
  432.         _0_qnAtPos = AT( SPACE(1), m._0_qcLine1)
  433.         IF m._0_qnAtPos > 0
  434.             _0_qcExpr = ALLTRIM( SUBSTR( m._0_qcLine1, m._0_qnAtPos))
  435.             IF NOT EMPTY( m._0_qcExpr)
  436.                 * RETURN <something>
  437.                 _0_qxRet = EVAL( m._0_qcExpr)
  438.             ENDIF
  439.         ENDIF
  440.         
  441.     OTHERWISE
  442.         IF EMPTY( m._0_qcExit)
  443.             * Just do it:
  444.             &_0_qcLine1
  445.         ENDIF
  446.  
  447.     ENDCASE
  448.  
  449.     IF NOT EMPTY( m._0_qcExit)
  450.         * Some exit code encountered.
  451.         EXIT
  452.     ENDIF
  453. ENDDO
  454.  
  455. SET MEMOWIDTH TO m._0_qMemoW
  456.  
  457. IF m._0_qcExit = "ILLEGAL"
  458.     DO _0_qError WITH 9999, 0, ;
  459.         "Unsupported Code Block statement", ;
  460.         m._0_qcLine1
  461. ENDIF
  462.  
  463. IF m._0_qlTop
  464.     * leaving for good
  465.     DO _0_qRestE
  466. ENDIF
  467.  
  468. IF m._0_qcExit == "ERROR"
  469.     _0_qxRet = .F.
  470. ENDIF
  471.  
  472. RETURN m._0_qxRet
  473.  
  474. * -------------------------------------------------------- *
  475.  
  476. FUNCTION _0_qRestE
  477. *
  478. * Restore environment.
  479. *
  480. IF EMPTY( m._0_qcError)
  481.     ON ERROR
  482. ELSE
  483.     ON ERROR &_0_qcError
  484. ENDIF
  485.  
  486. RETURN .T.
  487.  
  488. * -------------------------------------------------------- *
  489.  
  490. FUNCTION _0_qFile
  491. *
  492. * Get file contents.
  493. *
  494. PARAMETER pcFile
  495.  
  496. IF NOT FILE( m.pcFile)
  497.     RETURN SPACE(0)
  498. ENDIF
  499. PRIVATE lnSelect, lcCode
  500. lnSelect = SELECT()
  501. SELECT 0
  502. CREATE CURSOR _0_qFile (Contents M)
  503. APPEND BLANK
  504. APPEND MEMO Contents FROM ( m.pcFile)
  505. lcCode = Contents
  506. USE
  507. SELECT (m.lnSelect)
  508.  
  509. RETURN m.lcCode
  510.  
  511. * -------------------------------------------------------- *
  512.  
  513. PROCEDURE _0_qError
  514. *
  515. * ON ERROR routine
  516. *
  517. PARAMETERS pnError, pnLineNo, pcMessage, pcMessage1
  518.  
  519. * ?? CHR(7) + CHR(7)
  520.  
  521. WAIT WINDOW LEFT( ;
  522.     "* CODE BLOCK RUNTIME ERROR *" + CrLf + CrLf + ;
  523.     "Error: " + LTRIM( STR( m.pnError)) + " occurred." + CrLf + ;
  524.     "Mes'g: " + m.pcMessage + CrLf + ;
  525.     "Code.: " + LEFT( IIF( TYPE( "m._0_qcLine1") == "C", ;
  526.         m._0_qcLine1, m.pcMessage1), 50) + CrLf + ;
  527.     "Modul: CodeBlck.PRG, Line: "  + LTRIM( STR( m.pnLineNo)), ;
  528.     254) NOWAIT
  529.  
  530. */ SUSPEND
  531. STORE "ERROR" TO m._0_qcExit
  532. STORE .F. TO m._0_qxRet
  533.  
  534. RETURN .T.
  535.  
  536. * -------------------------------------------------------- *
  537.  
  538. FUNCTION _0_qInput
  539. *
  540. * Allow EDIT of code.
  541. *
  542. PRIVATE lcControl, lcLastKeyC
  543. lcControl = "Execute"
  544. IF _WINDOWS OR _MAC
  545.     lcLastKeyC = SET( "KEYCOMP")
  546.     SET KEYCOMP TO WINDOWS
  547. ENDIF
  548. DO CASE
  549. CASE _MAC
  550.     DEFINE WINDOW _0_qInput ;
  551.         AT 1, 0 ;
  552.         SIZE 16, 78 ;
  553.         TITLE " FoxPro Code Block Interpreter " ;
  554.         FONT "Geneva", 10 ;
  555.         STYLE "B" ;
  556.         COLOR RGB(,,,192,192,192) ;
  557.         FLOAT NOMDI
  558. CASE _WINDOWS
  559.     DEFINE WINDOW _0_qInput ;
  560.         AT 1, 0 ;
  561.         SIZE 16, 78 ;
  562.         TITLE " FoxPro Code Block Interpreter " ;
  563.         FONT "MS Sans Serif", 9 ;
  564.         STYLE "B" ;
  565.         COLOR RGB(,,,192,192,192) ;
  566.         FLOAT NOMDI
  567. OTHERWISE
  568.     DEFINE WINDOW _0_qInput ;
  569.         AT 1, 0 ;
  570.         SIZE 16, 76 ;
  571.         TITLE " FoxPro Code Block Interpreter " ;
  572.         COLOR SCHEME 1 ;
  573.         SHADOW ;
  574.         FLOAT NOMDI
  575. ENDCASE
  576.  
  577. ACTIVATE WINDOW _0_qInput NOSHOW 
  578.  
  579. IF _MAC
  580. @ 1, 1 SAY "Enter code to run:" FONT "Geneva", 10 STYLE [B]
  581. @ 2.2, 2 EDIT m._0_qcCode ;
  582.     SIZE 10, 87 ;
  583.     FUNCTION [3] ;
  584.     FONT "Monaco", 9 ;
  585.     SCROLL ;
  586.     TAB ;
  587.     MESSAGE "Press {Ctrl}+{Tab} to Exit Box"
  588. @ 13, 25 GET m.lcControl ;
  589.     PICTURE "@*HT Execute;\?Cancel" ;
  590.     SIZE 1.7, 12, 5 ;
  591.     FONT "Chicago", 12 ;
  592.     MESSAGE "Press EXECUTE to Run Code, CANCEL to Skip"
  593. ELSE
  594. @ 1, 1 SAY "Enter code to run:"
  595. @ 2.2, 2 EDIT m._0_qcCode ;
  596.     SIZE 8, 64 ;
  597.     FONT "Courier New", 8 ;
  598.     SCROLL ;
  599.     TAB ;
  600.     MESSAGE "Press {Ctrl}+{Tab} to Exit Box"
  601. @ 13, 25 GET m.lcControl ;
  602.     PICTURE "@*HT \!Execute;\?Cancel" ;
  603.     SIZE 1.7, 12, 5 ;
  604.     MESSAGE "Press EXECUTE to Run Code, CANCEL to Skip"
  605. ENDIF
  606. MOVE WINDOW _0_qInput CENTER
  607. SHOW WINDOW _0_qInput 
  608.  
  609. READ CYCLE MODAL
  610. DEACTIVATE WINDOW _0_qInput
  611. IF NOT m.lcControl = 'Execute'
  612.     _0_qcCode = SPACE( 0)
  613. ENDIF
  614. RELEASE WINDOW _0_qInput
  615.  
  616. IF _WINDOWS OR _MAC
  617.     IF NOT m.lcLastKeyC = "WINDOWS"
  618.         SET KEYCOMP TO &lcLastKeyC
  619.     ENDIF
  620. ENDIF
  621.  
  622. RETURN .T.
  623.  
  624. * -------------------------------------------------------- *
  625.  
  626. FUNCTION _0_qBlock
  627. *
  628. * Fetch block of code for recursive call, and increment 
  629. * pointer m._0_qnNext to point past end of block (e.g., 
  630. * line after ENDCASE).
  631. *
  632. PARAMETER pcType
  633. * {FOR, DO WHILE, IF, ELSE, DO CASE, SCAN, TEXT}
  634.  
  635. PRIVATE lcCodeBlk, lcLastExct
  636. lcCodeBlk = SPACE(0)
  637. lcLastExct = SET( 'EXACT')
  638. SET EXACT OFF
  639.  
  640. PRIVATE laBlkStack, lnDepth
  641. DIMENSION laBlkStack[ 1]
  642.  
  643. IF m.pcType == "ELSE"
  644.     laBlkStack[ 1] = "IF"
  645. ELSE
  646.     laBlkStack[ 1] = m.pcType
  647. ENDIF
  648.  
  649. lnDepth = 1
  650.  
  651. PRIVATE lcNext, lcUpper, lcSubstr
  652. PRIVATE llSubSect, llTrueCase
  653.  
  654. llSubSect = NOT INLIST( m.pcType, "ELSE", "DO CASE")
  655. * Flag of whether we're within
  656. * a .T. case (thus code should
  657. * be returned).
  658.  
  659. llTrueCase = .F.
  660. * Flag of whether a .T. case has 
  661. * yet been found (thus don't evaluate 
  662. * further CASE's or process OTHERWISE).
  663.  
  664. DO WHILE NOT m._0_qcExit = "ERROR"
  665.     lcNext = _0_qLine( laBlkStack[ m.lnDepth])
  666.     IF m._0_qcExit = "ERROR"
  667.         * Error discovered by Line function.
  668.         EXIT
  669.     ENDIF
  670.  
  671.     IF EMPTY( m.lcNext)
  672.         WAIT WINDOW "Nesting Error - no matching final END found " + ;
  673.             "for " + laBlkStack[ m.lnDepth] + "." NOWAIT
  674.         _0_qcExit = "ERROR"
  675.         EXIT
  676.     ENDIF
  677.  
  678.     lcUpper = UPPER( m.lcNext)
  679.  
  680.     DO CASE
  681.  
  682.     CASE INLIST( m.lcUpper, "END", "NEXT")
  683.         * end of control structure
  684.         IF ( m.lcUpper = "ENDC" AND ;
  685.                 INLIST( laBlkStack[ m.lnDepth], ;
  686.                 "CASE", "OTHERWISE")) OR ;
  687.             ( m.lcUpper = "ENDD" AND ;
  688.                 laBlkStack[ m.lnDepth] = "DO WHILE") OR ;
  689.             ( INLIST( m.lcUpper, "ENDF", "NEXT") AND ;
  690.                 laBlkStack[ m.lnDepth] = "FOR") OR ;
  691.             ( m.lcUpper = "ENDS" AND ;
  692.                 laBlkStack[ m.lnDepth] = "SCAN") OR ;
  693.             ( m.lcUpper = "ENDT" AND ;
  694.                 laBlkStack[ m.lnDepth] = "TEXT") OR ;
  695.             ( m.lcUpper = "ENDI" AND ;
  696.                 INLIST( laBlkStack[ m.lnDepth], "ELSE", "IF"))
  697.             *
  698.             lnDepth = m.lnDepth - 1
  699.             IF m.lnDepth = 0
  700.                 * Only valid exit point!
  701.                 EXIT
  702.             ELSE
  703.                 IF m.llSubSect
  704.                     lcCodeBlk = m.lcCodeBlk + m.lcNext + CrLf
  705.                 ENDIF
  706.                 LOOP
  707.             ENDIF
  708.         ELSE
  709.             WAIT WINDOW "Nesting error. " + CrLf + ;
  710.                 TRIM( PADR( m.lcUpper, 8)) + ;
  711.                 " found, when matching begin " + ;
  712.                 "line was " + laBlkStack[ m.lnDepth] + "." NOWAIT
  713.             _0_qcExit = "ERROR"
  714.         ENDIF
  715.  
  716.     CASE UPPER( m.lcNext) = "ELSE"
  717.         IF laBlkStack[ m.lnDepth] = "IF"
  718.             laBlkStack[ m.lnDepth] = "ELSE"
  719.     
  720.             IF m.lnDepth = 1
  721.                 IF m.pcType == "IF"
  722.                     m.llSubSect = .F.
  723.                 ELSE
  724.                     m.llSubSect = .T.
  725.                 ENDIF
  726.             ELSE
  727.                 IF m.llSubSect
  728.                     lcCodeBlk = m.lcCodeBlk + m.lcNext + CrLf
  729.                 ENDIF
  730.             ENDIF
  731.         
  732.             LOOP
  733.         ELSE
  734.             WAIT WINDOW "ELSE nesting error - no matching IF. " NOWAIT
  735.             _0_qcExit = "ERROR"
  736.         ENDIF
  737.  
  738.     CASE UPPER( m.lcNext) = "CASE"
  739.  
  740.         IF INLIST( laBlkStack[ m.lnDepth], "DO CASE", "CASE")
  741.             laBlkStack[ m.lnDepth] = "CASE"
  742.         
  743.             IF m.lnDepth = 1
  744.                 IF m.llTrueCase
  745.                     m.llSubSect = .F.
  746.                 ELSE
  747.                     lcSubstr = SUBSTR(m.lcNext, 5)
  748.                     IF &lcSubstr
  749.                         m.llTrueCase = .T.
  750.                         m.llSubSect = .T.
  751.                     ENDIF
  752.                 ENDIF
  753.             ELSE
  754.                 IF m.llSubSect
  755.                     lcCodeBlk = m.lcCodeBlk + m.lcNext + CrLf
  756.                 ENDIF
  757.             ENDIF
  758.         
  759.             LOOP
  760.         ELSE
  761.             WAIT WINDOW "CASE nesting error - no matching DO CASE."  NOWAIT
  762.             _0_qcExit = "ERROR"
  763.         ENDIF
  764.  
  765.     CASE UPPER( m.lcNext) = "OTHE"
  766.         IF INLIST( laBlkStack[ m.lnDepth], "DO CASE", "CASE")
  767.             laBlkStack[ m.lnDepth] = "OTHERWISE"
  768.         
  769.             IF m.lnDepth = 1
  770.                 IF m.llTrueCase
  771.                     m.llSubSect = .F.
  772.                 ELSE
  773.                     m.llSubSect = .T.
  774.                 ENDIF
  775.             ELSE
  776.                 IF m.llSubSect
  777.                     lcCodeBlk = m.lcCodeBlk + m.lcNext + CrLf
  778.                 ENDIF
  779.             ENDIF
  780.         
  781.             LOOP
  782.         ELSE
  783.             WAIT WINDOW "OTHERWISE nesting error - no matching DO CASE." NOWAIT
  784.             _0_qcExit = "ERROR"
  785.         ENDIF
  786.  
  787.     CASE INLIST( m.lcUpper, "IF", "DO WHIL", "SCAN", ;
  788.         "TEXT", "DO CASE", "FOR")
  789.         *
  790.         IF laBlkStack[ m.lnDepth] = "DO CASE"
  791.             WAIT WINDOW "Nesting error - DO CASE w/o CASE. "  NOWAIT
  792.             _0_qcExit = "ERROR"
  793.         ELSE
  794.             lnDepth = m.lnDepth + 1
  795.             DIMENSION laBlkStack[ m.lnDepth]
  796.         
  797.             DO CASE
  798.             CASE UPPER( m.lcNext) = "IF"
  799.                 laBlkStack[ m.lnDepth] = "IF"
  800.         
  801.             CASE UPPER( m.lcNext) = "DO WHIL"
  802.                 laBlkStack[ m.lnDepth] = "DO WHILE"
  803.  
  804.             CASE UPPER( m.lcNext) = "SCAN"
  805.                 laBlkStack[ m.lnDepth] = "SCAN"
  806.  
  807.             CASE UPPER( m.lcNext) = "TEXT"
  808.                 laBlkStack[ m.lnDepth] = "TEXT"
  809.  
  810.             CASE UPPER( m.lcNext) = "DO CASE"
  811.                 laBlkStack[ m.lnDepth] = "DO CASE"
  812.  
  813.             CASE UPPER( m.lcNext) = "FOR"
  814.                 laBlkStack[ m.lnDepth] = "FOR"
  815.         
  816.             OTHERWISE
  817.                 WAIT WINDOW "Internal CODEBLCK consistency error." NOWAIT
  818.                 _0_qcExit = "ERROR"
  819.  
  820.             ENDCASE
  821.         
  822.             IF m.llSubSect
  823.                 lcCodeBlk = m.lcCodeBlk + m.lcNext + CrLf
  824.             ENDIF
  825.             LOOP
  826.         ENDIF
  827.  
  828.     OTHERWISE
  829.         * legitmate in-line code
  830.         IF m.llSubSect
  831.             lcCodeBlk = m.lcCodeBlk + m.lcNext + CrLf
  832.         ENDIF
  833.     
  834.     ENDCASE
  835.  
  836. ENDDO
  837.  
  838. IF m.lcLastExct == "ON"
  839.     SET EXACT ON
  840. ENDIF
  841.  
  842. IF m._0_qcExit = "ERROR"
  843.     lcCodeBlk = SPACE(0)
  844. ENDIF
  845.  
  846. RETURN m.lcCodeBlk
  847.  
  848. * -------------------------------------------------------- *
  849.  
  850. FUNCTION _0_qLine
  851. *
  852. * Return next line of code, ignoring comments and
  853. * blank lines. Leave m._0_qnNext pointing to first
  854. * text line after returned line of code.  Return null string
  855. * if no code line found to end of block.
  856. *
  857. * Assume m._0_qnNext   points to line to read
  858. *        m._0_qnLines  counts total # of lines
  859. *        m._0_qcCode   contains the total code
  860. *
  861. PARAMETER pcType
  862. * Type of inner most block.  If "TEXT" skip almost 
  863. * all "conditioning" steps and take literally.
  864.  
  865. PRIVATE lcCode, lcUpper, lnMemoWidt, lcLastExct
  866. lcCode = SPACE(0)
  867. lnMemoWidt = SET( 'MEMOWIDTH')
  868. lcLastExct = SET( 'EXACT')
  869. SET EXACT OFF
  870.  
  871. PRIVATE llContinued, lnAtPos, llComment, llText
  872. llContinued = .F.
  873. lnAtPos = 0
  874. llComment = .F.
  875. llText = TYPE( "m.pcType") == "C" AND m.pcType == "TEXT"
  876.  
  877. DO WHILE m._0_qnNext <= m._0_qnLines
  878.  
  879.     SET MEMOWIDTH TO dnMemWidth
  880.     DO CASE
  881.     CASE m.llText
  882.         * Within TEXT...ENDTEXT; leave alone.
  883.         lcCode = MLINE( m._0_qcCode, m._0_qnNext)
  884.         
  885.     CASE m.llContinued
  886.         * 2nd or later line in multi-line
  887.         * statement; attach but don't LTRIM(),
  888.         * since we could be in middle of delimited string.
  889.         lcCode = m.lcCode + TRIM( ;
  890.             MLINE( m._0_qcCode, m._0_qnNext))
  891.             
  892.     OTHERWISE
  893.         * Beginning of new line of normal code; LTRIM
  894.         * any indentation after removing TAB's.
  895.         lcCode = LTRIM( STRTRAN( ;
  896.             MLINE( m._0_qcCode, m._0_qnNext), ;
  897.             CHR(9), SPACE(1)))
  898.         
  899.         IF EMPTY( m.lcCode) OR ;
  900.             INLIST( LTRIM( m.lcCode), "*", "&" + "&", "#", "<!--", "-->")
  901.             * Blank or comment line OR compiler directive.
  902.             * (Can't type 2 &'s together in FoxPro)
  903.             * (Probably if compiler directive, subsequent 
  904.             *  code will fail, but give it a try.)
  905.             lcCode = SPACE(0)
  906.         ENDIF
  907.     ENDCASE
  908.  
  909.     SET MEMOWIDTH TO m.lnMemoWidt
  910.     _0_qnNext = m._0_qnNext + 1
  911.  
  912.     IF m.llText
  913.         EXIT
  914.     ENDIF
  915.  
  916.     IF EMPTY( m.lcCode)
  917.         LOOP
  918.     ENDIF
  919.     
  920.     lnAtPos = AT( "&" + "&", m.lcCode)
  921.     * Note gymnastics to avoid compile error.
  922.     
  923.     IF m.lnAtPos > 0
  924.         lcCode = TRIM( LEFT( m.lcCode, m.lnAtPos - 1))
  925.         llComment = .T.
  926.     ELSE
  927.         llComment = .F.
  928.     ENDIF
  929.     
  930.     IF RIGHT( m.lcCode, 1) = ";"
  931.         IF m.llComment
  932.             * Not allowed on same line!
  933.             WAIT WINDOW "Syntax Error: Semi-Colon and " + ;
  934.                 "double-& on same line." NOWAIT
  935.             _0_qcExit = "ERROR"
  936.             lcCode = SPACE(0)
  937.             EXIT
  938.         ELSE
  939.             llContinued = .T.
  940.             lcCode = LEFT( m.lcCode, LEN( m.lcCode) - 1)
  941.             LOOP
  942.         ENDIF
  943.     ELSE
  944.         * llContinued = .F.
  945.         EXIT
  946.     ENDIF
  947. ENDDO
  948.  
  949. IF NOT m.llText
  950.     lcUpper = UPPER( m.lcCode)
  951.  
  952.     IF m.lcUpper = "DO" AND ;
  953.         NOT INLIST( m.lcUpper, "DO WHILE", "DO CASE")
  954.         *
  955.         lcStub = LTRIM( SUBSTR( m.lcCode, 3))
  956.         lcUpper = UPPER( m.lcStub)
  957.     
  958.         DO CASE
  959.         CASE INLIST( m.lcUpper, "WHILE", "CASE")
  960.             lcCode = "DO " + m.lcStub
  961.         CASE m.lcUpper = "WHIL"
  962.             lcCode = "DO WHILE " + SUBSTR( m.lcStub, 5)
  963.         OTHERWISE
  964.             * Hopefully DO <SomeLegitProcedure>
  965.             * Leave alone.
  966.         ENDCASE
  967.     ENDIF
  968. ENDIF [NOT m.llText]
  969.  
  970. IF m.lcLastExct == "ON"
  971.     SET EXACT ON
  972. ENDIF
  973.  
  974. RETURN m.lcCode
  975.  
  976. * -------------------------------------------------------- *
  977.