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

1520 lines
46 KiB
Plaintext
Executable File
Raw Blame History

*******************************************************************************
*
* Description: Initialize a secondary key file
*
* 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.
*
*******************************************************************************
*
* Maintenence log - insert most recent change descriptions at top
*
* Date.... GTAR# WHO Description.........................................
* 04/30/99 24742 GMH Create index file type same as data file
* 04/23/99 24742 GMH Add support for new headers
* 10/14/98 23801 SAP Change copyrights.
* 09/26/97 14997 KAM Remove 'Var prev undefined' warning from 87902
* 07/18/97 17516 DJL Index name wrong for long file name
* 07/18/97 17383 DJL add check to make sure MV field of I or D is M or S
* 06/23/97 20380 DTM Added support for default COLLATE value, if not spec.
* 06/20/97 19819 KAM Add support for UNIX filenames with special chars
* 05/20/97 20380 DTM Added code for COLLATE keyword
* 01/23/97 19949 PEJ Fix binary value conversion when NLS is on
* 09/04/96 18639 DJL CREATE.INDEX doesnt use secondary group privileges.
* 06/27/96 18571 HSB Support single and double quotes in SQL index identifiers
* 05/30/96 18438 JC Additional porting to NT.
* 04/08/96 18360 HSB Write SQL index info in proper hardware byte order.
* 04/03/96 18235 WSM Redo fix to keep rm errors out of COMO files
* 02/22/96 17804 GMM Replace 'SH -c' with OS.EXEC and handle remote paths
* 01/10/96 17832 HSB Add code to write SQL index map to type-25 file header
* 11/08/95 16356 WSM Keep rm errors out of COMO files
* 06/06/95 16638 EAP Change to use BYTE,BYTEVAL,BYTELEN for NLSsupport
* 05/05/95 15741 EAP undid last change NLS binary mapping now in WRITEBLK
* 03/30/95 15741 EAP Use BYTE() instead of CHAR() to encode lengths
* 03/28/95 15741 EAP Added -M NONE to set NLS map for mkdbfile
* 02/23/95 16030 SHK Only check for "V" in first position of SH verb
* 11/14/94 13388 DPB Abort if the SH verb is not in the VOC file.
* 11/14/94 14082 DPB Allow different A correlative on the same field.
* 11/02/94 15025 DPB Fix printing of error message for type 1 & 25 files.
* 10/21/94 15136 GMH Correct writes/deletes for ISOMODE level 2
* 08/01/94 14545 EAP Don't allow CREATE.INDEX on files which are being logged
* 07/20/94 14296 WLG Carry over NO.NULLS for distributed files.
* 06/27/94 14313 GMH Correct spelling of call
* 02/24/94 12743 GMH Correct calls for remote machines, enhance msg handling
* 11/23/93 12614 GMH Correct DIRECTORY argument
* 11/23/93 12614 GMH Correct argument to REMOTE.B
* 10/28/93 12435 GMH Correct parsing
* 10/15/93 12393 GMH Correct message
* 09/30/93 12344 JSM Fix UNIXlnode for machine type
* 09/23/93 12326 GMH Allow super-user to override permission check
* 09/23/93 12323 GMH Correct I-type compilation
* 09/22/93 12324 JWT Fix incorrect write of datalen
* 09/22/93 12201 GMH Fix longnames
* 09/08/93 12201 GMH Remove pathname type30 fix, compile DF i-types
* 09/07/93 12201 GMH Set @SYSTEM.RETURN.CODE on exit
* 09/07/93 12201 GMH Fix path name for type30 data files in DF
* 09/03/93 12201 JWT Fix path name for type 30 data file open
* 09/03/93 12201 GMH Enable creation on DICT & PDICT files
* 09/01/93 12138 GMH Fix code problems
* 08/31/93 12138 GMH Implement in BASIC
*
*******************************************************************************
$OPTIONS DEFAULT
ID = "%W%"
!
* Declare functions
!
DECLARE GCI NLSsetseqmap
DECLARE GCI BYTEreplace
DEFFUN UVREADMSG(num,args) CALLING '*UVREADMSG'
!
* Declare keyword values
!
INCLUDE UNIVERSE.INCLUDE FILENAMES.H
INCLUDE UNIVERSE.INCLUDE KEYWORD.H
INCLUDE UNIVERSE.INCLUDE MACHINE.NAME
INCLUDE UNIVERSE.INCLUDE FILEINFO.H
INCLUDE UNIVERSE.INCLUDE TLOG.H
INCLUDE UNIVERSE.INCLUDE OSDEF.H
INCLUDE UNIVERSE.INCLUDE UVNLSLOC.H
!
* Define multipliers
!
DIM POWER(5)
POWER(1) = 1
POWER(2) = 256
POWER(3) = 65536
POWER(4) = 16777216
!
* Define UNIX equates
!
EQU UNIXlnode TO BYTE(0):BYTE(2)
!
* Define XINU equates
!
EQU XINUlnode TO 512
!
* Declare general equates
!
EQU T25LEAFoffset TO 8192 ;* Offset to first leaf node
EQU FALSE TO 0
EQU TRUE TO 1
EQU VOC.ENTRY TO 1
EQU UNIX.PATH TO 2
EQU MAXindices TO 999 ;* Maximum number of indices
EQU WANT.DICT TO 100
EQU WANT.PDICT TO 200
!
* Declare variables
!
PERMISSIONS = '-PERMISSIONS';* Subroutine for determining file permissions
Index.info = "" ;* Secondary Index information
Index.file = "" ;* Secondary Index file descriptor
DKEY = 0 ;* DICT on command line
FILE = '' ;* Name of FILE
UDICT = '' ;* Dict file descriptor
UDATA = '' ;* Data file descriptor
ODICT = '' ;* Dict file desc for USING clause
IDX.TO.ADD = '' ;* List of indices to add
USING.CLAUSE = FALSE ;* USING clause
USING.NAME = '' ;* File for USING clause
USING.DICT = 0 ;* DICT was found after USING clause
AT.CLAUSE = FALSE ;* AT clause
AT.PATH = '' ;* Path for AT clause
NULLS.ALLOWED = TRUE ;* Allow Empty Strings as default
UNIQUE.INDEX = FALSE ;* Unique
NUMERIC.INDEX = FALSE ;* Numeric
SQLITYP.INDEX = FALSE ;* SQL I-type
AKdirPATH = '' ;* Path of AK
LONGNAMES.ON = FALSE ;* From FIELD 5 of CREATE.FILE
IDXcnt = 0 ;* Number of active indices
process.status= 0 ;* return value for @system.return.code
SYSTEM.name = '' ;* name of remote system
COLLATE.NAME = '' ;* Collation sequence not defined
IF SYSTEM( 100 ) AND SYSTEM( 101 ) THEN
* Get current locale information
COLLATE.NAME = GETLOCALE( UVLC$COLLATE )
END
!
* Set up command and data matrix
!
DIM COMMAND(125) ;* Command line arguments
DIM DICT.TEXT(1000) ;* Contents of DICT items to add
DIM INDEX.MAP(1000) ;* Contents of INDEX.MAP file
MAT INDEX.MAP = "" ;* Initialization
DIM DATA.MAP(1000) ;* Contents of Data from INDEX.MAP file
MAT DATA.MAP = "" ;* Initialization
!
* Define equates for INDEX.MAP array
!
EQU IDXname LIT 'INDEX.MAP(1)'
EQU IDXkeylen LIT 'INDEX.MAP(2)'
EQU IDXkeytext LIT 'INDEX.MAP(3)'
EQU IDXtype LIT 'INDEX.MAP(4)'
EQU IDXmulti LIT 'INDEX.MAP(5)'
EQU IDXbuilt LIT 'INDEX.MAP(6)'
EQU IDXnulls LIT 'INDEX.MAP(7)'
EQU IDXenabled LIT 'INDEX.MAP(8)'
EQU IDXdatalen LIT 'INDEX.MAP(9)'
EQU IDXdatatext LIT 'INDEX.MAP(10)'
!
* Disable auto pagination
!
ASSIGN 0 TO SYSTEM(1005)
!
* Open VOC file
!
OPEN 'VOC' TO VOC.FILE ELSE
** "Unable to open VOC file."
err.number = 1720
err.args = ""
process.status = -1
GOTO EXIT.OUT:
END
!
* Open UV.ACCOUNT file
!
OPENPATH UV.ROOT:'/UV.ACCOUNT' TO UVACCT.FILE ELSE
** "Unable to open UVACCT file."
err.number = 85303
err.args = "UV.ACCOUNT"
process.status = -1
GOTO EXIT.OUT:
END
!
* Read for LONGNAMES
!
READV TEMP FROM VOC.FILE,"CREATE.FILE",5 ELSE TEMP = ""
IF TEMP = "LONGNAMES" THEN
LONGNAMES.ON = TRUE
END
!
* Check for SH verb in VOC file.
!
READV TEMP FROM VOC.FILE,"SH",1 ELSE TEMP = ""
IF TEMP[1,1] <> "V" THEN
err.number = 35065
err.args = ""
process.status = -1
GOTO EXIT.OUT:
END
!
* Parse out COMMAND line
!
WORK = TRIM(@SENTENCE)
MATPARSE COMMAND FROM WORK , ' '
TOKENS = INMAT()
!
* Look at all TOKENS on the command line
!
FOR I = 2 TO TOKENS
* See if word is in VOC
READ VDESC FROM VOC.FILE, COMMAND(I) ELSE
* Check for multi-level data file
IF INDEX(COMMAND(I),",",1) THEN
MAINFILE = FIELD(COMMAND(I),",",1)
READ VDESC FROM VOC.FILE,MAINFILE ELSE
err.number = 85300
err.args = COMMAND(I)
process.status = -1
GOTO EXIT.OUT:
END
END ELSE
* Add as possible index
VDESC=""
END
END
!
* Examine for Keywords
!
BEGIN CASE
CASE VDESC[1,1] = 'K'
BEGIN CASE
* See if COLLATE is on command line
CASE VDESC<2> = KW$COLLATE
IF SYSTEM( 100 ) AND SYSTEM ( 101 ) THEN
* NLS/NLSlocales loaded, get names...
I += 1
IF COMMAND(I) = "OFF" THEN
COLLATE.NAME = "NONE"
END
ELSE
COLLATE.NAME = COMMAND(I)
END
END
ELSE
* Can't specify collation name unless NLS loaded up
process.status = -1
err.number = 32114
err.args = ""
GOTO EXIT.OUT
END
* See if DICT is on command line
CASE VDESC<2> = KW$DICT AND FILE = ''
DKEY = WANT.DICT
* See if PDICT is on command line
CASE VDESC<2> = KW$PDICT AND FILE = ''
DKEY = WANT.PDICT
* If DICT is used in USING clause
CASE VDESC<2> = KW$DICT AND USING.CLAUSE = TRUE
USING.DICT = WANT.DICT
* If PDICT is used in USING clause
CASE VDESC<2> = KW$PDICT AND USING.CLAUSE = TRUE
USING.DICT = WANT.PDICT
* See if NO.NULLS is on command line
CASE VDESC<2> = KW$NO.NULLS
NULLS.ALLOWED = FALSE
* See if BRIEF is on command line
CASE VDESC<2> = KW$BRIEF
HUSH ON
* See if USING is on command line
CASE VDESC<2> = KW$USING
USING.CLAUSE = TRUE
* See if SYSTEM is on command line
CASE VDESC<2> = KW$SYSTEM
I += 1
SYSTEM.name = COMMAND(I)
* See if AT is on command line
CASE VDESC<2> = KW$PRINTER
I += 1
* Check if path is given
IF COMMAND(I)[1,1] = "/" OR COMMAND(I)[1,1] = "\" THEN
AT.PATH = COMMAND(I)
* Verify that path exists
CHECK.PATH:
OPENPATH AT.PATH TO TMPfile ELSE
* Path %n cannot be opened for reading. Verify exists
err.number = 32100
err.args = AT.PATH
process.status = -1
GOTO EXIT.OUT:
END
* Must be Type1 or Type19
STATUS TMPstatus FROM TMPfile else TMPstatus = ""
IF TMPstatus<21> # 1 AND TMPstatus<21> # 19 THEN
* Location where indices are to reside not a UNIX directory!
err.number = 32101
err.args = ""
process.status = -1
GOTO EXIT.OUT:
END
CLOSE TMPfile
END ELSE
* Read from UV.ACCOUNT file
READV AT.PATH FROM UVACCT.FILE, COMMAND(I), 11 ELSE
* Unable to read item "%s".
err.number = 1205
err.args = COMMAND(I)
process.status = -1
GOTO EXIT.OUT:
END
GOTO CHECK.PATH:
END
AT.CLAUSE = TRUE
* See if UNIQUE is on command line
CASE VDESC<2> = KW$UNIQUE
UNIQUE.INDEX = TRUE
* See if NUMERIC is on command line
CASE VDESC<2> = KW$NUMERIC
NUMERIC.INDEX = TRUE
CASE VDESC<2> = KW$SQLITYP
SQLITYP.INDEX = TRUE
* Encountered unknown
CASE 1
GOTO ADD.IDX:
END CASE
!
* Check for FILE
!
CASE upcase(VDESC[1,1])='F' OR upcase(VDESC[1,1])='Q'
* Exit if more than 1 file name on command line and no USING clause
IF FILE # '' AND USING.CLAUSE = TRUE AND USING.NAME # '' THEN
** "Unexpected file name "%s" in command line."
err.number = 85302
err.args = COMMAND(I)
process.status = -1
GOTO EXIT.OUT:
END ELSE
* Assign file
IF FILE = "" THEN
FILE = COMMAND(I)
END ELSE
IF USING.CLAUSE = TRUE THEN
USING.NAME = COMMAND(I)
USING.CLAUSE = VOC.ENTRY
END ELSE
GOTO ADD.IDX
END
END
END
!
* Stack as possible entry
!
CASE 1
* Check for possible path for USING clause
IF USING.CLAUSE = TRUE AND USING.NAME = "" THEN
USING.NAME = COMMAND(I)
USING.CLAUSE = UNIX.PATH
END ELSE
ADD.IDX:
IF IDX.TO.ADD = '' THEN
IDX.TO.ADD = COMMAND(I)
END ELSE
IDX.TO.ADD := @FM:COMMAND(I)
END
END
END CASE
!
* Process next TOKEN item
!
NEXT I
!
* If FILE not on command line, prompt for it
!
PROMPT ' '
IF FILE = '' THEN
** "File name:"
PRINT UVREADMSG(85304,""):' ':
INPUT FILE
END
!
* Check for DICT
!
IF INDEX(FILE," ",1) THEN
DKEY = 0
AWORD = FIELD(FILE," ",1)
READ VDESC FROM VOC.FILE,AWORD THEN
* Check that this is DICT keyword
IF VDESC[1,1] = "K" THEN
IF VDESC<2> = KW$DICT THEN DKEY = WANT.DICT
IF VDESC<2> = KW$PDICT THEN DKEY = WANT.PDICT
END
END
IF DKEY = 0 THEN
** "Unrecognized keyword "%s" in command line"
err.number = 85300
err.args = AWORD
process.status = -1
GOTO EXIT.OUT:
END
FILE=TRIMF(FILE[LEN(AWORD)+1,999])
END
!
* Verify file is legit
!
IF FILE = '' THEN
** "No file name specified."
err.number = 10138
err.args = ""
process.status = -1
GOTO EXIT.OUT:
END ELSE
READ VDESC FROM VOC.FILE, FILE ELSE
* Check for multi-level data files
IF INDEX(FILE,",",1) THEN
MAINFILE = FIELD(FILE,",",1)
READ VDESC FROM VOC.FILE, MAINFILE ELSE
** "%n" is not a file name.
err.number = 45006
err.args = FILE
process.status = -1
GOTO EXIT.OUT:
END
END ELSE
** "%n" is not a file name.
err.number = 45006
err.args = FILE
process.status = -1
GOTO EXIT.OUT:
END
END
* Check for USING clause for which DICT to open
IF USING.CLAUSE # UNIX.PATH THEN
IF USING.CLAUSE = FALSE THEN
DFILE = IF DKEY THEN "DICT.DICT" ELSE "DICT ":FILE
END ELSE
DFILE = USING.NAME
IF USING.DICT = WANT.DICT THEN DFILE = "DICT "DFILE
IF USING.DICT = WANT.PDICT THEN DFILE = "PDICT "DFILE
END
OPEN DFILE TO UDICT ELSE
** "Unable to open "%s"."
err.number = 85303
err.args = DFILE
process.status = -1
GOTO EXIT.OUT:
END
END ELSE
OPENPATH USING.NAME TO UDICT ELSE
** "Unable to open "%s"."
err.number = 85303
err.args = USING.NAME
process.status = -1
GOTO EXIT.OUT:
END
DFILE = USING.NAME
END
* Get file status info
STATUS index.dict FROM UDICT ELSE
* Unable to stat file %s
err.number = 32007
err.args = DFILE
process.status = -1
GOTO EXIT.OUT:
END
END
!
* Open the file
!
IF DKEY = WANT.DICT THEN FILE = "DICT ":FILE
IF DKEY = WANT.PDICT THEN FILE = "PDICT ":FILE
OPEN FILE TO UDATA ELSE
** "Unable to open "%s"."
err.number = 85303
err.args = FILE
process.status = -1
GOTO EXIT.OUT:
END
!
* Get file status info
!
STATUS index.item FROM UDATA ELSE
* Unable to stat file %s
err.number = 32007
err.args = FILE
process.status = -1
GOTO EXIT.OUT:
END
!
* Can we even create indices
!
IF index.item<21> = 1 OR index.item<21> = 19 THEN
* Secondary index facility is not support for type 1 or 19 files.
* PRINT;CALL *UVPRINTMSG(35038,"")
err.number = 35038
err.args = ""
process.status = -1
GOTO EXIT.OUT:
END
STATE = 0
RECIO(STATE,FINFO$AI.STATE,RECIO$FINFO)
IF FILEINFO(UDATA,FINFO$RECOVERYTYPE) # 0 AND STATE = AI$LOGGING THEN
* PRINT;CALL *UVPRINTMSG(87902,"")
err.number = 87902
err.args = ""
process.status = -1
GOTO EXIT.OUT
END
!
* Get a list of INDICES. A null list is returned if none
!
IF IDX.TO.ADD = '' THEN
** "Index name(s): "
PRINT UVREADMSG(32009,""):
INPUT IDX.TO.ADD
IF IDX.TO.ADD = '' THEN
** "No Index name specified."
err.number = 85307
err.args = ""
process.status = -1
GOTO EXIT.OUT:
END
* Add as possible index key and convert space or comma to FM
* in case we got a string of index names
IDX.TO.ADD = CONVERT(\ ,\,@FM:@FM,IDX.TO.ADD)
END
HDRLAYOUT = FILEINFO(UDATA, FINFO$HDRLAYOUT)
AKPATHoffset = HDRLAYOUT<FH$INDEXPATH,1>
AKPATHlength = HDRLAYOUT<FH$INDEXPATH,2>
IDXOFFoffset = HDRLAYOUT<FH$INDEXFLAGS,1>
IDXOFFlength = HDRLAYOUT<FH$INDEXFLAGS,2>
SQLIDXoffset = HDRLAYOUT<FH$IDXCOLCNT,1>
SQLIDXlength = HDRLAYOUT<FH$IDXCOLCNT,2>
if index.item<32> = 5 then
FILETYPE = " -64BIT"
end else
if index.item<32> = 3 then
FILETYPE = " -32BIT"
end else
FILETYPE = " -OLDSTYLE"
end
end
!
* Disable interrupts
!
BREAK OFF
!
* Special handling for Distributed Files
!
IF index.item<21> = 27 THEN
* This is a Distributed File, so there are NO indices on the file
* itself. We must spawn a CREATE.INDEX for each partfile, and do
* them sequentially. The PF vocnames will be in F26 of the result
* from the above STATUS statement.
*
* Get absolute path of DICT file
DICT.UNIX.PATH = index.dict<27>
*
* Make certain I-types are compiled
* EXECUTE "COMPILE.DICT ":FILE:" ":CONVERT(@fm," ",IDX.TO.ADD)
*
* Get hostname
EXECUTE OS.EXEC:" '":HOSTNAME:"'" CAPTURING LocalHOSTNAME
LocalHOSTNAME = LocalHOSTNAME<1>
MAX.PFS = DCOUNT(index.item<26>,@vm)
FOR I = 1 TO MAX.PFS
* Set up spawn command
cmd = "CREATE.INDEX ":index.item<26,I>:" "
* Add names
cmd := CONVERT(@fm," ",IDX.TO.ADD)
* Is this PF a remote?
IF (index.item<25,I> MATCHES "1X0X'!/'0X") OR (index.item<25,I> MATCHES "1X0X'!\'0X") OR (index.item<25,I> MATCHES "1X0X'!'1A':'0X") THEN
* Let PF use DICT of DF prepended with LocalHOSTNAME
cmd := " USING ":LocalHOSTNAME:"!":DICT.UNIX.PATH
END ELSE
* Let PF's use DICT of DF
cmd := " USING ":DICT.UNIX.PATH
END
* Is there an AT clause
IF AT.CLAUSE = TRUE THEN
cmd := " AT ":AT.PATH
END
IF NULLS.ALLOWED = FALSE THEN
cmd := " NO.NULLS"
END
* Creating indice(s) for partfile '%s'!
*CALL *UVPRINTMSG(32102,index.item<26,I>)
* Go do command
EXECUTE cmd SETTING return.code
* Stop if error
IF return.code = -1 THEN
process.status = -1
END
NEXT I
GOTO EXIT.OUT:
END
!
* Special handling for Remote Files
!
$IFDEF UV.MSWIN
CONVERT '\' TO '/' IN index.item<20>
$ENDIF
IF (index.item<20> MATCHES "1X0X'!/'0X") THEN
IS.REMOTE = TRUE
NODE = FIELD(index.item<20>,"!/",1)
DIRECTORY = FIELD(index.item<20>,"!/",2,9999)
END ELSE IF (index.item<20> MATCHES "1X0X'!'1A':'0X") THEN
IS.REMOTE = TRUE
NODE = FIELD(index.item<20>,"!",1)
DIRECTORY = FIELD(index.item<20>,"!",2,9999)
END ELSE
IS.REMOTE = FALSE
END
IF IS.REMOTE THEN
* Set up for remote execute call
IF INDEX(DIRECTORY,"/DATA.30",1) THEN
DIRECTORY = FIELD(DIRECTORY, "/", 1, COUNT(DIRECTORY,"/"))
END
DIRECTORY = FIELD(DIRECTORY, "/", 1, COUNT(DIRECTORY,"/"))
* Clean up command - get rid of determining string
THING.TO.DO = "CREATE.INDEX ":FILE:" ":CONVERT(@fm," ",IDX.TO.ADD)
IF USING.CLAUSE # FALSE THEN
THING.TO.DO := " USING ":USING.NAME
END
* Add node name
THING.TO.DO := " SYSTEM ":NODE
RESULT=""
* Calling remote node '":NODE:"'. Please wait..."
* CALL *UVPRINTMSG(32103,NODE)
* Go do remote command
CALL *REMOTE.B(NODE, THING.TO.DO, DIRECTORY, RESULT)
if RESULT # "" THEN PRINT RESULT
TEMP=""
DIRECTORY=""
NODE=""
GOTO EXIT.OUT:
END
!
* Some initializations
!
MAX.INDICES = 0
FROM.VOC = STR(0,1000) ;* Assume read is from DICT
AVAILABLE = STR(1,1000) ;* Slots which are available - assume all
!
* Loop through named items and read from DICT FILE or VOC
!
LOOP
MAX.INDICES += 1
REMOVE IDX.ITEM FROM IDX.TO.ADD SETTING DELIM
* Check if item is in DICT
READ VDESC FROM UDICT, IDX.ITEM ELSE
* Check if item is in VOC
READ VDESC FROM VOC.FILE, IDX.ITEM ELSE
* Cannot find field name %s in field dictionary or VOC, no index"
err.number = 35033
err.args = IDX.ITEM
process.status = -1
GOTO EXIT.OUT:
END
FROM.VOC[MAX.INDICES,1] = TRUE
END
* If not correct type, croak
IF NOT(INDEX("ADIS",VDESC<1>[1,1],1)) THEN
* Only records of type A, D, I or S allowed!
err.number = 32104
err.args = ""
process.status = -1
GOTO EXIT.OUT:
END
* Save DICT text
DICT.TEXT(MAX.INDICES) = VDESC
UNTIL DELIM = 0 DO
* Have we exceeded limit
IF MAX.INDICES > MAXindices THEN
* Maximum number of indices exceed
err.number = 32105
err.args = MAXindices
process.status = -1
GOTO EXIT.OUT:
END
REPEAT
!
* Check that I-types are compiled
!
IDX.TO.ADD = IDX.TO.ADD ;* Reset REMOVE pointer
IDX.CNT = 1
LOOP
REMOVE IDX.ITEM FROM IDX.TO.ADD SETTING DELIM
* If this is an Itype - make certain its compiled
IF DICT.TEXT(IDX.CNT)[1,1] = 'I' THEN
* open local dict
OPEN 'DICT',FILE TO ODICT ELSE
** Unable to open
err.number = 85303
err.args = 'DICT ':FILE
process.status = -1
GOTO EXIT.OUT:
END
* Read from remote dict
IF FROM.VOC[IDX.CNT,1] = FALSE THEN
READ VDESC FROM UDICT, IDX.ITEM ELSE
* Unable to read item "%s".
err.number = 1205
err.args = IDX.ITEM
process.status = -1
GOTO EXIT.OUT:
END
END ELSE
READ VDESC FROM VOC.FILE, IDX.ITEM ELSE
* Unable to read item "%s".
err.number = 1205
err.args = IDX.ITEM
process.status = -1
GOTO EXIT.OUT:
END
END
* Write to temp record
READU ISOLOCK FROM ODICT,IDX.ITEM:".tEmPP" ELSE null
WRITE VDESC ON ODICT, IDX.ITEM:".tEmPP"
* Compile
* Quote the thing if it contains a single or double quote.
IF INDEX(IDX.ITEM, "'", 1) OR INDEX(IDX.ITEM, '"', 1)
THEN tmpidx.item = SYSTEM(1031, IDX.ITEM:".tEmPP")
ELSE tmpidx.item = IDX.ITEM:".tEmPP"
EXECUTE "COMPILE.DICT ":FILE:" ":tmpidx.item CAPTURING screen
* Re-read
READU VDESC FROM ODICT, IDX.ITEM:".tEmPP" ELSE
DELETE ODICT, IDX.ITEM:".tEmPP"
* Unable to read item "%s".
err.number = 1205
err.args = IDX.ITEM:".tEmPP"
process.status = -1
GOTO EXIT.OUT:
END
* delete
DELETE ODICT, IDX.ITEM:".tEmPP"
* Is there stuff beyond field 15
IF VDESC<20> = "" THEN
* I-descriptor must be compiled before execution.
err.number = 40018
err.args = ""
process.status = -1
GOTO EXIT.OUT:
END
* Replace
DICT.TEXT(IDX.CNT) = VDESC
VDESC = ""
END
UNTIL DELIM = 0 DO
IDX.CNT += 1
REPEAT
!
* Check for existence of index directory - read file header
!
$IFDEF UV.MSWIN
CONVERT '\' TO '/' IN index.item<27>
$ENDIF
ABSOLUTE.FILE.PATH = index.item<27>
FILENAME = FIELD(ABSOLUTE.FILE.PATH,"/",DCOUNT(ABSOLUTE.FILE.PATH,"/"))
IF index.item<21> = 30 THEN ABSOLUTE.FILE.PATH := "/DATA.30"
IF SYSTEM(100) THEN
* NLS is enabled
* First Save the original sequential file map
OLD.SEQ.MAP = SYSTEM(106)
* SET.SEQ.MAP to NONE to ensure binary access to index file
IGNORE = NLSsetseqmap("NONE")
END
OPENSEQ ABSOLUTE.FILE.PATH TO SEQ.FILE ELSE
IF SYSTEM(100) THEN
* Restore the original sequential file map
IGNORE = NLSsetseqmap(OLD.SEQ.MAP)
END
* Unable to openseq %s
err.number = 85309
err.args = ABSOLUTE.FILE.PATH
process.status = -1
GOTO EXIT.OUT:
END
IF SYSTEM(100) THEN
* Restore the original sequential file map
IGNORE = NLSsetseqmap(OLD.SEQ.MAP)
END
* Seek to AK position
SEEK SEQ.FILE, AKPATHoffset, 0 ELSE
* Unable to seq in %s
err.number = 85310
err.args = ABSOLUTE.FILE.PATH
process.status = -1
GOTO EXIT.OUT:
END
* Read in AKdirPATH
READBLK AKdirPATH FROM SEQ.FILE, AKPATHlength ELSE
* Unable to read index directory name in file header block.
err.number = 35030
err.args = ""
process.status = -1
GOTO EXIT.OUT:
END
!
* Extract important create data
!
OWNER = index.item<8>
GROUP = index.item<9>
PERMS = index.item<5>
PERMS = BITAND(PERMS, 511) ;* Get lowest 3 bits
EXPERMS = BITAND(PERMS, 73) ;* Give execute permissions
!
* Check
!
IF AKdirPATH[1,1] # BYTE(0) THEN
* We have a directory, with indices - truncate at first BYTE(0)
AKdirPATH = AKdirPATH[1,INDEX(AKdirPATH,BYTE(0),1)-1]
GOSUB LOAD.INDEX.MAP:
IF AT.CLAUSE THEN
* Indices exist at xxx! AT clause ignored!
err.number = 32106
err.args = AKdirPATH
AT.CLAUSE = FALSE
END
END ELSE
* Create path
IF AT.CLAUSE THEN
* Create at given account path
AKdirPATH = AT.PATH
END ELSE
* Create index directory where file exists
AKdirPATH = FIELD(index.item<27>,"/",1,COUNT(index.item<27>,"/"))
AT.PATH = AKdirPATH
END
* Open this directory
OPENPATH AKdirPATH TO TMPfile ELSE
* Unable to open the UNIX directory %s
err.number = 10001
err.args = AKdirPATH
process.status = -1
GOTO EXIT.OUT:
END
* Must be Type1 or Type19
STATUS TMPstatus FROM TMPfile else TMPstatus = ""
IF TMPstatus<21> # 1 AND TMPstatus<21> # 19 THEN
* Location where indices are to reside not a UNIX directory!
err.number = 32101
err.args = ""
process.status = -1
GOTO EXIT.OUT:
END
* Check that we have permissions to create
MYuid = SYSTEM(28)
WRITEABLE=0
CALL @PERMISSIONS(TMPfile,1,6,WRITEABLE)
IF NOT(WRITEABLE) AND MYuid # 0 THEN
* Privileges insufficient to create index directory in %s.
err.number = 35025
err.args = AT.PATH
process.status = -1
GOTO EXIT.OUT:
END
* CLose
CLOSE TMPfile
$IFDEF UV.UNIX
*
* Get the name of the file as saved in the file header. This will include
* any mapping done for special characters (ie X/Y is X?\Y at unix).
*
AKname = FIELD(index.item<27>,"/",(COUNT(index.item<27>,"/")+1))
$ELSE
* Convert name
BEGIN CASE
CASE DKEY = 0
AKname = FILENAME
CASE DKEY = WANT.DICT
AKname = CHANGE(FILENAME,"DICT ","D_",-1)
CASE DKEY = WANT.PDICT
AKname = CHANGE(FILENAME,"PDICT ","P_",-1)
END CASE
$ENDIF
AKdirPATH := "/I_":AKname
* Check path length
IF BYTELEN(AKdirPATH) > AKPATHlength THEN
* Index directory path name %n exceed %i character limit.
err.number = 35026
err.args = AKdirPATH:@fm:AKPATHlength
process.status = -1
GOTO EXIT.OUT:
END
* Does this new sub-directory already exist
PATH.OK = FALSE
PATH.CT = 0
LOOP
OPENPATH AKdirPATH TO TMPfile ELSE
PATH.OK = TRUE
END
UNTIL PATH.OK = TRUE DO
* Close
CLOSE TMPfile
* Start sequencing
AKdirPATH[2] = ('0':PATH.CT)"R#2"
PATH.CT += 1
IF PATH.CT >= MAXindices THEN
* Unable to generate unique index directory name. Last tried %n.
err.number = 35027
err.args = AKdirPATH
process.status = -1
GOTO EXIT.OUT:
END
REPEAT
* Build command
$IFDEF UV.UNIX
*
* quote the filename so that the unix shell won't try to
* interpret special chars
*
cmd = UV.BIN:UV.FSEP:"mkdbfile ":"'":AKdirPATH:"'":" 19 -u ":OWNER
cmd := " -g ":GROUP:" -m ":EXPERMS:" -M NONE"
EXECUTE OS.EXEC:' "':cmd:'"' CAPTURING screen
$ELSE
cmd = UV.BIN:UV.FSEP:"mkdbfile ":AKdirPATH:" 19 -u ":OWNER
cmd := " -g ":GROUP:" -m ":EXPERMS:" -M NONE"
* Go create directory
EXECUTE OS.EXEC:" '":cmd:"'" CAPTURING screen
$ENDIF
* If anything came back, then its an error
IF screen # "" THEN
* Attempt to create index directory %n failed.
*PRINT screen
err.number = 35028
err.args = AKdirPATH
process.status = -1
GOTO EXIT.OUT:
END
* Seek to AK position
SEEK SEQ.FILE, AKPATHoffset, 0 ELSE
* Unable to seq in %s
err.number = 85310
err.args = ABSOLUTE.FILE.PATH
process.status = -1
GOTO EXIT.OUT:
END
* Write out new path
TEMP = (AKdirPATH:STR(BYTE(0),AKPATHlength))("L#":AKPATHlength)
WRITEBLK TEMP ON SEQ.FILE ELSE
* Unable to write index directory name in file header block.
err.number = 35029
err.args = ""
process.status = -1
GOTO EXIT.OUT:
END
END
!
* Close
!
CLOSESEQ SEQ.FILE
!
* Add
!
IDX.TO.ADD = IDX.TO.ADD ;* Reset REMOVE pointer
STARTcnt = IDXcnt
NEWcnt = 0
LOOP
REMOVE IDX.ITEM FROM IDX.TO.ADD SETTING DELIM
NEWcnt += 1
* Look through INDEX.MAP for similar
ONE.IDX = 0
LOOP
ONE.IDX += 1
ADD.THIS.ONE = TRUE ;* Assume we can add this
CORRELATIVE = FALSE;* Assume none
TESTcnt = IDXdatatext<ONE.IDX>
* Get MV
IF INDEX("DI", DICT.TEXT(NEWcnt)<1>[1,1], 1) THEN
MV = DICT.TEXT(NEWcnt)<6>
IF MV = "" THEN MV = "S" ;* Assume Single-value if nothing given
END ELSE
* Pick-style: assume multi-valued
MV = "M"
* Check if this has correlative
IF DICT.TEXT(NEWcnt)<8> # "" THEN
CORRELATIVE = TRUE
END
END
IF MV # "M" AND MV # "S" THEN
* invalid multivalue field
IF SYSTEM.name # '' then
CALL *UVPRINTMSG(32112,SYSTEM.name)
END
CALL *UVPRINTMSG(35034,IDX.ITEM:@fm:IDXkeytext<ONE.IDX>)
ADD.THIS.ONE=FALSE
EXIT
END
UNTIL ONE.IDX > IDXcnt DO
* First, check name
IF IDX.ITEM = IDXkeytext<ONE.IDX> THEN
print
if SYSTEM.name # "" then
CALL *UVPRINTMSG(32112,SYSTEM.name)
end
* Index field %s is a duplicate of %n, no new index created.
CALL *UVPRINTMSG(35032, IDX.ITEM:@fm:IDXkeytext<ONE.IDX>)
ADD.THIS.ONE = FALSE
EXIT ;* Get next key
END
* Second, check type
BEGIN CASE
CASE INDEX("D",DICT.TEXT(NEWcnt)<1>[1,1],1)
* Does field 2 match
IF DICT.TEXT(NEWcnt)<2> = DATA.MAP(TESTcnt)<2> THEN
* Test M/S
IF MV = IDXmulti<ONE.IDX> THEN
print
if SYSTEM.name # "" then
CALL *UVPRINTMSG(32112,SYSTEM.name)
end
* Index field %s is a duplicate of %n, no new index created.
CALL *UVPRINTMSG(35032, IDX.ITEM:@fm:IDXkeytext<ONE.IDX>)
ADD.THIS.ONE = FALSE
EXIT ; * Get next key
END
END
* Check if this is a Pick-style
CASE INDEX("ACS",DICT.TEXT(NEWcnt)<1>[1,1],1)
* Is there correlative code
OKAY = 1
IF DICT.TEXT(NEWcnt)<2> = DATA.MAP(TESTcnt)<2> THEN
IF DICT.TEXT(NEWcnt)<8> # "" THEN
* Does it match
IF DICT.TEXT(NEWcnt)<8> = DATA.MAP(TESTcnt)<8> THEN
OKAY = 0
END
END ELSE
OKAY = 0
END
IF NOT(OKAY) THEN
* Index field %s is a duplicate of %n, no new index created.
print
if SYSTEM.name # "" then
CALL *UVPRINTMSG(32112,SYSTEM.name)
end
CALL *UVPRINTMSG(35032, IDX.ITEM:@fm:IDXkeytext<ONE.IDX>)
ADD.THIS.ONE = FALSE
EXIT ; * Get next key
END
END
CASE DICT.TEXT(NEWcnt)<1>[1,1] = 'I'
* Do nothing
CASE 1
* Error initializing index file "%n", no index created.
print
if SYSTEM.name # "" then
CALL *UVPRINTMSG(32112,SYSTEM.name)
end
CALL *UVPRINTMSG(35034, FILE);
ADD.THIS.ONE = FALSE
EXIT
END CASE
REPEAT
* Add one to memory INDEX.MAP
IF ADD.THIS.ONE = TRUE THEN
IDXcnt += 1
* Add namelen and nametext
IDXkeylen<IDXcnt> = BYTE(BYTELEN(IDX.ITEM)+1)
IDXkeytext<IDXcnt> = IDX.ITEM
* Add type
IF CORRELATIVE = FALSE THEN
IDXtype<IDXcnt> = DICT.TEXT(NEWcnt)<1>[1,1]
END ELSE
IDXtype<IDXcnt> = 'C'
END
* Add multi
IDXmulti<IDXcnt> = MV
* Add built
IDXbuilt<IDXcnt> = 'N'
* Add nulls
IDXnulls<IDXcnt> = IF NULLS.ALLOWED = TRUE THEN 'Y' ELSE 'N'
* Add enabled
IDXenabled<IDXcnt> = 'Y'
* Add datalen and datatext
IF IDXtype<IDXcnt> = 'C' OR IDXtype<IDXcnt> = 'I' THEN
IDXdatalen<IDXcnt> = BYTELEN(DICT.TEXT(NEWcnt))+1
IDXdatatext<IDXcnt> = IDXcnt
DATA.MAP(IDXcnt) = DICT.TEXT(NEWcnt):BYTE(0)
END ELSE
IDXdatalen<IDXcnt> = BYTELEN(DICT.TEXT(NEWcnt)<2>)+1
IDXdatatext<IDXcnt> = IDXcnt
DATA.MAP(IDXcnt) = DICT.TEXT(NEWcnt)<2>:BYTE(0)
END
* Go create file
GOSUB CREATE.EMPTY.INDEX.FILE:
* Go set IDXOFF tags
GOSUB SET.IDXOFF.TAG:
* Set process.status
process.status += 1
END
UNTIL DELIM = 0 DO
* Check for max
IF IDXcnt = MAXindices THEN
print
if SYSTEM.name # "" then
CALL *UVPRINTMSG(32112,SYSTEM.name)
end
* Maximum number of indices (":MAXindices:") reached!
CALL *UVPRINTMSG(32107,MAXindices)
EXIT
END
REPEAT
!
* Write out INDEX.MAP file
!
GOSUB WRITE.INDEX.MAP:
!
* Just exit
!
EXIT.OUT:
@SYSTEM.RETURN.CODE = process.status
BREAK ON
if process.status = -1 then
PRINT
if SYSTEM.name # "" then
CALL *UVPRINTMSG(32112,SYSTEM.name)
end
CALL *UVPRINTMSG(err.number,err.args)
end
STOP
!
* End of MAIN code - Start of subroutines
!
LOAD.INDEX.MAP:
!
* Open the INDEX.MAP file
!
INDEX.MAP.PATH = AKdirPATH:"/INDEX.MAP"
Islocked = 0
IF SYSTEM(100) THEN
* NLS is enabled
* First Save the original sequential file map
OLD.SEQ.MAP = SYSTEM(106)
* SET.SEQ.MAP to NONE to ensure binary access to index file
IGNORE = NLSsetseqmap("NONE")
END
LOOP
OPENSEQ INDEX.MAP.PATH TO MAP.FILE LOCKED
Islocked = 1
END ELSE
IF SYSTEM(100) THEN
* Restore the original sequential file map
IGNORE = NLSsetseqmap(OLD.SEQ.MAP)
END
* "Unable to open index map '%n' for read/write."
err.number = 35031
err.args = INDEX.MAP.PATH
process.status = -1
RETURN TO EXIT.OUT:
END
WHILE Islocked DO
SLEEP 10
REPEAT
IF SYSTEM(100) THEN
* Restore the original sequential file map
IGNORE = NLSsetseqmap(OLD.SEQ.MAP)
END
!
* Load in contents of INDEX.MAP file
!
IDXcnt = 0
LOOP
* Get file name
READBLK TEMP FROM MAP.FILE,10 ELSE EXIT
IDXcnt += 1
IDXname<IDXcnt> = TEMP
* Mark in AVAILABLE as already used
TEMP = TRIM(TEMP, BYTE(0), 'T')
AVAILABLE[(TEMP[3]+1),1] = 0
* Get keylen
READBLK IKL FROM MAP.FILE,1 ELSE IKL = 0
IDXkeylen<IDXcnt> = IKL
* Get keytext
READBLK TEMP FROM MAP.FILE, BYTEVAL(IKL) ELSE TEMP=""
* Remove BYTE(0) from end
IDXkeytext<IDXcnt> = TEMP[1,LEN(TEMP)-1]
* Get next 5 chars
READBLK TEMP FROM MAP.FILE, 5 ELSE TEMP=""
IDXtype<IDXcnt> = TEMP[1,1]
IDXmulti<IDXcnt> = TEMP[2,1]
IDXbuilt<IDXcnt> = TEMP[3,1]
IDXnulls<IDXcnt> = TEMP[4,1]
IDXenabled<IDXcnt> = TEMP[5,1]
* Read in datalen
READBLK IKL FROM MAP.FILE, 2 ELSE IKL = 0
* GTAR 19949
* Character substrings are not the same as byte substrings when NLS on
* IKL = BYTEVAL(IKL[1,1]) + 256 * BYTEVAL(IKL[2,1])
HEXIKL = OCONV( IKL, "MX0C" )
IKL = ICONV( HEXIKL[1,2], "MCD" ) + 256 * ICONV( HEXIKL[3,2], "MCD" )
IDXdatalen<IDXcnt> = IKL
* Read in datatext
READBLK TEMP FROM MAP.FILE, IKL ELSE TEMP=""
IDXdatatext<IDXcnt> = IDXcnt
DATA.MAP(IDXcnt) = TEMP
REPEAT
!
* Close and return
!
CLOSESEQ MAP.FILE
RETURN
!
* Write the INDEX.MAP file
!
WRITE.INDEX.MAP:
!
* Open it first
!
INDEX.MAP.PATH = AKdirPATH:"/INDEX.MAP"
Islocked = 0
IF SYSTEM(100) THEN
* NLS is enabled
* First Save the original sequential file map
OLD.SEQ.MAP = SYSTEM(106)
* SET.SEQ.MAP to NONE to ensure binary access to index file
IGNORE = NLSsetseqmap("NONE")
END
LOOP
OPENSEQ INDEX.MAP.PATH TO MAP.FILE LOCKED
Islocked = 1
END ELSE
IF SYSTEM(100) THEN
* Restore the original sequential file map
IGNORE = NLSsetseqmap(OLD.SEQ.MAP)
END
CREATE MAP.FILE ELSE
* Unable to create INDEX.MAP file
err.number = 32108
err.args = ""
process.status = -1
RETURN TO EXIT.OUT:
END
END
WHILE Islocked DO
SLEEP 10
REPEAT
IF SYSTEM(100) THEN
* Restore the original sequential file map
IGNORE = NLSsetseqmap(OLD.SEQ.MAP)
END
!
* Rewrite INDEX.MAP file
!
SEEK MAP.FILE, 0, 0 ELSE
* Unable to seq in %s.
err.number = 85310
err.args = INDEX.MAP.PATH
process.status = -1
RETURN TO EXIT.OUT:
END
!
* Truncate file
!
WEOFSEQ MAP.FILE
!
* Lay down remaining values
!
C = DCOUNT(IDXname,@fm)
B = 0
D = 0
F = 0
LOOP
B += 1
UNTIL B > C DO
TEMP = IDXname<B>
* Is last byte a BYTE(0)? If not, add one
IF TEMP[1] # BYTE(0) THEN
TEMP := BYTE(0)
END
TEMP := IDXkeylen<B>:IDXkeytext<B>:BYTE(0)
TEMP := IDXtype<B>:IDXmulti<B>:IDXbuilt<B>
TEMP := IDXnulls<B>:IDXenabled<B>
F = INT(IDXdatalen<B> / 256)
IF F > 0 THEN
D = BYTE((IDXdatalen<B>-(F*256))):CHAR(F)
END ELSE
D = BYTE(IDXdatalen<B>):BYTE(0)
END
TEMP := D
TEMP := DATA.MAP(IDXdatatext<B>)
WRITEBLK TEMP ON MAP.FILE ELSE
* Error updating INDEX.MAP file!
err.number = 32109
err.args = ""
process.status = -1
EXIT
END
REPEAT
!
* Close
!
CLOSESEQ MAP.FILE
RETURN
!
* Create an index file
!
CREATE.EMPTY.INDEX.FILE:
* Let's go create/assume the next available
Next.entry = INDEX(AVAILABLE,1,1)
* Did we get anything
IF Next.entry = 0 THEN
* Unable to generate unique index file name!
err.number = 32110
err.args = ""
process.status = -1
RETURN TO EXIT.OUT:
END
* Mark as taken
AVAILABLE[Next.entry,1] = 0
* Save name
IDXname<IDXcnt> = "INDEX.":FMT(Next.entry-1,"R%3")
* Set up name
NEW.FILE = AKdirPATH:UV.FSEP:IDXname<IDXcnt>
* Remove any existing file
HUSH ON SETTING HUSH.STATE
$IFDEF UV.UNIX
cmd = RM.CMD:" ":"'":NEW.FILE:"'"
EXECUTE OS.EXEC:' "':cmd:'"' CAPTURING screen
$ELSE
EXECUTE OS.EXEC:" '":RM.CMD:" ":NEW.FILE:"'" CAPTURING screen
$ENDIF
HUSH HUSH.STATE
* Build command
$IFDEF UV.UNIX
cmd = UV.BIN:UV.FSEP:"mkdbfile ":"'":NEW.FILE:"'":" 25 -u ":OWNER:" -M NONE"
cmd := " -g ":GROUP:" -m ":PERMS:FILETYPE
IF COLLATE.NAME THEN
cmd:= " -S ":COLLATE.NAME
END
* Go create file
EXECUTE OS.EXEC:' "':cmd:'"' CAPTURING screen
$ELSE
cmd = UV.BIN:UV.FSEP:"mkdbfile ":NEW.FILE:" 25 -u ":OWNER:" -M NONE"
cmd := " -g ":GROUP:" -m ":PERMS:FILETYPE
IF COLLATE.NAME THEN
cmd:= " -S ":COLLATE.NAME
END
* Go create file
EXECUTE OS.EXEC:" '":cmd:"'" CAPTURING screen
$ENDIF
* If anything came back, then its an error
IF screen # "" THEN
* Try another file
GOTO CREATE.EMPTY.INDEX.FILE:
END
RETURN
!
* Update tags
!
SET.IDXOFF.TAG:
* Openseq file
IF SYSTEM(100) THEN
* NLS is enabled
* First Save the original sequential file map
OLD.SEQ.MAP = SYSTEM(106)
* SET.SEQ.MAP to NONE to ensure binary access to index file
IGNORE = NLSsetseqmap("NONE")
END
OPENSEQ NEW.FILE TO TMPfile ELSE
IF SYSTEM(100) THEN
* Restore the original sequential file map
IGNORE = NLSsetseqmap(OLD.SEQ.MAP)
END
* Unable to openseq %s
err.number = 85309
err.args = NEW.FILE
process.status = -1
RETURN TO EXIT.OUT:
END
IF SYSTEM(100) THEN
* Restore the original sequential file map
IGNORE = NLSsetseqmap(OLD.SEQ.MAP)
END
* Initialize to being set by CREATE.INDEX
IDXOFF.VALUE = BITOR(0,8)
* Check justification
Fvalue = IF IDXtype<IDXcnt>="D" OR IDXtype<IDXcnt>="I" THEN 5 ELSE 9
TMPval = TRIMB(DICT.TEXT(NEWcnt)<Fvalue>)
IF TMPval[1] = "R" THEN
* Mark
IDXOFF.VALUE = BITOR(IDXOFF.VALUE, 4)
END
* Check unique
IF UNIQUE.INDEX = TRUE THEN
* Mark
IDXOFF.VALUE = BITOR(IDXOFF.VALUE, 16)
END
* Check unique
IF NUMERIC.INDEX = TRUE THEN
* Mark
IDXOFF.VALUE = BITOR(IDXOFF.VALUE, 32)
END
IF SQLITYP.INDEX = TRUE THEN
* Mark
IDXOFF.VALUE = BITOR(IDXOFF.VALUE, 64)
END
* Determine if UNIX or XINU system
SEEK TMPfile, T25LEAFoffset, 0 ELSE
* Unable to seq in %s
err.number = 85310
err.args = NEW.FILE
process.status = -1
RETURN TO EXIT.OUT:
END
* Read a short
READBLK NODE FROM TMPfile, 2 ELSE
* Unable to read block at %i in index file %s. Aborting!
err.number = 85341
err.args = T25LEAFoffset:@fm:NEW.FILE
process.status = -1
RETURN TO EXIT.OUT:
END
* Convert number IDXOFF.VALUE to ascii
CONVERTED.VALUE = STR(0,IDXOFFlength)
type = IF NODE = UNIXlnode THEN 0 ELSE 1 ; * UNIX or XINU
spot = 1
FOR p = 4 TO 1 STEP -1
temp = INT(IDXOFF.VALUE/POWER(p))
IF type = 0 THEN
CONVERTED.VALUE = BYTEreplace(CONVERTED.VALUE,spot,1,BYTE(temp))
spot += 1
END ELSE
CONVERTED.VALUE = BYTEreplace(CONVERTED.VALUE,spot+(p-1),1,BYTE(temp))
END
IDXOFF.VALUE -= (temp*POWER(p))
NEXT p
* Seek to IDXoff
SEEK TMPfile, IDXOFFoffset, 0 ELSE
* Unable to seq in %s
err.number = 85310
err.args = NEW.FILE
process.status = -1
RETURN TO EXIT.OUT:
END
* Write value
WRITEBLK CONVERTED.VALUE ON TMPfile ELSE
* Error updating IDXOFF value in file header block!
err.number = 32111
err.args = ""
process.status = -1
RETURN TO EXIT.OUT:
END
* If this is a SQL I-type index:
IF IDXtype<IDXcnt> = "I" AND SQLITYP.INDEX THEN
* Retrieve index map information from dictionary.
TMPval = TRIMB(DICT.TEXT(NEWcnt)<10>)
* How many table columns are part of this index?
IDX.COLS = DCOUNT(TMPval, @VM)
IDX.MAP = 0
* Index map is a 32 bit value with two bits used to represent each col.
* working right to left.
FOR I = IDX.COLS TO 1 STEP -1
IDX.MAP = (IDX.MAP * 4) + TMPval<1,I>
NEXT I
* Convert to a format appropriate for WRITEBLK.
CONVERTED.VALUE = STR(0,(2*SQLIDXlength))
IF type = 0 THEN
CONVERTED.VALUE = BYTEreplace(CONVERTED.VALUE, 1, 3, STR(BYTE(0),3))
CONVERTED.VALUE = BYTEreplace(CONVERTED.VALUE, 4, 1, BYTE(IDX.COLS))
END ELSE
CONVERTED.VALUE = BYTEreplace(CONVERTED.VALUE, 2, 3, STR(BYTE(0),3))
CONVERTED.VALUE = BYTEreplace(CONVERTED.VALUE, 1, 1, BYTE(IDX.COLS))
END
spot = 5
FOR p = 4 TO 1 STEP -1
temp = INT(IDX.MAP/POWER(p))
IF type = 0 THEN
CONVERTED.VALUE = BYTEreplace(CONVERTED.VALUE,spot,1,BYTE(temp))
spot += 1
END ELSE
CONVERTED.VALUE = BYTEreplace(CONVERTED.VALUE,spot+(p-1),1,BYTE(temp))
END
IDX.MAP -= (temp*POWER(p))
NEXT p
SEEK TMPfile, SQLIDXoffset, 0 ELSE
* Unable to seq in %s
err.number = 85310
err.args = NEW.FILE
process.status = -1
RETURN TO EXIT.OUT:
END
WRITEBLK CONVERTED.VALUE ON TMPfile ELSE
* Error updating SQLIDXMAP value on file header block!
err.number = 32113
err.args = ""
process.status = -1
RETURN TO EXIT.OUT:
END
END
* Close
CLOSESEQ TMPfile
RETURN
!
* End of code
!
END
Reference in New Issue View Git Blame Copy Permalink