📄 codeblck.prg
字号:
* Get file contents.
*
PARAMETER pcFile
IF NOT FILE( m.pcFile)
RETURN SPACE(0)
ENDIF
PRIVATE lnSelect, lcCode
lnSelect = SELECT()
SELECT 0
CREATE CURSOR _0_qFile (Contents M)
APPEND BLANK
APPEND MEMO Contents FROM ( m.pcFile)
lcCode = Contents
USE
SELECT (m.lnSelect)
RETURN m.lcCode
* -------------------------------------------------------- *
PROCEDURE _0_qError
*
* ON ERROR routine
*
PARAMETERS pnError, pnLineNo, pcMessage, pcMessage1
* ?? CHR(7) + CHR(7)
WAIT WINDOW LEFT( ;
"* CODE BLOCK RUNTIME ERROR *" + CrLf + CrLf + ;
"Error: " + LTRIM( STR( m.pnError)) + " occurred." + CrLf + ;
"Mes'g: " + m.pcMessage + CrLf + ;
"Code.: " + LEFT( IIF( TYPE( "m._0_qcLine1") == "C", ;
m._0_qcLine1, m.pcMessage1), 50) + CrLf + ;
"Modul: CodeBlck.PRG, Line: " + LTRIM( STR( m.pnLineNo)), ;
254) NOWAIT
*/ SUSPEND
STORE "ERROR" TO m._0_qcExit
STORE .F. TO m._0_qxRet
RETURN .T.
* -------------------------------------------------------- *
FUNCTION _0_qInput
*
* Allow EDIT of code.
*
PRIVATE lcControl, lcLastKeyC
lcControl = "Execute"
IF _WINDOWS OR _MAC
lcLastKeyC = SET( "KEYCOMP")
SET KEYCOMP TO WINDOWS
ENDIF
DO CASE
CASE _MAC
DEFINE WINDOW _0_qInput ;
AT 1, 0 ;
SIZE 16, 78 ;
TITLE " FoxPro Code Block Interpreter " ;
FONT "Geneva", 10 ;
STYLE "B" ;
COLOR RGB(,,,192,192,192) ;
FLOAT NOMDI
CASE _WINDOWS
DEFINE WINDOW _0_qInput ;
AT 1, 0 ;
SIZE 16, 78 ;
TITLE " FoxPro Code Block Interpreter " ;
FONT "MS Sans Serif", 9 ;
STYLE "B" ;
COLOR RGB(,,,192,192,192) ;
FLOAT NOMDI
OTHERWISE
DEFINE WINDOW _0_qInput ;
AT 1, 0 ;
SIZE 16, 76 ;
TITLE " FoxPro Code Block Interpreter " ;
COLOR SCHEME 1 ;
SHADOW ;
FLOAT NOMDI
ENDCASE
ACTIVATE WINDOW _0_qInput NOSHOW
IF _MAC
@ 1, 1 SAY "Enter code to run:" FONT "Geneva", 10 STYLE [B]
@ 2.2, 2 EDIT m._0_qcCode ;
SIZE 10, 87 ;
FUNCTION [3] ;
FONT "Monaco", 9 ;
SCROLL ;
TAB ;
MESSAGE "Press {Ctrl}+{Tab} to Exit Box"
@ 13, 25 GET m.lcControl ;
PICTURE "@*HT Execute;\?Cancel" ;
SIZE 1.7, 12, 5 ;
FONT "Chicago", 12 ;
MESSAGE "Press EXECUTE to Run Code, CANCEL to Skip"
ELSE
@ 1, 1 SAY "Enter code to run:"
@ 2.2, 2 EDIT m._0_qcCode ;
SIZE 8, 64 ;
FONT "Courier New", 8 ;
SCROLL ;
TAB ;
MESSAGE "Press {Ctrl}+{Tab} to Exit Box"
@ 13, 25 GET m.lcControl ;
PICTURE "@*HT \!Execute;\?Cancel" ;
SIZE 1.7, 12, 5 ;
MESSAGE "Press EXECUTE to Run Code, CANCEL to Skip"
ENDIF
MOVE WINDOW _0_qInput CENTER
SHOW WINDOW _0_qInput
READ CYCLE MODAL
DEACTIVATE WINDOW _0_qInput
IF NOT m.lcControl = 'Execute'
_0_qcCode = SPACE( 0)
ENDIF
RELEASE WINDOW _0_qInput
IF _WINDOWS OR _MAC
IF NOT m.lcLastKeyC = "WINDOWS"
SET KEYCOMP TO &lcLastKeyC
ENDIF
ENDIF
RETURN .T.
* -------------------------------------------------------- *
FUNCTION _0_qBlock
*
* Fetch block of code for recursive call, and increment
* pointer m._0_qnNext to point past end of block (e.g.,
* line after ENDCASE).
*
PARAMETER pcType
* {FOR, DO WHILE, IF, ELSE, DO CASE, SCAN, TEXT}
PRIVATE lcCodeBlk, lcLastExct
lcCodeBlk = SPACE(0)
lcLastExct = SET( 'EXACT')
SET EXACT OFF
PRIVATE laBlkStack, lnDepth
DIMENSION laBlkStack[ 1]
IF m.pcType == "ELSE"
laBlkStack[ 1] = "IF"
ELSE
laBlkStack[ 1] = m.pcType
ENDIF
lnDepth = 1
PRIVATE lcNext, lcUpper, lcSubstr
PRIVATE llSubSect, llTrueCase
llSubSect = NOT INLIST( m.pcType, "ELSE", "DO CASE")
* Flag of whether we're within
* a .T. case (thus code should
* be returned).
llTrueCase = .F.
* Flag of whether a .T. case has
* yet been found (thus don't evaluate
* further CASE's or process OTHERWISE).
DO WHILE NOT m._0_qcExit = "ERROR"
lcNext = _0_qLine( laBlkStack[ m.lnDepth])
IF m._0_qcExit = "ERROR"
* Error discovered by Line function.
EXIT
ENDIF
IF EMPTY( m.lcNext)
WAIT WINDOW "Nesting Error - no matching final END found " + ;
"for " + laBlkStack[ m.lnDepth] + "." NOWAIT
_0_qcExit = "ERROR"
EXIT
ENDIF
lcUpper = UPPER( m.lcNext)
DO CASE
CASE INLIST( m.lcUpper, "END", "NEXT")
* end of control structure
IF ( m.lcUpper = "ENDC" AND ;
INLIST( laBlkStack[ m.lnDepth], ;
"CASE", "OTHERWISE")) OR ;
( m.lcUpper = "ENDD" AND ;
laBlkStack[ m.lnDepth] = "DO WHILE") OR ;
( INLIST( m.lcUpper, "ENDF", "NEXT") AND ;
laBlkStack[ m.lnDepth] = "FOR") OR ;
( m.lcUpper = "ENDS" AND ;
laBlkStack[ m.lnDepth] = "SCAN") OR ;
( m.lcUpper = "ENDT" AND ;
laBlkStack[ m.lnDepth] = "TEXT") OR ;
( m.lcUpper = "ENDI" AND ;
INLIST( laBlkStack[ m.lnDepth], "ELSE", "IF"))
*
lnDepth = m.lnDepth - 1
IF m.lnDepth = 0
* Only valid exit point!
EXIT
ELSE
IF m.llSubSect
lcCodeBlk = m.lcCodeBlk + m.lcNext + CrLf
ENDIF
LOOP
ENDIF
ELSE
WAIT WINDOW "Nesting error. " + CrLf + ;
TRIM( PADR( m.lcUpper, 8)) + ;
" found, when matching begin " + ;
"line was " + laBlkStack[ m.lnDepth] + "." NOWAIT
_0_qcExit = "ERROR"
ENDIF
CASE UPPER( m.lcNext) = "ELSE"
IF laBlkStack[ m.lnDepth] = "IF"
laBlkStack[ m.lnDepth] = "ELSE"
IF m.lnDepth = 1
IF m.pcType == "IF"
m.llSubSect = .F.
ELSE
m.llSubSect = .T.
ENDIF
ELSE
IF m.llSubSect
lcCodeBlk = m.lcCodeBlk + m.lcNext + CrLf
ENDIF
ENDIF
LOOP
ELSE
WAIT WINDOW "ELSE nesting error - no matching IF. " NOWAIT
_0_qcExit = "ERROR"
ENDIF
CASE UPPER( m.lcNext) = "CASE"
IF INLIST( laBlkStack[ m.lnDepth], "DO CASE", "CASE")
laBlkStack[ m.lnDepth] = "CASE"
IF m.lnDepth = 1
IF m.llTrueCase
m.llSubSect = .F.
ELSE
lcSubstr = SUBSTR(m.lcNext, 5)
IF &lcSubstr
m.llTrueCase = .T.
m.llSubSect = .T.
ENDIF
ENDIF
ELSE
IF m.llSubSect
lcCodeBlk = m.lcCodeBlk + m.lcNext + CrLf
ENDIF
ENDIF
LOOP
ELSE
WAIT WINDOW "CASE nesting error - no matching DO CASE." NOWAIT
_0_qcExit = "ERROR"
ENDIF
CASE UPPER( m.lcNext) = "OTHE"
IF INLIST( laBlkStack[ m.lnDepth], "DO CASE", "CASE")
laBlkStack[ m.lnDepth] = "OTHERWISE"
IF m.lnDepth = 1
IF m.llTrueCase
m.llSubSect = .F.
ELSE
m.llSubSect = .T.
ENDIF
ELSE
IF m.llSubSect
lcCodeBlk = m.lcCodeBlk + m.lcNext + CrLf
ENDIF
ENDIF
LOOP
ELSE
WAIT WINDOW "OTHERWISE nesting error - no matching DO CASE." NOWAIT
_0_qcExit = "ERROR"
ENDIF
CASE INLIST( m.lcUpper, "IF", "DO WHIL", "SCAN", ;
"TEXT", "DO CASE", "FOR")
*
IF laBlkStack[ m.lnDepth] = "DO CASE"
WAIT WINDOW "Nesting error - DO CASE w/o CASE. " NOWAIT
_0_qcExit = "ERROR"
ELSE
lnDepth = m.lnDepth + 1
DIMENSION laBlkStack[ m.lnDepth]
DO CASE
CASE UPPER( m.lcNext) = "IF"
laBlkStack[ m.lnDepth] = "IF"
CASE UPPER( m.lcNext) = "DO WHIL"
laBlkStack[ m.lnDepth] = "DO WHILE"
CASE UPPER( m.lcNext) = "SCAN"
laBlkStack[ m.lnDepth] = "SCAN"
CASE UPPER( m.lcNext) = "TEXT"
laBlkStack[ m.lnDepth] = "TEXT"
CASE UPPER( m.lcNext) = "DO CASE"
laBlkStack[ m.lnDepth] = "DO CASE"
CASE UPPER( m.lcNext) = "FOR"
laBlkStack[ m.lnDepth] = "FOR"
OTHERWISE
WAIT WINDOW "Internal CODEBLCK consistency error." NOWAIT
_0_qcExit = "ERROR"
ENDCASE
IF m.llSubSect
lcCodeBlk = m.lcCodeBlk + m.lcNext + CrLf
ENDIF
LOOP
ENDIF
OTHERWISE
* legitmate in-line code
IF m.llSubSect
lcCodeBlk = m.lcCodeBlk + m.lcNext + CrLf
ENDIF
ENDCASE
ENDDO
IF m.lcLastExct == "ON"
SET EXACT ON
ENDIF
IF m._0_qcExit = "ERROR"
lcCodeBlk = SPACE(0)
ENDIF
RETURN m.lcCodeBlk
* -------------------------------------------------------- *
FUNCTION _0_qLine
*
* Return next line of code, ignoring comments and
* blank lines. Leave m._0_qnNext pointing to first
* text line after returned line of code. Return null string
* if no code line found to end of block.
*
* Assume m._0_qnNext points to line to read
* m._0_qnLines counts total # of lines
* m._0_qcCode contains the total code
*
PARAMETER pcType
* Type of inner most block. If "TEXT" skip almost
* all "conditioning" steps and take literally.
PRIVATE lcCode, lcUpper, lnMemoWidt, lcLastExct
lcCode = SPACE(0)
lnMemoWidt = SET( 'MEMOWIDTH')
lcLastExct = SET( 'EXACT')
SET EXACT OFF
PRIVATE llContinued, lnAtPos, llComment, llText
llContinued = .F.
lnAtPos = 0
llComment = .F.
llText = TYPE( "m.pcType") == "C" AND m.pcType == "TEXT"
DO WHILE m._0_qnNext <= m._0_qnLines
SET MEMOWIDTH TO dnMemWidth
DO CASE
CASE m.llText
* Within TEXT...ENDTEXT; leave alone.
lcCode = MLINE( m._0_qcCode, m._0_qnNext)
CASE m.llContinued
* 2nd or later line in multi-line
* statement; attach but don't LTRIM(),
* since we could be in middle of delimited string.
lcCode = m.lcCode + TRIM( ;
MLINE( m._0_qcCode, m._0_qnNext))
OTHERWISE
* Beginning of new line of normal code; LTRIM
* any indentation after removing TAB's.
lcCode = LTRIM( STRTRAN( ;
MLINE( m._0_qcCode, m._0_qnNext), ;
CHR(9), SPACE(1)))
IF EMPTY( m.lcCode) OR ;
INLIST( LTRIM( m.lcCode), "*", "&" + "&", "#")
* Blank or comment line OR compiler directive.
* (Can't type 2 &'s together in FoxPro)
* (Probably if compiler directive, subsequent
* code will fail, but give it a try.)
lcCode = SPACE(0)
ENDIF
ENDCASE
SET MEMOWIDTH TO m.lnMemoWidt
_0_qnNext = m._0_qnNext + 1
IF m.llText
EXIT
ENDIF
IF EMPTY( m.lcCode)
LOOP
ENDIF
lnAtPos = AT( "&" + "&", m.lcCode)
* Note gymnastics to avoid compile error.
IF m.lnAtPos > 0
lcCode = TRIM( LEFT( m.lcCode, m.lnAtPos - 1))
llComment = .T.
ELSE
llComment = .F.
ENDIF
IF RIGHT( m.lcCode, 1) = ";"
IF m.llComment
* Not allowed on same line!
WAIT WINDOW "Syntax Error: Semi-Colon and " + ;
"double-& on same line." NOWAIT
_0_qcExit = "ERROR"
lcCode = SPACE(0)
EXIT
ELSE
llContinued = .T.
lcCode = LEFT( m.lcCode, LEN( m.lcCode) - 1)
LOOP
ENDIF
ELSE
* llContinued = .F.
EXIT
ENDIF
ENDDO
IF NOT m.llText
lcUpper = UPPER( m.lcCode)
IF m.lcUpper = "DO" AND ;
NOT INLIST( m.lcUpper, "DO WHILE", "DO CASE")
*
lcStub = LTRIM( SUBSTR( m.lcCode, 3))
lcUpper = UPPER( m.lcStub)
DO CASE
CASE INLIST( m.lcUpper, "WHILE", "CASE")
lcCode = "DO " + m.lcStub
CASE m.lcUpper = "WHIL"
lcCode = "DO WHILE " + SUBSTR( m.lcStub, 5)
OTHERWISE
* Hopefully DO <SomeLegitProcedure>
* Leave alone.
ENDCASE
ENDIF
ENDIF [NOT m.llText]
IF m.lcLastExct == "ON"
SET EXACT ON
ENDIF
RETURN m.lcCode
* -------------------------------------------------------- *
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -