Black Box 4/BlackBox.cdr/dbase/computl2.arj/COMPALL2.PRG

Text File | 1991-06-27 | 17.2 KB | 653 lines

*************************************************************************
*      PROGRAM:            COMPALL2.PRG
*   WRITTEN BY:            James Thomas
* LAST CHANGED:            June 18, 1991 AT 10:29am
*************************************************************************
* This program creates source code to compile all .PRG
* files in a directory
*************************************************************************

* Set environment

SET TALK OFF
SET STATUS OFF
SET SAFETY OFF
SET TITLE OFF
SET SCOREBOARD OFF
CLEAR ALL
CLEAR

* Display program entry screen

CLEAR
@ 0,0 TO 24,79 DOUBLE
msg_txt = "COMPALL.PRG - dBase IV Source Code Compiling Program"
@ 11,Cntr(msg_txt) SAY msg_txt COLOR W+
msg_txt = "Charles County Government, Copyright (c) 1991"
@ 13,Cntr(msg_txt) SAY msg_txt COLOR W+
void = INKEY()
void = INKEY(6)
CLEAR

* Check for error conditions

IF Strstr("Runtime",VERSION())

    * Display error message

    ?? CHR(7)
    @ 0,0 TO 24,79 DOUBLE
    msg_txt = "COMPALL.PRG CANNOT Be Run From Runtime"
    @ 11,Cntr(msg_txt) SAY msg_txt COLOR W+
    msg_txt = "Re-run Program From dBase Dot Prompt"
    @ 13,Cntr(msg_txt) SAY msg_txt COLOR W+
    void = INKEY()
    void = INKEY(6)
    CLEAR

    * Reset environment and exit program

    SET TALK ON
    SET STATUS ON
    SET SAFETY ON
    SET TITLE ON
    SET SCOREBOARD ON
    RETURN
ENDIF

* Create database from extended structure file

DO Makedb

* Create database file containing program names

DO Create

* Build the source code program

DO Prg_bld

* Display messages, and define and activate a window before running
* generated source code.

DO Text_box WITH "C O M P I L I N G   P R O G R A M S",6,2
@ 17,Cntr("Directory--> " + SET("DIRECTORY")) SAY "Directory--> " + SET("DIRECTORY") COLOR W+
DEFINE WINDOW WINTEMP FROM 8,9 TO 15,67 DOUBLE COLOR N/W,N/W
ACTIVATE WINDOW WINTEMP

* Compile and run the generated program

COMPILE COMPRG$
DO COMPRG$

* Restore enviroment & erase program file

DEACTIVATE WINDOW WINTEMP
CLEAR
RELEASE WINDOW WINTEMP
RELEASE ALL
ERASE COMPRG$.PRG
ERASE COMPRG$.DBO
ERASE CATALOG.CAT
SET TALK ON
SET STATUS ON
SET SAFETY ON
SET TITLE ON
SET SCOREBOARD ON

RETURN
* ============= Procedures =========== *
PROCEDURE Create

    * Procedure to create program list

    * Clear screen and copy program files to text file using DOS command

    CLEAR
    !DIR *.PRG > PRG$.TXT

    DO Text_box WITH "C R E A T I N G   P R O G R A M   L I S T",12,2

    * Iniailize variables

    PRIVATE fname, ext
    STORE "" TO fname, ext

    * Append text from file

    APPEND FROM PRG$.TXT TYPE SDF

    * Erase temporary file

    ERASE PRG$.TXT

    * Delete unecessary lines

    DELETE FOR SUBSTR(ttext,10,3) # "PRG"
    PACK
    REPLACE ALL ttext WITH LEFT(ttext,12)
    GO TOP

    * Delete spaces from file names, and insert the COMPILE command

    DO WHILE .NOT. EOF()
        fname = LEFT(ttext,9)
        ext   = SUBSTR(ttext,10,3)

        * If one of the files is this program "COMPALL.PRG" or the file created by this program "COMPRG$.PRG",
        * do not compile

        IF TRIM(fname) # "COMPALL" .AND. TRIM(fname) # "COMPRG$"
            REPLACE ttext WITH "COMPILE " + TRIM(fname) + "." + ext
        ELSE
            REPLACE ttext WITH "*COMPILE " + TRIM(fname) + "." + ext
        ENDIF
        SKIP
    ENDDO
RETURN

PROCEDURE Makedb

    * Procedure to create a database for use with the file

    DO Text_box WITH "C R E A T I N G   D A T A B A S E",12,2

    * Erase extended structure file if it exists before
    * creating new structure file

    DO WHILE FILE("$TRUCFIL.DBF")
        ERASE $TRUCFIL.DBF
    ENDDO

    * Make new extended structure file

    void = Makestru("$TRUCFIL")

    * Append database information into $TRUCFIL.DBF

    USE $TRUCFIL
    APPEND BLANK
    REPLACE FIELD_NAME WITH "TTEXT"
    REPLACE FIELD_TYPE WITH "C"
    REPLACE FIELD_LEN  WITH 80
    REPLACE FIELD_DEC  WITH  0
    REPLACE FIELD_IDX  WITH "N"
    USE

    * Create database for source code creation

    CREATE PRG$TEMP FROM $TRUCFIL.DBF

    * Erase extended structure file

    ERASE $TRUCFIL.DBF

    * Open created database

    USE PRG$TEMP.DBF NOSAVE EXCLUSIVE
RETURN

PROCEDURE Prg_bld

    * Build program source code

    DO Text_box WITH "B U I L D I N G   S O U R C E   C O D E",12,2

    * Initialize variables

    PRIVATE a, line
    STORE 1 TO a, line

    * Array to store source code

    DECLARE Program[300,1]

    * Initialize array

    DO WHILE a # 301
        Program[a,1] = "VOID"
        a = a + 1
    ENDDO

    * Create program

    Program[ 1,1] = "********************************************************************************"
    Program[ 2,1] = "*        Program:   COMPPRG$.PRG"
    Program[ 3,1] = "*     Written By:   James Thomas, CCG Data Processing Dept. Copyright (c) 1991"
    Program[ 4,1] = "* Code Generated:   " + Ddate(DATE()) + " AT " + TIME()
    Program[ 5,1] = "********************************************************************************"
    Program[ 6,1] = "* Generated code to compile all .PRG files in a directory"
    Program[ 7,1] = "********************************************************************************"
    Program[ 8,1] = ""
    Program[ 9,1] = "* -- Initialization -- *"
    Program[10,1] = ""
    Program[11,1] = "CLEAR"
    Program[12,1] = "SET TALK ON"
    Program[13,1] = ""
    Program[14,1] = "* -- Compile Programs -- *"
    Program[15,1] = ""

    * Add source code from database

    * Initialize varible

    line = 16

    GO TOP
    DO WHILE .NOT. EOF() .AND. LEN(TRIM(ttext)) # 0

        * Build display line

        Program[line,1] = [? "Compiling--> " + ]
        comtmp = SUBSTR(TRIM(ttext),9,12)
        Program[line,1] = Program[line,1] + ["&comtmp."]
        line = line + 1

        * Build compile line

        Program[line,1] = TRIM(ttext)
        SKIP
        line = line + 1
    ENDDO

    * Continue with source code listing

     Program[line,1] = ""
    line = line + 1
    Program[line,1] = "* -- Reset environment -- *"
    line = line + 1
    Program[line,1] = ""
    line = line + 1
    Program[line,1] = "SET TALK OFF"
    line = line + 1
    Program[line,1] = "CLEAR"
    line = line + 1
    Program[line,1] = ""
    line = line + 1
    Program[line,1] = "RETURN"
    line = line + 1

    * Clear program file

    ZAP

    * Copy array data into program file

    APPEND FROM ARRAY Program FOR TRIM(ttext) # "VOID"

    * Copy database to program file, and erase database file

    COPY TO COMPRG$.PRG TYPE SDF
    USE

RETURN

PROCEDURE Text_box

    *********************************************************************
    * Text_box Program:   Draws a box around text on the line indicated *
    *                     by the user.                                  *
    *-------------------------------------------------------------------*
    * Example Of Usage:    STORE "This is some Text" TO string         *
    *                       STORE 12 TO line                *
    *            STORE 1  TO type                *
    *            DO Text_box WITH string,line,type           *
    *                                                                   *
    *    Type Options:    1 = Single Box                              *
    *            2 = Double Box                              *
    *                       3 = Panel Box                               *
    *        Any other number = Single Box                              *
    *********************************************************************

    * Establish Parameters

    PARAMETERS str,lno,typ

    CLEAR
    * Declare variables

    PRIVATE msgline,lineno,bxtype

    * Store parameter to variable

    msgline = str
    lineno  = lno
    bxtype  = typ

    * If 1st parameter passed was not a string, convert to string

    IF TYPE("msgline") = "N"
        msgline = LTRIM(STR(msgline))
    ENDIF

    IF TYPE("msgline") = "D"
        msgline = DTOC(msgline)
    ENDIF

    * If 2nd parameter passed was not a number, convert to number

    IF TYPE("lineno") = "C"
        lineno = VAL(lineno)
    ENDIF

    * If 3rd parameter passed was not a number, convert to number

    IF TYPE("bxtype") = "C"
        bxtype = VAL(bxtype)
    ENDIF

    * If value is not character, return error message

    IF TYPE("msgline") # "C" .OR. TYPE("lineno") # "N" .OR. TYPE("bxtype") # "N"
        ?? CHR(7)
        ?? "Invalid Value Passed To Text_box"
        RETURN
    ENDIF

    * If lenghth of text is greater than 80 (width of screen), return error message
    IF LEN(msgline) > 74
        ?? CHR(7)
        ?? "String Passed To Text_box Is Too Long"
        RETURN
    ENDIF

    * Draw Box and print text

    * Initialize variables

    PRIVATE up_lft,l_rght,bxapp

    STORE "" TO up_lft, l_rght, bxapp

    * Assign values to variables

    * Determine box type

    DO CASE
        CASE bxtype = 2
            STORE "DOUBLE" TO bxapp
        CASE bxtype = 3
            STORE "PANEL"  TO bxapp
        OTHERWISE
            STORE "" TO bxapp
    ENDCASE

    * If the line number coordinate exceeds screen boundaries, reassign the cooridinate

    lineno = IIF(lineno<=0,1,lineno)

    IF SET("STATUS") = "ON"
        lineno = IIF(lineno>=21,20,lineno)
    ELSE
        lineno = IIF(lineno>=24,23,lineno)
    ENDIF

    * Row coordinate

    up_lft = LTRIM(STR(lineno-1))
    l_rght = LTRIM(STR(lineno+1))

    * Column coordinate

    up_lft = up_lft + "," + LTRIM(STR(INT(Cntr(msgline))-2))
    l_rght = l_rght + "," + LTRIM(STR(INT(Cntr(msgline))+(LEN(msgline)+1)))

    * Draw box and display text

    @ &up_lft. TO &l_rght. &bxapp.
    @ lineno,Cntr(msgline) SAY msgline    COLOR W+

RETURN

* ============= Functions ============ *

*****************************************************************************************
* PROGRAM NAME:            CNTR.PRG
*                Centering Function
* LAST CHANGED:            March 18, 1991 AT 10:55am
*****************************************************************************************
* This file contains functions to be used in dBase IV programs.
*****************************************************************************************

*****************************************************************
* Cntr Function:  Returns position to center text on the screen *
*---------------------------------------------------------------*
* Example Of Usage:    STORE "This is some Text" TO string     *
*            @ 10,Cntr(string) SAY string            *
*****************************************************************

FUNCTION Cntr

    * Establish Parameters

    PARAMETERS str

    * Declare variables

    PRIVATE msgline

    * Store parameter to variable

    msgline = str

    * If parameter passed was not a string, convert to string

    IF TYPE("msgline") = "N"
        msgline = LTRIM(STR(msgline))
    ENDIF

    * If value is not character, return error message

    IF TYPE("msgline") <> "C"
        ?? CHR(7)
        ?? "Invalid Value Passed To Function Cntr"
        RETURN 1
    ENDIF

    * If lenghth of text is greater than 80 (width of screen), return 1 as starting position

    IF LEN(msgline) > 80
        RETURN 1
    ENDIF

    * Return Value of 40 minus half of the length of the string

RETURN 39-LEN(msgline)/2

*****************************************************************************************
* PROGRAM NAME:            DDATE.PRG
*                Date Function
* LAST CHANGED:            March 18, 1991 AT 11:28am
* WRITTEN BY:            James Thomas
*****************************************************************************************
* This file contains functions to be used in dBase IV programs.
*****************************************************************************************

*******************************************************************
* Ddate Function:  Returns Tuesday, October 9, 1990 from 10/09/90 *
*-----------------------------------------------------------------*
* Example Of Usage:    ?Ddate(DATE())                            *
*        OR    @1,1 SAY Ddate({01/01/90})                *
*******************************************************************

FUNCTION Ddate

    * Function to return the long display date from the system date.

    PARAMETERS dte

    * Establish variables

    PRIVATE d_date

    * Store parameter to variable

    d_date = dte

    * Test to see that a date was passed, if character convert to date.

    IF TYPE("d_date") = "C"
        d_date = CTOD(d_date)
    ENDIF

    * If value is not now a date, return error message

    IF TYPE("d_date") <> "D" .OR. d_date = {}
        ?? CHR(7)
        RETURN "Invalid Value Passed To Function Ddate"
    ENDIF

    * Construct long form date to be returned.

    IF SUBSTR(DTOC(d_date),4,1) <> "0"

        RETURN CDOW(d_date) + ", " + CMONTH(d_date) + " " + SUBSTR(DTOC(d_date),4,2) + ", " + LTRIM(STR(YEAR(d_date)))
    ENDIF
        RETURN CDOW(d_date) + ", " + CMONTH(d_date) + " " + SUBSTR(DTOC(d_date),5,1) + ", " + LTRIM(STR(YEAR(d_date)))

*************************************************************************
*      PROGRAM:            MAKESTRU.PRG
*   WRITTEN BY:            Martin Leon AKA Hman (A-T BBS)
* LAST CHANGED:            June 12, 1991 AT 8:02am
*************************************************************************
* This procedure creates a database structure.
*************************************************************************
FUNCTION Makestru

    * Establish paramters

    PARAMETER struname

    * Check to see that file does not already exist

    IF FILE(struname)
        RETURN .F.
    ENDIF

    * Create new catalog file

    newcat = "TMP" + LTRIM(STR(RAND(0)*100000,5)) + ".CAT"
    DO WHILE FILE(newcat)
        newcat = "TMP" + LTRIM(STR(RAND(0)*100000,5)) + ".CAT"
    ENDDO

    KEYBOARD CHR(13)
    SET CATALOG TO (newcat)
    SET CATALOG TO
    USE (newcat) NOSAVE
    COPY STRUCTURE EXTENDED TO (struname)
    USE(struname) EXCLUSIVE
    ZAP
    USE

RETURN .T.

*****************************************************************************************
* PROGRAM NAME:            STRSTR.PRG
*                String Searcing Function
* LAST CHANGED:            May 8, 1991 AT 7:27am
* WRITTEN BY:            James Thomas
*****************************************************************************************
* This file contains functions to be used in dBase IV programs.
*****************************************************************************************

***************************************************************************************
* Strstr Function:    Searches for a substring within a string, and returns true or *
*            false.  Character Or Numeric Data Can Be Passed               *
*            Recommened for searches of an array.
*-------------------------------------------------------------------------------------*
* Example Of Usage:    ?Strstr("ond","Monday") -> Returns .T.
*
*        OR    STORE "ond"    TO sub
*            STORE "Monday"    TO str
*            IF Strstr(sub,str)
*                ? str
*            ENDIF
**************************************************************************************

FUNCTION Strstr

    ***********************************************************
    * Establish Parameters                                    *
    *---------------------------------------------------------*
    * SUBSTR -  The substring to search for within the string *
    * STRING -  The string to be searched for the substring   *
    ***********************************************************

    PARAMETERS sub, str

    ***********************************************************
    * Establish variables                                     *
    *---------------------------------------------------------*
    * sublen -  Used to store the length of the substring.    *
    * strlen -  Used to store the length of the string.       *
    * pend   -  Used to store the ending search position.     *
    * pos    -  Used to store the current search postion.     *
    ***********************************************************

    PRIVATE sublen, strlen, pend, pos, substr, string

    ***********************************************************
    * Store parameters to variables                           *
    ***********************************************************

    substr = sub
    string = str

    ************************************************************
    * If numeric expressions were passed, convert to character *
    * expressions.                                             *
    ************************************************************

    ************************
    * Substring conversion *
    ************************

    IF TYPE("substr") = "N"
        substr = LTRIM(STR(substr))
    ENDIF

    *********************
    * String Conversion *
    *********************

    IF TYPE("string") = "N"
        string = LTRIM(STR(string))
    ENDIF

    *********************************************************
    * Return error message if either substring or string    *
    * are non numeric.  Indicates invalid data type passed. *
    *********************************************************

    IF TYPE("substr") <> "C" .OR. TYPE("string") <> "C"
        ?? CHR(7)
        ?? "Invalid Value Passed To Function Strstr"
        RETURN .F.
    ENDIF

    *****************
    * Set variables *
    *****************

    sublen = LEN(substr)        && Length of substring
    strlen = LEN(string)        && Lenght of string
    pend   = strlen - sublen    && Ending search position
    pos   = 1            && Beginning Search Position
    substr = TRIM(substr)        && Trim trailing spaces from substring

    **************************************************************
    * Search Procedure, Infinite loop is executed. If substring  *
    * is found, .T. is returned.  If substring is not found, and *
    * the pos counter exceeds the pend counter, .F. is returned. *
    **************************************************************

    DO WHILE pos <= (pend+1)
        IF UPPER(SUBSTR(string,pos,sublen)) = UPPER(substr)    && Make comparison
            RETURN .T.                    && Return True if substrings match
        ENDIF
        pos = pos + 1                        && Increment position counter
    ENDDO

RETURN .F.                                && Return False if substring is not found