📄 codeblck.prg
字号:
* CodeBlck.PRG
*
* FoxPro 2.5a (or later) Code Block Interpreter
*
* Created by: Randy Pearson, CYCLA Corporation
* Revision 1.0(d), September 20, 1994
*
* DO NOT rename this file! This program uses recursion (i.e.,
* calls itself) to handle nested programming constructs. If
* you must rename this file, be sure to revise all lines of code
* that include CodeBlck() calls.
*
* General Strategy:
* If code were all simple "in-line" code (no SCAN, DO, etc.),
* it is easy to run uncompiled by simply storing each line to
* a memory variable and then macro substituting each line.
*
* Thus, we adopt that approach, but when we encounter any control
* structure, we capture the actual code block within the structure,
* create an artificial simulation of the structure, and pass the
* internal code block recursively to this same routine. Nesting
* is handled automatically by this approach.
*
* Limitations:
* - Does not support embedded subroutines (PROC or FUNC)
* within code passed.
* Performs implied RETURN .T. if subroutine found.
* To use UDF's, capture each PROC/FUNC as its own code
* block and call CODEBLCK repeatedly as needed.
* - Doesn't accept TEXT w/ no ENDTEXT (although FP doc's
* suggest that this is acceptable to FP.
*
* Notes:
* All variables declared for usage by this routine have a
* prefix of _0_q (2 underscores, number zero, letter queue)
* in an attempt to minimize the chances of conflicts with
* variables in running programs.
*
* All FUNCTIONs are similarly named to avoid problems where
* the users code includes a DO <FunctionName> and that name
* matches a subroutine herein, which would be higher in the
* calling stack.
*
* No subroutines are called during _execution_ phases in order
* to minimize the depth of DO calls. FoxPro has a maximum
* of 32. My APPS are usually 10-16 levels deep at any time.
* By keeping all calls at top level, we only use up one level
* for each level of nesting in the code being processed.
*
* If your code block begins with a semicolon ";", the block is
* assumed to be a dBW-style code block, and all semicolons are
* translated to Cr-Lf pairs for the execution in this routine.
* (Existing code in files is not altered.)
*
* You may want to SET TALK OFF when testing this program from
* the Command Window.
PARAMETER _0_qcCode, _0_qlFile, _0_qlEdit
* _0_qcCode : Text of code to run OR File name with code.
* If blank, user gets screen to type code.
* _0_qlFile : .T. if 1st parameter is a file name. Internally
* passed as -1 when recursive call made.
* _0_qlEdit : .T. if user gets to edit code before running.
* Calling Examples:
* 1) Allow direct typing of code to run:
* DO CodeBlck
* 2) Run the code contained in memo field "TheCode":
* DO CodeBlck WITH TheCode
* 3) Same as 2, but allow review/edit first:
* DO CodeBlck WITH TheCode, .f., .T.
* 4) Run the code found in file "TESTRUN.PRG":
* DO CodeBlck WITH "TESTRUN.PRG", .T.
* 5) Same as 4, but allow user to review/edit:
* DO CodeBlck WITH "TESTRUN.PRG", .T., .T.
* [NOTE: The file doesn't get changed.]
* Record of Revision
* ==================
* Initials in brackets are credits to testers/users that found
* bugs or provided enhancement requests.
* [KL] = Ken Levy
* [BA] = Bill Anderson
* [TG] = Tom Gehrke
* [RP] = Randy Pearson
* 09/21/1994
* - Supports DO CODEBLCK, etc., from within another code block!
* Pass 2nd parameter as -1 to indicate recursion, rather than
* checking the program stack. Thus a code block can call
* CODEBLCK and it won't look like recursion. [BA, KL]
* - Trap for unsupportable commands CLEAR MEMORY, CLEAR ALL and
* RESTORE FROM w/o ADDITIVE. [BA]
* - Call error routine manually when unsupported statements found. [RP]
* - Adjusted SIZE of Edit Region for _MAC screens. [BA]
* - Added LEFT( , 254) to WAIT WINDOW in error handler, to avoid
* FP error if total expression exceeds 254 characters. [KL]
* - Expanded main CASE structure to detect orphaned END statements
* with no matching beginning statement. [RP]
* - Revised to RETURN .F. if file not found (or selected by user),
* or if user presses <Cancel> or doesn't enter any code. [RP]
* 09/14/1994
* - Revised to RETURN .T. if no RETURN <something> found, EXCEPT
* RETURN .F. if errors occur. [KL]
* - Revised to intercept dBW-style code blocks begining with
* and using semicolons as line breaks, and translating them
* to Cr-Lf pairs for this routine. [KL]
* - Removed bell in on error routine. [KL]
* - Changed all TYPE() function calls to use == operator, because
* dBW's TYPE() function now returns some 2-character codes (dBW
* programmers take note!) such as "CB", and we cannot be certain
* that FP 3.0 won't too. Existing code like TYPE("myvar") = "C"
* may break in dBW under some circumstances. [RP]
* 09/03/1994
* - Made determination of whether called recursively bullet-proof
* by analyzing entire program stack. [RP]
* - Cleaned up handling of FOR..ENDFOR and eliminated several
* unused memory variables. [RP]
* - Made several changes to streamline EXIT process when errors
* are encountered. [RP, KL]
* - Always return .T. if no code passed or file not found. [RP]
* - Made consistent the handling of "null blocks" (e.g., a SCAN
* ENDSCAN with no code in between. [RP]
* - Revised ON ERROR display to clarify that the Line ## is the
* CODEBLCK.PRG Line ##, not the line in the user's code. [TG]
*
* 09/02/1994
* - Changed name of program to CODEBLCK.PRG (from ZZRUNPRG.PRG). [KL]
* - Removed assumption that TEXTMERGE DELIMITERS were set to
* default values << >>. [RP]
* - Fixed bug where TEXT..ENDTEXT only worked correctly when
* SET TEXTMERGE was ON. [RP]
* - Revised font definitions for Mac. [BA]
* - Changed KEYCOMP to WINDOWS during code edit. [BA]
* - Localized setting/resetting of MEMOWIDTH in case users code
* depends on current setting. [RP]
* - Corrected various typos. [RP, TG]
* - Revised ON ERROR to send/receive MESSAGE(1), and optionally
* display it if there is no code being executed (i.e., it's my
* error rather than the users). [RP]
* - Revised routines to work properly if user has SET EXACT ON,
* by SET EXACT OFF when needed and lots of PADR() stuff. [RP]
* - Corrected bug where user's macro substitution didn't work
* within CASE, DO WHILE, and FOR. Lesson: If an expression
* might contain '&', always & it rather than EVAL() it. [BA, RP]
#DEFINE dnMaxNest 32
* Maximum DO nesting.
#DEFINE dnMemWidth 254
#DEFINE crLf CHR(13) + CHR(10)
* Carriage Return + Line Feed
PRIVATE _0_qnLines ;; # lines of code
PRIVATE _0_qnNext ;; Line # of next line of code
PRIVATE _0_qMemoW ;; previous SET MEMO setting
PRIVATE _0_qcLine1 ;; current line of code being processed
PRIVATE _0_qcUpper ;; UPPER() of same
PRIVATE _0_qxRet ;; Proposed RETURN value
PRIVATE _0_qcExpr ;; Fragment of control code line
PRIVATE _0_qnAtPos ;; Result of misc. AT() function calls.
PRIVATE _0_qcBlk ;; Nested block of code to pass recursively
PRIVATE _0_qnCount ;; Counter for misc. loops
PRIVATE _0_qlTop ;; Flag if top of recursion
IF TYPE( "m._0_qlFile") == "N" AND m._0_qlFile = -1
* Program called recursively.
_0_qlTop = .F.
ELSE
* First call to program.
_0_qlTop = .T.
* Establish "thread" control variables:
PRIVATE _0_qcExit ;; EXIT/LOOP/RETURN passback variable
PRIVATE _0_qcError ;; old ON ERROR process
_0_qcExit = SPACE(0)
_0_qcError = ON( "ERROR")
IF EMPTY(_0_qcError)
ON ERROR DO _0_qError WITH ;
ERROR(), LINENO(), MESSAGE(), MESSAGE(1)
ENDIF
* --- Deal with different calling methods, only
* --- applies to first call (not recursion):
IF m._0_qlFile
* File name as 1st parameter.
DO CASE
CASE EMPTY( m._0_qcCode) OR NOT TYPE("m._0_qcCode") == 'C'
_0_qcCode = GETFILE( 'PRG|TXT', 'Select File', 'Execute')
CASE '*' $ m._0_qcCode OR '?' $ m._0_qcCode
_0_qcCode = GETFILE( m._0_qcCode, 'Select File', 'Execute')
OTHERWISE
* Explicit file name sent.
ENDCASE
IF EMPTY( m._0_qcCode)
* File not found/selected.
DO _0_qRestE
RETURN .F.
ELSE
* Store file contents to memvar.
_0_qcCode = _0_qFile( m._0_qcCode)
ENDIF
ENDIF
IF NOT TYPE( "m._0_qcCode") == 'C'
* No code passed - see if any stored from last run.
IF PROGRAM(1) == "CODEBLCK" AND TYPE( "m._0_qcPrev") == "C"
_0_qcCode = m._0_qcPrev
ELSE
_0_qcCode = SPACE(0)
ENDIF
_0_qlEdit = .T.
ENDIF [no code passed as parameter]
_0_qcCode = ALLTRIM( m._0_qcCode)
IF LEFT( m._0_qcCode, 1) == ";"
* Assume dBW-style code block. Translate each ;
* to Cr-Lf so that this routine will run it.
_0_qcCode = STRTRAN( m._0_qcCode, ";", CrLf)
ENDIF
IF m._0_qlEdit
* Allow user to enter/edit code:
DO _0_qInput
IF NOT EMPTY( m._0_qcCode) AND ;
PROGRAM(1) == "CODEBLCK"
*
* Run from Command Window - save code
* so user can retry:
IF TYPE("m._0_qcPrev") == "U"
PUBLIC _0_qcPrev
_0_qcPrev = m._0_qcCode
ELSE
IF TYPE("m._0_qcPrev") == "C"
_0_qcPrev = m._0_qcCode
ENDIF
ENDIF [program previously used]
ENDIF [from Command window]
ENDIF [allow user to enter code]
IF EMPTY( m._0_qcCode)
* Still no code.
DO _0_qRestE
RETURN .F.
ENDIF [no code supplied to run]
ENDIF [called recursively]
_0_qMemoW = SET("MEMOWIDTH")
SET MEMOWIDTH TO dnMemWidth
_0_qnLines = MEMLINES( m._0_qcCode)
SET MEMOWIDTH TO m._0_qMemoW
_0_qnNext = 1
_0_qcLine1 = ""
_0_qxRet = .T.
DO WHILE m._0_qnNext <= m._0_qnLines
_0_qcLine1 = _0_qLine()
_0_qcUpper = UPPER( m._0_qcLine1)
DO CASE
CASE EMPTY( m._0_qcLine1)
* Almost assuredly past end.
LOOP
CASE PADR( m._0_qcUpper, 8) == "DO WHILE"
_0_qcExpr = SUBSTR( m._0_qcLine1, 9)
_0_qcBlk = _0_qBlock( 'DO WHILE')
DO WHILE &_0_qcExpr
IF NOT EMPTY( m._0_qcBlk)
_0_qxRet = CodeBlck( m._0_qcBlk, -1)
ENDIF
IF NOT EMPTY( m._0_qcExit)
IF m._0_qcExit = 'LOOP'
_0_qcExit = SPACE(0)
LOOP
ENDIF
IF m._0_qcExit = 'EXIT'
_0_qcExit = SPACE(0)
ENDIF
EXIT
ENDIF
ENDDO
CASE PADR( m._0_qcUpper, 4) == "SCAN"
_0_qcExpr = IIF( ALLTRIM( m._0_qcUpper) == "SCAN", ;
SPACE(0), ALLTRIM( SUBSTR( m._0_qcLine1, 5)))
_0_qcBlk = _0_qBlock( 'SCAN')
SCAN &_0_qcExpr
IF NOT EMPTY( m._0_qcBlk)
_0_qxRet = CodeBlck( m._0_qcBlk, -1)
ENDIF
IF NOT EMPTY( m._0_qcExit)
IF m._0_qcExit = 'LOOP'
_0_qcExit = SPACE(0)
LOOP
ENDIF
IF m._0_qcExit = 'EXIT'
_0_qcExit = SPACE(0)
ENDIF
EXIT
ENDIF
ENDSCAN
CASE PADR( m._0_qcUpper, 3) == "FOR"
_0_qcExpr = SUBSTR( m._0_qcLine1, 4)
_0_qcBlk = _0_qBlock( 'FOR')
FOR &_0_qcExpr
*
IF NOT EMPTY( m._0_qcBlk)
_0_qxRet = CodeBlck( m._0_qcBlk, -1)
ENDIF
IF NOT EMPTY( m._0_qcExit)
IF m._0_qcExit = 'LOOP'
_0_qcExit = SPACE(0)
LOOP
ENDIF
IF m._0_qcExit = 'EXIT'
_0_qcExit = SPACE(0)
ENDIF
EXIT
ENDIF
ENDFOR
CASE PADR( m._0_qcUpper, 2) == "IF"
_0_qcExpr = ALLTRIM( SUBSTR( m._0_qcLine1, 3))
IF &_0_qcExpr
_0_qcBlk = _0_qBlock( "IF")
ELSE
_0_qcBlk = _0_qBlock( "ELSE")
ENDIF
IF NOT EMPTY( m._0_qcBlk)
_0_qxRet = CodeBlck( m._0_qcBlk, -1)
ENDIF
CASE PADR( m._0_qcUpper, 7) == "DO CASE"
_0_qcBlk = _0_qBlock( "DO CASE")
* _0_qBlock() figures out which case to use.
IF NOT EMPTY( m._0_qcBlk)
_0_qxRet = CodeBlck( m._0_qcBlk, -1)
ENDIF
CASE PADR( m._0_qcUpper, 4) == "TEXT"
_0_qcBlk = _0_qBlock( 'TEXT')
_0_qMemoW = SET("MEMOWIDTH")
SET MEMOWIDTH TO dnMemWidth
FOR _0_qnCount = 1 TO MEMLINES( m._0_qcBlk)
_0_qcExpr = "\" + MLINE( m._0_qcBlk, m._0_qnCount)
&_0_qcExpr
ENDFOR
SET MEMOWIDTH TO m._0_qMemoW
CASE PADR( m._0_qcUpper, 4) == "LOOP"
_0_qcExit = "LOOP"
EXIT
CASE PADR( m._0_qcUpper, 4) == "EXIT"
_0_qcExit = "EXIT"
EXIT
* Prototype for statements to disallow. Remove comments or
* re-write portions if you want to disallow these.
*
* CASE INLIST( PADR( m._0_qcUpper, 4), "CANC", "QUIT")
* _0_qcExit = "ILLEGAL"
* _0_qxRet = .F.
* EXIT
CASE PADR( m._0_qcUpper, 9) == "CLEAR ALL" OR ;
PADR( m._0_qcUpper, 8) == "CLEA ALL" OR ;
PADR( m._0_qcUpper, 10) == "CLEAR MEMO" OR ;
PADR( m._0_qcUpper, 9) == "CLEA MEMO" OR ;
PADR( m._0_qcUpper, 7) == "RETU TO" OR ;
PADR( m._0_qcUpper, 8) == "RETUR TO" OR ;
PADR( m._0_qcUpper, 9) == "RETURN TO"
*
* These are known to break the system.
_0_qcExit = "ILLEGAL"
_0_qxRet = .F.
EXIT
CASE PADR( m._0_qcUpper, 4) == "REST" AND ;
"FROM " $ m._0_qcUpper AND ;
NOT "ADDI" $ m._0_qcUpper
*
* Can't have RESTORE FROM w/o ADDITIVE.
_0_qcExit = "ILLEGAL"
_0_qxRet = .F.
EXIT
CASE INLIST( PADR( m._0_qcUpper, 4), "PROC", "FUNC")
* Probably NOT good news, but maybe OK.
* This program does not support embedded PROC's
* and FUNC's. It can only call compiled routines.
_0_qcExit = "RETURN"
_0_qxRet = .T.
CASE INLIST( PADR( m._0_qcUpper, 4), ;
"ENDS", "ENDD", "ENDF", "ENDI", ;
"NEXT", "ENDC", "ENDT", "ELSE", "CASE")
*
* Nesting error in user's code.
_0_qnAtPos = AT( SPACE(1), m._0_qcUpper)
_0_qcExpr = LEFT( m._0_qcUpper, ;
IIF( m._0_qnAtPos = 0, 7, m._0_qnAtPos - 1))
WAIT WINDOW [Nesting Error - "] + m._0_qcExpr + ;
[" statement found, ] + CrLf + ;
[but there was no matching beginning statement.] NOWAIT
_0_qcExit = "ERROR"
_0_qxRet = .F.
EXIT
CASE PADR( m._0_qcUpper, 4) == "RETU"
_0_qcExit = "RETURN"
_0_qxRet = .T.
_0_qnAtPos = AT( SPACE(1), m._0_qcLine1)
IF m._0_qnAtPos > 0
_0_qcExpr = ALLTRIM( SUBSTR( m._0_qcLine1, m._0_qnAtPos))
IF NOT EMPTY( m._0_qcExpr)
* RETURN <something>
_0_qxRet = EVAL( m._0_qcExpr)
ENDIF
ENDIF
OTHERWISE
IF EMPTY( m._0_qcExit)
* Just do it:
&_0_qcLine1
ENDIF
ENDCASE
IF NOT EMPTY( m._0_qcExit)
* Some exit code encountered.
EXIT
ENDIF
ENDDO
SET MEMOWIDTH TO m._0_qMemoW
IF m._0_qcExit = "ILLEGAL"
DO _0_qError WITH 9999, 0, ;
"Unsupported Code Block statement", ;
m._0_qcLine1
ENDIF
IF m._0_qlTop
* leaving for good
DO _0_qRestE
ENDIF
IF m._0_qcExit == "ERROR"
_0_qxRet = .F.
ENDIF
RETURN m._0_qxRet
* -------------------------------------------------------- *
FUNCTION _0_qRestE
*
* Restore environment.
*
IF EMPTY( m._0_qcError)
ON ERROR
ELSE
ON ERROR &_0_qcError
ENDIF
RETURN .T.
* -------------------------------------------------------- *
FUNCTION _0_qFile
*
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -