#!/bin/sh
#
# This is a shell archive.  To extract its contents,
# execute this file with /bin/sh to create the file(s):
#
# Makefile	    i_equip.4gl		lu_equip.4gl	    o_equip.per
# README		    i_equip.hlp		lu_equip.per	    recursive.ec
# equipment.sql	    i_equip.per		o_equip.4gl	    usr_funcs.c
# equipment.unl	    i_equipb.per	o_equip.hlp
#
# This shell archive created: Sun Feb 11 14:38:19 EST 1996
#
echo "Extracting file Makefile"
sed -e 's/^X//' <<\SHAR_EOF > Makefile
X# Makefile - makefile for executable i_equip (i_equip.4ge)
X# Copyright (C) 1995  David A. Snyder  All Rights Reserved
X
X
XCFLAGS=-c -O
XLDFLAGS=-s
X
X
X################################################################################
X# Dependencies for creating the complete working screen.                       #
X################################################################################
X
Xall: i_equip.4ge i_equip.frm i_equipb.frm i_equip.msg o_equip.4ge o_equip.frm \
X     o_equip.msg lu_equip.frm
X
X
X################################################################################
X# Dependencies for creating individual executable, form, and help files.       #
X################################################################################
X
Xi_equip.4ge: i_equip.o lu_equip.o recursive.o usr_funcs.o
X	c4gl i_equip.o lu_equip.o recursive.o usr_funcs.o \
X	  $(LDFLAGS) -o i_equip.4ge
X
Xi_equip.frm: i_equip.per
X	form4gl -s i_equip.per
X
Xi_equipb.frm: i_equipb.per
X	form4gl -s i_equipb.per
X
Xi_equip.msg: i_equip.hlp
X	mkmessage i_equip.hlp i_equip.msg
X
Xo_equip.4ge: o_equip.o lu_equip.o recursive.o usr_funcs.o
X	c4gl o_equip.o lu_equip.o recursive.o usr_funcs.o \
X	  $(LDFLAGS) -o o_equip.4ge
X
Xo_equip.frm: o_equip.per
X	form4gl -s o_equip.per
X
Xo_equip.msg: o_equip.hlp
X	mkmessage o_equip.hlp o_equip.msg
X
Xlu_equip.frm: lu_equip.per
X	form4gl -s lu_equip.per
X
X
X################################################################################
X# Dependencies for creating executable's modules.                              #
X################################################################################
X
Xi_equip.o: i_equip.4gl
X	c4gl $(CFLAGS) i_equip.4gl
X	@rm -f i_equip.c i_equip.ec
X
Xo_equip.o: o_equip.4gl
X	c4gl $(CFLAGS) o_equip.4gl
X	@rm -f o_equip.c o_equip.ec
X
Xlu_equip.o: lu_equip.4gl
X	c4gl $(CFLAGS) lu_equip.4gl
X	@rm -f lu_equip.c lu_equip.ec
X
Xrecursive.o: recursive.ec
X	c4gl $(CFLAGS) recursive.ec
X	@rm -f recursive.c
X
X
X################################################################################
X# Dependency for cleaning up when all done.                                    #
X################################################################################
X
Xclean:
X	rm -f i_equip.4ge i_equip.o i_equip.frm i_equipb.frm i_equip.msg \
X	  o_equip.4ge o_equip.o o_equip.frm lu_equip.o lu_equip.frm \
X	  o_equip.msg recursive.o usr_funcs.o report.out
SHAR_EOF
if [ `wc -c < Makefile` -ne     2358 ]
then
    echo "Lengths do not match -- Bad Copy of Makefile"
fi
echo "Extracting file README"
sed -e 's/^X//' <<\SHAR_EOF > README
XFrom: dave@nfs.ee.vill.edu (Dave Snyder)
XSubject: Recursion
XTo: informix-list@rmy.emory.edu (INFORMIX Mailing list)
XDate: Mon, 4 Dec 1995 08:12:31 -0500 (EST)
X
XSeveral people have asked me for my examples of true recursion in 4GL.  One
Xeven suggested posting it to the list so it gets auto-archived at Emory.
X
XAnyway, I'm not into giving out proprietary code so this past weekend I
Xwhipped up this little demo.  If you don't already have the "stores" database
Xon your system, create it.  Build the "equipment" table by typing the
Xfollowing:
X  dbaccess stores equipment.sql
X
XAfter the table is built and loaded, compile the program by typing:
X  make
X
XThat's all there is to it.  RDS only people, you'll have to build a custom
Xrunner for this sucker.  Grab my "db4glgen" program for help in making it.
X
XThe i_equip.4ge program is fully functional.  It can do Queries, Adds,
XUpdates, Removes, Lookups, and a whole bunch of other stuff.  The program
Xrelies on the constraints attached to the equipment table for data validation.
XThe only data validation the program does itself is for recursive loops.
X(Someone want to help me write a trigger :-)
X
XThe o_equip.4ge program is a simple report program.  Provide an id along with
Xthe direction you want to go and it dumps the explosion (or implosion?) to a
Xfile called "report.out".
X
XI've documented the ESQL/C recursion routines somewhat.  It may look messy
Xbut there's nothing really complicated going on (remember I'm NOT a regular C
Xprogrammer).  I've documented the recursive loop routine extensively.  If it
Xsounds complicated, that's because it is!
X
XIf you have any questions, send me email.  If you have some suggestions,
Xplease let me know about them.  Enjoy!
SHAR_EOF
if [ `wc -c < README` -ne     1711 ]
then
    echo "Lengths do not match -- Bad Copy of README"
fi
echo "Extracting file equipment.sql"
sed -e 's/^X//' <<\SHAR_EOF > equipment.sql
X-- equipment.sql - SQL script for creating "equipment" table and loading it
X-- Copyright (C) 1995  David A. Snyder  All Rights Reserved
X
X
XCREATE TABLE equipment
X  (
X    eq_id SERIAL NOT NULL,
X    eqp_name CHAR(20),
X    parent_eq_id INTEGER,
X    PRIMARY KEY (eq_id) CONSTRAINT pk_eqid,
X    UNIQUE (eqp_name) CONSTRAINT u_eqpname,
X    CHECK (eq_id != parent_eq_id) CONSTRAINT eqid_ne_peqid
X  );
X
XALTER TABLE equipment ADD CONSTRAINT
X  (FOREIGN KEY (parent_eq_id) REFERENCES equipment CONSTRAINT fk_peqid);
X
XLOAD FROM "equipment.unl" INSERT INTO equipment;
SHAR_EOF
if [ `wc -c < equipment.sql` -ne      554 ]
then
    echo "Lengths do not match -- Bad Copy of equipment.sql"
fi
echo "Extracting file equipment.unl"
sed -e 's/^X//' <<\SHAR_EOF > equipment.unl
X1|PUMP-P11||
X2|FIRE EXTINGUSHER-F12||
X3|TELEPHONE-T13||
X4|SEAL-S24|1|
X5|HOSE-H25|2|
X6|RECEIVER-R26|3|
X7|VALVE-V27|1|
X8|GAUGE-G28|2|
X9|CORD-C29|3|
X10|MOTOR-M210|1|
X11|SHAFT-S311|10|
X12|NEEDLE-N312|8|
X13|SPEAKER-S313|6|
X14|WINDING-W314|10|
X15|MICROPHONE-M315|6|
X16|BRUSH-B316|10|
SHAR_EOF
if [ `wc -c < equipment.unl` -ne      278 ]
then
    echo "Lengths do not match -- Bad Copy of equipment.unl"
fi
echo "Extracting file i_equip.4gl"
sed -e 's/^X//' <<\SHAR_EOF > i_equip.4gl
X# i_equip.4gl - 4GL source for executable i_equip (i_equip.4ge)
X# Copyright (C) 1995  David A. Snyder  All Rights Reserved
X
X# Created by: db4glgen, v4.00 95/05/16 09:04:17
X
X
XDATABASE stores
X
X
XDEFINE  w_record RECORD LIKE equipment.*          # working record
XDEFINE  s_record RECORD LIKE equipment.*          # saving record
XDEFINE  n_record RECORD LIKE equipment.*          # null record
XDEFINE  q_cnt INTEGER                            # current size of list
XDEFINE  q_cur INTEGER                            # index position in list
XDEFINE  q_off CHAR(10)                           # offset to jump 'n' rows
XDEFINE  brw_scrline SMALLINT                         # line number in browse
X
XDEFINE  parent_eqp_name LIKE equipment.eqp_name
X
X
X{*******************************************************************************
X* This program drives the equipment screen.
X*******************************************************************************}
X
XMAIN
X    DEFER INTERRUPT
X    CALL menu_equipment()
X    CLEAR SCREEN
XEND MAIN
X
X
X{*******************************************************************************
X* This function handles the main ring menu.                                    *
X*******************************************************************************}
X
XFUNCTION menu_equipment()
X    CALL init_equipment()
X
X    OPEN FORM i_equip FROM "i_equip"
X    DISPLAY FORM i_equip
X
X    MENU "OPTIONS"
X        COMMAND "Query" "Searches the active database table." HELP 1
X            CALL qry_equipment()
X            CALL disp_equipment()
X        COMMAND "Browse" "Browse through rows in the Current List." HELP 1
X            IF repo_equipment("C", "B") THEN
X                CALL brw_equipment()
X                CALL disp_equipment()
X            END IF
X        COMMAND "Next" "Shows the next row in the Current List." HELP 1
X            IF repo_equipment("N", "S") THEN
X                CALL disp_equipment()
X            END IF
X        COMMAND "Previous" "Shows the previous row in the Current List." HELP 1
X            IF repo_equipment("P", "S") THEN
X                CALL disp_equipment()
X            END IF
X        COMMAND "First" "Shows the first row in the Current List." HELP 1
X            IF repo_equipment("F", "S") THEN
X                CALL disp_equipment()
X            END IF
X        COMMAND "Last" "Shows the last row in the Current List." HELP 1
X            IF repo_equipment("L", "S") THEN
X                CALL disp_equipment()
X            END IF
X        COMMAND "Add" "Adds a row to the active database table." HELP 1
X            CALL add_equipment()
X            CALL disp_equipment()
X        COMMAND "Update" "Changes a row in the active database table." HELP 1
X            IF repo_equipment("C", "U") THEN
X                CALL upd_equipment()
X            END IF
X            CALL disp_equipment()
X        COMMAND "Remove" "Deletes a row in the active database table." HELP 1
X            IF repo_equipment("C", "U") THEN
X                CALL del_equipment()
X            END IF
X            CALL disp_equipment()
X        COMMAND "Current" "Displays the current row of the current table." HELP 1
X            IF repo_equipment("C", "S") THEN
X                CALL disp_equipment()
X            END IF
X        COMMAND "Exit" "Returns to the INFORMIX-SQL menu." HELP 1
X            EXIT MENU
X        COMMAND KEY (CONTROL-G)
X            CALL fgl_prtscr()
X        COMMAND KEY ("0")
X            WHENEVER ERROR CONTINUE
X            LET q_off = q_off CLIPPED, "0"
X            WHENEVER ERROR STOP
X        COMMAND KEY ("1")
X            WHENEVER ERROR CONTINUE
X            LET q_off = q_off CLIPPED, "1"
X            WHENEVER ERROR STOP
X        COMMAND KEY ("2")
X            WHENEVER ERROR CONTINUE
X            LET q_off = q_off CLIPPED, "2"
X            WHENEVER ERROR STOP
X        COMMAND KEY ("3")
X            WHENEVER ERROR CONTINUE
X            LET q_off = q_off CLIPPED, "3"
X            WHENEVER ERROR STOP
X        COMMAND KEY ("4")
X            WHENEVER ERROR CONTINUE
X            LET q_off = q_off CLIPPED, "4"
X            WHENEVER ERROR STOP
X        COMMAND KEY ("5")
X            WHENEVER ERROR CONTINUE
X            LET q_off = q_off CLIPPED, "5"
X            WHENEVER ERROR STOP
X        COMMAND KEY ("6")
X            WHENEVER ERROR CONTINUE
X            LET q_off = q_off CLIPPED, "6"
X            WHENEVER ERROR STOP
X        COMMAND KEY ("7")
X            WHENEVER ERROR CONTINUE
X            LET q_off = q_off CLIPPED, "7"
X            WHENEVER ERROR STOP
X        COMMAND KEY ("8")
X            WHENEVER ERROR CONTINUE
X            LET q_off = q_off CLIPPED, "8"
X            WHENEVER ERROR STOP
X        COMMAND KEY ("9")
X            WHENEVER ERROR CONTINUE
X            LET q_off = q_off CLIPPED, "9"
X            WHENEVER ERROR STOP
X        COMMAND KEY ("!")
X            CALL bang()
X    END MENU
X    CLOSE FORM i_equip
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function initializes options and variables.                             *
X*******************************************************************************}
X
XFUNCTION init_equipment()
X    OPTIONS HELP FILE "i_equip.msg"
X    OPTIONS INPUT WRAP
X    OPTIONS MESSAGE LINE LAST
X    OPTIONS PROMPT LINE LAST
X
X    INITIALIZE n_record.* TO NULL
X    LET w_record.* = n_record.*   # Faster than INITIALIZE
X
X    IF i_rowid_s() THEN
X        ERROR " Memory allocation error, out of memory  "
X        EXIT PROGRAM
X    END IF
X
X    LET q_cnt = 0
X    LET q_cur = 0
X    LET q_off = "0"
X
X    PREPARE brw_stmt FROM
X      "SELECT eq_id, eqp_name FROM equipment WHERE ROWID = ?"
X    DECLARE brw_curs CURSOR FOR brw_stmt
X
X    PREPARE std_stmt FROM
X      "SELECT * FROM equipment WHERE ROWID = ?"
X    DECLARE std_curs CURSOR FOR std_stmt
X
X    PREPARE upd_stmt FROM
X      "SELECT * FROM equipment WHERE ROWID = ? FOR UPDATE"
X    DECLARE upd_curs CURSOR FOR upd_stmt
X
X    CREATE TEMP TABLE eqpweb
X      (seq SERIAL, id INTEGER NOT NULL, direction CHAR(1), level SMALLINT)
X     WITH NO LOG
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function will query the database table.                                 *
X*******************************************************************************}
X
XFUNCTION qry_equipment()
X    DEFINE  q_txt CHAR(512)
X    DEFINE  the_rowid INTEGER
X    DEFINE  retval SMALLINT
X
X    DISPLAY "QUERY:  ESCAPE queries.  INTERRUPT discards query.  ARROW keys move cursor.", "" AT 1,1
X    DISPLAY "Searches the active database table.", "" AT 2,1
X    MESSAGE ""
X
X    LET s_record.* = w_record.*
X
X    CLEAR FORM
X    LET int_flag = FALSE
X    CONSTRUCT BY NAME q_txt ON
X      equipment.eq_id,
X      equipment.eqp_name,
X      equipment.parent_eq_id
X     HELP 2
X        ON KEY (CONTROL-B)
X            NEXT FIELD PREVIOUS
X        ON KEY (CONTROL-E)
X            CALL ctrl_e_equipment()
X            NEXT FIELD NEXT
X        ON KEY (CONTROL-F)
X            NEXT FIELD NEXT
X        ON KEY (CONTROL-G)
X            CALL fgl_prtscr()
X        ON KEY (CONTROL-P)
X            CALL ctrl_p_equipment()
X            NEXT FIELD NEXT
X    END CONSTRUCT
X
X    IF int_flag THEN
X        RETURN
X    END IF
X
X    LET q_txt = "SELECT rowid, eq_id FROM equipment WHERE ", q_txt CLIPPED, " ORDER BY eq_id"
X
X    WHENEVER ERROR CONTINUE
X    OPTIONS SQL INTERRUPT ON
X    MESSAGE "Searching ..."
X
X    PREPARE q_sid FROM q_txt
X    IF sqlca.sqlcode THEN
X        CALL err_print(sqlca.sqlcode)
X        OPTIONS SQL INTERRUPT OFF
X        WHENEVER ERROR STOP
X        RETURN
X    END IF
X
X    DECLARE q_curs CURSOR FOR q_sid
X    IF sqlca.sqlcode THEN
X        CALL err_print(sqlca.sqlcode)
X        OPTIONS SQL INTERRUPT OFF
X        WHENEVER ERROR STOP
X        RETURN
X    END IF
X
X    LET q_cnt = 0
X    FOREACH q_curs INTO the_rowid
X        IF s_rowid_s(q_cnt + 1) THEN
X            ERROR " Memory allocation error, out of memory  "
X            OPTIONS SQL INTERRUPT OFF
X            WHENEVER ERROR STOP
X            RETURN
X        END IF
X        LET q_cnt = q_cnt + 1
X        CALL w_rowid_s(q_cnt, the_rowid)
X
X        IF int_flag THEN
X            EXIT FOREACH
X        END IF
X    END FOREACH
X
X    OPTIONS SQL INTERRUPT OFF
X    WHENEVER ERROR STOP
X
X    MESSAGE ""
X    IF int_flag THEN
X        ERROR " Statement interrupted by user  "
X        SLEEP 1
X    END IF
X
X    IF q_cnt > 0 THEN
X        LET q_cur = 1
X        LET retval = repo_equipment("C", "S")
X    ELSE
X        LET q_cur = 0
X        LET w_record.* = n_record.*   # Faster than INITIALIZE
X        ERROR " There are no rows satisfying the conditions  "
X    END IF
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function browses through the current list.                              *
X*******************************************************************************}
X
XFUNCTION brw_equipment()
X    DEFINE  s_cur INTEGER                            # saving index position
X    DEFINE  keyhit INTEGER
X    DEFINE  retval SMALLINT
X
X    DISPLAY "BROWSE:  ESCAPE selects data.  INTERRUPT aborts.  ARROW keys move cursor.", "" AT 1,1
X    DISPLAY "Browse through rows in the Current List.", "" AT 2,1
X
X    OPEN WINDOW browse AT 4,10 WITH FORM "i_equipb"
X      ATTRIBUTES(BORDER, FORM LINE FIRST + 1)
X
X    LET s_cur = q_cur
X    CALL brw_dsppage_equipment()
X
X    OPTIONS HELP KEY CONTROL-Q
X    WHILE (TRUE)
X        LET keyhit = fgl_getkey()
X        CASE
X            WHEN keyhit = fgl_keyval("ACCEPT")
X                EXIT WHILE
X            WHEN keyhit = fgl_keyval("INTERRUPT")
X                LET q_cur = s_cur
X                EXIT WHILE
X            WHEN keyhit = fgl_keyval("DOWN") OR keyhit = fgl_keyval("RIGHT")
X                CALL brw_down_equipment()
X            WHEN keyhit = fgl_keyval("UP") OR keyhit = fgl_keyval("LEFT")
X                CALL brw_up_equipment()
X            WHEN keyhit = fgl_keyval("F3")     # NEXT KEY
X                CALL brw_nextpage_equipment()
X            WHEN keyhit = fgl_keyval("F4")     # PREVIOUS KEY
X                CALL brw_prevpage_equipment()
X            WHEN keyhit = fgl_keyval("CONTROL-G")
X                CALL fgl_prtscr()
X            WHEN keyhit = fgl_keyval("0") OR
X                 keyhit = fgl_keyval("1") OR
X                 keyhit = fgl_keyval("2") OR
X                 keyhit = fgl_keyval("3") OR
X                 keyhit = fgl_keyval("4") OR
X                 keyhit = fgl_keyval("5") OR
X                 keyhit = fgl_keyval("6") OR
X                 keyhit = fgl_keyval("7") OR
X                 keyhit = fgl_keyval("8") OR
X                 keyhit = fgl_keyval("9")
X                WHENEVER ERROR CONTINUE
X                LET q_off = q_off CLIPPED, ASCII keyhit
X                WHENEVER ERROR STOP
X            OTHERWISE
X                ERROR ""
X                LET q_off = "0"
X        END CASE
X    END WHILE
X    OPTIONS HELP KEY CONTROL-W
X
X    LET retval = repo_equipment("C", "S")
X
X    CLOSE WINDOW browse
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function adds a row to the database table.                              *
X*******************************************************************************}
X
XFUNCTION add_equipment()
X    DEFINE  the_rowid INTEGER
X
X    DISPLAY "ADD:  ESCAPE adds new data.  INTERRUPT discards it.  ARROW keys move cursor.", "" AT 1,1
X    DISPLAY "Adds new data to the active database table.", "" AT 2,1
X    MESSAGE ""
X
X    LET s_record.* = w_record.*
X    LET w_record.* = n_record.*   # Faster than INITIALIZE
X
X    CLEAR parent_eqp_name
X
X    LET int_flag = FALSE
X    OPTIONS HELP KEY CONTROL-Q
X    INPUT BY NAME
X      w_record.eq_id,
X      w_record.eqp_name,
X      w_record.parent_eq_id
X     HELP 2
X        BEFORE FIELD eq_id
X            CALL reverse_on_equipment()
X        AFTER FIELD eq_id
X            CALL reverse_off_equipment()
X        BEFORE FIELD eqp_name
X            CALL reverse_on_equipment()
X        AFTER FIELD eqp_name
X            CALL reverse_off_equipment()
X        BEFORE FIELD parent_eq_id
X            CALL reverse_on_equipment()
X        AFTER FIELD parent_eq_id
X            CALL reverse_off_equipment()
X            LET parent_eqp_name = NULL
X            SELECT eqp_name INTO parent_eqp_name
X              FROM equipment WHERE eq_id = w_record.parent_eq_id
X            DISPLAY BY NAME parent_eqp_name
X        ON KEY (CONTROL-B)
X            CALL reverse_off_equipment()
X            NEXT FIELD PREVIOUS
X        ON KEY (CONTROL-E)
X            CALL reverse_off_equipment()
X            CALL ctrl_e_equipment()
X            NEXT FIELD NEXT
X        ON KEY (CONTROL-F)
X            CALL reverse_off_equipment()
X            NEXT FIELD NEXT
X        ON KEY (CONTROL-G)
X            CALL fgl_prtscr()
X        ON KEY (CONTROL-P)
X            CALL reverse_off_equipment()
X            CALL ctrl_p_equipment()
X            NEXT FIELD NEXT
X        ON KEY (CONTROL-W)
X            CALL help_equipment()
X        ON KEY (INTERRUPT)
X            EXIT INPUT
X    END INPUT
X    OPTIONS HELP KEY CONTROL-W
X
X    IF int_flag THEN
X        LET w_record.* = s_record.*
X        RETURN
X    END IF
X
X    WHENEVER ERROR CONTINUE
X
X    LET w_record.eq_id = 0
X    INSERT INTO equipment VALUES (w_record.*)
X    IF sqlca.sqlcode THEN
X        CALL err_print(sqlca.sqlcode)
X        LET w_record.* = s_record.*
X        WHENEVER ERROR STOP
X        RETURN
X    END IF
X    LET w_record.eq_id = sqlca.sqlerrd[2]
X    LET the_rowid = sqlca.sqlerrd[6]
X
X    DISPLAY BY NAME w_record.eq_id
X
X    IF s_rowid_s(q_cnt + 1) THEN
X        ERROR " Memory allocation error, out of memory  "
X        LET w_record.* = s_record.*
X        WHENEVER ERROR STOP
X        RETURN
X    END IF
X    LET q_cnt = q_cnt + 1
X
X    WHENEVER ERROR STOP
X
X    LET q_cur = q_cnt
X    CALL w_rowid_s(q_cur, the_rowid)
X
X    MESSAGE "Row added"
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function will update the current row.                                   *
X*******************************************************************************}
X
XFUNCTION upd_equipment()
X    DISPLAY "UPDATE:  ESCAPE changes data.  INTERRUPT discards changes.  ARROW keys move.", "" AT 1,1
X    DISPLAY "Changes this row in the active database table.", "" AT 2,1
X    MESSAGE ""
X
X    LET s_record.* = w_record.*
X
X    LET int_flag = FALSE
X    OPTIONS HELP KEY CONTROL-Q
X    INPUT BY NAME
X      w_record.eq_id,
X      w_record.eqp_name,
X      w_record.parent_eq_id
X     WITHOUT DEFAULTS HELP 2
X        BEFORE FIELD eq_id
X            CALL reverse_on_equipment()
X        AFTER FIELD eq_id
X            CALL reverse_off_equipment()
X        BEFORE FIELD eqp_name
X            CALL reverse_on_equipment()
X        AFTER FIELD eqp_name
X            CALL reverse_off_equipment()
X        BEFORE FIELD parent_eq_id
X            CALL reverse_on_equipment()
X        AFTER FIELD parent_eq_id
X            CALL reverse_off_equipment()
X            LET parent_eqp_name = NULL
X            SELECT eqp_name INTO parent_eqp_name
X              FROM equipment WHERE eq_id = w_record.parent_eq_id
X            DISPLAY BY NAME parent_eqp_name
X            IF recursive_loop() THEN
X                NEXT FIELD parent_eq_id
X            END IF
X        ON KEY (CONTROL-B)
X            CALL reverse_off_equipment()
X            NEXT FIELD PREVIOUS
X        ON KEY (CONTROL-E)
X            CALL reverse_off_equipment()
X            CALL ctrl_e_equipment()
X            NEXT FIELD NEXT
X        ON KEY (CONTROL-F)
X            CALL reverse_off_equipment()
X            NEXT FIELD NEXT
X        ON KEY (CONTROL-G)
X            CALL fgl_prtscr()
X        ON KEY (CONTROL-P)
X            CALL reverse_off_equipment()
X            CALL ctrl_p_equipment()
X            NEXT FIELD NEXT
X        ON KEY (CONTROL-W)
X            CALL help_equipment()
X        ON KEY (INTERRUPT)
X            EXIT INPUT
X    END INPUT
X    OPTIONS HELP KEY CONTROL-W
X
X    IF int_flag THEN
X        CLOSE upd_curs
X        IF sqlca.sqlcode THEN
X            CALL err_print(sqlca.sqlcode)
X        END IF
X        LET w_record.* = s_record.*
X        RETURN
X    END IF
X
X    WHENEVER ERROR CONTINUE
X
X    UPDATE equipment SET equipment.* = w_record.* WHERE CURRENT OF upd_curs
X    IF sqlca.sqlcode THEN
X        CALL err_print(sqlca.sqlcode)
X        CLOSE upd_curs
X        IF sqlca.sqlcode THEN
X            CALL err_print(sqlca.sqlcode)
X        END IF
X        LET w_record.* = s_record.*
X        WHENEVER ERROR STOP
X        RETURN
X    END IF
X
X    CLOSE upd_curs
X    IF sqlca.sqlcode THEN
X        CALL err_print(sqlca.sqlcode)
X        WHENEVER ERROR STOP
X        RETURN
X    END IF
X
X    WHENEVER ERROR STOP
X
X    MESSAGE "This row has been changed"
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function will delete the current row.                                   *
X*******************************************************************************}
X
XFUNCTION del_equipment()
X    MENU "REMOVE"
X        COMMAND "No" "Does NOT remove this row from the active table." HELP 3
X            CLOSE upd_curs
X            IF sqlca.sqlcode THEN
X                CALL err_print(sqlca.sqlcode)
X            END IF
X            RETURN
X        COMMAND "Yes" "Removes this row from the active table." HELP 3
X            EXIT MENU
X        COMMAND KEY (CONTROL-G)
X            CALL fgl_prtscr()
X    END MENU
X
X    WHENEVER ERROR CONTINUE
X
X    DELETE FROM equipment WHERE CURRENT OF upd_curs
X    IF sqlca.sqlcode THEN
X        CALL err_print(sqlca.sqlcode)
X        CLOSE upd_curs
X        IF sqlca.sqlcode THEN
X            CALL err_print(sqlca.sqlcode)
X        END IF
X        WHENEVER ERROR STOP
X        RETURN
X    END IF
X
X    CLOSE upd_curs
X    IF sqlca.sqlcode THEN
X        CALL err_print(sqlca.sqlcode)
X        WHENEVER ERROR STOP
X        RETURN
X    END IF
X
X    WHENEVER ERROR STOP
X
X    CALL shuffle_equipment()              # I deleted this record
X
X    MESSAGE "Row deleted"
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function executes a shell command.                                      *
X*******************************************************************************}
X
XFUNCTION bang()
X    DEFINE  cmd CHAR(80)
X    DEFINE  x CHAR(1)
X
X    MESSAGE ""
X
X    LET x = "!"
X    WHILE x = "!"
X        PROMPT "!" FOR cmd
X            ON KEY (CONTROL-G)
X                CALL fgl_prtscr()
X        END PROMPT
X        RUN cmd
X        PROMPT "Press return to continue" FOR CHAR x
X            ON KEY (CONTROL-G)
X                CALL fgl_prtscr()
X        END PROMPT
X    END WHILE
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function gets the current, next, or previous row.                       *
X*******************************************************************************}
X
XFUNCTION repo_equipment(direction, cursor_type)
XDEFINE  direction CHAR(1)
XDEFINE  cursor_type CHAR(1)
X
X    DEFINE  the_rowid INTEGER
X    DEFINE  q_jmp INTEGER
X
X    IF q_cnt = 0 THEN
X        ERROR " There are no rows in the current list  "
X        RETURN FALSE
X    ELSE
X        MESSAGE ""
X    END IF
X
X    LET q_jmp = q_off
X    IF q_jmp = 0 THEN
X        LET q_jmp = 1
X    END IF
X    LET q_off = "0"
X
X    CASE direction
X        WHEN "N"
X            LET q_cur = q_cur + q_jmp
X            IF  q_cur > q_cnt THEN
X                LET q_cur = q_cnt
X                ERROR " There are no more rows in the direction you are going  "
X            END IF
X        WHEN "P"
X            LET q_cur = q_cur - q_jmp
X            IF  q_cur < 1 THEN
X                LET q_cur = 1
X                ERROR " There are no more rows in the direction you are going  "
X            END IF
X        WHEN "F"
X            LET q_cur = 1
X        WHEN "L"
X            LET q_cur = q_cnt
X        WHEN "C"
X            #  Do Nothing !!!
X    END CASE
X
X    WHENEVER ERROR CONTINUE
X
X    LET the_rowid = r_rowid_s(q_cur)
X    CASE
X        WHEN cursor_type = "U"
X            OPEN upd_curs USING the_rowid
X        WHEN cursor_type = "B"
X            OPEN brw_curs USING the_rowid
X        OTHERWISE
X            OPEN std_curs USING the_rowid
X    END CASE
X    IF sqlca.sqlcode THEN
X        CALL err_print(sqlca.sqlcode)
X        WHENEVER ERROR STOP
X        RETURN FALSE
X    END IF
X
X    CASE
X        WHEN cursor_type = "U"
X            FETCH upd_curs INTO w_record.*
X        WHEN cursor_type = "B"
X            FETCH brw_curs INTO w_record.eq_id, w_record.eqp_name
X        OTHERWISE
X            FETCH std_curs INTO w_record.*
X    END CASE
X    IF sqlca.sqlcode THEN
X        IF sqlca.sqlcode = NOTFOUND THEN
X            ERROR " Someone else has deleted a row which is in your list  "
X            CALL shuffle_equipment()              # Other deleted this record
X            IF cursor_type = "S" THEN
X                WHENEVER ERROR STOP
X                RETURN TRUE
X            END IF
X        ELSE
X            CALL err_print(sqlca.sqlcode)
X        END IF
X        WHENEVER ERROR STOP
X        RETURN FALSE
X    END IF
X
X    WHENEVER ERROR STOP
X
X    RETURN TRUE
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function displays data for the current row.                             *
X*******************************************************************************}
X
XFUNCTION disp_equipment()
X    LET parent_eqp_name = NULL
X    SELECT eqp_name INTO parent_eqp_name
X      FROM equipment WHERE eq_id = w_record.parent_eq_id
X
X    DISPLAY BY NAME
X      w_record.eq_id,
X      w_record.eqp_name,
X      w_record.parent_eq_id,
X      parent_eqp_name,
X      q_cur,
X      q_cnt
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function brings in the most recent column value of the row.             *
X*******************************************************************************}
X
XFUNCTION ctrl_p_equipment()
X    CASE
X        WHEN INFIELD(eq_id)
X            LET w_record.eq_id = s_record.eq_id
X            DISPLAY BY NAME w_record.eq_id
X        WHEN INFIELD(eqp_name)
X            LET w_record.eqp_name = s_record.eqp_name
X            DISPLAY BY NAME w_record.eqp_name
X        WHEN INFIELD(parent_eq_id)
X            LET w_record.parent_eq_id = s_record.parent_eq_id
X            DISPLAY BY NAME w_record.parent_eq_id
X    END CASE
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function displays the contents of the working record in reverse video.  *
X*******************************************************************************}
X
XFUNCTION reverse_on_equipment()
X    CASE
X        WHEN INFIELD(eq_id)
X            DISPLAY BY NAME w_record.eq_id ATTRIBUTE(REVERSE)
X        WHEN INFIELD(eqp_name)
X            DISPLAY BY NAME w_record.eqp_name ATTRIBUTE(REVERSE)
X        WHEN INFIELD(parent_eq_id)
X            DISPLAY BY NAME w_record.parent_eq_id ATTRIBUTE(REVERSE)
X    END CASE
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function displays the contents of the working record normally.          *
X*******************************************************************************}
X
XFUNCTION reverse_off_equipment()
X    CASE
X        WHEN INFIELD(eq_id)
X            DISPLAY BY NAME w_record.eq_id
X        WHEN INFIELD(eqp_name)
X            DISPLAY BY NAME w_record.eqp_name
X        WHEN INFIELD(parent_eq_id)
X            DISPLAY BY NAME w_record.parent_eq_id
X    END CASE
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function shuffles the rowid array down one element (after a delete).    *
X*******************************************************************************}
X
XFUNCTION shuffle_equipment()
X    DEFINE  retval SMALLINT
X
X    CALL m_rowid_s(q_cur, q_cnt)
X
X    LET q_cnt = q_cnt - 1
X    IF q_cur > q_cnt THEN
X        LET q_cur = q_cnt
X    END IF
X
X    IF q_cur = 0 THEN
X        LET w_record.* = n_record.*   # Faster than INITIALIZE
X    ELSE
X        LET retval = repo_equipment("C", "S")
X    END IF
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function moves the cursor in the browse window down one line.           *
X*******************************************************************************}
X
XFUNCTION brw_down_equipment()
X    DEFINE  retval SMALLINT
X
X    IF q_off = "0" THEN
X        IF q_cur + 1 > q_cnt THEN
X            ERROR " There are no more rows in the direction you are going  "
X            RETURN
X        ELSE
X            LET q_cur = q_cur + 1
X        END IF
X
X        CALL brw_dspline_equipment("NORMAL")
X        IF brw_scrline + 1 > 10 THEN
X            SCROLL b_record.* UP
X        ELSE
X            LET brw_scrline = brw_scrline + 1
X        END IF
X        IF repo_equipment("C", "B") THEN
X            CALL brw_dspline_equipment("REVERSE")
X        END IF
X    ELSE
X        LET retval = repo_equipment("N", "B")
X        CALL brw_dsppage_equipment()
X    END IF
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function moves the cursor in the browse window up one line.             *
X*******************************************************************************}
X
XFUNCTION brw_up_equipment()
X    DEFINE  retval SMALLINT
X
X    IF q_off = "0" THEN
X        IF q_cur - 1 < 1 THEN
X            ERROR " There are no more rows in the direction you are going  "
X            RETURN
X        ELSE
X            LET q_cur = q_cur - 1
X        END IF
X
X        CALL brw_dspline_equipment("NORMAL")
X        IF brw_scrline - 1 < 1 THEN
X            SCROLL b_record.* DOWN
X        ELSE
X            LET brw_scrline = brw_scrline - 1
X        END IF
X        IF repo_equipment("C", "B") THEN
X            CALL brw_dspline_equipment("REVERSE")
X        END IF
X    ELSE
X        LET retval = repo_equipment("P", "B")
X        CALL brw_dsppage_equipment()
X    END IF
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function moves the cursor in the browse window down one page.           *
X*******************************************************************************}
X
XFUNCTION brw_nextpage_equipment()
X    DEFINE  retval SMALLINT
X
X    IF q_off = "0" THEN
X        IF (q_cur - brw_scrline + 1) + 10 > q_cnt THEN
X            ERROR " There are no more rows in the direction you are going  "
X            RETURN
X        ELSE
X            LET q_cur = (q_cur - brw_scrline + 1) + 10
X        END IF
X    ELSE
X        WHENEVER ERROR CONTINUE
X        LET q_off = q_off * 10
X        WHENEVER ERROR STOP
X        LET retval = repo_equipment("N", "B")
X    END IF
X
X    CALL brw_dsppage_equipment()
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function moves the cursor in the browse window up one page.             *
X*******************************************************************************}
X
XFUNCTION brw_prevpage_equipment()
X    DEFINE  retval SMALLINT
X
X    IF q_cur = 1 THEN
X        ERROR " There are no more rows in the direction you are going  "
X        RETURN
X    ELSE
X        IF q_off = "0" THEN
X            IF (q_cur - brw_scrline + 1) - 10 < 1 THEN
X                LET q_cur = 1
X            ELSE
X                LET q_cur = (q_cur - brw_scrline + 1) - 10
X            END IF
X        ELSE
X            WHENEVER ERROR CONTINUE
X            LET q_off = q_off * 10
X            WHENEVER ERROR STOP
X            LET retval = repo_equipment("P", "B")
X        END IF
X    END IF
X
X    CALL brw_dsppage_equipment()
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function displays a page of data in the browse window.                  *
X*******************************************************************************}
X
XFUNCTION brw_dsppage_equipment()
X    FOR brw_scrline = 1 TO 10
X        IF q_cur <= q_cnt THEN
X            IF repo_equipment("C", "B") THEN
X                CALL brw_dspline_equipment("NORMAL")
X            END IF
X        ELSE
X            CALL brw_dspline_equipment("")
X        END IF
X        LET q_cur = q_cur + 1
X    END FOR
X    LET q_cur = q_cur - 10
X    LET brw_scrline = 1
X    IF repo_equipment("C", "B") THEN
X        CALL brw_dspline_equipment("REVERSE")
X    END IF
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function displays a line of data in the browse window.                  *
X*******************************************************************************}
X
XFUNCTION brw_dspline_equipment(style)
XDEFINE  style CHAR(7)
X
X    DEFINE  brw_offset SMALLINT
X
X    CASE
X        WHEN style IS NULL
X            DISPLAY "", ""
X              TO b_record[brw_scrline].eq_id, b_record[brw_scrline].eqp_name
X        WHEN style = "NORMAL"
X            DISPLAY w_record.eq_id, w_record.eqp_name
X              TO b_record[brw_scrline].eq_id, b_record[brw_scrline].eqp_name
X        WHEN style = "REVERSE"
X            DISPLAY w_record.eq_id, w_record.eqp_name
X              TO b_record[brw_scrline].eq_id, b_record[brw_scrline].eqp_name
X                ATTRIBUTE(REVERSE)
X    END CASE
X
X    LET brw_offset = brw_scrline + 3
X    DISPLAY " " AT brw_offset,1
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function displays help for individual fields.                           *
X*******************************************************************************}
X
XFUNCTION help_equipment()
X    CASE
X        WHEN INFIELD(eq_id)
X            CALL SHOWHELP(1000)
X        WHEN INFIELD(eqp_name)
X            CALL SHOWHELP(1001)
X        WHEN INFIELD(parent_eq_id)
X            CALL SHOWHELP(1002)
X    END CASE
XEND FUNCTION
X
X
XFUNCTION ctrl_e_equipment()
X    CASE
X        WHEN INFIELD(parent_eq_id)
X            CALL lu_equip(w_record.parent_eq_id, parent_eqp_name)
X              RETURNING w_record.parent_eq_id, parent_eqp_name
X            DISPLAY BY NAME w_record.parent_eq_id, parent_eqp_name
X        OTHERWISE
X            ERROR ""
X    END CASE
XEND FUNCTION
X
X
XFUNCTION recursive_loop()
X    DEFINE  retval INTEGER
X    DEFINE  dups INTEGER
X
X    # The following mess checks for recursive loops.
X    # Here's how it's done:
X    #
X
X    # First, we clean out the temp table (eqpweb) to start with
X    # a clean slate.
X    #
X    DELETE FROM eqpweb
X
X    # Next, while walking UP the web, we stuff the id's
X    # of all parents, grand-parents, great-grand-parents, etc.
X    # for the proposed "parent_eq_id" into the temp table.
X    #
X    LET retval = build_web(w_record.parent_eq_id, "U")
X    IF retval THEN
X        CALL err_print(retval)
X        RETURN TRUE
X    END IF
X
X    # Then, while walking DOWN the web, we stuff the id's
X    # of all children, grand-children, great-grand-children,
X    # etc. for the current "eq_id" into the temp table.
X    #
X    LET retval = build_web(w_record.eq_id, "D")
X    IF retval THEN
X        CALL err_print(retval)
X        RETURN TRUE
X    END IF
X
X    # Now, we stuff the current "eq_id" into the temp table as a DOWN
X    # link with a level of '0'.  We need to stuff the current "eq_id"
X    # because the recursion routine only provides ancestors or
X    # decendents, not the id itself.  We choose DOWN because we
X    # walked down the tree with the "eq_id".  We walked up the tree with
X    # "parent_eq_id" so the "parent_eq_id" wasn't written to the temp
X    # table (but we don't care about that).  What we do care about is
X    # that maybe while walking up the tree, we wrote the current "eq_id"
X    # to the temp table there too.  Read the comments below to see why
X    # we care.
X    WHENEVER ERROR CONTINUE
X    INSERT INTO eqpweb VALUES (NULL, w_record.eq_id, "D", 0)
X    IF sqlca.sqlcode THEN
X        CALL err_print(sqlca.sqlcode)
X        WHENEVER ERROR STOP
X        RETURN TRUE
X    END IF
X    WHENEVER ERROR STOP
X
X    # Lastly, by doing a self-join on the temp table, we know who
X    # are ancesters and who are decendents of the relationship
X    # about to be created.  If there is one or more id's in the
X    # temp table that's both an ancester AND a descendent,
X    # you've got a recursive loop.
X    SELECT COUNT(*) INTO dups
X      FROM eqpweb u, eqpweb d
X      WHERE u.direction = "U" AND d.direction = "D"
X        AND u.id = d.id
X    IF dups > 0 THEN
X        ERROR " This entry would create a recursive loop  "
X        RETURN TRUE
X    END IF
X
X    RETURN FALSE
XEND FUNCTION
X
X
SHAR_EOF
if [ `wc -c < i_equip.4gl` -ne    32298 ]
then
    echo "Lengths do not match -- Bad Copy of i_equip.4gl"
fi
echo "Extracting file i_equip.hlp"
sed -e 's/^X//' <<\SHAR_EOF > i_equip.hlp
X-- i_equip.hlp - Help source for executable i_equip (i_equip.4ge)
X-- Copyright (C) 1995  David A. Snyder  All Rights Reserved
X
X
X.1
XOPTIONS.
X
XThe OPTIONS Menu presents you with the following options:
X
X > Query            Searches the table
X > Browse           Browse through rows in Current List
X > Next             Displays the next row in the Current List
X > Previous         Displays the previous row in the Current List
X > First            Displays the first row in the Current List
X > Last             Displays the last row in the Current List
X > Add              Adds data to the active table
X > Update           Changes a row in the active table
X > Remove           Deletes a row from the active table
X > Current          Displays the current row of the active table
X > Exit             Returns to the Main Menu
X
XPROCEDURE:
X
XEnter the first letter of the menu option you want:  q for Query, b for Browse,
Xn for Next, p for Previous, f for First, l for Last, a for Add, u for Update, r
Xfor Remove, c for Current, or e for Exit.
X
XUse the Next and Previous options to view the next or previous row in the
XCurrent List.  First use the Query option to generate a Current List (a list of
Xall the rows that satisfy your query).  If there is more than one row in the
XCurrent List, you can select the Next option to look at the next row.  After
Xyou use Next, you can use the Previous option to look at the previous row.
X
XUse the Exit option to leave the OPTIONS Menu and return to the Main Menu.
XAfter you select the Exit option, Options displays the Main Menu.
X
X
XQUIT:
X
XSelect the Exit option to leave the OPTIONS Menu and return to the MAIN Menu.
X
X
XNOTES:
X
XYou cannot select Browse, Update, Next, Previous, First, Last, Remove, or
XCurrent until you have generated a Current List with Query.
X.2
XFIELD EDITING CONTROL KEYS:
XCTRL X    : Deletes a character
XCTRL A    : Toggles in and out of character insertion mode
XCTRL D    : Clears to the end of the field
Xleft      : Backspace
Xright     : Forward Space
Xup        : Traverse backwards through the fields
XCTRL F    : 'Fast-forward' through the fields
XCTRL B    : 'Fast-reverse' through the fields
XCTRL G    : Prints the current screen (including windows)
XCTRL P    : Brings in most recent column value of the row
XCTRL W    : Display help message
XCR        : Next field
XCTRL I    : Next field
Xdown      : Next field
XESCAPE    : Entry Complete
XINTERRUPT : Abort Command
X
X
X
XQUERY COMPARISON SYMBOLS:
X<     Less than                 <=    Less than or equal
X>     Greater than              >=    Greater than or equal
X=     Equal                     <>    Not equal
X>>    Last value (only for indexed columns, without other comparisons)
X<<    First value (same conditions as last value)
X:     Range (inclusive)
X|     OR condition
XThe colon for range comparison is typed between the desired range values
XThe pipe symbol for OR separates the different possibilities
X         All other symbols are typed in front of the column value
XAn asterisk (*) is used for wild card comparison of character columns
XA blank field means don't care
X         To match for a blank character field, use the equality symbol
X.3
XREMOVE.
X
XThe REMOVE Menu presents you with the following options:
X
X > No               Does NOT remove this row from the active table
X > Yes              Removes this row from the active table
X
X
XPROCEDURE:
X
XEnter the first letter of the menu option you want:  n for No, y for Yes.
X.1000
XEnter the piece of equipment's ID number.
X
X.1001
XEnter the piece of equipment's name.
X
X.1002
XEnter the equipment ID number for the parent of this piece of equipment
X(if applicable).
X
SHAR_EOF
if [ `wc -c < i_equip.hlp` -ne     3619 ]
then
    echo "Lengths do not match -- Bad Copy of i_equip.hlp"
fi
echo "Extracting file i_equip.per"
sed -e 's/^X//' <<\SHAR_EOF > i_equip.per
X-- i_equip.per - Main screen source for executable i_equip (i_equip.4ge)
X-- Copyright (C) 1995  David A. Snyder  All Rights Reserved
X
X
XDATABASE stores
X
XSCREEN
X{
X
X--ROW-[x000  ]-OF-[x001  ]---------------------- Press CTRL-W for Help --------
X
X
XEquipment ID       [f000       ]
X
XEquipment Name     [f001                ]
X
X
XParent:
X  Equipment ID     [f002       ]      Equipment Name     [f003                ]
X}
X
XTABLES equipment
X
XATTRIBUTES
Xf000 = equipment.eq_id,
X  COMMENTS="Enter the equipment id";
Xf001 = equipment.eqp_name,
X  COMMENTS="Enter the equipment name", UPSHIFT;
Xf002 = equipment.parent_eq_id,
X  COMMENTS="Enter the equipment id of this equipment's parent           (CTRL-E for EQ_IDs)";
Xf003 = FORMONLY.parent_eqp_name;
Xx000 = FORMONLY.q_cur, NOENTRY, REVERSE;
Xx001 = FORMONLY.q_cnt, NOENTRY, REVERSE;
SHAR_EOF
if [ `wc -c < i_equip.per` -ne      818 ]
then
    echo "Lengths do not match -- Bad Copy of i_equip.per"
fi
echo "Extracting file i_equipb.per"
sed -e 's/^X//' <<\SHAR_EOF > i_equipb.per
X-- i_equipb.per - Browse screen source for executable i_equip (i_equip.4ge)
X-- Copyright (C) 1995  David A. Snyder  All Rights Reserved
X
X
XDATABASE stores
X
XSCREEN
X{
X Eqp. ID     Eqp. Name
X ----------  --------------------
X[f000      ][f001                ]
X[f000      ][f001                ]
X[f000      ][f001                ]
X[f000      ][f001                ]
X[f000      ][f001                ]
X[f000      ][f001                ]
X[f000      ][f001                ]
X[f000      ][f001                ]
X[f000      ][f001                ]
X[f000      ][f001                ]
X}
X
XTABLES equipment
X
XATTRIBUTES
Xf000 = equipment.eq_id;
Xf001 = equipment.eqp_name;
X
XINSTRUCTIONS
X  DELIMITERS "  "
X  SCREEN RECORD b_record[10] (eq_id, eqp_name)
SHAR_EOF
if [ `wc -c < i_equipb.per` -ne      733 ]
then
    echo "Lengths do not match -- Bad Copy of i_equipb.per"
fi
echo "Extracting file lu_equip.4gl"
sed -e 's/^X//' <<\SHAR_EOF > lu_equip.4gl
X# lu_equip.4gl - 4GL source for equipment lookups
X# Copyright (C) 1995  David A. Snyder  All Rights Reserved
X
X
XDATABASE stores
X
X
XDEFINE  lu_arrcount SMALLINT
XDEFINE  lu_arrcurr SMALLINT
XDEFINE  lu_scrline SMALLINT
XDEFINE  p_record ARRAY[64] OF RECORD
X            eq_id LIKE equipment.eq_id,
X            eqp_name LIKE equipment.eqp_name
X        END RECORD
X
X
X{*******************************************************************************
X* This function searches through the equipment table.                          *
X*******************************************************************************}
X
XFUNCTION lu_equip(eq_id, eqp_name)
XDEFINE  eq_id LIKE equipment.eq_id
XDEFINE  eqp_name LIKE equipment.eqp_name
X
X    DEFINE  keyhit INTEGER
X    DEFINE  scratch CHAR(512)
X
X    OPEN WINDOW ringout_equipment AT 1,1 WITH 2 ROWS, 79 COLUMNS
X    DISPLAY "LU-QUERY:  ESCAPE queries.  INTERRUPT aborts.  ARROW keys move cursor.", "" AT 1,1 ATTRIBUTE(WHITE)
X    DISPLAY "Searches through the equipment table.", "" AT 2,1 ATTRIBUTE(WHITE)
X    OPEN WINDOW lu_equip AT 6, 30 WITH FORM "lu_equip"
X      ATTRIBUTE(BORDER, WHITE, FORM LINE FIRST + 1)
X
XLABEL retry:
X    LET int_flag = FALSE
X    CONSTRUCT BY NAME scratch ON eq_id, eqp_name
X    IF int_flag THEN
X        CLOSE WINDOW lu_equip
X        CLOSE WINDOW ringout_equipment
X        RETURN eq_id, eqp_name
X    END IF
X
X    LET scratch = "SELECT eq_id, eqp_name FROM equipment WHERE ", scratch CLIPPED, " ORDER BY eq_id"
X    PREPARE lu_stmt FROM scratch
X    DECLARE lu_curs CURSOR FOR lu_stmt
X
X    LET lu_arrcount = 1
X    FOREACH lu_curs INTO p_record[lu_arrcount].*
X        LET lu_arrcount = lu_arrcount + 1
X    END FOREACH
X    LET lu_arrcount = lu_arrcount - 1
X    IF lu_arrcount = 0 THEN
X        ERROR " There are no rows satisfying the conditions  "
X        GOTO retry
X    END IF
X    LET lu_arrcurr = 1
X    LET lu_scrline = 1
X
X    CURRENT WINDOW IS ringout_equipment
X    DISPLAY "LOOKUP:  ESCAPE selects.  INTERRUPT aborts.  ARROW keys move cursor.", "" AT 1,1 ATTRIBUTE(WHITE)
X    CURRENT WINDOW IS lu_equip
X
X    CALL lu_dsppage_equipment()
X
X    WHILE (TRUE)
X        LET keyhit = fgl_getkey()
X        CASE
X            WHEN keyhit = fgl_keyval("ACCEPT") OR keyhit = fgl_keyval("INTERRUPT")
X                EXIT WHILE
X            WHEN keyhit = fgl_keyval("DOWN") OR keyhit = fgl_keyval("RIGHT")
X                CALL lu_down_equipment()
X            WHEN keyhit = fgl_keyval("UP") OR keyhit = fgl_keyval("LEFT")
X                CALL lu_up_equipment()
X            WHEN keyhit = fgl_keyval("CONTROL-F")     # NEXT KEY
X                CALL lu_nextpage_equipment()
X            WHEN keyhit = fgl_keyval("CONTROL-B")     # PREVIOUS KEY
X                CALL lu_prevpage_equipment()
X            WHEN keyhit = fgl_keyval("CONTROL-G")
X                CALL fgl_prtscr()
X            OTHERWISE
X                ERROR ""
X        END CASE
X    END WHILE
X
X    IF int_flag THEN
X        LET p_record[lu_arrcurr].eq_id = eq_id
X        LET p_record[lu_arrcurr].eqp_name = eqp_name
X        LET int_flag = FALSE
X    END IF
X
X    CLOSE WINDOW lu_equip
X    CLOSE WINDOW ringout_equipment
X    RETURN p_record[lu_arrcurr].*
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function moves the cursor in the lookup window down one line.           *
X*******************************************************************************}
X
XFUNCTION lu_down_equipment()
X    IF lu_arrcurr + 1 > lu_arrcount THEN
X        ERROR " There are no more rows in the direction you are going  "
X        RETURN
X    END IF
X
X    CALL lu_dspline_equipment("NORMAL")
X    LET lu_arrcurr = lu_arrcurr + 1
X
X    IF lu_scrline + 1 > 5 THEN
X        SCROLL s_record.* UP
X    ELSE
X        LET lu_scrline = lu_scrline + 1
X    END IF
X    CALL lu_dspline_equipment("REVERSE")
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function moves the cursor in the lookup window up one line.             *
X*******************************************************************************}
X
XFUNCTION lu_up_equipment()
X    IF lu_arrcurr - 1 < 1 THEN
X        ERROR " There are no more rows in the direction you are going  "
X        RETURN
X    END IF
X
X    CALL lu_dspline_equipment("NORMAL")
X    LET lu_arrcurr = lu_arrcurr - 1
X
X    IF lu_scrline - 1 < 1 THEN
X        SCROLL s_record.* DOWN
X    ELSE
X        LET lu_scrline = lu_scrline - 1
X    END IF
X    CALL lu_dspline_equipment("REVERSE")
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function moves the cursor in the lookup window down one page.           *
X*******************************************************************************}
X
XFUNCTION lu_nextpage_equipment()
X    IF (lu_arrcurr - lu_scrline + 1) + 5 > lu_arrcount THEN
X        ERROR " There are no more rows in the direction you are going  "
X        RETURN
X    ELSE
X        LET lu_arrcurr = (lu_arrcurr - lu_scrline + 1) + 5
X    END IF
X
X    CALL lu_dsppage_equipment()
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function moves the cursor in the lookup window up one page.             *
X*******************************************************************************}
X
XFUNCTION lu_prevpage_equipment()
X    DEFINE  retval SMALLINT
X
X    IF lu_arrcurr = 1 THEN
X        ERROR " There are no more rows in the direction you are going  "
X        RETURN
X    ELSE
X        IF (lu_arrcurr - lu_scrline + 1) - 5 < 1 THEN
X            LET lu_arrcurr = 1
X        ELSE
X            LET lu_arrcurr = (lu_arrcurr - lu_scrline + 1) - 5
X        END IF
X    END IF
X
X    CALL lu_dsppage_equipment()
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function displays a page of data in the lookup window.                  *
X*******************************************************************************}
X
XFUNCTION lu_dsppage_equipment()
X    FOR lu_scrline = 1 TO 5
X        IF lu_arrcurr <= lu_arrcount THEN
X            CALL lu_dspline_equipment("NORMAL")
X        ELSE
X            CALL lu_dspline_equipment("")
X        END IF
X        LET lu_arrcurr = lu_arrcurr + 1
X    END FOR
X    LET lu_arrcurr = lu_arrcurr - 5
X    LET lu_scrline = 1
X    CALL lu_dspline_equipment("REVERSE")
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function displays a line of data in the lookup window.                  *
X*******************************************************************************}
X
XFUNCTION lu_dspline_equipment(style)
XDEFINE  style CHAR(7)
X
X    DEFINE  lu_offset SMALLINT
X
X    CASE
X        WHEN style IS NULL
X            DISPLAY "", ""
X              TO s_record[lu_scrline].eq_id, s_record[lu_scrline].eqp_name
X        WHEN style = "NORMAL"
X            DISPLAY p_record[lu_arrcurr].eq_id, p_record[lu_arrcurr].eqp_name
X              TO s_record[lu_scrline].eq_id, s_record[lu_scrline].eqp_name
X        WHEN style = "REVERSE"
X            DISPLAY p_record[lu_arrcurr].eq_id, p_record[lu_arrcurr].eqp_name
X              TO s_record[lu_scrline].eq_id, s_record[lu_scrline].eqp_name
X                ATTRIBUTE(REVERSE)
X    END CASE
X
X    LET lu_offset = lu_scrline + 3
X    DISPLAY " " AT lu_offset,1
XEND FUNCTION
X
X
SHAR_EOF
if [ `wc -c < lu_equip.4gl` -ne     7291 ]
then
    echo "Lengths do not match -- Bad Copy of lu_equip.4gl"
fi
echo "Extracting file lu_equip.per"
sed -e 's/^X//' <<\SHAR_EOF > lu_equip.per
X-- lu_equip.per - Screen source for equipment lookups
X-- Copyright (C) 1995  David A. Snyder  All Rights Reserved
X
X
XDATABASE stores
X
XSCREEN
X{
X Eqp. ID     Eqp. Name
X ----------  --------------------
X[f000      ][f001                ]
X[f000      ][f001                ]
X[f000      ][f001                ]
X[f000      ][f001                ]
X[f000      ][f001                ]
X}
X
XTABLES equipment
X
XATTRIBUTES
Xf000 = equipment.eq_id;
Xf001 = equipment.eqp_name;
X
XINSTRUCTIONS
X    DELIMITERS "  "
X    SCREEN RECORD s_record[5] (eq_id, eqp_name)
SHAR_EOF
if [ `wc -c < lu_equip.per` -ne      539 ]
then
    echo "Lengths do not match -- Bad Copy of lu_equip.per"
fi
echo "Extracting file o_equip.4gl"
sed -e 's/^X//' <<\SHAR_EOF > o_equip.4gl
X# o_equip.4gl - 4GL source for executable o_equip (o_equip.4ge)
X# Copyright (C) 1995  David A. Snyder  All Rights Reserved
X
X
XDATABASE stores
X
X
XDEFINE  w_record, s_record RECORD                           # work/save record
X            eq_id LIKE equipment.eq_id,
X            eqp_name LIKE equipment.eqp_name,
X            level SMALLINT
X        END RECORD
X
XDEFINE  direction CHAR(1)
X
X
X{*******************************************************************************
X* This program drives the equipment screen.
X*******************************************************************************}
X
XMAIN
X    DEFER INTERRUPT
X    CALL menu_equipment()
XEND MAIN
X
X
X{*******************************************************************************
X* This function handles the main ring menu.                                    *
X*******************************************************************************}
X
XFUNCTION menu_equipment()
X    CALL init_equipment()
X
X    OPEN FORM o_equip FROM "o_equip"
X    DISPLAY FORM o_equip
X
X    CALL qry_equipment()
X    IF NOT int_flag THEN
X        CALL out_equipment()
X    END IF
X
X    CLOSE FORM o_equip
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function initializes options and variables.                             *
X*******************************************************************************}
X
XFUNCTION init_equipment()
X    OPTIONS HELP FILE "o_equip.msg"
X    OPTIONS INPUT WRAP
X    OPTIONS MESSAGE LINE LAST
X
X    CREATE TEMP TABLE eqpweb
X      (seq SERIAL, id INTEGER NOT NULL, direction CHAR(1), level SMALLINT)
X     WITH NO LOG
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function will query the database table.                                 *
X*******************************************************************************}
X
XFUNCTION qry_equipment()
X    DISPLAY "OUTPUT:  ESCAPE outputs.  DELETE discards output.  ARROW keys move cursor.", "" AT 1,1
X    DISPLAY "Output select rows in report format.", "" AT 2,1
X    MESSAGE ""
X
X    LET int_flag = FALSE
X    INPUT BY NAME s_record.eq_id, direction HELP 1
X        AFTER FIELD eq_id
X            LET s_record.eqp_name = NULL
X            SELECT eqp_name INTO s_record.eqp_name
X              FROM equipment WHERE eq_id = s_record.eq_id
X            DISPLAY BY NAME s_record.eqp_name
X        ON KEY (CONTROL-B)
X            NEXT FIELD PREVIOUS
X        ON KEY (CONTROL-E)
X            CASE
X                WHEN INFIELD(eq_id)
X                    CALL lu_equip(s_record.eq_id, s_record.eqp_name)
X                      RETURNING s_record.eq_id, s_record.eqp_name
X                    DISPLAY BY NAME s_record.eq_id, s_record.eqp_name
X                    NEXT FIELD NEXT
X                OTHERWISE
X                    ERROR ""
X            END CASE
X        ON KEY (CONTROL-F)
X            NEXT FIELD NEXT
X        ON KEY (CONTROL-G)
X            CALL fgl_prtscr()
X    END INPUT
X
X    RETURN
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function outputs the current list to the printer.
X*******************************************************************************}
X
XFUNCTION out_equipment()
X    DEFINE  retval INTEGER
X
X    MESSAGE "Outputting ..."
X
X    LET retval = build_web(s_record.eq_id, direction)
X    IF retval THEN
X        CALL err_print(retval)
X        RETURN
X    END IF
X
X    DECLARE out_curs CURSOR FOR
X      SELECT id, eqp_name, level, seq FROM eqpweb, equipment
X        WHERE equipment.eq_id = eqpweb.id
X          AND eqpweb.id = equipment.eq_id
X        ORDER BY seq
X
X    START REPORT rpt_equipment TO "report.out"
X    FOREACH out_curs INTO w_record.*
X        OUTPUT TO REPORT rpt_equipment(w_record.*)
X    END FOREACH
X    FINISH REPORT rpt_equipment
XEND FUNCTION
X
X
X{*******************************************************************************
X* This function does the actual formating and printing.                        *
X*******************************************************************************}
X
XREPORT rpt_equipment(o_record)
XDEFINE  o_record RECORD
X            eq_id LIKE equipment.eq_id,
X            eqp_name LIKE equipment.eqp_name,
X            level SMALLINT
X        END RECORD
X
X    OUTPUT LEFT MARGIN 0
X
X    FORMAT
X        FIRST PAGE HEADER
X            PRINT COLUMN 32, "EQUIPMENT EXPLOSION"
X            PRINT COLUMN 32, "-------------------"
X            SKIP 2 LINES
X            PRINT s_record.eqp_name CLIPPED, "(", s_record.eq_id USING "<<<<<<<<<<", ")"
X
X        ON EVERY ROW 
X            PRINT COLUMN o_record.level+1,
X              o_record.eqp_name CLIPPED, "(", o_record.eq_id USING "<<<<<<<<<<", ")"
X
X        ON LAST ROW
X            SKIP 1 LINE
X            PRINT  "Total number of items in explosion: ", COUNT(*)+1 USING "<<<"
X
XEND REPORT
X
X
SHAR_EOF
if [ `wc -c < o_equip.4gl` -ne     4825 ]
then
    echo "Lengths do not match -- Bad Copy of o_equip.4gl"
fi
echo "Extracting file o_equip.hlp"
sed -e 's/^X//' <<\SHAR_EOF > o_equip.hlp
X-- o_equip.hlp - Help source for executable o_equip (o_equip.4ge)
X-- Copyright (C) 1995  David A. Snyder  All Rights Reserved
X
X
X.1
XFIELD EDITING CONTROL KEYS:
XCTRL X    : Deletes a character
XCTRL A    : Toggles in and out of character insertion mode
XCTRL D    : Clears to the end of the field
Xleft      : Backspace
Xright     : Forward Space
Xup        : Traverse backwards through the fields
XCTRL F    : 'Fast-forward' through the fields
XCTRL B    : 'Fast-reverse' through the fields
XCTRL G    : Prints the current screen (including windows)
XCTRL P    : Brings in most recent column value of the row
XCTRL W    : Display help message
XCR        : Next field
XCTRL I    : Next field
Xdown      : Next field
XESCAPE    : Entry Complete
XINTERRUPT : Abort Command
SHAR_EOF
if [ `wc -c < o_equip.hlp` -ne      754 ]
then
    echo "Lengths do not match -- Bad Copy of o_equip.hlp"
fi
echo "Extracting file o_equip.per"
sed -e 's/^X//' <<\SHAR_EOF > o_equip.per
X-- o_equip.per - Main screen source for executable o_equip (o_equip.4ge)
X-- Copyright (C) 1995  David A. Snyder  All Rights Reserved
X
X
XDATABASE stores
X
XSCREEN
X{
X
X------------------------------------------------ Press CTRL-W for Help --------
X
X
X  Equipment ID     [f000       ]      Equipment Name     [f001                ]
X
X  Direction        [a]
X}
X
XTABLES equipment
X
XATTRIBUTES
Xf000 = FORMONLY.eq_id TYPE INTEGER,
X  COMMENTS="Enter the equipment id                                      (CTRL-E for EQ_IDs)";
Xf001 = equipment.eqp_name;
Xa = FORMONLY.direction TYPE CHAR, UPSHIFT, REQUIRED, INCLUDE=("U", "D"),
X  COMMENTS="Enter the direction... <U>p or <D>own";
SHAR_EOF
if [ `wc -c < o_equip.per` -ne      662 ]
then
    echo "Lengths do not match -- Bad Copy of o_equip.per"
fi
echo "Extracting file recursive.ec"
sed -e 's/^X//' <<\SHAR_EOF > recursive.ec
X/*
X**  recursive.ec - 'ESQL/C' functions required to perform equipment explosions
X**  Copyright (C) 1995  David A. Snyder
X**
X**  This library is free software; you can redistribute it and/or
X**  modify it under the terms of the GNU Library General Public
X**  License as published by the Free Software Foundation; version
X**  2 of the License.
X**
X**  This library is distributed in the hope that it will be useful,
X**  but WITHOUT ANY WARRANTY; without even the implied warranty of
X**  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
X**  Library General Public License for more details.
X**
X**  You should have received a copy of the GNU Library General Public
X**  License along with this library; if not, write to the Free
X**  Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
X*/
X
X#include <stdio.h>
X
Xstruct web {
X	long	id;
X	struct web *NWebP;
X};
X$char	direction[2];
X
X
X/*
X************************************************************************
X    This function builds a list of linked ids in "eqpweb".
X************************************************************************
X*/
X
Xbuild_web(arg)
Xint	arg;
X{
X	int	retval;
X	long	id;
X
X	if (arg != 2)
X		fgl_fatal("eqpweb.ec", 41, -1318);
X
X	popquote(direction, sizeof(direction));
X	poplong(&id);
X
X	retval = __build_web(id, 1);
X
X	retint(retval);
X	return(1);
X}
X
X
Xstatic
X__build_web(parent_id, level)
X$long	parent_id;
X$long	level;
X{
X	char	*malloc();
X	int	retval;
X	struct web *WebP, *SWepP;
X	$long	id;
X	$char	scratch[256];
X
X	/* Allocate the first element of the linked list and NULL it */
X	if ((WebP = (struct web *)malloc(sizeof(struct web ))) == NULL)
X		return(-1319);
X	WebP->id = (long)NULL;
X	WebP->NWebP = (struct web *)NULL;
X
X	/* Save the beginning of the linked list */
X	SWepP = WebP;
X
X	/* Build a cursor */
X	if (*direction == 'U')
X		sprintf(scratch, "select parent_eq_id from equipment where eq_id = %d", parent_id);
X	else if (*direction == 'D')
X		sprintf(scratch, "select eq_id from equipment where parent_eq_id = %d", parent_id);
X
X	$prepare walk_stmt from $scratch;
X	if (sqlca.sqlcode) {
X		Free_WebP(SWepP);
X		return(sqlca.sqlcode);
X	}
X	$declare walk_curs cursor for walk_stmt;
X	if (sqlca.sqlcode) {
X		Free_WebP(SWepP);
X		return(sqlca.sqlcode);
X	}
X
X	/* Blow through the cursor and build the linked-list */
X	$open walk_curs;
X	$fetch walk_curs into $id;
X	while (!sqlca.sqlcode) {
X		if ((WebP->NWebP = (struct web *)malloc(sizeof(struct web ))) == NULL) {
X			Free_WebP(SWepP);
X			return(-1319);
X		}
X		WebP = WebP->NWebP;
X		WebP->id = id;
X		WebP->NWebP = NULL;
X		$fetch walk_curs into $id;
X	}
X
X	/* Rewind to the beginning of the linked list */
X	WebP = SWepP;
X
X	/* Blow through the linked-list and write the data to "eqpweb" */
X	while (WebP->NWebP != NULL) {
X		WebP = WebP->NWebP;
X		id = WebP->id;
X		$insert into eqpweb values (0, $id, $direction, $level);
X
X		if ((retval = __build_web(id, level + 1))) {
X			Free_WebP(SWepP);
X			return(retval);
X		}
X	}
X
X	/* Free up all the allocated memory */
X	Free_WebP(SWepP);
X
X	return(0);
X}
X
X
Xstatic
XFree_WebP(SWepP)
Xstruct web *SWepP;
X{
X	struct web *WebP;
X
X	/* Rewind to the beginning of the linked list (for the last time) */
X	WebP = SWepP;
X
X	/* Blow through the linked-list and "free" all the elements */
X	while (WebP->NWebP != NULL) {
X		SWepP = WebP->NWebP;
X		free(WebP);
X		WebP = SWepP;
X	}
X	free(WebP);
X}
X
X
SHAR_EOF
if [ `wc -c < recursive.ec` -ne     3326 ]
then
    echo "Lengths do not match -- Bad Copy of recursive.ec"
fi
echo "Extracting file usr_funcs.c"
sed -e 's/^X//' <<\SHAR_EOF > usr_funcs.c
X/*
X**  usr_funcs.c - 'C' functions required by programs generated by db4glgen
X**  Copyright (C) 1989-1995  David A. Snyder
X**
X**  This library is free software; you can redistribute it and/or
X**  modify it under the terms of the GNU Library General Public
X**  License as published by the Free Software Foundation; version
X**  2 of the License.
X**
X**  This library is distributed in the hope that it will be useful,
X**  but WITHOUT ANY WARRANTY; without even the implied warranty of
X**  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
X**  Library General Public License for more details.
X**
X**  You should have received a copy of the GNU Library General Public
X**  License along with this library; if not, write to the Free
X**  Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
X*/
X
X#include <malloc.h>
X#include <stdio.h>
X#include <string.h>
X
X
X/******************************************************************************
X* This function prints whatever is on the screen (including windows).         *
X******************************************************************************/
X
X#define bool		char
X#define CHAR		short
X#define _ATTRIBUTE	(0x7f00)
X#define _CHARACTER	(0x00ff)
X#define _GRAPHMODE	(0x8000)
X
Xtypedef struct window {
X	short	_cury, _curx;
X	short	_maxy, _maxx;
X	short	_begy, _begx;
X	short	_flags;
X	bool	_clear;
X	bool	_leave;
X	bool	_scroll;
X	CHAR	**_y;
X	short	*_firstch;
X	short	*_lastch;
X	short	_attr;
X} WINDOW;
X
Xtypedef struct _efwindow {
X	struct _efwindow *upper, *lower;
X	int *win;
X	int *swin;
X	char *formname;
X	int *winfrm;
X	short rows, columns;
X	short promptline;
X	short msgline;
X	short formline;
X	short cmtline;
X	short flag;
X	short forecolor;
X	unsigned long ucount;
X} _EFwindow;
X
X
Xextern _EFwindow	*topwin, *botwin, *_Wscreen;
Xextern WINDOW		*_efbigwin;
Xextern char	*GB;
X
Xfgl_prtscr(arg)
Xint	arg;
X{
X	register FILE		*fp;
X	register _EFwindow	*scr;
X	register WINDOW		*win;
X	register CHAR		**line, *data;
X	register int	y, x;
X	register char	c;
X	char	*getenv(), *dbprint;
X
X	if ((dbprint = getenv("DBPRINT")) == NULL)
X		dbprint = "lp -s";
X
X	if (topwin == _Wscreen)
X		/* the user is looking at the "screen" */
X
X		win = (WINDOW * ) _Wscreen->win;
X	else {
X		/* the user is looking at the one or more "windows" */
X
X		win = _efbigwin;
X
X		for (scr = botwin; scr != (_EFwindow * )0; 
X		    scr  = (_EFwindow * )scr->upper) {
X			overwrite((WINDOW * ) scr->win, win);
X		}
X	}
X
X	if ((fp = popen(dbprint, "w")) != (FILE * )0) {
X		for (y = 0, line = win->_y; y < win->_maxy; y++, line++) {
X			for (x = 0, data = *line; x < win->_maxx; x++, data++) {
X				c = (char) *data & _CHARACTER;
X
X				if ((*data & _GRAPHMODE) && *GB) {
X					if (c == GB[0])
X						c = '+';
X					else if (c == GB[1])
X						c = '+';
X					else if (c == GB[2])
X						c = '+';
X					else if (c == GB[3])
X						c = '+';
X					else if (c == GB[4])
X						c = '-';
X					else if (c == GB[5])
X						c = '|';
X				}
X				(void)fputc(c, fp);
X			}
X			(void)fputc('\n', fp);
X		}
X		(void)pclose(fp);
X	}
X	return 0;
X}
X
X
X/******************************************************************************
X* This function waits for a key on the keyboard to be hit and returns an      *
X* INTEGER code for that key.                                                  *
X******************************************************************************/
X
Xextern short	eflastkey;
X
Xfgl_getkey(arg)
Xint	arg;
X{
X	extern short	_acckey;
X	short	keyhit;
X
X	eflastkey = ((keyhit = rgetkey()) == _acckey) ? 2016 : keyhit;
X	clrmsg();
X	retlong((long) eflastkey);
X	return(1);
X}
X
X
X/******************************************************************************
X* These four(4) functions handle the dynamic rowid array for all standard     *
X* 4GL screens.                                                                *
X******************************************************************************/
X
Xstatic long	*ptr;
X
Xi_rowid_s(arg)
Xint	arg;
X{
X	if ((ptr = (long *)malloc(sizeof(long))) != NULL)
X		retint(0);
X	else
X		retint(1);
X	return(1);
X
X}
X
X
Xm_rowid_s(arg)
Xint	arg;
X{
X	int	i, q_cur, q_cnt;
X
X	popint(&q_cnt);
X	popint(&q_cur);
X
X	for (i = q_cur; i < q_cnt; i++)
X	    ptr[i] = ptr[i+1];
X
X	return(0);
X}
X
X
Xr_rowid_s(arg)
Xint	arg;
X{
X	int	pos;
X
X	popint(&pos);
X	retint(ptr[pos]);
X	return(1);
X}
X
X
Xs_rowid_s(arg)
Xint	arg;
X{
X	int	size;
X
X	popint(&size);
X	if ((ptr = (long *)realloc((char *)ptr, (unsigned)(size + 1) * sizeof(long))) != NULL)
X		retint(0);
X	else
X		retint(1);
X	return(1);
X}
X
X
Xw_rowid_s(arg)
Xint	arg;
X{
X	int	pos, value;
X
X	popint(&value);
X	popint(&pos);
X	ptr[pos] = value;
X	return(0);
X}
X
X
SHAR_EOF
if [ `wc -c < usr_funcs.c` -ne     4544 ]
then
    echo "Lengths do not match -- Bad Copy of usr_funcs.c"
fi
echo "Done."
exit 0