#---------------------------------- cut here ---------------------------------- # This is a shell archive. Remove anything before this line, # then unpack it by saving it in a file and typing "sh file". # # This archive contains: # Makefile coxxc04.4gl coxxq01.4gl coxxq01a.per # coxxq01b.per coxxq01c.per coxxq01d.per coxxq01e.per # coxxq01f.per coxxq01g.per coxxq01h.per coxxq01i.per # coxxq01j.per coxxx03.4gl misql.4gl misql.per # # Error checking via wc(1) will be performed. LANG=""; export LANG PATH=/bin:/usr/bin:/usr/sbin:/usr/ccs/bin:$PATH; export PATH echo x - Makefile sed 's/^@//' >Makefile <<'@EOF' @.SUFFIXES : @.SUFFIXES : .4ge .a .o .4gl .ec .c .frm .per .arc .ace .exe .msg @.SUFFIXES: .4go .src .hlp #if not .IGNORE then test can't be used @.IGNORE : #INFORMIXDIR = /usr/informix INFORMIXBIN = $(INFORMIXDIR)/bin C4GL = $(INFORMIXBIN)/c4gl CFORM= form4gl CFLAGS = -O LIBS = @.4gl.o: cd $( $@ forms: misql.frm coxxq01a.frm coxxq01b.frm coxxq01c.frm coxxq01d.frm coxxq01e.frm coxxq01f.frm coxxq01g.frm coxxq01h.frm coxxq01i.frm coxxq01j.frm @EOF set `wc -lwc coxxc04.4gl <<'@EOF' # $Id: coxxc04.4gl,v 2.17 1996/01/22 04:49:02 liz Exp $ {****************************************************************************** * Filename: coxxc04.4gl * * System : Eunice 4GL - Library Module * * Purpose : round() a value. Get the abs()olute value * * Returns : * * Author : Unknown * * * * 14/09/94 Kerry S - Added "is_blank". Dunno if this is the right place tho' * * 14/09/94 Kerry S - Added "updated". I guess I've just made this file a bit * * of a dumping ground for little aimless functions * * 05/10/94 Kerry S - And "is_number". * * 02/12/94 Kerry S - Added "max" and "min" * * 07/12/94 Kerry S - nvl now handles money fields * * 27/01/95 Kerry S - "round" only rounded accurately to 2dp! * * 08/02/95 Kerry S - Use Jack Parker's is_number 'cause it copes with an * * unusual Informix bug * * 10/02/95 Kerry S - Added "bwz" - blank when zero. Nice for reports * * 25/08/95 Julia R - Added "is_numeric" this also checks for symbols passed * * 29/08/95 Kerry S - Added "!" to the "is_numeric" symbol list * * 29/11/95 Eric H - didn't allow more than 4 decimals precision * * 17/01/95 GBA - 'is_numeric' allowed a '!' but should check for '!=' * * 22/01/96 EJD - Added 'calc_percent' to calculate a percentage and store* * the result in a variable of a given size. * * * ******************************************************************************} #! round(amount, precision) RETURNs rounded amount #! - Rounds "amount" to "precision" decimal places #! #! abs(amount) RETURNs absolute value #! - eg: if amount = -35 abs will return 35. #! #! is_blank(variable) RETURNS TRUE/FALSE #! - if variable is NULL or = " " then returns TRUE #! #! is_number(variable) RETURNs TRUE/FALSE #! - if variable is numeric then returns TRUE #! #! updated() RETURNS number of rows updated #! - Returns the number of rows updated by the preceeding #! UPDATE (ie: SQLCA.SQLERRD[3]) #! #! maxval(value1, value2) RETURNs the larger of the two parameters #! #! minval(value1, value2) RETURNs the smaller of the two parameters #! #! nvl(oldvalue, newvalue) RETURNs newvalue if oldvalue is null #! - oldvalue - The value that is to be compared to null. #! - newvalue - The value to return if value is null. #! #! - Returns newvalue if oldvalue is null, otherwise #! returns oldvalue #! #! bwz(value) RETURNs a blank when value is zero #! (this is ideal for reporting) #! #! is_numeric(l_string) RETURNs True or False if a numeric field, handles #! passed symbols eg. < > = | etc. #! #! trunc(value, precision) RETURNs value truncated to precision decimal places #! - value - The value to truncate #! - precision - The number of decimal place to truncate to. #! If you want to truncate to figures before the #! decimal place, use negative numbers. #! calc_percent(numerator, demoninator, size) RETURNs percentage #! to a maximum size required FUNCTION nvl(l_original, l_if_null) DEFINE l_original CHAR(80), l_if_null CHAR(80) IF LENGTH(l_original) = 0 THEN RETURN l_if_null ELSE IF l_original[1]="$" THEN # Cope with money fields LET l_original[1]=" " END IF RETURN l_original END IF END FUNCTION FUNCTION round(amount,precsn) DEFINE amount MONEY(32,16), factor INTEGER, precsn SMALLINT, spare DECIMAL(32,0) LET factor = 10 ** precsn LET spare = amount * factor LET amount = spare / factor RETURN amount END FUNCTION FUNCTION abs(l_amount) DEFINE l_amount DECIMAL(20,5) IF l_amount < 0 THEN LET l_amount = - l_amount END IF RETURN l_amount END FUNCTION FUNCTION is_blank(l_str) DEFINE l_str CHAR(50) IF LENGTH(l_str) = 0 THEN RETURN TRUE END IF RETURN FALSE END FUNCTION FUNCTION trunc(l_value, l_precision) DEFINE l_value DECIMAL(32, 16), l_precision SMALLINT DEFINE l_factor DECIMAL(32, 16), l_valstr CHAR(34) LET l_factor = 10 ** l_precision LET l_value = l_value * l_factor LET l_valstr = l_value USING "----------------&.&&&&&&&&&&&&&&&&" LET l_value = l_valstr[1, 17] LET l_value = l_value / l_factor RETURN l_value END FUNCTION FUNCTION is_number_dummy_function_stupid_informix_bug_wank() WHENEVER ANY ERROR CONTINUE END FUNCTION FUNCTION is_number(l_text) DEFINE l_text INTEGER IF status != 0 THEN RETURN FALSE ELSE RETURN TRUE END IF END FUNCTION FUNCTION updated() RETURN SQLCA.SQLERRD[3] END FUNCTION -- bwz = BLANK WHEN ZERO FUNCTION bwz(l_number) DEFINE l_number DECIMAL(32,16) IF l_number = 0 THEN RETURN "" END IF RETURN l_number END FUNCTION FUNCTION is_numeric(l_string) DEFINE l_string CHAR(80), l_ok, i SMALLINT LET l_ok = TRUE #Default to TRUE FOR i = 1 TO LENGTH(l_string) IF l_string[i] < "0" OR #Set FALSE for invalid char l_string[i] > "9" THEN IF l_string[i] = ">" OR l_string[i] = "<" OR l_string[i] = "[" OR l_string[i] = "]" OR l_string[i] = ":" OR l_string[i] = "|" OR l_string[i,i+1] = "!=" OR l_string[i] = "=" THEN ELSE LET l_ok = FALSE EXIT FOR END IF END IF END FOR RETURN l_ok END FUNCTION FUNCTION calc_percent(l_numerator, l_denominator, l_size) DEFINE l_numerator DECIMAL(32,5), l_denominator DECIMAL(32,5), l_size SMALLINT, l_maxval DECIMAL(12,2), l_minval DECIMAL(12,2), l_percent DECIMAL(12,2) LET l_numerator = nvl(l_numerator, 0) LET l_denominator = nvl(l_denominator, 0) LET l_size = nvl(l_size, 3) CASE WHEN l_size = 1 LET l_maxval = 9.99 WHEN l_size = 2 LET l_maxval = 99.99 WHEN l_size = 3 LET l_maxval = 999.99 WHEN l_size = 4 LET l_maxval = 9999.99 WHEN l_size = 5 LET l_maxval = 99999.99 WHEN l_size = 6 LET l_maxval = 999999.99 WHEN l_size = 7 LET l_maxval = 9999999.99 WHEN l_size = 8 LET l_maxval = 99999999.99 WHEN l_size = 9 LET l_maxval = 999999999.99 WHEN l_size = 10 LET l_maxval = 9999999999.99 OTHERWISE LET l_maxval = 999.99 END CASE LET l_minval = -1 * l_maxval IF l_denominator = 0 THEN CASE WHEN l_numerator > 0 AND l_size > 2 LET l_percent = 100 WHEN l_numerator < 0 AND l_size > 2 LET l_percent = -100 OTHERWISE LET l_percent = 0 END CASE ELSE CASE WHEN (l_numerator / l_denominator) * 100 > l_maxval LET l_percent = l_maxval WHEN (l_numerator / l_denominator) * 100 < l_minval LET l_percent = l_minval OTHERWISE LET l_percent = (l_numerator / l_denominator) * 100 END CASE END IF RETURN l_percent END FUNCTION FUNCTION centre(l_text, l_fieldsize) DEFINE l_text CHAR(150), l_fieldsize SMALLINT, l_lth SMALLINT, l_centre SMALLINT, l_centered CHAR(150) LET l_lth = LENGTH(l_text) LET l_centre = l_fieldsize / 2 - l_lth / 2 IF l_centre < 1 THEN LET l_centre = 1 END IF IF l_fieldsize < l_centre + l_lth THEN LET l_lth = l_fieldsize - l_centre END IF LET l_centered = 150 SPACES LET l_centered[l_centre, l_centre+l_lth]=l_text CLIPPED RETURN l_centered END FUNCTION FUNCTION check_del(str) DEFINE str CHAR(80) IF int_flag <> 0 OR quit_flag <> 0 THEN MESSAGE str CLIPPED LET int_flag = 0 LET quit_flag = 0 RETURN TRUE END IF RETURN FALSE END FUNCTION FUNCTION coxxc04_id() DEFINE l_id CHAR(80) LET l_id = '$Id: coxxc04.4gl,v 2.17 1996/01/22 04:49:02 liz Exp $' END FUNCTION @EOF set `wc -lwc coxxq01.4gl <<'@EOF' # $Id: coxxq01.4gl,v 2.28 1995/12/27 20:53:49 maugan Exp $ {****************************************************************************** * Filename : coxxq01.4gl * * System : Eunice 4GL - Common Module * * Purpose : Quick and dirty QBE selection window * * Returns : key value * * Author : Kerry Sainsbury * * Date Written : 12 August 1993 * * Last Change : * * * * 21/10/93 Kerry S - Major changes to the front end * * - Cleaning up Temp String Storage bug. * * 22/10/93 Kerry S - Cope with cancelling from QBE window if keycnt > 1 * * 28/10/93 Kerry S - Fields in "Query" QBE window now right-justified * * 29/10/93 Kerry S - AS flag was not working * * - Null flag meant "Line" prompt did not display * * 12/11/93 Kerry S - Large headings causing routine to fall over * * 12/11/93 Kerry S - Stick "Nothing to list" message in a window * * 16/11/93 Kerry S - If > 5 keys would not open correct form * * 01/12/93 Kerry S - Problems with numeric columns, and their headings * * 07/12/93 Kerry S - Catch user's attempts to use wildcards in numeric fields* * 07/12/93 Kerry S - Cope with any error with QDsystem_error * * 13/12/93 Kerry S - Cope with headings of up to 80 characters (but only * * display first 30 characters) * * 26/04/94 Kerry S - Found the -4518 (Temp String Space) bug. Informix bug! * * 14/06/94 Kerry S - Add tagging * * 14/06/94 Kerry S - Disable subsequent QBEs if tagging is enabled * * 16/06/94 Kerry S - Was crashing for non-tagging selections! * * 11/07/94 Kerry S - Just CREATE temporary tagging table once per program * * 12/08/94 Kerry S - Cope with longer titles than can fit in 80 columns * * - When window is oversize, use all 80 columns (was 76) * * 24/08/94 Kerry S - Cope with column list not padded with spaces * * 01/09/94 Kerry S - Add the "More..." indicator per: a Fox & Gun good idea * * 07/10/94 Kerry S - Drop QBE box down a line so that it doesn't obscure * * line 3 (The heading line) * * 18/10/94 EJD - Cope with more than one occurance of text to change in * * QDchange_text * * 20/10/94 Kerry S - New parameter CDE to allow a cheap data-entry screen * * 25/10/94 Kerry S - If a multiple-return-value QBE failed, it was returning * * data from previous windows as 2nd thru 10th values * * 28/10/94 Kerry S - New parameter "NA" to not insist on a * to QBE everythng* * 29/12/94 Kerry S - Cope with BIG SELECTs (like used in cocmq01) * * - Add F12 "I'm sorry" message * * 06/04/95 Kerry S - Finally fix headings with embedded spaces * * 07/04/95 Kerry S - Let this routine die if it needs to * * 07/04/95 Kerry S - Now add ability to put a title inside query_windows * * 13/04/95 Kerry S - Now handle empty headings * * 26/04/95 Kerry S - Maximum heading per column is 30 characters * * 02/05/95 Kerry S - Cope with headings of "Something," * * 15/06/95 Greg A - Cope with multi-line titles and also lets you have * * uncentred titles and fixed NS flag so that it works * * 15/06/95 Kerry S - Wildcard matching cannot be used with non-character * * datatypes (an old bug I recently reintroduced) * * 15/06/95 Eric H - Have key columns that dont show in select - only in qbe * * 19/07/95 Eric H - Add new STn start column flag - see below * * 24/07/91 Eric H - Problems with status field * * 17/08/95 Eric H - program aborting on OPEN cursor if non-numeric data in * * a numeric field. Let QDsystem_error handle it. * * 29/09/95 Greg A - Add tag all and untag all options to the ring menu for * * list when tagging is on * * 12/10/95 Kerry S - Added in_background test, and a GOTO (for clarity!) * * * *******************************************************************************} #! query_window(select_statement, headings, keycnt, flags) #! - select_statement : display columns need {[k]size} parameter #! eg: SELECT pmprodno{k15}, pmdesc{40}, smohdqty{8.2} etc #! would specify that pmprodno is 15 characters wide, #! pmdesc is 40 characters wide, and smohdqty is a numeric #! field 8 characters wide with 2 figures after the #! decimal points. #! - A "k" after the "{" indicates the field can be queryed #! under the "Query" menu option #! - headings : headings for the SELECTed columns #! (eg:Code, Description) #! - keycnt : this number of columns which are keys #! (the first columns are returned #! to the calling function) #! - flags. User selection options, delimited by pipes (|). #! "AS" - Automatically select if only one option to choose. #! "CDE"- Cheap Data Entry. FQ & AS plus it skips the the #! "No details to display" window and returns immediately #! to the calling program. A cheap data entry routine :-) #! "FQ" - Force QBE before bringing up selection window #! "NA" - No asterisk required to QBE everything #! "NBE"- No Back End. Just pops up QBE window and returns #! WHERE clause #! "NS" - No line selection available. #! "NQ" - No "Query" option on ring menu #! "TAG"- Allow tagging of multiple items (requires subsequent #! calls to "next_tag()") #! "STn"- Start RETURN of parameters in column "n" of SELECT list #! ie RETURN column n thru n + keycnt - 1 #! #! next_tag() RETURNs next tagged item, or NULL on last item #! #! query_title(l_title) RETURNs nothing #! - Places l_title as a title at the top of the query_window #! selection screen #! #! query_centre_off(l_centre_lines) RETURNs nothing #! - l_centre_lines - Numbers of the lines that you want centred or null #! for all uncentred #! - Places l_centre_lines as centre title and all others a uncentred #! If passed null then all lines are uncentred # Note: I'm not passing huge strings around the place any more simply because # Informix is slow at it, and I'm concerned about running out of # Temporary String Storage space. Hence more globals in this version. # DEFINE m_lpp SMALLINT, # Number of lines per page m_bell CHAR(1), # For ASCII(7) ma_desclen ARRAY[10] OF DECIMAL(3,1), # Length of display field ma_number ARRAY[10] OF SMALLINT, # Is field a number ? ma_key ARRAY[10] OF SMALLINT, # Is field a key for QBE? ma_head ARRAY[10] OF CHAR(30), # Heading text ma_desc ARRAY[10] OF CHAR(80), # Data from current row ma_column ARRAY[10] OF CHAR(20), # Columns name m_select CHAR(1000), # Hold SQL SELECT string m_change_text CHAR(1000), m_eighty_spaces CHAR(80), m_tagkeycnt INTEGER, m_tagstartcol INTEGER, m_built_tagtable SMALLINT, # Has the tagtable been built? m_using CHAR(20), # For formatting numerics m_width SMALLINT, m_offset SMALLINT, -- Row at which data starts displaying m_title CHAR(250), -- 78 * 3 :-o m_centrelines CHAR(15) -- No's of lines to centre FUNCTION query_any(l_table, l_keycolumn, l_desccolumn, # Easy frontend l_keyname, l_heading,l_where, l_old) DEFINE l_table CHAR(18), # LIKE systables.tabname, l_keycolumn CHAR(18), # LIKE syscolumns.colname, l_desccolumn CHAR(18), # LIKE syscolumns.colname, l_keyname CHAR(18), # LIKE syscolumns.colname, l_heading CHAR(18), # LIKE syscolumns.colname, l_where CHAR(100), l_old CHAR(80), l_flags CHAR(20), l_key CHAR(80), l_keylen SMALLINT, l_desclen SMALLINT, l_text CHAR(200), l_head CHAR(80), l_nrows SMALLINT -- WHENEVER ANY ERROR CALL QDsystem_error IF l_where IS NULL THEN LET l_where = "1=1" END IF LET l_keylen = QDgetcollen(l_table, l_keycolumn) # Get size of columns LET l_desclen = QDgetcollen(l_table, l_desccolumn) LET l_text = # Build a SELECT string "SELECT ",l_keycolumn CLIPPED,"{k",l_keylen,"}, ", # in a format suitable l_desccolumn CLIPPED,"{",l_desclen,"}", # for query_window() " FROM ",l_table CLIPPED, " WHERE ",l_where CLIPPED, " ORDER BY ",l_keycolumn CLIPPED LET l_head = l_keyname CLIPPED,",",l_heading CLIPPED # Force QBE box if more than 50 rows in the table... SELECT nrows INTO l_nrows FROM systables WHERE tabname = l_table IF l_nrows > 50 THEN # If more than 50 rows in table LET l_flags = "FQ" ELSE LET l_flags = "" END IF LET l_key = query_window(l_text, l_head, 1, l_flags) # Do it! IF l_key IS NULL THEN LET l_key = l_old END IF RETURN l_key END FUNCTION FUNCTION query_title(l_title) DEFINE l_title CHAR(800) LET m_title = l_title END FUNCTION FUNCTION query_centre_off(l_centrelines) DEFINE l_centrelines CHAR(15) LET m_centrelines = l_centrelines IF m_centrelines IS NULL THEN LET m_centrelines = "ZZ" ELSE LET m_centrelines = "[",m_centrelines CLIPPED,"]" END IF END FUNCTION FUNCTION query_window(l_select, l_heading, l_keycnt, l_flags) DEFINE l_select CHAR(1000), l_heading CHAR(100), l_titlearr ARRAY[3] OF CHAR(78), l_keycnt SMALLINT, l_flags CHAR(30), l_desccolumn CHAR(20), l_text CHAR(600), l_fixwhere CHAR(600), l_desc CHAR(80), l_desclen SMALLINT, l_wcol SMALLINT, l_depth SMALLINT, l_page SMALLINT, l_tagging SMALLINT, l_headlineno SMALLINT, l_headmatch CHAR(3), l_noofheadlines SMALLINT, l_want_selection_window SMALLINT, l_menuline SMALLINT, l_startcol SMALLINT, i SMALLINT, la_desc ARRAY[10] OF CHAR(80) -- WHENEVER ANY ERROR CALL QDsystem_error # Setup global variables... LET m_select = l_select LET m_lpp = 9 # There are 9 lines per page... LET m_bell = ASCII(7) LET m_using = "--------------------" LET m_eighty_spaces = # Do not replace with "80 SPACES" " " LET l_flags = "|",l_flags CLIPPED, "|" IF l_flags MATCHES "*|CDE|*" THEN # Cheap data entry turned on? LET l_flags = l_flags CLIPPED,"FQ|AS|" END IF IF l_flags MATCHES "*|NBE|*" THEN # No Back End turned on? LET l_flags = l_flags CLIPPED,"FQ|" END IF LET l_startcol = 1 IF l_flags MATCHES "*|ST*" THEN FOR i = 1 TO 26 IF l_flags[i,i+2] = "|ST" THEN IF l_flags[i+4] = "|" THEN LET l_startcol = l_flags[i+3] ELSE LET l_startcol = l_flags[i+3,i+4] END IF EXIT FOR END IF END FOR END IF IF l_flags MATCHES "*|TAG|*" THEN LET l_tagging = TRUE LET m_tagkeycnt = l_keycnt LET m_tagstartcol = l_startcol LET l_keycnt = FALSE IF NOT m_built_tagtable THEN PREPARE create_tagtable FROM "CREATE TEMP TABLE tagtable (line SMALLINT) WITH NO LOG" EXECUTE create_tagtable LET m_built_tagtable = TRUE ELSE DELETE FROM tagtable END IF ELSE LET l_tagging = FALSE END IF # Extract options from l_desccolumn, and work out how wide the # description field will be... LET l_desclen = QDget_desc_sizes() LET l_select = m_select # Store our cleaned up SQL string for later LET l_heading = QDformat_heading(l_heading) # Force QBE box ? IF l_flags MATCHES "*|FQ|*" # If Force-Query flag turned on... THEN LET l_text = QDqbewindow(l_flags) IF check_del("Query cancelled") THEN LET m_title = "" IF l_flags MATCHES "*|NBE|*" THEN # No Back End turned on? RETURN "" # return empty where clause END IF GOTO RETURN_CHOICE -- At the end of this function END IF IF l_flags MATCHES "*|NBE|*" THEN # No Back End turned on? LET m_title = "" RETURN l_text # return where clause END IF ELSE LET l_text = "1=1" END IF LET l_fixwhere = " WHERE ",l_text CLIPPED," AND " LET m_change_text = l_select CALL QDchange_text("WHERE", l_fixwhere, "g") LET m_select = m_change_text IF m_change_text = l_select THEN # Check for WHERE clause LET m_select = "SYSTEM ERROR!<", "SELECT string passed to query_window() did not contain a WHERE clause. ", "Advise your support company of this error!" CALL message_prompt(m_select, "") LET m_title = "" GOTO RETURN_CHOICE -- At the end of this function END IF CALL QDbuild_cursor() # If there's only one record, then don't bother with the selection window... LET l_want_selection_window = TRUE IF l_flags MATCHES "*|AS|*" THEN # If Auto-Select flag is on, then CALL QDchoice(1, 2,FALSE, FALSE, 0) # check if more than one record. IF ma_desc[1] IS NULL THEN # There is no second record, CALL QDchoice(1, 1,FALSE, l_tagging, 0) # So look for a first one IF ma_desc[1] IS NOT NULL THEN # There is a first record LET l_want_selection_window = FALSE # so don't need window END IF ELSE CALL QDclear_desc() END IF ELSE CALL QDclear_desc() END IF IF l_flags MATCHES "*|CDE|*" THEN # If cheap data entry then CALL QDchoice(1, 1,FALSE, FALSE, 0) # read the first record, and if IF ma_desc[1] IS NULL THEN # blank return to calling program LET l_want_selection_window = FALSE END IF END IF IF l_want_selection_window THEN IF l_desclen + 2 > 78 THEN # Truncate long descriptive fields LET l_desclen = 78 - 2 END IF LET m_width = l_desclen + 2 IF m_width < 42 THEN # This stops an "invalid opcode" error in LET m_width = 42 # Informix 4.1 if the Menu list does not END IF # all fit inside the window. IF m_width > 78 THEN # This keeps the window small enough to LET m_width = 78 # fit on the screen! END IF LET l_depth = 6 + m_lpp LET m_offset = 4 LET l_menuline = 1 IF NOT is_blank(m_title) THEN LET l_noofheadlines = setup_wwrap(m_title,m_width) IF l_noofheadlines > 3 THEN CALL message_prompt("coxxq01: Can only handle 3 title lines", "") LET l_noofheadlines = setup_wwrap(m_title,m_width) LET l_noofheadlines = 3 END IF FOR l_headlineno = 1 TO l_noofheadlines LET l_titlearr[l_headlineno]=next_wwrap() END FOR LET l_depth = l_depth + 1 + l_noofheadlines LET m_offset = m_offset + 1 + l_noofheadlines LET l_menuline = l_menuline + 1 + l_noofheadlines END IF # Open scrolly selection window... LET l_wcol = (80 - m_width) / 2 IF l_wcol < 2 THEN LET l_wcol = 2 END IF OPEN WINDOW qdwin AT 6, l_wcol WITH l_depth ROWS, m_width COLUMNS ATTRIBUTE(BORDER, CYAN, MESSAGE LINE LAST, MENU LINE l_menuline) IF NOT is_blank(m_title) THEN FOR l_headlineno = 1 TO l_noofheadlines LET l_headmatch = l_headlineno IF m_centrelines IS NOT NULL THEN IF l_headmatch MATCHES m_centrelines THEN LET l_titlearr[l_headlineno]= centre(l_titlearr[l_headlineno],m_width) END IF ELSE LET l_titlearr[l_headlineno]= centre(l_titlearr[l_headlineno],m_width) END IF DISPLAY l_titlearr[l_headlineno] AT l_headlineno,1 ATTRIBUTE(REVERSE) END FOR LET m_title = "" LET m_centrelines = "" END IF LET l_wcol = 3 IF l_desclen THEN DISPLAY l_heading AT m_offset, l_wcol ATTRIBUTE(DIM) END IF IF l_flags NOT MATCHES "*|NS|*" THEN MESSAGE "Enter Line No." ATTRIBUTE (REVERSE) END IF IF QDshow_page(1, l_desclen, l_tagging) THEN LET l_page = 1 MENU "SELECT" BEFORE MENU HIDE OPTION "Tag All" HIDE OPTION "Untag All" IF l_flags MATCHES "*|NQ|*" THEN # If No Query flag is on HIDE OPTION "Query" # then turn off "Query" option END IF IF l_flags MATCHES "*|TAG|*" THEN # or tagging is enabled HIDE OPTION "Query" # then turn off "Query" option SHOW OPTION "Tag All" SHOW OPTION "Untag All" END IF COMMAND "Query" "Find a match based on partial information" IF l_flags NOT MATCHES "*|NS|*" THEN MESSAGE "Enter Line No." ATTRIBUTE (REVERSE) END IF LET l_text = QDqbewindow(l_flags) IF NOT check_del("Query cancelled") THEN LET l_fixwhere = " WHERE ",l_text CLIPPED," AND " LET m_change_text = l_select CALL QDchange_text("WHERE", l_fixwhere, "g") LET m_select = m_change_text CALL QDbuild_cursor() LET l_page = 1 IF NOT QDshow_page(l_page, l_desclen, l_tagging) THEN CALL QDblank_window(1) CALL message_prompt("No details to display","") END IF MESSAGE "Enter Line No." ATTRIBUTE (REVERSE) END IF COMMAND "Next" "Display next page" IF l_flags NOT MATCHES "*|NS|*" THEN MESSAGE "Enter Line No." ATTRIBUTE (REVERSE) END IF CALL QDnext_page(l_page, l_desclen, l_tagging) RETURNING l_page COMMAND "Previous" "Display previous page" IF l_flags NOT MATCHES "*|NS|*" THEN MESSAGE "Enter Line No." ATTRIBUTE (REVERSE) END IF CALL QDprev_page(l_page, l_desclen, l_tagging) RETURNING l_page COMMAND "Tag All" "Tags All lines in the selection window" CALL QDtagallctrl(l_page,l_desclen,l_tagging,"T") COMMAND "Untag All" "Untag All lines in the selection window" CALL QDtagallctrl(l_page,l_desclen,l_tagging,"U") COMMAND "Exit" "Exit selection window" CALL QDclear_desc() EXIT MENU COMMAND KEY (F3) # Next Page IF l_flags NOT MATCHES "*|NS|*" THEN MESSAGE "Enter Line No." ATTRIBUTE (REVERSE) END IF CALL QDnext_page(l_page, l_desclen, l_tagging) RETURNING l_page COMMAND KEY (F4) # Prev Page IF l_flags NOT MATCHES "*|NS|*" THEN MESSAGE "Enter Line No." ATTRIBUTE (REVERSE) END IF CALL QDprev_page(l_page, l_desclen, l_tagging) RETURNING l_page COMMAND KEY ("1") IF l_flags MATCHES "*|NS|*" THEN CONTINUE MENU END IF CALL QDchoice(l_page, 1, TRUE, l_tagging, l_desclen) IF NOT l_tagging AND ma_desc[1] IS NOT NULL THEN EXIT MENU END IF COMMAND KEY ("2") IF l_flags MATCHES "*|NS|*" THEN CONTINUE MENU END IF CALL QDchoice(l_page, 2, TRUE, l_tagging, l_desclen) IF NOT l_tagging AND ma_desc[1] IS NOT NULL THEN EXIT MENU END IF COMMAND KEY ("3") IF l_flags MATCHES "*|NS|*" THEN CONTINUE MENU END IF CALL QDchoice(l_page, 3, TRUE, l_tagging, l_desclen) IF NOT l_tagging AND ma_desc[1] IS NOT NULL THEN EXIT MENU END IF COMMAND KEY ("4") IF l_flags MATCHES "*|NS|*" THEN CONTINUE MENU END IF CALL QDchoice(l_page, 4, TRUE, l_tagging, l_desclen) IF NOT l_tagging AND ma_desc[1] IS NOT NULL THEN EXIT MENU END IF COMMAND KEY ("5") IF l_flags MATCHES "*|NS|*" THEN CONTINUE MENU END IF CALL QDchoice(l_page, 5, TRUE, l_tagging, l_desclen) IF NOT l_tagging AND ma_desc[1] IS NOT NULL THEN EXIT MENU END IF COMMAND KEY ("6") IF l_flags MATCHES "*|NS|*" THEN CONTINUE MENU END IF CALL QDchoice(l_page, 6, TRUE, l_tagging, l_desclen) IF NOT l_tagging AND ma_desc[1] IS NOT NULL THEN EXIT MENU END IF COMMAND KEY ("7") IF l_flags MATCHES "*|NS|*" THEN CONTINUE MENU END IF CALL QDchoice(l_page, 7, TRUE, l_tagging, l_desclen) IF NOT l_tagging AND ma_desc[1] IS NOT NULL THEN EXIT MENU END IF COMMAND KEY ("8") IF l_flags MATCHES "*|NS|*" THEN CONTINUE MENU END IF CALL QDchoice(l_page, 8, TRUE, l_tagging, l_desclen) IF NOT l_tagging AND ma_desc[1] IS NOT NULL THEN EXIT MENU END IF COMMAND KEY ("9") IF l_flags MATCHES "*|NS|*" THEN CONTINUE MENU END IF CALL QDchoice(l_page, 9, TRUE, l_tagging, l_desclen) IF NOT l_tagging AND ma_desc[1] IS NOT NULL THEN EXIT MENU END IF END MENU ELSE CALL message_prompt("No details to display","") END IF CLOSE WINDOW qdwin OPTIONS MENU LINE 1 END IF IF check_del("") THEN MESSAGE m_bell,"Query cancelled" ATTRIBUTE(REVERSE) END IF IF l_tagging THEN CALL QDsetup_tags() END IF LET m_title = "" FOR i = 1 TO l_keycnt IF i + l_startcol > 10 THEN LET la_desc[i] = "" ELSE LET la_desc[i] = ma_desc[i + l_startcol - 1] END IF END FOR LABEL RETURN_CHOICE: CASE WHEN l_keycnt = 0 RETURN WHEN l_keycnt = 1 RETURN la_desc[1] WHEN l_keycnt = 2 RETURN la_desc[1], la_desc[2] WHEN l_keycnt = 3 RETURN la_desc[1], la_desc[2], la_desc[3] WHEN l_keycnt = 4 RETURN la_desc[1], la_desc[2], la_desc[3], la_desc[4] WHEN l_keycnt = 5 RETURN la_desc[1], la_desc[2], la_desc[3], la_desc[4], la_desc[5] WHEN l_keycnt = 6 RETURN la_desc[1], la_desc[2], la_desc[3], la_desc[4], la_desc[5], la_desc[6] WHEN l_keycnt = 7 RETURN la_desc[1], la_desc[2], la_desc[3], la_desc[4], la_desc[5], la_desc[6], la_desc[7] WHEN l_keycnt = 8 RETURN la_desc[1], la_desc[2], la_desc[3], la_desc[4], la_desc[5], la_desc[6], la_desc[7], la_desc[8] WHEN l_keycnt = 9 RETURN la_desc[1], la_desc[2], la_desc[3], la_desc[4], la_desc[5], la_desc[6], la_desc[7], la_desc[8], la_desc[9] WHEN l_keycnt = 10 RETURN la_desc[1], la_desc[2], la_desc[3], la_desc[4], la_desc[5], la_desc[6], la_desc[7], la_desc[8], la_desc[9], la_desc[10] OTHERWISE CALL message_prompt("Can't return more than 10 values from query_window", "") END CASE END FUNCTION FUNCTION QDbuild_cursor() # Builds the cursor, based on m_select string MESSAGE "Building list..." WHENEVER ANY ERROR CALL QDsystem_error PREPARE qdprep FROM m_select DECLARE qdcurs SCROLL CURSOR FOR qdprep OPEN qdcurs WHENEVER ANY ERROR STOP MESSAGE "" END FUNCTION # This function scans thru the SELECT string looking for directives (ie {k5}) # and throws the various bits of information into misc arrays for later use. # # Also strips the directive text out of the SELECT string so that it makes # sense to Informix-SQL FUNCTION QDget_desc_sizes() DEFINE l_thiscol CHAR(18), # LIKE syscolumns.colname, l_desclen SMALLINT, l_lth SMALLINT, l_nstart SMALLINT, l_cnt SMALLINT, # Count of descriptions i, j SMALLINT FOR i = 1 TO 10 # Clean out description length array LET ma_desclen[i]=0 LET ma_number[i]=0 LET ma_key[i]=0 END FOR LET l_cnt = 1 LET l_lth = LENGTH(m_select) FOR i = 1 TO l_lth # Scan through desccolumn string CASE WHEN m_select[i]="{" # Hit a definition FOR j = i-1 TO 1 STEP -1 # Try to work out the name of the column IF m_select[j]=" " OR m_select[j]="," THEN LET j = j + 1 EXIT FOR END IF END FOR LET ma_column[l_cnt]=m_select[j, i-1] FOR l_nstart = j - 1 TO 1 STEP -1 # look for a comma IF m_select[l_nstart] = "," THEN EXIT FOR END IF IF m_select[l_nstart] <> " " THEN LET l_nstart = l_nstart + 1 EXIT FOR END IF END FOR FOR j = i+1 TO l_lth # Look for column sizes CASE WHEN m_select[j]="k" # It's a QBE key column LET ma_key[l_cnt]=TRUE # so remember to display it in the LET m_select[j]=" " # "Query" ring menu WHEN m_select[j]="K" # It's a QBE key column LET ma_key[l_cnt]=TRUE # but we don't want it in the select LET m_select[l_nstart,j]=" " # WHEN m_select[j]="}" # End of column size definition LET ma_desclen[l_cnt] = m_select[i+1,j-1] FOR i = i TO j IF m_select[i]="." THEN # Look for a decimal point LET ma_number[l_cnt] = TRUE # Hey - it's a number END IF LET m_select[i]=" " END FOR LET i = j LET l_cnt = l_cnt + 1 EXIT FOR OTHERWISE END CASE END FOR OTHERWISE END CASE END FOR # Work out total size of all descriptions bolted together... LET l_desclen = 0 FOR i = 1 TO l_cnt LET l_desclen = l_desclen+ma_desclen[i] LET l_lth = ma_desclen[i] # Check for numeric with decimal places IF l_lth != ma_desclen[i] THEN # If found, then add one to account LET l_desclen = l_desclen + 1 # for the decimal place marker END IF IF l_desclen > 76 THEN LET ma_desclen[i] = ma_desclen[i] - (l_desclen - 76) LET l_desclen = 76 END IF END FOR LET l_desclen = l_desclen + l_cnt - 1 RETURN l_desclen END FUNCTION FUNCTION QDformat_heading(l_heading) DEFINE l_heading CHAR(100), l_desc CHAR(80), l_cnt SMALLINT, l_lth SMALLINT, i SMALLINT, l_s SMALLINT, l_e SMALLINT, l_rounded_desclen SMALLINT # First work out what headings we've got... LET l_desc = m_eighty_spaces LET l_cnt = 1 LET l_s = 1 LET l_lth = LENGTH(l_heading) FOR i = 1 TO l_lth IF l_heading[i] = "," THEN IF i-1 >= l_s THEN -- Cope with an empty heading LET ma_head[l_cnt] = l_heading[l_s, i-1] END IF LET l_cnt = l_cnt + 1 LET l_s = i + 1 IF l_cnt > 30 THEN -- Max column heading size is 30 characters LET l_heading[i+1]="," -- so force our way onto the next heading END IF END IF END FOR IF l_s <= l_lth THEN LET ma_head[l_cnt] = l_heading[l_s, l_lth] CLIPPED ELSE LET ma_head[l_cnt] = "" END IF # Build up description line... LET l_e = -1 FOR i = 1 TO l_cnt IF ma_desclen[i] THEN LET l_s = l_e + 2 LET l_e = l_s + ma_desclen[i] -1 IF ma_number[i] THEN LET l_lth = LENGTH(ma_head[i]) # Right justify numbers IF l_lth > ma_desclen[i] THEN LET l_lth = ma_desclen[i] END IF LET l_s = l_e - l_lth + 1 # LET l_rounded_desclen = ma_desclen[i] # IF ma_desclen[i] != l_rounded_desclen THEN # LET l_s = l_s + 1 # END IF END IF IF ma_head[i] IS NOT NULL AND l_s <=80 THEN IF l_e > 80 THEN LET l_e = 80 END IF LET l_desc[l_s, l_e] = ma_head[i] END IF END IF END FOR RETURN l_desc END FUNCTION FUNCTION QDnext_page(l_page, l_desclen, l_tagging) # Next page of list DEFINE l_page SMALLINT, l_desclen SMALLINT, l_tagging SMALLINT IF QDshow_page(l_page+1, l_desclen, l_tagging) THEN LET l_page = l_page + 1 ELSE MESSAGE m_bell,"No more pages to display" ATTRIBUTE(REVERSE) END IF RETURN l_page END FUNCTION FUNCTION QDprev_page(l_page, l_desclen, l_tagging) # Previous page of list DEFINE l_page SMALLINT, l_desclen SMALLINT, l_tagging SMALLINT IF l_page !=1 THEN IF QDshow_page(l_page-1, l_desclen, l_tagging) THEN LET l_page = l_page -1 END IF ELSE MESSAGE m_bell,"No previous page to display" ATTRIBUTE(REVERSE) END IF RETURN l_page END FUNCTION FUNCTION QDchoice(l_page, l_selline, l_errflag, l_tagging, l_desclen) DEFINE l_page SMALLINT, l_selline SMALLINT, l_errflag SMALLINT, l_tagging SMALLINT, l_desclen SMALLINT, l_rec INTEGER, i SMALLINT LET l_rec = ((l_page-1) * m_lpp) + l_selline FETCH ABSOLUTE l_rec qdcurs INTO ma_desc[1], ma_desc[2], ma_desc[3], ma_desc[4], ma_desc[5], ma_desc[6], ma_desc[7], ma_desc[8], ma_desc[9], ma_desc[10] IF status !=0 THEN FOR i = 1 TO 10 LET ma_desc[i]= NULL END FOR IF l_errflag THEN MESSAGE m_bell,"Invalid line number" ATTRIBUTE(REVERSE) END IF ELSE IF l_tagging THEN # If tagging then DELETE FROM tagtable WHERE line = l_rec # toggle tag table IF SQLCA.SQLERRD[3]=0 THEN INSERT INTO tagtable (line) VALUES (l_rec) END IF IF l_desclen THEN # Do not try to display anything if autoselecting IF QDshow_line(l_page, l_desclen, l_rec, l_selline, l_tagging) THEN END IF END IF END IF END IF END FUNCTION FUNCTION QDtagallctrl(l_page, l_desclen, l_tagging, l_tagctrl) DEFINE l_page SMALLINT, l_desclen SMALLINT, l_tagging SMALLINT, l_tagctrl CHAR(1), l_row_cnt SMALLINT, l_ok SMALLINT IF l_tagctrl = "U" THEN DELETE FROM tagtable LET l_ok=QDshow_page(l_page,l_desclen,l_tagging) ELSE DELETE FROM tagtable LET l_row_cnt = 1 FOREACH qdcurs INSERT INTO tagtable VALUES(l_row_cnt) LET l_row_cnt = l_row_cnt + 1 END FOREACH OPEN qdcurs LET l_ok=QDshow_page(l_page,l_desclen,l_tagging) END IF END FUNCTION FUNCTION QDshow_page(l_page, l_desclen, l_tagging)# Display a page full of lines DEFINE l_page SMALLINT, l_desclen SMALLINT, l_tagging SMALLINT, l_rec INTEGER, i SMALLINT, l_last_ok SMALLINT, l_col SMALLINT, l_row SMALLINT LET l_rec = (l_page-1) * m_lpp + 1 FOR i = 1 TO m_lpp LET l_last_ok = i - 1 IF NOT QDshow_line(l_page, l_desclen, l_rec+i-1, i, l_tagging) THEN IF i > 1 THEN CALL QDblank_window(i) # Blank reset of window END IF EXIT FOR END IF END FOR LET i = l_rec + l_last_ok LET l_row = m_offset + m_lpp + 2 LET l_col = m_width - 7 FETCH ABSOLUTE i qdcurs IF status = 0 THEN DISPLAY "More... " AT l_row, l_col ELSE DISPLAY " " AT l_row, l_col END IF RETURN l_last_ok END FUNCTION # Display a single line FUNCTION QDshow_line(l_page, l_desclen, l_curr, l_row, l_tagging) DEFINE l_page SMALLINT, l_desclen SMALLINT, l_curr INTEGER, l_row SMALLINT, l_tagging SMALLINT, l_s SMALLINT, l_e SMALLINT, i SMALLINT, l_rec INTEGER, l_desc CHAR(80), l_text CHAR(80), l_using CHAR(30), l_lth SMALLINT, l_decimals SMALLINT, l_num CHAR(1), l_temp CHAR(80), l_templen SMALLINT LET l_desc = m_eighty_spaces FETCH ABSOLUTE l_curr qdcurs INTO ma_desc[1], ma_desc[2], ma_desc[3], ma_desc[4], ma_desc[5], ma_desc[6], ma_desc[7], ma_desc[8], ma_desc[9], ma_desc[10] IF status = NOTFOUND THEN CALL QDclear_desc() RETURN FALSE END IF IF ma_desc[1] IS NULL THEN LET l_num = " " ELSE LET l_num = l_row END IF # Build up description line... LET l_e = -1 FOR i = 1 TO 10 IF ma_desclen[i] THEN LET l_using = "" IF ma_number[i] THEN # If this is a numeric column LET l_lth = ma_desclen[i] # then build a "USING" string LET l_decimals = (ma_desclen[i]-l_lth) *10 # How many after dpoint? # Build up left hand side of the using string IF l_decimals THEN LET l_lth = l_lth - l_decimals - 1 END IF IF l_lth > 1 THEN LET l_using = m_using[1,l_lth-1],"&" ELSE LET l_using = "&" END IF # And tack on the right hand side if there are any decimal places IF l_decimals THEN LET l_using = l_using CLIPPED,".", m_using[1,l_decimals] END IF END IF LET l_s = l_e + 2 LET l_e = l_s + ma_desclen[i] -1 IF ma_number[i] THEN LET l_temp = ma_desc[i] IF l_temp[1] = "$" THEN LET l_templen = LENGTH(l_temp) LET ma_desc[i] = l_temp[2, l_templen] END IF LET l_desc[l_s, l_e] = ma_desc[i] USING l_using ELSE IF ma_desc[i] IS NOT NULL AND l_s <=80 THEN # This test stops IF l_e > 80 THEN LET l_e = 80 END IF LET l_desc[l_s, l_e] = ma_desc[i] # Informix -4518ing later on END IF END IF END IF END FOR LET l_text = l_num, " ",l_desc[1,l_desclen] # And plonk it on the screen... LET l_row = l_row + m_offset IF l_tagging THEN SELECT line FROM tagtable WHERE line = l_curr IF status = 0 THEN DISPLAY l_text AT l_row, 1 ATTRIBUTE(REVERSE) ELSE DISPLAY l_text AT l_row, 1 ATTRIBUTE(NORMAL) END IF ELSE DISPLAY l_text AT l_row, 1 ATTRIBUTE(NORMAL) END IF RETURN TRUE END FUNCTION FUNCTION QDblank_window(l_start_row) # Blank out the rest of the page DEFINE i SMALLINT, l_start_row SMALLINT, l_row SMALLINT FOR i = l_start_row TO m_lpp LET l_row = i + m_offset DISPLAY "" AT l_row, 1 ATTRIBUTE(NORMAL) END FOR END FUNCTION FUNCTION QDqbewindow(l_flags) # Do the CONSTRUCT... DEFINE l_flags CHAR(30) DEFINE l_text CHAR(200), l_cnt SMALLINT, l_lth SMALLINT, l_strcnt CHAR(1), l_qdkey CHAR(10), l_form CHAR(15), l_pad CHAR(15), l_finished SMALLINT, i SMALLINT # Find out how many key columns there are, so we know which form to open... LET l_cnt = 0 FOR i = 1 TO 10 IF ma_key[i] THEN LET l_cnt = l_cnt + 1 END IF END FOR # Open the appropriate form... CASE WHEN l_cnt = 0 RETURN " 1=1" WHEN l_cnt = 1 LET l_form = "coxxq01a" WHEN l_cnt = 2 LET l_form = "coxxq01b" WHEN l_cnt = 3 LET l_form = "coxxq01c" WHEN l_cnt = 4 LET l_form = "coxxq01d" WHEN l_cnt = 5 LET l_form = "coxxq01e" WHEN l_cnt = 6 LET l_form = "coxxq01f" WHEN l_cnt = 7 LET l_form = "coxxq01g" WHEN l_cnt = 8 LET l_form = "coxxq01h" WHEN l_cnt = 9 LET l_form = "coxxq01i" WHEN l_cnt = 10 LET l_form = "coxxq01j" OTHERWISE END CASE OPEN WINDOW qbewind at 5, 8 WITH FORM l_form ATTRIBUTE (CYAN, BORDER, MESSAGE LINE LAST, COMMENT LINE LAST-1) DISPLAY "Enter data for QBE" AT 1, 2 ATTRIBUTE(DIM) DISPLAY "Esc to accept. Del to exit" AT 2, 2 ATTRIBUTE(DIM) # Display the column descriptions... LET l_cnt = 0 FOR i = 1 TO 10 IF ma_key[i] THEN LET l_cnt = l_cnt + 1 LET l_pad = " :" LET l_lth = LENGTH(ma_head[i]) IF l_lth > 14 THEN LET l_lth = 13 END IF IF ma_head[i] IS NOT NULL THEN LET l_pad[15-l_lth, 14] = ma_head[i] END IF DISPLAY l_pad TO anyqbe[l_cnt].keyname ATTRIBUTE(DIM) END IF END FOR # Do the CONSTRUCT... (If you know a better way to do this, feel free..) LET l_finished = FALSE WHILE NOT l_finished CASE WHEN l_cnt = 1 CONSTRUCT l_text ON qdkey1 FROM keyqbe1 ATTRIBUTE(NORMAL) WHEN l_cnt = 2 CONSTRUCT l_text ON qdkey1, qdkey2 FROM keyqbe1, keyqbe2 ATTRIBUTE(NORMAL) WHEN l_cnt = 3 CONSTRUCT l_text ON qdkey1, qdkey2, qdkey3 FROM keyqbe1, keyqbe2, keyqbe3 ATTRIBUTE(NORMAL) WHEN l_cnt = 4 CONSTRUCT l_text ON qdkey1, qdkey2, qdkey3, qdkey4 FROM keyqbe1, keyqbe2, keyqbe3, keyqbe4 ATTRIBUTE(NORMAL) WHEN l_cnt = 5 CONSTRUCT l_text ON qdkey1, qdkey2, qdkey3, qdkey4, qdkey5 FROM keyqbe1, keyqbe2, keyqbe3, keyqbe4, keyqbe5 ATTRIBUTE(NORMAL) WHEN l_cnt = 6 CONSTRUCT l_text ON qdkey1, qdkey2, qdkey3, qdkey4, qdkey5, qdkey6 FROM keyqbe1, keyqbe2, keyqbe3, keyqbe4, keyqbe5, keyqbe6 ATTRIBUTE(NORMAL) WHEN l_cnt = 7 CONSTRUCT l_text ON qdkey1, qdkey2, qdkey3, qdkey4, qdkey5, qdkey6, qdkey7 FROM keyqbe1, keyqbe2, keyqbe3, keyqbe4, keyqbe5, keyqbe6, keyqbe7 ATTRIBUTE(NORMAL) WHEN l_cnt = 8 CONSTRUCT l_text ON qdkey1, qdkey2, qdkey3, qdkey4, qdkey5, qdkey6, qdkey7, qdkey8 FROM keyqbe1, keyqbe2, keyqbe3, keyqbe4, keyqbe5, keyqbe6, keyqbe7, keyqbe8 ATTRIBUTE(NORMAL) WHEN l_cnt = 9 CONSTRUCT l_text ON qdkey1, qdkey2, qdkey3, qdkey4, qdkey5, qdkey6, qdkey7, qdkey8, qdkey9 FROM keyqbe1, keyqbe2, keyqbe3, keyqbe4, keyqbe5, keyqbe6, keyqbe7, keyqbe8, keyqbe9 ATTRIBUTE(NORMAL) OTHERWISE CONSTRUCT l_text ON qdkey1, qdkey2, qdkey3, qdkey4, qdkey5, qdkey6, qdkey7, qdkey8, qdkey9, qdkey10 FROM keyqbe1, keyqbe2, keyqbe3, keyqbe4, keyqbe5, keyqbe6, keyqbe7, keyqbe8, keyqbe9, keyqbe10 ATTRIBUTE(NORMAL) END CASE # Check everything is OK... IF int_flag THEN LET l_text = "!CANCEL!" LET l_finished = TRUE END IF IF l_text = " 1=1" AND NOT (l_flags MATCHES "*|NA|*") THEN MESSAGE m_bell,"Cannot search for all records" ATTRIBUTE(REVERSE) ELSE # Yep - Then change the select string so it reflects real column names... LET l_cnt = 0 FOR i = 1 TO 10 IF ma_key[i] THEN LET l_cnt = l_cnt + 1 LET l_strcnt = l_cnt LET l_qdkey = "qdkey", l_strcnt LET m_change_text = l_text CALL QDchange_text(l_qdkey, ma_column[i], "1") LET l_text = m_change_text END IF END FOR LET l_finished = TRUE END IF END WHILE CLOSE WINDOW qbewind RETURN l_text END FUNCTION # Replace l_old with l_new in m_change_text FUNCTION QDchange_text(l_old, l_new, l_global) DEFINE l_old CHAR(600), l_new CHAR(600), l_global CHAR(1), l_cnt SMALLINT, l_oldlth SMALLINT, l_difflth SMALLINT, l_for SMALLINT, i SMALLINT LET l_cnt = LENGTH(m_change_text) LET l_oldlth = LENGTH(l_old) LET l_difflth = l_old - LENGTH(l_new) LET l_for = l_cnt - l_oldlth FOR i = 1 TO l_for IF m_change_text[i, i+l_oldlth-1]=l_old CLIPPED THEN IF i > 1 THEN LET m_change_text = m_change_text[1,i-1],l_new CLIPPED, m_change_text[i+l_oldlth,l_cnt] CLIPPED ELSE LET m_change_text = l_new CLIPPED, m_change_text[i+l_oldlth,l_cnt] CLIPPED END IF # 18/10/94 EJD # If a 'global' replace (l_global = "g") then don't EXIT FOR here but adjust # lengths, counts, etc and continue until all l_olds are found IF l_global != "g" THEN EXIT FOR ELSE LET l_for = l_for - l_difflth LET l_cnt = l_cnt - l_difflth LET i = i - l_difflth END IF END IF END FOR END FUNCTION FUNCTION QDclear_desc() # Clear out current row details DEFINE i SMALLINT FOR i = 1 TO 10 LET ma_desc[i] = NULL END FOR END FUNCTION FUNCTION QDgetcollen(l_table, l_column) # Get size of column (from syscolumns) DEFINE l_table CHAR(18), # LIKE systables.tabname, l_column CHAR(18), # LIKE syscolumns.colname, l_desclen SMALLINT SELECT collength INTO l_desclen FROM syscolumns, systables WHERE systables.tabname = l_table AND syscolumns.tabid = systables.tabid AND syscolumns.colname = l_column IF status = NOTFOUND THEN LET l_desclen = 0 END IF RETURN l_desclen END FUNCTION FUNCTION QDsystem_error() DEFINE l_status INTEGER LET l_status = status LET m_select = err_get(l_status) IF l_status != -219 AND l_status != -1213 THEN LET m_select = "ERROR in coxxq01.4gl!<",m_select CLIPPED ,"<", "Please quote the above error message to your ", "support company" END IF CALL message_prompt(m_select, "") LET m_select = "SELECT ROWID FROM syscolumns WHERE ROWID = -6" CALL QDbuild_cursor() END FUNCTION FUNCTION QDsetup_tags() DECLARE smeg CURSOR FOR SELECT line FROM tagtable ORDER BY line OPEN smeg END FUNCTION FUNCTION next_tag() DEFINE l_rec INTEGER, i SMALLINT, la_desc ARRAY[10] OF CHAR(80) WHENEVER ANY ERROR CONTINUE # Cope with unopen cursors FETCH smeg INTO l_rec FETCH ABSOLUTE l_rec qdcurs INTO ma_desc[1], ma_desc[2], ma_desc[3], ma_desc[4], ma_desc[5], ma_desc[6], ma_desc[7], ma_desc[8], ma_desc[9], ma_desc[10] -- WHENEVER ANY ERROR CALL QDsystem_error WHENEVER ANY ERROR STOP IF status !=0 THEN LET la_desc[1]= NULL ELSE IF m_tagkeycnt > 0 THEN FOR i = 1 TO m_tagkeycnt IF i + m_tagstartcol > 10 THEN LET la_desc[i] = "" ELSE LET la_desc[i] = ma_desc[i + m_tagstartcol - 1] END IF END FOR END IF END IF CASE WHEN m_tagkeycnt = 0 RETURN WHEN m_tagkeycnt = 1 RETURN la_desc[1] WHEN m_tagkeycnt = 2 RETURN la_desc[1], la_desc[2] WHEN m_tagkeycnt = 3 RETURN la_desc[1], la_desc[2], la_desc[3] WHEN m_tagkeycnt = 4 RETURN la_desc[1], la_desc[2], la_desc[3], la_desc[4] WHEN m_tagkeycnt = 5 RETURN la_desc[1], la_desc[2], la_desc[3], la_desc[4], la_desc[5] WHEN m_tagkeycnt = 6 RETURN la_desc[1], la_desc[2], la_desc[3], la_desc[4], la_desc[5], la_desc[6] WHEN m_tagkeycnt = 7 RETURN la_desc[1], la_desc[2], la_desc[3], la_desc[4], la_desc[5], la_desc[6], la_desc[7] WHEN m_tagkeycnt = 8 RETURN la_desc[1], la_desc[2], la_desc[3], la_desc[4], la_desc[5], la_desc[6], la_desc[7], la_desc[8] WHEN m_tagkeycnt = 9 RETURN la_desc[1], la_desc[2], la_desc[3], la_desc[4], la_desc[5], la_desc[6], la_desc[7], la_desc[8], la_desc[9] WHEN m_tagkeycnt = 10 RETURN la_desc[1], la_desc[2], la_desc[3], la_desc[4], la_desc[5], la_desc[6], la_desc[7], la_desc[8], la_desc[9], la_desc[10] END CASE END FUNCTION FUNCTION coxxq01_id() DEFINE l_id CHAR(80) LET l_id = '$Id: coxxq01.4gl,v 2.28 1995/12/27 20:53:49 maugan Exp $' END FUNCTION @EOF set `wc -lwc coxxq01a.per <<'@EOF' { $Id: coxxq01a.per,v 2.0 1994/08/08 05:24:11 q1 Exp $ } DATABASE formonly SCREEN { [f01 ][f02 ] } ATTRIBUTES f01 = formonly.keyname; f02 = formonly.keyqbe1; INSTRUCTIONS DELIMITERS " " SCREEN RECORD anyqbe[1](formonly.keyname) SCREEN RECORD scrrr(formonly.keyqbe1 THRU formonly.keyqbe1) @EOF set `wc -lwc coxxq01b.per <<'@EOF' { $Id: coxxq01b.per,v 2.0 1994/08/08 05:24:21 q1 Exp $ } DATABASE formonly SCREEN { [f01 ][f02 ] [f01 ][f03 ] } ATTRIBUTES f01 = formonly.keyname; f02 = formonly.keyqbe1; f03 = formonly.keyqbe2; INSTRUCTIONS DELIMITERS " " SCREEN RECORD anyqbe[2](formonly.keyname) SCREEN RECORD scrrr(formonly.keyqbe1 THRU formonly.keyqbe2) @EOF set `wc -lwc coxxq01c.per <<'@EOF' { $Id: coxxq01c.per,v 2.0 1994/08/08 05:24:31 q1 Exp $ } DATABASE formonly SCREEN { [f01 ][f02 ] [f01 ][f03 ] [f01 ][f04 ] } ATTRIBUTES f01 = formonly.keyname; f02 = formonly.keyqbe1; f03 = formonly.keyqbe2; f04 = formonly.keyqbe3; INSTRUCTIONS DELIMITERS " " SCREEN RECORD anyqbe[3](formonly.keyname) SCREEN RECORD scrrr(formonly.keyqbe1 THRU formonly.keyqbe3) @EOF set `wc -lwc coxxq01d.per <<'@EOF' { $Id: coxxq01d.per,v 2.0 1994/08/08 05:24:41 q1 Exp $ } DATABASE formonly SCREEN { [f01 ][f02 ] [f01 ][f03 ] [f01 ][f04 ] [f01 ][f05 ] } ATTRIBUTES f01 = formonly.keyname; f02 = formonly.keyqbe1; f03 = formonly.keyqbe2; f04 = formonly.keyqbe3; f05 = formonly.keyqbe4; INSTRUCTIONS DELIMITERS " " SCREEN RECORD anyqbe[4](formonly.keyname) SCREEN RECORD scrrr(formonly.keyqbe1 THRU formonly.keyqbe4) @EOF set `wc -lwc coxxq01e.per <<'@EOF' { $Id: coxxq01e.per,v 2.0 1994/08/08 05:24:51 q1 Exp $ } DATABASE formonly SCREEN { [f01 ][f02 ] [f01 ][f03 ] [f01 ][f04 ] [f01 ][f05 ] [f01 ][f06 ] } ATTRIBUTES f01 = formonly.keyname; f02 = formonly.keyqbe1; f03 = formonly.keyqbe2; f04 = formonly.keyqbe3; f05 = formonly.keyqbe4; f06 = formonly.keyqbe5; INSTRUCTIONS DELIMITERS " " SCREEN RECORD anyqbe[5](formonly.keyname) SCREEN RECORD scrrr(formonly.keyqbe1 THRU formonly.keyqbe5) @EOF set `wc -lwc coxxq01f.per <<'@EOF' { $Id: coxxq01f.per,v 2.0 1994/08/08 05:25:03 q1 Exp $ } DATABASE formonly SCREEN { [f01 ][f02 ] [f01 ][f03 ] [f01 ][f04 ] [f01 ][f05 ] [f01 ][f06 ] [f01 ][f07 ] } ATTRIBUTES f01 = formonly.keyname; f02 = formonly.keyqbe1; f03 = formonly.keyqbe2; f04 = formonly.keyqbe3; f05 = formonly.keyqbe4; f06 = formonly.keyqbe5; f07 = formonly.keyqbe6; INSTRUCTIONS DELIMITERS " " SCREEN RECORD anyqbe[6](formonly.keyname) SCREEN RECORD scrrr(formonly.keyqbe1 THRU formonly.keyqbe6) @EOF set `wc -lwc coxxq01g.per <<'@EOF' { $Id: coxxq01g.per,v 2.0 1994/08/08 05:25:12 q1 Exp $ } DATABASE formonly SCREEN { [f01 ][f02 ] [f01 ][f03 ] [f01 ][f04 ] [f01 ][f05 ] [f01 ][f06 ] [f01 ][f07 ] [f01 ][f08 ] } ATTRIBUTES f01 = formonly.keyname; f02 = formonly.keyqbe1; f03 = formonly.keyqbe2; f04 = formonly.keyqbe3; f05 = formonly.keyqbe4; f06 = formonly.keyqbe5; f07 = formonly.keyqbe6; f08 = formonly.keyqbe7; INSTRUCTIONS DELIMITERS " " SCREEN RECORD anyqbe[7](formonly.keyname) SCREEN RECORD scrrr(formonly.keyqbe1 THRU formonly.keyqbe7) @EOF set `wc -lwc coxxq01h.per <<'@EOF' { $Id: coxxq01h.per,v 2.0 1994/08/08 05:25:20 q1 Exp $ } DATABASE formonly SCREEN { [f01 ][f02 ] [f01 ][f03 ] [f01 ][f04 ] [f01 ][f05 ] [f01 ][f06 ] [f01 ][f07 ] [f01 ][f08 ] [f01 ][f09 ] } ATTRIBUTES f01 = formonly.keyname; f02 = formonly.keyqbe1; f03 = formonly.keyqbe2; f04 = formonly.keyqbe3; f05 = formonly.keyqbe4; f06 = formonly.keyqbe5; f07 = formonly.keyqbe6; f08 = formonly.keyqbe7; f09 = formonly.keyqbe8; INSTRUCTIONS DELIMITERS " " SCREEN RECORD anyqbe[8](formonly.keyname) SCREEN RECORD scrrr(formonly.keyqbe1 THRU formonly.keyqbe8) @EOF set `wc -lwc coxxq01i.per <<'@EOF' { $Id: coxxq01i.per,v 2.0 1994/08/08 05:25:31 q1 Exp $ } DATABASE formonly SCREEN { [f01 ][f02 ] [f01 ][f03 ] [f01 ][f04 ] [f01 ][f05 ] [f01 ][f06 ] [f01 ][f07 ] [f01 ][f08 ] [f01 ][f09 ] [f01 ][f10 ] } ATTRIBUTES f01 = formonly.keyname; f02 = formonly.keyqbe1; f03 = formonly.keyqbe2; f04 = formonly.keyqbe3; f05 = formonly.keyqbe4; f06 = formonly.keyqbe5; f07 = formonly.keyqbe6; f08 = formonly.keyqbe7; f09 = formonly.keyqbe8; f10 = formonly.keyqbe9; INSTRUCTIONS DELIMITERS " " SCREEN RECORD anyqbe[9](formonly.keyname) SCREEN RECORD scrrr(formonly.keyqbe1 THRU formonly.keyqbe9) @EOF set `wc -lwc coxxq01j.per <<'@EOF' { $Id: coxxq01j.per,v 2.0 1994/08/08 05:25:41 q1 Exp $ } DATABASE formonly SCREEN { [f01 ][f02 ] [f01 ][f03 ] [f01 ][f04 ] [f01 ][f05 ] [f01 ][f06 ] [f01 ][f07 ] [f01 ][f08 ] [f01 ][f09 ] [f01 ][f10 ] [f01 ][f11 ] } ATTRIBUTES f01 = formonly.keyname; f02 = formonly.keyqbe1; f03 = formonly.keyqbe2; f04 = formonly.keyqbe3; f05 = formonly.keyqbe4; f06 = formonly.keyqbe5; f07 = formonly.keyqbe6; f08 = formonly.keyqbe7; f09 = formonly.keyqbe8; f10 = formonly.keyqbe9; f11 = formonly.keyqbe10; INSTRUCTIONS DELIMITERS " " SCREEN RECORD anyqbe[10](formonly.keyname) SCREEN RECORD scrrr(formonly.keyqbe1 THRU formonly.keyqbe10) @EOF set `wc -lwc coxxx03.4gl <<'@EOF' # $Id: coxxx03.4gl,v 2.8 1995/10/12 00:02:52 kerry Exp $ {****************************************************************************** * Filename : coxxx03.4gl * * System : Eunice 4GL - Common Module * * Purpose : Display text in a box and let user choose an option * * Returns : Option user chose * * Author : Kerry S * * Date Written : 04/10/93 * * Last Change : * * * * 07/10/93 Kerry S - Made code far more re-usable by splitting into * * setup_wwrap and next_wwrap functions. * * 29/10/93 Kerry S - Hard returns were not working since above mod * * 10/11/93 Kerry S - If only option is "Exit", don't return a value * * 24/03/94 Kerry S - next_wwrap sucks string space too much! * * 27/05/94 Kerry S - Never try to open a window bigger than the screen * * 21/07/94 Kerry S - Cludgey little mod to let you specify window width * * 30/03/95 Kerry S - Cope with running in the background * * 31/05/95 Kerry S - Added message_prompt_fussy() function * * 12/10/95 Kerry S - Cope with running in the background via "in_background" * * * ******************************************************************************} #! message_prompt(l_text, l_menu_commands) RETURNING l_choice #! - Displays "l_text" in a window on-screen, and prompts the user #! to make a choice from a ring menu list passed as a comma-delimted #! string. The function returns the user's selection. #! #! l_text - Text to display in window. #! - The "<" character is interpreted as a hard-return. #! - l_text is currently limited to 800 characters #! l_commands - Commands to place in ring menu, delimited by commas #! eg: "Yes,No" gives the user two options #! - A null "l_command" generates an "Exit" option #! - Only 5 options of 10 characters may be placed in #! the l_command string. #! l_choice - The full text of the ring menu choice the user chose #! #! message_prompt_fussy(l_row, l_col, l_width) #! - Allows fussy programmers the ability to place the message box #! window at a particular row and col, and a particular width #! (Passing 0 or NULL values indicates a default value will be used) #! #! setup_wwrap(l_text, l_width) RETURNING l_depth #! - Sets up a long text string for word-wrapping within l_width #! characters. #! #! next_wwrap() RETURNING l_formated_text #! - Returns formatted text line, being l_width characters of the #! l_text string passed to setup_wwrap(). #! #! #! eg: LET l_depth = setup_wwrap(l_long_text_string, 40) #! FOR i = 1 TO l_depth #! LET l_formated_to_40_characters_string = next_wwrap() #! PRINT l_formatted_to_40_characters_string #! END FOR #! DEFINE m_text CHAR(800), m_internalwidth SMALLINT, m_width SMALLINT, m_col SMALLINT, m_row SMALLINT, m_spos SMALLINT, m_line_text CHAR(132) FUNCTION message_prompt_fussy(l_row, l_col, l_width) DEFINE l_col SMALLINT, l_row SMALLINT, l_width SMALLINT LET m_col = l_col LET m_row = l_row LET m_width = l_width END FUNCTION FUNCTION message_prompt(l_text, l_commands) DEFINE l_text CHAR(800), l_commands CHAR(50), l_choice CHAR(10), l_width SMALLINT, l_depth SMALLINT, l_col SMALLINT, l_row SMALLINT, i SMALLINT IF l_commands IS NULL THEN LET l_commands = "Exit" END IF IF nvl(m_width, 0) = 0 THEN -- If particular width not specified LET l_width = 50 -- just default to 50 characters ELSE LET l_width = m_width -- otherwise use specified width END IF IF l_text[1,6]="WIDTH=" THEN -- Ugly cludge kept for backwards WHENEVER ANY ERROR CONTINUE -- compatability only. Should use LET l_width = l_text[7,8] -- message_prompt_fussy instead IF status !=0 THEN LET l_width = 50 END IF WHENEVER ANY ERROR STOP LET l_text = l_text[9, 800] END IF # Calculate depth of box... LET l_depth = setup_wwrap(l_text, l_width) LET l_depth = l_depth + 3 IF nvl(m_row, 0) = 0 THEN LET l_row = (20 - l_depth) / 2 ELSE LET l_row = m_row END IF IF nvl(m_col, 0) = 0 THEN LET l_col = (80 - l_width) / 2 ELSE LET l_col = m_col END IF CALL message_prompt_fussy(0, 0, 0) -- Reset fussy stuff for the next -- time this routine is called IF l_row < 2 THEN LET l_row = 2 END IF IF l_col < 2 THEN LET l_col = 2 END IF IF l_depth > 19 THEN LET l_depth = 19 END IF OPEN WINDOW msgbox AT l_row, l_col WITH l_depth ROWS, l_width COLUMNS ATTRIBUTE(BORDER, YELLOW) # Display message text... LET l_depth = l_depth - 3 LET l_row = 3 FOR i = 1 TO l_depth CALL coxxx03_study_text() DISPLAY m_line_text AT l_row, 1 ATTRIBUTE(NORMAL) LET l_row = l_row + 1 END FOR # Let user select choice from ring menu... LET l_choice = coxxx03_varimenu(l_commands) CLOSE WINDOW msgbox IF l_commands != "Exit" THEN RETURN l_choice END IF END FUNCTION FUNCTION setup_wwrap(l_text, l_width) DEFINE l_text CHAR(800), # Text string to be formatted l_width SMALLINT, # Width of the box l_depth SMALLINT, # Depth of the box l_lth SMALLINT # Length of entire text string LET m_internalwidth = l_width LET m_text = l_text LET l_depth = 0 LET l_lth = length(m_text) LET m_spos = 1 WHILE m_spos <= l_lth CALL coxxx03_study_text() LET l_depth = l_depth + 1 END WHILE LET m_spos = 1 LET m_text = l_text RETURN l_depth END FUNCTION FUNCTION next_wwrap() DEFINE l_text CHAR(132) CALL coxxx03_study_text() LET l_text = m_line_text RETURN l_text END FUNCTION FUNCTION coxxx03_study_text() DEFINE l_epos SMALLINT, # End position in text string l_hp SMALLINT # Hard-return position ("<") # First look for a white-space to end the line on... FOR l_epos = m_spos + m_internalwidth TO m_spos STEP -1 IF m_text[l_epos]=" " THEN EXIT FOR END IF END FOR IF m_spos >= l_epos THEN # Could not find a white-space, so LET l_epos = m_spos + m_internalwidth # just chop off end of word END IF FOR l_hp = m_spos TO l_epos # Have a look for hard-return code... IF m_text[l_hp]="<" THEN # Found it... LET l_epos = l_hp LET m_text[l_hp]=" " EXIT FOR END IF END FOR LET m_line_text = m_text[m_spos, l_epos] # This is our text to output LET m_spos = l_epos + 1 END FUNCTION FUNCTION coxxx03_varimenu(l_commands) DEFINE i SMALLINT, l_lth SMALLINT, l_cnt SMALLINT, l_s SMALLINT, l_commands CHAR(50), la_opt ARRAY[5] OF CHAR(10), l_choice CHAR(10), l_menu_name CHAR(10) # First determine which options are required... LET l_cnt = 1 LET l_s = 1 LET l_lth = LENGTH(l_commands) FOR i = 1 TO l_lth IF l_commands[i,i]="," THEN LET la_opt[l_cnt] = l_commands[l_s, i-1] LET l_s = i + 1 LET l_cnt = l_cnt + 1 END IF END FOR LET la_opt[l_cnt] = l_commands[l_s, l_lth] IF l_cnt = 1 THEN LET l_menu_name = "MESSAGE" ELSE LET l_menu_name = "SELECT" END IF # The following code is something that I find very embarrassing, but it's # necessary if this routine is going to perform well for the user... CASE WHEN l_cnt = 1 MENU l_menu_name COMMAND la_opt[1] LET l_choice = la_opt[1] EXIT MENU END MENU WHEN l_cnt = 2 MENU l_menu_name COMMAND la_opt[1] LET l_choice = la_opt[1] EXIT MENU COMMAND la_opt[2] LET l_choice = la_opt[2] EXIT MENU END MENU WHEN l_cnt = 3 MENU l_menu_name COMMAND la_opt[1] LET l_choice = la_opt[1] EXIT MENU COMMAND la_opt[2] LET l_choice = la_opt[2] EXIT MENU COMMAND la_opt[3] LET l_choice = la_opt[3] EXIT MENU END MENU WHEN l_cnt = 4 MENU l_menu_name COMMAND la_opt[1] LET l_choice = la_opt[1] EXIT MENU COMMAND la_opt[2] LET l_choice = la_opt[2] EXIT MENU COMMAND la_opt[3] LET l_choice = la_opt[3] EXIT MENU COMMAND la_opt[4] LET l_choice = la_opt[4] EXIT MENU END MENU WHEN l_cnt = 5 MENU l_menu_name COMMAND la_opt[1] LET l_choice = la_opt[1] EXIT MENU COMMAND la_opt[2] LET l_choice = la_opt[2] EXIT MENU COMMAND la_opt[3] LET l_choice = la_opt[3] EXIT MENU COMMAND la_opt[4] LET l_choice = la_opt[4] EXIT MENU COMMAND la_opt[5] LET l_choice = la_opt[5] EXIT MENU END MENU END CASE RETURN l_choice END FUNCTION FUNCTION coxxx03_id() DEFINE l_id CHAR(80) LET l_id = '$Id: coxxx03.4gl,v 2.8 1995/10/12 00:02:52 kerry Exp $' END FUNCTION @EOF set `wc -lwc misql.4gl <<'@EOF' # $Id: misql.4gl,v 3.0 1996/12/06 04:27:28 kerry Exp $ # MISQL - Kerry's alternative to Informix-ISQL { MISQL is the result of work done on behalf of QUANTA SYSTEMS LTD, AUCKLAND, NEW ZEALAND, and has been placed in the public domain with their consent. There are no restrictions on how you can use it, but please always include a reference to QUANTA SYSTEMS LTD and myself in any derivative of this work. Cheers, Kerry Sainsbury (kerry@kcbbs.gen.nz, kerry@quanta.co.nz) PS: Here's the obligatory disclaimer: QUANTA SYSTEMS LTD DISCLAIMS ALL WARRANTIES RELATING TO THIS SOFTWARE, WHETHER EXPRSSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE, AND ALL SUCH WARRANTIES ARE EXPRESSLY AND SPECIFICALLY DISCLAIMED. NEITHER QUANTA SYSTEMS LTD NOR ANYONE INVOLVED IN THE CREATION, PRODUCTION, OR DELIVERY OF THIS SOFTWARE SHALL BE LIABLE FOR ANY INDIRECT, CONSEQUENTIAL, OR INCIDENTAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE SUCH SOFTWARE EVEN IF QUANTA SYSTEMS LTD HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES OR CLAIMS. IN NO EVENT SHALL QUANTA SYSTEMS LTD LIABILITY FOR ANY DAMAGES EVER EXCEED THE PRICE PAID FOR THE LICENSE TO USE THE SOFTWARE, REGARDLESS OF THE FORM OF CLAIM. THE PERSON USING THE SOFTWARE BEARS ALL RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE. } # 30/03/94 Kerry S - Ready for beta testing... # 06/04/94 Kerry S - Add "!" shell function # 06/04/94 Kerry S - Add second parameter to automatically run a given form # 18/04/94 Kerry S - Say if Insert/Update/Delete succeeded # - Display SQL statements in correct order! # - Display number of rows found after a Query # 20/04/94 Kerry S - Tidy up shell function # 21/04/94 Kerry S - Add "Searching..." message # 27/04/94 Kerry S - Fix nasty loop if enter character in numeric field # when doing the Query-by-Example # 25/05/94 Kerry S - Could not set a column to null # 31/05/94 Kerry S - Internal screen count did not reset when choose Query # 07/06/94 Kerry S - Add "Output" option for forms # 09/06/94 Kerry S - When leave "Query-Language", go to "Forms" and return to # "Query-Language" your query was destroyed. # 30/06/94 Kerry S - Make backward compatible with Informix 4.0 # (per Kingsley's notes) # 18/07/94 Kerry S - Sort tables by tablename # 16/08/94 Kerry S - Cope with != # - in QBE now cancels Query # - Say "0 rows found" if can't find any at all # 17/08/94 Kerry S - Add an "Info" option # 17/08/94 Kerry S - Cope with | in QBE # 18/08/94 Kerry S - Bug with | code # 18/08/94 Kerry S - Bug with | code (part 2) # - Added -v version display # 26/08/94 Kerry S - Would not INSERT if enter lots of columns # 25/11/94 Kerry S - Display blank page where deleted records used to be # 05/01/95 Kerry S - "=" now checks for ='' OR IS NULL (not just IS NULL) # 02/05/95 Kerry S - Removed stupid wanky *slow* "x rows found" message # 10/05/95 Kerry S - Added an "OUTPUT" to Query menu # 18/06/95 Kerry S - Now clever enough to figure out if they have dbaccess # or isql, and use whichever is appropriate for SQL # commands # 02/07/95 Kerry S - Added "View" to forms menu to re-load current record # - When no database name passed as argument 2 assume they # want to use $E4GLDBNAME rather than "eunice" # 22/11/95 Greg A - Modified to test arg_val 1 to see if it's a database # and if its not assumes it its a table in $E4GLDBNAME # 01/04/96 Kerry S - Fixed strange Network errors # 25/06/96 Kerry S - Was complaining about database not being closed before # opening a new one # 05/07/96 Kerry S - "=" now checks for IS NULL only. Was also checking for # ="" which, for some reason, returns rows for numeric # columns that contain a zero. # 25/07/96 Kerry S - Removed dependancy on having a "eunice" database DEFINE m_tabname CHAR(18), m_database CHAR(50), m_realname CHAR(100), # Holds original .sql filename m_viname CHAR(100), # Holds filename of current .sql file m_rowid INTEGER, ma_col ARRAY[300] OF RECORD colname CHAR(18), val CHAR(100) END RECORD, ma_diff ARRAY[300] OF INTEGER, m_text CHAR(3000), m_depth INTEGER, m_isql_or_dbaccess CHAR(9) MAIN # WHENEVER ANY ERROR CALL serious_error # CALL init_prog("misql") DEFER INTERRUPT DEFER QUIT OPTIONS MESSAGE LINE LAST IF arg_val(1) = "-v" OR arg_val(1) = "-V" THEN CALL message_prompt("$Id: misql.4gl,v 3.0 1996/12/06 04:27:28 kerry Exp $","") EXIT PROGRAM END IF LET m_database = arg_val(1) LET m_tabname = arg_val(2) WHENEVER ANY ERROR CONTINUE -- GPA added following test to figure LET m_text = "DATABASE ",m_database -- out with to use argval(1) as dbase PREPARE test_database FROM m_text -- or as table for $E4GLDBNAME EXECUTE test_database WHENEVER ANY ERROR STOP IF status!=0 THEN LET m_tabname = m_database LET m_database = fgl_getenv("E4GLDBNAME") END IF LET m_text = "database ",m_database PREPARE oo_p FROM m_text EXECUTE oo_p IF m_tabname IS NULL OR m_tabname = " " THEN LET m_tabname = NULL END IF WHENEVER ERROR CALL local_error LET m_depth = 17 OPEN FORM misql FROM "/usr/e4gl/bin/misql" CREATE TEMP TABLE picklist (textt char(80), linee serial) WITH NO LOG IF m_tabname IS NOT NULL THEN CALL form_maint(m_tabname) END IF MENU "MI-SQL" COMMAND "Form" "Run a form" CALL form_maint("") COMMAND "Query-Language" "Use Informix Structured Query Language" CALL query_maint() COMMAND "Database" "Change current database" CALL new_database() COMMAND "Exit" "Exit MI-SQL" EXIT MENU COMMAND KEY ("!") CALL shell() # COMMAND KEY(F12) CALL user_menu() -- COMMAND KEY(CONTROL-W) CALL show_help("") END MENU LET m_text = "rm -f /tmp/m????????.tmp" # Cleanup temp .sql files RUN m_text END MAIN FUNCTION clear_stuff() DEFINE i INTEGER FOR i = 1 TO 300 LET ma_col[i].val = "" LET ma_diff[i] = FALSE END FOR END FUNCTION FUNCTION do_query() DEFINE i, j INTEGER, l_where CHAR(1000), l_cnt INTEGER, l_first INTEGER, l_wc INTEGER, l_word CHAR(80), l_val CHAR(100) CALL set_count(300) OPTIONS INSERT KEY f35, DELETE KEY f35 CALL clear_stuff() INPUT ARRAY ma_col WITHOUT DEFAULTS FROM scr.* IF check_del("") THEN RETURN END IF LET l_where = "select rowid, * from ",m_tabname CLIPPED, " where 1=1 " FOR i = 1 TO 300 IF ma_col[i].val IS NOT NULL THEN CASE WHEN string_in("*", ma_col[i].val) LET l_where = l_where CLIPPED, " and ",ma_col[i].colname CLIPPED, " matches '",ma_col[i].val CLIPPED,"'" WHEN ma_col[i].val = "<<" LET l_where = l_where CLIPPED, " and ",ma_col[i].colname CLIPPED, " = (select min(",ma_col[i].colname CLIPPED,") from ", m_tabname CLIPPED,")" WHEN ma_col[i].val = ">>" LET l_where = l_where CLIPPED, " and ",ma_col[i].colname CLIPPED, " = (select max(",ma_col[i].colname CLIPPED,") from ", m_tabname CLIPPED,")" WHEN ma_col[i].val[1] = "<" OR ma_col[i].val[1] = ">" LET l_where = l_where CLIPPED, " and ",ma_col[i].colname CLIPPED, ma_col[i].val CLIPPED WHEN ma_col[i].val = "=" LET l_where = l_where CLIPPED, " and ", ma_col[i].colname CLIPPED, " IS NULL" # WHEN ma_col[i].val = "=''" # LET l_where = l_where CLIPPED, " and ", # ma_col[i].colname CLIPPED, " = ''" # ma_col[i].colname CLIPPED, " IS NULL OR ", # ma_col[i].colname CLIPPED, " = '')" WHEN ma_col[i].val = "!=" LET l_where = l_where CLIPPED, " and ",ma_col[i].colname CLIPPED, " IS NOT NULL" WHEN ma_col[i].val[1,2] = "!=" LET l_where = l_where CLIPPED, " and ",ma_col[i].colname CLIPPED, ma_col[i].val CLIPPED OTHERWISE # Assume "=" LET l_where = l_where CLIPPED, " and ",ma_col[i].colname CLIPPED, " IN (" LET l_first = TRUE LET l_val = ma_col[i].val LET l_word = "" LET l_wc = 0 FOR j = 1 TO LENGTH(l_val) # Scan thru looking for pipes (|) IF l_val[j] = "|" THEN # so can build multiple selection IF NOT l_first THEN # criteria... LET l_where = l_where CLIPPED, "," END IF LET l_where = l_where CLIPPED,"'", l_word CLIPPED,"' " LET l_first = FALSE LET l_word = "" LET l_wc = 0 ELSE LET l_wc = l_wc + 1 LET l_word[l_wc] = l_val[j] END IF END FOR IF NOT l_first THEN LET l_where = l_where CLIPPED, "," END IF LET l_where = l_where CLIPPED,"'", l_word CLIPPED,"')" END CASE END IF END FOR MESSAGE "Searching..." # PREPARE cntpre FROM l_where # IF STATUS !=0 THEN # RETURN # END IF # DECLARE cnt_curs CURSOR FOR cntpre # IF STATUS !=0 THEN # RETURN # END IF # LET l_cnt = 0 # FOREACH cnt_curs # IF STATUS !=0 THEN # RETURN # END IF # LET l_cnt = l_cnt + 1 # END FOREACH # MESSAGE l_cnt USING "<<<<&"," row(s) found" # CLOSE cnt_curs # IF STATUS !=0 THEN # RETURN # END IF # IF l_cnt = 0 THEN # RETURN # END IF PREPARE pre FROM l_where IF STATUS !=0 THEN RETURN END IF DECLARE qcurs SCROLL CURSOR WITH HOLD FOR pre IF STATUS !=0 THEN RETURN END IF OPEN qcurs IF STATUS !=0 THEN RETURN END IF MESSAGE "Searching... Complete" CALL show_next(1) END FUNCTION FUNCTION show_next(l_page) DEFINE l_page INTEGER FETCH NEXT qcurs INTO m_rowid IF STATUS != 0 THEN ERROR "No more rows in that direction" ELSE CALL load_stuff() END IF LET l_page = disp_page(l_page) END FUNCTION FUNCTION load_stuff() DEFINE i INTEGER LET m_text = "select * from ",m_tabname CLIPPED," where rowid = ",m_rowid PREPARE ls FROM m_text IF STATUS !=0 THEN RETURN END IF DECLARE lsc CURSOR FOR ls IF STATUS !=0 THEN RETURN END IF OPEN lsc IF STATUS !=0 THEN RETURN END IF FETCH lsc INTO ma_col[1].val,ma_col[2].val,ma_col[3].val,ma_col[4].val,ma_col[5].val, ma_col[6].val,ma_col[7].val,ma_col[8].val,ma_col[9].val, ma_col[10].val,ma_col[11].val,ma_col[12].val,ma_col[13].val,ma_col[14].val, ma_col[15].val,ma_col[16].val,ma_col[17].val,ma_col[18].val,ma_col[19].val, ma_col[20].val,ma_col[21].val,ma_col[22].val,ma_col[23].val,ma_col[24].val, ma_col[25].val,ma_col[26].val,ma_col[27].val,ma_col[28].val,ma_col[29].val, ma_col[30].val,ma_col[31].val,ma_col[32].val,ma_col[33].val,ma_col[34].val, ma_col[35].val,ma_col[36].val,ma_col[37].val,ma_col[38].val,ma_col[39].val, ma_col[40].val,ma_col[41].val,ma_col[42].val,ma_col[43].val,ma_col[44].val, ma_col[45].val,ma_col[46].val,ma_col[47].val,ma_col[48].val,ma_col[49].val, ma_col[50].val,ma_col[51].val,ma_col[52].val,ma_col[53].val,ma_col[54].val, ma_col[55].val,ma_col[56].val,ma_col[57].val,ma_col[58].val,ma_col[59].val, ma_col[60].val,ma_col[61].val,ma_col[62].val,ma_col[63].val,ma_col[64].val, ma_col[65].val,ma_col[66].val,ma_col[67].val,ma_col[68].val,ma_col[69].val, ma_col[70].val,ma_col[71].val,ma_col[72].val,ma_col[73].val,ma_col[74].val, ma_col[75].val,ma_col[76].val,ma_col[77].val,ma_col[78].val,ma_col[79].val, ma_col[80].val,ma_col[81].val,ma_col[82].val,ma_col[83].val,ma_col[84].val, ma_col[85].val,ma_col[86].val,ma_col[87].val,ma_col[88].val,ma_col[89].val, ma_col[90].val,ma_col[91].val,ma_col[92].val,ma_col[93].val,ma_col[94].val, ma_col[95].val,ma_col[96].val,ma_col[97].val,ma_col[98].val,ma_col[99].val, ma_col[100].val,ma_col[101].val,ma_col[102].val,ma_col[103].val,ma_col[104].val, ma_col[105].val,ma_col[106].val,ma_col[107].val,ma_col[108].val,ma_col[109].val, ma_col[110].val,ma_col[111].val,ma_col[112].val,ma_col[113].val,ma_col[114].val, ma_col[115].val,ma_col[116].val,ma_col[117].val,ma_col[118].val,ma_col[119].val, ma_col[120].val,ma_col[121].val,ma_col[122].val,ma_col[123].val,ma_col[124].val, ma_col[125].val,ma_col[126].val,ma_col[127].val,ma_col[128].val,ma_col[129].val, ma_col[130].val,ma_col[131].val,ma_col[132].val,ma_col[133].val,ma_col[134].val, ma_col[135].val,ma_col[136].val,ma_col[137].val,ma_col[138].val,ma_col[139].val, ma_col[140].val,ma_col[141].val,ma_col[142].val,ma_col[143].val,ma_col[144].val, ma_col[145].val,ma_col[146].val,ma_col[147].val,ma_col[148].val,ma_col[149].val, ma_col[150].val,ma_col[151].val,ma_col[152].val,ma_col[153].val,ma_col[154].val, ma_col[155].val,ma_col[156].val,ma_col[157].val,ma_col[158].val,ma_col[159].val, ma_col[160].val,ma_col[161].val,ma_col[162].val,ma_col[163].val,ma_col[164].val, ma_col[165].val,ma_col[166].val,ma_col[167].val,ma_col[168].val,ma_col[169].val, ma_col[170].val,ma_col[171].val,ma_col[172].val,ma_col[173].val,ma_col[174].val, ma_col[175].val,ma_col[176].val,ma_col[177].val,ma_col[178].val,ma_col[179].val, ma_col[180].val,ma_col[181].val,ma_col[182].val,ma_col[183].val,ma_col[184].val, ma_col[185].val,ma_col[186].val,ma_col[187].val,ma_col[188].val,ma_col[189].val, ma_col[190].val,ma_col[191].val,ma_col[192].val,ma_col[193].val,ma_col[194].val, ma_col[195].val,ma_col[196].val,ma_col[197].val,ma_col[198].val,ma_col[199].val, ma_col[200].val,ma_col[201].val,ma_col[202].val,ma_col[203].val,ma_col[204].val, ma_col[205].val,ma_col[206].val,ma_col[207].val,ma_col[208].val,ma_col[209].val, ma_col[210].val,ma_col[211].val,ma_col[212].val,ma_col[213].val,ma_col[214].val, ma_col[215].val,ma_col[216].val,ma_col[217].val,ma_col[218].val,ma_col[219].val, ma_col[220].val,ma_col[221].val,ma_col[222].val,ma_col[223].val,ma_col[224].val, ma_col[225].val,ma_col[226].val,ma_col[227].val,ma_col[228].val,ma_col[229].val, ma_col[230].val,ma_col[231].val,ma_col[232].val,ma_col[233].val,ma_col[234].val, ma_col[235].val,ma_col[236].val,ma_col[237].val,ma_col[238].val,ma_col[239].val, ma_col[240].val,ma_col[241].val,ma_col[242].val,ma_col[243].val,ma_col[244].val, ma_col[245].val,ma_col[246].val,ma_col[247].val,ma_col[248].val,ma_col[249].val, ma_col[250].val,ma_col[251].val,ma_col[252].val,ma_col[253].val,ma_col[254].val, ma_col[255].val,ma_col[256].val,ma_col[257].val,ma_col[258].val,ma_col[259].val, ma_col[260].val,ma_col[261].val,ma_col[262].val,ma_col[263].val,ma_col[264].val, ma_col[265].val,ma_col[266].val,ma_col[267].val,ma_col[268].val,ma_col[269].val, ma_col[270].val,ma_col[271].val,ma_col[272].val,ma_col[273].val,ma_col[274].val, ma_col[275].val,ma_col[276].val,ma_col[277].val,ma_col[278].val,ma_col[279].val, ma_col[280].val,ma_col[281].val,ma_col[282].val,ma_col[283].val,ma_col[284].val, ma_col[285].val,ma_col[286].val,ma_col[287].val,ma_col[288].val,ma_col[289].val, ma_col[290].val,ma_col[291].val,ma_col[292].val,ma_col[293].val,ma_col[294].val, ma_col[295].val,ma_col[296].val,ma_col[297].val,ma_col[298].val,ma_col[299].val IF status !=0 THEN FOR i = 1 TO 299 LET ma_col[i].val = "" END FOR END IF END FUNCTION FUNCTION show_prev(l_page) DEFINE l_page INTEGER FETCH PREVIOUS qcurs INTO m_rowid IF STATUS != 0 THEN ERROR "No more rows in that direction" ELSE CALL load_stuff() END IF LET l_page = disp_page(l_page) END FUNCTION FUNCTION form_maint(l_tabname) DEFINE l_tabname CHAR(18) DEFINE l_tabid INTEGER, i INTEGER, l_page INTEGER IF l_tabname IS NOT NULL THEN LET m_tabname = l_tabname ELSE LET m_tabname = select_table() END IF SELECT tabid INTO l_tabid FROM SYSTABLES WHERE tabname = m_tabname IF STATUS !=0 THEN ERROR "Could not find the tablename in systables" RETURN END IF DISPLAY FORM misql CALL disp_dbtable() DECLARE isql_curs CURSOR FOR SELECT colname, colno FROM syscolumns WHERE syscolumns.tabid = l_tabid ORDER BY colno LET i = 0 FOREACH isql_curs INTO ma_col[i+1].colname LET i = i + 1 LET ma_col[i].val = NULL END FOREACH CALL set_count(i) FOR i = i + 1 TO 300 INITIALIZE ma_col[i].* TO NULL END FOR LET l_page = disp_page(1) MENU "PERFORM" COMMAND "Query" "Searches the active database table" MESSAGE "" CALL do_query() LET l_page = 1 COMMAND "Next" "Shows the next row in the Current List" MESSAGE "" CALL show_next(l_page) COMMAND "Previous" "Shows the previous row in the Current List" MESSAGE "" CALL show_prev(l_page) COMMAND "Add" "Add a row to the active database table" MESSAGE "" CALL clear_stuff() CALL input_stuff() IF NOT check_del("") THEN CALL insert_table() END IF COMMAND "Update" "Changes a row in the active database table" MESSAGE "" IF got_record() THEN CALL input_stuff() IF NOT check_del("") THEN CALL update_table() END IF END IF COMMAND "Remove" "Deletes a row from the active database table" MESSAGE "" IF got_record() THEN MENU "SURE" COMMAND "Yes" "Delete this row" CALL delete_table() CALL clear_stuff() LET l_page = disp_page(l_page) EXIT MENU COMMAND "No" "Do not delete this row" EXIT MENU # COMMAND KEY(F12) CALL user_menu() -- COMMAND KEY(CONTROL-W) CALL show_help("") END MENU END IF COMMAND "Forward" "Shows the next page of the form" MESSAGE "" LET l_page = disp_page(l_page+1) COMMAND "Back" "Shows the previous page of the form" MESSAGE "" IF l_page > 1 THEN LET l_page = disp_page(l_page-1) ELSE ERROR "Already on first page" END IF COMMAND "View" "View record again with latest data" MESSAGE "" IF got_record() THEN CALL load_stuff() LET l_page = disp_page(l_page) END IF COMMAND "Info" "Show column definitions" CALL load_info() LET l_page = disp_page(l_page) MENU "TABLE INFO" COMMAND "Forward" "Shows the next page of the form" MESSAGE "" LET l_page = disp_page(l_page+1) COMMAND "Back" "Shows the previous page of the form" MESSAGE "" IF l_page > 1 THEN LET l_page = disp_page(l_page-1) ELSE ERROR "Already on first page" END IF COMMAND "Exit" "Back to main forms menu" EXIT MENU # COMMAND KEY(F12) CALL user_menu() -- COMMAND KEY(CONTROL-W) CALL show_help("") END MENU CALL load_stuff() LET l_page = disp_page(l_page) COMMAND "Output" "Print this row's details to the printer" MESSAGE "" CALL output_row() COMMAND "Exit" "Exits to the MI-SQL Menu" MESSAGE "" EXIT MENU COMMAND KEY ("!") MESSAGE "" CALL shell() # COMMAND KEY(F12) CALL user_menu() -- COMMAND KEY(CONTROL-W) CALL show_help("") END MENU CLOSE isql_curs IF STATUS !=0 THEN RETURN END IF CLEAR SCREEN END FUNCTION FUNCTION got_record() IF m_rowid IS NULL THEN ERROR "No item selected!" RETURN FALSE END IF RETURN TRUE END FUNCTION FUNCTION input_stuff() DEFINE i INTEGER, l_curr INTEGER, l_old CHAR(100) INPUT ARRAY ma_col WITHOUT DEFAULTS FROM scr.* BEFORE ROW LET l_curr = arr_curr() LET l_old = ma_col[l_curr].val AFTER ROW IF (l_old != ma_col[l_curr].val) OR (l_old IS NULL AND ma_col[l_curr].val IS NOT NULL) OR (l_old IS NOT NULL AND ma_col[l_curr].val IS NULL) THEN LET ma_diff[l_curr] = TRUE END IF # ON KEY(F12) CALL user_menu() -- ON KEY(CONTROL-W) CALL show_help("") END INPUT END FUNCTION FUNCTION output_row() DEFINE i INTEGER START REPORT output_report FOR i = 1 TO 300 IF ma_col[i].colname IS NOT NULL THEN OUTPUT TO REPORT output_report(i) ELSE EXIT FOR END IF END FOR FINISH REPORT output_report END FUNCTION REPORT output_report(i) DEFINE i INTEGER OUTPUT REPORT TO PRINTER FORMAT ON EVERY ROW PRINT ma_col[i].colname, ma_col[i].val CLIPPED ON LAST ROW SKIP TO TOP OF PAGE END REPORT FUNCTION query_maint() DEFINE i INTEGER, l_outfile CHAR(100) # LET l_viname = get_tmpname() # LET l_realname = NULL MENU "QUERY" COMMAND "New" "Enter new SQL statements" LET m_viname = get_tmpname() LET m_text = "vi ",m_viname RUN m_text CALL show_sql(m_viname) NEXT OPTION "Run" COMMAND "Run" "Run the current SQL commands" IF m_viname IS NOT NULL THEN LET m_text = isql(),m_database CLIPPED, " < ",m_viname," | pg" RUN m_text # CALL execute_sql(m_viname) NEXT OPTION "Modify" ELSE ERROR "No command file is active!" NEXT OPTION "New" END IF COMMAND "Modify" "Modify the current SQL commands" IF m_viname IS NOT NULL THEN LET m_text = "vi ",m_viname RUN m_text CALL show_sql(m_viname) NEXT OPTION "Run" ELSE ERROR "Null command filename. Select New" NEXT OPTION "New" END IF COMMAND "Choose" "Choose a command file for the current SQL statement" LET m_text = pick_sql() IF m_text IS NOT NULL THEN LET m_realname = m_text IF m_viname IS NULL THEN LET m_viname = get_tmpname() END IF LET m_text = "cp ",m_realname clipped," ",m_viname RUN m_text CALL show_sql(m_realname) END IF NEXT OPTION "Run" COMMAND "Save" "Save the current SQL command file" IF m_realname IS NULL THEN ERROR "No command file is current. Use Save As" NEXT OPTION "As" ELSE LET m_text = "cp ",m_viname clipped," ",m_realname RUN m_text NEXT OPTION "Run" END IF COMMAND "As" "Save the current SQL command statement in a new command file" PROMPT "Save As: " FOR m_text IF m_text IS NOT NULL THEN LET i = LENGTH(m_text) IF m_text[i-3,i] != ".sql" THEN LET m_text = m_text CLIPPED,".sql" END IF LET m_realname = m_text LET m_text = "cp ",m_viname CLIPPED," ",m_text CLIPPED RUN m_text END IF NEXT OPTION "Run" COMMAND "Drop" "Drop an SQL command file" LET m_text = pick_sql() IF m_text IS NOT NULL THEN LET m_text = "rm -f ",m_text CLIPPED RUN m_text END IF NEXT OPTION "Exit" COMMAND "Output" "Run the current SQL commands and redirect output to a file" IF m_viname IS NOT NULL THEN PROMPT "Enter a output filename " FOR l_outfile IF NOT is_blank(l_outfile) THEN MESSAGE "Running..." LET m_text = isql(), m_database CLIPPED, " < ",m_viname," > ", l_outfile RUN m_text MESSAGE "Running... Complete" END IF # CALL execute_sql(m_viname) NEXT OPTION "Modify" ELSE ERROR "No command file is active!" NEXT OPTION "New" END IF COMMAND "Exit" "Exit to MI-SQL Menu" EXIT MENU COMMAND KEY ("!") CALL shell() # COMMAND KEY(F12) CALL user_menu() -- COMMAND KEY(CONTROL-W) CALL show_help("") END MENU END FUNCTION FUNCTION show_sql(l_sqlfile) DEFINE l_sqlfile CHAR(30), l_tmp CHAR(30), i INTEGER DELETE FROM picklist LET l_tmp = get_tmpname() LET l_tmp[14]="S" LET m_text = "cat ",l_sqlfile CLIPPED," | sed -e 's/$/~0~/' > ",l_tmp RUN m_text LOAD FROM l_tmp DELIMITER "~" INSERT INTO picklist DECLARE kcufs CURSOR FOR SELECT textt, linee FROM picklist ORDER BY linee LET l_sqlfile = l_sqlfile CLIPPED,":" DISPLAY l_sqlfile AT 4,1 ATTRIBUTE(NORMAL) OPEN kcufs FOR i = 5 TO 20 FETCH kcufs INTO m_text IF status !=0 THEN LET m_text = "" END IF LET m_text = m_text[1,80] DISPLAY m_text,"" AT i, 1 ATTRIBUTE(DIM) END FOR END FUNCTION # This routine needs to understand ; as end-of-command... FUNCTION execute_sql(l_sqlfile) DEFINE l_sqlfile CHAR(30), l_tmp CHAR(30), l_text CHAR(200), i INTEGER DELETE FROM picklist LET l_tmp = get_tmpname() LET m_text = "cat ",l_sqlfile CLIPPED," | sed -e 's/$/~0~/' > ",l_tmp RUN m_text LOAD FROM l_tmp DELIMITER "~" INSERT INTO picklist DECLARE ecufs CURSOR FOR SELECT textt, linee FROM picklist ORDER BY linee FOREACH ecufs INTO l_text LET m_text = m_text CLIPPED," ",l_text END FOREACH PREPARE exprep FROM m_text IF status != 0 THEN # ERROR "Error near character position ",SQLCA.SQLERRD[5] USING "<<<<<" RETURN END IF EXECUTE exprep IF status = 0 THEN MESSAGE SQLCA.SQLERRD[3] USING "<<<<<"," rows processed" END IF END FUNCTION FUNCTION pick_sql() DEFINE l_tmp CHAR(20), l_sqlfile CHAR(20) DELETE FROM picklist LET l_tmp = get_tmpname() LET m_text = "ls *sql | sed -e 's/$/+0+/' > ",l_tmp RUN m_text LOAD FROM l_tmp DELIMITER "+" INSERT INTO picklist LET m_text = "SELECT textt{k30} FROM picklist WHERE 1=1" LET l_sqlfile = query_window(m_text, "SQL file",1, "") RETURN l_sqlfile END FUNCTION FUNCTION get_tmpname() DEFINE l_tmp CHAR(30) LET l_tmp = "/tmp/m",TIME,".tmp" RETURN l_tmp END FUNCTION FUNCTION new_database() PROMPT "Database: " FOR m_text IF m_text IS NOT NULL THEN LET m_database = m_text LET m_text = "database ",m_database PREPARE f_pr FROM m_text EXECUTE f_pr CALL disp_dbtable() END IF END FUNCTION FUNCTION disp_dbtable() DEFINE i INTEGER LET m_text = m_database CLIPPED,":",m_tabname LET i = 80 - LENGTH(m_text) DISPLAY "" AT 2, 1 DISPLAY m_text CLIPPED AT 3, i END FUNCTION FUNCTION select_table() DEFINE l_tabname CHAR(18) LET m_text = "select tabname{k20} from systables WHERE 1=1 ORDER BY tabname" LET l_tabname = query_window(m_text, "Table", 1, "FQ|AS") RETURN l_tabname END FUNCTION FUNCTION disp_page(l_page) DEFINE l_page INTEGER, l_start INTEGER, i INTEGER LET l_start = ((l_page-1) * m_depth) + 1 IF ma_col[l_start].colname IS NULL THEN LET l_start = 1 LET l_page = 1 END IF FOR i = l_start TO l_start + m_depth -1 DISPLAY ma_col[i].colname, ma_col[i].val TO scr[i - l_start + 1].* END FOR RETURN l_page END FUNCTION FUNCTION insert_table() DEFINE i INTEGER, l_value CHAR(2000), l_first INTEGER LET l_first = TRUE LET m_text = "insert into ",m_tabname CLIPPED,"(" LET l_value= " values(" FOR i = 1 TO 300 IF ma_col[i].colname IS NULL THEN EXIT FOR END IF IF ma_diff[i] THEN IF NOT l_first THEN LET m_text = m_text CLIPPED,"," LET l_value = l_value CLIPPED,"," ELSE LET l_first = FALSE END IF LET m_text = m_text CLIPPED,ma_col[i].colname LET l_value = l_value CLIPPED,"'",ma_col[i].val CLIPPED,"'" END IF END FOR IF l_first THEN ERROR "MI-SQL Cannot insert a null record" ELSE LET m_text = m_text CLIPPED,") ",l_value CLIPPED,")" PREPARE pp2 FROM m_text EXECUTE pp2 IF status = 0 THEN MESSAGE "Row inserted" END IF END IF END FUNCTION FUNCTION delete_table() LET m_text = "delete from ",m_tabname CLIPPED," where rowid = ",m_rowid PREPARE DO FROM m_text EXECUTE DO IF status = 0 THEN MESSAGE "Row deleted" END IF LET m_rowid = NULL END FUNCTION FUNCTION update_table() DEFINE i INTEGER BEGIN WORK FOR i = 1 TO 300 IF ma_col[i].colname IS NULL THEN EXIT FOR END IF IF ma_diff[i] THEN LET m_text = "update ",m_tabname CLIPPED, " set ",ma_col[i].colname CLIPPED, " = '", ma_col[i].val CLIPPED, "' where rowid = ",m_rowid PREPARE pp FROM m_text IF STATUS !=0 THEN EXIT FOR END IF EXECUTE pp IF STATUS !=0 THEN EXIT FOR END IF END IF END FOR IF STATUS !=0 THEN ROLLBACK WORK ELSE MESSAGE "Row updated" COMMIT WORK END IF END FUNCTION FUNCTION string_in(word, l_where_part) DEFINE word CHAR(20), where_length INTEGER, lngth, i INTEGER, l_where_part CHAR(500) # Scan where_part for the first occurrence of word, # and return the position found. LET lngth = LENGTH(word) LET where_length = LENGTH(l_where_part) FOR i = 1 TO where_length IF l_where_part[i] = word[1] THEN IF l_where_part[i,i+lngth-1] = word THEN RETURN i END IF END IF END FOR RETURN 0 END FUNCTION FUNCTION local_error() DEFINE l_status INTEGER LET l_status = STATUS LET m_text = err_get(STATUS) ERROR m_text CLIPPED LET STATUS = l_status END FUNCTION FUNCTION shell() PROMPT "Command: !" FOR m_text IF m_text IS NOT NULL THEN RUN m_text PROMPT "Press to continue" FOR m_text END IF END FUNCTION FUNCTION load_info() DEFINE i INTEGER, l_tabid INTEGER, l_coltype INTEGER, l_collength INTEGER MESSAGE "Loading column definitions..." SELECT tabid INTO l_tabid FROM systables WHERE tabname = m_tabname IF status !=0 THEN CALL message_prompt("Information not found!", "") RETURN END IF DECLARE info_curs CURSOR FOR SELECT coltype, collength, colno FROM syscolumns WHERE syscolumns.tabid = l_tabid ORDER BY colno LET i = 0 FOREACH info_curs INTO l_coltype, l_collength LET i = i + 1 IF i = 301 THEN CALL message_prompt("More than 300 columns in table!", "") EXIT FOREACH END IF LET ma_col[i].val = get_type(l_coltype, l_collength) END FOREACH MESSAGE "" END FUNCTION -- Identify if client uses dbacess or isql... FUNCTION isql() DEFINE l_return_code INTEGER IF is_blank(m_isql_or_dbaccess) THEN RUN "dbaccess mja11a lkz99a 2>/dev/null" RETURNING l_return_code IF l_return_code / 256 = 1 THEN -- There's no dbaccess, so assume isql LET m_isql_or_dbaccess = "isql" ELSE LET m_isql_or_dbaccess = "dbaccess" END IF END IF RETURN m_isql_or_dbaccess END FUNCTION FUNCTION get_type(l_coltype, l_collength) DEFINE l_coltype INTEGER, l_collength INTEGER, type_text CHAR(41) CASE WHEN l_coltype=0 OR l_coltype=256 LET type_text="CHAR(", l_collength USING "<<<", ")" WHEN l_coltype=1 OR l_coltype=257 LET type_text="SMALLINT" WHEN l_coltype=2 OR l_coltype=258 LET type_text="INTEGER" WHEN l_coltype=3 OR l_coltype=259 LET type_text="FLOAT" WHEN l_coltype=4 OR l_coltype=260 LET type_text="SMALLFLOAT" WHEN l_coltype=5 OR l_coltype=261 LET type_text="DECIMAL" LET type_text = dec_length(l_collength, type_text) WHEN l_coltype=6 OR l_coltype=262 IF l_collength > 1 THEN LET type_text="SERIAL(", l_collength USING "<<<<<<<<<&", ")" ELSE LET type_text="SERIAL" END IF WHEN l_coltype=7 OR l_coltype=263 LET type_text="DATE" WHEN l_coltype=8 OR l_coltype=264 LET type_text="MONEY" LET type_text = dec_length(l_collength, type_text) WHEN l_coltype=10 OR l_coltype=266 LET type_text="DATETIME" LET type_text = dt_length(l_collength, type_text) WHEN l_coltype=11 OR l_coltype=267 LET type_text="BYTE" WHEN l_coltype=12 OR l_coltype=268 LET type_text="TEXT" WHEN l_coltype=13 OR l_coltype=269 LET type_text="VARCHAR" LET type_text = varc_length(l_collength, type_text) WHEN l_coltype=14 OR l_coltype=270 LET type_text="INTERVAL" LET type_text = dt_length(l_collength, type_text) OTHERWISE LET type_text="????" END CASE ## Now the not nulls IF l_coltype > 255 THEN LET type_text=type_text CLIPPED, " NOT NULL" END IF RETURN type_text END FUNCTION FUNCTION dec_length(l_collength, type_text) # calculate length & precision for DECIMAL & MONEY data types DEFINE type_text CHAR(41) DEFINE len, prec INTEGER # Length & Precision DEFINE l_collength INTEGER LET len = l_collength / 256 LET prec = l_collength mod 256 IF prec > len THEN IF type_text = "DECIMAL" THEN # floating precision INITIALIZE prec TO NULL ELSE # 0 precision LET prec = 0 END IF END IF IF prec IS NULL THEN LET type_text = type_text CLIPPED, "(", len USING "<<<<&", ")" ELSE LET type_text = type_text CLIPPED, "(", len USING "<<<<&", ",", prec USING "<<<<&", ")" END IF RETURN type_text END FUNCTION FUNCTION varc_length(l_collength, type_text) # calculate max & min length for VARCHAR data types DEFINE l_collength INTEGER DEFINE type_text CHAR(41) DEFINE minl, maxl INTEGER # Length & Precision LET maxl = l_collength mod 256 LET minl = l_collength / 256 IF minl < 2 THEN LET type_text = type_text CLIPPED, "(", maxl USING "<<<<&", ")" ELSE LET type_text = type_text CLIPPED, "(", maxl USING "<<<<&", ",", minl USING "<<<<&", ")" END IF RETURN type_text END FUNCTION FUNCTION dt_length(l_collength, type_text) # calculate range for DATETIME & INTERVAL DEFINE l_collength INTEGER DEFINE type_text CHAR(41) CASE WHEN l_collength = 459 LET type_text = type_text CLIPPED, " FRACTION TO FRACTION(1)" WHEN l_collength = 546 LET type_text = type_text CLIPPED, " MONTH TO MONTH" WHEN l_collength = 580 LET type_text = type_text CLIPPED, " DAY TO DAY" WHEN l_collength = 614 LET type_text = type_text CLIPPED, " HOUR TO HOUR" WHEN l_collength = 648 LET type_text = type_text CLIPPED, " MINUTE TO MINUTE" WHEN l_collength = 682 LET type_text = type_text CLIPPED, " SECOND TO SECOND" WHEN l_collength = 716 LET type_text = type_text CLIPPED, " FRACTION TO FRACTION(2)" WHEN l_collength = 939 LET type_text = type_text CLIPPED, " SECOND TO FRACTION(1)" WHEN l_collength = 973 # default fraction is 3, so no need for () LET type_text = type_text CLIPPED, " FRACTION TO FRACTION" WHEN l_collength = 1024 LET type_text = type_text CLIPPED, " YEAR TO YEAR" WHEN l_collength = 1060 LET type_text = type_text CLIPPED, " MONTH TO DAY" WHEN l_collength = 1094 LET type_text = type_text CLIPPED, " DAY TO HOUR" WHEN l_collength = 1128 LET type_text = type_text CLIPPED, " HOUR TO MINUTE" WHEN l_collength = 1162 LET type_text = type_text CLIPPED, " MINUTE TO SECOND" WHEN l_collength = 1196 LET type_text = type_text CLIPPED, " SECOND TO FRACTION(2)" WHEN l_collength = 1230 LET type_text = type_text CLIPPED, " FRACTION TO FRACTION(4)" WHEN l_collength = 1419 LET type_text = type_text CLIPPED, " MINUTE TO FRACTION(1)" WHEN l_collength = 1453 LET type_text = type_text CLIPPED, " SECOND TO FRACTION" WHEN l_collength = 1487 LET type_text = type_text CLIPPED, " FRACTION TO FRACTION(5)" WHEN l_collength = 1538 LET type_text = type_text CLIPPED, " YEAR TO MONTH" WHEN l_collength = 1574 LET type_text = type_text CLIPPED, " MONTH TO HOUR" WHEN l_collength = 1608 LET type_text = type_text CLIPPED, " DAY TO MINUTE" WHEN l_collength = 1642 LET type_text = type_text CLIPPED, " HOUR TO SECOND" WHEN l_collength = 1676 LET type_text = type_text CLIPPED, " MINUTE TO FRACTION(2)" WHEN l_collength = 1710 LET type_text = type_text CLIPPED, " SECOND TO FRACTION(4)" WHEN l_collength = 1899 LET type_text = type_text CLIPPED, " HOUR TO FRACTION(1)" WHEN l_collength = 1933 LET type_text = type_text CLIPPED, " MINUTE TO FRACTION" WHEN l_collength = 1967 LET type_text = type_text CLIPPED, " SECOND TO FRACTION(5)" WHEN l_collength = 2052 LET type_text = type_text CLIPPED, " YEAR TO DAY" WHEN l_collength = 2088 LET type_text = type_text CLIPPED, " MONTH TO MINUTE" WHEN l_collength = 2122 LET type_text = type_text CLIPPED, " DAY TO SECOND" WHEN l_collength = 2156 LET type_text = type_text CLIPPED, " HOUR TO FRACTION(2)" WHEN l_collength = 2190 LET type_text = type_text CLIPPED, " MINUTE TO FRACTION(4)" WHEN l_collength = 2379 LET type_text = type_text CLIPPED, " DAY TO FRACTION(1)" WHEN l_collength = 2413 LET type_text = type_text CLIPPED, " HOUR TO FRACTION" WHEN l_collength = 2447 LET type_text = type_text CLIPPED, " MINUTE TO FRACTION(5)" WHEN l_collength = 2566 LET type_text = type_text CLIPPED, " YEAR TO HOUR" WHEN l_collength = 2602 LET type_text = type_text CLIPPED, " MONTH TO SECOND" WHEN l_collength = 2636 LET type_text = type_text CLIPPED, " DAY TO FRACTION(2)" WHEN l_collength = 2670 LET type_text = type_text CLIPPED, " HOUR TO FRACTION(4)" WHEN l_collength = 2859 LET type_text = type_text CLIPPED, " MONTH TO FRACTION(1)" WHEN l_collength = 2893 LET type_text = type_text CLIPPED, " DAY TO FRACTION" WHEN l_collength = 2927 LET type_text = type_text CLIPPED, " HOUR TO FRACTION(5)" WHEN l_collength = 3080 LET type_text = type_text CLIPPED, " YEAR TO MINUTE" WHEN l_collength = 3116 LET type_text = type_text CLIPPED, " MONTH TO FRACTION(2)" WHEN l_collength = 3150 LET type_text = type_text CLIPPED, " DAY TO FRACTION(4)" WHEN l_collength = 3373 LET type_text = type_text CLIPPED, " MONTH TO FRACTION" WHEN l_collength = 3407 LET type_text = type_text CLIPPED, " DAY TO FRACTION(5)" WHEN l_collength = 3594 LET type_text = type_text CLIPPED, " YEAR TO SECOND" WHEN l_collength = 3630 LET type_text = type_text CLIPPED, " MONTH TO FRACTION(4)" WHEN l_collength = 3851 LET type_text = type_text CLIPPED, " YEAR TO FRACTION(1)" WHEN l_collength = 3887 LET type_text = type_text CLIPPED, " MONTH TO FRACTION(5)" WHEN l_collength = 4108 LET type_text = type_text CLIPPED, " YEAR TO FRACTION(2)" WHEN l_collength = 4365 LET type_text = type_text CLIPPED, " YEAR TO FRACTION" WHEN l_collength = 4622 LET type_text = type_text CLIPPED, " YEAR TO FRACTION(4)" WHEN l_collength = 4879 LET type_text = type_text CLIPPED, " YEAR TO FRACTION(5)" OTHERWISE LET type_text = type_text CLIPPED, " ????" END CASE RETURN type_text END FUNCTION @EOF set `wc -lwc misql.per <<'@EOF' database formonly screen { \gp--------------------p--------------------------------------------------------q\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \g|\g[f001 ]\g|\g[f002 ]\g|\g \gb--------------------b--------------------------------------------------------d\g } attributes f001=formonly.colname, noentry; f002=formonly.val; instructions delimiters " " screen record scr[17](colname, val) @EOF set `wc -lwc