#!/bin/sh # # This is a shell archive. To extract its contents, # execute this file with /bin/sh to create the file(s): # # README errlog.4gl mainwin.4gl sql_lock.4gl # action.c fgiusr.c make.common std_opts.4gl # action.h fgl_putenv.c opendb.4gl totrows.4gl # actline.4gl frmtitle.4gl popup.4gl trap_err.4gl # disperr.4gl intract.4gl split.c windows.4gl # # This shell archive created: Tue Sep 26 08:51:40 EDT 1995 # echo "Extracting file README" sed -e 's/^X//' <<\SHAR_EOF > README XThese files, contributed by Mark Denham, comprise a library of functions useful Xin writing interactive maintenance programs. Below is the message from Mark Xthat accompanied the files. X XWalt Hultgren X X------------------------------------------------------------------------------ X XFrom: Mark Denham XTo: Walt Hultgren {rmy} XDate: Tue, 26 Sep 95 07:24:00 PDT X XWalt, X XHere are all the C functions and 4gls that make up the library. I have split Xthem all out into individual routines to make life easier. I have not had a Xchance to run through them all and check there are no bugs yet. All I can say Xis that the originals worked fine and I have no reason to suspect that these Xwill not also. X XThe pop_get_line function requires the user to define a 2 screen 4gl form. I Xhave not sent an example because my backup is corrupted so I will have to redo Xone. The first screen should contain an array sized appropriately for the Xpopup you require, the second should contain a single char AUTONEXT field. XThis field should be positioned so that the single char input field EXACTLY Xoverlays the closing brace ']' of the input array field on the first screen. XBoth forms need to have the field delimiters set to " " (spaces) so that the Xdisplay does not look odd. X XThe purpose of this double screen is to provide the user with hot-key Xsearching during input (ie hitting B takes you to the first entry starting Xwith B) without having to have an extra field on the screen main screen. X XMark X X------------------------------------------------------------------------------ SHAR_EOF if [ `wc -c < README` -ne 1612 ] then echo "Lengths do not match -- Bad Copy of README" fi echo "Extracting file action.c" sed -e 's/^X//' <<\SHAR_EOF > action.c X/***************************************************************************** X* X* SCCS IDENTIFICATION X* ------------------- X* X* MODULE NAME: action.c X* RELEASE: 1.1 X* CREATION DATE: 92/01/27 (YY/MM/DD) X* PATHNAME: /users/mhac/visits/c/s.action.c X* AUTHOR: Mark Denham, Shadowfax Systems Ltd X* THIS DOCUMENT CONTAINS SOURCE CODE WHICH IS X* THE PROPERTY OF SHADOWFAX SYSTEMS LTD. THIS X* SOURCE IS SUPPLIED TO RECIPIENT IN CONFIDENCE. X* INFORMATION CONTAINED HEREIN MAY NOT BE USED, X* COPIED OR DISCLOSED IN WHOLE OR IN PART EXCEPT X* AS PERMITTED BY WRITTEN AGREEMENT SIGNED BY AN X* EMPLOYEE OF SHADOWFAX SYSTEMS LTD. X* X* DESCRIPTION: This function is used to display a list of function keys X* at the bottom of the screen. X* X* Current Date: 92/03/18 (YY/MM/DD) Time: 15:37:39 X* X****************************************************************************** X*/ X X/****************************************************************************/ X/* X/* FUNCTION: action_line X/* X/* AUTHOR: M Denham, Shadowfax Systems Ltd DATE: 9-9-90 X/* X/* PURPOSE: Prepares the action line for display. X/* X/* X/* PARAMETERS: cols integer X/* mode integer X/* act_no integer X/* X/* RETURNS: TRUE Request processed successfully. X/* FALSE An error occurred. X/* act_str char X/* X/* MODIFICATION LOG X/* X/* NAME DATE DESCRIPTION X/* X/****************************************************************************/ X X#include X#include X X#define NEW 0 X#define PREV -1 X#define NEXT 1 X#define CLEAR 2 X#define TRUE 1 X#define FALSE 0 X#define MESS_NOT_SELECTED -1 X#define MAX_FKEY_LINES 20 X X#define FKEY_NEXT " F10-NEXT>" X#define FKEY_PREV " arr_size || act_no < 1 ) { X sprintf(act_str, "action_line(): Action %4d does not exist", act_no); X rval = FALSE; X break; X } X max_lines = setup_lines(cols, act_no, fkey_list, action_msg); X curr_line = 0; X strncpy(act_str, fkey_list[0].s_pos, fkey_list[0].no_ch); X *(act_str + fkey_list[0].no_ch + 1) = '\0'; X tmp = act_str; X act_str = act_str + strlen(act_str); X if( max_lines > 0 ) { X strcpy(act_str, FKEY_NEXT); X } X act_str = tmp; X X strcpy(curr_msg_str, act_str); X rval = TRUE; X break; X X case NEXT: X if( max_lines == MESS_NOT_SELECTED ) { X strcpy(act_str, "actionline(): No action has been selected."); X rval = FALSE; X break; X } X if( curr_line == max_lines ) { X strcpy(act_str, curr_msg_str); X rval = FALSE; X break; X } X curr_line++; X strcpy(act_str, FKEY_PREV); X strncat(act_str, fkey_list[curr_line].s_pos, fkey_list[curr_line].no_ch); X if( curr_line != max_lines ) X strcat(act_str, FKEY_NEXT); X X strcpy(curr_msg_str, act_str); X rval = TRUE; X break; X X case PREV: X if( max_lines == MESS_NOT_SELECTED ) { X strcpy(act_str, "actionline(): No action has been selected."); X rval = FALSE; X break; X } X if( curr_line == 0 ) { X strcpy(act_str, curr_msg_str); X rval = FALSE; X break; X } X curr_line--; X if( curr_line != 0 ) X strcpy(act_str, FKEY_PREV); X X strncat(act_str, fkey_list[curr_line].s_pos, fkey_list[curr_line].no_ch); X strcat(act_str, FKEY_NEXT); X X strcpy(curr_msg_str, act_str); X rval = TRUE; X break; X X case CLEAR: X curr_msg_str[0] = '\0'; X for(i=0; i<20; i++) { X fkey_list[i].s_pos = curr_msg_str; X fkey_list[i].no_ch = 0; X } X max_lines = MESS_NOT_SELECTED; X break; X default: X sprintf(act_str, "action_line(): Invalid mode specified"); X rval = FALSE; X } X retint(rval); X retquote(actstr); X X return(2); X} X Xint arr_len() X{ X int i; X X for(i=1; strlen(action_list[i]) > 0; i++); X X return(i); X} X Xint setup_lines(ncols, act_no, list, curr_msg) Xint ncols, X act_no; Xstruct fkey_strp *list; Xchar * curr_msg; X{ X int i, lennext, lenprev; X X char save_char, X *save_ptr, X *tmp, X *end_line; X X lennext = strlen(FKEY_NEXT) - 1; X lenprev = strlen(FKEY_PREV); X X sprintf(curr_msg, "%s%s", STANDARD_FKEYS, action_list[act_no] ); X tmp = curr_msg; X X for(i=0; strlen(tmp) > ncols; i++) { X end_line = tmp + ncols - lennext; X save_char = *end_line; X *end_line = '\0'; X save_ptr = end_line; X end_line = strrchr(tmp, (int) ' '); X *save_ptr = save_char; X X list[i].s_pos = tmp; X list[i].no_ch = (int) (end_line - tmp); X tmp = end_line+1; X if(i==0) X ncols = ncols - lenprev; X } X X if(strlen(tmp) > 0) { X list[i].s_pos = tmp; X list[i].no_ch = strlen(tmp); X } X return i; X} SHAR_EOF if [ `wc -c < action.c` -ne 5388 ] then echo "Lengths do not match -- Bad Copy of action.c" fi echo "Extracting file action.h" sed -e 's/^X//' <<\SHAR_EOF > action.h X/*1*/ "F1-Help ESC-Accept DEL-Quit", X/*2*/ "F1-Help ESC-Accept DEL-Quit F5-List", X/*3*/ "F1-Help ESC-Accept DEL-Quit F3-Super Reg F4-Region F6-Area F7-Country F8-Station F9-Route", X/*4*/ "F1-Help ESC-Accept DEL-Quit F3-Super Reg F4-Region F6-Area F7-Country F8-Station", X/*5*/ "F1-Help ESC-Accept DEL-Quit F3-Super Reg F4-Region F6-Area F7-Country", X/*6*/ "F1-Help DEL-Quit", X/*7*/ "F1-Help ESC-Accept DEL-Quit F7-Country F8-Station F9-Route", X/*8*/ "ESC-Accept DEL-Quit", X/*9*/ "F1-Help", X/*10*/ "F1-Help DEL-Quit F2-Refresh F3-Cancel F6-Detail", X/*11*/ "F1-Help DEL-Quit F2-Refresh F3-Cancel F4-User F6-Detail", X/*12*/ "DEL-Quit", SHAR_EOF if [ `wc -c < action.h` -ne 672 ] then echo "Lengths do not match -- Bad Copy of action.h" fi echo "Extracting file actline.4gl" sed -e 's/^X//' <<\SHAR_EOF > actline.4gl X{* 4gp source *} X{****************************************************************************** X* X* $Author: oasis $ X* X* $Date: 95/09/01 13:29:58 $ X* X* $Revision: 1.1 $ X* X* Doc Refs: OASIS Common Library functions X* X* Purpose: General purpose of the functions defined in this file. X* X* Usage: Description of each function in file and return values X* X* Library Names of any functions used that are NOT a part of the sources X* Functions: for this program. X* X* X* Modification Log X*=============================================================================== X* X* $Log: actline.4gp,v $ X* Revision 1.1 95/09/01 13:29:58 13:29:58 oasis (OASIS Source Administrator) X* Initial revision X* X* X*******************************************************************************} X{* X X*} X X{****************************************************************************** X* X* X* FUNCTION NAME: new_action X* X* AUTHOR: Mark Denham DATE: 10/09/91 X* X* PURPOSE: X* X* PARAMETERS: X* X* RETURNS: X* X* MODIFICATION LOG X* NAME DATE DESCRIPTION OF CHANGE X* Mark Denham 7-2-92 Change function to use win_width and X* win_last_line for the display of action line. X* This makes the ncols and act_line parameters X* redundant.win.last_line and win.w_width X* replace act_lineno and act_ncols respectively. X******************************************************************************} X XDEFINE act_msg CHAR(100), X action_ok, X saved_act_no INTEGER X X XFUNCTION dummy_actline() X X DEFINE rcsfileid CHAR(100) X X-- ******************** CHANGE THIS AS REQUIRED *************************** X X WHENEVER ANY ERROR CALL fatal_err X X LET rcsfileid = "$@(#)$Header: actline.4gp,v 1.1 95/09/01 13:29:58 oasis Exp $"; X XEND FUNCTION X XFUNCTION new_action(ncols, act_no, act_line) X X DEFINE curr_win SMALLINT, X ncols, X act_no, X act_line, X stat, X disp_line, X line_len, X bug_offset INTEGER, X win_dim RECORD X tlc_x INTEGER, X tlc_y INTEGER, X w_width INTEGER, X w_len INTEGER X END RECORD X X LET curr_win = curr_window() X X CALL window_dimensions() RETURNING win_dim.* X X IF( win_dim.tlc_x < 1 ) THEN X RETURN X END IF X X LET bug_offset = 2 X{ LET bug_offset = 3 { Bug in displaying } X { 2.10.03k } X X LET disp_line = win_dim.w_len X LET line_len = win_dim.w_width - bug_offset X INITIALIZE act_msg TO NULL X X IF( win_dim.w_width < 10 ) THEN X ERROR "new_action(): Too few columns for action_line. curr_win = ", Xcurr_win, " win.w_width = ", win_dim.w_width X RETURN X END IF X X IF( saved_act_no != act_no ) THEN X CALL action_line(line_len, 0, act_no) RETURNING stat, act_msg X LET saved_act_no = act_no X X{ LET act_msg = " ", act_msg clipped, " \b" { Handle 2.10.03k bug } X X DISPLAY " ", act_msg AT disp_line,1 ATTRIBUTE(reverse) X LET action_ok = stat X X IF( stat = FALSE ) THEN X ERROR "Invalid action number: ", act_no X END IF X END IF X XEND FUNCTION X X{****************************************************************************** X* X* X* FUNCTION NAME: next_action X* X* AUTHOR: Mark Denham DATE: 10/09/91 X* X* PURPOSE: X* X* PARAMETERS: X* X* RETURNS: X* X* MODIFICATION LOG X* NAME DATE DESCRIPTION OF CHANGE X* Mark Denham 2-7-92 See mod of same date to new_action function. X* Mark Denham 31-3-93 Missing " " in display statement. X******************************************************************************} X XFUNCTION next_action() X X DEFINE stat, X disp_line, X line_len INTEGER, X bug_offset SMALLINT, X win_dim RECORD X tlc_x INTEGER, X tlc_y INTEGER, X w_width INTEGER, X w_len INTEGER X END RECORD X X CALL window_dimensions() RETURNING win_dim.* X X X{ OPTIONS ERROR LINE LAST { Bug 2.10.03k do not } X { uncomment } X X LET bug_offset = 1 X LET disp_line = win_dim.w_len X LET line_len = win_dim.w_width - bug_offset X X IF( action_ok = TRUE ) THEN X CALL action_line(line_len, 1, 0) RETURNING stat, act_msg X X{ LET act_msg = " ", act_msg clipped, " \b" { Handle 2.10.03k bug } X X DISPLAY " ", act_msg AT disp_line,1 ATTRIBUTE(reverse) X X IF( stat = FALSE ) THEN X ERROR "Invalid function key pressed" X END IF X ELSE X ERROR "Action line has not been read" X END IF X XEND FUNCTION X X{****************************************************************************** X* X* X* FUNCTION NAME: prev_action X* X* AUTHOR: Mark Denham DATE: 10/09/91 X* X* PURPOSE: X* X* PARAMETERS: X* X* RETURNS: X* X* MODIFICATION LOG X* NAME DATE DESCRIPTION OF CHANGE X* Mark Denham 31-3-93 Missing " " in display statement. X******************************************************************************} X XFUNCTION prev_action() X X DEFINE stat, X disp_line, X line_len INTEGER, X bug_offset SMALLINT, X win_dim RECORD X tlc_x INTEGER, X tlc_y INTEGER, X w_width INTEGER, X w_len INTEGER X END RECORD X X CALL window_dimensions() RETURNING win_dim.* X X X{ OPTIONS ERROR LINE LAST { Bug 2.10.03k do not } X { uncomment } X X LET bug_offset = 1 X LET disp_line = win_dim.w_len X LET line_len = win_dim.w_width - bug_offset X X IF( action_ok = TRUE ) THEN X CALL action_line(line_len, -1, 0) RETURNING stat, act_msg X X{ LET act_msg = " ", act_msg CLIPPED, " \b" { Handle 2.10.03k bug } X X DISPLAY " ", act_msg at disp_line,1 ATTRIBUTE(reverse) X X IF( stat = FALSE ) THEN X ERROR "Invalid function key pressed" X END IF X ELSE X ERROR "Action line has not been read" X END IF X XEND FUNCTION X X{****************************************************************************** X* X* X* FUNCTION NAME: clear_action X* X* AUTHOR: Mark Denham DATE: 10/09/91 X* X* PURPOSE: X* X* PARAMETERS: X* X* RETURNS: X* X* MODIFICATION LOG X* NAME DATE DESCRIPTION OF CHANGE X******************************************************************************} X XFUNCTION clear_action() X X DEFINE stat, X disp_line INTEGER, X win_dim RECORD X tlc_x INTEGER, X tlc_y INTEGER, X w_width INTEGER, X w_len INTEGER X END RECORD X X CALL window_dimensions() RETURNING win_dim.* X X LET disp_line = win_dim.w_len X X CALL action_line(win_dim.w_width, 2, 0) RETURNING stat, act_msg X LET saved_act_no = -1 X X DISPLAY "" AT disp_line, 1 X XEND FUNCTION SHAR_EOF if [ `wc -c < actline.4gl` -ne 6598 ] then echo "Lengths do not match -- Bad Copy of actline.4gl" fi echo "Extracting file disperr.4gl" sed -e 's/^X//' <<\SHAR_EOF > disperr.4gl X{* 4gp source *} X{****************************************************************************** X* X* $Author: oasis $ X* X* $Date: 95/09/01 13:29:55 $ X* X* $Revision: 1.1 $ X* X* Doc Refs: OASIS Common Library functions X* X* Purpose: General purpose of the functions defined in this file. X* X* Usage: Description of each function in file and return values X* X* Library Names of any functions used that are NOT a part of the sources X* Functions: for this program. X* X* X* Modification Log X*=============================================================================== X* X* $Log: disperr.4gp,v $ X* Revision 1.1 95/09/01 13:29:55 13:29:55 oasis (OASIS Source Administrator) X* Initial revision X* X* X*******************************************************************************} X{* X X*} X X{****************************************************************************** X* X* X* FUNCTION NAME: display_err X* X* AUTHOR: Mark Denham DATE: 07/04/92 X* X* PURPOSE: X* X* PARAMETERS: X* X* RETURNS: X* X* TABLES USED: X* X* MODIFICATION LOG X* NAME DATE DESCRIPTION OF CHANGE X******************************************************************************} X X XFUNCTION dummy_disperr() X X DEFINE rcsfileid CHAR(100) X X-- ******************** CHANGE THIS AS REQUIRED *************************** X X WHENEVER ANY ERROR CALL fatal_err X X LET rcsfileid = "$@(#)$Header: disperr.4gp,v 1.1 95/09/01 13:29:55 oasis Exp $"; X XEND FUNCTION X Xfunction display_err(err_str) X X define err_str char(65), X ans char(1), X bell char(1) X X let bell = ASCII 7 X X open window disperr_win at 24,3 with 1 rows, 76 columns X attribute( reverse, prompt line 1) X X options accept key F34 X X while( TRUE ) X display bell at 1,1 X display bell, " " at 1,1 X prompt err_str clipped, " Press Return " for char ans X on key(ESC) X CONTINUE WHILE X on key(INTERRUPT) X CONTINUE WHILE X end prompt X if( ans is NULL ) then X exit while X end if X end while X X close window disperr_win X X call set_std_options() X X -- let int_flag = 0 X Xend function SHAR_EOF if [ `wc -c < disperr.4gl` -ne 2145 ] then echo "Lengths do not match -- Bad Copy of disperr.4gl" fi echo "Extracting file errlog.4gl" sed -e 's/^X//' <<\SHAR_EOF > errlog.4gl X{* 4gp source *} X{****************************************************************************** X* X* $Author: oasis $ X* X* $Date: 95/09/01 13:30:00 $ X* X* $Revision: 1.1 $ X* X* Doc Refs: OASIS Common Library functions X* X* Purpose: General purpose of the functions defined in this file. X* X* Usage: Description of each function in file and return values X* X* Library Names of any functions used that are NOT a part of the sources X* Functions: for this program. X* X* X* Modification Log X*=============================================================================== X* X* $Log: errlog.4gp,v $ X* Revision 1.1 95/09/01 13:30:00 13:30:00 oasis (OASIS Source Administrator) X* Initial revision X* X* X*******************************************************************************} X{* X X*} X XDEFINE _log_started INTEGER X X XFUNCTION dummy_errlog() X X DEFINE rcsfileid CHAR(100) X X-- ******************** CHANGE THIS AS REQUIRED *************************** X X WHENEVER ANY ERROR CALL fatal_err X X LET rcsfileid = "$@(#)$Header: errlog.4gp,v 1.1 95/09/01 13:30:00 oasis Exp $"; X XEND FUNCTION X XFUNCTION log_started() X X RETURN _log_started X XEND FUNCTION X XFUNCTION setup_errorlog() X X DEFINE logfiledir CHAR(300), X login_name CHAR(20), X logpathname CHAR(330) X X IF( _log_started = FALSE ) THEN X LET logfiledir = fgl_getenv("LOG_PATH") X X IF( logfiledir IS NULL ) THEN X ERROR "LOG_PATH environment variable not set!" X SLEEP 1 X EXIT PROGRAM 1 X END IF X X LET login_name = fgl_getenv("LOGNAME") { If su'ed then won't work as } X { expected. Wrong username. } X { most users don't su! } X X IF( login_name IS NULL ) THEN X ERROR "LOGNAME environment variable not set!" X SLEEP 1 X EXIT PROGRAM 2 X END IF X X { If we get this far, attempt to open the logfile } X X LET logpathname = logfiledir clipped, "/", login_name X X CALL startlog(logpathname clipped) X X END IF X X LET _log_started = TRUE X XEND FUNCTION X XFUNCTION write_log_msg(sql_err, sql_isam, err_msg) X X DEFINE sql_err INTEGER, X sql_isam INTEGER, X progname CHAR(100), X err_msg CHAR(300) X X LET progname = arg_val(0) X LET err_msg = progname CLIPPED, ":", err_msg CLIPPED X X IF( _log_started ) THEN X LET sqlca.sqlcode = sql_err X LET sqlca.sqlerrd[2] = sql_isam X CALL errorlog(err_msg clipped) X ELSE X ERROR progname CLIPPED, ": Error log not started!" X SLEEP 1 X EXIT PROGRAM 3 X END IF X XEND FUNCTION SHAR_EOF if [ `wc -c < errlog.4gl` -ne 2366 ] then echo "Lengths do not match -- Bad Copy of errlog.4gl" fi echo "Extracting file fgiusr.c" sed -e 's/^X//' <<\SHAR_EOF > fgiusr.c X/*************************************************************************** X * X * INFORMIX SOFTWARE, INC. X * X * PROPRIETARY DATA X * X * THIS DOCUMENT CONTAINS TRADE SECRET DATA WHICH IS THE PROPERTY OF X * INFORMIX SOFTWARE, INC. THIS DOCUMENT IS SUBMITTED TO RECIPIENT IN X * CONFIDENCE. INFORMATION CONTAINED HEREIN MAY NOT BE USED, COPIED OR X * DISCLOSED IN WHOLE OR IN PART EXCEPT AS PERMITTED BY WRITTEN AGREEMENT X * SIGNED BY AN OFFICER OF INFORMIX SOFTWARE, INC. X * X * THIS MATERIAL IS ALSO COPYRIGHTED AS AN UNPUBLISHED WORK UNDER X * SECTIONS 104 AND 408 OF TITLE 17 OF THE UNITED STATES CODE. X * UNAUTHORIZED USE, COPYING OR OTHER REPRODUCTION IS PROHIBITED BY LAW. X * X * X * Title: fgiusr.c X * Sccsid: @(#)fgiusr.c 8.1.1.1 7/23/91 17:46:23 X * Description: X * definition of user C functions X * X *************************************************************************** X */ X X/*************************************************************************** X * X * This table is for user-defined C functions. X * X * Each initializer has the form: X * X * "name", name, nargs, X * X * Variable # of arguments: X * X * set nargs to -(maximum # args) X * X * Be sure to declare name before the table and to leave the X * line of 0's at the end of the table. X * X * Example: X * X * You want to call your C function named "mycfunc" and it expects X * 2 arguments. You must declare it: X * X * int mycfunc(); X * X * and then insert an initializer for it in the table: X * X * "mycfunc", mycfunc, 2, X * X *************************************************************************** X */ X X#include "fgicfunc.h" X Xextern int fgl_putenv(); Xextern int action_line(); Xextern int split_string(); X Xcfunc_t usrcfuncs[] = X { X "fgl_putenv", fgl_putenv, 1, X "action_line", action_line, 3, X "split_string", split_string, 4, X 0, 0, 0 X }; SHAR_EOF if [ `wc -c < fgiusr.c` -ne 1833 ] then echo "Lengths do not match -- Bad Copy of fgiusr.c" fi echo "Extracting file fgl_putenv.c" sed -e 's/^X//' <<\SHAR_EOF > fgl_putenv.c X/* c source *} X{****************************************************************************** X* X* $Author$ X* X* $Date$ X* X* $Revision$ X* X* Doc Refs: X* X* Purpose: Allows an RDS program to set environment variables X* X* Usage: fgl_putenv string X* X* where: X* X* string char * Pointer to a string of the form NAME=value X* eg DBPATH=/users/oasis_run/oasis X* X* Library X* Functions: X* X* Notes: This function is MUST be linked with the RDS runner and debugger X* using the cfglgo and cfgldb commands. Refer to the Interactive X* debugger manual for details. X* X* Modification Log X*=============================================================================== X* X* $Log$ X* X*******************************************************************************} X/* X X*/ X Xint dummy_() { X X static char *rcsid = "@(#)$Header: $"; X X} X X X#include X#include X#include X X#define MAX_STR_SIZE 300 X Xtypedef struct envlist* envlistptr; X Xtypedef struct envlist { X envlistptr next; X char envstr[MAX_STR_SIZE]; X}; X Xint fgl_putenv(numargs) Xint numargs; X{ X envlistptr findvar(), new_item(); X X int putenv(); X char *strtok(); X X static envlistptr top = (envlistptr) NULL; X X envlistptr curr = top; X X register char newstr[300]; X X int rval = 0; X X if( numargs == 1 ) { X popquote(newstr, MAX_STR_SIZE-1); X strtok(newstr, " "); /* Convert first SPACE to NULL */ X X#ifdef DEBUG X fprintf(stderr, "\n\nputenv: DBPATH='%s'\n\n", newstr); X#endif X X if( (curr = findvar(top, newstr)) != (envlistptr) NULL ) { X strcpy(curr->envstr, newstr); X } X else { X /* Get new item */ X X if( (curr = new_item()) == (envlistptr) NULL ) { X X /* If space cannot be allocated, error */ X X rval = -2; X retint(rval); X return(1); X } X /* Add string and make this the top of the list */ X X strcpy(curr->envstr, newstr); X curr->next = top; X top = curr; X } X X rval = putenv(curr->envstr); /* Set the enviroment variable */ X } X else X rval = -1; X X sleep(3); X X retint(rval); X return(1); X} X Xenvlistptr new_item() X{ X void *malloc(); X X envlistptr new; X X#ifdef DEBUG X fprintf(stderr, "\nnew_item called\n"); X#endif X X new = (envlistptr) malloc((size_t) sizeof(struct envlist)); X X if( new != (envlistptr) NULL ) X init_item(new); X X#ifdef DEBUG X fprintf(stderr, "\nnew_item exited\n"); X#endif X X return new; X} X Xint init_item(item) Xregister envlistptr item; X{ X item->next = (envlistptr) NULL; X item->envstr[0] = '\0'; X} X Xenvlistptr findvar(curr, newstr) Xregister envlistptr curr; Xchar *newstr; X{ X char *strtok(); X X register X char varname1[50], X varname2[50], X tstr[MAX_STR_SIZE]; X X varname1[0] = varname2[0] = '\0'; X X#ifdef DEBUG X fprintf(stderr, "\nfindvar called\n"); X#endif X X strcpy(tstr, newstr); X X strcpy(varname1, strtok(tstr, "=")); X X#ifdef DEBUG X fprintf(stderr, "\nwhile starting\n"); X#endif X X while( curr != (envlistptr) NULL ) { X X#ifdef DEBUG X fprintf(stderr, "\ncurr=%d, envstr=%s\n", curr, curr->envstr); X#endif X X strcpy(tstr, curr->envstr); X strcpy(varname2, strtok(tstr, "=")); X if( strcmp(varname1, varname2) == 0 ) X break; X X curr=curr->next; X } X X#ifdef DEBUG X fprintf(stderr, "\nvarname1=%s\nvarname2=%s\n", varname1, varname2); X#endif X X return curr; X} SHAR_EOF if [ `wc -c < fgl_putenv.c` -ne 3182 ] then echo "Lengths do not match -- Bad Copy of fgl_putenv.c" fi echo "Extracting file frmtitle.4gl" sed -e 's/^X//' <<\SHAR_EOF > frmtitle.4gl X{* 4gp source *} X{****************************************************************************** X* X* $Author: oasis $ X* X* $Date: 95/09/01 13:30:17 $ X* X* $Revision: 1.1 $ X* X* Doc Refs: OASIS Common Library functions X* X* Purpose: General purpose of the functions defined in this file. X* X* Usage: Description of each function in file and return values X* X* Library Names of any functions used that are NOT a part of the sources X* Functions: for this program. X* X* X* Modification Log X*=============================================================================== X* X* $Log: frmtitle.4gp,v $ X* Revision 1.1 95/09/01 13:30:17 13:30:17 oasis (OASIS Source Administrator) X* Initial revision X* X* X*******************************************************************************} X{* X X*} X X{****************************************************************************** X* * X* FUNCTION NAME: form_title X* * X* AUTHOR: Mark Denham DATE: 10/09/91 * X* * X* PURPOSE: Displays form title, centred in the current window. X* * X* PARAMETERS: title char Text to display as form title X* * X* RETURNS: X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X* Mark Denham 7-2-92 Ignore parameter window_width and use global * X* win_width variable instead. This value is set * X* by all open_window functions in library. * X* Mark Denham 2-3-92 Force title to uppercase. * X* Mark Denham 23-3-92 Correct centring algorithm, replace - with +. * X******************************************************************************} X X XFUNCTION dummy_frmtitle() X X DEFINE rcsfileid CHAR(100) X X-- ******************** CHANGE THIS AS REQUIRED *************************** X X WHENEVER ANY ERROR CALL fatal_err X X LET rcsfileid = "$@(#)$Header: frmtitle.4gp,v 1.1 95/09/01 13:30:17 oasis Exp $"; X XEND FUNCTION X XFUNCTION form_title(title) X X DEFINE title CHAR(60), X startx INTEGER, X win_dim RECORD X tlc_x INTEGER, X tlc_y INTEGER, X w_width INTEGER, X w_len INTEGER X END RECORD X X CALL window_dimensions() RETURNING win_dim.* X X IF( win_dim.tlc_x > 0 ) THEN X LET startx = (win_dim.w_width - length(title CLIPPED))/2 + 1 X LET title = UPSHIFT(title) { Ensure uppercase } X X DISPLAY "" at 1,1 { Clear first 2 lines } X DISPLAY "" at 2,1 { of WINDOW ready to } X DISPLAY title CLIPPED at 1,startx ATTRIBUTE(white) { DISPLAY FORM title } X END IF X XEND FUNCTION X SHAR_EOF if [ `wc -c < frmtitle.4gl` -ne 2542 ] then echo "Lengths do not match -- Bad Copy of frmtitle.4gl" fi echo "Extracting file intract.4gl" sed -e 's/^X//' <<\SHAR_EOF > intract.4gl X{* 4gp source *} X{****************************************************************************** X* X* $Author: oasis $ X* X* $Date: 95/09/01 13:30:03 $ X* X* $Revision: 1.1 $ X* X* Doc Refs: OASIS Common Library functions X* X* Purpose: General purpose of the functions defined in this file. X* X* Usage: Description of each function in file and return values X* X* Library Names of any functions used that are NOT a part of the sources X* Functions: for this program. X* X* X* Modification Log X*=============================================================================== X* X* $Log: intract.4gp,v $ X* Revision 1.1 95/09/01 13:30:03 13:30:03 oasis (OASIS Source Administrator) X* Initial revision X* X* X*******************************************************************************} X{* X X*} X X-- This set of functions utilises the fact that informix intialises all global X-- ints to 0, which is treated as FALSE. If this is not true for the current X-- environment, then these functions need to be changed/ammended. X XDEFINE _interactive INTEGER X X XFUNCTION dummy_intract() X X DEFINE rcsfileid CHAR(100) X X-- ******************** CHANGE THIS AS REQUIRED *************************** X X WHENEVER ANY ERROR CALL fatal_err X X LET rcsfileid = "$@(#)$Header: intract.4gp,v 1.1 95/09/01 13:30:03 oasis Exp $"; X XEND FUNCTION X XFUNCTION set_interactive() X X LET _interactive = TRUE X XEND FUNCTION X XFUNCTION inter_active() X X CALL set_interactive() -- non-interactive programs not X -- supported yet, apps are not X -- using open_window functions X -- When they do, this can be X -- removed X X RETURN _interactive X XEND FUNCTION SHAR_EOF if [ `wc -c < intract.4gl` -ne 1634 ] then echo "Lengths do not match -- Bad Copy of intract.4gl" fi echo "Extracting file mainwin.4gl" sed -e 's/^X//' <<\SHAR_EOF > mainwin.4gl X{* 4gp source *} X{****************************************************************************** X* X* $Author: oasis $ X* X* $Date: 95/09/01 13:30:05 $ X* X* $Revision: 1.1 $ X* X* Doc Refs: OASIS Common Library functions X* X* Purpose: General purpose of the functions defined in this file. X* X* Usage: Description of each function in file and return values X* X* Library Names of any functions used that are NOT a part of the sources X* Functions: for this program. X* X* X* Modification Log X*=============================================================================== X* X* $Log: mainwin.4gp,v $ X* Revision 1.1 95/09/01 13:30:05 13:30:05 oasis (OASIS Source Administrator) X* Initial revision X* X* X*******************************************************************************} X{* X X*} X X{****************************************************************************** X* * X* FUNCTION NAME: open_mainwindow X* * X* AUTHOR: Mark Denham DATE: 16/01/92 * X* * X* PURPOSE: This function creates the main window, with a border for * X* the application. All entry level forms are displayed * X* within this window with any sub-windows being created by * X* calling open_inputwin/open_popup. * X* Ideally every program that forms part of your application * X* should cal this function if forms are going to be used. * X* This will ensure a consistent initial interface for the * X* users. * X* It should be modified as required to provide the type of * X* initial display you require. * X* * X* PARAMETERS: NONE * X* * X* RETURNS: NONE * X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X* Mark Denham 7-2-92 Set act_ncols and act_lineno to last line of * X* window, this saves the need specify them in * X* calls to new_action, next_action etc... * X* Mark Denham 17-2-92 Remove call to fatal_err. This is now handled * X* by whenever error fatal error. * X* Mark Denham 20-5-92 Allow enabling of SET EXPLAIN by reading the * X* environment variable SQL_EXPLAIN. This will * X* cause whole application to be profiled!! * X******************************************************************************} X XDEFINE _main_win SMALLINT X X XFUNCTION dummy_mainwin() X X DEFINE rcsfileid CHAR(100) X X-- ******************** CHANGE THIS AS REQUIRED *************************** X X WHENEVER ANY ERROR CALL fatal_err X X LET rcsfileid = "$@(#)$Header: mainwin.4gp,v 1.1 95/09/01 13:30:05 oasis Exp $"; X XEND FUNCTION X XFUNCTION open_mainwindow(version_no) X X DEFINE version_no CHAR(10), X datenow DATE, X ttynam CHAR(5) X X -- Ensure that main window is the first window opened X X IF( curr_window() > 1 ) then X CALL display_err("Main window MUST be first window opened!") X RETURN FALSE X END IF X X -- **** modify next 3 lines as you see fit **** X X LET datenow = today X-- LET ttynam = ttyid() X X DISPLAY "TERM ID: ", ttynam CLIPPED AT 1,67 X X -- **** Do not remove the following 4 lines **** X X LET _main_win = open_window(3, 3, 76, 21, TRUE) X X IF( _main_win = FALSE ) THEN X RETURN FALSE X END IF X X -- **** modify as you see fit **** X X DISPLAY "VERSION: ", version_no CLIPPED AT 1,2 X DISPLAY "YOUR TITLE HERE" AT 1,29 X DISPLAY datenow AT 1,65 X X -- **** end of modifiable area **** X X OPTIONS FORM LINE 3 X X RETURN TRUE X XEND FUNCTION X X{****************************************************************************** X* * X* FUNCTION NAME: close_mainwindow X* * X* AUTHOR: Mark Denham DATE: 16/01/92 * X* * X* PURPOSE: This function matches up with the open_mainwindow function* X* * X* PARAMETERS: NONE * X* * X* RETURNS: NONE * X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X* Mark Denham 17-2-92 Remove call to fatal_err. This is now handled * X* by whenever error fatal_err. * X******************************************************************************} X XFUNCTION close_mainwindow() X X IF( _main_win = FALSE ) THEN X CALL display_err("Main window has not been opened. Cannot close!") X RETURN X END IF X X IF( curr_window() = 1 ) THEN X IF( close_window(_main_win) = FALSE ) THEN X CALL display_err("Failed to close Main window") X END IF X ELSE X CALL display_err("Cannot close main window with other windows open!") X END IF X XEND FUNCTION X X{****************************************************************************** X* * X* FUNCTION NAME: clear_mainwindow X* * X* AUTHOR: Mark Denham DATE: 10/04/92 * X* * X* PURPOSE: Allow main window to be cleared. * X* * X* PARAMETERS: X* * X* RETURNS: X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X******************************************************************************} X XFUNCTION clear_mainwindow() X X IF( _main_win = 1 ) THEN X X IF( curr_window() = _main_win ) THEN X CLEAR window _main_win X END IF X X ELSE X CALL display_err("Cannot clear Main window. It has not been opened!") X END IF X XEND FUNCTION X SHAR_EOF if [ `wc -c < mainwin.4gl` -ne 5388 ] then echo "Lengths do not match -- Bad Copy of mainwin.4gl" fi echo "Extracting file make.common" sed -e 's/^X//' <<\SHAR_EOF > make.common X XBASE=/users X X# X# IF YOU WANT TO FORCE THE COMPILE TO USE ALL THE LIBRARIES IN THE OASIS X# BUILD AREA, INSTEAD OF ANY YOU HAVE DEFINED LOCALLY, CHANGE PROJECT TO X# oasis1. YOU WILL NEED TO EDIT THE PATHNAME FOR YOUR GLOBALSFILE X# ACCORDINGLY. X# X XPROJECT=oasis1 X XVERSION= X XGLOBALSFILE = X XGLOBAL4GL = $(GLOBALSFILE) X XGLOBAL4GO = $(GLOBALSFILE:.4gl=.4go) X XDBNAME= X XCPP_OPTS = -E -C -P X X.PRECIOUS: X X.SUFFIXES: .4go .4gl .4gp .ec .frm .per .pep .awk .sh .dat .h X X XINC_DIRS= \ X -I. \ X -I$(BASE)/$(PROJECT)/$(VERSION)/include/V2.0 \ X -I$(BASE)/$(PROJECT)/$(VERSION)/include X X X XLIB = libcomm.4go X X XLIBS = X X X XPER_SRC = X X XPERS = $(PER_SRC:.pep=.per) X X X XFRMS = $(PER_SRC:.pep=.frm) X X XOTH_SRC = \ X actline.4gp \ X disperr.4gp \ X errlog.4gp \ X frmtitle.4gp \ X intract.4gp \ X mainwin.4gp \ X opendb.4gp \ X popup.4gp \ X sql_lock.4gp \ X std_opts.4gp \ X totrows.4gp \ X trap_err.4gp \ X windows.4gp X X X XOTH_4GL = $(OTH_SRC:.4gp=.4gl) X X X X XOTH_4GO = $(OTH_SRC:.4gp=.4go) X X X X XRELEASE=$(BASE)/$(PROJECT)/$(VERSION)/$(RELDIR) X XRELEASE_LIB=$(RELEASE)/libs/V2.0 X X X XRELEASE_EXE=$(RELEASE)/bin X XRELEASE_FRM=$(RELEASE)/forms X XRELEASE_SH=$(RELEASE)/sh X XRELEASE_DAT=$(RELEASE)/dat X XRELEASE_ETC=$(RELEASE)/etc X XRELEASE_TXT=$(RELEASE)/sh X XRELEASE_AWK=$(RELEASE)/sh X X X X# X# RELEASE_TXT and RELEASE_AWK are not included in the REL_DIRS list because X# they are the same as RELEASE_SH. mkmake.sh will need to be modified if this X# situation changes to ensure that the new directory is created. X# X XREL_DIRS= $(RELEASE) $(RELEASE_EXE) $(RELEASE_FRM) $(RELEASE_SH) \ X $(RELEASE_DAT) $(RELEASE_ETC) $(RELEASE_LIB) $(RELEASE_INC) X X Xall: $(RELEASE_LIB) $(RELEASE_INC) $(INCL) $(EXE) $(FRMS) $(LIB) X -@[ -n "$(INCL)" ] && cpfiles.sh 444 $(RELEASE_INC) $(INCL) X -@[ -f "$(LIB)" ] && cpfiles.sh 644 $(RELEASE_LIB) $(LIB) X -@[ -f "`basename $(GLOBAL4GL)`" -a -z "$(MAIN_SRC)" -a -z "$(OTH_SRC)" ] \ X && cpfiles.sh 644 $(RELEASE_LIB) $(GLOBAL4GL) X @echo "Made: $?" X X X X XRELEASE: X @${MAKE} -f makefile -$(MAKEFLAGS) RELDIR=release REL X XREL: $(REL_DIRS) $(INCL) $(EXE) $(FRMS) $(LIB) $(SHELLS) $(AWKS) $(DATS) \ X $(TXTS) $(ETCS) X -@[ -n "$(INCL)" ] && cpfiles.sh 444 $(RELEASE_INC) $(INCL) X -@[ -n "$(EXE)" ] && cpfiles.sh 644 $(RELEASE_EXE) $(EXE) X -@[ -n "$(FRMS)" ] && cpfiles.sh 644 $(RELEASE_FRM) $(FRMS) X -@[ -f "$(LIB)" ] && cpfiles.sh 644 $(RELEASE_LIB) $(LIB) X -@[ -f "`basename $(GLOBAL4GL)`" -a -z "$(MAIN_SRC)" -a -z "$(OTH_SRC)" ] \ X && cpfiles.sh 644 $(RELEASE_LIB) $(GLOBAL4GL) X -@[ -n "$(SHELLS)" ] && cpfiles.sh 755 $(RELEASE_SH) $(SHELLS) X -@[ -n "$(AWKS)" ] && cpfiles.sh 644 $(RELEASE_AWK) $(AWKS) X -@[ -n "$(DATS)" ] && cpfiles.sh 644 $(RELEASE_DAT) $(DATS) X -@[ -n "$(TXTS)" ] && cpfiles.sh 644 $(RELEASE_TXT) $(TXTS) X -@[ -n "$(ETCS)" ] && cpfiles.sh 755 $(RELEASE_ETC) $(ETCS) X @echo "Made: $?" X X X X X$(REL_DIRS): X mkdir -p $@ X @chmod 755 $@ X X X X.4gp.4gl: X @echo "Pre-processing $< to create $*.4gl" X $(CC) $(CPP_OPTS) $(INC_DIRS) \ X -DDBNAME=$(DBNAME) -DGLOBALSFILE=\"$(GLOBALSFILE)\" $< >$*.4gl X X.4gl.4go: X @echo "Compiling $<" X @echo fglpc $< X @fglpc $< || ( [ "4gp" != "4gl" ] && rm -f $<; exit 1 ) X X.pep.per: X @echo "Pre-processing $< to create $*.per" X $(CC) $(CPP_OPTS) \ X -DDBNAME=$(DBNAME) -DGLOBALSFILE=\"$(GLOBALSFILE)\" $< | \ X grep -E -v "# [1-9]" >$*.per X X.per.frm: X @echo "Compiling $<" X @echo form4gl $< X @form4gl $< || ( [ "pep" != "per" ] && rm -f $<; exit 1 ) X X X X$(LIB): $(INCL) $(GLOBAL4GO) $(OTH_4GO) X cat $(GLOBAL4GO) $(OTH_4GO) >$@ X X X X$(MAIN_4GL) $(OTH_4GL):: $$(@:.4gl=.4gp) X X X X# X# If the globals file you are using is in the current directory, then X# uncomment the GLOBAL4GL rule below. X# If the GLOBAL4GO file is somewhere else then uncomment the GLOBAL4GO rule. X# For the GLOBAL4GL rule, DO NOT REMOVE LEADING TAB from the line with a ':'. X# If you do not need a globals file at all, leave both lines commented. X# X X#$(GLOBAL4GO): $(GLOBAL4GL) X# @: # Dummy action, MUST remain!!!! X X#$(GLOBAL4GL): $(GLOBAL4GP) X X X Xclean: X -rm -f $(EXE) $(LIB) X -rm -f $(MAIN_4GO) $(OTH_4GO) $(FRMS) X -[ -f "`basename $(GLOBAL4GO)`" ] && rm -f `basename $(GLOBAL4GO)` X Xcleanall: X -rm -f $(GLOBALSFILE:.4gl=.err) X -rm -f $(MAIN_SRC:.4gp=.err) $(OTH_SRC:.4gp=.err) $(PER_SRC:.pep=.err) X -rm -f $(OTH_4GL) $(MAIN_4GL) $(PERS) X -[ -f "`basename $(GLOBAL4GL)`" ] && rm -f `basename $(GLOBAL4GL)` X make clean X X SHAR_EOF if [ `wc -c < make.common` -ne 4321 ] then echo "Lengths do not match -- Bad Copy of make.common" fi echo "Extracting file opendb.4gl" sed -e 's/^X//' <<\SHAR_EOF > opendb.4gl X{* 4gp source *} X{****************************************************************************** X* X* $Author: oasis $ X* X* $Date: 95/09/01 13:30:08 $ X* X* $Revision: 1.1 $ X* X* Doc Refs: OASIS Common Library functons Common library functions X* X* Purpose: Sets up the program runtime database environment as follows: X* 1) Opens db indicated by lc_dbname. If this is NULL the X* default database specified by the environment variable X* is used. X* 2) Sets the length of time that programs will wait for a lock X* before exiting. Default is 5 mins. An ONLINE environment X* is assumed. X* 3) Sets the ISOLATION level, default of DIRTY READ X* 4) Sets SQL EXPLAIN, default off. X* X* If an error occurs, the error is logged in a log file. X* This function is part of the libcomm set of 4GL routines. X* X* Usage: open_database(lc_dbname) X* X* where: X* lc_dbname char Name of database to open, can be NULL X* X* Library None X* Functions: X* X* Modification Log X*=============================================================================== X* X* $Log: opendb.4gp,v $ X* Revision 1.1 95/09/01 13:30:08 13:30:08 oasis (OASIS Source Administrator) X* Initial revision X* XRevision 1.1 95/08/01 16:11:49 16:11:49 oasis (OASIS Source Administrator) XInitial revision X X* X*******************************************************************************} X{* X X*} X X X XFUNCTION dummy_opendb() X X DEFINE rcsfileid CHAR(100) X X-- ******************** CHANGE THIS AS REQUIRED *************************** X X WHENEVER ANY ERROR CALL fatal_err X X LET rcsfileid = "$@(#)$Header: opendb.4gp,v 1.1 95/09/01 13:30:08 oasis Exp $"; X XEND FUNCTION X XFUNCTION open_database(lc_dbname) X X DEFINE lc_dbname CHAR(18), X ls_timeoutval SMALLINT, X lc_dbwait CHAR(1), X lc_sqlexplain CHAR(1), X lc_isolation CHAR(6), X lc_sql_str char(100) X X WHENEVER ANY ERROR CALL fatal_err X X LET lc_dbwait = fgl_getenv("DBWAIT") X X IF( lc_dbwait IS NULL ) THEN X LET lc_dbwait = 'y' -- Default to WAIT X END IF X X LET ls_timeoutval = fgl_getenv("DBTIMEOUT") X X IF( ls_timeoutval IS NULL ) THEN X LET ls_timeoutval = 5 * 60 -- Default to 5 min wait X END IF X X LET lc_isolation = fgl_getenv("DBISOLATION") -- If not set, use inf default X X LET lc_sqlexplain = fgl_getenv("DBEXPLAIN") X X IF( lc_sqlexplain IS NULL ) THEN X LET lc_sqlexplain = 'n' -- Default to no explain output X END IF X X IF( lc_dbname IS NULL ) THEN X LET lc_dbname = fgl_getenv("DBNAME") X END IF X X IF( lc_dbname IS NULL ) THEN X CALL errorlog("DBNAME environment variable not set!") X EXIT PROGRAM 1 X END IF X X DATABASE lc_dbname X X IF( lc_dbwait MATCHES "[Yy]" ) THEN X X LET lc_sql_str = "SET LOCK MODE TO WAIT ", ls_timeoutval X X PREPARE l_lockstmt FROM lc_sql_str X EXECUTE l_lockstmt X FREE l_lockstmt X ELSE X SET LOCK MODE TO NOT WAIT X END IF X X CASE X WHEN lc_isolation = "DIRTY" X X SET ISOLATION TO DIRTY READ X X WHEN lc_isolation = "COMMIT" X X SET ISOLATION TO COMMITTED READ X X WHEN lc_isolation = "REPEAT" X X SET ISOLATION TO REPEATABLE READ X X WHEN lc_isolation = "CURSOR" X X SET ISOLATION TO CURSOR STABILITY X X END CASE X X IF( lc_sqlexplain MATCHES "[Yy]" ) THEN X SET EXPLAIN ON X END IF X XEND FUNCTION SHAR_EOF if [ `wc -c < opendb.4gl` -ne 3166 ] then echo "Lengths do not match -- Bad Copy of opendb.4gl" fi echo "Extracting file popup.4gl" sed -e 's/^X//' <<\SHAR_EOF > popup.4gl X{* 4gp source *} X{****************************************************************************** X* X* $Author: oasis $ X* X* $Date: 95/09/01 13:30:10 $ X* X* $Revision: 1.1 $ X* X* Doc Refs: OASIS Common Library functions X* X* Purpose: General purpose of the functions defined in this file. X* X* Usage: Description of each function in file and return values X* X* Library Names of any functions used that are NOT a part of the sources X* Functions: for this program. X* X* X* Modification Log X*=============================================================================== X* X* $Log: popup.4gp,v $ X* Revision 1.1 95/09/01 13:30:10 13:30:10 oasis (OASIS Source Administrator) X* Initial revision X* X* X*******************************************************************************} X{* X X*} X X{****************************************************************************** X* * X* FUNCTION NAME: open_popup X* * X* AUTHOR: Mark Denham DATE: 10/09/91 * X* * X* PURPOSE: X* * X* PARAMETERS: X* * X* RETURNS: X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X* Mark Denham 7-2-92 Set win[].* structure up for use by * X* action line and form title functions etc. * X* Mark Denham 17-2-92 Remove calls to fatal_err. This is now handled* X* by whenever error fatal_err. * X* Mark Denham 12-2-92 Initialize pop_rec_idx FOR new window. * X******************************************************************************} X XDEFINE pop_data ARRAY[1000] OF RECORD X inp_fld CHAR(1), X disp_dat CHAR(76) X END RECORD, X pop_rec_idx INTEGER X XDEFINE _pop_win SMALLINT X X XFUNCTION dummy_popup() X X DEFINE rcsfileid CHAR(100) X X-- ******************** CHANGE THIS AS REQUIRED *************************** X X WHENEVER ANY ERROR CALL fatal_err X X LET rcsfileid = "$@(#)$Header: popup.4gp,v 1.1 95/09/01 13:30:10 oasis Exp $"; X XEND FUNCTION X XFUNCTION open_popup(rowno, colno, ncols) X X DEFINE rowno, { Caller is expected to determine } X colno, { the window position and width. } X ncols, { The size is calculated so that } X nrows INTEGER { the bottom of the window border } X { covers the border of the parent } X { window. } X X IF( _pop_win > 0 ) THEN X CALL display_err("Popup is already open!") X RETURN X END IF X X LET nrows = 24 - (rowno + 1) { Allow for error line (add 1) } X X LET _pop_win = open_window(colno, rowno, ncols, nrows) X X IF( _pop_win > 0 ) THEN X LET pop_rec_idx = 0 { Init pop_data array index to 0 } X X CALL pop_data_init(1) X END IF X XEND FUNCTION X X{****************************************************************************** X* * X* FUNCTION NAME: close_popup X* * X* AUTHOR: Mark Denham DATE: 10/09/91 * X* * X* PURPOSE: X* * X* PARAMETERS: X* * X* RETURNS: X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X* Mark Denham 7-2-92 Remove latest entry from win[].* stack. * X* Mark Denham 17-2-92 Remove calls to fatal_err. This is now handled* X* by whenever error fatal_err. * X******************************************************************************} X XFUNCTION close_popup() X X IF( _pop_win > 0 ) THEN X CALL close_window(_pop_win) X END IF X XEND FUNCTION X X{****************************************************************************** X* * X* FUNCTION NAME: pop_data_init * X* * X* AUTHOR: Mark Denham DATE: 6/4/92 * X* * X* PURPOSE: This function initializes the pop_data structure with NULL* X* VALUES. It only initializes the NEXT 40 elements of the * X* structure in ORDER BY to avoid unncessary work being done.* X* This FUNCTION is particularly important FOR the correct * X* functioning of page up and page down. * X* It is called by open_popup. * X* * X* PARAMETERS: NONE * X* * X* RETURNS: NONE * X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X******************************************************************************} X XFUNCTION pop_data_init(strt_idx) X X DEFINE strt_idx, X idx INTEGER, X null_row RECORD X inp_fld CHAR(1), X disp_dat CHAR(76) X END RECORD X X INITIALIZE null_row.* to NULL X FOR idx = strt_idx TO strt_idx + 30 { More than page size } X LET pop_data[idx].* = null_row.* {Initialize CURRENT} X IF( idx = 1000 ) THEN { We have reached } X EXIT FOR { ARRAY boundary } X END IF X END FOR X XEND FUNCTION X X{****************************************************************************** X* * X* FUNCTION NAME: pop_put_line * X* * X* AUTHOR: Mark Denham DATE: 12/2/92 * X* * X* PURPOSE: This function adds a row to the pop_data structure. It * X* must be used in conjuction with open_popup, close_popup * X* and get_pop_line. * X* * X* PARAMETERS: str string Data to add to pop_data. This * X* represents 1 row of data to be * X* displayed in the popup. * X* * X* RETURNS: TRUE Row was added to pop_data successfully. * X* FALSE Row not added (ie pop_data array boundary * X* reached) * X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X* Mark Denham 30/3/92 Initialize ARRAY when pop_rec_idx is 1 to * X* ensure that no garbage is left behind FROM an * X* earlier CALL of this FUNCTION. * X* Mark Denham 6/4/92 Undo above change, CREATE pop_data_init fn. * X******************************************************************************} X XFUNCTION pop_put_line(text_rec) X X DEFINE text_rec CHAR(76), { This is the max } X { width allowed for} X idx INTEGER X X LET pop_rec_idx = pop_rec_idx + 1 { Increment index } X X IF( pop_rec_idx = 1000 ) THEN { text line in } X RETURN FALSE { bordered window } X END IF X X LET pop_data[pop_rec_idx].disp_dat = text_rec CLIPPED { and save data } X LET pop_data[pop_rec_idx].inp_fld = NULL { Clear input fld } X X RETURN TRUE X XEND FUNCTION X X{****************************************************************************** X* * X* FUNCTION NAME: pop_get_line * X* * X* AUTHOR: Mark Denham DATE: 12/2/92 * X* * X* PURPOSE: This function displays the records in pop_data and reads * X* user input to determine what to do. The user may move up * X* and down through the list of rows using the cursor keys, * X* PGUP/PGDN or by entering the first letter of the group of * X* rows that they are interested in. (ie pressing the letter * X* E will result in the array being scrolled until the first * X* row that begins will an E has been found). The current row* X* is highlighted by a reverse cursor bar. This row is * X* returned to the calling function if the user presses * X* . If is selected -1 and the null string are* X* returned. * X* * X* PARAMETERS: helpno integer Help message number. The relevant * X* help message will be displayed if * X* the key is pressed. * X* * X* RETURNS: pop_data[idx].disp_dat The row selected on or * X* a Null string on . * X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X* Mark Denham 24/02/92 Return index of selected row along with the * X* text string for the row, this allows the * X* programmer to determine which row was chosen * X* from a cursor, saving the need to split the * X* text string up to retrieve the required info. * X* Mark Denham 12/03/92 Update function to take advantage of 4GL V4.1.* X* THIS FUNCTION IS NOT COMPATIBLE WITH V4.0 due * X* to extended features, notably it is possible * X* to prevent pagedown, down arrow etc from * X* advancing the user to a blank row in a much * X* better manner (4.0 requires you to exit input)* X* Mark Denham 20-3-92 Poke about with function to overcome 4.1 bug. * X* AUTONEXT doesn't work at all with INPUT ARRAY.* X* The problem occurs IF the user uses the right * X* arrow key or the "character search" function. * X* To compound the problem fgl_lastkey returns * X* 2018 when the user exits a FIELD with AUTONEXT* X* ATTRIBUTE using the right arrow key instead of* X* returning the keys' value - 2003 so you cannot* X* detect the offending key press yourself. * X* Mark Denham 27-3-92 Leave the 'CURRENT line' highlighted when the * X* user is running the search facility. * X* Mark Denham 1-4-92 Added pop_data_loaded flag to cater for being * X* called without any data. * X* Mark Denham 15-4-92 Add check in OTHERWISE part of CASE in AFTER * X* FIELD inp_fld. This code prevents the user * X* FROM performing an INSERT. Add new case to * X* trap when the up/PGUP keys have been pressed. * X* This ensures that up arrow works as it should * X******************************************************************************} X XFUNCTION pop_get_line(helpno) X X DEFINE helpno, { Help file message no. for popup } X lno, { Screen line no. for current line} X idx, { Index of current row in pop_data} X sidx, { Index of row found by search fn } X key_val, { Value of last key pressed } X key_code, X pop_data_loaded, { Flag to indicate rows loaded } X not_exit, { Flag used to control input } X { termination } X cursor_bar_on, { Control display of highlight bar} X srch_forwd, { Search direction flag, see F2 } X action_no, { Action line number } X pagelen, { Number of records on screen } X tpagelen, { Used when DOWN key pressed } X nextpage_pressed INTEGER { Flag to indicate pagedn pressed } X X OPTIONS INSERT KEY F32, { Disable insert key } X COMMENT LINE LAST - 2, X {input no wrap,} X INPUT ATTRIBUTE(normal), { Popup all in white to handle all } X DISPLAY ATTRIBUTE(normal) { terminal types. } X X LET pop_data_loaded = TRUE X IF( pop_rec_idx = 0 ) THEN { Ensure that IF no data has been } X LET pop_rec_idx = 1 { loaded, at least a blank row is } X LET pop_data_loaded = FALSE { useful is returned to application} X END IF X LET pagelen = 0 X LET nextpage_pressed = FALSE X LET cursor_bar_on = FALSE X LET sidx = -1 X LET not_exit = TRUE X LET srch_forwd = TRUE X X LET action_no = 6 X CALL new_action(0,action_no,0) { Display action line } X X WHILE( not_exit ) X CALL set_count(pop_rec_idx) { Set no of rows in array to no. of} X { filled rows. } X X INPUT ARRAY pop_data X WITHOUT DEFAULTS X FROM s_rec.* X X { ***** BEFORE ROW PROCESSING ***** } X { Save current array line and screen line indexes. Ensure that } X { user cannot go beyond last filled in row. Check if the } X { user had selected to search for a record by pressing any non } X { cursor key (sidx is not -1). If search chosen then force the } X { input array scroll to the desired line by performing a next } X { field on pop_data.disp_dat, the display only field. Finally } X { display the current line in reverse to create the highlight } X { bar and set cursor_bar_on (this is to try to make things a } X { bit more efficient). } X X BEFORE ROW X X LET idx = arr_curr() X IF( nextpage_pressed = TRUE ) THEN X LET pagelen = idx - pagelen { Work out page size } X LET nextpage_pressed = -1 X X { Only necessary to exit input if NEXTPAGE is pressed for } X { the first time and we have advanced beyond the end of } X { the pick list. } X X IF( pop_data[idx].disp_dat IS NULL ) THEN X LET sidx = pop_rec_idx X EXIT INPUT X END IF X END IF X X LET lno = scr_line() X IF( sidx > 0 ) THEN X IF( idx != sidx ) THEN X NEXT FIELD s_rec.disp_dat X END IF X LET sidx = -1 X END IF X X IF( NOT cursor_bar_on ) THEN X DISPLAY pop_data[idx].disp_dat X TO s_rec[lno].disp_dat X ATTRIBUTE(reverse) X LET cursor_bar_on = TRUE X END IF X X { ***** AFTER ROW PROCESSING ***** } X { This bit checks to see if the user pressed a non cursor key. } X { If they have, findidx is used to get the offset of the row } X { in the array. If no row exists with the key then -1 is returned} X { and the error message is displayed. The input field is nulled } X { and if the highlight bar is on it is turned off and the } X { cursor_bar_on flag is set to FALSE. Finally if the index of the } X { row returned by search is before the current row the input is } X { terminated and restarted from the top of the array. } X X AFTER ROW X IF( cursor_bar_on ) THEN X DISPLAY pop_data[idx].disp_dat X TO s_rec[lno].disp_dat X ATTRIBUTE(normal) X LET cursor_bar_on = FALSE X END IF X IF( sidx > 0 AND sidx < idx ) THEN X EXIT INPUT X END IF X X BEFORE FIELD inp_fld X X MESSAGE "Displaying record ", idx CLIPPED, X " of ", pop_rec_idx X X { ***** AFTER FIELD PROCESSING ***** } X X AFTER FIELD inp_fld X CLEAR inp_fld { Don't display input } X { For 4.1 with search } X { pop-up, disallow all} X IF( pop_data[idx].inp_fld is not NULL ) THEN {non-cursor } X ERROR "Invalid FUNCTION key pressed" { keys } X LET pop_data[idx].inp_fld = NULL { Clear out field} X NEXT FIELD s_rec.inp_fld X END IF X X{ ***** COMMENTED OUT. REPLACED WITH PATTERN SEARCH FUNCTION ****** } X{ IF( pop_data[idx].inp_fld IS NOT NULL ) THEN X LET sidx = findidx(pop_data[idx].inp_fld, idx, srch_forwd) X END IF X IF( sidx = -1 ) THEN X ERROR "No records begin with ", pop_data[idx].inp_fld, X " in the direction you are searching" X LET sidx = 0 X LET pop_data[idx].inp_fld = NULL { Clear out input field} X{ NEXT FIELD s_rec.inp_fld X END IF X X***** END OF COMMENTED OUT CODE *******} X X LET key_val = fgl_lastkey() X CASE X { No bugs here so allow informix to handle it } X X WHEN key_val = 2000 OR key_val = fgl_keyval("up") OR X key_val = 2006 OR key_val = fgl_keyval("prevpage") OR X key_val = 2016 OR key_val = fgl_keyval("esc") X X EXIT CASE X X WHEN key_val = 2001 OR key_val = fgl_keyval("down") X X IF( pagelen < lno ) THEN { Work out pagelen when } X LET pagelen = lno { down arrow used too. } X END IF X IF( pop_data[idx+1].disp_dat IS NULL ) THEN X ERROR "There are no more rows in the direction you are going" X NEXT FIELD s_rec.inp_fld X END If X EXIT CASE X X WHEN key_val = 2005 OR key_val = fgl_keyval("nextpage") X X IF( (idx + pagelen) > pop_rec_idx ) THEN X ERROR "There are no more rows in the direction you are going" X NEXT FIELD s_rec.inp_fld X X { Try to get Informix to throw away this key press } X { and THEN force a NEXT FIELD to move to the END of} X { the INPUT list. This won't work until 4.11 rel } X {call dummy_input() X NEXT FIELD s_rec.inp_fld} X END IF X IF( nextpage_pressed = FALSE ) THEN X LET pagelen = idx { Save current row for } X LET nextpage_pressed = TRUE {working out screen len} X END IF X EXIT CASE X X WHEN key_val = 2002 OR key_val = fgl_keyval("left") X X ERROR "Invalid function key" X NEXT FIELD s_rec.inp_fld X EXIT CASE X X WHEN key_val = 2018 OR key_val = fgl_keyval("right") X X { key_val = 2003 when right arrow pressed except for } X { autonext fields!!!! } X { This code is to get round informix bug in 4.1 } X { 2018 code is returned when right arrow is pressed } X { and when any other key A-Z etc is pressed. Since } X { non-CURSOR keys will result in data being saved } X { in your INPUT FIELD a check FOR NULL is a useful } X { way of determining what the user did ie entered } X { data or pressed the right arrow key. } X X IF( sidx = -1 ) THEN X ERROR "Invalid function key" X NEXT FIELD s_rec.inp_fld X END IF X EXIT CASE X X OTHERWISE X { For any other key assume cursor will attempt to } X { move down a row in the list } X X IF( sidx = -1 AND idx + 1 > pop_rec_idx ) THEN X ERROR "There are no more rows in the direction you are going" X NEXT FIELD s_rec.inp_fld X END IF X X END CASE X X { ***** AFTER INPUT PROCESSING ***** } X X AFTER INPUT X LET not_exit = FALSE { Ensure exit from while } X X { ***** INTERRUPT HANDLING ***** } X X ON KEY(interrupt) X LET not_exit = FALSE { Ensure exit from while } X EXIT INPUT X X { ***** HELP KEY PROCESSING ***** } X X ON KEY(F1) X CALL showhelp(helpno) X X {ON KEY(F2) X CALL clear_action() X{**** CURRENT LINE IS HIGHLIGHTED IN SEARCH. **** X **** SO THIS BIT IS COMMENTED OUT ALONG WITH THE OTHER BIT BELOW **** X X DISPLAY pop_data[idx].disp_dat X TO s_rec[lno].disp_dat X ATTRIBUTE(normal) X X **** normally CALL findidx here **** X X DISPLAY pop_data[idx].disp_dat X TO s_rec[lno].disp_dat X ATTRIBUTE(reverse) X} X {LET sidx = find_pattern(idx) X CALL new_action(0, action_no, 0) X IF( sidx > -1 ) THEN X NEXT FIELD s_rec.disp_dat X ELSE X CONTINUE INPUT X END IF X} X{******** COMMENTED OUT. THIS CODE WAS USED TO CHANGE SEARCH DIRN. *********} X X{ ON KEY(F2) { Change search direction } X{ IF( srch_forwd ) THEN { Search backwards } X{ LET srch_forwd = FALSE X LET action_no = 5 X CALL new_action(0, action_no, 0) X ELSE X LET srch_forwd = TRUE { Search forwards } X{ LET action_no = 6 X CALL new_action(0, action_no, 0) X END IF X NEXT FIELD s_rec.inp_fld X} X {ON KEY(LEFT) X ON KEY(RIGHT) X ERROR "Use UP/DOWN arrows or PAGE UP/DOWN to move cursor"} X X X ON KEY(F10) X CALL next_action() X X ON KEY(F20,F22) X call prev_action() X END INPUT X END WHILE X X CALL set_std_options() X CALL clear_action() X X IF( int_flag = 0 AND pop_data_loaded ) THEN X LET idx = arr_curr() X RETURN idx, pop_data[idx].disp_dat X END IF X X RETURN -1, "" { pressed } X XEND FUNCTION X X{ This function is used to try to CLEAR the INPUT buffer of the FUNCTION key } X{ that has just been pressed. } X X{****************************************************************************** X* * X* FUNCTION NAME: dummy_input X* * X* AUTHOR: Mark Denham DATE: 07/04/92 * X* * X* PURPOSE: X* * X* PARAMETERS: X* * X* RETURNS: X* * X* TABLES USED: X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X******************************************************************************} X XFUNCTION dummy_input() X X DEFINE dummy_char CHAR(1) X X INPUT dummy_char X FROM s_rec.inp_fld X X BEFORE field inp_fld X EXIT INPUT X END INPUT X XEND FUNCTION X X{****************************************************************************** X* * X* FUNCTION NAME: find_pattern X* * X* AUTHOR: Mark Denham DATE: 07/04/92 * X* * X* PURPOSE: Allows user to enter a search pattern and to choose the * X* direction of the search (up/down) the list. The index of * X* the first entry found that matches the pattern. * X* * X* PARAMETERS: list_strt INTEGER Index of current line in program * X* array. * X* * X* RETURNS: line_idx INTEGER Index of first line found to match* X* pattern OR * X* -1 IF no match found/DEL pressed. * X* * X* TABLES USED: NONE * X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X******************************************************************************} X XFUNCTION find_pattern(list_strt) X X DEFINE searchwin SMALLINT, X list_strt, X top_left_x, X top_left_y, X nrows, X find_exact, X srch_fwd, X i, X line_idx INTEGER, X backward CHAR(1), X pattern, X tpattern CHAR(30), X win_dim RECORD X tlc_x INTEGER, X tlc_y INTEGER, X w_width INTEGER, X w_len INTEGER X END RECORD X X INITIALIZE tpattern, backward TO NULL X LET line_idx = -1 X LET top_left_x = win_dim.tlc_x + 2 X LET top_left_y = win_dim.w_len - 9 + 5 X X { Get current windows size and location FROM win structure and use it to } X { determine WHERE to DISPLAY this window. } X X LET nrows = 24 - (top_left_y + 1) { Allow for error line } X X LET searchwin = open_window(top_left_x, top_left_y, 33, nrows) X X IF( searchwin < 1 ) THEN X CALL display_err("Could not open search window!") X RETURN X END IF X X OPEN FORM searchfrm FROM "search" X X DISPLAY FORM searchfrm X X CALL new_action(0, 1, 0) X X WHILE( line_idx = -1 ) X MENU " Find" X COMMAND "Exact" X " Find line starting with pattern" X X LET find_exact = TRUE X EXIT MENU X X COMMAND "Matches" X " Find line containing pattern" X X LET find_exact = FALSE X EXIT MENU X X COMMAND KEY(interrupt) X X EXIT MENU X END MENU X X IF( int_flag ) THEN X EXIT WHILE X END IF X X LET pattern = tpattern X X INPUT X backward, X pattern X WITHOUT DEFAULTS X FROM X s_rec.backward, X pattern X X AFTER FIELD pattern X IF( find_exact ) THEN X FOR i = 1 to (length(pattern)) X IF( pattern[i] = '\*' ) THEN X CALL display_err("You cannot use '*' in exact pattern search.") X CONTINUE INPUT X END IF X END FOR X END IF X X AFTER INPUT X IF( pattern is NULL ) THEN { Treat LIKE abort } X LET int_flag = 1 X EXIT INPUT X END IF X LET tpattern = pattern CLIPPED X IF( not find_exact ) THEN X IF( pattern[1] != '\*' ) THEN X LET pattern = '\*', pattern CLIPPED X END IF X END IF X LET i = length(pattern) X IF( pattern[i] != '\*' ) THEN X LET pattern[i+1] = '\*' X END IF X X ON KEY(interrupt) X EXIT INPUT X X END INPUT X X IF( int_flag ) THEN X EXIT WHILE X END IF X X IF( backward = "X" ) THEN X LET srch_fwd = FALSE X ELSE X LET srch_fwd = TRUE X END IF X X LET line_idx = findidx(pattern, list_strt, srch_fwd) X IF( line_idx = -1 ) THEN X ERROR "Pattern not found. Re-enter pattern or press to abort." X END IF X END WHILE X X CALL clear_action() X CLOSE FORM searchfrm X CALL close_window(searchwin) X X LET int_flag = 0 X RETURN line_idx X XEND FUNCTION X X{****************************************************************************** X* * X* FUNCTION NAME: findidx * X* * X* AUTHOR: Mark Denham DATE: 12/2/92 * X* * X* PURPOSE: This function searches the pop_data array for the first * X* record that begins with the search character entered by * X* the user. The direction used for searching is determined * X* by the srch_forwd parameter. If this is TRUE searching is * X* performed in a forward direction (default), otherwise the * X* search is performed in the reverse direction. In either * X* the first record that matches the key is chosen. * X* * X* PARAMETERS: letter char Key letter to search for. * X* list_start integer Start index in array. We are * X* searching forwards/backwards from * X* this array entry. * X* srch_forwd integer TRUE if search is from list_start * X* to the end of array. * X* FALSE if search is from start of * X* array to list_start (backwards). * X* * X* RETURNS: idx integer Index of first matching line or * X* -1 if there was no match. * X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X******************************************************************************} X XFUNCTION findidx(pattern, list_start, srch_forwd) X X DEFINE pattern CHAR(25), X tstr CHAR(76), X list_start, X srch_forwd, X patlen, { length of pattern } X idx, X tidx INTEGER X X LET patlen = length(pattern) - 1 {Length of search str} X X IF( srch_forwd ) THEN X { First search from current position to end of list to find } X { new list pos. In searching we ignore leading spaces...but we } X { also do not need to look further into the pattern string than} X { the length of the search pattern itself, this is due to the } X { fact that if the pattern to find is longer than the string } X { to be searched then we can never find the pattern...get it? } X X FOR idx = (list_start + 1) TO 1000 X FOR tidx = 1 TO (76 - patlen) {Ignore leading spaces} X IF( pop_data[idx].disp_dat[tidx] != ' ' ) THEN X EXIT FOR X END IF X END FOR X LET tstr = pop_data[idx].disp_dat[tidx,76] X IF( tstr MATCHES pattern ) then X RETURN idx X END IF X END FOR X ELSE X { Find first line backwards beginning with key } X X FOR tidx = 1 TO 76 { Ignore leadig spaces } X IF( pop_data[idx].disp_dat[tidx] != ' ' ) THEN X EXIT FOR X END IF X END FOR X LET tstr = pop_data[idx].disp_dat[tidx,76] X FOR idx = (list_start - 1) TO 1 STEP -1 X IF( pop_data[idx].disp_dat MATCHES pattern ) THEN X RETURN idx X END IF X END FOR X END IF X X RETURN -1 { Unnecessary, here for completeness } X XEND FUNCTION X SHAR_EOF if [ `wc -c < popup.4gl` -ne 25771 ] then echo "Lengths do not match -- Bad Copy of popup.4gl" fi echo "Extracting file split.c" sed -e 's/^X//' <<\SHAR_EOF > split.c X/* c source *} X{****************************************************************************** X* X* $Author$ X* X* $Date$ X* X* $Revision$ X* X* Doc Refs: X* X* Purpose: Allows an RDS program to split a string using a delimiter X* given by the user. X* X* Usage: split_string string String to split. X* delimiter Delimiter string. X* returns Max no. of strings to return. X* When there are less strings in X* source than returns and strict is X* FALSE, null strings are returned X* for the remaining values. X* strict If set causes the routine to return X* a failure status if the number of X* elements in string does not match X* the number specified by returns. X* X* where: X* X* string char[5120] Null terminated string to split. X* delimiter char[10] Null terminated delimiter string. X* returns smallint Max. no. of strings to return. X* strict integer TRUE/FALSE. Causes function to X* fail when no. of strings found X* does not match returns. X* X* Returns: stat integer 0 for ok, -ve as below: X* -1 = Too few strings in source X* -2 = retcnt > MAX_STRINGS X* -3 = Source contains more strs X* str[0..n] string As many strings as required. X* X* Library X* Functions: X* X* Notes: WHEN USING RDS. X* This function is MUST be linked with the RDS runner and debugger X* using the cfglgo and cfgldb commands. Refer to the Interactive X* debugger manual for details. X* If you have a NULL value separated by 2 delimiters, X* fred||john|... X* This routine will not produce the result you expect! X* X* Modification Log X*=============================================================================== X* X* $Log$ X* X*******************************************************************************} X/* X X*/ X Xint dummy_string_split() { X X static char *rcsid = "@(#)$Header: $"; X X} X X X#include X#include X X#define MAX_STRINGS 320 X X#define MAX_DELIM_LEN 10 X X#define MAX_STR_SIZE 5120 X Xint split_string(numargs) Xint numargs; X{ X char *strtok(); X X char src_string[MAX_STR_SIZE+1]; X X char delim[MAX_DELIM_LEN+1]; X X char *strlist[MAX_STRINGS]; X X char *nullstr = "", X *str; X X register int curridx = 0, X idx = 0; X X int strict = 0, X retcnt = 0, X stat = 0; X X if( numargs != 4 ) { /* This is a problem and cannot easily */ X stat=-1; /* 4GL will most likely produce an error*/ X retint(stat); /* indicating that the no. of returned */ X return(1); /* values is incorrect....*/ X } X X /* Read parameter list */ X X popint(&strict); X popint(&retcnt); X popvchar(delim, MAX_DELIM_LEN); X popvchar(src_string, MAX_STR_SIZE); X X /* Check that the no. strings required does not exceed max allowed */ X X if( retcnt <= MAX_STRINGS ) { X str = src_string; X X /* Split up string, fail if srtict and end of source string reached */ X X for(; curridx < retcnt; curridx++) { X strlist[curridx] = strtok(str, delim); X str = NULL; X if( strict && strlist[curridx] == NULL ) { X stat = -1; X break; X } X } X } X else X stat = -2; X X if( stat == 0 ) { X if( strict ) { X /* See if the source string is empty, if not fail */ X X if(strtok(str, delim) != NULL ) X stat = -3; X } X } X X /* Return extraction status */ X X retint(stat); X X /* Return all filled in values, may help debugging when an error occurs */ X X for(idx=0; idx < curridx; idx++ ) { X retvchar(strlist[idx]); X } X X /* Now do rest of strings, if any */ X X while(idx < retcnt) { X retvchar(nullstr); X idx++; X } X X return(idx+1); X} X SHAR_EOF if [ `wc -c < split.c` -ne 3552 ] then echo "Lengths do not match -- Bad Copy of split.c" fi echo "Extracting file sql_lock.4gl" sed -e 's/^X//' <<\SHAR_EOF > sql_lock.4gl X{* 4gp source *} X{****************************************************************************** X* X* $Author: oasis $ X* X* $Date: 95/09/01 13:30:13 $ X* X* $Revision: 1.1 $ X* X* Doc Refs: OASIS Common Library functions X* X* Purpose: General purpose of the functions defined in this file. X* X* Usage: Description of each function in file and return values X* X* Library Names of any functions used that are NOT a part of the sources X* Functions: for this program. X* X* X* Modification Log X*=============================================================================== X* X* $Log: sql_lock.4gp,v $ X* Revision 1.1 95/09/01 13:30:13 13:30:13 oasis (OASIS Source Administrator) X* Initial revision X* X* X*******************************************************************************} X{* X X*} X X{****************************************************************************** X* * X* FUNCTION NAME: data_locked * X* * X* AUTHOR: Mark Denham DATE: 17/02/92 * X* * X* PURPOSE: This function checks to see if the status of the last * X* completed 4gl action returned a locked status. If it did * X* then this function returns TRUE, otherwise it returns * X* false. After each call to this function the library global* X* sql_lock is reset to FALSE. sql_lock is set explicitly by * X* calls to fatal_err. * X* * X* PARAMETERS: NONE * X* * X* RETURNS: TRUE Last SQL operation failed due to a lock. * X* FALSE Some other error occured * X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X******************************************************************************} X XDEFINE _sql_lock INTEGER X XFUNCTION dummy_sql_lock() X X DEFINE rcsfileid CHAR(100) X X-- ******************** CHANGE THIS AS REQUIRED *************************** X X WHENEVER ANY ERROR CALL fatal_err X X LET rcsfileid = "$@(#)$Header: sql_lock.4gp,v 1.1 95/09/01 13:30:13 oasis Exp $"; X XEND FUNCTION X XFUNCTION data_locked() X X DEFINE rval INTEGER X X LET rval = _sql_lock X X LET _sql_lock = FALSE X X RETURN rval X XEND FUNCTION X X{****************************************************************************** X* * X* FUNCTION NAME: set_sql_lock * X* * X* AUTHOR: Mark Denham DATE: 26/07/95 * X* * X* PURPOSE: Sets the _sql_lock variable that is used to determine if * X* a lock problem has occured. This function is called by * X* fatal_err. * X* * X* PARAMETERS: NONE * X* * X* RETURNS: NONE * X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X******************************************************************************} X XFUNCTION set_sql_lock() X X let _sql_lock = TRUE X XEND FUNCTION X X{****************************************************************************** X* * X* FUNCTION NAME: unset_sql_lock * X* * X* AUTHOR: Mark Denham DATE: 26/07/95 * X* * X* PURPOSE: Unsets the _sql_lock variable that is used to determine if* X* a lock problem has occured. This function is called by * X* fatal_err. * X* * X* PARAMETERS: NONE * X* * X* RETURNS: NONE * X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X******************************************************************************} X XFUNCTION unset_sql_lock() X X LET _sql_lock = FALSE X XEND FUNCTION SHAR_EOF if [ `wc -c < sql_lock.4gl` -ne 3761 ] then echo "Lengths do not match -- Bad Copy of sql_lock.4gl" fi echo "Extracting file std_opts.4gl" sed -e 's/^X//' <<\SHAR_EOF > std_opts.4gl X{* 4gp source *} X{****************************************************************************** X* X* $Author: oasis $ X* X* $Date: 95/09/21 11:32:40 $ X* X* $Revision: 1.2 $ X* X* Doc Refs: OASIS Common Library functions X* X* Purpose: General purpose of the functions defined in this file. X* X* Usage: Description of each function in file and return values X* X* Library Names of any functions used that are NOT a part of the sources X* Functions: for this program. X* X* X* Modification Log X*=============================================================================== X* X* $Log: std_opts.4gp,v $ X* Revision 1.2 95/09/21 11:32:40 11:32:40 oasis (OASIS Source Administrator) X* Commented out the DISPLAY/INPUT ATTIBUTES since they cause RDS to override X* the DISPLAY attributes used in BEFORE/AFTER field statements. X* M. Denham 210995 X* X* Revision 1.1 95/09/01 13:30:15 13:30:15 oasis (OASIS Source Administrator) X* Initial revision X* X* X*******************************************************************************} X{* X X*} X X{****************************************************************************** X* * X* FUNCTION NAME: set_std_options X* * X* AUTHOR: Mark Denham DATE: 16/01/92 * X* * X* PURPOSE: Set options for application ie form line, message line etc* X* This function makes it possible for screens that are * X* handled in a different manner (ie forced to use non-std * X* settings to reset them for the rest of the application * X* afterwards. The options chosen are picked to minimise the * X* differences between 'common' keys from one third party * X* product (ie Informix/Wordperfect) to another, for example * X* Wordperfect uses F1 for help, so do we. * X* * X* PARAMETERS: X* * X* RETURNS: X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X* Mark Denham 17-2-92 Change whenever error continue to whenever * X* error fatal_err() as per isd5 program standard* X* Mark Denham 26-2-92 Remove whenever error statement. * X******************************************************************************} X X XFUNCTION dummy_std_opts() X X DEFINE rcsfileid CHAR(100) X X-- ******************** CHANGE THIS AS REQUIRED *************************** X X WHENEVER ANY ERROR CALL fatal_err X X LET rcsfileid = "$@(#)$Header: std_opts.4gp,v 1.2 95/09/21 11:32:40 oasis Exp $"; X XEND FUNCTION X Xfunction set_std_options() X X if( log_started() = FALSE ) then X call setup_errorlog() X end if X X { Some notes on why these settings have been used: } X { 1) next/previous key are set to ambiguose codes because PC keyboards } X { are being used, these have PGUP/PGDN keys. } X { 2) The colours chosen are largely only for demos and development, in } X { reality the user terminals don't have them. } X { 3) Input wrap was chosen so that the user has time to ensure that } X { they are happy with what they have got on the screen and are } X { required to press a key to take any action. } X { 4) Prompt, message and comment lines are the same because bordered } X { windows are used and the number of lines available is assumed to } X { be a maximum of 24 (allowing for small screens). } X { 5) The delete key is disabled, any input array that allows delete } X { must handle it specifically. This allows for confirmed deletion/ } X { undeletion of rows in the list. } X { 6) The accept key is set specifically so that changes to its default } X { value do not permiate through the application (ie this function } X { resets ALL default options. } X X options X{ X display attribute(normal), X input attribute(normal), X} X input wrap, X error line 24, X prompt line last - 1, X comment line last - 1, X message line last - 1, X form line 3, X accept key ESC, { Set accept explicitly } X help key F1, X{ X help file HELPPATHNAME, X} X insert key F4, X next key F35, { Hopefully user won't press } X previous key F34, { Hopefully user won't press } X delete key F36 { Hopefully user won't press } X Xend function X SHAR_EOF if [ `wc -c < std_opts.4gl` -ne 4182 ] then echo "Lengths do not match -- Bad Copy of std_opts.4gl" fi echo "Extracting file totrows.4gl" sed -e 's/^X//' <<\SHAR_EOF > totrows.4gl X{* 4gp source *} X{****************************************************************************** X* X* $Author: oasis $ X* X* $Date: 95/09/01 13:30:20 $ X* X* $Revision: 1.1 $ X* X* Doc Refs: OASIS Common Library Functions X* X* Purpose: General purpose of the functions defined in this file. X* X* Usage: Description of each function in file and return values X* X* Library Names of any functions used that are NOT a part of the sources X* Functions: for this program. X* X* X* Modification Log X*=============================================================================== X* X* $Log: totrows.4gp,v $ X* Revision 1.1 95/09/01 13:30:20 13:30:20 oasis (OASIS Source Administrator) X* Initial revision X* X* X*******************************************************************************} X{* X X*} X X{****************************************************************************** X* * X* FUNCTION NAME: total_rows X* * X* AUTHOR: Mark Denham DATE: 10/09/91 * X* * X* PURPOSE: X* * X* PARAMETERS: X* * X* RETURNS: X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X* Mark Denham 17-2-92 Remove calls to fatal_err. This is now handled* X* by whenever error fatal_err. * X* Mark Denham 3-4-92 Call data_locked function after open to check * X* for locks. Return -1 if true. * X******************************************************************************} X X XFUNCTION dummy_totrows() X X DEFINE rcsfileid CHAR(100) X X-- ******************** CHANGE THIS AS REQUIRED *************************** X X WHENEVER ANY ERROR CALL fatal_err X X LET rcsfileid = "$@(#)$Header: totrows.4gp,v 1.1 95/09/01 13:30:20 oasis Exp $"; X XEND FUNCTION X Xfunction total_rows(t_list, where_clause) X X define t_list char(100), X where_clause char(2000), X sel_stmt char(2300), X n_rows integer X X let sel_stmt = "select count(*) from ", t_list clipped, " where" X let sel_stmt = sel_stmt clipped, " ", where_clause clipped X X prepare tot_sel from sel_stmt X X declare tot_cur cursor for tot_sel X X open tot_cur X X IF( NOT data_locked() ) THEN X fetch tot_cur into n_rows X X close tot_cur X ELSE X RETURN -1 X END IF X X free tot_sel X X return n_rows X Xend function X SHAR_EOF if [ `wc -c < totrows.4gl` -ne 2281 ] then echo "Lengths do not match -- Bad Copy of totrows.4gl" fi echo "Extracting file trap_err.4gl" sed -e 's/^X//' <<\SHAR_EOF > trap_err.4gl X{* 4gp source *} X{****************************************************************************** X* X* $Author: oasis $ X* X* $Date: 95/09/01 13:30:22 $ X* X* $Revision: 1.1 $ X* X* Doc Refs: OASIS Common Library functions X* X* Purpose: General purpose of the functions defined in this file. X* X* Usage: Description of each function in file and return values X* X* Library Names of any functions used that are NOT a part of the sources X* Functions: for this program. X* X* X* Modification Log X*=============================================================================== X* X* $Log: trap_err.4gp,v $ X* Revision 1.1 95/09/01 13:30:22 13:30:22 oasis (OASIS Source Administrator) X* Initial revision X* X* X*******************************************************************************} X{* X X*} X X{****************************************************************************** X* * X* FUNCTION NAME: fatal_err * X* * X* AUTHOR: Mark Denham DATE: 17/02/92 * X* * X* PURPOSE: THIS FUNCTION MUST BE THE FIRST ONE IN THE SOURCE FILE. * X* This function is called whenever a 4gl error occurs. It * X* checks to see if the failure has been caused by a lock * X* event, if it has then the variable sql_lock is set to TRUE* X* and this function returns control to the application. If * X* the error has been caused by some other event then an * X* error message is printed into the error log file opened * X* by set_std_options and an application error message is * X* displayed to the user. In this case the program terminates* X* * X* PARAMETERS: NONE * X* * X* RETURNS: NONE * X* * X* MODIFICATION LOG * X* NAME DATE DESCRIPTION OF CHANGE * X* Mark Denham 26-2-92 Add whenever error call fatal_err to the end * X* of this function so that the rest of the * X* source file will call this routine by default.* X******************************************************************************} X X XFUNCTION dummy_trap_err() X X DEFINE rcsfileid CHAR(100) X X-- ******************** CHANGE THIS AS REQUIRED *************************** X X WHENEVER ANY ERROR CALL fatal_err X X LET rcsfileid = "$@(#)$Header: trap_err.4gp,v 1.1 95/09/01 13:30:22 oasis Exp $"; X XEND FUNCTION X Xfunction fatal_err() X X define sql_status integer, X sql_isam integer, X errmsg char(100) X X let sql_status = sqlca.sqlcode X let sql_isam = sqlca.sqlerrd[2] X X call unset_sql_lock() X X case( sql_status ) X X { *** ROW LEVEL LOCKS *** } X X when -107 { C-ISAM error: locked by other user } X call set_sql_lock() X return X when -233 { Cannot read record locked by other } X call set_sql_lock() X return X when -250 { Cannot read record for update } X call set_sql_lock() X return X when -263 { Row could not be locked for update } X call set_sql_lock() X return X when -378 { Record locked by another user } X call set_sql_lock() X return X X { *** TABLE LEVEL LOCKS *** } X X when -400 { Fetch failed on unopened cursor } X call set_sql_lock() X return X when -215 { Cannot open file for table } X call set_sql_lock() X return X when -242 { Could not open database table } X call set_sql_lock() X return X when -288 { Table not locked by current user } X call set_sql_lock() X return X when -289 { Cannot lock table in shared mode } X call set_sql_lock() X return X when -291 { Table is already locked } X call set_sql_lock() X return X when -503 { Too many tables locked } X call set_sql_lock() X return X X { *** NO CURRENT ROW *** } X X when -245 { Could not get next row } X call set_sql_lock() X return X when -266 { No current row } X call set_sql_lock() X return X when -262 { No current cursor } X call set_sql_lock() X return X end case X X whenever any error continue X X call write_log_msg(sql_status, sql_isam, "Program terminating due to fatal error") X X if( inter_active() = TRUE ) then X call display_err("A fatal error has occurred") X end if X X rollback work X close database X X exit program 10 X Xend function X SHAR_EOF if [ `wc -c < trap_err.4gl` -ne 4192 ] then echo "Lengths do not match -- Bad Copy of trap_err.4gl" fi echo "Extracting file windows.4gl" sed -e 's/^X//' <<\SHAR_EOF > windows.4gl X{* 4gp source *} X{****************************************************************************** X* X* $Author: oasis $ X* X* $Date: 95/09/01 13:30:24 $ X* X* $Revision: 1.1 $ X* X* Doc Refs: OASIS Common Library functions X* X* Purpose: General purpose of the functions defined in this file. X* X* Usage: Description of each function in file and return values X* X* Library Names of any functions used that are NOT a part of the sources X* Functions: for this program. X* X* X* Modification Log X*=============================================================================== X* X* $Log: windows.4gp,v $ X* Revision 1.1 95/09/01 13:30:24 13:30:24 oasis (OASIS Source Administrator) X* Initial revision X* X* X*******************************************************************************} X{* X X*} X XDEFINE _win ARRAY[10] OF RECORD X w_tlc_x INTEGER, X w_tlc_y INTEGER, X w_width INTEGER, X w_len INTEGER, X w_border INTEGER X end record, X _curr_win INTEGER, X _max_win INTEGER, X _window_init INTEGER X X XFUNCTION dummy_windows() X X DEFINE rcsfileid CHAR(100) X X-- ******************** CHANGE THIS AS REQUIRED *************************** X X WHENEVER ANY ERROR CALL fatal_err X X LET rcsfileid = "$@(#)$Header: windows.4gp,v 1.1 95/09/01 13:30:24 oasis Exp $"; X XEND FUNCTION X XFUNCTION win_setup() X X DEFINE i SMALLINT X X CALL set_interactive() { Let fatal_err know to write } X { errors to tty } X X -- Just in case this has not been called, do it here. X X CALL set_std_options() X X LET _max_win = 10 X LET _curr_win = 0 X FOR i = 1 TO 10 X LET _win[i].w_tlc_x = -1 X END FOR X X LET _window_init = TRUE X XEND FUNCTION X XFUNCTION open_window(top_x, top_y, width, len, border_reqd) X X DEFINE top_x, top_y, X width, len, X border_reqd INTEGER X X -- Ensure that the first time this routine is called that all structs are X -- initialised. X X IF( _window_init = FALSE ) THEN X CALL win_setup() X END IF X X CASE X WHEN _curr_win = 0 X IF( border_reqd ) THEN X OPEN WINDOW win1 AT top_y,top_x X WITH len ROWS, width COLUMNS ATTRIBUTE(border) X ELSE X OPEN WINDOW win1 AT top_y,top_x X WITH len ROWS, width COLUMNS X END IF X EXIT CASE X X WHEN _curr_win = 1 X IF( border_reqd ) THEN X OPEN WINDOW win2 AT top_y,top_x X WITH len ROWS, width COLUMNS ATTRIBUTE(border) X ELSE X OPEN WINDOW win2 AT top_y,top_x X WITH len ROWS, width COLUMNS X END IF X EXIT CASE X X WHEN _curr_win = 2 X IF( border_reqd ) THEN X OPEN WINDOW win3 AT top_y,top_x X WITH len ROWS, width COLUMNS ATTRIBUTE(border) X ELSE X OPEN WINDOW win3 AT top_y,top_x X WITH len ROWS, width COLUMNS X END IF X EXIT CASE X X WHEN _curr_win = 3 X IF( border_reqd ) THEN X OPEN WINDOW win4 AT top_y,top_x X WITH len ROWS, width COLUMNS ATTRIBUTE(border) X ELSE X OPEN WINDOW win4 AT top_y,top_x X WITH len ROWS, width COLUMNS X END IF X EXIT CASE X X WHEN _curr_win = 4 X IF( border_reqd ) THEN X OPEN WINDOW win5 AT top_y,top_x X WITH len ROWS, width COLUMNS ATTRIBUTE(border) X ELSE X OPEN WINDOW win5 AT top_y,top_x X WITH len ROWS, width COLUMNS X END IF X EXIT CASE X X WHEN _curr_win = 5 X IF( border_reqd ) THEN X OPEN WINDOW win5 AT top_y,top_x X WITH len ROWS, width COLUMNS ATTRIBUTE(border) X ELSE X OPEN WINDOW win5 AT top_y,top_x X WITH len ROWS, width COLUMNS X END IF X EXIT CASE X X WHEN _curr_win = 6 X IF( border_reqd ) THEN X OPEN WINDOW win6 AT top_y,top_x X WITH len ROWS, width COLUMNS ATTRIBUTE(border) X ELSE X OPEN WINDOW win6 AT top_y,top_x X WITH len ROWS, width COLUMNS X END IF X EXIT CASE X X WHEN _curr_win = 7 X IF( border_reqd ) THEN X OPEN WINDOW win7 AT top_y,top_x X WITH len ROWS, width COLUMNS ATTRIBUTE(border) X ELSE X OPEN WINDOW win7 AT top_y,top_x X WITH len ROWS, width COLUMNS X END IF X EXIT CASE X X WHEN _curr_win = 8 X IF( border_reqd ) THEN X OPEN WINDOW win8 AT top_y,top_x X WITH len ROWS, width COLUMNS ATTRIBUTE(border) X ELSE X OPEN WINDOW win8 AT top_y,top_x X WITH len ROWS, width COLUMNS X END IF X EXIT CASE X X WHEN _curr_win = 9 X IF( border_reqd ) THEN X OPEN WINDOW win9 AT top_y,top_x X WITH len ROWS, width COLUMNS ATTRIBUTE(border) X ELSE X OPEN WINDOW win9 AT top_y,top_x X WITH len ROWS, width COLUMNS X END IF X EXIT CASE X X WHEN _curr_win = 10 X IF( border_reqd ) THEN X OPEN WINDOW win10 AT top_y,top_x X WITH len ROWS, width COLUMNS ATTRIBUTE(border) X ELSE X OPEN WINDOW win10 AT top_y,top_x X WITH len ROWS, width COLUMNS X END IF X EXIT CASE X X OTHERWISE X CALL display_err("Too many windows opened") X RETURN FALSE X X END CASE X X LET _curr_win = _curr_win + 1 X LET _win[_curr_win].w_tlc_x = top_x X LET _win[_curr_win].w_tlc_y = top_y X LET _win[_curr_win].w_width = width X LET _win[_curr_win].w_len = len X LET _win[_curr_win].w_border = border_reqd X X RETURN _curr_win X XEND FUNCTION X XFUNCTION close_window(win_no) X X DEFINE win_no INTEGER, X rval INTEGER, X i SMALLINT, X errstr CHAR(80) X X CASE X WHEN win_no = 1 X CLOSE WINDOW win1 X LET rval = TRUE X EXIT CASE X X WHEN win_no = 2 X CLOSE WINDOW win2 X LET rval = TRUE X EXIT CASE X X WHEN win_no = 3 X CLOSE WINDOW win3 X LET rval = TRUE X EXIT CASE X X WHEN win_no = 4 X CLOSE WINDOW win4 X LET rval = TRUE X EXIT CASE X X WHEN win_no = 5 X CLOSE WINDOW win5 X LET rval = TRUE X EXIT CASE X X WHEN win_no = 6 X CLOSE WINDOW win6 X LET rval = TRUE X EXIT CASE X X WHEN win_no = 7 X CLOSE WINDOW win7 X LET rval = TRUE X EXIT CASE X X WHEN win_no = 8 X CLOSE WINDOW win8 X LET rval = TRUE X EXIT CASE X X WHEN win_no = 9 X CLOSE WINDOW win9 X LET rval = TRUE X EXIT CASE X X WHEN win_no = 10 X CLOSE WINDOW win10 X LET rval = TRUE X EXIT CASE X X OTHERWISE X CALL display_err("Invalid window number") X LET rval = FALSE X EXIT CASE X END CASE X X IF( rval = TRUE ) THEN X LET _win[win_no].w_tlc_x = -1 X LET _win[win_no].w_tlc_y = -1 X LET _win[win_no].w_width = -1 X LET _win[win_no].w_len = -1 X LET _win[win_no].w_border = FALSE X X FOR i = 5 TO 0 STEP -1 X IF( i = 0 ) THEN X EXIT FOR X END IF X X IF( _win[i].w_tlc_x != -1 ) THEN X LET rval = change_window(i) X EXIT FOR X END IF X END FOR X END IF X X RETURN rval X XEND FUNCTION X XFUNCTION change_window(win_no) X X DEFINE win_no INTEGER, X rval INTEGER, X errstr CHAR(80) X X CASE X WHEN win_no = 1 X CURRENT WINDOW IS win1 X LET rval = TRUE X EXIT CASE X X WHEN win_no = 2 X CURRENT WINDOW IS win2 X LET rval = TRUE X EXIT CASE X X WHEN win_no = 3 X CURRENT WINDOW IS win3 X LET rval = TRUE X EXIT CASE X X WHEN win_no = 4 X CURRENT WINDOW IS win4 X LET rval = TRUE X EXIT CASE X X WHEN win_no = 5 X CURRENT WINDOW IS win5 X LET rval = TRUE X EXIT CASE X X OTHERWISE X LET errstr = "Invalid window number(", win_no USING "##", X ") specified" X CALL display_err(errstr CLIPPED) X LET rval = FALSE X EXIT CASE X END CASE X X IF( rval = TRUE ) THEN X LET _curr_win = win_no X END IF X X RETURN rval X XEND FUNCTION X XFUNCTION curr_window() X X RETURN _curr_win X XEND FUNCTION X XFUNCTION windows_initialised() X X RETURN _window_init X XEND FUNCTION X XFUNCTION window_dimensions() X X IF( _curr_win > 0 ) THEN X X RETURN _win[_curr_win].w_tlc_x, X _win[_curr_win].w_tlc_y, X _win[_curr_win].w_width, X _win[_curr_win].w_len X X ELSE X CALL display_err("No windows setup!") X END IF X X -- Return default set of values X X RETURN _win[1].w_tlc_x, X _win[1].w_tlc_y, X _win[1].w_width, X _win[1].w_len X XEND FUNCTION SHAR_EOF if [ `wc -c < windows.4gl` -ne 7465 ] then echo "Lengths do not match -- Bad Copy of windows.4gl" fi echo "Done." exit 0