johnblood/tldm-universe
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
77e33191cb
tldm-universe/Ardent/UV/BP/CONV.SQL.B
John Paul Wohlscheid 77e33191cb first push of universe files
2024-09-09 17:51:08 -04:00

3817 lines
127 KiB
Brainfuck
Executable File
Raw Blame History

*****************************************************************************
*
* Routine to convert a uniVerse file into an SQL table
*
* Module %M% Version %I% Date %H%
*
* (c) Copyright 1998 Ardent Software Inc. - All Rights Reserved
* This is unpublished proprietary source code of Ardent Software Inc.
* The copyright notice above does not evidence any actual or intended
* publication of such source code.
*
*******************************************************************************
*
* Maintenance log - insert most recent change descriptions at top
*
* Date.... GTAR# WHO Description........................................
* 10/14/98 23801 SAP Change copyrights.
* 09/09/98 23597 TFH Avoid endless loop expanding @/@KEY/@SELECT phrases
* 03/31/98 21228 TFH Justific'n = L/T/U/none and no SQLTYPE ==> VARCHAR
* 07/03/97 21036 TFH If phantom, don't set "page-wait" flag
* 06/03/97 20695 TFH Add "change datatype" editing feature
* 05/23/97 20695 TFH Many release 9.4 changes to CONVERT.SQL (see spec)
* 10/15/96 17743 TFH Convert more than 99 fields to columns (see MAXC)
* 07/02/96 18760 EAP For RESTORE close files before renaming them
* 03/13/96 17797 AGM Replace 'SH -c' with OS.EXEC
* 01/31/95 17671 LAG Windows NT port
* 12/28/95 17827 TFH Additional changes for MVASSOC option (GTAR 17669)
* 12/11/95 17669 TFH Add MVASSOC option, which makes every non-associated
* multi-valued field into an association
* 12/08/95 17744 TFH Support GEN.SAVE option
* 12/06/95 17692 TFH Identifiers starting with lowercase letter are legal
* 11/14/95 17641 TFH If RESTORE, do DROP TABLE...CASCADE
* 10/03/95 17438 TFH Handle format such as 12QR3E1
* 10/02/95 15808 TFH Handle format of 0L
* 09/26/95 17405 TFH Handle conversion of form MD0x where x is non-digit
* 06/27/95 16608 TFH Don't use @SCHEMA to find out if we're in a schema;
* use proper CREATE.FILE syntax if pick-type flavor
* 11/02/94 15251 TFH Remove ability to enter new filename when exiting
* 10/25/94 15199 TFH Fix problem with Pick association (C;n;n;n)
* 10/21/94 15164 TFH Preserve "Key" indication if an ASSOC is defined
* in more than one synonym of the same field
* 10/14/94 15118 TFH If LPTR, send *all* CREATE TABLE messgs to printer
* 10/07/94 15090 TFH Discard dict fields with Pick correlatives; change
* "SHOW" to "INFO", "P" to "S"; add SQLDEF time stamp
* 09/30/94 15018 TFH Use sdml's return code to see if table was created
* 09/29/94 15028 TFH Disallow the conversion of type 25 files to tables
* 09/19/94 14958 TFH If SQLTYPE (in dict) contains garbage, ignore it.
* 09/18/94 14942 TFH Force association columns to be multivalued,
* handle single-quotes correctly in COL.HDG etc,
* fix bug in check for duplicating dictionary entry
* 09/08/94 14870 TFH Handle LOC = '00' or '', other minor cleanup
* 09/01/94 14569 TFH Handle PICK flavor better
* 08/30/94 14569 TFH Handle overlapping associations
* 08/28/94 14569 TFH Make sure column and table names are unique
* 08/25/94 14569 TFH Initial version
*
*******************************************************************************
* June 1997
* CONVERT.SQL (SQL-ization utility)
*
$OPTIONS DEFAULT
$INCLUDE UNIVERSE.INCLUDE MACHINE.NAME
* Set printer page-handling mode to pause after printing a page full of lines
* (this feature is normally off in Pick-flavor accounts).
**** DO THIS ONLY IF NOT RUNNING AS A PHANTOM *******************************
SYS1005 = system(1005)
if not(system(25)) then assign 1 to system(1005)
******************
** Windows NT port
**
DEFFUN IS.FULLPATH(FILESPEC) CALLING "*IS.FULLPATH"
DEFFUN IS.EQPATHS(FILESPEC.A, FILESPEC.B) CALLING "*IS.EQPATHS"
DEFFUN GET.DIRNAME(FILESPEC) CALLING "*GET.DIRNAME"
DEFFUN GET.BASENAME(FILESPEC) CALLING "*GET.BASENAME"
**
******************
prompt ''
CMDNAME = "CONVERT.SQL" ; * Name of this command
CURREVCODE = "REV#1" ; * Current Rev number of file format of SQLDEF file
MAXSLEEP = 5 ; * Number of 2-second intervals to sleep awaiting freeing of lock
MAXLINES = 1000 ; * Max number of lines in CREATE EXISTING TABLE statement
TOPMAX = 500 ; * Max field number that can be converted to a column
MAXC = 49 ; * Array size for storing information about every field (this is
* adjusted upward if stored fields with AMC > 49 are found)
MAXNEW = 49 ; *Max number of newly created dictionary column-name entries (this
* is adjusted upward if stored fields with AMC > 49 are found)
MAXWARN = 100 ; * Max number of warnings to be displayed when analyzing dict.
WARNX = 1 ; * Next available position in the WARNINGS array
FILENM = ""
ARGA = ""
DISP = 1
SHOW = 0
DEBUG = 0
DEBUGFIRST = 0
LPTR = 0
SAVE = 0
NEWDEF = 0
CRTAB = 0
TEST = 0
TESTEDIT = 0
CRXDONE = 0
BERX = 0
******************
** Windows NT port
**
UV.ROOT = SYSTEM(32)
**
******************
* Determine what CREATE.FILE syntax to use
FLAVOR = system(1001)
if FLAVOR = 2 or FLAVOR = 8 or FLAVOR = 16 then
CREATE.SYNTAX = "PICK"
end else
CREATE.SYNTAX = ""
end
* Process command line arguments
get(arg.) FILENM else goto VERUSER
gosub NEXTARG
begin case
case ARGL = ""
goto VERUSER
case ARGL = "TESTEDIT" ; * With this option, which is for internal testing
* only, interactive editing commands can be
* submitted as DATA statements in the test
* paragraph; the final DATA statement should
* contain the "Q" command (or "X" or "X.SAVEDATA").
* Up to 25 commands can be processed with this
* mechanism.
TEST = 1
BADOPT = 0
TESTEDIT = 1
dim INPUTS(26)
mat INPUTS = ""
INCOUNT = 1
loop
LPEND = len(@DATA.PENDING)
while LPEND <> 0 do
input NXX
while NXX # "Q" and INCOUNT <= 25 do
if NXX[1,1] = "*" then continue
INPUTS(INCOUNT) = NXX
INCOUNT += 1
repeat
INPUTS(INCOUNT) = "Q"
INCOUNT = 1
case ARGL = "TEST"
TEST = 1
BADOPT = 0
case ARGL = "CREATE"
CRTAB = 1
BADOPT = 0
case ARGL = "INFO" or ARGL = "RESTORE" or ARGL = "RESTOREDATA"
ARGA = ARGL
BADOPT = 0
case LPTR = 1
BADOPT = 6
case DEBUG = 1
DEBUGFIRST = 1
end case
loop
until BADOPT
gosub NEXTARG
until ARGL = "" or BADOPT
repeat
if BADOPT = 1 then stop "Illegal command line argument: ":ARGL
if BADOPT = 2 then stop ARGL:" option is only legal with TEST or CREATE"
if BADOPT = 3 then stop "Duplicated command line argument: ":ARGL
if BADOPT = 4 then stop ARGL:" option is only legal with CREATE"
if BADOPT = 5 then
stop "If DEBUG is first argument after filename it must be the last"
end
if BADOPT = 6 then
stop "LPTR option is not legal as first argument after filename"
end
goto VERUSER
* This subroutine gets the next command line argument
* Output: ARGL is set to empty if there are no more command line arguments
* or: ARGL contains the next command line argument if there is one
* BADOPT = 0 if ARGL is a valid option; in this case, the proper
* flag is set: NEWDEF, DISP, SHOW, SAVE, LPTR, or DEBUG
* BADOPT = 1 if the argument (ARGL) is not a valid option keyword
* BADOPT = 2 if this option (GEN, SHOW, BRIEF) is illegal w this action
* BADOPT = 3 if the argument (ARGL) is a duplicated option
* BADOPT = 4 if this option SAVEDATA is illegal with this action
* BADOPT = 5 if DEBUG is the first argument and another arg is found
NEXTARG:
BADOPT = 0
ARGL = ""
get(arg.) ARGL else return
if DEBUGFIRST then BADOPT = 5 ; return
ARGL = upcase(ARGL)
begin case
case ARGL = "GEN"
if not(CRTAB or TEST) then BADOPT = 2
if NEWDEF then BADOPT = 3 else NEWDEF = 1
case ARGL = "BRIEF"
if not(CRTAB or TEST) then BADOPT = 2
if DISP = 0 then BADOPT = 3 else DISP = 0
case ARGL = "SHOW"
if not(CRTAB or TEST) then BADOPT = 2
if SHOW then BADOPT = 3 else SHOW = 1
case ARGL = "SAVEDATA"
if not(CRTAB) then BADOPT = 4
if SAVE then BADOPT = 3 else SAVE = 1
case ARGL = "LPTR"
if LPTR then BADOPT = 3 else LPTR = 1
case ARGL = "DEBUG"
if DEBUG then BADOPT = 3 else DEBUG = 1
case 1
BADOPT = 1
end case
return ; *from NEXTARG
* Verify that user is a registered SQL user
VERUSER:
if LPTR then printer on
AUTH = @AUTHORIZATION
open "UV_USERS" to FVAR else stop "Can't open UV_USERS"
read TVAR from FVAR,AUTH then
close FVAR
end else
close FVAR
stop "Can't run ":CMDNAME:": '":AUTH:"' is not an SQL User"
end
* Verify that this account is an SQL schema
VERACCT:
PATH = @PATH
PATH = trim(PATH)
IF OS.TYPE = "UNIX" THEN
if PATH[1] = "/" then PATH = PATH[1,len(PATH)-1]
END ELSE
if PATH[1] = "/" OR PATH[1] = "\" then PATH = PATH[1,len(PATH)-1]
END
* Find out if this account is a schema; put its name (or empty) in SCH
gosub Getschinfo
if len(SCH) <= 0 then
stop "Can't run ":CMDNAME:": '":PATH:"' is not an SQL Schema"
end
* Verify that user has write permission to this account's directory
VERDIR:
TCH = OS.EXEC: ' "': TOUCH.CMD : ' dUmMy.newSQL"'
RMV = OS.EXEC: ' "' : RM.CMD : ' dUmMy.newSQL"'
TVAR = ""
execute TCH capturing TVAR
if len(TVAR) > 1 then
stop "Can't run ":CMDNAME:": No UNIX write permission on '":PATH:"'"
end
execute RMV capturing TVAR
* Verify that user has write permission to the VOC
VERVOC:
VPATH = PATH:"/VOC"
openpath VPATH to VOCVAR else
stop "Can't run ":CMDNAME:": Can't open '":VPATH:"'"
end
LSLEEP = MAXSLEEP
VERVOC1:
if LSLEEP <= 0 then
close VOCVAR
stop "Can't run ":CMDNAME:": '":VPATH:"' is locked"
end
readu TVAR from VOCVAR,"VOC" locked
LSLEEP -= 1
sleep 2
goto VERVOC1
end else
close VOCVAR
stop "Can't run ":CMDNAME:": Can't read from '":VPATH:"'"
end
write TVAR to VOCVAR,"VOC" else
close VOCVAR
stop "Can't run ":CMDNAME:": Can't write to '":VPATH:"'"
end
if ARGA = "INFO" then close VOCVAR ; goto DOINFO
* Prompt for filename if no command line arguments
if FILENM = "" then
print "Enter Filename to be converted (or <return> to Quit)? ":
input FILENM
if FILENM = "" then goto GOODBYE
end
* Get FILENM's VOC pointer, if possible, to support Q-pointer error message
readl RVAR from VOCVAR,FILENM locked
RVAR = ""
end else
RVAR = ""
end
VOCCODE = upcase(RVAR<1>[1,1])
if ARGA[1,7] # "RESTORE" then close VOCVAR ; *leave VOC open if RESTORE
* Open the file, get its STATUS
hush on ; *Suppress ugly message if can't open due to (eg) no SQL permission
open FILENM to FVAR then
hush off
status FSTAT from FVAR else
close FVAR
stop "Can't get STATUS of file '":FILENM:"'"
end
end else
OPSTAT = status()
hush off
print "Can't open file '":FILENM:"'. ":
if OPSTAT = -1 and VOCCODE = "Q" then OPSTAT = -987
gosub POPERR
goto GOODBYE
end
* Verify that the data file is on the local system
FPATH = FSTAT<27,1,1>
IF OS.TYPE = "UNIX" THEN
if FPATH[1] = "/" then FPATH = FPATH[1,len(FPATH)-1]
END ELSE
if FPATH[1] = "/" OR FPATH[1] = "\" then FPATH = FPATH[1,len(FPATH)-1]
END
if fileinfo(FVAR,0) then
if fileinfo(FVAR,12) # "" then
close FVAR
stop "File '":FPATH:"' is not on local system"
end
end else
stop "File '":FPATH:"' is no longer open"
end
* Close the data file
close FVAR
* Open the dictionary, get its STATUS
open "DICT",FILENM to DVAR else
OPSTAT = status()
print "Can't open DICT '":FILENM:"'. ":
gosub POPERR
goto GOODBYE
end
status DSTAT from DVAR else
close DVAR
stop "Can't get STATUS of DICT '":FILENM:"'"
end
* Verify that dictionary is on local system
DPATH = DSTAT<27,1,1>
IF OS.TYPE = "UNIX" THEN
if DPATH[1] = "/" then DPATH = DPATH[1,len(DPATH)-1]
END ELSE
if DPATH[1] = "/" OR DPATH[1] = "\" then DPATH = DPATH[1,len(DPATH)-1]
END
if fileinfo(DVAR,0) then
if fileinfo(DVAR,12) # "" then
close DVAR
stop "Dictionary '":DPATH:"' is not on local system"
end
end else
stop "Dictionary '":DPATH:"' is no longer open"
end
if DEBUG then
print "PATH is ":PATH
print "FPATH is ":FPATH
print "DPATH is ":DPATH
end
* At this point, the dictionary file is open (to DVAR)
if ARGA[1,7] # "RESTORE" then goto ANALYZE
* RESTORE and RESTOREDATA options
* At this point, the VOC file is open (to VOCVAR)
* Close the file's dictionary
close DVAR
* Check to verify that the file is an SQL table
if FSTAT<29,1,1> = 0 then
close VOCVAR
stop "Can't do RESTORE option because '":FILENM:"' is not a table"
end
* Check that <filename>_SQLDEF exists
DEFNM = change(FILENM," ","_"):"_SQLDEF"
readl SVAR from VOCVAR,DEFNM else
close VOCVAR
stop "Can't do RESTORE option because '":DEFNM:"' doesn't exist"
end
release VOCVAR,DEFNM
* See if <filename>_SQLSAVE exists (keep info in ZVAR)
SAVNM = change(FILENM," ","_"):"_SQLSAVE"
readl ZVAR from VOCVAR,SAVNM then
release VOCVAR,SAVNM
end else ZVAR = ""
* Close the VOC file
close VOCVAR
if ARGA[8,4] = "DATA" then
* Check that <filename>_SQLSAVE exists
if ZVAR = "" then
stop "Can't do RESTOREDATA option because '":SAVNM:"' doesn't exist"
end
* Open the SQLSAVE file to VVAR and its dict to DVVAR (locking both)
gosub OPENSAVE
if OPENERR then stop ; * no message needed, OPENSAVE already produced one
end
* Open the SQLDEF file to NVAR and its dict to DNVAR (locking both)
gosub OPENDEF
if OPENERR then
if ARGA[8,4] = "DATA" then
fileunlock VVAR ; close VVAR
fileunlock DVVAR ; close DVVAR
end
stop ; * no message needed, OPENDEF already produced one
end
* Issue the CREATE EXISTING TABLE...RESTORE command
CRXDEF = 'CREATE EXISTING TABLE "':change(FILENM,'"','""'):'" RESTORE;'
if LPTR then
execute CRXDEF capturing CRTABOUT setting TVAR
POUT = change(CRTABOUT,char(254),char(10),0,1)
if POUT[1] = char(10) then POUT = POUT[1,len(POUT)-1]
print POUT
end else
execute CRXDEF setting TVAR
end
* Check to see if CREATE EXISTING TABLE...RESTORE failed
if TVAR <> 0 then
fileunlock NVAR ; close NVAR
fileunlock DNVAR ; close DNVAR
if ARGA[8,4] = "DATA" then
fileunlock VVAR ; close VVAR
fileunlock DVVAR ; close DVVAR
end
if TVAR <> -1 then goto NORETURN
stop "Table could not be restored to a file."
end
* Restore the dictionary from the SQLDEF file
print " Restoring DICT '":FILENM:"' (using ":DEFNM:")"
open "DICT",FILENM to DVAR else
OPSTAT = status()
fileunlock NVAR ; close NVAR
fileunlock DNVAR ; close DNVAR
if ARGA[8,4] = "DATA" then
fileunlock VVAR ; close VVAR
fileunlock DVVAR ; close DVVAR
end
print "Can't open DICT '":FILENM:"'. ":
gosub POPERR
stop
end
* Copy the saved dictionary records from SQLDEF to DICT FILENM
clearfile DVAR
SELNX = 'SELECT ':DEFNM:' WITH NOT (@ID LIKE "SQL_..." AND F1 LIKE "X...")'
execute SELNX capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
NOMORE = 0
loop
until NOMORE
readnext ATID then
read DICTREC from NVAR,ATID else goto RDERR
write DICTREC to DVAR,ATID else goto WRERR
end else NOMORE = 1
repeat
fileunlock NVAR ; close NVAR
fileunlock DNVAR ; close DNVAR
close DVAR
* If RESTOREDATA option, restore the file's data from the SQLSAVE file
if ARGA[8,4] = "DATA" then
print " Restoring DATA '":FILENM:"' (using ":SAVNM:")"
open FILENM to FVAR else
OPSTAT = status()
print "Can't open file '":FILENM:"'. ":
gosub POPERR
stop
end
* Copy the saved data records from SQLSAVE to FILENM
clearfile FVAR
select VVAR
NOMORE = 0
loop
until NOMORE
readnext ATID then
read DATAREC from VVAR,ATID else goto RDERR
write DATAREC to FVAR,ATID else goto WRERR
end else NOMORE = 1
repeat
fileunlock VVAR ; close VVAR
fileunlock DVVAR ; close DVVAR
close FVAR
end
* Delete the SQLSAVE file if it exists
if ZVAR # "" then
print " Deleting file '":SAVNM:"'"
DELSAVE = "DELETE.FILE ":SAVNM
execute DELSAVE capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
end
print "File restored"
goto GOODBYE
* INFO option
DOINFO:
gosub SETUPINFO
CNTASD = CNTD:FILENM:CNTDD2
gosub GETCNT
if CNTCNT = "" then goto GOODBYE
if CNTCNT = 0 then goto DOCNTAS
SUMDDD = SUMDD:FILENM:SUMDD2
execute SUMDDD capturing TVAR
gosub PRINTOUT
DOCNTAS:
CNTASD = CNTD:FILENM:CNTAS2
gosub GETCNT
if CNTCNT = "" or CNTCNT = 0 then goto GOODBYE
SUMAAS = SUMAS:FILENM:SUMAS2
execute SUMAAS capturing TVAR
gosub PRINTOUT
goto GOODBYE
ANALYZE:
gosub GETDAT ; * get printable date/time in DATETIME
print "Analyzing '":FILENM:"' for conversion to SQL ":
if len(FILENM) < 18 then print space(18 - len(FILENM)):
print DATETIME
* Determine if filename is legal as a table name on this O/S
IDENT = FILENM ; IDTYPE = "TABLE" ; gosub CKLEGAL
if ILLEGAL then
close DVAR
print "File name '":FILENM:"' is not a legal table name: ":ILLEGAL
stop "Create VOC entry using a legal name and then rerun ":CMDNAME
end
* Lock the dictionary (it will remain locked for awhile)
LSLEEP = MAXSLEEP
ANAL1:
if LSLEEP <= 0 then
close DVAR
stop "Can't lock dictionary: ":DPATH
end
filelock DVAR locked
LSLEEP -= 1
sleep 2
goto ANAL1
end
* Verify that the file is not already an SQL table, and that its file Type
* is valid for being an SQL table
VERFVALID:
if FSTAT<29,1,1> <> 0 then
fileunlock DVAR
close DVAR
stop "File '":FPATH:"' is already an SQL table"
end
FTYPE = FSTAT<21,1,1>
FMODSEP = ""
PMODSEP = "1,2"
begin case
case (FTYPE >= 2 and FTYPE <= 18)
FMODSEP = FSTAT<22,1,1>:" "
FMODSEP := FSTAT<23,1,1>
PMODSEP = FSTAT<22,1,1>:","
PMODSEP := FSTAT<23,1,1>
* case FTYPE = 25 ; * In rel 8.3.1 we don't support type 25 tables
case FTYPE = 30
case 1
fileunlock DVAR
close DVAR
stop "File '":FPATH:"' has invalid Type (":FTYPE:") for an SQL table"
end case
* Get file's F- or Q-record from VOC, save it (in RVAR)
GETFVOC:
* Open the VOC file to VOCVAR
openpath VPATH to VOCVAR else
fileunlock DVAR
close DVAR
stop "Can't run ":CMDNAME:": Can't open '":VPATH:"'"
end
LSLEEP = MAXSLEEP
GETFVOC1:
if LSLEEP <= 0 then
fileunlock DVAR
close DVAR
close VOCVAR
stop "Can't run ":CMDNAME:": '":VPATH:"' is locked"
end
readl RVAR from VOCVAR,FILENM locked
LSLEEP -= 1
sleep 2
goto GETFVOC1
end else
fileunlock DVAR
close DVAR
close VOCVAR
stop "Can't run ":CMDNAME:": Can't read from '":VPATH:"'"
end
* Find out if <filename>_SQLDEF already exists (keep info in SVAR)
DEFNM = change(FILENM," ","_"):"_SQLDEF"
readl SVAR from VOCVAR,DEFNM else SVAR = ""
* Close the VOC file
close VOCVAR
* Verify that the file's VOC entry is either an F-record or a Q-record
VOCCODE = upcase(RVAR<1>[1,1])
if (VOCCODE # "F" and VOCCODE # "Q") then
fileunlock DVAR
close DVAR
stop "VOC entry for '":FILENM:"' is neither an F-record nor a Q-record"
end
* Verify that the file (if it has an F-pointer) is not a multi-level file
if VOCCODE = "F" and upcase(RVAR<4>) matches 'M...' then
fileunlock DVAR
close DVAR
stop "File '":FPATH:"' is a multi-level file (invalid for an SQL table)"
end
* Prepare to create and/or delete SQLDEF file
SQLDEF:
DELDEF = "DELETE.FILE ":DEFNM
if CREATE.SYNTAX = "PICK" then
CREDEF = "CREATE.FILE ":DEFNM:" 1 1,2,3"
end else
CREDEF = "CREATE.FILE ":DEFNM:" 3 1 2"
end
if SVAR = "" then goto GENDEF ; * goto GENDEF if SQLDEF file doesn't exist
* A SQLDEF file exists
gosub OPENDEF ; *open the SQLDEF file to NVAR, and its dict to DNVAR
if OPENERR then goto GENDEF ; * goto GENDEF if SQLDEF file doesn't exist
if NEWDEF then goto DELEX
if (TEST or CRTAB) then
print "Using existing file '":DEFNM:"'"
goto REPORT
end
print "File '":DEFNM:"' exists. Do you wish to overwrite? [N] ":
input TVAR
if not(upcase(TVAR) = "Y" or upcase(TVAR) = "YES") then goto REPORT
* Delete existing SQLDEF file
DELEX:
print "Generating file '":DEFNM:"' ..":
print ".":
clearfile NVAR
goto GENDEF1
* Generate new SQLDEF file
GENDEF:
print "Generating file '":DEFNM:"' ..":
execute CREDEF capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
print ".":
gosub OPENDEF ; *open the SQLDEF file to NVAR, and its dict to DNVAR
if OPENERR then goto GOODBYE
GENDEF1:
print ".":
* Create select list of original dictionary recid's into DICTLIST (used to
* check for duplicate dictionary entries when creating artificial columns -
* this is inefficient, but before changing it look at ALL references in code).
select DVAR
print ".":
readlist DICTLIST else
print ""
gosub UCAF
print "DICT '":FILENM:"' is empty. Can't convert file"
execute DELDEF capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
goto GOODBYE
end
* Copy all records from DICT FILENM to the SQLDEF file (and determine largest
* field number for a stored field while doing so, to use when creating arrays)
select DICTLIST
print ".":
NOMORE = 0
loop
until NOMORE
readnext ATID then
read DICTREC from DVAR,ATID else goto RDERR
write DICTREC to NVAR,ATID else goto WRERR
CODETEMP = upcase(DICTREC<1>[1,2])
LOCTEMP = DICTREC<2>
CORRTEMP = DICTREC<8>
begin case
case (CODETEMP = "A" or CODETEMP = "A ") and num(LOCTEMP)
if CORRTEMP # "" then LOCTEMP = 0
case (CODETEMP = "S" or CODETEMP = "S ") and num(LOCTEMP)
if CORRTEMP # "" then LOCTEMP = 0
case CODETEMP[1,1] = "D"
case 1
LOCTEMP = 0
end case
if LOCTEMP > MAXC and LOCTEMP <= TOPMAX then
MAXC = LOCTEMP+0
MAXNEW = MAXC
end
end else NOMORE = 1
repeat
print ".":
* Put useful entries in SQLDEF's dictionary (F1-F6, @, and INFX)
LSLEEP = MAXSLEEP
WRDICT:
if LSLEEP <= 0 then
print "Can't read F1 from DICT ":DEFNM:" because it is locked"
fileunlock DVAR
close DVAR
fileunlock NVAR
close NVAR
fileunlock DNVAR
close DNVAR
goto GOODBYE
end
readu TVAR from DNVAR,"F1" locked
LSLEEP -= 1
sleep 2
print ".":
goto WRDICT
end then
print "...":
goto MAKEDINFO
end else
for M = 1 to 6
FFF = "D":@FM:M:@FM:@FM:@FM:"2L":@FM:"S"
GGG = "F":M
write FFF to DNVAR,GGG else goto WRERR
next M
EEE = "D":@FM:2:@FM:@FM:@FM:"60T":@FM:"S"
write EEE to DNVAR,"F2" else goto WRERR
print ".":
HHH = "PH":@FM:"F1 F2 F3 F4 F5 F6" ; *??
write HHH to DNVAR,"@" else goto WRERR
print ".":
IDESC = "IF (@ID MATCH 'SQL_A...' OR @ID MATCH 'SQL_C...'"
IDESC := " OR @ID MATCH 'SQL_K...')"
IDESC := " THEN F2 ELSE F2:' ':F3:' ':F4:' ':F5:' ':F6"
TVAR = "I":@FM:IDESC:@FM:@FM:"SQL Table Information":@FM:"62T":@FM:"S"
write TVAR to DNVAR,"INFX" else goto WRERR
print ".":
CDICT = "CD ":DEFNM:" INFX"
execute CDICT capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
end
* Create WARNINGS, KEYNAMES, ATNAMES, and SELNAMES arrays
MAKEDINFO:
VOCOPEN = 0 ; * This flag is used in subroutine EXPANDPH to avoid
* repeatedly opening the VOC file once it has been opened
dim WARNINGS (MAXWARN)
mat WARNINGS = ""
WARNX = 1
* Create KEYNAMES array
TRYKEY:
NEEDATKEY = 0
KEYLAST = 0
SEPCHAR = ""
read DICTREC from NVAR,"@KEY" then
if upcase(DICTREC<1>[1,2]) # "PH" then goto TRYAT
end else
goto TRYAT
end
DICTTEMP = trim(DICTREC<2>)
PHNAME = "@KEY" ; gosub EXPANDPH
dim KEYNAMES (TOKCNT+1,2)
mat KEYNAMES = ""
MSGTEMP = ""
loop
while DICTTEMP # "" do
TOKTEMP = field(DICTTEMP," ",1)
DICTTEMP = field(DICTTEMP," ",2,999)
* Check for duplicated tokens in @KEY; only put one of them in KEYNAMES()
if KEYLAST > 0 then
for I = 1 to KEYLAST
until KEYNAMES(I) = TOKTEMP
next I
if I <= KEYLAST then
WARNINGS(WARNX) = "Duplicate token '":TOKTEMP
WARNINGS(WARNX) := "' in @KEY phrase is ignored"
if WARNX < MAXWARN then WARNX += 1
continue
end
end
read RECTEMP from NVAR,TOKTEMP then
CODETEMP = upcase(RECTEMP<1>[1,2])
LOCTEMP = RECTEMP<2>
CORRTEMP = RECTEMP<8>
KEYLAST += 1
KEYNAMES(KEYLAST,1) = TOKTEMP
begin case
case CODETEMP[1,1] = "I"
KEYNAMES(KEYLAST,2) = "I"
case (CODETEMP = "A" or CODETEMP = "A ") and num(LOCTEMP) and LOCTEMP # "" and CORRTEMP # ""
KEYNAMES(KEYLAST,2) = "A"
case (CODETEMP = "S" or CODETEMP = "S ") and num(LOCTEMP) and LOCTEMP # "" and CORRTEMP # ""
KEYNAMES(KEYLAST,2) = "S"
case 1
KEYLAST -= 1
if MSGTEMP # "" then
WARNINGS(WARNX) = "@KEY token '":MSGTEMP:"' is ignored:"
WARNINGS(WARNX) := ' must be I-type or Correlative'
if WARNX < MAXWARN then WARNX += 1
end
MSGTEMP = TOKTEMP
end case
end else
WARNINGS(WARNX) = "@KEY token '":TOKTEMP:"' is ignored:"
WARNINGS(WARNX) := ' not in dictionary'
if WARNX < MAXWARN then WARNX += 1
end
repeat
if TOKCNT > 1 and MSGTEMP # "" then
WARNINGS(WARNX) = "@KEY token '":MSGTEMP:"' is ignored:"
WARNINGS(WARNX) := ' must be I-type or Correlative'
if WARNX < MAXWARN then WARNX += 1
end
* Put key-separator character (if any) in SEPCHAR
read DICTREC from NVAR,"@KEY_SEPARATOR" then
if upcase(DICTREC<1>[1,1]) = "X" then SEPCHAR = DICTREC<2>[1,1]
end
* Create ATNAMES array
TRYAT:
ATLAST = 0
SELLAST = 0
NEWATSEL = 0
USESELECT = 0
read DICTREC from NVAR,"@" else goto TRYSEL
if upcase(DICTREC<1>[1,2]) = "PH" then
DICTTEMP = DICTREC<2>
PHNAME = "@" ; gosub EXPANDPH
dim SELNAMES (TOKCNT+1,2)
mat SELNAMES = ""
gosub MKSELAT
dim ATNAMES (TOKCNT+1,2)
mat ATNAMES = mat SELNAMES
ATLAST = SELLAST
end
* Create SELNAMES array
TRYSEL:
read DICTREC from NVAR,"@SELECT" else goto GOTNOSEL
if upcase(DICTREC<1>[1,2]) = "PH" then
DICTTEMP = DICTREC<2>
PHNAME = "@SELECT" ; gosub EXPANDPH
dim SELNAMES (TOKCNT+1,2)
mat SELNAMES = ""
gosub MKSELAT
if SELLAST > 0 then goto BUILDSELD
end
GOTNOSEL:
if ATLAST > 0 then
NEWATSEL = 1
SELLAST = 0
dim SELNAMES (TOKCNT+2,2)
mat SELNAMES = ""
if IDSUP = 0 and KEYLAST <= 1 then DICTTEMP = "@ID" ; gosub MKSELAT
* At this point SELLAST is either 0 or 1
for I = 1 to ATLAST
SELNAMES(I+SELLAST,1) = ATNAMES(I,1)
SELNAMES(I+SELLAST,2) = ATNAMES(I,2)
next I
SELLAST += I-1
end
goto BUILDSELD
* This subroutine fills array SELNAMES (for eventual use either as ATNAMES
* or as SELNAMES) with an ordered list of tokens which represent D, I, A,
* or S dictionary entries (or the speciial token @ASSOC_ROW)
* Input: SELNAMES must be dim'd and mat'd
* DICTTEMP contains space-separated list of tokens in proper order
* Output: SELNAMES is now loaded
* SELLAST contains the number of rows in SELNAMES
MKSELAT:
SELLAST = 0
loop
while DICTTEMP # "" do
TOKTEMP = field(DICTTEMP," ",1)
DICTTEMP = field(DICTTEMP," ",2,999)
read RECTEMP from NVAR,TOKTEMP then
CODETEMP = upcase(RECTEMP<1>[1,2])
LOCTEMP = RECTEMP<2>
SELLAST += 1
SELNAMES(SELLAST,1) = TOKTEMP
begin case
case (CODETEMP = "A" or CODETEMP = "A ") and num(LOCTEMP) and LOCTEMP # ""
SELNAMES(SELLAST,2) = "A"
case (CODETEMP = "S" or CODETEMP = "S ") and num(LOCTEMP) and LOCTEMP # ""
SELNAMES(SELLAST,2) = "S"
case (CODETEMP[1,1] = "D" or CODETEMP[1,1] = "I")
SELNAMES(SELLAST,2) = CODETEMP[1,1]
case 1
SELLAST -= 1
end case
end else
if TOKTEMP = "@ASSOC_ROW" then
SELLAST += 1
SELNAMES(SELLAST,1) = TOKTEMP
SELNAMES(SELLAST,2) = "Y"
end
end
repeat
return ; *from MKSELAT
* Build select list of all valid D, A, and S records in dictionary
* (note that A or S is invalid if 2nd character of F1 is non-blank)
BUILDSELD:
print ".":
SELD = 'SELECT ':DEFNM:' WITH F1 LIKE "D..." '
SELD := 'OR F1 LIKE "A ..." OR F1 = "A" '
SELD := 'OR F1 LIKE "S ..." OR F1 = "S"'
execute SELD capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
print ".."
* Define array COLUMNS of field names
MAKEARRAY:
dim COLUMNS (MAXC+1,52) ;* First element is the code (D, A, or S) followed
* by a multi-digit preference code (CODEX)
* 2nd element is number of definitions of this field
* 3rd element is field-name of this field
* 4th, 5th,..elements are synonym-names
mat COLUMNS = 0
COLLAST = 0 ; * Field number of last column to be created
COLCNT = 0 ; * Number of columns to be created (not counting field 0)
COLTOT = 0 ; * Number of fields defined (incl. AMC > MAXC, not incl. 0)
* Define array ASSOCS of associations
dim ASSOCS (50,MAXC+3) ;* First element is association-name
* Elements 2 - MAXC+1 show which columns (1-MAXC) are
* in this association; K means it is a key column
* and X means that it is a non-key column
* If element MAXC+2 is "X" then this assoc overlaps
* a lower-numbered assoc definition
* Element MAXC+3 contains information from this
* association's @ASSOC_KEY X-record (if any):
* S = Stable key
* U = Unstable key
* K = Key'd association
* N = This association has no @ASSOC_KEY record
mat ASSOCS = 0
ASSOCLAST = 0 ; * Number of the last association
* Define array PHRASES for PHrases whose names are also in ASSOC field of dict
dim PHRASES (50,MAXC+3) ; *First element is phrase-name (= assoc-name)
* Elements 2 - MAXC+1 show which fields (1-MAXC) are in
* this phrase; "1" means it is the first token in
* the PHrase, "2" means it is the second token in
* the PHrase, etc.
* If element MAXC+2 is "X" then the PHrase includes a
* token that is not a data field name in this file
* (it might be an I-descriptor)
* Element MAXC+3 is the number of data-field tokens
* in the PHrase
mat PHRASES = 0
* Define array NEWDICT of new (valid SQL) dictionary names to be created
dim NEWDICT (MAXNEW) ; * Each element is a new name
mat NEWDICT = 0
NEWLAST = 0 ; * Number of the last new dictionary name at any time
* Initialize ATSELX, LEGALX, etc, which are "importance weightings" used in
* deciding which dictionary definition (when there are several for the same
* field) should be chosen as the basis for the column definition.
* Each importance weighting must be different (9 = highest, 1 = lowest).
***** NOTE: these importance weightings must all be different ***************
ATSELX = 9 ; * ATSELCODEX = 1 if fieldname is in user-supplied @SELECT phrase
LEGALX = 8 ; * LEGALCODEX = 1 if fieldname is a legal identifier on this O/S
MVAX = 7 ; * MVACODEX tells whether this field is in an association, etc:
* MVACODEX = 0 if MULTI and AMC = 0; otherwise:
* if dict entry has legal token in ASSOC field (or Pick equiv),
* then = 9 if MULTI, in ASSOC phrase, is KEY in @ASSOC_KEY.assoc
* = 8 if MULTI and in ASSOC phrase
* = 4 if MULTI and is KEY in @ASSOC_KEY.assoc
* = 3 if MULTI
* = 1 if SINGLE (in which case ASSOC field is ignored)
* if dict entry doesn't have legal ASSOC token (or Pick equiv),
* then = 7 if MULTI and exists @ASSOC_KEY.namv for this field
* = 6 if MULTI
* = 5 if SINGLE
TYPEX = 6 ; * TYPECODEX = 4 if dict datatype is DATE/TIME and CONV agrees
* = 4 if dict datatype is DEC/NUMERIC and CONV agrees
* = 3 if datatype is DATE/TIME/DEC/NUM and CONV = ""
* = 2 if valid dict datatype (not DATE/TIME/DEC/NUM)
* = 1 if dict datatype is DATE/TIME and CONV disagrees
* = 1 if datatype is DEC/NUMERIC and CONV disagrees
* = 0 if dict doesn't contain a valid SQL datatype
ATKEYX = 5 ; * ATKEYCODEX = 1 if fieldname is in multi-token @KEY phrase
ATX = 4 ; * ATCODEX = 1 if fieldname is in @ phrase
NUMX = 3 ; * NUMCODEX = 1 if fieldname is NOT a valid SQL numeric literal
ATIDX = 2 ; * ATIDCODEX = 1 if fieldname is NOT "@ID"
DASX = 1 ; * DASCODEX = 3 for D-type, 2 for A-type, 1 for S-type
* Initialize CODEX, used to rate different possible column-definitions.
**** NOTE: CODEX must contain at least as many 0's as the largest "importance
* weighting" number above (currently 5/20/97 this is 9 = ATSELX)
CODEX = "000000000"
* Build the COLUMNS array
MAKE1:
readnext ATID else goto MAKEEND
if ATID[1,4] = '@Ak.' then goto MAKE1
read TVAR from NVAR,ATID else goto RDERR
CODE = upcase(TVAR<1>[1,1])
*Reject A or S item with Correlative, since this is equivalent to I-type
*Also reject A or S with empty LOC
if (CODE = 'A' or CODE = 'S') then
if len(trim(TVAR<8>)) > 0 then goto MAKE1
if len(trim(TVAR<2>)) = 0 then goto MAKE1
end
LOC = trim(TVAR<2>)
if (LOC = '' or LOC = 0) then LOC = '0'
if len(LOC) > 1 then LOC = trim(LOC,"0","L")
if not(num(LOC)) then
WARNINGS(WARNX) = 'Dict entry "':ATID:'" is ignored:'
WARNINGS(WARNX) := " non-numeric LOC field '":LOC:"'"
if WARNX < MAXWARN then WARNX += 1
goto MAKE1
end
if LOC > MAXC then
WARNINGS(WARNX) = 'Dict entry "':ATID:'" is ignored:'
WARNINGS(WARNX) := ' its LOC field (':LOC:') is too large'
if WARNX < MAXWARN then WARNX += 1
COLTOT += 1
goto MAKE1
end
AMC = LOC
if LOC = 0 then LOC = MAXC+1 else
if COLUMNS(LOC,2) = 0 then
COLCNT += 1
COLTOT += 1
end
if LOC > COLLAST then COLLAST = LOC
end
if COLUMNS(LOC,2) = 50 then
if AMC = 0 then LOC = '0'
if len(LOC) > 1 then LOC = trim(LOC,"0","L")
WARNINGS(WARNX) = 'Dict entry "':ATID:'" is ignored:'
WARNINGS(WARNX) := ' >50 definitions for location ':LOC
if WARNX < MAXWARN then WARNX += 1
goto MAKE1
end
COLUMNS(LOC,2) += 1
if CODE = "D" then
SQLTYPE = TVAR<8>
CONV = TVAR<3>
ASSOCID = TVAR<7>
MULTI = upcase(TVAR<6>[1,1])
end else
SQLTYPE = TVAR<6>
CONV = TVAR<7>
PICKA = TVAR<4>
if len(PICKA) > 2 and (PICKA[1,2] = "C;" or PICKA[1,2] = "D;") then
ASSOCID = "@DC":LOC
if AMC <> 0 then MULTI = "M" else MULTI = "S"
end else
ASSOCID = ""
if TVAR<5> = "M" and AMC <> 0 then MULTI = "M" else MULTI = "S"
end
end
if len(SQLTYPE) = 0 then TYPECODEX = "0" else
SQLX = SQLTYPE
gosub CONVST
if CSTERR then
if seq(SQLX[1,1]) <= 31 and seq(SQLX[1,1]) >= 0 then
SQLX = "(hex 00-1F)"
end else
SQLX = "'":SQLX:"'"
end
WARNINGS(WARNX) = 'In dict entry "':ATID:'",'
WARNINGS(WARNX) := " illegal DATATYPE ":SQLX:" is ignored"
if WARNX < MAXWARN then WARNX += 1
TYPECODEX = "0"
end else
* See if CONV is consistent with DATATYPE in dictionary
begin case
case SQLTYPE = "DATE"
begin case
case CONV[1,1] = "D"
TYPECODEX = "4"
case CONV = ""
TYPECODEX = "3"
case 1
WARNINGS(WARNX) = 'In field "':ATID:'",'
WARNINGS(WARNX) := " CONV '":CONV:"' disagrees"
WARNINGS(WARNX) := " with DATATYPE '":SQLX:"'"
if WARNX < MAXWARN then WARNX += 1
TYPECODEX = "1"
end case
case SQLTYPE = "TIME"
begin case
case CONV[1,2] = "MT"
TYPECODEX = "4"
case CONV = ""
TYPECODEX = "3"
case 1
WARNINGS(WARNX) = 'In field "':ATID:'",'
WARNINGS(WARNX) := " CONV '":CONV:"' disagrees"
WARNINGS(WARNX) := " with DATATYPE '":SQLX:"'"
if WARNX < MAXWARN then WARNX += 1
TYPECODEX = "1"
end case
case SQLTYPE[1,3] = "DEC" or SQLTYPE[1,7] = "NUMERIC"
SCALET = "0"
if count(SQLTYPE,',') = 1 then SCALET = SQLTYPE[2][1,1]
begin case
case CONV[1,2] = "MD" or CONV[1,2] = "ML" or CONV[1,2] = "MR"
gosub GETSCALE
if SCALEX = SCALET then
TYPECODEX = "4"
end else
WARNINGS(WARNX) = 'In field "':ATID:'",'
WARNINGS(WARNX) := " CONV '":CONV:"' disagrees"
WARNINGS(WARNX) := " with DATATYPE '":SQLX:"'"
if WARNX < MAXWARN then WARNX += 1
TYPECODEX = "1"
end
case CONV = ""
TYPECODEX = "3"
case 1
WARNINGS(WARNX) = 'In field "':ATID:'",'
WARNINGS(WARNX) := " CONV '":CONV:"' disagrees"
WARNINGS(WARNX) := " with DATATYPE '":SQLX:"'"
if WARNX < MAXWARN then WARNX += 1
TYPECODEX = "1"
end case
case 1
TYPECODEX = "2"
end case
end
end
if ASSOCID # "" then
IDENT = ASSOCID ; IDTYPE = "ASSOC" ; gosub CKLEGAL
if ILLEGAL then
WARNINGS(WARNX) = 'ASSOC field of dict entry "':ATID:'" is'
WARNINGS(WARNX) := ' ignored: ':ILLEGAL
if WARNX < MAXWARN then WARNX += 1
goto IGNOREF7
end else
if MULTI = "M" then
gosub CKASSOCPH ; * find out if this ASSOCID has an assoc phrase
* and if so whether ATID is in it
gosub CKASSOCKEY1 ; * find out if this ASSOCID has an @ASSOC_KEY
* X-record and if so whether ATID is in it
if INASSOCKEY then
if INASSOCPH then MVACODEX = "9" else MVACODEX = "4"
end else
if INASSOCPH then MVACODEX = "8" else MVACODEX = "3"
end
end else
MVACODEX = "1"
end
end
end else
IGNOREF7:
if MULTI = "M" then
gosub CKASSOCKEY2 ; * find out if this ATID has an @ASSOC_KEY record
if ISASSOCKEY then
MVACODEX = "7"
end else
MVACODEX = "6"
end
end else
MVACODEX = "5"
end
end
if AMC = 0 and MULTI = "M" then
MVACODEX = "0"
end
goto SELKEYCODES
CKASSOCPH:
INASSOCPH = 0
read APH from NVAR,ASSOCID then
if upcase(APH<1>[1,2]) = "PH" then
DICTTEMP = trim(APH<2>)
PHNAME = ASSOCID ; gosub EXPANDPH
if VOCOPEN then close VOCVAR ; VOCOPEN = 0
loop ; until DICTTEMP = "" do
if ATID = field(DICTTEMP," ",1,1) then INASSOCPH = 1
until INASSOCPH
DICTTEMP = field(DICTTEMP," ",2,999)
repeat
end
end
return ; *from CKASSOCPH
CKASSOCKEY1:
INASSOCKEY = 0
read KEYX from NVAR,"@ASSOC_KEY.":ASSOCID then
if upcase(KEYX<1>[1,1]) = "X" then
KEYX2 = trim(KEYX<2>)
if field(KEYX2," ",1,1) = "KEY" then
KEYX2 = field(KEYX2," ",2,99)
loop ; until KEYX2 = "" do
if ATID = field(KEYX2," ",1,1) then INASSOCKEY = 1
until INASSOCKEY
KEYX2 = field(KEYX2," ",2,99)
repeat
end
end
end
return ; *from CKASSOCKEY1
CKASSOCKEY2:
ISASSOCKEY = 0
read KEYX from NVAR,"@ASSOC_KEY.":ATID then
if upcase(KEYX<1>[1,1]) = "X" then ISASSOCKEY = 1
end
return ; *from CKASSOCKEY2
SELKEYCODES:
* See if column name is in user-specified @SELECT phrase
gosub CKSEL
if INSEL then ATSELCODEX = "1" else ATSELCODEX = "0"
* See if column name is in multi-token @KEY phrase
gosub CKKEY
if INKEY then ATKEYCODEX = "1" else ATKEYCODEX = "0"
* See if column name is in @ phrase
gosub CKAT
if INAT then ATCODEX = "1" else ATCODEX = "0"
* See if column name is a legal SQL identifier
IDENT = ATID ; IDTYPE = "COLUMN" ; gosub CKLEGAL
if ILLEGAL then
WARNINGS(WARNX) = 'Field name "':ATID:'" is illegal'
WARNINGS(WARNX) := ' as a column name: ':ILLEGAL
if WARNX < MAXWARN then WARNX += 1
LEGALCODEX = "0"
end else
LEGALCODEX = "1"
end
* See if column name is "@ID"
if ATID = "@ID" then ATIDCODEX = "0" else ATIDCODEX = "1"
begin case
case CODE = 'D'
DASCODEX = "3"
case CODE = 'A'
DASCODEX = "2"
case CODE = 'S'
DASCODEX = "1"
case 1
DASCODEX = "0"
end case
* See if the column name is a valid SQL numeric literal
if num(ATID) then NUMCODEX = "0" else NUMCODEX = "1"
* Assemble the column-definition preference code (CODEX)
CODEX[10-NUMX,1] = NUMCODEX
CODEX[10-TYPEX,1] = TYPECODEX
CODEX[10-MVAX,1] = MVACODEX
CODEX[10-ATSELX,1] = ATSELCODEX
CODEX[10-ATKEYX,1] = ATKEYCODEX
CODEX[10-LEGALX,1] = LEGALCODEX
CODEX[10-ATIDX,1] = ATIDCODEX
CODEX[10-ATX,1] = ATCODEX
CODEX[10-DASX,1] = DASCODEX
* Make appropriate adjustments to current entry in COLUMNS() ARRAY
I = COLUMNS(LOC,2)+2
if CODEX <= COLUMNS(LOC,1)[2,9] then
* The current column-definition is less "preferred" than previous one
COLUMNS(LOC,I) = ATID
end else
* The current column-definition is more "preferred" than previous one
if COLUMNS(LOC,2) > 1 then COLUMNS(LOC,I) = COLUMNS(LOC,3)
COLUMNS(LOC,1) = CODE:CODEX
COLUMNS(LOC,3) = ATID
end
goto MAKE1
MAKEEND:
******* debug messages *******************
if DEBUG then
print "COLUMNS() 0 through 5:"
print " ":
for N = 1 to 9
print COLUMNS(MAXC+1,N):", ":
next N
print COLUMNS(MAXC+1,10)
for M = 1 to 5
print " ":
for N = 1 to 9
print COLUMNS(M,N):", ":
next N
print COLUMNS(M,10)
next M
print "SELNAMES() 1 through ":SELLAST:":"
for M = 1 to SELLAST
print " ":
print SELNAMES(M,1):", '":SELNAMES(M,2):"'"
next M
print "KEYNAMES() 1 through ":KEYLAST:":"
for M = 1 to KEYLAST
print " ":
print KEYNAMES(M,1):", '":KEYNAMES(M,2):"'"
next M
end
******* debug messages *******************
* Create primary key definition
MAKEPK:
if KEYLAST > 1 then
for I = 1 to KEYLAST
LOC = (-1) * I
ATID = KEYNAMES(I,1)
if KEYNAMES(I,2) = "I" then CODE = "D" else CODE = KEYNAMES(I,2)
read ATREC from NVAR,ATID else BERX = 6 ; goto BADERR
ALPHID = "A"
gosub CREATECOL
next I
goto MAKEOTHER
end
if COLUMNS(MAXC+1,2) <= 0 then
gosub UCAF
print "No record-id defined in DICT '":FILENM:"'. Can't convert file"
execute DELDEF capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
goto GOODBYE
end
LOC = 0
CODE = COLUMNS(MAXC+1,1)[1,1]
ATID = COLUMNS(MAXC+1,3)
read ATREC from NVAR,ATID else goto RDERR ; *??what should I do?
gosub TRIMAT
if upcase(ATREC<1>[1,1]) <> CODE then BERX = 7 ; goto BADERR
if ATREC<2> <> LOC then BERX = 8 ; goto BADERR
ALPHID = "A"
gosub CREATECOL
gosub WRCOL
* Create primary key synonyms
MAKEPKSYN:
if COLUMNS(MAXC+1,2) = 1 then goto MAKEOTHER
for I = 1 to COLUMNS(MAXC+1,2)-1
LOC = 0
ATID = COLUMNS(MAXC+1,3+I)
read ATREC from NVAR,ATID else goto RDERR ; *??what should I do?
gosub TRIMAT
if ATREC<2> <> LOC then BERX = 9 ; goto BADERR
BASEID = COLUMNS(MAXC+1,3)
CODE = upcase(ATREC<1>[1,1])
if ALPHID = "Z" then ALPHID = "a" else
ALPHID = char(seq(ALPHID)+1)
end
gosub CREATECOL
next I
* Create remaining column definitions and synonyms
MAKEOTHER:
for K = 1 to COLLAST
LOC = K
if COLUMNS(LOC,2) <= 0 then gosub CREATENONE ; continue
CODE = COLUMNS(LOC,1)[1,1]
ATID = COLUMNS(LOC,3)
read ATREC from NVAR,ATID else goto RDERR ; *??what should I do?
gosub TRIMAT
if upcase(ATREC<1>[1,1]) <> CODE then BERX = 1 ; goto BADERR
if ATREC<2> <> LOC then BERX = 2 ; goto BADERR
ALPHID = "A"
gosub CREATECOL
gosub WRCOL
if COLUMNS(LOC,2) = 1 then continue
for J = 1 to COLUMNS(LOC,2)-1
ATID = COLUMNS(LOC,3+J)
read ATREC from NVAR,ATID else goto RDERR ; *??what should I do?
gosub TRIMAT
if ATREC<2> <> LOC then BERX = 3 ; goto BADERR
BASEID = COLUMNS(LOC,3)
CODE = ATREC<1>[1,1]
if ALPHID = "Z" then ALPHID = "a" else
ALPHID = char(seq(ALPHID)+1)
end
gosub CREATECOL
next J
next K
if ASSOCLAST = 0 then goto WRINFO
******* debug messages *******************
if DEBUG then
print "ASSOCS() 1 through 5; elements 1-9 and ":MAXC+2:":"
for M = 1 to 5
print " ":
for N = 1 to 9
print ASSOCS(M,N):", ":
next N
print "..., ":ASSOCS(M,MAXC+2)
next M
print "PHRASES() 1 through 5; elements 1-9, ":MAXC+2:", ":MAXC+3:":"
for M = 1 to 5
print " ":
for N = 1 to 9
print PHRASES(M,N):", ":
next N
print "..., ":PHRASES(M,MAXC+2):", ":PHRASES(M,MAXC+3)
next M
end
******* debug messages *******************
* Create associations
MAKEASSOCS:
if ASSOCLAST = 0 then goto WRINFO
for K = 1 to ASSOCLAST
ALPHID = char(seq("A")-1)
AIX = K
ASSOCID = ASSOCS(K,1)
gosub CREATEASSOC
next K
******* debug messages *******************
if DEBUG then
print "ASSOCS() 1 through 5; elements 1-9 and ":MAXC+2:":"
for M = 1 to 5
print " ":
for N = 1 to 9
print ASSOCS(M,N):", ":
next N
print "..., ":ASSOCS(M,MAXC+2)
next M
end
******* debug messages *******************
WRINFO:
* Create and write the SQL_SELECT record in SQLDEF file
TVAR = "X":@FM
if SELLAST > 0 then
* Create SQL_SELECT record if there was an @SELECT or @ phrase in dict
if NEWATSEL then USESELECT = 1
for I = 1 to SELLAST
AMCAGAIN = 0
* First see if this @SELECT token is in @KEY
if KEYLAST > 1 then
for J = 1 to KEYLAST
until KEYNAMES(J,1) = SELNAMES(I)
next J
if J <= KEYLAST then
if KEYNAMES(J,2) = "FOUND" then
* This can only happen if @SELECT contains the same
* keypart name more than once
USESELECT = 1
AMCAGAIN = 1
end else
KEYNAMES(J,2) = "FOUND"
end
end
L = COLLAST
end else
L = MAXC+1
end
* Now see if this @SELECT token is a stored-column definition
loop
until L = 0
KNUM = COLUMNS(L,2)
for J = 3 to 2+KNUM
until COLUMNS(L,J) = SELNAMES(I)
next J
if J > 2+KNUM then
if L = MAXC+1 then L = COLLAST else L -= 1
continue
end
if COLUMNS(L,1) = "FOUND" then
* This can only happen if @SELECT contains more than one
* field name defining the same field position (AMC)
USESELECT = 1
AMCAGAIN = 1
end else
COLUMNS(L,1) = "FOUND"
if J <> 3 then
SELNAMES(I) = COLUMNS(L,3)
USESELECT = 1
end
end
until 1
repeat
if not(AMCAGAIN) then TVAR := SELNAMES(I):" "
next I
if TVAR[1] = " " then TVAR = TVAR[1,len(TVAR)-1]
write TVAR to NVAR,"SQL_SELECT" else goto WRERR
end else
* Create SQL_SELECT record if there was no @SELECT or @ phrase in dict
if KEYLAST > 1 then
for L = 1 to KEYLAST
TVAR := KEYNAMES(L,1):" "
next L
end else
TVAR := COLUMNS(MAXC+1,3):" "
end
for L = 1 to COLLAST
if COLUMNS(L,2) > 0 then TVAR := COLUMNS(L,3):" "
next L
if TVAR[1] = " " then TVAR = TVAR[1,len(TVAR)-1]
write TVAR to NVAR,"SQL_SELECT" else goto WRERR
USESELECT = 1
end
* Create and write the SQL_INFO record
gosub GETDAT ; * get current date/time in DATETIME
DSTAMP = "(SQLDEF was generated ":DATETIME:")"
TVAR = "X":@FM:FILENM:@FM:COLLAST:@FM:ASSOCLAST:@FM:CURREVCODE:@FM:DSTAMP
TVAR := @FM:SELLAST:@FM:KEYLAST:@FM:SEPCHAR:@FM:USESELECT:@FM:NEEDATKEY
write TVAR to NVAR,"SQL_INFO" else goto WRERR
* Create and write the SQL_VOC record
TVAR = "X":@FM:FPATH:@FM:DPATH:@FM:VOCCODE
if RVAR<5> <> "" then
if RVAR<6> <> "" then TVAR := @FM:RVAR<5>:@FM:RVAR<6> else
TVAR := @FM:RVAR<5>
end
end else
if RVAR<6> <> "" then TVAR := @FM:@FM:RVAR<6>
end
write TVAR to NVAR,"SQL_VOC" else goto WRERR
REPORT:
* The SQLDEF file (NVAR) and its dict (DNVAR) are open and filelocked
read INFREC from NVAR,"SQL_INFO" else goto RDERR
TABNM = INFREC<2>
COLLAST = INFREC<3>
ASSOCLAST = INFREC<4>
REVCODE = INFREC<5>
DSTAMP = INFREC<6>
SELLAST = INFREC<7>
KEYLAST = INFREC<8>
SEPCHAR = INFREC<9>
USESELECT = INFREC<10>
NEEDATKEY = INFREC<11>
* If SQLDEF file was created with incompatible rev of CONVERT.SQL, recreate it
if REVCODE # CURREVCODE then goto DELEX
* Print Col and Assoc definitions if DISP is set
* Build CREATE EXISTING TABLE in array CRX
PINFO:
dim CRX (MAXLINES+2)
mat CRX = ""
CRX(1) = 'CREATE EXISTING TABLE "':change(TABNM,'"','""'):'"'
CRNEX = 2
* The ith element of array CRXCOL contains the line number (in the CREATE
* EXISTING TABLE statement) where column i is defined; used by MKDEFASSOC
dim CRXCOL (COLLAST+5)
mat CRXCOL = 0
if DISP then
print 'Table name: "':TABNM:'"':space(3):
if len(TABNM) < 18 then print space(18 - len(TABNM)):
print DSTAMP
print "Columns:"
end
NN = "NOT NULL"
PK = "PRIMARY KEY"
COLFIRST = 0
* Handle multi-part primary key (case: KEYLAST > 1)
if KEYLAST > 1 then
PKCLAUSE = PK
if SEPCHAR # "" then PKCLAUSE := " '":SEPCHAR:"'"
PKCLAUSE := " ("
CRX(CRNEX) = "("
for I = 1 to KEYLAST
if I <= 9 then I2 = "0":I else I2 = I
read DEF1 from NVAR,"SQL_K":I2 else goto RDERR
NEEDQ = DEF1<2> ; gosub QFIRST
DEF12 = NEEDQ
if DISP then print " K":I2:" ":DEF12
PKCLAUSE := field(DEF12," ",1,1):", "
findstr " ":NN in DEF12 setting FMC then
CRX(CRNEX) := DEF12:","
end else
CRX(CRNEX) := field(DEF12," ",1,2)
if field(DEF12," ",2,1) = "DOUBLE" then
CRX(CRNEX) := " ":field(DEF12," ",3,1)
CRX(CRNEX) := " ":NN:" ":field(DEF12," ",4,99):","
end else
CRX(CRNEX) := " ":NN:" ":field(DEF12," ",3,99):","
end
end
CRNEX += 1
next I
PKCLAUSE = PKCLAUSE[1,len(PKCLAUSE)-2]
CRX(CRNEX) = PKCLAUSE:"),"
CRNEX += 1
COLFIRST = 1
end
LESS100 = 1
* Build sorted select list of column synonyms for columns 0 through 99,
* and read first record-id from the list into SQLID.
gosub BUILDSELCOL
PINFO4:
for I = COLFIRST to COLLAST
if I <= 9 then I2 = "0":I else I2 = I
read DEF1 from NVAR,"SQL_C":I2 else goto RDERR
NEEDQ = DEF1<2> ; gosub QFIRST
DEF12 = NEEDQ
if DISP then print " ":I2:" ":DEF12
* Handle single-part primary key
if I2 = "00" then
NNPK = " ":NN:" ":PK:" "
findstr PK in DEF12 setting FMC then
CRX(CRNEX) = "(":DEF12:","
end else
CRX(CRNEX) = "(":field(DEF12," ",1,2)
if field(DEF12," ",2,1) = "DOUBLE" then
CRX(CRNEX) := " ":field(DEF12," ",3,1)
CRX(CRNEX) := NNPK:field(DEF12," ",4,99):","
end else
CRX(CRNEX) := NNPK:field(DEF12," ",3,99):","
end
end
end else
CRX(CRNEX) = DEF12:","
end
PINFO3:
CRXCOL(I) = CRNEX
CRNEX += 1
BASEID = field(DEF1<2>," ",1,1)
* If column number is > 99 and a second list hasn't been built yet,
* build sorted select list of column synonyms for columns greater
* than 99 and read first record-id from the list into SQLID.
if I > 99 and LESS100 then
LESS100 = 0
clearselect
gosub BUILDSELCOL
end
PINFO1:
if CRNEX > MAXLINES then
print "Too many column/association definitions (>":MAXLINES:")"
gosub UCAF
goto GOODBYE
end
loop
while SQLID # "NOMORE" do
if num(SQLID[8,1]) then
ALPHID = SQLID[9,1]
NUMID = SQLID[6,3]
end else
ALPHID = SQLID[8,1]
NUMID = SQLID[6,2]
end
while NUMID < I do
readnext SQLID else SQLID = "NOMORE"
repeat
if SQLID = "NOMORE" or NUMID > I then continue
read DEF2 from NVAR,SQLID else goto RDERR
readnext SQLID else SQLID = "NOMORE"
if upcase(DEF2<3>) = "D" then goto PINFO1
* Print out synonyms (but not the alphid which defines the preferred column)
if DISP then
if field(trim(DEF2<2>)," ",1,1) <> field(trim(DEF1<2>)," ",1,1) then
NEEDQ = DEF2<2> ; gosub QFIRST
print " ":I2:ALPHID:" ":NEEDQ
end
end
goto PINFO1
next I
clearselect
if ASSOCLAST = 0 then goto FINCRX
if DISP then print "Associations:"
for I = 1 to ASSOCLAST
if CRNEX > MAXLINES then
print "Too many column/association definitions (>":MAXLINES:")"
gosub UCAF
goto GOODBYE
end
OLAP = 0
if I <= 9 then I2 = "0":I else I2 = I
read DEF1 from NVAR,"SQL_A":I2 else goto RDERR
if upcase(DEF1<3>) = "D" then continue
if upcase(DEF1<3>) = "O" then OLAP = 1 else
NEEDQ = DEF1<2> ; gosub QFIRST
ADEF = NEEDQ
if DISP then print " ":I2:" ":ADEF
gosub MKDEFASSOC
CRX(CRNEX) = "ASSOC ":COLDEF:"," ; CRNEX += 1
end
AC = "A" ; gosub BUILDSELAC
PINFO2:
readnext SQLID else continue
read DEF2 from NVAR,SQLID else goto RDERR
ALPHID = SQLID[8,1]
if (((DEF2<2> <> DEF1<2>) or OLAP) and DISP) then
print " ":I2:ALPHID:" ":
NEEDQ = DEF2<2> ; gosub QFIRST
print NEEDQ:
if OLAP then print space(6):"Overlapping association not used" else
print space(6):"PHrase differs from ASSOC"
end
end
goto PINFO2
next I
* Finish the CREATE EXISTING TABLE statement
* Replace trailing comma, on last column or assoc definition, by ");"
FINCRX:
CRL = CRX(CRNEX-1)
CRX(CRNEX-1) = CRL[1,len(CRL)-1]:");"
CRXDONE = 1
if WARNX > 1 then
NUMAST = 43 - len(FILENM)
if NUMAST < 4 then NUMAST = 4
NUMAST2 = int(NUMAST/2)
NUMAST1 = NUMAST2
if NUMAST2 <> NUMAST/2 then NUMAST1 += 1
BANNER = change(space(NUMAST1)," ","*"):' Inconsistencies found in DICT "'
BANNER := FILENM:'" ':change(space(NUMAST2)," ","*")
print BANNER
for I = 1 to WARNX-1
print " ":WARNINGS(I)
next I
print "****************************************************************":
print "*************"
end
if SHOW then gosub PCRX
if CRTAB then goto CRXTAB
if TEST then
if TESTEDIT then TEST = 0 else goto GOODBYE
end
* Allow user to edit the column definitions and association definitions
EDIT:
print "Enter C..., D..., U..., R..., ":
print "R, S, X, Q, or H for Help [R]: ":
if TESTEDIT then
TVAR = INPUTS(INCOUNT)
print TVAR
INCOUNT += 1
end else
input TVAR
end
EDIT1:
* Reset SHOW and DISP in case they were changed by previous "S" typein
SHOW = 0
DISP = 1
begin case
* case upcase(TVAR) = "V" **??
* gosub MAKEVFLAG
* goto EDIT
case TVAR = "" or upcase(TVAR) = "R"
goto REPORT
case upcase(TVAR[1,1]) = "R"
EDCOM = TVAR
gosub DISPCA
if EDERR then gosub PEDERR
goto EDIT
case upcase(TVAR) = "S"
if CRXDONE then
gosub PCRX
goto EDIT
end else
SHOW = 1
DISP = 0
goto REPORT
end
case upcase(TVAR) = "X"
CRTAB = 1
SAVE = 0
DISP = 0
goto REPORT
case upcase(TVAR) = "X.SAVEDATA"
CRTAB = 1
SAVE = 1
DISP = 0
goto REPORT
case upcase(TVAR) = "Q"
gosub UCAF
goto GOODBYE
case upcase(TVAR) = "H"
goto HELP
case upcase(TVAR) = "M"
goto MOREHELP
case upcase(TVAR[1,1]) = "C"
CRXDONE = 0
EDCOM = TVAR
gosub CHANGECA
if EDERR then gosub PEDERR
goto EDIT
case upcase(TVAR[1,1]) = "D"
CRXDONE = 0
EDCOM = TVAR
gosub DELETECA
if EDERR then gosub PEDERR
goto EDIT
case upcase(TVAR[1,1]) = "U"
CRXDONE = 0
EDCOM = TVAR
gosub USECA
if EDERR then gosub PEDERR
goto EDIT
case 1
print " Invalid response" ; goto EDIT
end case
HELP:
*print "You may now change column or association definitions:"
*print " Enter V to Validate all current definitions"
print " Enter C... to Change a column or association"
print " Enter D... to Delete an association"
print " Enter U... to Use another column or association"
print " Enter R... to Redisplay a column or association"
print " Enter M for More help on the above options"
print " Enter R to Redisplay all current definitions (default)"
print " Enter S to Show the CREATE EXISTING TABLE statement"
print " Enter X to eXecute the CREATE EXISTING TABLE statement"
print " Enter X.SAVEDATA to save the file's data and do the X option"
print " Enter Q to Quit"
print " Enter H for Help"
print "What is your choice? [R] ": ; input TVAR
goto EDIT1
MOREHELP:
print " CCn/xx/yy[/G] changes column n, replacing string 'xx' by 'yy'"
print " CKn/xx/yy[/G] changes key-part n, replacing string 'xx' by 'yy'"
print " CAn/xx/yy[/G] changes association n, replacing string 'xx' by 'yy'"
print " CCn T type changes datatype of column n to 'type'"
print " CKn T type changes datatype of key-part n to 'type'"
print " DAn deletes association n"
print " UCna uses synonym 'a' as preferred definition of column n"
print " UAna uses synonym 'a' as definition of association n"
print " RCn redisplays column n with all of its synonyms"
print " RKn redisplays key-part n"
print " RAn redisplays association n"
goto EDIT
* Prepare to Build and Execute the CREATE EXISTING TABLE statement
CRXTAB:
* Delete @KEY phrase from dictionary if it needs to be changed
if NEEDATKEY then
read TVAR from DVAR,"@KEY" then delete DVAR,"@KEY"
end
fileunlock DVAR
close DVAR
* If SAVEDATA option, create <filename>_SQLSAVE and copy data into it
if SAVE then
openpath VPATH to VOCVAR else
gosub UCAF
stop CMDNAME:" aborted. Can't open '":VPATH:"'"
end
SAVNM = change(FILENM," ","_"):"_SQLSAVE"
* Check if <filename>_SQLSAVE exists; if so, don't create it
LSLEEP = MAXSLEEP
CRXTAB1:
if LSLEEP <= 0 then
close VOCVAR
gosub UCAF
stop CMDNAME:" aborted. '":VPATH:"' is locked"
end
readl TVAR from VOCVAR,SAVNM locked
LSLEEP -= 1
sleep 2
goto CRXTAB1
end then
release VOCVAR,SAVNM
CLSAVE = "CLEAR.FILE ":SAVNM
print "Generating file '":SAVNM:"'"
execute CLSAVE capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
goto CRXTAB2
end else release VOCVAR,SAVNM
if CREATE.SYNTAX = "PICK" then
CRSAVE = "CREATE.FILE ":SAVNM:" 1 ":PMODSEP:",":FTYPE
end else
CRSAVE = "CREATE.FILE ":SAVNM:" ":FTYPE
if FMODSEP <> "" then CRSAVE := " ":FMODSEP
end
print "Generating file '":SAVNM:"'"
execute CRSAVE capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
CRXTAB2:
CPSAVE = "COPYI FROM ":FILENM:" TO ":SAVNM:" ALL"
execute CPSAVE capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
close VOCVAR ; *close the VOC file
end
print "Preparing to create table ......"
* Now build the CREATE EXISTING TABLE statement
CRXDEF = CRX(1):" "
for I = 2 to CRNEX-1
CRXDEF := CRX(I):" "
next I
CRXDEF = CRXDEF[1,len(CRXDEF)-1]
TVAR = 9
* Now execute the CREATE EXISTING TABLE statement
* If outputting to printer, then capture-and-print output because otherwise
* sdml writes its output to error-out which goes to screen
if LPTR then
execute CRXDEF capturing CRTABOUT setting TVAR
print change(CRTABOUT,char(254),char(10),0,1)
end else
execute CRXDEF setting TVAR
end
* Check to see if CREATE EXISTING TABLE failed
if TVAR <> 0 then
if TVAR <> -1 then goto NORETURN
print "Table could not be created."
* Silently issue a CREATE EXISTING TABLE...RESTORE command since the
* table may be partially created in some error situations
CRXDEF = 'CREATE EXISTING TABLE "':change(FILENM,'"','""'):'" RESTORE;'
execute CRXDEF capturing CRTABOUT setting TVAR
POUT = change(CRTABOUT,char(254),char(10),0,1)
if POUT[1] = char(10) then POUT = POUT[1,len(POUT)-1]
if DEBUG then print POUT
* Silently restore the dictionary from the SQLDEF file since it might
* be partially modified in some error situations
open "DICT",FILENM to DVAR else goto CRXTAB5
* Copy the saved dictionary records from SQLDEF to DICT FILENM
clearfile DVAR
SELNX = 'SELECT ':DEFNM:' WITH NOT (@ID LIKE "SQL_..." AND F1 LIKE "X...")'
execute SELNX capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
NOMORE = 0
loop
until NOMORE
readnext ATID then
read DICTREC from NVAR,ATID else goto RDERR
write DICTREC to DVAR,ATID else goto WRERR
end else NOMORE = 1
repeat
close DVAR
goto CRXTAB5
end else
* Write @SELECT record (unless no change needed) to the table's dictionary
if USESELECT = "1" then
read TVAR from NVAR,"SQL_SELECT" then
open "DICT",FILENM to DVAR else
OPSTAT = status()
print "Can't open DICT '":FILENM:"'. ":
gosub POPERR
goto CRXTAB5
end
write "PH":@FM:TVAR<2> to DVAR,"@SELECT" else goto WRERR
close DVAR
end
end
end
CRXTAB5:
fileunlock NVAR
close NVAR
fileunlock DNVAR
close DNVAR
GOODBYE:
* I think next is unnecessary because 1005 seems to get reset anyway but...
if SYS1005 = 0 then assign 0 to system(1005)
stop
*****************
* Subroutines *
*****************
* Subroutine to put current date/time in printable format (into DATETIME)
GETDAT:
DATETIME = oconv(date(),'D'):" ":oconv(time(),'MT')
return ; *from GETDAT
* Subroutine to rewrite SQL_INFO record with new date/time stamp
NEWDSTAMP:
read INFREC from NVAR,"SQL_INFO" else goto RDERR
gosub GETDAT
INFREC<6> = " (SQLDEF last updated ":DATETIME:")"
write INFREC to NVAR,"SQL_INFO" else goto WRERR
return ; *from NEWDSTAMP
* TRIMAT subroutine
*4/29/97 All this routine does is fix up field 2.
*4/29/97 It doesn't trim other fields any more.
*NONO Trim all fields in ATREC and eliminate completely blank fields.NONONONO
* For ATREC<2>, the location field, change empty or multiple 0's to a single 0.
* Also remove leading zeros from location field.
TRIMAT:
* for T = 1 to 10
* ATREC<T> = trim(ATREC<T>)
* if ATREC<T> = " " then ATREC<T> = ""
* next T
if (ATREC<2> = '' or ATREC<2> = 0) then ATREC<2> = '0'
if len(ATREC<2>) > 1 then ATREC<2> = trim(ATREC<2>,"0","L")
return ; *from TRIMAT
* Setup for the "INFO" argument
SETUPINFO:
CNTD = "COUNT DICT "
CNTAS2 = ' WITH CODE = "A" OR CODE LIKE "A ..."'
CNTAS2 := ' OR CODE = "S" OR CODE LIKE "S ..."'
CNTDD2 = ' WITH CODE LIKE "D..."'
SUMDD = "SELECT BREAK.ON LOC FMT '2R' COL.HDG 'LOC',"
SUMDD := " @ID FMT '18L' COL.HDG 'FIELD NAME',"
SUMDD := " SM FMT '2L' COL.HDG 'SM',"
SUMDD := " FORMAT FMT '4L' COL.HDG 'FMT',"
SUMDD := " CONV FMT '6L' COL.HDG 'CONV',"
SUMDD := " NAME FMT '24L' COL.HDG 'DISPLAY NAME',"
SUMDD := " SQLTYPE FMT '16L' COL.HDG 'SQLTYPE'"
SUMDD := " FROM DICT "
SUMDD2 = " WHERE CODE LIKE 'D%' ORDER BY LOC HEADING "
SUMDD2 := '"Type D entries from DICT '
SUMDD2 := "'F18' 'T'"
SUMDD2 := '" COUNT.SUP;'
SUMAS = "SELECT BREAK.ON F2 FMT '2R' COL.HDG 'LOC',"
SUMAS := " @ID FMT '18L' COL.HDG 'FIELD NAME',"
SUMAS := " F9 FMT '2L' COL.HDG 'TY',"
SUMAS := " F10 FMT '4L' COL.HDG 'WID',"
SUMAS := " F7 FMT '6L' COL.HDG 'CONV',"
SUMAS := " F3 FMT '24L' COL.HDG 'DISPLAY NAME',"
SUMAS := " F1 FMT '2L' COL.HDG 'AS',"
SUMAS := " F8 FMT '9L' COL.HDG 'CORR',"
SUMAS := " F6 FMT '3L' COL.HDG 'SQL'"
SUMAS := " FROM DICT "
SUMAS2 = " WHERE F1 = 'A' OR F1 LIKE 'A %' OR F1 = 'S'"
SUMAS2 := " OR F1 LIKE 'S %' ORDER BY LOC HEADING "
SUMAS2 := '"Type A and S entries from DICT '
SUMAS2 := "'F18' 'T'"
SUMAS2 := '" COUNT.SUP;'
return ; *from SETUPINFO
* Print dictionary info (part of INFO option)
* This subr removes ** and *** lines, press-any-key lines, clear-screen lines,
* superfluous blank lines (really?), and heading lines except the first
* Input is TVAR (captured output of a SELECT statement from DICT...)
PRINTOUT:
LOOPP = 0
HDG = 0
BLINE = 0
loop
LOOPP += 1
while TVAR <> "" and LOOPP <= 999 do
TVARF = field(TVAR,@FM,1,1)
if seq(TVARF[1,1]) = 27 then
LOOPN = 0
loop
LOOPN += 1
while TVARF <> "" and TVARF[1,4] <> "Type" and LOOPN <= 99 do TVARF = TVARF[2,len(TVARF)-1]
repeat
end
* Next takes care of INFO flavor BREAK.ON (line consists of **)
if TVARF = "**" then del TVAR<1> ; continue
* Next takes care of PICK flavor BREAK.ON (*** line followed by blank line)
if TVARF = "***" then
del TVAR<1>
if trim(TVAR<1>) = "" then del TVAR<1>
continue
end
if TVARF[1,5] = "Press" then del TVAR<1> ; continue
if TVARF[1,4] = "Type" and HDG = 2 then del TVAR<1> ; continue
if TVARF[1,5] = "LOC F" and HDG = 2 then del TVAR<1> ; continue
print TVARF
begin case
case HDG = 0
if TVARF[1,4] <> "Type" and TVARF <> "" then
print "Error in dictionary list output"
return
end else
if TVARF <> "" then HDG = 1
end
case HDG = 1
if TVARF[1,5] <> "LOC F" and TVARF <> "" then
print "Error in dictionary list output"
return
end else
if TVARF <> "" then HDG = 2
end
end case
if TVARF = "" then BLINE = 1 else BLINE = 0
del TVAR<1>
repeat
return ; *from PRINTOUT
* Get count of number of dictionary items of type D, or of type A or S
* Input is CNTASD (which is the COUNT statement ready to execute)
* Output is CNTCNT:
* "" means we can't COUNT this dictionary and message has been issued
* else CNTCNT contains the requested COUNT (which, of course, may be 0)
GETCNT:
execute CNTASD capturing TVAR
if TVAR[1,1] = @FM then TVAR = trim(TVAR[2,29]) else TVAR = trim(TVAR[1,29])
if count(TVAR,"records counted") <> 1 then
CNTCNT = ""
print "Can't count DICT '":FILENM:"'"
return
end
CNTCNT = field(TVAR[1,29]," ",1,1)
if not(num(CNTCNT)) then
CNTCNT = ""
print "Can't count DICT '":FILENM:"'"
return
end
return ; *from GETCNT
* Build select list to get all definitions of the nth column or association
* (except the "planned" definition"
* Input is: I2 (2-or-more-digit column number)
* AC ("C" for column, "A" for association)
BUILDSELAC:
SELAC = 'SELECT ':DEFNM:' BY @ID WITH @ID LIKE "'
SELAC := "'SQL_":AC:I2:"'1A...":'"'
execute SELAC capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
return ; *from BUILDSELAC
* Build sorted select list of all column synonyms (either columns in the
* range 00 - 99 or columns with numbers greater than 99, depending on the
* value of input parameter LESS100). Then read the first record-id into
* SQLID, setting SQLID = "NOMORE" there are no records.
BUILDSELCOL:
SELAC = 'SELECT ':DEFNM:' BY @ID WITH @ID LIKE "'
if LESS100 then
SELAC := "'SQL_C'2N1A...":'"'
end else
SELAC := "'SQL_C'3N1A...":'"'
end
execute SELAC capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
readnext SQLID else SQLID = "NOMORE"
return ; *from BUILDSELCOL
* Check if a given column name is in user-specified @SELECT phrase
* by consulting the SELNAMES() array.
* Input: ATID is column name to be checked
* Output: INSEL = 1 if there is a user-specified @SELECT and ATID is in it
* INSEL = 0 otherwise
CKSEL:
INSEL = 0
if NEWATSEL or (SELLAST = 0) then return
for I = 1 to SELLAST
until SELNAMES(I,1) = ATID
next I
if I <= SELLAST then INSEL = 1
return ; *from CKSEL
* Check if a given column name is in @KEY phrase (if @KEY contains more than
* one token) by consulting the KEYNAMES() array.
* Input: ATID is column name to be checked
* Output: INKEY = 1 if there is a multi-token @KEY phrase and ATID is in it
* INKEY = 0 otherwise
CKKEY:
INKEY = 0
if KEYLAST <= 1 then return
for I = 1 to KEYLAST
until KEYNAMES(I,1) = ATID
next I
if I <= KEYLAST then INKEY = 1
return ; *from CKKEY
* Check if a given column name is in @ phrase by consulting ATNAMES() array.
* Input: ATID is column name to be checked
* Output: INAT = 1 if there is an @ phrase and ATID is in it
* INAT = 0 otherwise
CKAT:
INAT = 0
if ATLAST <= 0 then return
for I = 1 to ATLAST
until ATNAMES(I,1) = ATID
next I
if I <= ATLAST then INAT = 1
return ; *from CKAT
* Create column definition from D, A, or S type dictionary record
* Builds COLDEF consisting of <column name>
* <datatype>
* then optionally <multival>
* <colhdg>
* <fmt>
* <conv>
*
* Inputs are: ATID (record-id)
* ATREC (record-contents)
* CODE (D, A, or S)
* LOC (field location)
* Note: LOC < 0 means this is a key-part of a multi-part key;
* in this case, if the field is an I-descriptor, the
* value of CODE will be D
CREATECOL:
if LOC < 0 then
LOC2 = LOC * (-1)
if LOC2 <= 9 then LOC2 = "0":LOC2
end else
if LOC <= 9 then LOC2 = "0":LOC else LOC2 = LOC
end
* Get SQLTYPE
if CODE = 'D' then SQLTYPE = ATREC<8> else SQLTYPE = ATREC<6>
* Get single/multi (MULTI), and get assoc info (ASSOC)
MULTI = 'S'
ASSOC = ""
if CODE = 'D' then
if ATREC<6>[1,1] = 'M' then MULTI = 'M'
ASSOC = ATREC<7>
if LOC <= 0 then
if MULTI = 'M' then
WX = 'Dict entry "':ATID:'" defines'
if LOC < 0 then WX := " a Key-part" else WX := " field 0"
WARNINGS(WARNX) = WX:" so its SM = 'M' is illegal"
if WARNX < MAXWARN then WARNX += 1
MULTI = 'S'
ASSOC = ""
end else
if ASSOC # "" then
WX = 'Dict entry "':ATID:'" defines'
if LOC < 0 then WX := " a Key-part" else WX := " field 0"
WARNINGS(WARNX) = WX:" so its ASSOC '":ASSOC:"' is ignored"
if WARNX < MAXWARN then WARNX += 1
ASSOC = ""
end
end
end
end else
AR4 = ATREC<4>
if ATREC<5> = 'M' then MULTI = 'M'
if len(AR4) > 2 and (AR4[1,2] = "D;" or AR4[1,2] = "C;") then
MULTI = 'M'
ASSOC = AR4
end
if LOC <= 0 then
if ASSOC # "" then
WX = 'Dict entry "':ATID:'" defines'
if LOC < 0 then WX := " a Key-part" else WX := " field 0"
WARNINGS(WARNX) = WX:" so its ASSOC '":ASSOC:"' is illegal"
if WARNX < MAXWARN then WARNX += 1
MULTI = 'S'
ASSOC = ""
end else
if MULTI = 'M' then
WX = 'Dict entry "':ATID:'" defines'
if LOC < 0 then WX := " a Key-part" else WX := " field 0"
WARNINGS(WARNX) = WX:" so its SM = 'M' is illegal"
if WARNX < MAXWARN then WARNX += 1
MULTI = 'S'
end
end
end
if ASSOC[1,2] = "D;" then ASSOC = ""
end
* Get COLHDG
if CODE = 'D' then COLHDG = ATREC<4> else COLHDG = ATREC<3>
* Get CONV
if CODE = 'D' then CONV = ATREC<3> else CONV = ATREC<7>
* Get FMT
if CODE = 'D' then FMT = ATREC<5> else
FMT = ATREC<10>
if ATREC<9> = "" then
if FMT <> "" then FMT := 'L'
end else
FMT := ATREC<9>
end
end
gosub ANALFMT
* At this point: SQLTYPE (from dict, may be empty)
* MULTI (M or S or PK)
* COLHDG (from dict, may be empty)
* CONV (from dict, may be empty)
* FMT (empty, <just>, or <width><just>)
* FMTJ (justification)
* FMTW (width)
* ASSOC (from dict, empty if A/S 'D;...')
* Add info to ASSOCS array if relevant
if ASSOC <> "" and MULTI = "M" then
if CODE = 'D' then ASSOCID = ASSOC else ASSOCID = "@DC":LOC
for I = 1 to ASSOCLAST
until ASSOCS(I,1) = ASSOCID
next I
begin case
case I > 50
WARNINGS(WARNX) = "ASSOC '":ASSOC:"' in dict entry"
WARNINGS(WARNX) := ' "':ATID:'" is ignored: >50 associations'
if WARNX < MAXWARN then WARNX += 1
goto CONVSQLTYPE
case I > ASSOCLAST
if ASSOCS(I,LOC+1) = "0" then ASSOCS(I,LOC+1) = "X"
ASSOCLAST += 1
ASSOCS(I,1) = ASSOCID
ASSOCS(I,MAXC+3) = "N"
read KEYX from NVAR,"@ASSOC_KEY.":ASSOCID then
KEYX2 = trim(KEYX<2>)
begin case
case upcase(KEYX<1>[1,1]) # "X"
case KEYX2 = "STABLE"
ASSOCS(I,MAXC+3) = "S"
case KEYX2 = "UNSTABLE"
ASSOCS(I,MAXC+3) = "U"
case field(KEYX2," ",1,1) = "KEY"
KEYX2 = field(KEYX2," ",2,999)
FOUND = 0
loop ; until KEYX2 = "" do
COLID = field(KEYX2," ",1,1)
for L = 1 to COLLAST
KNUM = COLUMNS(L,2)
for J = 3 to 2+KNUM
until COLUMNS(L,J) = COLID
next J
if J > 2+KNUM then continue
FOUND = 1
ASSOCS(I,L+1) = "K"
until 1
next L
KEYX2 = field(KEYX2," ",2,999)
repeat
if FOUND then ASSOCS(I,MAXC+3) = "K"
end case
end
read APH from NVAR,ASSOCID then
if upcase(APH<1>[1,2]) = "PH" then
PHRASES(I,1) = ASSOCID
PHORD = 1
DICTTEMP = APH<2>
PHNAME = ASSOCID ; gosub EXPANDPH
if VOCOPEN then close VOCVAR ; VOCOPEN = 0
loop ; until DICTTEMP = "" do
COLID = field(DICTTEMP," ",1,1)
* (5/20/97) At this point I was tempted to verify that COLID actually exists
* in the dictionary (else give error message), but then I realized that (a)
* keywords such as HEADING may legitimately appear in an association phrase,
* and furthermore (b) subroutine EXPANDPH has already purged any such tokens
* from DICTTEMP.
for L = 1 to COLLAST
KNUM = COLUMNS(L,2)
for J = 3 to 2+KNUM
until COLUMNS(L,J) = COLID
next J
if J > 2+KNUM then continue
PHRASES(I,1+L) = PHORD
PHORD += 1
until 1
next L
DICTTEMP = field(DICTTEMP," ",2,999)
repeat
PHRASES(I,MAXC+3) = PHORD-1
end
end
case 1
if ASSOCS(I,LOC+1) = "0" then ASSOCS(I,LOC+1) = "X"
end case
if CODE # 'D' then
ASC2 = trim(ASSOC[3,99])
for J = 1 to 98
NEXTNUM = trim(field(ASC2,";",1))
NEXTNUM = trim(NEXTNUM,"0","L")
until NEXTNUM = ""
ASC2 = field(ASC2,";",2,50)
if not(num(NEXTNUM)) then continue
if NEXTNUM > MAXC then continue
ASSOCS(I,NEXTNUM+1) = "X"
next J
end
end
* Convert SQLTYPE to correct format if it is present in dictionary
CONVSQLTYPE:
if len(SQLTYPE) > 0 then
gosub CONVST
if not(CSTERR) then goto MKDEFCOL
end
* Determine data type if SQLTYPE not present
* (note that there is code below to handle cases where FMTW = "" even though
* I don't think that can happen)
MAKETYPE:
if CONV = "" then
begin case
case FMT = ""
SQLTYPE = "VARCHAR"
case FMTJ = 'R'
SQLTYPE = "INT"
case FMTJ[1,1] = 'Q'
SQLTYPE = "REAL"
* If we reach this point, the Justification is L, T, or U
case 1
SQLTYPE = "VARCHAR"
if FMTW # "" then
if FMTW > 254 and FMTW < 65536 then SQLTYPE := "(":FMTW:")"
end
end case
end else
CONV12 = upcase(CONV[1,2])
begin case
case CONV12 = 'MD' or CONV12 = 'ML' or CONV12 = 'MR'
gosub GETSCALE
if SCALEX = "0" then SQLTYPE = "INT" else
SQLTYPE = "DEC(9,":SCALEX:")" ; * Should prec always be 9??
end
case CONV12 = 'MB' or CONV12 = 'MO' or CONV12 = 'MX' or CONV12 = 'NR'
SQLTYPE = "INT"
case CONV12[1,1] = 'Q'
SQLTYPE = "REAL"
case CONV12[1,1] = 'D'
SQLTYPE = "DATE"
case CONV12 = 'MT'
SQLTYPE = "TIME"
case 1 ; * There is a CONV but it isn't one of the above
SQLTYPE = "VARCHAR"
if FMTW # "" then
if FMTW > 254 and FMTW < 65536 then SQLTYPE := "(":FMTW:")"
end
end case
end
if FMTW = "" then FMT = ""
* Build column definition string
MKDEFCOL:
COLDEF = SQLTYPE
if MULTI[1,1] = 'M' then COLDEF := " MULTIVALUED"
if COLHDG # "" then
USTRING = COLHDG ; gosub QSTRING
COLDEF := " COL.HDG ":USTRING
end
if FMT # "" then
USTRING = FMT ; gosub QSTRING
COLDEF := " FMT ":USTRING
end
if CONV # "" then
begin case
* If type is DATE or TIME and CONV disagrees, don't emit CONV
case SQLTYPE = "DATE" and CONV[1,1] # "D"
case SQLTYPE = "TIME" and CONV[1,2] # "MT"
case 1
USTRING = CONV ; gosub QSTRING
COLDEF := " CONV ":USTRING
end case
end
COLDEF = ATID:" ":COLDEF
TVAR = "X":@FM:COLDEF
if LOC < 0 then
AVAR = "SQL_K":LOC2 ; * key-part of multi-part key
end else
AVAR = "SQL_C":LOC2:ALPHID:"_":ATID
end
* Write synonym (alphid) definition, or key-part definition, to SQLDEF file
write TVAR to NVAR,AVAR else goto WRERR
return ; *from CREATECOL
* Write preferred column definition (except for key-part) to SQLDEF file
WRCOL:
AVAR = "SQL_C":LOC2
if LOC = 0 then
TVAR<3> = COLUMNS(MAXC+1,2)
end else
TVAR<3> = COLUMNS(LOC,2)
end
write TVAR to NVAR,AVAR else goto WRERR
return ; *from WRCOL
* Check SQLTYPE (from dictionary) for validity and convert it to proper format
* for CREATE TABLE. If invalid, set CSTERR = 1 and set SQLTYPE = "".
CONVST:
CSTERR = 0
SQLTYPE = change(SQLTYPE,"INTEGER","INT",1,1)
SQLTYPE = change(SQLTYPE,"DECIMAL","DEC",1,1)
SQLTYPE = change(SQLTYPE,"CHARACTER","CHAR",1,1)
NCOMMA = count(SQLTYPE,",")
begin case
case SQLTYPE = "INT"
case SQLTYPE = "SMALLINT"
case SQLTYPE = "REAL"
case SQLTYPE = "DATE"
case SQLTYPE = "TIME"
case SQLTYPE = "DOUBLE"
SQLTYPE = "DOUBLE PRECISION"
* Next 4 cases allow for commas in some SQLTYPEs
case SQLTYPE[1,3] = "DEC"
STYPE = "DEC"
if (NCOMMA = 1 or NCOMMA = 2) then goto CST1
SQLTYPE = STYPE
case SQLTYPE[1,7] = "NUMERIC"
STYPE = "NUMERIC"
if (NCOMMA = 1 or NCOMMA = 2) then goto CST1
SQLTYPE = STYPE
case SQLTYPE[1,5] = "FLOAT"
STYPE = "FLOAT"
if NCOMMA = 1 then goto CST1
SQLTYPE = STYPE
case SQLTYPE[1,4] = "CHAR" or SQLTYPE[1,7] = "VARCHAR"
if NCOMMA = 1 then
CSTNUM = field(SQLTYPE,',',2,99)
begin case
case not(num(CSTNUM))
SQLTYPE = "VARCHAR"
case CSTNUM < 1 or CSTNUM > 65535
SQLTYPE = "VARCHAR"
case CSTNUM < 255 and SQLTYPE[1,4] = "CHAR"
SQLTYPE = "CHAR(":CSTNUM:")"
case 1
SQLTYPE = "VARCHAR(":CSTNUM:")"
end case
end else
if SQLTYPE[1,4] = "CHAR" then
SQLTYPE = "CHAR"
end else
SQLTYPE = "VARCHAR"
end
end
case 1
SQLTYPE = ""
CSTERR = 1
return ; *from CONVST (SQLTYPE is bad)
end case
return ; *from CONVST (no error)
CST1:
NUM1 = field(SQLTYPE,',',2)
NUM2 = field(SQLTYPE,',',3)
if not(num(NUM1)) or NUM1 = "" then SQLTYPE = STYPE ; return
if NUM1 < 1 or NUM1 <> int(NUM1) then SQLTYPE = STYPE ; return
SQLTYPE = STYPE:"(":NUM1+0
if NCOMMA = 1 then SQLTYPE := ")" ; return
if not(num(NUM2)) or NUM2 = "" then SQLTYPE := ")" ; return
if NUM2 < 0 or NUM2 <> int(NUM2) then SQLTYPE := ")" ; return
if NUM2 > NUM1 then NUM2 = NUM1
if NUM2 > 9 then NUM2 = 9
SQLTYPE := ",":NUM2+0:")"
return ; *from CONVST (no error)
* Get the scale factor from MD, ML, or MR conversion
* Input: CONV contains the conversion code (already known to be MD, ML, or MR)
* Output: SCALEX contains the scale as a single digit in the range 0-9
GETSCALE:
if not(num(CONV[3,1])) or CONV[3,1] = "" then SCALEX = "0" ; return
if not(num(CONV[4,1])) or CONV[4,1] = "" then
SCALEX = CONV[3,1]
end else
SCALEX = CONV[4,1]
end
return ; *from GETSCALE
* Create column definition for field which has no dictionary definition
* Builds COLDEF consisting of <generated column name>
* <datatype>
* <multival>
*
* Inputs are: LOC (field location)
*
CREATENONE:
if LOC <= 9 then LOC2 = "0":LOC else LOC2 = LOC
LEGAL = "SQL_C":LOC2
gosub CKDUPDICT
* if ISDUP then VALCODE = 1 else
if not(ISDUP) then
NEWLAST += 1
if NEWLAST > MAXNEW then
print "Too many (>":MAXNEW:") newly created dictionary names"
goto GOODBYE
end
NEWDICT(NEWLAST) = LEGAL
end
COLDEF = LEGAL
COLDEF := " VARCHAR MULTIVALUED"
TVAR = "X":@FM:COLDEF:@FM:"1"
AVAR = "SQL_C":LOC2
write TVAR to NVAR,AVAR else goto WRERR
return ; *from CREATENONE
* Create association definition from an entry in ASSOCS
* Builds COLDEF consisting of <assoc name>
* (<colnumber> KEY,
* ... <colnumber>)
*
* Inputs are AIX (index into ASSOCS array)
* ASSOCID (association name)
*
CREATEASSOC:
if AIX <= 9 then AIX2 = "0":AIX else AIX2 = AIX
COLDEF = "("
if PHRASES(AIX,1) = ASSOCID then PHZ = 1 else PHZ = 0
OLAPERR = 0
PHZERR = 0
FIRST = 1
* Check consistency of this association's definition with:
* (a) the column-makeup of lower-numbered associations (ie, overlap), and
* (b) a PHrase having same name (if one exists)
* Set OLAPERR if there is an overlap; set PHZERR if PHrase exists and differs
for J = 1 to MAXC
if J <=9 then J2 = "0":J else J2 = J
if ASSOCS(AIX,J+1) = 0 then
if PHZ and PHRASES(AIX,J+1) <> 0 then PHZERR = 1
continue
end
if ASSOCS(AIX,J+1) = "K" then
if AIX > 1 then
for M = 1 to AIX-1
if (ASSOCS(M,J+1) # 0 and ASSOCS(M,MAXC+2) = 0) then OLAPERR = 1
next M
end
if PHZ and PHRASES(AIX,J+1) = 0 then PHZERR = 1
if FIRST then FIRST = 0 else COLDEF := ", "
COLDEF := J2:" KEY"
continue
end
if ASSOCS(AIX,J+1) = "X" then
if AIX > 1 then
for M = 1 to AIX-1
if (ASSOCS(M,J+1) # 0 and ASSOCS(M,MAXC+2) = 0) then OLAPERR = 1
next M
end
if PHZ and PHRASES(AIX,J+1) = 0 then PHZERR = 1
if FIRST then FIRST = 0 else COLDEF := ", "
COLDEF := J2
continue
end
next J
COLDEF := ")"
if PHRASES(AIX,MAXC+2) <> 0 then PHZERR = 1
* If this association overlaps another association, mark it in ASSOCS()
if OLAPERR then ASSOCS(AIX,MAXC+2) = "X"
* If there is a PHrase for this association, and it agrees with the assoc
* inferred from data field defs in dictionary, then order the columns in
* the chosen association definition according to the PHrase ordering
if (PHZ and not(PHZERR)) then gosub REORDER
if ASSOCS(AIX,MAXC+3) = "S" then COLDEF = "INSERT PRESERVING ":COLDEF
if ASSOCS(AIX,MAXC+3) = "U" then COLDEF = "INSERT LAST ":COLDEF
CHODEF = ASSOCID:" ":COLDEF
* If this association overlaps another association, mark it as overlapping
* Now write out the chosen association definition to <filename>_SQLDEF
*
TVAR = "X":@FM:CHODEF
if OLAPERR then TVAR := @FM:"O"
AVAR = "SQL_A":AIX2
write TVAR to NVAR,AVAR else goto WRERR
* If there is a PHrase for this association, then order the columns in the
* "association-synonym" according to the PHrase ordering
if PHZ then gosub REORDER
if ASSOCS(AIX,MAXC+3) = "S" then COLDEF = "INSERT PRESERVING ":COLDEF
if ASSOCS(AIX,MAXC+3) = "U" then COLDEF = "INSERT LAST ":COLDEF
COLDEF = ASSOCID:" ":COLDEF
* Now write the "assoc-synonym" definition to <filename>_SQLDEF
TVAR = "X":@FM:COLDEF
if ALPHID = "Z" then ALPHID = "a" else
ALPHID = char(seq(ALPHID)+1)
end
AVAR = "SQL_A":AIX2:ALPHID:"_":ASSOCID
write TVAR to NVAR,AVAR else goto WRERR
return ; *from CREATEASSOC
* Subroutine to reorder assoc according to PHrase ordering
REORDER:
COLDEF = "("
FIRST = 1
if PHRASES(AIX,MAXC+3) = 0 then goto REORD1
for I = 1 to PHRASES(AIX,MAXC+3)
for J = 1 to MAXC
if PHRASES(AIX,J+1) = I then
if J <= 9 then J2 = "0":J else J2 = J
if FIRST then FIRST = 0 else COLDEF := ", "
COLDEF := J2
if ASSOCS(AIX,J+1) = "K" then
COLDEF := " KEY"
end
goto REORD2
end
next J
REORD2:
next I
REORD1:
if PHRASES(AIX,MAXC+2) <> 0 then
if not(FIRST) then COLDEF := ", "
COLDEF := "??"
end
COLDEF := ")"
return ; *from REORDER
* Create association definition in CREATE TABLE format
* Also update column def(s) to add NOT NULL for association KEY(s)
* (if not already there)
* Also update column def(s) to add MULTIVALUED (if not already there)
* Output is COLDEF
* Inputs are: ADEF association definition with column numbers not names
* CRXCOL() array of positions in CRXTAB statemt of chosen columns
MKDEFASSOC:
COLDEF = field(ADEF,"(",1,1):"("
ADEF = trim(field(ADEF,"(",2,99))
if ADEF[1] = ")" then ADEF = trim(ADEF[1,len(ADEF)-1])
if ADEF[3] = ",??" then ADEF = trim(ADEF[1,len(ADEF)-3])
if ADEF[4] = ", ??" then ADEF = trim(ADEF[1,len(ADEF)-4])
FIRST = 1
loop ; until dcount(ADEF,",") < 1 do
CHGCOLM = 0
if FIRST then FIRST = 0 else COLDEF := ", "
A2 = field(ADEF," ",1,1) ; if A2[1] = "," then A2 = A2[1,len(A2)-1]
read DEF3 from NVAR,"SQL_C":A2 else goto MKDEFA1
if DEF3<2>[1,1] # '"' then
DEF321 = '"':change(field(DEF3<2>," ",1,1),'"','""'):'"'
end else DEF321 = field(DEF3<2>," ",1,1)
COLDEF := DEF321
DEF32 = DEF321:" ":field(DEF3<2>," ",2,1)
if field(DEF32," ",2,1) = "DOUBLE" then
DEF32 := " ":field(DEF3<2>," ",3,1)
DBL = 1
end else DBL = 0
MULTIV = " MULTIVALUED"
findstr MULTIV in DEF3<2> setting FMC else
DEF32 := MULTIV
CHGCOLM = 1
end
if field(ADEF," ",2,1)[1,3] = "KEY" then
COLDEF := " KEY"
findstr " ":NN in DEF3<2> setting FMC else
DEF32 := " ":NN
CHGCOLM = 1
end
end
MKDEFA1:
if CHGCOLM then
if DBL then
DEF32 := " ":field(DEF3<2>," ",4,99):","
end else
DEF32 := " ":field(DEF3<2>," ",3,99):","
end
CRX(CRXCOL(trim(A2,"0","L"))) = DEF32
end
ADEF = trim(field(ADEF,",",2,99))
repeat
COLDEF := ")"
return ; *from MKDEFASSOC
* Analyze FMT and generate FMTJ (justification) and FMTW (width)
ANALFMT:
if FMT # "" then
* put width in FMTW
TVAR = FMT
FMTW = ""
loop
until TVAR = "" or not(num(TVAR[1,1])) do
FMTW := TVAR[1,1]
TVAR = TVAR[2,len(TVAR)-1]
repeat
* If FMT doesn't specify 'width', try to get width from 'mask'
if FMTW = "" then
FMTW = '10'
FMT9 = fmt(change(space(254)," ","9"),FMT)
FMTSTAT = status()
if FMTSTAT = 0 then
if len(FMT9) < 255 then FMTW = len(FMT9)
end
end
if FMTW = 0 then
FMTW = '0'
end else
FMTW = trim(FMTW,'0','L')
end
if TVAR = "" then TVAR = "T"
if TVAR[1,1] = "'" then
* bypass quoted fill character
TVAR = field(TVAR,"'",3,99)
if len(TVAR) = 0 then TVAR = "T" ; *syntax error in FMT
goto FMT1
end
T1 = TVAR[1,1]
* bypass unquoted fill character
if not(T1 = 'L' or T1 = 'R' or T1 = 'T' or T1 = 'U' or T1 = 'Q') then
TVAR = TVAR[2,len(TVAR)-1]
if len(TVAR) = 0 then TVAR = "T" ; *syntax error in FMT
end
FMT1:
T1 = TVAR[1,1]
if (T1 = 'L' or T1 = 'R' or T1 = 'T' or T1 = 'U' or T1 = 'Q') then
FMTJ = T1
TVAR = TVAR[2,len(TVAR)-1]
if len(TVAR) > 0 then
if TVAR[1,1] = 'L' then FMTJ = 'QL'
if TVAR[1,1] = 'R' then FMTJ = 'QR'
end
end else
if len(TVAR) > 1 then FMTJ = TVAR[2,1] else FMTJ = 'T'
end
end else
FMTJ = 'T'
FMTW = '10'
end
return ; *from ANALFMT
* Put appropriate quotes (single or double) around a character string
* Input: USTRING contains string to be quoted
* Output: USTRING has been appropriately quoted
QSTRING:
DQUOTE = "'"
if count(USTRING,"'") = 0 then goto QSEND
if count(USTRING,'"') = 0 then DQUOTE = '"' ; goto QSEND
USTRING = change (USTRING,"'",'"',0,1)
QSEND:
USTRING = DQUOTE:USTRING:DQUOTE
return ; *from QSTRING
* Enclose the first token of a string within double-quote-marks, and
* replace every double-quote in that token by a pair of double-quotes,
* if this hasn't already been done.
* Input: The string to be modified is in NEEDQ
* Output: The modified string is put back into NEEDQ
QFIRST:
if NEEDQ[1,1] # '"' then
NQ1 = '"':change(field(NEEDQ," ",1),'"','""'):'"'
NEEDQ = fieldstore(NEEDQ," ",1,-1,NQ1)
end
return ; *from QFIRST
* In a phrase, recursively replace PH-tokens by their contents until no
* PH-tokens remain. This subroutine is called from MAKEDINFO to process
* @SELECT, @, and @KEY phrases. It is also called (from CKASSOCPH and
* from within CREATECOL) to process association phrases.
* NOTE: This subroutine deals with the fact that phrases may contain certain
* multi-token clauses such as BREAK.SUP "text" fieldname or BY.EXP fieldname.
* Input: DICTTEMP contains the original phrase
* NVAR is the file-variable for the SQLDEF file (containing dict recs)
* VOCOPEN is a flag indicating whether the VOC is currently open
* PHNAME is the name of the PHrase being expanded
* Output: At return, DICTTEMP contains only non-PH tokens
* TOKCNT contains the number of tokens (used later for array size)
* IDSUP = 1 if "ID.SUP" was encountered, else 0
* VOCOPEN will be set to 1 by this subroutine if it opens the VOC
EXPANDPH:
IDSUP = 0
loop
PHF = 0
DICTT2 = ""
TOKCNT = 0
DICTTEMP = trim(DICTTEMP)
loop
while DICTTEMP # "" do
* Skip quoted string, including embedded spaces, if it is the next "token"
if DICTTEMP[1,1] = '"' and count(DICTTEMP,'"') > 1 then
DICTTEMP = trim(field(DICTTEMP,'"',3,999))
end else
if DICTTEMP[1,1] = "'" and count(DICTTEMP,"'") > 1 then
DICTTEMP = trim(field(DICTTEMP,"'",3,999))
end
end
TOKTEMP = field(DICTTEMP," ",1)
DICTTEMP = field(DICTTEMP," ",2,999)
* Skip token if same as original phrase name (GTAR 23597)
if TOKTEMP = PHNAME then continue
read RECTEMP from NVAR,TOKTEMP then
if upcase(RECTEMP<1>[1,2]) = 'PH' then
DICTT2 := " ":trim(RECTEMP<2>)
PHF = 1
end else
DICTT2 := " ":TOKTEMP
TOKCNT += 1
end
end else
if TOKTEMP = "ID.SUP" then IDSUP = 1 ; goto EXP2
if TOKTEMP = "@ASSOC_ROW" then
DICTT2 := " ":TOKTEMP
TOKCNT += 1
goto EXP2
end
if not(VOCOPEN) then
openpath VPATH to VOCVAR else
gosub UCAF
stop "Can't open '":VPATH:"'"
end
VOCOPEN = 1
end
LSLEEP = MAXSLEEP
EXP1:
if LSLEEP <= 0 then
close VOCVAR
gosub UCAF
stop "Record '":TOKTEMP:"' in '":VPATH:"' is locked"
end
readl KVAR from VOCVAR,TOKTEMP locked
LSLEEP -= 1
sleep 2
goto EXP1
end then
release VOCVAR,TOKTEMP
if upcase(KVAR<1>[1,1]) = "K" then
KV2 = KVAR<2>
begin case
case KV2 = 12 or KV2 = 13 ; * BY or BY.DSND
case KV2 = 48 or KV2 = 49 ; * BY.EXP or BY.EXP.DSND
case KV2 = 303 ; * ASSOC.WITH
case KV2 = 42 ; * BREAK.SUP
* Skip quoted string (if present) after BREAK.SUP
if DICTTEMP[1,1] = '"' and count(DICTTEMP,'"') > 1 then
DICTTEMP = trim(field(DICTTEMP,'"',3,999))
end else
if DICTTEMP[1,1] = "'" and count(DICTTEMP,"'") > 1 then
DICTTEMP = trim(field(DICTTEMP,"'",3,999))
end
end
case KV2 = 18 ; * ID.SUP other spellings
IDSUP = 1
goto EXP2
case 1
goto EXP2
end case
* Skip fieldname after BY, BY.DSND, BY.EXP, BY.EXP.DSND,
* ASSOC.WITH, and BREAK.SUP (and their alternate spellings)
DICTTEMP = field(DICTTEMP," ",2,999)
end
end
end
EXP2:
repeat
DICTTEMP = trim(DICTT2)
while PHF
repeat
return ; *from EXPANDPH
* Subroutine to show the planned CREATE EXISTING TABLE statement
PCRX:
if CRNEX < 3 then
print " CREATE EXISTING TABLE statement too short"
return
end
print CRX(1)
print " ":CRX(2)
if CRNEX = 3 then return
for I = 3 to CRNEX-1
print " ":CRX(I)
next I
return ; *from PCRX
* Check for legal SQL quoted identifier
* Input: IDENT is the identifier to be checked
* IDTYPE is the type of identifier (TABLE, COLUMN, or ASSOC)
* Output: if ILLEGAL = 0 then the identifier is OK
* else ILLEGAL contains a reason why the identifier is illegal (NULL,
* PERIOD, NTCHAR, MARKCHAR, CONTROL, SPACE, SLASHQ, or QUOTES)
CKLEGAL:
ILLEGAL = 0
if isnull(IDENT) then ILLEGAL = "it is SQL NULL" ; return
IDCH = IDENT[1,1]
if len(IDENT) = 1 and IDCH = @NULL.STR then
ILLEGAL = "it is SQL NULL"
return
end
if OS.TYPE = "UNIX" and IDCH = "." and IDTYPE = "TABLE" then
ILLEGAL = "starts with Period"
return
end
IDQ = ""
NTCHAR = "contains NT-restricted character"
SDQUOT = "contains both single and double Quotes"
MKCHAR = "contains Mark character"
loop ; until IDENT = "" do
IDCH = IDENT[1,1]
if OS.TYPE # "UNIX" then
if IDCH = '"' or IDCH = '%' or IDCH = '*' then ILLEGAL = NTCHAR
if IDCH = '\' or IDCH = ':' or IDCH = '<' then ILLEGAL = NTCHAR
if IDCH = '>' then ILLEGAL = NTCHAR
end
if seq(IDCH) >= 251 and seq(IDCH) <= 255 then ILLEGAL = MKCHAR
if seq(IDCH) >= 0 and seq(IDCH) <= 31 then ILLEGAL = "contains Hex 00-1F"
if IDCH = ' ' and IDTYPE = "COLUMN" then ILLEGAL = "contains Space"
if IDCH = '/' and IDTYPE = "TABLE" then ILLEGAL = "contains Slash"
if IDCH = '?' and IDTYPE = "TABLE" then ILLEGAL = "contains Question mark"
if IDCH = '"' and IDTYPE = "TABLE" then
if IDQ = "SINGLE" then ILLEGAL = SDQUOT
end else
IDQ = "DOUBLE"
end
if IDCH = "'" and IDTYPE = "TABLE" then
if IDQ = "DOUBLE" then ILLEGAL = SDQUOT
end else
IDQ = "SINGLE"
end
if ILLEGAL then return
IDENT = IDENT[2,len(IDENT)-1]
repeat
return ; *from CKLEGAL
* Check for duplicate entry in dictionary; generate non-dup name if necessary
* Input string is LEGAL (new name to be checked for uniqueness in dictionary)
* Output is ISDUP: if 0, then LEGAL is OK (possibly after some modification)
* if 1, then we can't find a valid name after many attempts
* and LEGAL is set to "NO_NAME"
CKDUPDICT:
gosub CDUP0
if ISDUP then
gosub CRNEW
if LEGAL = "" then
ISDUP = 1
LEGAL = "NO_NAME"
end else
ISDUP = 0
end
end
return ; *from CKDUPDICT
* Check for duplicate entry in dictionary
* Input string is LEGAL (new name to be checked for uniqueness in dictionary)
* Output is ISDUP: if 0, then LEGAL is OK
* if 1, then LEGAL is a duplicate
CDUP0:
ISDUP = 0
select DICTLIST
CDUP1:
readnext DICTID else goto CDUP2
if DICTID = LEGAL then goto CDUP9 else goto CDUP1
CDUP2:
if NEWLAST = 0 then return ; * LEGAL is OK, it doesn't duplicate anything
for N = 1 to NEWLAST
if NEWDICT(N) = LEGAL then goto CDUP9
next N
return ; * LEGAL is OK, it doesn't duplicate anything
CDUP9:
ISDUP = 1
return ; *from CDUP0 with ISDUP set to 1
* Create new unique legal name for dictionary entry
* Input = LEGAL (previously failed attempted new name)
* Output = LEGAL: if non-empty, contains new unique legal name
* if empty then we can't find a good name after many tries
CRNEW:
SAVLEG = LEGAL
if len(SAVLEG) > 16 then SAVLEG = SAVLEG[1,16]
for M = 1 to 9
LEGAL = SAVLEG:"_":char(48+M)
gosub CDUP0
if not(ISDUP) then return ; * LEGAL is now OK, ending with _1 to _9
next M
for M = 1 to 26
LEGAL = SAVLEG:"_":char(64+M)
gosub CDUP0
if not(ISDUP) then return ; * LEGAL is now OK, ending with _A to _Z
next M
for M = 1 to 26
LEGAL = SAVLEG:"_":char(96+M)
gosub CDUP0
if not(ISDUP) then return ; * LEGAL is now OK, ending with -a to -z
next M
LEGAL = ""
return ; *from CRNEW - can't find good name after many tries
* Subroutines to let user change a column or association definition
* Input is EDCOM (the typed-in edit command)
* Output is EDERR: 0 if no error
* 1 if command is wrong length
* 2 if column number is non-numeric
* 3 if synonym-identifier is non-alphabetic
* 4 if column has been deleted
* 5 if illegal command
* 6 if column-synonym is non-existent
* 7 if column number too large
* 8 if association number too large
* 9 if column not found (shouldn't happen)
* 10 if command not implemented yet
* 11 if key-part number is < 1
* 12 if assoc number is non-numeric
* 13 if no datatype was specified
* 14 if assoc has been deleted (or is overlapping)
* 16 if assoc-synonym is non-existent
* 17 if key-part number too large
* 18 if invalid datatype is entered
* 19 if assoc not found (shouldn't happen)
* 20 if datatype CHAR[ACTER] VARYING is entered
CHANGECA:
EDERR = 0
EDCOM = EDCOM[2,len(EDCOM)-1]
if upcase(EDCOM[1,1]) = "A" then goto CHANGEA
* Change column or key-part
if upcase(EDCOM[1,1]) = "K" then
EK = 1
EDCOM = EDCOM[2,len(EDCOM)-1]
end else
EK = 0
if upcase(EDCOM[1,1]) = "C" then EDCOM = EDCOM[2,len(EDCOM)-1]
end
gosub GETNUM
if NUMERR and EK then EDERR = 11 ; return
if NUMERR then EDERR = 2 ; return
if EC2[1,1] = " " then EC2 = EC2[2,len(EC2)-1]
if len(EC2) < 2 and upcase(EC2) # "T" then EDERR = 1 ; return
EC3 = EC2[2,len(EC2)-1]
EC2 = EC2[1,1]
if EK then
if I2 > KEYLAST then EDERR = 17 ; return
if I2 < 1 then EDERR = 11 ; return
CREC = "SQL_K":I2
end else
if I2 > COLLAST then EDERR = 7 ; return
if I2 < 1 and KEYLAST > 1 then EDERR = 15 ; return
CREC = "SQL_C":I2
end
read CDEF from NVAR,CREC else EDERR = 9 ; return
DEF = CDEF<2>
begin case
case EC2 = "/" or EC2 = "\"
if upcase(field(EC3,EC2,3)[1,1]) = "G" and field(EC3,EC2,1) # ""
then NUMREP = -1
else NUMREP = 1
DEF = ereplace(DEF,field(EC3,EC2,1),field(EC3,EC2,2),NUMREP)
OLDNAME = field(CDEF<2>," ",1)
NEWNAME = field(DEF," ",1)
gosub REWRITESEL
CDEF<2> = DEF
write CDEF to NVAR,CREC else goto WRERR
gosub NEWDSTAMP
NEEDQ = DEF ; gosub QFIRST
if EK then print " K":I2:" ":NEEDQ else print " ":I2:" ":NEEDQ
case upcase(EC2) = "N"
if upcase(EC3[1,3]) = "AME" then EC3 = EC3[4,len(EC3)-3]
NEWNAME = trim(EC3)
DEF = fieldstore(DEF," ",1,-1,NEWNAME)
OLDNAME = field(CDEF<2>," ",1)
gosub REWRITESEL
CDEF<2> = DEF
write CDEF to NVAR,CREC else goto WRERR
gosub NEWDSTAMP
NEEDQ = DEF ; gosub QFIRST
if EK then print " K":I2:" ":NEEDQ else print " ":I2:" ":NEEDQ
case upcase(EC2) = "T"
if upcase(EC3[1,3]) = "YPE" then EC3 = EC3[4,len(EC3)-3]
NEWTYPE = upcase(trim(EC3))
TYPE2 = ""
TYPEFLAG = 0
begin case
case NEWTYPE = ""
EDERR = 13 ; return
case NEWTYPE = "DOUBLE PRECISION" or NEWTYPE = "REAL"
case NEWTYPE = "SMALLINT" or NEWTYPE = "INT" or NEWTYPE = "INTEGER"
case NEWTYPE = "DEC" or NEWTYPE = "DECIMAL" or NEWTYPE = "FLOAT"
case NEWTYPE = "NUMERIC" or NEWTYPE = "DATE" or NEWTYPE = "TIME"
case NEWTYPE = "CHAR" or NEWTYPE = "CHARACTER" or NEWTYPE = "VARCHAR"
case NEWTYPE[1,12] = "CHAR VARYING"
EDERR = 20 ; return
case NEWTYPE[1,17] = "CHARACTER VARYING"
EDERR = 20 ; return
case NEWTYPE[1,5] = "FLOAT"
TYPE2 = change(NEWTYPE[6,len(NEWTYPE)-5]," ","")
NEWTYPE = "FLOAT"
case NEWTYPE[1,7] = "VARCHAR"
TYPE2 = change(NEWTYPE[8,len(NEWTYPE)-7]," ","")
NEWTYPE = "VARCHAR"
case NEWTYPE[1,9] = "CHARACTER"
TYPE2 = change(NEWTYPE[10,len(NEWTYPE)-9]," ","")
NEWTYPE = "CHARACTER"
case NEWTYPE[1,4] = "CHAR"
TYPE2 = change(NEWTYPE[5,len(NEWTYPE)-4]," ","")
NEWTYPE = "CHAR"
case NEWTYPE[1,7] = "NUMERIC"
TYPE2 = change(NEWTYPE[8,len(NEWTYPE)-7]," ","")
NEWTYPE = "NUMERIC"
TYPEFLAG = 1
case NEWTYPE[1,7] = "DECIMAL"
TYPE2 = change(NEWTYPE[8,len(NEWTYPE)-7]," ","")
NEWTYPE = "DECIMAL"
TYPEFLAG = 1
case NEWTYPE[1,3] = "DEC"
TYPE2 = change(NEWTYPE[4,len(NEWTYPE)-3]," ","")
NEWTYPE = "DEC"
TYPEFLAG = 1
case 1
EDERR = 18 ; return
end case
if TYPE2 # "" then
if TYPE2[1,1] # "(" or TYPE2[1] # ")" then EDERR = 18 ; return
begin case
case count(TYPE2,",") > 1
EDERR = 18 ; return
case count(TYPE2,",") = 1 ; * DEC or NUMERIC with precision & scale
if TYPEFLAG = 0 then EDERR = 18 ; return
SBNUM = field(TYPE2,",",1)[2,99]
gosub TESTNUM
if NOTNUM then EDERR = 18 ; return
if SBNUM < 1 then EDERR = 18 ; return
PRECNUM = SBNUM
SBNUM = field(TYPE2,",",2)
SBNUM = SBNUM[1,len(SBNUM)-1]
gosub TESTNUM
if NOTNUM then EDERR = 18 ; return
if SBNUM > 9 or SBNUM > PRECNUM then EDERR = 18 ; return
NEWTYPE = NEWTYPE:TYPE2
case 1 ; * DEC, NUMERIC, FLOAT with prec; CHAR, VARCHAR with size
SBNUM = TYPE2[2,len(TYPE2)-2]
gosub TESTNUM
if NOTNUM then EDERR = 18 ; return
if SBNUM < 1 then EDERR = 18 ; return
if NEWTYPE[1,1] = "C" and SBNUM > 254 then EDERR = 18 ; return
if NEWTYPE[1,1] = "V" and SBNUM > 65535 then EDERR = 18 ; return
NEWTYPE = NEWTYPE:TYPE2
end case
end
if field(DEF," ",3) = "PRECISION" then
DEF = fieldstore(DEF," ",2,-2,NEWTYPE)
end else
DEF = fieldstore(DEF," ",2,-1,NEWTYPE)
end
CDEF<2> = DEF
write CDEF to NVAR,CREC else goto WRERR
gosub NEWDSTAMP
NEEDQ = DEF ; gosub QFIRST
if EK then print " K":I2:" ":NEEDQ else print " ":I2:" ":NEEDQ
case upcase(EC2) = "V" ; * Future possibility to change SM (valuedness)
EDERR = 10
case upcase(EC2) = "F" ; * Future possibility to change FMT
EDERR = 10
case upcase(EC2) = "H" ; * Future possibility to change COL.HDG
EDERR = 10
case upcase(EC2) = "C" ; * Future possibility to change CONV
EDERR = 10
case 1
EDERR = 5
end case
return ; *from CHANGECA after changing a column definition
TESTNUM:
NOTNUM = 0
WKNUM = SBNUM
if WKNUM = "" then NOTNUM = 1 ; return
loop
until WKNUM = "" or NOTNUM
if not(num(WKNUM[1,1])) then NOTNUM = 1
WKNUM = WKNUM[2,99]
repeat
return ; *from TESTNUM
CHANGEA:
* Change association
EDCOM = EDCOM[2,len(EDCOM)-1]
gosub GETNUM
if NUMERR then EDERR = 12 ; return
if EC2[1,1] = " " then EC2 = EC2[2,len(EC2)-1]
if len(EC2) < 2 then EDERR = 1 ; return
EC3 = EC2[2,len(EC2)-1]
EC2 = EC2[1,1]
begin case
case EC2 = "/" or EC2 = "\"
if I2 > ASSOCLAST then EDERR = 8 ; return
if I2 < 1 then EDERR = 12 ; return
AREC = "SQL_A":I2
read ADEF from NVAR,AREC else EDERR = 19 ; return
if upcase(ADEF<3>) = "D" then EDERR = 14 ; return
DEF = ADEF<2>
if upcase(field(EC3,EC2,3)[1,1]) = "G" and field(EC3,EC2,1) # ""
then NUMREP = -1
else NUMREP = 1
DEF = ereplace(DEF,field(EC3,EC2,1),field(EC3,EC2,2),NUMREP)
ADEF<2> = DEF
write ADEF to NVAR,AREC else goto WRERR
gosub NEWDSTAMP
NEEDQ = DEF ; gosub QFIRST
print " ":I2:" ":NEEDQ
case upcase(EC2) = "N"
EDERR = 10
case upcase(EC2) = "K"
EDERR = 10
case 1
EDERR = 5
end case
return ; *from CHANGECA after changing an assoc definition
* Delete a column or association definition
DELETECA:
EDERR = 0
EDCOM = EDCOM[2,len(EDCOM)-1]
if upcase(EDCOM[1,1]) = "A" then goto DELETEA
* Delete column -- mark it "deleted" in field 3
******* The following line of code was added 5/22/97 ************************
EDERR = 5 ; return
******* The following code is no longer used (as of 5/22/97) but ************
******* I am reluctant to delete it just yet ******************************
if upcase(EDCOM[1,1]) = "C" then EDCOM = EDCOM[2,len(EDCOM)-1]
gosub GETNUM
if NUMERR then EDERR = 2 ; return
if EC2[1,1] = " " then EC2 = EC2[2,len(EC2)-1]
if len(EC2) <> 1 then EDERR = 1 ; return
if I2 > COLLAST then EDERR = 7 ; return
if not(alpha(EC2)) then EDERR = 3 ; return
SELAC = 'SELECT ':DEFNM:' WITH @ID LIKE "SQL_C':I2
SELAC := "'":EC2:"'..."
SELAC := '"'
execute SELAC capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
readnext SQLID else EDERR = 6 ; return
read CDEF from NVAR,SQLID else EDERR = 9 ; return
if upcase(CDEF<3>) = "D" then EDERR = 4 ; return
CDEF<3> = "D"
write CDEF to NVAR,SQLID else goto WRERR
gosub NEWDSTAMP
print " Column-synonym deleted"
return ; *from DELETECA after deleting a column
******* The above code is no longer used (as of 5/22/97) but ****************
******* I am reluctant to delete it just yet ******************************
* Delete an association entirely -- mark it deleted in field 3
DELETEA:
EDCOM = EDCOM[2,len(EDCOM)-1]
gosub GETNUM
if NUMERR then EDERR = 12 ; return
if len(EC2) <> 0 then EDERR = 1 ; return
if I2 > ASSOCLAST then EDERR = 8 ; return
if I2 < 1 then EDERR = 12 ; return
AREC = "SQL_A":I2
read ADEF from NVAR,AREC else EDERR = 19 ; return
if upcase(ADEF<3>) = "D" then EDERR = 14 ; return
ADEF<3> = "D"
write ADEF to NVAR,AREC else goto WRERR
gosub NEWDSTAMP
print " Association deleted"
return ; *from DELETECA after deleting an association
* Use another column or association definition
USECA:
EDERR = 0
EDCOM = EDCOM[2,len(EDCOM)-1]
if upcase(EDCOM[1,1]) = "A" then goto USEA
* Use other definition for the "chosen" column
EK = 0 ; * this is set in case we call subroutine REWRITESEL
if upcase(EDCOM[1,1]) = "C" then EDCOM = EDCOM[2,len(EDCOM)-1]
gosub GETNUM
if NUMERR then EDERR = 2 ; return
if EC2[1,1] = " " then EC2 = EC2[2,len(EC2)-1]
if len(EC2) <> 1 then EDERR = 1 ; return
if I2 > COLLAST then EDERR = 7 ; return
if not(alpha(EC2)) then EDERR = 3 ; return
SELAC = 'SELECT ':DEFNM:' WITH @ID LIKE "SQL_C':I2
SELAC := "'":EC2:"'..."
SELAC := '"'
execute SELAC capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
readnext SQLID else EDERR = 6 ; return
read CDEF from NVAR,SQLID else EDERR = 9 ; return
if upcase(CDEF<3>) = "D" then EDERR = 4 ; return
read TVAR from NVAR,"SQL_C":I2 else EDERR = 9 ; return
OLDNAME = field(TVAR<2>," ",1)
NEWNAME = field(CDEF<2>," ",1)
gosub REWRITESEL
write CDEF to NVAR,"SQL_C":I2 else goto WRERR
gosub NEWDSTAMP
NEEDQ = CDEF<2> ; gosub QFIRST
print " ":I2:" ":NEEDQ
return ; *from USECA after setting column definition to Use another def
USEA:
* Use other definition for the "chosen" association
EDCOM = EDCOM[2,len(EDCOM)-1]
gosub GETNUM
if NUMERR then EDERR = 12 ; return
if EC2[1,1] = " " then EC2 = EC2[2,len(EC2)-1]
if len(EC2) <> 1 then EDERR = 1 ; return
if I2 > ASSOCLAST then EDERR = 7 ; return
if I2 < 1 then EDERR = 12 ; return
if not(alpha(EC2)) then EDERR = 3 ; return
SELAC = 'SELECT ':DEFNM:' WITH @ID LIKE "SQL_A':I2
SELAC := "'":EC2:"'..."
SELAC := '"'
execute SELAC capturing TVAR
if DEBUG then print change(TVAR,char(254),char(10),0,1)
readnext SQLID else EDERR = 16 ; return
read ADEF from NVAR,SQLID else EDERR = 19 ; return
if upcase(ADEF<3>) = "D" then EDERR = 14 ; return
if upcase(ADEF<3>) = "O" then EDERR = 14 ; return
write ADEF to NVAR,"SQL_A":I2 else goto WRERR
gosub NEWDSTAMP
NEEDQ = ADEF<2> ; gosub QFIRST
print " ":I2:" ":NEEDQ
return ; *from USECA after setting assoc definition to Use another def
* Redisplay one column or association definition
DISPCA:
EDERR = 0
EDCOM = EDCOM[2,len(EDCOM)-1]
if upcase(EDCOM[1,1]) = "A" then goto DISPA
* Redisplay column or key-part def
if upcase(EDCOM[1,1]) = "K" then
EK = 1
EDCOM = EDCOM[2,len(EDCOM)-1]
end else
EK = 0
if upcase(EDCOM[1,1]) = "C" then EDCOM = EDCOM[2,len(EDCOM)-1]
end
gosub GETNUM
if NUMERR and EK then EDERR = 11 ; return
if NUMERR then EDERR = 2 ; return
if len(EC2) <> 0 then EDERR = 1 ; return
if EK then
if I2 > KEYLAST then EDERR = 17 ; return
if I2 < 1 then EDERR = 11 ; return
print "Column K":I2:":"
read DEF1 from NVAR, "SQL_K":I2 else EDERR = 9 ; return
NEEDQ = DEF1<2> ; gosub QFIRST
print " K":I2:" ":NEEDQ
goto DISPENDC
end
if I2 > COLLAST then EDERR = 7 ; return
if I2 < 1 and KEYLAST > 1 then EDERR = 15 ; return
print "Column ":I2:":"
read DEF1 from NVAR, "SQL_C":I2 else EDERR = 9 ; return
NEEDQ = DEF1<2> ; gosub QFIRST
print " ":I2:" ":NEEDQ
AC = "C" ; gosub BUILDSELAC
DISPRNC:
readnext SQLID else goto DISPENDC
read DEF2 from NVAR, SQLID else EDERR = 9 ; return
if upcase(DEF2<3>) = "D" then goto DISPRNC
ALPHID = SQLID[8,1]
if num(ALPHID) then ALPHID = SQLID[9,1]
if field(trim(DEF2<2>)," ",1,1) <> field(trim(DEF1<2>)," ",1,1) then
NEEDQ = DEF2<2> ; gosub QFIRST
print " ":I2:ALPHID:" ":NEEDQ
end
goto DISPRNC
DISPENDC:
return ; *from DISPCA after Redisplaying a column
* Redisplay assoc def
DISPA:
EDCOM = EDCOM[2,len(EDCOM)-1]
gosub GETNUM
if NUMERR then EDERR = 12 ; return
if len(EC2) <> 0 then EDERR = 1 ; return
if I2 > ASSOCLAST then EDERR = 8 ; return
if I2 < 1 then EDERR = 12 ; return
read DEF1 from NVAR,"SQL_A":I2 else EDERR = 19
if upcase(DEF1<3>) = "D" then EDERR = 14 ; return
if upcase(DEF1<3>) = "O" then EDERR = 14 ; return
print "Association ":I2:":"
NEEDQ = DEF1<2> ; gosub QFIRST
print " ":I2:" ":NEEDQ
AC = "A" ; gosub BUILDSELAC
DISPRNA:
readnext SQLID else goto DISPENDA
read DEF2 from NVAR,SQLID else EDERR = 19 ; return
if upcase(DEF2<3>) = "O" then OLAP = 1 else OLAP = 0
ALPHID = SQLID[8,1]
if (DEF2<2> <> DEF1<2>) then
NEEDQ = DEF2<2> ; gosub QFIRST
print " ":I2:ALPHID:" ":NEEDQ:
if OLAP then print space(6):"Overlapping association not used" else
print space(6):"PHrase differs from ASSOC"
end
end
goto DISPRNA
DISPENDA:
return ; *from DISPCA after Redisplaying an association
* Rewrite the @SELECT phrase (SQL_SELECT record in SQLDEF file) if it exists,
* replacing (every occurence of) a specified old column name by a specified
* new column name if the new name is different. This subroutine is called from
* the following editing operations: Use-column-synonym, Change-column-def, and
* Change-column-name.
* Inputs: OLDNAME is previous name of the column being changed
* NEWNAME is the new name of the column being changed
* EK = 1 if the column is a Key-part, EK = 0 otherwise
* Outputs: The effect of this subroutine is to rewrite the SQL_SELECT record
* (if there is one) in the SQLDEF file. Also, variables USESELECT
* and NEEDATKEY are changed if appropriate, and if so the SQL_INFO
* record is rewritten with updated values for USESELECT and NEEDATKEY.
* Also, OLDNAME and NEWNAME may be modified: this subroutine unquotes
* OLDNAME and NEWNAME if they are delimited, since the @SELECT phrase
* must not contain delimited identifiers.
REWRITESEL:
if OLDNAME[1,1] = '"' and OLDNAME[1] = '"' and len(OLDNAME) > 2 then
OLDNAME = OLDNAME[2,len(OLDNAME)-2]
OLDNAME = change(OLDNAME,'""','"')
end
if NEWNAME[1,1] = '"' and NEWNAME[1] = '"' and len(NEWNAME) > 2 then
NEWNAME = NEWNAME[2,len(NEWNAME)-2]
NEWNAME = change(NEWNAME,'""','"')
end
if NEWNAME = OLDNAME then return ; *from REWRITESEL if name didn't change
read SELREC from NVAR,"SQL_SELECT" then
if upcase(SELREC<1>[1,1]) # "X" then return
TVAR = ""
SELREC = trim(SELREC)
loop
while SELREC # "" do
TOKTEMP = field(SELREC," ",1)
SELREC = field(SELREC," ",2,999)
if TOKTEMP = OLDNAME then
TVAR := " ":NEWNAME
end else
TVAR := " ":TOKTEMP
end
repeat
write trim(TVAR) to NVAR,"SQL_SELECT" else goto WRERR
* Rewrite SQL_INFO record if necessary to force new SQL_SELECT to be used
* and/or, if the name being changed is a Key-part name, to force @KEY
* to be re-generated in the dictionary by CREATE EXISTING TABLE; this
* is accomplished by setting USESELECT = "1" and/or NEEDATKEY = "1",
* respectively.
if USESELECT = "0" or (EK and NEEDATKEY = "0") then
read INFREC from NVAR,"SQL_INFO" then
if upcase(INFREC<1>[1,1]) # "X" then return
USESELECT = "1"; INFREC<10> = USESELECT
if EK then NEEDATKEY = "1" ; INFREC<11> = NEEDATKEY
write INFREC to NVAR,"SQL_INFO" else goto WRERR
end
end
end
return ; *from REWRITESEL after rewriting SQL_SELECT (and perhaps SQL_INFO)
***** GETNUM Subroutine to find column, key-part, or association number in
* an Editing command (C, D, U, or R)
* Input: EDCOM contains string of which the first part should be a number
* Outputs: NUMERR = 0 if a valid non-negative integer was found; in this case,
* I2 will contain the actual integer as 2 or more digits in
* the form required for reading from SQLDEF (eg, 00, 01,
* ... 09, 10, ..., 99, 100, ...). Also,
* EC2 will contain the remainder of the original string after
* the numeric part was removed (EC2 may contain empty)
* NUMERR = 1 if no number was found at beginning of string
* NUMERR = 2 if a number was found but it's invalid (eg negative,
* fractional, or exponential)
GETNUM:
NUMERR = 0
EC2 = ""
I2 = EDCOM
loop
until num(I2) do
EC2 = I2[1]:EC2
I2 = I2[1,len(I2)-1]
repeat
if I2 = "" then NUMERR = 1 ; return
I2 = trim(I2," ","T")
if int(I2) <> I2 or I2 < 0 then NUMERR = 2 ; return
if count(I2,".") > 0 then NUMERR = 2 ; return
if count(I2,"+") > 0 then NUMERR = 2 ; return
if count(I2,"-") > 0 then NUMERR = 2 ; return
if count(I2,"E") > 0 then NUMERR = 2 ; return
if count(I2,"e") > 0 then NUMERR = 2 ; return
if I2 = 0 then I2 = "00" ; return
I2 = trim(I2,"0","L")
if I2 <= 9 then I2 = "0":I2
return ; *from GETNUM
* Subroutine to check validity of entire set of col and assoc definitions
MAKEVFLAG:
return ; **??temporary until this routine is implemented
* Open the SQLDEF file to NVAR, and its dict to DNVAR, then filelock both
OPENDEF:
open DEFNM to NVAR else
OPSTAT = status()
print "Can't open '":DEFNM:"'. ":
gosub POPERR
if ARGA[1,7] # "RESTORE" then
fileunlock DVAR
close DVAR
end
OPENERR = 1
return
end
filelock NVAR locked
print "Can't filelock ":DEFNM
if ARGA[1,7] # "RESTORE" then
fileunlock DVAR
close DVAR
end
close NVAR
OPENERR = 1
return
end
open "DICT",DEFNM to DNVAR else
OPSTAT = status()
print "Can't open 'DICT ":DEFNM:"'. ":
gosub POPERR
if ARGA[1,7] # "RESTORE" then
fileunlock DVAR
close DVAR
end
fileunlock NVAR
close NVAR
OPENERR = 1
return
end
filelock DNVAR locked
print "Can't filelock DICT ":DEFNM
if ARGA[1,7] # "RESTORE" then
fileunlock DVAR
close DVAR
end
fileunlock NVAR
close NVAR
close DNVAR
OPENERR = 1
return
end
OPENERR = 0
return ; *from OPENDEF
* Open the SQLSAVE file to VVAR, and its dict to DVVAR, then filelock both
OPENSAVE:
open SAVNM to VVAR else
OPSTAT = status()
print "Can't open '":SAVNM:"'. ":
gosub POPERR
OPENERR = 1
return
end
filelock VVAR locked
print "Can't filelock ":SAVNM
close VVAR
OPENERR = 1
return
end
open "DICT",SAVNM to DVVAR else
OPSTAT = status()
print "Can't open 'DICT ":SAVNM:"'. ":
gosub POPERR
fileunlock VVAR
close VVAR
OPENERR = 1
return
end
filelock DVVAR locked
print "Can't filelock DICT ":SAVNM
fileunlock VVAR
close VVAR
close DVVAR
OPENERR = 1
return
end
OPENERR = 0
return ; *from OPENSAVE
* Print message for error occurring during interactive editing
* input = EDERR, which contains error code
PEDERR:
print " Operation not done. ":
begin case
case EDERR = 1
print "Command is wrong length"
case EDERR = 2
print "Invalid or missing column number"
case EDERR = 3
print "Synonym-identifier must be alphabetic"
case EDERR = 4
print "Specified synonym has been deleted"
case EDERR = 5
print "Illegal command"
case EDERR = 6
print "Specified synonym doesn't exist"
case EDERR = 7
print "Specified column number too large"
case EDERR = 8
print "Specified association number too large"
case EDERR = 9
print "Column definition not found"
case EDERR = 10
print "Command not yet implemented"
case EDERR = 11
print "Invalid or missing key-part number"
case EDERR = 12
print "Invalid or missing association number"
case EDERR = 13
print "No datatype specified"
case EDERR = 14
print "Specified association has been deleted or is overlapping"
case EDERR = 15
print "Column 0 is invalid; specify a Key-part"
case EDERR = 16
print "Specified association doesn't exist"
case EDERR = 17
print "Specified key-part number too large"
case EDERR = 18
print "Invalid datatype"
case EDERR = 19
print "Association definition not found"
case EDERR = 20
print "Use VARCHAR, not CHAR VARYING"
case 1
print "Error code ":EDERR
end case
return ; *from PEDERR
* Print error message when unable to open file (partial msg is already printed)
* input = OPSTAT, which contains status()
POPERR:
begin case
case OPSTAT = -1
print "Filename not in VOC"
case OPSTAT = -2
print "Non-existent or inaccessible file"
case OPSTAT = -3
print "No UNIX permission"
case OPSTAT = -4
print "No UNIX permission or invalid file"
case OPSTAT = -5
print "UNIX read error"
case OPSTAT = -6
print "Can't lock file header"
case OPSTAT = -7
print "Bad file rev or byte-swap"
case OPSTAT = -8
print "Invalid part-file info"
case OPSTAT = -9
print "Invalid type 30 info"
case OPSTAT = -10
print "File marked inconsistent"
case OPSTAT = -11
print "SQL view"
case OPSTAT = -12
print "No SQL permission"
case OPSTAT = -13
print "Problem with index"
case OPSTAT = -14
print "Can't open NFS file"
case OPSTAT = -987
print "Bad Q-pointer"
case 1
print "Status = ":OPSTAT
end case
return ; *from POPERR
* Unlock and Close all files
UCAF:
fileunlock DVAR
close DVAR
fileunlock DNVAR
close DNVAR
fileunlock NVAR
close NVAR
return ; *from UCAF
DELERR:
stop "Can't delete record"
*??
WRERR:
stop "Can't write record"
* ??
RDERR:
stop "Can't read record"
* ??
* Allegedly, this BADERR error exit should never be invoked
BADERR:
stop "BADERR: code = ":BERX
* ??
SELERR:
stop "SELERR"
* ??
Getschinfo:
* This subroutine determines whether the current account is a schema, and
* if so it returns the schema name. This routine doesn't use @SCHEMA
* because, unfortunately, @SCHEMA doesn't get updated until a user logs
* out of uniVerse and back in again, so @SCHEMA isn't always reliable.
* inputs are PATH is the full pathname of the account
* outputs are SCH = schema name if this is a schema, else empty string
*
* Open UV_SCHEMA
hush on setting OLDHUSH
open "UV_SCHEMA" to FVAR else
hush OLDHUSH
OPSTAT = status()
print "Can't open UV_SCHEMA. ":
gosub POPERR
stop
end
hush OLDHUSH
* Lock UV_SCHEMA
LSLEEP = MAXSLEEP
Getsin1:
if LSLEEP <=0 then
close FVAR
stop "Can't lock UV_SCHEMA."
end
filelock FVAR locked
LSLEEP -= 1
sleep 2
goto Getsin1
end
* Search UV_SCHEMA for path of this account
select FVAR
SCH = ""
FOUND = 0
NOMORE = 0
loop
until (FOUND or NOMORE) do
readnext SCH then
read SCHREC from FVAR,SCH then
if IS.EQPATHS(trim(SCHREC<2>), PATH) then FOUND = 1
end else
fileunlock FVAR
close FVAR
stop "Can't read UV_SCHEMA."
end
end else NOMORE = 1
repeat
fileunlock FVAR
close FVAR
return ; * return from Getschinfo
NORETURN:
stop "Invalid system return code from sdml"
end
Reference in New Issue View Git Blame Copy Permalink