Liren Large Software Subsidy 5/05.iso/a/a106/2.ddi/GENMENU.PR_/GENMENU.bin

Text File | 1994-04-28 | 49.7 KB | 1,724 lines

*
* GENMENU - Menu code generator.
*
* Copyright (c) 1990 - 1993 Microsoft Corp.
* 1 Microsoft Way
* Redmond, WA 98052
*
* Description:
* This program generates menu code which was designed in the
* FoxPro 2.5 MENU BUILDER.
*
* Notes:
* In this program, for clarity/readability reasons, we use variable
* names that are longer than 10 characters.  Note, however, that only
* the first 10 characters are significant.
*
* Modification History:
* December 13, 1990             JAC             Program Created
*
* Modifed for FoxPro 2.5 by WJK.
*
PARAMETER m.projdbf, m.recno
PRIVATE ALL
IF SET("TALK") = "ON"
    SET TALK OFF
    m.talkstate = "ON"
ELSE
    m.talkstate = "OFF"
ENDIF
m.escape = SET("ESCAPE")
SET ESCAPE OFF
m.trbetween = SET("TRBET")
SET TRBET OFF
m.comp = SET("COMPATIBLE")
SET COMPATIBLE OFF
mdevice = SET("DEVICE")
SET DEVICE TO SCREEN

*
* Declare Constants
*
#DEFINE c_esc   CHR(27)
#DEFINE c_null  CHR(0)

*
* Possible values of Objtype field in SCX database.
*
#DEFINE c_menu          1
#DEFINE c_submenu       2
#DEFINE c_item          3

*
* Some of the values of Objcode field in SCX database.
*
#DEFINE c_global        1
#DEFINE c_proc          80

#DEFINE c_maxsnippets   25
#DEFINE c_maxpads               25
#DEFINE c_pjx20flds             33
#DEFINE c_pjxflds               31
#DEFINE c_mnxflds               23
#DEFINE c_20mnxflds             22

#DEFINE c_authorlen             45
#DEFINE c_complen               45
#DEFINE c_addrlen               45
#DEFINE c_citylen               20
#DEFINE c_statlen               5
#DEFINE c_ziplen                10
#DEFINE c_countrylen 40

#DEFINE c_error_1               "Minor"
#DEFINE c_error_2               "Serious"
#DEFINE c_error_3               "Fatal"

#DEFINE c_dlgface               "MS Sans Serif"
#DEFINE c_dlgsize               8.000
#DEFINE c_dlgstyle              "B"

#DEFINE c_replace               0
#DEFINE c_append                1
#DEFINE c_before                2
#DEFINE c_after                 3

*
* Declare Variables
*
STORE "" TO m.cursor, m.consol, m.bell, m.onerror, ;
    m.exact, m.print, m.fixed, m.delimiters, m.mpoint, m.mcollate
STORE 0 TO m.deci, m.memowidth

m.g_error      = .F.
m.g_errlog     = ""
m.g_homedir    = ""
m.g_location   = 0
m.g_menucolor  = 0
m.g_menumark   = ""
m.g_nohandle   = .T.
m.g_nsnippets  = 0
m.g_outfile    = ""
m.g_padloca    = ""
m.g_projalias  = ""
m.g_projdbf    = m.projdbf
m.g_projpath   = ""
m.g_status     = 0
m.g_snippcnt   = 0
m.g_thermwidth = 0
m.g_workarea   = 0
m.g_graphic    = .F.
m.g_20mnx          = .F.

m.g_devauthor  = PADR("Author's Name",45," ")
m.g_devcompany = PADR("Company Name",45, " ")
m.g_devaddress = PADR("Address",45," ")
m.g_devcity    = PADR("City",20," ")
m.g_devstate   = "  "
m.g_devzip     = PADR("Zip",10," ")
m.g_devctry    = PADR("Country",40," ")

*m.g_boxstrg = ['─','─','│','│','┌','┐','└','┘','─','─','│','│','┌','┐','└','┘']
m.g_boxstrg = [ 8,8,'│','│','┌','┐','└','┘',8,8,'│','│','┌','┐','└','┘']

STORE "" TO m.g_corn1, m.g_corn2, m.g_corn3, m.g_corn4, m.g_corn5, ;
    m.g_corn6, m.g_verti2
STORE "*" TO  m.g_horiz, m.g_verti1

*
* Array Declarations
*
* g_mnxfile [1] - Normalized path + name
* g_mnxfile [2] - Basename
* g_mnxfile [3] - Opened originally?
* g_mnxfile [4] - Alias
*
DIMENSION g_mnxfile[4]
g_mnxfile[1] = ""
g_mnxfile[2] = ""
g_mnxfile[3] = .F.
g_mnxfile[4] = ""

*
* g_pads - names of generated menu pads
*
DIMENSION g_pads(c_maxpads)

*
* g_snippets [*,1] - generated snippet procedure name
* g_snippets [*,2] - recno()
*

DIMENSION g_snippets (c_maxsnippets,2)
g_snippets = ""

IF AT("WINDOWS", UPPER(VERSION())) <> 0 OR ;
        AT("MAC", UPPER(VERSION())) <> 0
    m.g_graphic = .T.
ELSE
    m.g_graphic = .F.
ENDIF

*
* Main program
*
m.onerror = ON("ERROR")
ON ERROR DO errorhandler WITH MESSAGE(), LINENO(), c_error_3

IF PARAMETERS()=2
    DO setup
    IF validparams()
        ON ESCAPE DO eschandler
        SET ESCAPE ON
        DO refreshprefs
        DO BUILD
    ENDIF
    DO cleanup
ELSE
    DO errorhandler WITH "Invalid number of parameters passed to"+;
        " the generator",LINENO(),c_error_3
ENDIF
ON ERROR &onerror

RETURN m.g_status

**
** Setup, Cleanup, Validparams, and Refreshprefs of Main Program
**

*
* STARTUP - Create program's environment.
*
* Description:
* Save the user's environment so that we can set it back when
* we are done, then issue various SET commands. The only state
* we cannot conveniently save is SET TALK, because storing the
* state involves an assignment statement, and assignments
* generate unwanted output if TALK is set ON.
*
* Side Effects:
* Creates a temporary file which is deleted in the Cleanup
* procedure executed at the end of MENUGEN.
*
PROCEDURE setup
    CLEAR PROGRAM
    CLEAR GETS
    m.g_workarea = SELECT()
    m.delimiters = SET('TEXTMERGE',1)
    SET TEXTMERGE DELIMITERS TO
    SET UDFPARMS TO VALUE

    m.bell = SET("BELL")
    SET BELL OFF
    m.consol = SET("CONSOLE")
    SET CONSOLE OFF
    m.cursor = SET("CURSOR")
    SET CURSOR OFF
    m.deci = SET("DECIMALS")
    SET DECIMALS TO 0
    mdevice = SET("DEVICE")
    SET DEVICE TO SCREEN
    m.memowidth = SET("MEMOWIDTH")
    SET MEMOWIDTH TO 256
    m.exact = SET("EXACT")
    SET EXACT ON
    m.print = SET("PRINT")
    SET PRINT OFF
    m.fixed = SET("FIXED")
    SET FIXED ON
    mpoint = SET("POINT")
    SET POINT TO "."
    mcollate = SET("COLLATE")
    SET COLLATE TO "machine"
*
* CLEANUP - restore environment to pre-execution state.
*
* Description:
* Close all databases opened in the course of the execution of MENUGEN.
* Restore the environment to the pre-execution of MENUGEN.  Delete
* the VIEW file since there is no further use for it.
*
* Side Effects:
* Closes databases.
* Deletes the temporary view file.
*
PROCEDURE cleanup
    PRIVATE m.delilen, m.ldelimi, m.rdelimi
    IF EMPTY(m.g_projalias)
        RETURN
    ENDIF
    SELECT (m.g_projalias)
    USE
    IF NOT EMPTY(g_mnxfile[3])
        IF USED(g_mnxfile[4])
            SELECT (g_mnxfile[4])
            USE
        ENDIF
    ENDIF
    SELECT (m.g_workarea)

    m.delilen = LEN(m.delimiters)
    m.ldelimi = SUBSTR(m.delimiters,1,;
        IIF(MOD(m.delilen,2)=0,m.delilen/2,CEILING(m.delilen/2)))
    m.rdelimi = SUBSTR(m.delimiters,;
        IIF(MOD(m.delilen,2)=0,m.delilen/2+1,CEILING(m.delilen/2)+1))
    SET TEXTMERGE DELIMITERS TO m.ldelimi, m.rdelimi

    IF m.bell = "ON"
        SET BELL ON
    ENDIF
    IF m.cursor = "ON"
        SET CURSOR ON
    ELSE
        SET CURSOR OFF
    ENDIF
    IF m.consol = "ON"
        SET CONSOLE ON
    ENDIF
    IF m.escape = "ON"
        SET ESCAPE ON
    ELSE
        SET ESCAPE OFF
    ENDIF
    IF m.print = "ON"
        SET PRINT ON
    ENDIF
    IF m.exact = "OFF"
        SET EXACT OFF
    ENDIF
    IF m.fixed = "OFF"
        SET FIXED OFF
    ENDIF
    SET DECIMALS TO m.deci
    SET MEMOWIDTH TO m.memowidth
    SET DEVICE TO &mdevice
    IF m.trbetween = "ON"
        SET TRBET ON
    ENDIF
    IF m.comp = "ON"
        SET COMPATIBLE ON
    ENDIF
    IF m.talkstate = "ON"
        SET TALK ON
    ENDIF
    SET POINT TO "&mpoint"
    SET COLLATE TO "&mcollate"
    SET MESSAGE TO

    ON ERROR &onerror


*
* VALIDPARAMS - Validate generator parameters.
*
* Description:
* Attempt to open the project database.  If error encountered then
* on error routine takes over and issues 'CANCEL'.  The output file
* cannot be erased, name not known.
*
FUNCTION validparams
    SELECT 0
    m.g_projalias = IIF(USED("projdbf"),"P"+;
        SUBSTR(LOWER(SYS(3)),2,8),"projdbf")
    USE (m.projdbf) ALIAS (m.g_projalias)
    IF versnum() > "2.5"
       SET NOCPTRANS TO devinfo, arranged, symbols, object
    ENDIF

    m.g_errlog = stripext(m.projdbf)
    m.g_projpath = SUBSTR(m.projdbf,1,RAT("\",m.projdbf))

    IF FCOUNT() <> c_pjxflds
        DO errorhandler WITH "Generator out of date.",;
            LINENO(), c_error_2
        RETURN .F.
    ENDIF

    GOTO RECORD m.recno

    m.g_outfile = ALLTRIM(SUBSTR(outfile,1,AT(c_null,outfile)-1))
    m.g_outfile = FULLPATH(m.g_outfile, m.g_projpath)
    g_mnxfile[1] = FULLPATH(ALLTRIM(name), m.g_projpath)
    g_mnxfile[2] = basename(g_mnxfile[1])

*
* REFRESHPREFS - Refresh comment style and developer preferences.
*
* Description:
* Get the newest preferences for documentation style and developer
* data from the project database.
*
PROCEDURE refreshprefs
    PRIVATE m.start, m.savrecno
    m.savrecno = RECNO()
    LOCATE FOR TYPE = "H"
    IF NOT FOUND ()
        DO errorhandler WITH "Missing header record in "+m.g_projdbf,;
            LINENO(), c_error_2
        GOTO RECORD m.savrecno
        RETURN
    ENDIF

    m.g_homedir = ALLTRIM(SUBSTR(homedir,1,AT(c_null,homedir)-1))

    m.start = 1
    m.g_devauthor = subdevinfo(m.start,c_authorlen,m.g_devauthor)

    m.start = m.start + c_authorlen + 1
    m.g_devcompany = subdevinfo(m.start,c_complen,m.g_devcompany)

    m.start = m.start + c_complen + 1
    m.g_devaddress = subdevinfo(m.start,c_addrlen,m.g_devaddress)

    m.start = m.start + c_addrlen + 1
    m.g_devcity = subdevinfo(m.start,c_citylen,m.g_devcity)

    m.start = m.start + c_citylen + 1
    m.g_devstate = subdevinfo(m.start,c_statlen,m.g_devstate)

    m.start = m.start + c_statlen + 1
    m.g_devzip = subdevinfo(m.start,c_ziplen,m.g_devzip)

    m.start = m.start + c_ziplen + 1
    m.g_devctry = subdevinfo(m.start,c_countrylen,m.g_devctry)

    IF cmntstyle = 0
*       m.g_corn1 = "╓"
        m.g_corn1 = "*"
*       m.g_corn2 = "╖"
        m.g_corn2 = "*"
*       m.g_corn3 = "╙"
        m.g_corn3 = "*"
*       m.g_corn4 = "╜"
        m.g_corn4 = "*"
*       m.g_corn5 = "╟"
        m.g_corn5 = "*"
*       m.g_corn6       = "╢"
        m.g_corn6       = "*"
*       m.g_horiz = "─"
        m.g_horiz = "*"
*       m.g_verti1 = "║"
        m.g_verti1 = "*"
*       m.g_verti2 = "║"
        m.g_verti2 = "*"
    ENDIF
    GOTO RECORD m.savrecno

*
* SUBDEVINFO - Substring the DEVINFO memo filed.
*
FUNCTION subdevinfo
    PARAMETER m.start, m.stop, m.default
    PRIVATE m.string
    m.string = SUBSTR(devinfo, m.start, m.stop+1)
    m.string = SUBSTR(m.string, 1, AT(c_null,m.string)-1)
    RETURN IIF(EMPTY(m.string), m.default, m.string)

**
** Menu Code Generator's Main Module.
**

*
* BUILD - Generate code for a menu.
*
* Description:
* Call BUILDENABLE to open .MNX database specified by the user.
* If the above is successfully accomplished, then proceed to generate
* the menu code.  After the menu code is generated, call BUILDDISABLE
* to disable code generation between SET TEXTMERGE ON and
* SET TEXTMERGE OFF.
*
PROCEDURE BUILD
    IF NOT buildenable()
        RETURN
    ENDIF
    DO acttherm WITH "Generating Menu Code..."
    DO updtherm WITH 10

    DO HEADER
    DO gensetupcleanup WITH "setup"
    DO definemenu
    DO definepopups
    DO globaldefaults
    DO gensetupcleanup WITH "cleanup"
    DO genprocedures

    IF m.g_graphic
        SET MESSAGE TO 'Generation Complete'
    ENDIF
    DO builddisable
    DO updtherm WITH 100
    DO deactthermo

*
* BUILDENABLE - Enable code generation.
*
* Description:
* Call opendb to open .MNX database.
* Call openfile to open file to hold the generated program.
* If error(s) encountered in opendb or openfile then don't do
* anything and exit, otherwise enable code generation with the
* SET TEXTMERGE ON command.
*
* Returns:
* .T. on success; .F. on failure
*
FUNCTION buildenable
    PRIVATE m.stat
    m.stat = opendb(g_mnxfile[1]) AND openfile()
    IF m.stat
        SET TEXTMERGE ON
    ENDIF
    RETURN m.stat

*
* BUILDDISABLE - Disable code generation.
*
* Description:
* Issue the command SET TEXTMERGE OFF.
* Close the generated menu code output file.
* If anything goes wrong display appropriate message to the user.
*
PROCEDURE builddisable
    SET ESCAPE OFF
    ON ESCAPE
    SET TEXTMERGE OFF
    IF NOT FCLOSE(_TEXT)
        DO errorhandler WITH "Unable to Close the Application File",;
            LINENO(), c_error_2
    ENDIF

*
* OPENDB - Prepare database for processing.
*
* Description:
* Attempt to USE a database.  If attempt fails and error is reported
* call ERRORHANDLER routine to display a friendly message.  Return
* with a status of .F..  If attempt succeeds, return with status of .T.
*
* Returns:
* .T. on success; .F. on failure
*
FUNCTION opendb
    PARAMETER m.dbname
    PRIVATE m.dbalias
    ON ERROR DO errorhandler WITH MESSAGE(), LINENO(), c_error_2

    m.dbalias = basename(m.dbname)
    IF USED (m.dbalias)
        SELECT (m.dbalias)
        IF RAT(".MNX",DBF())<>0
            g_mnxfile[3] = .F.
            g_mnxfile[4] = m.dbalias
        ELSE
            g_mnxfile[4] = "M"+SUBSTR(LOWER(SYS(3)),2,8)
            SELECT 0
            USE (m.dbname) AGAIN ALIAS (g_mnxfile[4])
            g_mnxfile[3] = .T.
        ENDIF
    ELSE
        IF illegalname(m.dbalias)
            g_mnxfile[4] = "M"+SUBSTR(LOWER(SYS(3)),2,8)
        ELSE
            g_mnxfile[4] = m.dbalias
        ENDIF
        SELECT 0
        USE (m.dbname) AGAIN ALIAS (g_mnxfile[4])
        g_mnxfile[3] = .T.
    ENDIF

    IF FCOUNT() <> c_mnxflds
        IF FCOUNT() = c_20mnxflds
            m.g_20mnx = .T.
        ELSE
            DO errorhandler WITH "Menu "+m.dbalias+" is invalid",LINENO(),;
                c_error_2
            RETURN .F.
        ENDIF
    ELSE
        m.g_20mnx = .F.
    ENDIF

    ON ERROR DO errorhandler WITH MESSAGE(), LINENO(), c_error_3
    IF m.g_error = .T.
        RETURN .F.
    ENDIF

*
* ILLEGALNAME - Check if default alias will be used when this
*               database is USEd. (i.e., 1st letter is not A-Z,
*                               a-z or '_', or any one of ramaining letters is not
*                               alphanumeric.)
*
FUNCTION illegalname
    PARAMETER m.menuname
    PRIVATE m.start, m.aschar, m.length
    m.length = LEN(m.menuname)
    m.start  = 0
    IF m.length = 1
        *
        * If length 1, then check if default alias can be used,
        * i.e., name is different than A-J and a-j.
        *
        m.aschar = ASC(m.menuname)
        IF (m.aschar >= 65 AND m.aschar <= 74) OR ;
                (m.aschar >= 97 AND m.aschar <= 106)
            RETURN .T.
        ENDIF
    ENDIF
    DO WHILE m.start < m.length
        m.start  = m.start + 1
        m.aschar = ASC(SUBSTR(m.menuname, m.start, 1))
        IF m.start<>1 AND (m.aschar >= 48 AND m.aschar <= 57)
            LOOP
        ENDIF
        IF NOT ((m.aschar >= 65 AND m.aschar <= 90) OR ;
                (m.aschar >= 97 AND m.aschar <= 122) OR m.aschar = 95)
            RETURN .T.
        ENDIF
    ENDDO
    RETURN .F.

*
* OPENFILE - Create and open the application output file.
*
* Description:
* Create a file that will hold the generated menu code.
* Open the newly created file.  If error(s) encountered
* at any time issue an error message and return .F.
*
* Returns:
* .T. on success; .F. on failure
*
FUNCTION openfile
    PRIVATE m.msg
    _TEXT = FCREATE(m.g_outfile)
    IF (_TEXT = -1)
        m.msg = "Cannot open file "+m.g_outfile
        DO errorhandler WITH m.msg, LINENO(), c_error_3
        m.g_nohandle = .T.
        RETURN .F.
    ENDIF
    m.g_nohandle = .F.

*
* DEFINEMENU - Define main menu and its pads.
*
* Description:
* Issue DEFINE MENU ... command.
* Call a procedure to define all menu pads.
* Call a procedure to generate ON PAD statements when appropriate.
*
PROCEDURE definemenu

    IF m.g_graphic
        SET MESSAGE TO 'Generating menu definitions...'
    ENDIF
    DO commentblock WITH "menu"
    SELECT (g_mnxfile[4])
    LOCATE FOR objtype = c_menu
    m.g_location = location
    m.g_padloca  = ALLTRIM(name)

    LOCATE FOR objtype = c_submenu AND objcode = c_global

    m.g_menucolor = SCHEME
    m.g_menumark  = MARK
    IF m.g_location = c_replace
        \SET SYSMENU TO
        \
    ENDIF
    \SET SYSMENU AUTOMATIC
    \

    DO defmenupads
    DO defonpad
    \
    DO updtherm WITH 25

*
* DEFMENUPADS - Define all pads for the menu bar.
*
* Description:
* Scan the menu database for all objects of the type item which
* have the levelname=_MSYSMENU.
* For each such item, generate a statement DEFINE PAD... where
* the name of the pad is the contents of NAME field or (if Name
* field is empty) an automatically generated name.
* Call procedures addkey, addskipfor, and mark to generate
* KEY, SKIPFOR, or MARK clauses when appropriate.
*
PROCEDURE defmenupads
    PRIVATE m.padname, m.prompt
    SCAN FOR objtype=c_item AND UPPER(levelname)="_MSYSMENU"
        IF NOT EMPTY(ALLTRIM(name))
            g_pads[VAL(Itemnum)] = name
        ELSE
            g_pads[VAL(Itemnum)] = LOWER(SYS(2015))
        ENDIF
        \DEFINE PAD <<g_pads[VAL(Itemnum)]>> OF _MSYSMENU

        IF MOD(VAL(itemnum),25)=0
            DIMENSION g_pads[VAL(Itemnum)+25]
        ENDIF
        m.prompt = SUBSTR(PROMPT,1,LEN(PROMPT))
        \\ PROMPT "<<m.prompt>>"
        \\ COLOR SCHEME <<m.g_menucolor>>

        IF m.g_menumark<>c_null AND m.g_menumark<>""
            \\ ;
            \   MARK "<<m.g_menumark>>"
        ENDIF

        DO CASE
            CASE m.g_location = c_before
                \\ ;
                \       BEFORE <<m.g_padloca>>
            CASE m.g_location = c_after
                \\ ;
                \       AFTER
                IF VAL(itemnum) = 1
                    \\ <<m.g_padloca>>
                ELSE
                    \\ <<g_pads[VAL(Itemnum)-1]>>
                ENDIF
        ENDCASE

        DO addkey
        DO addskipfor
        DO addmessage

    ENDSCAN
    DO updtherm WITH 35

*
* DEFONPAD - Generate ON PAD... statements.
*
* Description:
* Generate ON PAD statements for each pad off of the main menu which
* has a submenu associated with it.
* For pads which have no submenus, but there is a command associated
* with them, issue ON SELECTION PAD... statements.  If the code
* associated with a pad is a snippet, then issue a call to the
* generated procedure and place the snippet code in it.
*
PROCEDURE defonpad
    PRIVATE m.padname
    SCAN FOR objtype=c_item AND UPPER(levelname)="_MSYSMENU"
        IF NOT EMPTY(ALLTRIM(name))
            m.padname = name
        ELSE
            m.padname = g_pads[VAL(Itemnum)]
        ENDIF
        SKIP
        IF objtype=c_submenu AND numitems<>0
            \ON PAD <<m.padname>> OF _MSYSMENU
            \\ ACTIVATE POPUP <<LOWER(Name)>>
            SKIP -1
        ELSE
            SKIP -1
            DO onselection WITH "pad", m.padname, '_MSYSMENU'
        ENDIF
    ENDSCAN
    DO updtherm WITH 45

*
* DEFINEPOPUPS - Define popups and their bars.
*
* Description:
* Scan the Menu database to find all objecttypes = submenu.
* They all correspond to popups.  For each such object found, issue
* command DEFINE POPUP....  Add MARK, KEY, and SKIP FOR clauses
* if appropriate by calling procedures to handle these tasks.  Call
* procedure Defbars to define all bars of each popup.
*
PROCEDURE definepopups
    PRIVATE m.savrecno, m.popname, m.sch
    IF m.g_graphic
        SET MESSAGE TO 'Generating popup definitions...'
    ENDIF
    SCAN FOR objtype=c_submenu AND UPPER(levelname)<>"_MSYSMENU" ;
            AND numitems <> 0

        m.savrecno = RECNO()
        m.popname  = ALLTRIM(LOWER(levelname))
        m.sch      = SCHEME

        \DEFINE POPUP <<LOWER(Name)>> MARGIN RELATIVE SHADOW
        \\ COLOR SCHEME <<m.sch>>

        DO addmark
        DO addkey
        DO defbars WITH m.popname, numitems
        DO defonbar WITH m.popname
        \
        GOTO RECORD m.savrecno
    ENDSCAN
    DO updtherm WITH 65

*
* DEFBARS - Define bars for each popup.
*
* Description:
* Scan the menu database for all objects of the type item whose
* name equals to the current popup name.
* For each such item, generate a statement DEFINE BAR....
* Call procedures addkey, addskipfor, and addmark to generate
* KEY, SKIPFOR, or MARK clauses when appropriate.
*
PROCEDURE defbars
    PARAMETER m.popname, m.howmany, m.name
    PRIVATE m.itemno, m.prompt
    SCAN FOR objtype=c_item AND LOWER(levelname)=m.popname
        m.itemno = ALLTRIM(itemnum)

        IF NOT EMPTY(ALLTRIM(name))
            m.name = name
            \DEFINE BAR <<m.name>> OF <<LOWER(m.popname)>>
        ELSE
            \DEFINE BAR <<m.itemno>> OF <<LOWER(m.popname)>>
        ENDIF
        m.prompt = SUBSTR(PROMPT, 1,LEN(PROMPT))
        \\ PROMPT "<<m.prompt>>"

        DO addmark
        DO addkey
        DO addskipfor
        DO addmessage

        IF VAL(m.itemno)=m.howmany
            DO updtherm WITH 75
            RETURN
        ENDIF
    ENDSCAN

*
* DEFONBAR - Generate ON BAR... statements.
*
* Description:
* Generate ON BAR statements for each popup.
* For bars which have no submenus, but there is a command associated
* with them, issue ON SELECTION BAR... statements.  If a snippet is
* associated with the code then generate a call statement to the
* generated procedure containing the snippet code.
*
PROCEDURE defonbar
    PARAMETER m.popname
    PRIVATE m.itemno
    SCAN FOR objtype=c_item AND LOWER(levelname)=m.popname
        IF EMPTY(ALLTRIM(name))
            m.itemno = ALLTRIM(itemnum)
        ELSE
            m.itemno = name
        ENDIF
        SKIP
        IF objtype=c_submenu AND numitems<>0
            \ON BAR <<m.itemno>> OF <<LOWER(m.popname)>>
            \\ ACTIVATE POPUP <<LOWER(Name)>>
            SKIP -1
        ELSE
            SKIP -1
            DO onselection WITH "BAR", m.itemno, m.popname
        ENDIF
    ENDSCAN
    DO updtherm WITH 85

*
* GLOBALDEFAULTS - Generate global default statements
*
* Description:
* Search the menu database for information needed to generate any of
* the following commands:
* ON SELECTION MENU <name> DO <action>
* ON SELECTION POPUP ALL DO <action>
* ON SELECTION POPUP <name> DO <action>
* It is possible that none of the above mentioned statements will be
* generated.  It is also possible that the action is a snippet of
* code and a call to the generated procedure containing the snippet
* will be generated.
*
* First try to generate ON SELECTION MENU...
* Then try to generate ON POPUP ALL...
* Lastly, try to generate ON SELECTION POPUP...
*
PROCEDURE globaldefaults
    LOCATE FOR objtype = c_menu
    m.mrk = MARK
    IF FOUND() AND MARK <> ""
        IF MARK = c_null
            \SET MARK OF MENU _MSYSMENU TO " "
        ELSE
            \SET MARK OF MENU _MSYSMENU TO "<<Mark>>"
        ENDIF
    ENDIF
    IF FOUND() AND NOT EMPTY(PROCEDURE)
        \ON SELECTION MENU _MSYSMENU
        DO genproccall
    ENDIF
    LOCATE FOR objtype = c_submenu AND objcode = c_global
    IF FOUND() AND NOT EMPTY(PROCEDURE)
        \ON SELECTION POPUP ALL
        DO genproccall
    ENDIF
    SCAN FOR (objtype=c_submenu AND UPPER(levelname)<>"_MSYSMENU";
            AND NOT EMPTY(PROCEDURE))
        \ON SELECTION POPUP <<ALLTRIM(LOWER(Levelname))>>
        DO genproccall
    ENDSCAN
    DO updtherm WITH 95

**
** Subroutines for processing menu clause options.
**

*
* ADDMARK - Generate a MARK clause whenever appropriate.
*
* Description:
* Add a MARK clause to the current PAD or BAR definition.
* If a field named Mark is not empty, then add the continuation
* character, ";", to the previous line, and then add the MARK... clause.
*
PROCEDURE addmark
    IF MARK<>c_null AND MARK<>""
        \\ ;
            \   MARK "<<Mark>>"
    ENDIF

*
* ADDKEY - Generate KEY... clause whenever appropriate.
*
* Description:
* Add a KEY clause to the current PAD or BAR definition.
* If a field named Keyname is not empty, then add the continuation
* character, ";", to the previous line, and then add the KEY... clause.
*
PROCEDURE addkey
    IF NOT EMPTY(keyname)
        \\ ;
        \       KEY <<Keyname>>, "<<Keylabel>>"
    ENDIF

*
* ADDSKIPFOR - Generate SKIP FOR... clause whenever appropriate.
*
* Description:
* Add a ADDSKIPFOR clause to the current PAD or BAR definition.
* If a field named Addskipfor is not empty, then add the continuation
* character, ";", to the previous line, and then add the SKIP FOR...
* clause.
*
PROCEDURE addskipfor
    PRIVATE m.skip
    m.skip = skipfor
    IF NOT EMPTY(skipfor)
        \\ ;
        \       SKIP FOR <<m.skip>>
    ENDIF

*
* ADDMESSAGE - Generate MESSAGE clause whenever appropriate.
*
* Description:
* Add a MESSAGE clause to the current PAD or BAR definition.
* If a field named MESSAGE is not empty and it is not a 2.0 menu,
* then add the continuation character, ";", to the previous line,
* and then add the MESSAGE clause.
*
PROCEDURE addmessage

    IF !m.g_20mnx AND NOT EMPTY(MESSAGE)
        \\ ;
        \       MESSAGE <<Message>>
    ENDIF

*
* HEADER - Generate generated program's header.
*
* Description:
* As a part of the automatically generated program's header generate
* program name, name of the author of the program, copyright notice,
* company name and address, and the word 'Description:' which will be
* followed with a short description of the generated code.
*
PROCEDURE HEADER
    \\*       <<m.g_corn1>><<REPLICATE(m.g_horiz,57)>><<m.g_corn2>>
    \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
    \*       <<m.g_verti1>> <<DATE()>>
    \\<<PADC(UPPER(ALLTRIM(strippath(m.g_outfile))),IIF(SET("CENTURY")="ON",35,37))," ")>>
    \\ <<TIME()>>  <<m.g_verti2>>
    \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
    \*       <<m.g_corn5>><<REPLICATE(m.g_horiz,57)>><<m.g_corn6>>
    \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
    \*       <<m.g_verti1>> <<m.g_devauthor>>
    \\<<REPLICATE(" ",56-LEN(m.g_devauthor))>><<m.g_verti2>>
    \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
    \*       <<m.g_verti1>>
    \\ Copyright (c) <<YEAR(DATE())>>
    IF LEN(ALLTRIM(m.g_devcompany)) <= 36
        \\ <<ALLTRIM(m.g_devcompany)>>
        \\<<REPLICATE(" ",37-LEN(ALLTRIM(m.g_devcompany)))>>
        \\<<m.g_verti2>>
    ELSE
        \\ <<REPLICATE(" ",37)>><<m.g_verti2>>
        \*       <<m.g_verti1>> <<m.g_devcompany>>
        \\<<REPLICATE(" ",56-LEN(m.g_devcompany))>><<m.g_verti2>>
    ENDIF

    \*       <<m.g_verti1>> <<m.g_devaddress>>
    \\<<REPLICATE(" ",56-LEN(m.g_devaddress))>><<m.g_verti2>>

    \*       <<m.g_verti1>> <<ALLTRIM(m.g_devcity)>>, <<m.g_devstate>>
    \\  <<ALLTRIM(m.g_devzip)>>
    \\<<REPLICATE(" ",50-(LEN(ALLTRIM(m.g_devcity)+ALLTRIM(m.g_devzip))))>>
    \\<<m.g_verti2>>

    IF !INLIST(ALLTRIM(UPPER(m.g_devctry)),"USA","COUNTRY") AND !EMPTY(m.g_devctry)
       \*       <<m.g_verti1>> <<ALLTRIM(m.g_devctry)>>
       \\<<REPLICATE(" ",50-(LEN(ALLTRIM(m.g_devctry))))>>
       \\<<m.g_verti2>>
    ENDIF

    \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
    \*       <<m.g_verti1>> Description:
    \\                                            <<m.g_verti2>>
    \*       <<m.g_verti1>>
    \\ This program was automatically generated by GENMENU.
    \\    <<m.g_verti2>>
    \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
    \*       <<m.g_corn3>><<REPLICATE(m.g_horiz,57)>><<m.g_corn4>>
    \

*
* GENFUNCHEADER - Generate Comment for Function/Procedure.
*
PROCEDURE genfuncheader
    PARAMETER m.procname
    PRIVATE m.place, m.prompt
    m.g_snippcnt = m.g_snippcnt + 1
    DO CASE
        CASE objtype = c_menu
            m.place = "ON SELECTION MENU _MSYSMENU"
        CASE objtype = c_submenu AND objcode = c_global
            m.place = "ON SELECTION POPUP ALL"
        CASE objtype = c_submenu AND objcode <> c_global
            m.place = "ON SELECTION POPUP "+LOWER(ALLTRIM(name))
        CASE objtype = c_item AND UPPER(levelname) = "_MSYSMENU"
            m.place = "ON SELECTION PAD "
        CASE objtype = c_item AND UPPER(levelname) <> "_MSYSMENU"
            m.place = "ON SELECTION BAR "+ALLTRIM(itemnum)+;
                +" OF POPUP "+LOWER(ALLTRIM(levelname))
        OTHERWISE
            m.place = ""
    ENDCASE
    \
    \*       <<m.g_corn1>><<REPLICATE(m.g_horiz,57)>><<m.g_corn2>>
    \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
    \*       <<m.g_verti1>> <<UPPER(PADR(m.procname,10))>>  <<m.place>>
    \\<<REPLICATE(" ",44-LEN(m.place))>><<m.g_verti2>>
    \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
    \*       <<m.g_verti1>> Procedure Origin:
    \\<<REPLICATE(" ",39)>><<m.g_verti2>>
    \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
    \*       <<m.g_verti1>> From Menu:
    \\  <<ALLTRIM(strippath(m.g_outfile))>>
    \\,            Record:  <<STR(RECNO(),3)>>
    \\<<REPLICATE(" ",22-LEN(ALLTRIM(strippath(m.g_outfile))+STR(RECNO(),3))))>>
    \\<<m.g_verti2>>
    \*       <<m.g_verti1>> Called By:  <<m.place>>
    \\<<REPLICATE(" ",44-LEN(m.place))>><<m.g_verti2>>
    IF NOT EMPTY(PROMPT)
        m.prompt = removemeta()
        \*       <<m.g_verti1>> Prompt:     <<ALLTRIM(m.prompt)>>
        \\<<REPLICATE(" ",44-LEN(ALLTRIM(m.prompt)))>><<m.g_verti2>>
    ENDIF
    \*       <<m.g_verti1>> Snippet:
    \\    <<ALLTRIM(STR(m.g_snippcnt,2))>>
    \\<<REPLICATE(" ",44-LEN(ALLTRIM(STR(m.g_snippcnt,2))))>><<m.g_verti2>>
    \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
    \*       <<m.g_corn3>><<REPLICATE(m.g_horiz,57)>><<m.g_corn4>>
    \*

*
* REMOVEMETA - Remove meta characters for documentation.
*
FUNCTION removemeta
    PRIVATE m.prompt, m.hotkey
    m.prompt = PROMPT
    m.hotkey = AT("\<",m.prompt)

    IF m.hotkey <> 0
        m.prompt = STUFF(m.prompt,m.hotkey,2,"")
    ENDIF

    m.disabl = AT("\",m.prompt)
    IF m.disabl <> 0
        m.prompt = STUFF(m.prompt,m.disabl,1,"")
    ENDIF
    RETURN m.prompt

*
* COMMENTBLOCK - Generate a comment block.
*
PROCEDURE commentblock
    PARAMETER m.snippet
    \
    \*       <<m.g_corn1>><<REPLICATE(m.g_horiz,57)>><<m.g_corn2>>
    \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
    DO CASE
        CASE m.snippet == "setup"
            \*       <<m.g_verti1>>
            \\ <<PADC(" Setup Code",56," ")>>
        CASE m.snippet == "cleanup"
            \*       <<m.g_verti1>>
            \\ <<PADC(" Cleanup Code & Procedures",56," ")>>
        CASE m.snippet == "init"
            \*       <<m.g_verti1>>
            \\ <<PADC(" Initializing Code",56," ")>>
        CASE m.snippet == "menu"
            \*       <<m.g_verti1>>
            \\ <<PADC(" Menu Definition",56," ")>>
    ENDCASE
    \\<<m.g_verti2>>
    \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
    \*       <<m.g_corn3>><<REPLICATE(m.g_horiz,57)>><<m.g_corn4>>
    \*
    \

**
** Supporting routines
**

*
* ONSELECTION - Generate ON SELECTION... statements for menu items.
*
* Description:
* For pads and bars which have no submenu associated with them but
* instead have a non-empty Command field in the database, issue
* the ON SELECTION <command> statements.  If a snippet is associated
* with a pad then issue a call statement to the generated procedure
* containing the snippet.  Generated snippet procedure will be
* appended to the end of the output file.
*
PROCEDURE onselection
    PARAMETER m.which, m.name, m.ofname, m.commd
    PRIVATE m.trimname, m.basename
    IF EMPTY(PROCEDURE) AND EMPTY(COMMAND)
        RETURN
    ENDIF
    DO CASE
        CASE m.which == "pad"
            \ON SELECTION PAD <<m.name>>
        CASE m.which == "BAR"
            \ON SELECTION <<m.which+" "+m.name>>
    ENDCASE
    \\ OF <<m.ofname>>
    IF objcode = c_proc
        DO gensnippname
        m.trimname = SYS(2014,m.g_outfile,m.g_homedir)
        m.trimname = stripext(m.trimname)
        m.basename = basename(m.trimname)
        \\ ;
        \       DO <<g_snippets[g_nsnippets,1]>> ;
        \       IN LOCFILE("<<m.trimname>>"
        \\ ,"MPX;MPR|FXP;PRG"
        \\ ,"Where is <<m.basename>>?")
    ELSE
        m.commd = COMMAND
        \\ <<m.commd>>
    ENDIF

*
* GENSNIPPNAME - Generate a unique name for snippet procedure.
*
* Description:
* Lookup the #NAME name of this snippet, or alternatively
* provide a unique name for a snippet of code associated with the
* generated menu.  Save this name in an array g_snippets.
*
PROCEDURE gensnippname
    g_nsnippets = g_nsnippets + 1
    g_snippets[g_nsnippets,1] = getcname(procedure)
    g_snippets[g_nsnippets,2] = RECNO()

    IF MOD(g_nsnippets,25) = 0
        DIMENSION g_snippets [g_nsnippets+25,2]
    ENDIF

*
* GENPROCCALL - Generate a call statement to snippet procedure.
*
* Description:
* Generate a call to the snippet procedure in the menu definition
* code.
*
PROCEDURE genproccall
    PRIVATE m.trimname, m.basename, m.proc
    IF singleline()
        m.proc = PROCEDURE
        \\ <<MLINE(m.proc,1)>>
    ELSE
        DO gensnippname
        m.trimname = SYS(2014,m.g_outfile,m.g_homedir)
        m.trimname = stripext(m.trimname)
        m.basename = basename(m.trimname)
        \\ ;
        \       DO <<g_snippets[m.g_nsnippets,1]>> ;
        \       IN LOCFILE("<<m.trimname>>"
        \\ ,"MPX;MPR|FXP;PRG"
        \\ ,"Where is <<m.basename>>?")
    ENDIF

*
* SINGLELINE - Determine if Memo contains only one line.
*
* Description:
* This procedure is used to decide if an ON SELECTION... statement
* and a snippet procedure will be needed (i.e., if more than one
* line of snippet code then its a snippet, otherwise its a command)
*
FUNCTION singleline
    PRIVATE m.size, m.i
    m.size = MEMLINES(PROCEDURE)
    IF m.size = 1
        RETURN .T.
    ENDIF
    m.i = m.size
    DO WHILE m.i > 1
        m.line = MLINE(PROCEDURE, m.i)
        IF NOT EMPTY(m.line)
            RETURN .F.
        ENDIF
        m.i = m.i - 1
    ENDDO

*
* GENPROCEDURES - Generate procedure/snippet code.
*
* Description:
* Generate 'PROCEDURE procedurename' statement and its body.
*
PROCEDURE genprocedures
    PRIVATE m.i
    IF m.g_graphic
        SET MESSAGE TO 'Generating procedures...'
    ENDIF
    FOR m.i = 1 TO m.g_nsnippets
        GOTO RECORD (g_snippets[m.i,2])
        DO genfuncheader WITH g_snippets[m.i,1]
        \PROCEDURE <<g_snippets[m.i,1]>>
        DO writecode WITH procedure
        \
    ENDFOR

*
* WRITECODE - Write contents of a memo to a low level file.
*
* Description:
* Receive a memo field as a parameter and write its contents out
* to the currently opened low level file whose handle is stored
* in the system memory variable _TEXT.  Contents of the system
* memory variable _pretext will affect the positioning of the
* generated text.
*
PROCEDURE writecode
    PARAMETER m.memo
    PRIVATE m.lines, m.i, m.thisline
    m.lines = MEMLINES(m.memo)
    _MLINE = 0
    FOR m.i = 1 TO m.lines
        m.thisline = MLINE(m.memo, 1, _MLINE)
        IF LEFT(UPPER(LTRIM(m.thisline)),5) == "#INSE"   && #INSERT
           DO GenInsertCode WITH m.thisline
        ELSE
           IF LEFT(UPPER(LTRIM(m.thisline)),5) <> "#NAME"
              \<<m.thisline>>
           ENDIF
        ENDIF
    ENDFOR

*
* GENSETUPCLEANUP - Generate setup/cleanup code.
*
PROCEDURE gensetupcleanup
    PARAMETER m.choice
    LOCATE FOR objtype = c_menu
    DO CASE
        CASE m.choice == "setup"
            IF EMPTY(setup)
                RETURN
            ENDIF
            IF m.g_graphic
                SET MESSAGE TO 'Generating Menu Setup Code...'
            ENDIF
            DO commentblock WITH m.choice
            DO writecode WITH setup
        CASE m.choice == "cleanup"
            IF EMPTY(cleanup)
                RETURN
            ENDIF
            IF m.g_graphic
                SET MESSAGE TO 'Generating Menu Cleanup Code...'
            ENDIF
            DO commentblock WITH m.choice
            DO writecode WITH cleanup
    ENDCASE

*
* STRIPEXT - Strip the extension from a file name.
*
* Description:
* Use the algorithm employed by FoxPRO itself to strip a
* file of an extension (if any): Find the rightmost dot in
* the filename.  If this dot occurs to the right of a "\"
* or ":", then treat everything from the dot rightward
* as an extension.  Of course, if we found no dot,
* we just hand back the filename unchanged.
*
* Parameters:
* filename - character string representing a file name
*
* Return value:
* The string "filename" with any extension removed
*
FUNCTION stripext
    PARAMETER m.filename
    PRIVATE m.dotpos, m.terminator
    m.dotpos = RAT(".", m.filename)
    m.terminator = MAX(RAT("\", m.filename), RAT(":", m.filename))
    IF m.dotpos > m.terminator
        m.filename = LEFT(m.filename, m.dotpos-1)
    ENDIF
    RETURN m.filename

*
* STRIPPATH - Strip the path from a file name.
*
* Description:
* Find positions of backslash in the name of the file.  If there is one
* take everything to the right of its position and make it the new file
* name.  If there is no slash look for colon.  Again if found, take
* everything to the right of it as the new name.  If neither slash
* nor colon are found then return the name unchanged.
*
* Parameters:
* filename - character string representing a file name
*
* Return value:
* The string "filename" with any path removed
*
FUNCTION strippath
    PARAMETER m.filename
    PRIVATE m.slashpos, m.namelen, m.colonpos
    m.slashpos = RAT("\", m.filename)
    IF m.slashpos > 0
        m.namelen  = LEN(m.filename) - m.slashpos
        m.filename = RIGHT(m.filename, m.namelen)
    ELSE
        m.colonpos = RAT(":", m.filename)
        IF m.colonpos > 0
            m.namelen  = LEN(m.filename) - m.colonpos
            m.filename = RIGHT(m.filename, m.namelen)
        ENDIF
    ENDIF
    RETURN m.filename

*
* BASENAME - returns strippath(stripext(filespec))
*
FUNCTION basename
    PARAMETER m.filespec
    RETURN strippath(stripext(m.filespec))

*
* GENINSERTCODE - Emit code from the #insert file, if any
*
PROCEDURE GenInsertCode
PARAMETER strg
PRIVATE m.word1, m.filname, m.ins_fp, m.buffer

IF UPPER(LEFT(LTRIM(m.strg),5)) == "#INSE"
   m.word1 = wordnum(m.strg,1)
   m.filname = SUBSTR(m.strg,LEN(m.word1)+1)
   m.filname = ALLTRIM(CHRTRAN(m.filname,CHR(9),""))

   * Bail out if we can't find the file either explicitly or on the DOS path
   IF !FILE(m.filname)
      filname = FULLPATH(m.filname,1)
      IF !FILE(m.filname)
         \*Insert file <<m.filname>> could not be found
         RETURN
      ENDIF
   ENDIF

   ins_fp = FOPEN(m.filname)
   IF ins_fp > 0
      \* Inserted from <<strippath(m.filname)>>
      DO WHILE !feof(ins_fp)
         m.buffer = fgets(ins_fp)
         \<<m.buffer>>
      ENDDO
      =fclose(m.ins_fp)
      \* End of inserted lines
   ENDIF
ENDIF

**
** Code Associated with the Thermometer
**

*
* ACTTHERM(<text>) - Activate thermometer.
*
* Description:
* Activates thermometer.  Update the thermometer with UPDTHERM().
* Thermometer window is named "thermometer."  Be sure to RELEASE
* this window when done with thermometer.  Creates the global
* m.g_thermwidth.
*
PROCEDURE acttherm
    PARAMETER m.text
    PRIVATE m.prompt

    IF m.g_graphic
        m.prompt = LOWER(m.g_outfile)
        IF txtwidth(m.prompt, c_dlgface, c_dlgsize, c_dlgstyle) > 43
            DO WHILE txtwidth(m.prompt+"...", c_dlgface, c_dlgsize, c_dlgstyle) > 43
                m.prompt = LEFT(m.prompt, LEN(m.prompt)-1)
            ENDDO
            m.prompt = m.prompt + "..."
        ENDIF

        DEFINE WINDOW thermomete ;
            AT  INT((SROW() - (( 5.615 * ;
            fontmetric(1, c_dlgface, c_dlgsize, c_dlgstyle )) / ;
            fontmetric(1, wfont(1,""), wfont(2,""), wfont(3,"")))) / 2), ;
            INT((SCOL() - (( 63.833 * ;
            fontmetric(6, c_dlgface, c_dlgsize, c_dlgstyle )) / ;
            fontmetric(6, wfont(1,""), wfont(2,""), wfont(3,"")))) / 2) ;
            SIZE 5.615,63.833 ;
            font c_dlgface, c_dlgsize ;
            STYLE c_dlgstyle ;
            NOFLOAT ;
            NOCLOSE ;
            NONE ;
            COLOR rgb(0, 0, 0, 192, 192, 192)

        ACTIVATE WINDOW thermomete NOSHOW

        @ 0.5,3 SAY m.text font c_dlgface, c_dlgsize STYLE c_dlgstyle
        @ 1.5,3 SAY m.prompt font c_dlgface, c_dlgsize STYLE c_dlgstyle
        @ 0.000,0.000 TO 0.000,63.833 ;
            COLOR rgb(255, 255, 255, 255, 255, 255)
        @ 0.000,0.000 TO 5.615,0.000 ;
            COLOR rgb(255, 255, 255, 255, 255, 255)
        @ 0.385,0.667 TO 5.231,0.667 ;
            COLOR rgb(128, 128, 128, 128, 128, 128)
        @ 0.308,0.667 TO 0.308,63.167 ;
            COLOR rgb(128, 128, 128, 128, 128, 128)
        @ 0.385,63.000 TO 5.308,63.000 ;
            COLOR rgb(255, 255, 255, 255, 255, 255)
        @ 5.231,0.667 TO 5.231,63.167 ;
            COLOR rgb(255, 255, 255, 255, 255, 255)
        @ 5.538,0.000 TO 5.538,63.833 ;
            COLOR rgb(128, 128, 128, 128, 128, 128)
        @ 0.000,63.667 TO 5.615,63.667 ;
            COLOR rgb(128, 128, 128, 128, 128, 128)
        @ 3.000,3.333 TO 4.231,3.333 ;
            COLOR rgb(128, 128, 128, 128, 128, 128)
        @ 3.000,60.333 TO 4.308,60.333 ;
            COLOR rgb(255, 255, 255, 255, 255, 255)
        @ 3.000,3.333 TO 3.000,60.333 ;
            COLOR rgb(128, 128, 128, 128, 128, 128)
        @ 4.231,3.333 TO 4.231,60.500 ;
            COLOR rgb(255, 255, 255, 255, 255, 255)
        m.g_thermwidth = 56.269

        SHOW WINDOW thermomete TOP
    ELSE
        m.prompt = SUBSTR(SYS(2014,m.g_outfile),1,48)+;
            IIF(LEN(m.g_outfile)>48,"...","")

        DEFINE WINDOW thermomete;
            FROM INT((SROW()-6)/2), INT((SCOL()-57)/2) ;
            TO INT((SROW()-6)/2) + 6, INT((SCOL()-57)/2) + 57;
            DOUBLE COLOR SCHEME 5

        ACTIVATE WINDOW thermomete NOSHOW

        m.g_thermwidth = 50
        @ 0,3 SAY m.text
        @ 1,3 SAY UPPER(m.prompt)
        @ 2,1 TO 4,m.g_thermwidth+4 &g_boxstrg

        SHOW WINDOW thermomete TOP
    ENDIF

*
* UPDTHERM(<percent>) - Update thermometer.
*
PROCEDURE updtherm
    PARAMETER m.percent
    PRIVATE m.nblocks, m.percent
    ACTIVATE WINDOW thermomete
    m.nblocks = (m.percent/100) * (m.g_thermwidth)
    IF m.g_graphic
        @ 3.000,3.333 TO 4.231,m.nblocks + 3.333 ;
            pattern 1 COLOR rgb(128, 128, 128, 128, 128, 128)
    ELSE

* CGC MMM               1994.2.21
*        @ 3,3 SAY REPLICATE("█",m.nblocks)
        @ 3,3 SAY REPLICATE("ä",m.nblocks)
* CGC MMM

    ENDIF

*
* DEACTTHERMO - Deactivate and Release thermometer window.
*
PROCEDURE deactthermo
    RELEASE WINDOW thermomete

**
** Error Handling Code
**

*
* ERRORHANDLER - Error Processing Center.
*
PROCEDURE errorhandler
    PARAMETERS m.messg, m.lineno, m.code
    IF ERROR() = 22
        ON ERROR &onerror
        DO cleanup
        CANCEL
    ENDIF

    DO CASE
        CASE m.code == "Minor"
            DO errlog WITH m.messg, m.lineno
            m.g_status = 1
        CASE m.code == "Serious"
            DO errlog  WITH m.messg, m.lineno
            DO errshow WITH m.messg, m.lineno
            m.g_error = .T.
            m.g_status = 2
            ON ERROR
        CASE m.code == "Fatal"
            IF NOT m.g_nohandle
                DO errlog  WITH m.messg, m.lineno
            ENDIF
            DO errshow WITH m.messg, m.lineno
            IF WEXIST("Thermomete") AND WVISIBLE6.269



    ne_Fo    000 Te
        @c_dl    <cI thermometDURE deactth m.meH m.messg, m.line 1.5,3 SAY m.prom    O)mess.333o psinen   eacti ne_Fo         CASE m.cod5,3 SAY m.     piLOR'Pbr, 255t fon      @ 2,1 TO 4, 3,3upCoWIN       @ 1,3 S  @LE6.2prom255)N      WIN       @ 1,3 SE6.2p
* =,Elineno       COse         1,3 nenermwi COLOR rgb(128, 1     @c_dl         @ 5.231,0.667 TOY)<Sg rgb(128, 128, 12SrsbTeeftbil, 12667 TOYg, m.line 1SYS(2014,m.g_outfs 1,3@LE6OLO ;
   +31, @ 0. WI'gstyle
  yledthsty0.3rcentYg, m.l
   , 255, 255,fs 1  @ 5.231,0128andle
        .li   FROM INT((SROW()-   OW()-   OW()-   Os 1,3@LE6O5, 255)
  DO errlo  @\r * m 4A   oxstrg

 255, 255, 2GAtso,hA3850128andle

 3 SE(iR    e
  INT((SROW(.538,0.000 TO 5.5 5.5A   o , 267 T TO 4.2m.g_outfile),1,48m 5.5I)128, 1eac,0.000 ;er.
*
PROCEDURE
 255, s 1,3@LE6OLO ;
 gb(M_0 OW() ELSEM_0 OW() 8andle

 255, 255, 255LSEM_0 OW() 8andl EL3rcentYg, m.l
  IBLE6.269

    P 1p231,0  COs TO 4.20    o<cI  .269
.l
    WIN           PARAM()-GCOL 128, 128667 TOURE
 255, s 1,3@  .269
.l
    WI255,)
      LSEM   @)
      LSEM   @ 255RM1nhermom * m 4VISIBLE6.269

 ME2G detnC.Dr WIrmom * m 4VISIBLO 4.231,603upoo

g, m.lineno
      P 1p25I)1281nhermom * menReK.5, 3@LE6OL=m.g    m.g_   IF ER
            END
        @c_mO+;
         )"ont/100) *
    IF m.g_grap255, s 1,3@LE6OLO;
  Mbfile)>48,"...".26cks = (>48rgb(1    Tnlc  , 2O;
 3,3up      @ 0.000,63.
C_Llm-7 (>3l8, 128, 128)
   ont/100) NTf m.LO ;Y UPPER( m.percentandle
      m.lineno00,6, @ 0. WI'gsDUREom * menReK.5, 3@ae TO.l
    8, 128, 128,3@L5, 255)128, 128,l_ 0,100) *
    IF om * menReK.5OCEDURE updthermDUREom c  , 2O0'2RHERM(<p  , 2O;
 3,3up;
           a)>4EACT = 56menReK.5,  \mg_Pi"DIF
    ENm.gDEF 255, 255)
   DEACIIF(LEN(m.g_outfi,n8)mOSE6.2p
* =,ElinenThermomete") AND ,6, 231,0( mfintLrrh &km.g_error = rrhSE ERROR()gDWh(.   M_0 OW() ELSEM_0 Ea,3 uN1_tlh ) 0. WI'gsty M_0 OW()centg Center m.messg, gDEFWI'gLO;cks + 3       @c_mL
* CGC D2Ointy   28,     .1
  adlb"1TIVwidth)
     255<ase theRE upwidth)
     255< 255RM1
   ldPutf  IF>P<NnmNmO<scACGC MMM
8, 128, 128, 12;cks + 3       , @ 0. WI'

ssg,8, 128, 128, 12;dth)
    3       @c_mL
* IF>P<error = .T.
    Rbase,6, 231, = .T.
    O 4,m.g_tM(<1
   led.T.5, 2o
       O 4,m.     , @ 0. WI'
",m.nbloc55,
PROCEDth 0 OW() ELSEM      led.T.5, 2orlog  WITH
     255<aO;LAmLO ;Y UT   LO ;Y UT   LO ;Y  DO errshow WITH leOCE    +4 &GC MMM, 128, 128)
   oig       @c_mL
* IF>P<er uN1_+0=ndle
  ITH leOCE    +4 ST(h)
     255< 2551 COLORIVwidthm.nblITH m.messg, m.lith)
    3          @c_mL
* M

      22
       T("e t  +4 ST(h)
         1iRcNtnsdERM(<p  , 2O;
 3T   Lssg,
    ENDIF
      tus H m.mes)
, 2oE6.< 2 t  +4 ST(htW z,H m.m COsno
           R**
** Error Ha1iRcNtnsdERM(<p    DO<1
   ledfi,n8)mOSE     255<aO;  WIyte    ,RcNt 2oE6.< 2 t  enttHDf(tLrrh &km.g_err    @c_mAY REPtm,fn1,3nbW, moE6.< 55< e
e1 T      , @ 0. WI'ATE("█",m.nblointLr6.< 55< e
e1 T  inenrmomete") AND WVInbW, mo  @c_mL
* IF>P<.< 55< m.g_grapIF ER
   269

 trg

 25<p  m.m, 255, 255 ne_Fo   ls + 3 m.m, 25l (mp, 2o
              CASE m.c(m.g_outfi,n8)Yg, msR",oessm.l
 gDEFWI'grrshow WITfi,n8)YmsR",oessm
    IF m.g_grap25I)12     m.g_status OR
6OLO;
  Mbf"i,aP]rAP"...".26cks = (>4l
 gDEFWI'grrsrineno
 Dth  eacti ne_Fo    COs TO 4.vm.n, 255, 2GAtso,       COseliS  @LE6.2prom25Fr5=KPe)> 4.vm.n,      i   FRO  DERIVwidthm.nblITH CbCNCP_dc'Pwd  i   FRO  DERI  o<cI  .269
cti ne_ef
  26EE
   hr      @cOLO;
  MbRDe_Fon,     .5,3 SAY      Ih3 IDnuVm.mes8)YMbfile)>48,"..TaG deactth m.meH m.g, m.l.269
.l
       CASE y M_0 OW()centg 0 OW()centg OCEDUREWI'gs    @  WI'

ssg,8, n"  @c_dl   ssg
    FRO mo  @c_mL
* 0 OW() 8andl EL3r0 O      .meH m.messg, m
           ac,0.000   pi
   +31, @ 0. WIPBv>xu
6OLO;
  M ACE[e,>u.Ca4AnH5'
",m.nb< 55< m.    COse         ANDok3 MPuLc @coxstrm.c          WI255,CEDUREPBv>xu
6OLO;
  M AC
  M A  o<cI  .2r\bT M Am.messg
   1,3@  .2g, gDEFWI ls + 3 m.mineno00,6,ieTP

fnctSnpi s OR
6OLO;
, 25
 00   mes) pi
   +31,s   l
 gDEFWI'grrss OR
6OLO;
2GAg OCEDUREWI'gs  WI' EL    OLO;
  Ms TO.l, 25CE[e,>u.CaleOeliLO;
, 25
 00H00,63.
C_L@ 0. WI'gstyle
   MbRDe_Fon,.26cks = (>4l
no
 Dth  eacti>4l
no
 Dth  eno
 Dth  k&edt  o1MbRI* M
  tus H0LI* M
  tus H0LI*LO;nUeEm5RM1 2O0Dth  eno
 D
        @c_mO+F>P<ln o=(F68, >P<er uN1_+0=nd( m2GAg OCEDUR1_+0=nd( m2GM(<p    DO<1
   lO;nUeEm5 4VISIBLAg O6, @ 0.
 3 SE(iR    er m.mesee2 t nt/100) NTf<+)
  D     2GAtso,hA3850128e,6, 231, = .I' EL    OLO;
  gTE7 (>3 uN1_+0=nd( N1SIBLO 4.231,603s = (>4l
 gDE'ATE("█",m.ls +   RpR",oessm
    IF mEM  hSE ERROR()gDWh(.Mi4    Dth  eag,
    ENDI0=nd( N1SIBLriYg  RpR",oes .26lm-7 (>y      M"6Ch&5bg <nH5' #+ 6'aNSx2O;nter m.messg, gDEITH CbCNCPcb'R OW()    2S1
    o<cI  .26m.g)Ei xDTO 4.H CuVm.mes8)YMbfi
   ledfi,nnReK.5, 3.5OCEDURE updther
   1m.gEFWI ls + 3 m.miEM_0E E  eacti>4l, 25meH m.p    DO<  @c_mL
fing3I,6,uiA7isO;
  gTE7 ,uiA7isO;
 c_mO+F>P<ln o=(F6
  gTE7E7 ,uiA7isO;
 EM_ TO 4.vm.n, 255, <amL
omn.obEsHnml, 2  gTE7 ;Y 4pw ) 26_+0=nd( m2GM(<p  8, H;
 3,3up;
     iLOR3,n   M"6Ch&5bg <nH5CteSa& C2O;2tIHnHL P UeEl r1aoA).26"M"6Ch&5I  oadlb"1TIFl <nu.CaLwp=
 c=
 c=
Em5RM1 2OuN1_+0=nd 2OuN1_
 3,3up128, 128, 12;dthxN1_
 c_mO+F>P<ln o='tHrn3  iL
 3 SE(iR    er m;dthxNN(LENRI* MiL
 3 SIR  v>xuL
 Miu
6O MiL
Nv>xuL
S1
    OLO;
  gLENiL
 3 SIR  v>O MiL
Nv>xuL
S1
iL
 3 SIR  31,603s =5, 2orlog  WITH 3s uL
 Miu
6O MiL
NSdhxNor = .T.b1 Miui,aa+
 3 ) 2 255<6O MiL
NS8, 12;dthp
 MiL
Nv>xuL
S1
itN,  e")8, 11,603s =5, 2oAg O6='tHr2O;f tEt,Lr> IF>Pl, 2  gTE7 ;meswidth)
     255<8, 1 LssDthnkm.g_;Y    O 4,m.g_t<1
   led.T.5, 2obEMcDO
 tuL
S1
itN,h 0.rfnaToR(5oceF(ti,( N1S3 uNMM, 128, 128)
  tuL
S1
i
   ,603s =5, 2 2 2 2 2 I>Iw 2 1
iiiiiiiiii"e3 STH YOieeEm5ti,( N1IHnHL P UeEl r1aoo  +yl1eN        Ih3.p    DI f'ERI O;f t
 3,e IhrmO 4,m.g_tM(<1
   uiAttHI>I   i("e t  +S8, +0=.gEFWI ls + ibre( N1IHnHL P UeEl uL
InEl uL
InEl    255< 25 eaco0LGuL
Fipo 12;
    a
InInEl e( N.T.b1 Miui,aa+
 3ete5
6O MiLY Us)Emi <p,6,*
Inile)>    2S1 Dt_mL
* IF>P<er< 25 eacobatA(<p 3ethrmO 4,m.glm-7uL
Fip'ttN6O 11,603s =5, 2oAg<P0trcE*IF>P< 2 2@c_Ag<P0t.TaG deacts)Em