Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive : DGENIII.ZIP
Filename : DGPROC.PRG
* Filename.: dg_proc.prg
* Author...: Tom Rettig
* Dates....: 3/28/84, 8/30/84, 12/29/84, 12/30/84, 12/31/84, 1/01/85,
* 1/03/85, 1/04/85, 1/05/85, 1/06/85, 1/11/85, 1/12/85,
* 1/13/85, 1/15/85, 1/25/85, 1/26/85, 1/27/85, 1/28/85,
* 1/29/85, 1/30/85, 2/01/85, 2/09/85, 2/10/85, 2/12/85,
* 2/13/85, 2/16/85, 2/17/85, 2/18/85, 2/19/85, 2/22/85,
* 2/23/85, 2/24/85, 2/25/85, 3/17/85, 4/01/85, 6/01/85,
* 6/26/85, 6/27/85, 7/01/85, 7/25/85, 7/27/85
* Notice...: Copyright 1985, Tom Rettig & Associates, All Rights Reserved.
* Version..: 1.0 (x30)
* Run under: dBASE III, any version greater than 1.1, or dBRUN.
* Notes....: To generate executable dBASE code from screen-forms
* and database files.
*
* Called from...: dg_main.prg
*
* Files requed: dg_main.prg --> Program entry and main menu
* dg.dbf --> Structure for database: dg.dbf
* Field Field Name Type Width
* 1 DG_TEXT Character 254
* ** Total ** 255
*
* Procedures are in alphabetical order:
* dg_main ::= entry/exit from dGENERATE and main menu
* 1 abort ::= aborts code generation and returns to main menu
* 2 alt_file ::= opens/closes alternate file and writes header/footer
* 3 config ::= initializes system values from parameters line
* 4 crea_new ::= creates a new screen-form for drawing
* 5 doer ::= executes a command file
* 6 editor ::= edits a screen-form or any text file
* 7 file_msg ::= displays source and target filenames
* 8 fileprmt ::= prompts for a filename and tests for existence
* 9 generate ::= reads a screen-form and causes code to be written
* 10 gen_entr ::= writes code for data entry/edit algorithm
* 11 gen_menu ::= writes code for menu algorithm
* 12 gen_rprt ::= writes code for report algorithm
* 13 helper ::= main help file
* 14 hlp_crea ::= help screen for crea_new
* 15 hlp_doer ::= help screen for doer
* 16 hlp_edit ::= help screen for edit
* 17 hlp_gene ::= help screen for generate
* 18 hlp_mgen ::= help screen for mem_gen
* 19 hlp_setu ::= help screen for setup
* 20 hlp_togl ::= toggles between pages in multi-page hlp_* screens
* 21 key_time ::= displays continuous time while waiting for keypress
* 22 line_inc ::= increments line counter and tests for new page
* 23 marquee ::= places this program's headings on screen
* 24 mem_gen ::= writes memvar statements from database file
* 25 pars_lit ::= parses literal strings for write
* 26 pars_var ::= parses variables for write
* { 27 setup ::= menu driven edit of the default parameters
* 28 set_if1 ::= setup options -|
* 29 set_if2 ::= setup options -|---(broken up for performance)
* 30 set_if3 ::= setup options -|
* 31 wait_msg ::= handles 'be patient' message, and sets up abort
* 32 write ::= writes code from parsed literals or variables
*
* Macro is used in the syntax of these commands:
* APPEND FROM, DIR, DO, ERASE, MODIFY COMMAND, RUN, USE
* SET ALTERNATE, SET COLOR, SET DELIMITERS
PROCEDURE abort
PARAMETERS dl_wrkfile
* Called from crea_new, generate, mem_gen
ON ESCAPE *
SET COLOR TO &dg_accent
SET BELL ON
@ 22,0 SAY " Aborting this procedure!!!" +;
" h "
?? CHR(7), CHR(7)
@ 23,0 SAY " One moment, please, while I clean up..." +;
" "
SET COLOR TO &dg_normal
SET BELL OFF
*
CLOSE ALTERNATE
IF FILE(dl_wrkfile)
ERASE &dl_wrkfile
ENDIF
*
CLOSE INDEXES
IF FILE("Dg_temp$.ndx")
ERASE Dg_temp$.ndx
ENDIF
*
* This is possible only from generate where 'dg_param' is reinitialized.
* (unless crea_new or mem_gen are told to use dg.dbf)
IF "DG.DBF" $ UPPER(DBF())
SET SAFETY OFF
ZAP
SET SAFETY ON
IF [] < dl_oldt
APPEND BLANK
REPLACE Dg_text WITH dl_oldt
DO config WITH dl_oldt
ENDIF
ENDIF
*
USE
*
IF FILE("Dg_temp$.dbf")
ERASE Dg_temp$.dbf
ENDIF
*
ON ESCAPE SUSPEND
RETURN TO MASTER
*
* EOP abort **********************************{***********************
{PROCEDURE alt_file
* Called from generate and mem_gen, not from crea_new
PARAMETERS dl_targetf, dl_part
*
IF dl_part = 1
* Open target file, and write its name and system date as a header.
@ 3,0 SAY []
SET ALTERNATE TO &dl_targetf
SET ALTERNATE ON
?? "* Program..: " + dl_targetf
? "* Author...:
? "* Date.....: " + DTOC(DATE())
? "* Notice...: Copyright " + STR(YEAR(DATE()),4) +;
",
? "* Notes....: "
? "*"
?
ELSE
* Write footer and close the file.
?? "* EOF: " + dl_targetf
CLOSE ALTERNATE
ENDIF
*
RETURN
* EOP alt_file *******************************************************
PROCEDURE config
* Called from default, generate, setup
PARAMETERS dl_linef
*
* Characters used to denote SAYs and GETs in the screen-form.
dg_atget = SUBSTR(dl_linef,13,1)
dg_atsay = SUBSTR(dl_linef,15,1)
* Character used to denote a memvar initialization in the screeo~form.
dg_init = SUBSTR(dl_linef,17,1)
* Number of columns on the screen (1..254).
dg_eol = VAL(SUBSTR(dl_linef,19,3)) && end of line
* Number of lines (rows) on the screen (1..999).
dg_eos = VAL(SUBSTR(dl_linef,23,3)) && end of screen
* Logicals.
dg_isreltv = SUBSTR(dl_linef,27,1) = [T] && relative addressing in code
dg_isruler = SUBSTR(dl_linef,29,1) = [T] && ruler line in screen-form
dg_isdelim = SUBSTR(dl_linef,31,1) = [T] && set delimiters on
dg_isfill = SUBSTR(dl_linef,33,1) = [T] && fill screen-form with blanks
dg}7ishelp = SUBSTR(dl_linef,35,1) = [T] && help screens for each menu item
* Default file extensions.
dg_fmemout = SUBSTR(dl_linef,37,3) && output file for creating memvars
dg_fscrout = SUBSTR(dl_linef,41,3) && output file for code from screen-form
dg_fscr_in = SUBSTR(dl_linef,45,3) && screen-form file for drawing screens
* Characters in ruler.
dg_rule1 = SUBSTR(dl_linef,49,1) && appears in column zero only
dg_rule = SUBSTR(dl_linef,51,10) && repeats every ten columns after zero
* Delimiters.
dg_delim = SUBSTR(dl_linef,62,2) && characters used for delimiters
* Character used in this menu (ASCII value).
dg_char = VAL(SUBSTR(dl_linef,65,3)) && used in marquee of this program
* Word processor.
dg_wp = SUBSTR(dl_linef,69,8) && external editor for screen-forms
*
* Program constants.
dg_line = REPLICATE(CHR(dg_char),80) && marquee line in this program
dg_ruler = dg_rule1 + REPLICATE(dg_rule,INT((dg_eol-1)/10)) +;
LEFT(dg_rule,MOD(dg_eol-1,10)) && ruler line in screen-forms
dg_max = IIF(dg_eol < 100, 2, 3) && number of digits in @ coordinates
*
* Set the delimiters.
IF dg_isdelim .AND. dg_delim > [ ]
SET DELIMITERS TO [&dg_delim]
SET DELIMITERS ON
ELSE
SET DELIMITERS OFF
ENDIF
*
* Convert logicals to character.
dl_1 = IIF(dg_isreltv, "T", "F")
dl_2 = IIF(dg_isruler, "T", "F")
dl_3 = IIF(dg_isdelim, "T", "F")
dl_4 = IIF(dg_isfill , "T", "F")
dl_5 = IIF(dg_ishelp , "T", "F")
*
* Construct a new parameters line from individual memvars.
dl = [ ]
dg_param = [parameters: ]+dg_atget+dl+dg_atsay+dl+dg_init+dl+;
STR(dg_eol,3)+dl+STR(dg_eos,3)+dl+dl_1+dl+dl_2+dl+dl_3+dl+dl_4+dl+dl_5+dl+;
dg_fmemout+dl+dg_fscrout+dl+dg_fscr_in+dl+dg_rule1+dl+dg_rule+dl+;
dg_delim+dl+STR(dg_char,3)+dl+dg_wp
*
RETURN
* EOP config *********************************************************
PROCEDURE crea_new
* Called from menu
* To initialize a text file for drawing screens.
*
DO marquee WITH [ Creating a New Screen ]
*
IF dg_ishelp
DO helper WITH 1
ENDIF
*
* Prompt for name of target text file.
dl_targetf = [ ]
dl_defext = dg_fscr_in
dl_istargt = .T.
dl_isedit = .F.
DO fileprmt
IF dg_iserror
RETURN
ENDIF
*
* Prompt for name of source database file if any.
dl_sourcef = []
dl_names = [?]
SET COLOR TO &dg_accent
*
@ 11,13 SAY "Add field and memvar names from a database file? (Y/N)" ;
GET dl_names
IF dg_ishelp
@ 13,08 SAY "Memory variable names are generated from "+;
"this file's field names,"
@ 14,14 SAY "and both are placed in the screen-form for your use."
ENDIF
*
READ
@ 11,13
{@ 13,08
@ 14,14
SET COLOR TO &dg_normal
IF dl_names $ "Yy"
dl_defext = [dbf]
STORE .F. TO dl_istargt, dl_isedit
DO fileprmt
IF dg_iserror
RETURN
ENDIF
ENDIF
*
dl_abortf = dl_targetf
DO wait_msg WITH 1
DO file_msg WITH dl_sourcef, dl_targetf
* returns with color set to dg_accent.
*
* Open target file, and write.
SET CONSOLE OFF
SET ALTERNATE TO &dl_targetf
SET ALTERNATE ON
*
* Write the top (ruler) line.
IF dg_isruler
?? dg_ruler
ENDIF
*
* Write the screen body.
dl_i = 1
IF dg_isfill
DO WHILE dl_i <= dg_eos
? SPACE(dg_eol)
dl_i = dl_i+1
ENDDO
ELSE
DO WHILE dl_i <= dg_eos
?
dl_i = dl_i+1
ENDDO
ENDIF
*
* Add parameters, date, and definition table lines.
?
? "dgDEFINE -- Begin definitions in the first column. Example syntax follows:"
? "
"]
IF [] < dl_sourcef && add memvars initialized from file if requested
dl_oldt = [] && for abort if dg.dbf is specified
USE &dl_sourcef
dl_i = 1
DO WHILE [] < FIELD(dl_i)
? [ m_] + LOWER(SUBSTR(FIELD(dl_i),1,8)) + [ ] + dg_init + [ ] +;
SUBSTR(FIELD(dl_i),1,1) + LOWER(SUBSTR(FIELD(dl_i),2))
dl_i = dl_i+1
ENDDO
* Add file O{pening statement.
?
? [dgFILE], dl_sourcef
USE
ENDIF
?
?
? "Begin options in the first column, one per line."
? "Code generating options are: dgENTRY, dgMENU, and dgREPORT, one per screen."
? "File opening option is: dgFILE
?
?
? LEFT(dg_param,29) + [ ] + DTOC(DATE())
? " | | | | | | |"
? " GET Symbol-' | | | | | `-Ruler line (T/F)"
? " SAY Symbol---' | | | `---Relative Addressing (T/F)"
? " Initialization | | `-------Form Length (rows: 1..999)"
? " Symbol-' `-----------Form Width (columns: 1..254)"
*
CLOSE ALTERNATE
ON ESCAPE SUSPEND
SET CONSOLE ON
SET COLOR TO &dg_normal
*
* Automatic edit with this target filename.
DO editor WITH dl_targetf
*
RETURN
* EOP crea_new *******************************************************
PROCEDURE doer
* Called from menu and generate
PARAMETERS{dl_fname
*
DO marquee WITH [ DOing a Command File ]
*
* Branch for call from menu
IF [] = dl_fname
IF dg_ishelp
DO helper WITH 5
ENDIF
*
* Prompt for name of command file.
dl_sourcef = [ ]
dl_defext = dg_fscrout
STORE .F. TO dl_istargt, dl_isedit
DO fileprmt
IF dg_iserror
RETURN
ENDIF
dl_fname = dl_sourcef
ENDIF
*
* Do nothing about errors in DO file so they can be observed.
CLEAR
DO &dl_fname
*
RETURN
* EOP doer *********************************************************
PROCEDURE editor
* Called from menu and create
PARAMETERS dl_finame
*
DO marquee WITH [ Editing a Screen-Form ]
*
IF dg_ishelp
DO helper WITH 2
ENDIF
*
* Branch for call from menu
IF [] = dl_finame
*
* Prompt for name of source text file.
dl_sourcef = [ ]
dl_defext = dg_fscr_in
dl_istargt = .F.
dl_isedit = .T.
DO fileprmt
IF dg_iserror
RETURN
ENDIF
dl_finame = dl_sourcef
ENDIF
*
DO file_msg WITH dl_finame, []
SET COLOR TO &dg_normal
*
* No way to check for existence of word processor file where DOS
* path is set to its location in another directory. Only solution
* is to set WP in Config.db and use MODI COMM.
IF dg_wp > [ ]
RUN &dg_wp &dl_finame
SET COLOR TO &dg_normal
{ELSE
MODIFY COMMAND &dl_finame
ENDIF
*
* Automatic generation of edited file if
* extension is screen-form and file exists.
IF RIGHT(dl_finame,3) = dg_fscr_in .AND. FILE(dl_finame)
DO generate WITH dl_finame
ENDIF
*
RETURN
* EOP editor *********************************************************
PROCEDURE file_msg
PARAMETERS dl_sfile, dl_tfile
* Called from crea_new, editor, generate, mem_gen
* Sets color to dg_accent on return.
@ 23,11 SAY IIF([] < dl_tfile, ;
"Source file: >>> Target file: ",;
"Source file:")
SET COLOR TO &dg_accent
@ 23,24 SAY IIF([] = dl_sfile, "
@ 23,56 SAY dl_tfile
*
RETURN
* EOP file_msg *******************************************************
PROCEDURE fileprmt
* Called from crea_new, doer, editor, generate, mem_gen
* To prompt for filenames, input & output with different default extensions.
* dl_defext, dl_istargt, dl_isedit are i{itialized in calling routine.
* If dl_isedit, then it's ok for source file not to exist.
*
* Display files of the appropriate type.
* (file types are screen-form, executable, or database)
* System extensions (dg_f...) must be initialized in calling routine.
@ 4,0 SAY "Existing " + IIF(dl_defext=dg_fscr_in .OR. dl_defext=dg_fscrout,;
IIF(d{_defext=dg_fscr_in,"screen-form","executable"),"database")+;
" files in the current directory are:"
@ 5,0 SAY []
IF "UNIX" $ OS()
DIR ALL *.&dl_defext
ELSE
DIR *.&dl_defext
ENDIF
*
* Returns true if operator chooses to abort.
dg_iserror = .F.
*
DO WHILE .T.
dl_n = [ .] + dl_defext
SET COLOR TO &dg_accent
@ 17,10 SAY "Enter " + IIF(dl_istargt, "target", "source") +;
" filename, or press " + dg_key + " to abort:"
@ 17,COL()+1 GET dl_n PICTURE [AXXXXXXXXXXX]
READ
*
* Clear re-enter prompt, if any.
@ 22,17
@ 23,13
*
DO CASE
CASE dl_n = [ .] + dl_defext .OR. LTRIM(dl_n) = [.] .OR.;
[] = TRIM(dl_n)
* Abort.
dg_iserror = .T.
SET COLOR TO &dg_normal
@ 17,10
RETURN
CASE "DOS"$OS() .AND. ( "["$dl_n .OR. "]"$dl_n .OR. "^"$dl_n .OR.;
{ "*"$dl_n .OR. "+"$dl_n .OR. "="$dl_n .OR. ";"$dl_n .OR.;
"<"$dl_n .OR. ">"$dl_n .OR. ","$dl_n .OR. "?"$dl_n .OR.;
"|"$dl_n .OR. "\"$dl_n .OR. "/"$dl_n )
* Invalid entry.
@ 23,18 SAY "Invalid filename, please re-enter or abort..."
LOOP
CASE "." $ dl_n
* Trim the name and place next to the extension.
dl_n = LTRIM(RTRIM( SUBSTR(dl_n,1,AT(".",dl_n)-1) )) +;
SUBSTR(dl_n,AT(".",dl_n),4)
OTHERWISE
* Trim the name and add the defa{lt extension.
dl_n = IIF(LEN(LTRIM(RTRIM(dl_n))) > 8,;
SUBSTR(LTRIM(RTRIM(dl_n)),1,8),;
LTRIM(RTRIM(dl_n)) ) + [.] + dl_defext
ENDCASE
*
* Branch for space in filename. Space is allowed in CASE statement
* above in order to allow for spaces between the name and extension.
IF [ ] $ dl_n
@ 23,18 SAY "Invalid filename,{please re-enter or abort..."
LOOP
ENDIF
*
SET COLOR TO &dg_normal
*
IF dl_istargt
* It's a target file.
*
IF FILE(dl_n)
SET COLOR TO &dg_accent
@ 22,(54-LEN(dl_n))/2 SAY dl_n + " exists where I'm looking."
@ 23,13 SAY "Press
SET COLOR TO &dg_normal
dl_i = 0
DO key_time WITH COL()
IF CHR(dl_i) $ "wW"
dl_targetf = dl_n
EXIT
ELSE
@ 17,10
@ 22,21
@ 23,13
LOOP
ENDIF
ELSE
dl_targetf = dl_n
EXIT
ENDIF
ELSE
* It's a source file.
*
IF FILE(dl_n) .OR. dl_isedit
* It's ok for the dl_sourcef to not exist when coming from editor.
dl_sourcef = dl_n
SET COLOR TO &dg_normal
EXIT
ELSE
SET COLOR TO &dg_accent
@ 22,(47-LEN(dl_n))/2 ;
SAY dl_n + " doesn't exist where I'm looking."
@ 23,13 ;
SAY "Please enter a different source filename, or abort..."
ENDIF [FILE(dl_n) .OR. dl_isedit]
ENDIF [dl_istargt]
ENDDO [WHILE .T.]
*
* Clear screen body and repaint bottom screen line before returning.
SET COLOR TO &dg_normal
@ 3,0 CLEAR
@ 21,0 SAY dg_line
RETURN
*
* EOP fileprmt *******************************************************
PROCEDURE generate
* Called from menu and editor
PARAMETERS dl_filname
* Variable 'dl_filname' is used as the source file in this module.
*
DO marquee WITH [ Generating Commands ]
*
* Branch for call from menu.
IF [] = dl_filname
IF dg_ishelp
DO helper WITH 3
ENDIF
*
* Prompt for name of source text file.
dl_sourcef = [ ]
dl_defext = dg_fscr_in
STORE .F. TO dl_istargt, dl_isedit
DO fileprmt
IF dg_iserror
RETURN
ENDIF
dl_filname = dl_sourcef
ENDIF
*
* Target filename is automatic from source file.
STORE SUBSTR(dl_filname,1,AT(".",dl_filname)) + dg_fscrout ;
TO dl_tfile, dl_abortf
*
DO wait_msg WITH 1
DO file_msg WITH dl_filname, dl_tfile
*
* Open system database file, and preserve the parameters line if any.
USE dg
dl_oldt = IIF(RECCOUNT() > 0 .AND. Dg_text = "parameters: ",;
TRIM(Dg_text), [] )
SET SAFETY OFF
ZAP
*
* Bring source text file into database file, and index.
APPEND FROM &dl_filname SDF
INDEX ON LEFT(Dg_text,13) TO Dg_temp$.ndx
*
SET SAFETY ON
*
* Read parameters line of file, and set everything accordingly.
SEEK "parameters: "
*
* Parameter test is different from one in main.
dl_isdiffp = .F.
IF FOUND() .AND. SUBSTR(Dg_text,27,1) $ [TF] .AND.;
SUBSTR(Dg_text,29,1) $ [TF] .AND.;
SUBST{(Dg_text,13,1) # SUBSTR(Dg_text,15,1)
* Branch if parameters in file do not equal current system parameters.
IF LEFT(dg_param,29) # LEFT(Dg_text,29)
dl_isdiffp = .T.
dl_oldp = dg_param && save the current parameters
DO config WITH LEFT(Dg_text,29) + SUBSTR(dg_param,30)
ENDIF
ELSE
SET COLOR TO &dg_normal
@ 22,1 SAY "Parameters line in Source file is not valid; " +;
"current system values being used."
SET COLOR TO &dg_accent
ENDIF
*
* Clear waiting message, open target file, and write its header.
DO wait_msg WITH 2
DO alt_file WITH dl_tfile, 1
*
* Establish offset between top of file and row zero.
* (top of screen ::= dl_offset; end of screen ::= dg_eos + dl_offset)
dl_offset = IIF(dg_isruler,2,1)
*
* If any says or gets are in the screen, prepare for the
* case where one is undefined or unitialized.
SET ORDER TO 0
GO dl_offset && top of screen
LOCATE WHILE RECNO() < dg_eos + dl_offset;
FOR (dg_atget $ Dg_text .OR. dg_atsay $ Dg_text) .AND.;
Dg_text # "parameters: " .AND. Dg_text # "
DO line_inc
?? [undefined = "***"]
DO line_inc
ENDIF
*
* Write the file-opening command if there is one.
SET ORDER TO 1
SEEK [dgFILE ]
dl_isfile = FOUND({
IF FOUND()
DO line_inc
DO line_inc
?? [USE ] + LTRIM(RTRIM(SUBSTR(Dg_text,AT(" ",Dg_text))))
DO line_inc
ENDIF
*
* Write the initialized memvar statements.
SEEK [dgDEFINE]
IF FOUND()
SET ORDER TO 0
SKIP 2
DO WHILE [] < TRIM(Dg_text) .AND. .NOT. EOF()
IF dg_init $ Dg_text
dl_phrase = LTRIM(RTRIM(SUBSTR(Dg_text,AT(dg_init,Dg_text)+1)))
dl_loc = IIF(" PICT"$UPPER(dl_phrase),AT(" PICT",UPPER(dl_phrase)),;
AT(" FUNC",UPPER(dl_phrase)))
dl_exp = IIF(dl_loc>0, TRIM(LEFT(dl_phrase,dl_loc)), dl_phrase)
dl_var = LTRIM(SUBSTR(Dg_text,3,AT(" ",LTRIM(SUBSTR(Dg_text,3)))))
*
DO line_inc
?? dl_var + SPACE(11-LEN(dl_var)) + [= ] +;
IIF(TYPE("dl_exp")="U",[undefined],dl_exp)
ENDIF
SKIP
ENDDO
DO line_inc
SET ORDER TO 1
ENDIF
*
* Write the delimiters code if requested.
IF dg_isdelim
DO line_inc
?? [SET DELIMITERS TO ] + dg_delim
DO line_inc
ENDIF
*
* Write part one of the requested optional code.
STORE .F. TO dl_isentry, dl_ismenu, dl_isreprt
SEEK [dgENTRY ]
IF FOUND()
dl_isentry = .T.
DO gen_entr WITH 1
ELSE
SEEK [dgMENU ]
IF FOUND()
dl_ismenu = .T.
dl_menupos = RECNO()
DO gen_menu WITH 1 && sets ORDER to 0
ELSE
SEEK [dgREPORT ]
IF FOUND()
dl_isreprt = .T.
DO gen_rprt WITH 1
ENDIF [report]
ENDIF [menu]
{ENDIF [entry]
*
* Write the beginning relative positioning statement.
dl_lastrow = 0
IF dg_isreltv
DO line_inc
?? [@ ] + STR(dl_lastrow,dg_max) + [,] + STR(dl_lastrow,dg_max) +;
[ SAY ""]
ENDIF
*
* Parse each line on the screen, and write the output code.
SET ORDER TO 0
GO dl_offset && top of screen
DO WHILE RECNO() < dg_eos+dl_offset .AND. .NOT. EOF()
IF [] < TRIM(Dg_text)
dl_atrow = RECNO() - dl_offset
dl_line = LEFT(Dg_text,dgS{ol)
* 'dl_i' is a pointer to individual characters in 'dl_line'.
* Point to first character, skipping any spaces.
dl_i = AT(LTRIM(dl_line), dl_line)
DO WHILE dl_i <= dg_eol
dl_str = SUBSTR(dl_line, dl_i)
IF dl_str = dg_atsay .OR. dl_str = dg_atget
* Process it as a variable.
DO pars_var
* Reposition record pointer which is moved to search for defines.
GO dl_atrow + dl_offset
ELSE
* Process it as a literal.
DO pars_lit
ENDIF
dl_lastrow = dl_atrow
ENDDO
ENDIF
SKIP
ENDDO
*
DO line_inc
* Write part two of the requested optional code.
DO CASE
CASE dl_isentry
DO gen_entr WITH 2
CASE dl_ismenu
DO gen_menu WITH 2
CASE dl_isreprt
DO gen_rprt WITH 2
ENDCASE
*
* Write file-closing command if one was opened.
IF dl_isfile
DO line_inc
?? [USE]
ENDIF
*
DO line_inc
DO line_inc
?? [WAIT ""]
*
* Close the target file.
DO line_inc
DO alt_file WITH dl_tfile, 2
*
* Restore environment.
ON ESCAPE SUSPEND
SET COLOR TO &dg_normal
CLOSE INDEXES
SET SAFETY OFF
ERASE Dg_temp$.ndx
ZAP
SET SAFETY ON
*
* Restore parameter line, and close file.
IF [] < dl_oldt
APPEND BLANK
REPLACE Dg_text WITH dl_oldt
ENDIF
USE
*
* Restore system parameters.
IF dl_isdiffp
DO config WITH dl_oldp
ENDIF
*
* Automatic DO of generated file.
DO doer{WITH dl_tfile
*
RETURN
* EOP generate *******************************************************
PROCEDURE gen_entr
* Called from generate
PARAMETERS dl_part
*
IF dl_part = 1
* Part one.
*
DO line_inc
?? [* Entry algorithm]
DO line_inc
DO line_inc
?? [CLEAR]
DO line_inc
*
ELSE
* Part two.
DO line_inc
?? [DO WHILE .T.]
*
DO line_inc
?? [ @ 22,19 SAY "Press any key to edit,
DO line_inc
?? [ @ 23,18 SAY "or ] + dg_key + [ to return to menu without saving..."]
DO line_inc
?? [ WAIT "" TO choice]
DO line_inc
?? [ @ 22,19]
DO line_inc
?? [ @ 23,18]
*
DO line_inc
?? [ DO CASE]
DO line_inc
?? [ CASE "" = choice]
DO line_inc
?? [ RETURN]
DO line_inc
?? [ CASE "S" = UPPER(choice)]
DO line_inc
?? [ * Add replace statements here.]
DO line_inc
?? [ RETURN]
DO line_inc
?? [ OTHERWISE]
DO line_inc
?? [ READ SAVE]
DO line_inc
?? [ ENDCASE]
*
DO line_inc
?? [ENDDO (WHILE .T.)]
DO line_inc
ENDIF
*
RETURN
*
* EOP gen_entr *******************************************************
PROCEDURE gen_menu
* Called from generate
PARAMETERS dl_part
*
IF dl_part = 1
* Part one.
*
*
DO line_inc
?? [* Menu algorithm]
DO line_inc
DO line_inc
?? [DO WHILE .T.]
DO line_inc
DO line_inc
?? [ CLEAR]
DO line_inc
*
ELSE
* Part two.
DO line_inc
?? [ i = 0]
DO line_inc
?? [ DO WHILE i = 0]
DO line_inc
?? [ i = INKEY()]
DO line_inc
?? [ ENDDO]
DO line_inc
?? [ *]
DO line_inc
?? [ DO CASE]
*
* Write the specified CASE statements.
SET ORDER TO 0
GO dl_menupos
SKIP
DO WHILE .NOT. ( EOF() .OR. [] = TRIM(Dg_text) )
DO line_inc
?? [ CASE CHR(i) $ "] + LTRIM(RTRIM(Dg_text)) +["]
DO line_inc
?? [ WAIT "Not implemented yet. ]+;
[Press any key to return to menu..."]
SKIP
ENDDO
DO line_inc
?? [ CASE i = 13]
DO line_inc
?? [ RETURN]
DO line_inc
?? [ ENDCASE]
DO line_inc
DO line_inc
?? [ENDDO (WHILE .T.)]
ENDIF
*
{RETURN
*
* EOP gen_menu ********************************************************
PROCEDURE gen_rprt
* Called from generate
PARAMETERS dl_part
*
IF dl_part = 1
* Part one.
*
DO line_inc
?? [* Report algorithm]
DO line_inc
DO line_inc
?? [* Prompt user to set up the printer or abort.]
DO line_inc
DO line_inc
?? [@ 12,23 SAY "Printing. Please do not disturb..."]
DO line_inc
DO line_inc
?? [SET DEVICE TO PRINT]
DO line_inc
DO line_inc
?? [DO WHILE (.NOT. EOF()) .AND. "" < DBF() &] +;
[& report has to use a file]
DO line_inc
*
ELSE
* Part two.
DO line_inc
?? [ SKIP]
DO line_inc
?? [ENDDO]
DO line_inc
DO line_inc
?? [EJECT &] +;
[& flush the last line from printer buffer]
DO line_inc
?? [SET DEVICE TO SCREEN]
DO line_inc
?? [@ 12,23 SAY " *** *** Done Printing *** *** "]
ENDIF
*
RETURN
*
* EOP gen_rprt *******************************************************
PROCEDURE helper
* Called from everything that can be called from the menu, plus the menu.
* Calls the individual help screen when not called from menu.
*
PARAMETERS dl_from
* 'dl_from' is same as selection number in main menu.
*
SET COLOR TO &dg_accent
DO CASE
CASE dl_from = 1
DO hlp_crea
CASE dl_from = 2
DO hlp_edit
CASE dl_from = 3
DO hlp_gene
CASE dl_from = 4
DO hlp_mgen
CASE dl_from = 5
DO hlp_doer
CASE dl_from = 6
DO hlp_setu
CASE dl_from = 7
@ 3,24 SAY "ARE YOU A REGISTERED dGENERATE?"
@ 5,14 SAY "For a registration fee of fifteen dollars, you get"
@ 6,13 SAY "an unprotected disk containing 3 copies of dGENERATE:"
@ 8,13 SAY "1. The source code in two files, main and procedure"
@ 9,13 SAY "2. A single command file coded and linked with RunTime+"
@ 10,13 SAY "3. A single executable file compiled with Clipper"
@ 12, 9 SAY "Also on the disk is a text file with additional " +;
"documentation."
@ 14,14 SAY "REGISTRATION ENTITLES YOU TO FULL TECHNICAL SUPPORT,"
@ 15,12 SAY "and contributes to the development of software like this."
@ 17,29 SAY "Tom Rettig Associates"
@ 18,23 SAY "9300 Wilshire Boulevard, Suite 470"
@ 19,28 SAY "Beverly Hills, CA 90212"
@ 20,10 SAY "Phone:(213)272-3784 -- CompuServe:75066,352 "+;
"-- Source:BCR480"
ENDCASE
*
IF dl_from # 2
* Only single page help screens should take this branch.
* (Two page help screens use hlp_togl.)
@ 23,26 SAY "Press any key to continue..."
SET COLOR TO &dg_normal
dl_i = 0
DO key_time WITH COL()
ENDIF
*
* Clear help screen and repaint bottom marquee line before returning.
SET COLOR TO &dg_normal
@ 3,0 CLEAR
@ 21,0 SAY dg_line
RETURN
*
* EOP helper *********************************************************
PROCEDURE hlp_crea
* Help screen for crea_new (1), called from helper
*
@ 4,0
TEXT
1. A target "screen-form" file is created in which you draw your screen.
- You will be prompted for its filename, and it has a default
ENDTEXT
*
? " extension of ." + dg_fscr_in + ;
" if you do not specify a different one."
*
TEXT
2. You will be asked if you want to add names from a database file.
- If you answer yes, you will be prompted for a database filename.
- Memory variable names are generated from this file's field names,
and both are placed in the screen-form for your use.
3. After the screen-form file is created, you are automatically placed
in editing mode where you draw your screen with your favorite word
processor. Specify your own word processor by choosing number
six
ENDTEXT
*
RETURN
* EOP hlp_crea *******************************************************
PROCEDURE hlp_doer
* Help screen for doer (5), called from helper
*
@ 6,0
TEXT
1. This module simply runs any executable dBASE III program.
2. It is called automatically upon completion of generating
a new executable command file from a screen-form file.
3. If the DO file crashes, press 'S' to SUSPEND, type
RETURN and RESUME, and you will be back in dGENERATE
ready to
ENDTEXT
*
RETURN
* EOP hlp_doer *******************************************************
PROCEDURE hlp_edit
* Help screen for edit (2), called from helper
*
* This initialization makes first screen come up.
dl_i = 49
dl_screen = 2
*
DO WHILE .T.
DO CASE
CASE dl_screen = 2 .AND. CHR(dl_i) $ "1pP"
*
@ 4,0
TEXT
- The first (top) line is a ruler for your convenience in placing things.
- Then there is the area where you draw your screen-form:
ENDTEXT
? " " + LEFT(dg_ruler,29) + " " +;
"<----[ruler line]"
?
? " First name: " + dg_atsay + "1 <--+"
? " Last name: " + dg_atget +;
"n____________: |-[screen area]"
? " Address: " + dg_atget + "Street_Address___: <--+"
TEXT
^ ^ ^^^ ^
^-Literals-^ ||^---Optional----^
||
GET/SAY Symbol--'`--Definition Symbol (expression defined below)
ENDTEXT
dl_screen = 1
*
*
CASE dl_screen = 1 .AND. CHR(dl_i) $ "2nN"
@ 3,0
TEXT
- Under the screen-form is the definition table marked by 'dgDEFINE'.
This is where you define the symbols used in the screen-form by
assigning them to an expression and, optionally, a variable name.
- Anywhere below the screen-form, you can specify a code algorithm
to be generated such as menu, entry, report, or open file.
dgDEFINE <--+
1 First_name PICTURE "AAAAAAAA" |-[definition table]
ENDTEXT
? " n m_lname " + dg_init +;
[ Last_name FUNCTION "!" |]
? " S m_address " + dg_init +;
[ SPACE(25) <--+]
TEXT
|
`-------------------[memvar initialization symbol]
dgFILE Names <--|-[options]
dgENTRY <--+
ENDTEXT
dl_screen = 2
OTHERWISE
RETURN
ENDCASE
*
dl_i = 0
DO hlp_togl
ENDDO
*
* EOP hlp_edit *******************************************************
PROCEDURE hlp_gene
* Help screen for generate (3), called from helper
*
@ 5,0
TEXT
1. When prompted, just enter the name of a screen-form file
that you created and edited; dGENERATE will do the rest.
2. You can change from relative addressing (@ ROW()+1,0) to
"hard coded" numeric coordinates (@ 5,0) in number six
i
3. After the executable dBASE code is generated, the file will
be run automatically so that you can see the results.
ENDTEXT
*
RETURN
* EOP hlp_gene *******************************************************
PROCEDURE hlp_mgen
* Help screen for mem_gen (4), called from helper
*
@ 2,79 SAY []
TEXT
1. Memory variable names are generated from the file's field names.
Only eight characters of the field name are significant in this
operation: 'First_name' becomes 'm_first_na'.
2. Three sets of commands are generated using the memory variable
names and field names from the database file.
- The first set is composed of memory variable initialization
statements from the file (memvar = Field).
- The second set is composed of memory variable initialization
statements from an expression (memvar = CTOD(" / / ")).
- The third set is composed of REPLACE statements to transfer
data from the memory variables to the file's fields
(REPLACE Field WITH memvar).
3. This code is not intended to run as it stands. It is to be
incorporated in your program by reading it into your command file
or procedure using your word processor. Your program will probably
use only some of this code, and the rest can be discarded.
ENDTEXT
*
RETURN
* EOP hlp_mgen *******************************************************
PROCEDURE hlp_setu
* Help screen for setup (6), called from helper
*
@ 5,0
TEXT
1. These are the system parameters that dGENERATE uses.
2. Information about each parameter is displayed
when the parameter is selected.
3. You can change them for temporary use and still retain
the original system defaults, or you can make your
changes the new default.
ENDTEXT
*
RETURN
* EOP hlp_setu *******************************************************
PROCEDURE hlp_togl
* Called from hlp_edit
* For two-screen helps
*
SET COLOR TO &dg_normal
@ 22,28 SAY "This is screen number " + IIF(dl_screen=1,"one","two")
SET COLOR TO &dg_accent
@ 23,13 SAY IIF(dl_screen=1," 2 -
revious screen")-;
", or any other key to continue..."
*
* 'dl_i' and 'dl_screen' are initialized in the calling program.
SET COLOR TO &dg_normal
DO key_time WITH IIF(dl_screen=2,COL(),COL()-2)
*
@ 3,0 CLEAR
@ 21,0 SAY dg_line
SET COLOR TO &dg_accent
RETURN
* EOP hlp_togl *******************************************************
PROCEDURE key_time
* Called from main, fileprmt, helper, hlp_togl, setup
* Also see marquee.
PARAMETERS dl_column
*
dl_j = 0
* 'dl_i' must be initialized to zero in calling program.
DO WHILE dl_i = 0
@ 1,53 SAY IIF(VAL(TIME())<12, TIME() + " am",;
IIF(VAL(TIME())=12, TIME() + " pm",;
STR(VAL(TIME())-12,2) + SUBSTR(TIME(),3) + " pm"))
@ 23,dl_column SAY [] && positions cursor to end of prompt
*
* Wait for a keypress or the time to change.
dl_t = TIME()
DO WHILE dl_t = TIME() .AND. dl_i = 0
dl_i = INKEY()
ENDDO
*
* Time out after
dl_j = dl_j+1
IF dl_j = 180
RETURN
ENDIF
ENDDO
*
RETURN
* EOP key_time *******************************************************
PROCEDURE line_inc
* Called from generate, gen_entr, gen_menu, gen_rprt, mem_gen, write
* Call before writing output statements when they are displayed on screen.
* Furnishes the carriage return before each line and tests for new screen.
*
?
IF ROW() # 21
RETURN
ENDIF
*
@ 3,0
@ 4,0
@ 5,0
@ 6,0
@ 7,0
@ 8,0
@ 9,0
@ 10,0
@ 11,0
@ 12,0
@ 13,0
@ 14,0
@ 15,0
@ 16,0
@ 17,0
@ 18,0
@ 19,0
@ 20,0
@ 3,0 SAY []
*
RETURN
* EOP line_inc *******************************************************
PROCEDURE marquee
* Called from crea_new, doer, editor, generate, helper, mem_gen,
* and setup. Expects color to be dg_dim. Also see key_time.
*
PARAMETERS dl_title
* LEN(dl_title) must be 23
*
CLEAR
@ 1, 0 SAY [d G E N E R A T E - -] + dl_title +;
[- - - -]
@ 1,53 SAY IIF(VAL(TIME())<12, TIME() + " am",;
IIF(VAL(TIME())=12, TIME() + " pm",;
STR(VAL(TIME())-12,2) + SUBSTR(TIME(),3) + " pm"))
@ 1,72 SAY DATE()
@ 2, 0 SAY dg_line
@ 21, 0 SAY dg_line
RETURN
* EOP marquee *********************************************************
PROCEDURE mem_gen
* Called from menu
*
CLEAR
DO marquee WITH [ Generating Memvars ]
*
IF dg_ishelp
DO helper WITH 4
ENDIF
*
* Prompt for name of source database file.
* (target file name is constructed from this)
dl_sourcef = [ ]
dl_defext = [dbf]
STORE .F. TO dl_istargt, dl_isedit
DO fileprmt
IF dg_iserror
RETURN
ENDIF
*
* Target filename is automatic from source file.
STORE SUBSTR(dl_sourcef,1,AT(".",dl_sourcef)) + dg_fmemout ;
TO dl_tgfile, dl_abortf
*
DO wait_msg WITH 1
DO file_msg WITH dl_sourcef, dl_tgfile
*
* Copy to a structure-extended file to get the field specs.
dl_oldt = [] && for abort if dg.dbf is specified
USE &dl_sourcef
SET SAFETY OFF
COPY TO Dg_temp$ STRUCTURE EXTENDED
USE Dg_temp$
*
* Convert field names to lowercase.
REPLACE ALL Field_name WITH LOWER(Field_name)
*
* Index the structure file.
INDEX ON Field_type + Field_name TO Dg_temp$
SET SAFETY ON
*
DO wait_msg WITH 2
*
* Open target file, and write its header.
DO alt_file WITH dl_tgfile, 1
*
* Output the initialization statements from expressions.
DO line_inc
?? [* Initialization commands from expressions.]
dl_zeros = "00000000000000000000"
DO WHILE .NOT. EOF()
DO line_inc
DO CASE
CASE Field_type = "C"
?? [m_] + SUBSTR(Field_name,1,8) + [ = SPACE(] +;
STR(Field_len,3) + [)]
CASE Field_type = "D"
?? [m_] + SUBSTR(Field_name,1,8) + [ = CTOD(" / / ")]
CASE{ Field_type = "L"
?? [m_] + SUBSTR(Field_name,1,8) + [ = .F.]
CASE Field_type = "N" .AND. Field_dec = 0
?? [m_] + SUBSTR(Field_name,1,8) + [ = ] +;
SUBSTR(dl_zeros,1,Field_len-Field_dec)
CASE Field_type = "N" .AND. Field_dec > 0
?? [m_] + SUBSTR(Field_name,1,8) + [ = ] +;
SUBSTR(dl_zeros,1,Field_len-Field_dec-1) + [.] +;
SUBSTR(dl_zeros,1,Field_dec)
ENDCASE
*
SKIP
zDDO
*
* Output the initialization statements from file fields.
DO line_inc
DO line_inc
?? [* Initialization commands from fields.]
GO TOP
DO WHILE .NOT. EOF()
DO line_inc
?? [m_] + SUBSTR(Field_name,1,8) + [ = ] + ;
UPPER(SUBSTR(Field_name,1,1)) + SUBSTR(Field_name,2,9)
SKIP
ENDDO
*
* Output the REPLACE statements.
DO line_inc
DO line_inc
?? [* Replace commands.]
GO TOP
DO WHILE .NOT. EOF()
DO line_inc
?? [REPLACE ] + UPPER(SUBSTR(Field_name,1,1)) + SUBSTR(Field_name,2,9) +;
[ WITH m_] + SUBSTR(Field_name,1,8)
SKIP
ENDDO
*
* Close the target file.
DO line_inc
DO line_inc
DO alt_file WITH dl_tgfile, 2
*
* Restore the environment, and return to menu.
ON ESCAPE SUSPEND
USE
ERASE Dg_temp$.dbf
ERASE Dg_temp$.ndx
SET COLOR TO &dg_normal
RETURN
* EOP mem_gen ********************************************************
PROCEDURE pars_lit
* Called from generate
*
* It's a literal prompt; save the pointer (dl_i) and
* reposition it to the next dg_atget, dg_atsay, or eol.
dl_start = dl_i
dl_nextsay = AT(dg_atsay,dl_str)
dl_nextget = AT(dg_atget,dl_str)
DO CASE
CASE dl_nextsay + dl_nextget = 0
* Point past end-of-line.
dl_i = dg_eol+1
CASE dl_nextsay = 0
* Point to next dg_atget symbol.
dl_i = dl_i-1 + dl_nextget
CASE dl_nextget = 0
* Point to next dg_atsay symbol.
dl_i = dl_i-1 + dl_nextsay
OTHERWISE
* Point to next dg_atsay or dg_atget symbol, whichever is first.
dl_i = dl_i-1 + IIF(dl_nextsay < dl_nextget, dl_nextsay, dl_nextget)
END{ASE
*
* Write the literal prompt, trimming any trailing blanks.
DO write WITH TRIM( SUBSTR(dl_line,dl_start,dl_i-dl_start) ),;
dl_start, .T., .T.
*
RETURN
* EOP pars_lit *******************************************************
PROCEDURE pars_var
* Called from generate
*
* Activate index file for searching the variable definitions table.
SET ORDER TO 1
*
* See if the next character is listed in the definitions table.
SEEK SUBSTR(dl_str, 2, 1) + [ ]
DO CASE
CASE FOUND() .AND. dg_init $ Dg_text
* If it is an initialized memvar, the expression has been tested.
* Write the @...SAY or @...GET variable name and the
* picture or function clause if any.
dl_phrase = LTRIM(RTRIM(SUBSTR(Dg_text,3)))
dl_loc = IIF(" PICT"$UPPER(dl_phrase),AT(" PICT",UPPER(dl_phrase)),;
AT(" FUNC",UPPER(dl_phrase)))
DO write WITH TRIM(LEFT(dl_phrase,AT(dg_init,dl_phrase)-1))+;
IIF(dl_loc>0,IIF("PICT"$UPPER(dl_phrase)," PICTURE "," FUNCTION ")+;
LTRIM(SUBSTR(dl_phrase,dl_loc+AT([ ],SUBSTR(dl_phrase,dl_loc+1)))),;
[]), dl_i, dl_str=dg_atsay, .F.
CASE FOUND() .AND. .NOT. dg_init $ Dg_text
* If defined, but not initialized, it's an expression.
* Test the expression and write it or the 'undefined' variable.
* Expression test is duplicated in generate.
dl_phrase = LTRIM(RTRIM(SUBSTR(Dg_text,3)))
dl_loc = IIF(" PICT"$UPPER(dl_phrase),AT(" PICT",UPPER(dl_phrase)),;
AT(" FUNC",UPPER(dl_phrase)))
*
* Uninitialized variable name will get through as valid
* character expression. Necessary to let field names through.
DO write WITH ;
IIF(TYPE("IIF(dl_loc>0,LEFT(dl_phrase,dl_loc),dl:hrase)")="U",;
[undefined],dl_phrase), dl_i, dl_str=dg_atsay, .F.
OTHERWISE
* Not defined at all, write the memvar 'undefined'.
DO write WITH [undefined], dl_i, dl_str=dg_atsay, .F.
ENDCASE
*
* Point to next character if there is one, or past eol.
dl_i = IIF(AT(LTRIM(SUBSTR(dl_line,dl_i-1+AT(" ",dl_str)) ),;
dl_str) > 0 .AND. AT(" ",dl_str) > 0, ;
dl_i-1 + AT( LTRIM( SUBSTR(dl_line,dl_i-1+AT(" ",dl_str)) ), dl_str),;
dg_eol+1)
*
SET ORDER TO 0
RETURN
* EOP pars_var *******************************************************
PROCEDURE setup
* Called from menu
DO marquee WITH [ Setting Up dGENERATE ]
*
IF dg_ishelp
DO helper WITH 6
ENDIF
*
* SAYs.
dg_p1 = "Characters used to denote GETs: and SAYs:"
dg_p2 = "Character used for the initialization code:"
dg_p3 = "Size of screen-form in ROWs: and COLumns:"
dg_p4 = "Relative Addressing?:"
dg_p5 = "Ruler line in screen-form?:"
dg_p6 = "Delimiters on?:"
dg_p7 = "Fill screen-form with blanks?:"
dg_p8 = "Help screens on?:"
dg_p9 = "Default file extensions for drawing screens: , code generated:"
dg_p10 = "memvar names generated:"
{dg_p11 = "Characters used to make up ruler in COLumn zero: , every ten:"
dg_p12 = "Characters used for left and right delimiters:"
dg_p13 = "Character used for marquee lines in this program (ASCII value):"
dg_p14 = "Filename of word processor used for editing screen-forms:"
*
* GETs.
dl_atget = dg_atget
dl_atsay = dg_atsay
dl_init = dg_init
dl_eol = dg_eol
dl_eos = dg_eos
dl_isreltv = dg_isreltv
dl_isruler = dg_isruler
dl_isdelim = dg_isdelim
dl_isfill = dg_isfill
dl_ishelp = dg_ishelp
dl_fmemout = dg_fmemout
dl_fscrout = dg_fscrout
dl_fscr_in = dg_fscr_in
dl_rule1 = dg_rule1
dl_rule = dg_rule
dl_delim = dg_delim
dl_char = dg_char
dl_wp = dg_wp
*
SET COLOR TO &dg_accent
@ 3, 1 SAY " -->"
@ 4, 1 SAY " -->"
@ 5, 1 SAY "
@ 7, 1 SAY "
@ 8, 1 SAY "
@ 9, 1 SAY "
@ 10, 1 SAY "
@ 11, 1 SAY "
@ 13, 1 SAY " -->"
@ 16, 1 SAY "
@ 18, 1 SAY "
@ 19, 1 SAY "
@ 20, 1 SAY "
*
SET COLOR TO &dg_normal
@ 3, 9 SAY dg_p1
@ 4, 9 SAY dg_p2
@ 5, 9 SAY dg_p3
@ 7, 9 SAY dg_p4
@ 8, 9 SAY dg_p5
@ 9, 9 SAY dg_p6
@ 10, 9 SAY dg_p7
@ 11, 9 SAY dg_p8
@ 13, 9 SAY dg_p9
@ 14,50 SAY dg_p10
@ 16, 9 SAY dg_p11
@ 18, 9 SAY dg_p12
@ 19, 9 SAY dg_p13
@ 20, 9 SAY dg_p14
*
* If delimiters are being used in screens, don't use them here.
IF dg_isdelim
SET DELIMITERS OFF
ENDIF
*
@ 3,40 GET dl_atget
@ 3,51 GET dl_atsay
@ 4,52 GET dl_init
@ 5,37 GET dl_eos PICTURE "###"
@ 5,53 GET dl_eol PICTURE "###"
@ 7,30 GET dl_isreltv
@ 8,36 GET dl_isruler
@ 9,24 GET dl_isdelim
@ 10,39 GET dl_isfill
@ 11,26 GET dl_ishelp
@ 13,53 GET dl_fscr_in
@ 13,73 GET dl_fscrout
@ 14,73 GET dl_fmemout
@ 16,57 GET dl_rule1
@ 16,70 GET dl_rule
@ 18,55 GET dl_delim
@ 19,72 GET dl_char PICTURE "###"
@ 20,66 GET dl_wp
*
CLEAR GETS
SET BELL ON
*
DO WHILE .T.
{ SET COLOR TO &dg_accent
@ 22,8 SAY "Choose item to change by letter, "+;
"
@ 23,8 SAY " to ave as system defaults, or " + dg_key +;
" to abort any changes."
SET COLOR TO &dg_normal
*
dl_i = 0
DO key_time WITH COL()
@ 22,8
@ 23,8
*
SET COLOR TO &dg_accent
dl_istrap = .T.
*
* Split up to speed up an othe?&wise very long DO CASE structure.
DO CASE
CASE LOWER(CHR(dl_i)) >= 'a' .AND. LOWER(CHR(dl_i)) <= 'd'
DO set_if1
CASE LOWER(CHR(dl+{)) >= 'e' .AND. LOWER(CHR(dl_i)) <= 'i'
Do set_if2
CASE LOWER(CHR(dl_i)) >= 'j' .AND. LOWER(CHR(dl_i)) <= 'm'
Do set_if3
CASE CHR(dl_i) $ "tsTS" .OR. dl_i = 13 .OR. dl_i = 0
EXIT
ENDCASE
@ 22,0
@ 23,0
ENDDO [WHILE .T.]
*
* Exit routine.
IF dl_i # 13 .AND. dl_i # 0
@ 23,27 SAY "Saving these parameters..."
*
* Write a new dg_param line.
dl = [ ]
dl_re = IIF(dl_isreltv, "T", "F")
dl_ru = IIF(dl_isruler, "T", "F")
dl_d = IIF(dl_isdelim, "T", "F")
dl_f = IIF(dl_isfill , "T", "F")
dl_h = IIF(dl_ishelp , "T", "F")
DO config WITH [parameters: ]+dl_atget+dl+dl_atsay+dl+dl_init+dl+;
STR(dl_eol,3)+dl+STR(dl_eos,3)+dl+dl_re+dl+dl_ru+dl+dl_d+dl+dl_f+dl+dl_h+dl+;
dl_fmemout+dl+dl_fscrout+dl+dl_fscr_in+dl+dl_rule1+dl+dl_rule+dl+;
dl_delim+dl+STR(dl_char,3)+dl+dl_wp
*
* Branch to make these the system defaults.
IF CHR(dl_i) $ "sS"
USE dg
IF RECCOUNT() = 0
APPEND BLANK
ENDIF
REPLACE Dg_text WITH dg_param
{ USE
ENDIF (save to file)
ENDIF (save temporarily)
*
* If delimiters are being used in screens, turn them back on.
IF dg_isdelim
SET DELIMITERS ON
ENDIF
*
SET COLOR TO &dg_normal
SET BELL OFF
RETURN
*
* EOP setup **********************************************************
PROCEDURE set_if1
* Called from setup
*
DO CASE
CASE CHR(dl_i) $ [aA]
@ 3, 9 SAY dg_p1
@ 22,18 SAY "GET and SAY must each use different symbols."
@ 23, 6 SAY "Neither symbol may be used in a "+;
"literal prompt in the screen-form..."
DO WHILE dl_istrap
@ 3,40 GET dl_atget
@ 3,51 GET dl_atsay
READ
dl_istrap = dl_atget = [ ] .OR. dl_atsay = [ ] .OR.;
dl_atget = dl_atsay
{ ENDDO
{ SET COLOR TO &dg_normal
@ 3, 9 SAY dg_p1
@ 3,40 GET dl_atget
CLEAR GETS
CASE CHR(dl_i) $ [bB]
@ 4, 9 SAY dg_p2
@ 23, 8 SAY "Initialization symbol cannot be any of " +;
"these: []<>()`'^*/+-|:.&= "
DO WHILE dl_istrap
@ 4,52 GET dl_init
READ
dl_istrap = dl_init $ "[]<>()`'^*/+-|:.&= "
ENDDO
SET COLOR TO &dg_normal
@ 4, 9 SAY dg_p2
CASE CHR(dl_i) $ [cC]
@ 5, 9 SAY dg_p3
@ 5,37 GET dl_eos PICTURE "###" RANGE 1,999
@ 5,53 GET dl_eol PICTURE "###" RANGE 1,254
@ 23,18 SAY "Range for ROWs: 1..999, and COLumns: 1..254."
READ
SET COLOR TO &dg_normal
@ 5, 9 SAY dg_p3
@ 5,37 GET dl_eos PICTURE "###" RANGE 1,999
CLEAR GETS
CASE CHR(dl_i) $ [dD]
@ 7, 9 SAY dg_p4
@ 7,30 GET dl_isreltv
@ 23,26 SAY "Can be True/Yes or False/No."
READ
SET COLOR TO &dg_normal
@ 7, 9 SAY dg_p4
ENDCASE
*
RETURN
* EOP set_if1 ********************************************************
PROCEDURE set_if2
* Called from setup
*
DO CASE
CASE CHR(dl_i) $ [eE]
@ 8, 9 SAY dg_p5
@ 8,36 GET dl_isruler
@ 23,26 SAY "Can be True/Yes or False/No."
READ
SET COLOR TO &dg_normal
@ 8, 9 SAY dg_p5
CASE CHR(dl_i) $ [fF]
@ 9, 9 SAY dg_p6
@ 9,24 GET dl_isdelim
@ 23,26 SAY "Can be True/Yes or False/No."
READ
SET COLOR TO &dg_normal
@ 9, 9 SAY dg_p6
CASE CHR(dl_i) $ [gG]
@ 10, 9 SAY dg_p7
@ 10,39 GET dl_isfill
@ 23,26 SAY "Can be True/Yes or False/No."
READ
SET COLOR TO &dg_normal
@ 10, 9 SAY dg_p7
CASE CHR(dl_i) $ [hH]
@ 11, 9 SAY dg_p8
@ 11,26 GET dl_ishelp
@ 23,26 SAY "Can be True/Yes or False/No."
READ
SET COLOR TO &dg_normal
@ 11, 9 SAY dg_p8
CASE CHR(dl_i) $ [iI]
@ 13, 9 SAY dg_p9
@ 14,50 SAY dg_p10
@ 22,17 SAY "Each file type must use a different extension."
@ 23,17 SAY "Extensions cannot begin with a blank or a dot."
DO WHILE dl_istrap
@ 13,53 GET dl_fscr_in
@ 13,73 GET dl_fscrout
@ 14,73 GET dl_fmemout
READ
dl_istrap = dl_fscr_in=dl_fscrout .OR. dl_fscr_in=dl_fmemout .OR.;
dl_fscrout=dl_fmemout .OR. LEFT(dl_fscr_in,{)$[. ] .OR.;
LEFT(dl_fscrout,1)$[. ] .OR. LEFT(dl_fmemout,1)$[. ]
ENDDO
SET COLOR TO &dg_normal
@ 13, 9 SAY dg_p9
@ 13,53 GET dl_fscr_in
@ 14,50 SAY dg_p10
CLEAR GETS
ENDCASE
*
RETURN
* EOP set_if2 ********************************************************
PROCEDURE set_if3
* Called from setup
*
DO CASE
CASE CHR(dl_i) $ [jJ]
@ 16, 9 SAY dg_p11
@ 16,57 GET dl_rule1
@ 16,70 GET dl_rule
@ 23, 9 SAY "Ruler line is same length as screen-form " +;
"COLumns in
READ
SET COLOR TO &dg_normal
@ 16, 9 SAY dg_p11
@ 16,57 GET dl_rule1
CLEAR GETS
CASE CHR(dl_i) $ [kK]
@ 18, 9 SAY dg_p12
@ 23,25 SAY "Left delimiter cannot be blank."
DO WHILE dl_istrap
@ 18,55 GET dl_delim
READ
dl_istrap = dl_delim = [ ]
ENDDO
SET COLOR TO &dg_normal
@ 18, 9 SAY dg_p12
CASE CHR(dl_i) $ [lL]
@ 19, 9 SAY dg_p13
@ 19,72 GET dl_char PICTURE "###" RANGE 1,255
@ 23,29 SAY "ASCII range is 1..255."
READ
SET COLOR TO &dg_normal
@ 2, 0 SAY REPLICATE(CHR(dl_char),80) && display new marquee lines
@ 19, 9 SAY dg_p13
@ 21, 0 SAY REPLICATE(CHR(dl_char),80)
CASE CHR(dl_i) $ [mM]
@ 20, 9 SAY dg_p14
@ 22,12 SAY "Filename can be up to eight characters " +;
"with no extension."
@ 23, 7 SAY "Set operating system path if located in " +;
"another drive or directory."
DO WHILE dl_istrap
@ 20,66 GET dl_wp PICTURE [AXXXXXXX]
READ
dl_istrap = dl_wp = [ ] .OR. [.] $ dl_wp
ENDDO
SET COLOR TO &dg_normal
@ 20, 9 SAY dg_p14
ENDCASE
*
RETURN
* EOP set_if3 ********************************************************
PROCEDURE wait_msg
* Called from crea_new, generate, mem_gen
PARAMETERS dl_part
*
IF dl_part = 1
@ 11,21 SAY "This takes a moment, please be patient."
@ 22,25 SAY "Press the Escape key to abort."
ON ESCAPE DO abort WITH dl_abortf
* dl_abortf is initialized and ON ESCAPE is restored
* in the calling program.
ELSE
@ 11,21
ENDIF
*
RETURN
* EOP wait_msg *****************************************************
PROCEDURE write
* Called from pars_lit, pars_var
*
PARAMETERS dl_str, dl_column, dl_issay, dl_isquote
* Passed string has been TRIMmed and is not null [].
*
* Write the @...
DO line_inc
Io dg_isreltv
{ ?? [@ ] + IIF(dl_isreprt, "PROW()", "ROW()") + IIF(dl_atrow = dl_lastrow,;
IIF(dl_atrow-dl_lastrow<10, [ ], [ ]),;
"+" +STR(dl_atrow-dl_lastrow,2)) + [,] + STR(dl_column-1,dg_max)
ELSE
?? [@ ] + STR(dl_atrow,dg_max) + [,] + STR(dl_column-1,dg_max)
ENDIF
*
* Write the expression part of the command.
IF dl_issay .AND. dl_isquote
* It's a literal prompt.
IF LEN(dl_st[) <= 60
?? [ SAY "] + dl_str + ["]
ELSE
* Break long string every 40 columns.
?? [ SAY "] + SUBSTR(dl_str, 1,40) + [" +;]
dl_str = SUBSTR(dl_str,41)
DO WHILE LEN(dl_str) > 40
DO line_inc
?? IIF(dg_isrel
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/