johnblood/tldm-universe
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
main
tldm-universe/Ardent/UV/BP/SET.INDEX

859 lines
26 KiB
Plaintext
Raw Permalink Normal View History

first push of universe files
2024-09-09 21:51:08 +00:00
******************************************************************************
*
* Description: SET.INDEX to ENABLE, DISABLE, CLEAR and MOVE
*
* 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/23/99 24742 GMH Add support for new headers
* 10/14/98 23801 SAP Change copyrights.
* 05/28/97 18104 KAM Allow root access despite file permissions
* 05/28/97 19314 KAM Honor secondary group permissions
* 09/06/96 19192 ALC Corrected the test for OS.TYPE
* 04/22/96 18329 JJV Port to NT.
* 06/08/95 16638 EAP Fixed CONVERT.number.TO.ASCII for NLS
* 06/06/95 16638 EAP Change to use BYTE,BYTEVAL,BYTELEN for NLSsupport
* 01/28/94 12922 GMH Fix path for local type 30 files
* 12/16/93 12745 GMH Correct pathname for OPENPATH
* 11/03/93 12492 GMH Check for Type 1 and 19 files
* 10/28/93 12384 GMH Accept NULL keyword with TO option
* 09/08/93 12183 GMH Fix FILE prompting
* 09/07/93 12183 GMH Fix openseq for type30 files
* 09/03/93 12183 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 KEYWORD.H
INCLUDE UNIVERSE.INCLUDE FILENAMES.H
INCLUDE UNIVERSE.INCLUDE FILEINFO.H
INCLUDE UNIVERSE.INCLUDE MACHINE.NAME
!
* Declare general equates
!
EQU UNIXmachine TO 44271 ;* UNIX byte ordering (acef)
EQU END.OF.STRING TO 0 ;* For REMOVE
EQU FALSE TO 0 ;* no
EQU TRUE TO 1 ;* yes
EQU DEFAULT TO -1 ;* No mode set
EQU ENABLED TO 1 ;* ENABLE indices
EQU DISABLED TO 2 ;* DISABLE indices
EQU CLEAR.TAG TO 3 ;* CLEAR 2 bit of IDXOFF value
EQU MOVE.INDEX TO 4 ;* MOVE indice path in file header
EQU INFORM TO 5 ;* Display current AK location
EQU CLEAR.INDEX TO 6 ;* CLEAR indice path in file header
EQU WANT.DICT TO 100 ;* The DICT keyword was seen
EQU WANT.PDICT TO 200 ;* The PDICT keyword was seen
!
* Define variables used
!
FIL.TO.CHANGE = '' ;* Dynarray of file names
INDEX.MODE = DEFAULT;* Default to no mode specified
VDESC = '' ;* Item read from VOC file
PROMPTING = TRUE ;* Default to verify
USE.DICT = 0 ;* Default to DATA portion of file
MOVE.PATH = '' ;* Where indices are to be relocated
MACHINE.TYPE = UNIXmachine ;* Default to UNIX byte ordering
process.status = FALSE ;* Value to set @system.return.code
INDENT = '' ;* To offset partfiles
PARTFILE = 0 ;* Current partfile
!
* Define multipliers
!
dim POWER(5)
POWER(1) = 1
POWER(2) = 256
POWER(3) = 65536
POWER(4) = 16777216
!
* Define MACROS
!
EQU getUNIXlong LIT "byteval(IDXOFFvalue,1)*POWER(4) + byteval(IDXOFFvalue,2)*POWER(3) + byteval(IDXOFFvalue,3)*POWER(2) + byteval(IDXOFFvalue,4)"
EQU getXINUlong LIT "byteval(IDXOFFvalue,4)*POWER(4) + byteval(IDXOFFvalue,3)*POWER(3) + byteval(IDXOFFvalue,2)*POWER(2) + byteval(IDXOFFvalue,1)"
!
* Set up command and data matrix
!
DIM COMMAND(125) ;* Command line arguments
!
* Disable auto pagination
!
ASSIGN 0 TO SYSTEM(1005)
PROMPT ' '
!
* Open VOC file
!
OPEN 'VOC' TO VOC.FILE ELSE
** "Unable to open VOC file."
PRINT;CALL *UVPRINTMSG(1720,"")
process.status = -1
GOTO EXIT.OUT:
END
!
* Is LONGNAMES active
!
READV LONGNAMES FROM VOC.FILE,"CREATE.FILE",5 ELSE LONGNAMES=""
IF LONGNAMES = "" THEN
LONGNAMES = 12
END ELSE
LONGNAMES = 999
END
!
* Open UV.ACCOUNT file
!
OPENPATH UV.ROOT:'/UV.ACCOUNT' TO UVACCT.FILE ELSE
** "Unable to open UVACCT file."
PRINT;CALL *UVPRINTMSG(85303,"UV.ACCOUNT")
process.status = -1
GOTO EXIT.OUT:
END
!
* Parse out COMMAND line
!
MATPARSE COMMAND FROM TRIM(@SENTENCE) , ' '
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 VDESC = ""
* Check if path is given
IF INDEX.MODE = MOVE.INDEX AND MOVE.PATH = "" THEN
* Check for NULL keyword
IF VDESC<2> = KW$NULL OR COMMAND(I) = '""' OR COMMAND(I) = "''" THEN
MOVE.PATH = ""
INDEX.MODE = CLEAR.INDEX
CONTINUE
END
* If any other VOC entry, then leave
IF VDESC # "" THEN GOTO REMAIN
IF COMMAND(I)[1,1] = "/" OR (OS.TYPE = "MSWIN" AND ((COMMAND(I) MATCH "1A':\'0X") OR (COMMAND(I) MATCH "1A':/'0X") OR (COMMAND(I)[1,1] = "\"))) THEN
MOVE.PATH = COMMAND(I)
* Verify that path exists
CHECK.PATH:
IF OS.TYPE = "MSWIN" THEN
MOVE.PATH = CONVERT( "\", "/", MOVE.PATH )
END
OPENPATH MOVE.PATH TO TMPfile ELSE
* Path %n cannot be opened for reading. Verify exists
PRINT;CALL *UVPRINTMSG(32100, MOVE.PATH)
process.status = -1
GOTO EXIT.OUT:
END
* Must be Type1 or Type19
STATUS FILstatus FROM TMPfile else FILstatus = ""
IF FILstatus<21> # 1 AND FILstatus<21> # 19 THEN
* Location where indices are to reside not a UNIX directory!
PRINT;CALL *UVPRINTMSG(32101,"")
process.status = -1
GOTO EXIT.OUT:
END
CLOSE TMPfile
END ELSE
* Read from UV.ACCOUNT file
READV MOVE.PATH FROM UVACCT.FILE, COMMAND(I), 11 ELSE
* Unable to read item "%s".
PRINT;CALL *UVPRINTMSG(1205,COMMAND(I))
process.status = -1
GOTO EXIT.OUT:
END
GOTO CHECK.PATH:
END
CONTINUE
END
REMAIN:
* If entry is not in VOC file
IF VDESC = "" THEN
* Check for multi-level data file
IF INDEX(COMMAND(I),",",1) THEN
MAINFILE = FIELD(COMMAND(I),",",1)
READ VDESC FROM VOC.FILE,MAINFILE ELSE
PRINT;CALL *UVPRINTMSG(85300,COMMAND(I))
process.status = -1
GOTO EXIT.OUT:
END
END ELSE
PRINT;CALL *UVPRINTMSG(85300,COMMAND(I))
process.status = -1
GOTO EXIT.OUT:
END
END
!
* Examine for Keywords
!
BEGIN CASE
CASE VDESC[1,1] = 'K'
BEGIN CASE
* Check for DICT keyword
CASE VDESC<2> = KW$DICT
USE.DICT = WANT.DICT
* Check for PDICT keyword
CASE VDESC<2> = KW$PDICT
USE.DICT = WANT.PDICT
* Check if FORCE keyword
CASE VDESC<2> = KW$FORCE
PROMPTING = FALSE
* Check if CLEAR keyword
CASE VDESC<2> = KW$CLEAR
IF INDEX.MODE = DEFAULT THEN
INDEX.MODE = CLEAR.TAG
END ELSE
GOTO BAD.OPTION:
END
* Check if ON keyword
CASE VDESC<2> = KW$ON
IF INDEX.MODE = DEFAULT THEN
INDEX.MODE = ENABLED
END ELSE
GOTO BAD.OPTION:
END
* Check if INFORM keyword
CASE VDESC<2> = KW$INFORM
IF INDEX.MODE = DEFAULT THEN
INDEX.MODE = INFORM
END ELSE
GOTO BAD.OPTION:
END
* Check if OFF keyword
CASE VDESC<2> = KW$OFF
IF INDEX.MODE = DEFAULT THEN
INDEX.MODE = DISABLED
END ELSE
GOTO BAD.OPTION:
END
* Check if TO keyword
CASE VDESC<2> = KW$TO
IF INDEX.MODE = DEFAULT THEN
INDEX.MODE = MOVE.INDEX
END ELSE
BAD.OPTION:
* "Only one mode can be specified!"
PRINT;CALL *UVPRINTMSG(32200,"")
process.status = -1
GOTO EXIT.OUT:
END
* Default
CASE 1
PRINT;CALL *UVPRINTMSG(85300,COMMAND(I))
process.status = -1
GOTO EXIT.OUT:
END CASE
!
* Check for FILE
!
CASE upcase(VDESC[1,1])='F' OR upcase(VDESC[1,1])='Q'
* Add file to file list
FIL.TO.CHANGE<-1> = COMMAND(I)
!
* Stack as possible entry
!
CASE 1
* Unrecognised word "%s" in command line.
PRINT;CALL *UVPRINTMSG(85300,COMMAND(I))
process.status = -1
GOTO EXIT.OUT:
END CASE
!
* Process next TOKEN item
!
NEXT I
!
* Was any mode set?
!
IF INDEX.MODE = DEFAULT THEN
process.status = -1
GOTO EXIT.OUT:
END
!
* If TO keyword is seen and MOVE.PATH is NULL, set to CLEAR
!
IF INDEX.MODE = MOVE.INDEX AND MOVE.PATH = "" THEN
INDEX.MODE = CLEAR.INDEX
END
!
* Check if there is an active SELECT list. Add to FIL.TO.CHANGE
!
IF SYSTEM(11) = TRUE THEN
* Change SELECT list into dynarray
READLIST TMParray THEN
* Append to file list
FIL.TO.CHANGE<-1> = TMParray
END
TMParray = ""
END
!
* Any files?
!
IF FIL.TO.CHANGE = "" THEN
* "File name:"
PRINT UVREADMSG(85304,""):' ':
INPUT FIL.TO.CHANGE
* Check for DICT
IF INDEX(FIL.TO.CHANGE," ",1) THEN
USE.DICT = 0
AWORD = FIELD(FIL.TO.CHANGE," ",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
USE.DICT = WANT.DICT
END ELSE
IF VDESC<2> = KW$PDICT THEN
USE.DICT = WANT.PDICT
END
END
END
END
IF USE.DICT = 0 THEN
* "Unrecognized keyword "%s" in command line"
PRINT;CALL *UVPRINTMSG(85300,AWORD)
process.status = -1
GOTO EXIT.OUT:
END
FIL.TO.CHANGE=TRIMF(FIL.TO.CHANGE[LEN(AWORD)+1,999])
END
END
!
* Process through each file and do requested work
!
CURRENT.FILE = ''
DELIM = 0
DICT = ''
HDRLAYOUT = ''
LOOP
pSTATUS = TRUE
REMOVE CURRENT.FILE FROM FIL.TO.CHANGE SETTING DELIM
* Is there any CURRENT.FILE
IF CURRENT.FILE = "" AND DELIM = END.OF.STRING THEN EXIT
* DICT keyword seen?
IF USE.DICT = WANT.DICT THEN DICT = 'DICT '
IF USE.DICT = WANT.PDICT THEN DICT = 'PDICT '
* Open this file
OPEN DICT:CURRENT.FILE TO FILE.VAR ELSE
* Unable to open %s
PRINT;CALL *UVPRINTMSG(32006, DICT:CURRENT.FILE)
* Get next
CONTINUE
END
* Does this file even have indices?
FILE.INDICES = INDICES(FILE.VAR)
IF FILE.INDICES = "" AND INDEX.MODE # MOVE.INDEX AND INDEX.MODE # CLEAR.INDEX THEN
* Print mode message
BEGIN CASE
CASE USE.DICT = 0
* File %s has no secondary indices.
PRINT;CALL *UVPRINTMSG(35059, DICT:CURRENT.FILE)
CASE USE.DICT = WANT.DICT
* File DICT %s has no secondary indices.
PRINT;CALL *UVPRINTMSG(35057, DICT:CURRENT.FILE)
CASE USE.DICT = WANT.PDICT
* File PDICT %s has no secondary indices.
PRINT;CALL *UVPRINTMSG(35058, DICT:CURRENT.FILE)
END CASE
* Get next
CONTINUE
END
* Get info
STATUS FILstatus FROM FILE.VAR ELSE
* Unable to stat file %s
PRINT;CALL *UVPRINTMSG(32007, DICT:CURRENT.FILE)
* Get next
CONTINUE
END
* Do we have UNIX/SQL write permissions to file
GOSUB CHECK.PERMISSIONS:
* Check ATPERMS
IF ATPERMS = 0 THEN
* Insufficient privileges on file %s to perform operation.
PRINT;CALL *UVPRINTMSG(32201,DICT:CURRENT.FILE)
* Get next
CONTINUE
END
* Set up file offsets
HDRLAYOUT = FILEINFO(FILE.VAR, FINFO$HDRLAYOUT)
AKPATHoffset = HDRLAYOUT<FH$INDEXPATH,1>
AKPATHlength = HDRLAYOUT<FH$INDEXPATH,2>
IDXOFFoffset = HDRLAYOUT<FH$INDEXFLAGS,1>
IDXOFFlength = HDRLAYOUT<FH$INDEXFLAGS,2>
* Special handling for DISTRIBUTED files
IF FILstatus<21> = 27 THEN
GOSUB DO.PARTFILES:
END ELSE
* Check if file is type 1 or 19
IF FILstatus<21> = 1 OR FILstatus<21> = 19 THEN
* Secondary index facility is not supported for type 1 or 19 files.
PRINT;CALL *UVPRINTMSG(35038,"")
pSTATUS = FALSE
END ELSE
GOSUB DISPATCH:
END
END
* Close main file
CLOSE FILE.VAR
* add so that @system.return.code will return number of files processed
IF pSTATUS = TRUE THEN
process.status += 1
END
* Check for any more files
UNTIL DELIM = END.OF.STRING DO
REPEAT
!
* Exit
!
EXIT.OUT:
* Should return number of files processed, or -1 if error
@SYSTEM.RETURN.CODE = process.status
STOP
!
* All those nasty subroutines
!
DISPATCH:
* Go do action
ON INDEX.MODE GOSUB CHANGE.INDEX,
CHANGE.INDEX,
CHANGE.INDEX,
MOVE.INDEX.PATH,
SHOW.INDEX.PATH,
CLEAR.INDEX.PATH
RETURN
!
* Check UNIX/SQL permissions
!
CHECK.PERMISSIONS:
MYuid = SYSTEM(28) ;* effective uid
MYgid = SYSTEM(30) ;* effective gid
MYgid<-1> = SYSTEM(1017) ;*supplementary groups
ATPERMS = 0 ;* No permissions
IF MYuid = FILstatus<8> THEN ;* Am I file owner?
ATPERMS = BITAND(FILstatus<5>, 128);* 128(dec) = 200(oct)
END ELSE ;* Am I in same group?
LOCATE FILstatus<9> IN MYgid SETTING POS THEN
ATPERMS = BITAND(FILstatus<5>, 16);* 16(dec) = 20(oct)
END ELSE ;* I must be other
ATPERMS = BITAND(FILstatus<5>, 2);* 2(dec) = 2(oct)
END
END
* If this is an SQL type file, do we have write permissions
IF FILstatus<28> # "" THEN
* This is an SQL type file - check bit 1 for write permissions
ATPERMS = BITAND(FILstatus<28>, 1)
END
IF MYuid = 0 THEN
ATPERMS = 1
END
RETURN
!
* Special handling for distributed files
!
DO.PARTFILES:
PARTFILES = FILstatus<26>
newDELIM = 0
* Go do each partfile
LOOP
REMOVE CURRENT.FILE FROM PARTFILES SETTING newDELIM
* Open this file
OPEN CURRENT.FILE TO PART.VAR ELSE
* Unable to open %s
PRINT;CALL *UVPRINTMSG(32006, CURRENT.FILE)
* Get next
CONTINUE
END
* Get info
STATUS FILstatus FROM PART.VAR ELSE
* Unable to stat file %s
PRINT;CALL *UVPRINTMSG(32007, CURRENT.FILE)
* Get next
CONTINUE
END
INDENT=SPACE(5)
PARTFILE=FILstatus<24>
GOSUB DISPATCH:
CLOSE PART.VAR
UNTIL newDELIM = END.OF.STRING DO
REPEAT
RETURN
!
* Change list of indices
!
CHANGE.INDEX:
FILEopen = FALSE
* Update file header IDXOFF value
GOSUB OPEN.FILE:
IF pSTATUS = FALSE THEN GOTO SPIT.OUT.MESSAGE:
FILEopen = TRUE
* Get system type
GOSUB SYSTEM.TYPE:
* Go to location
SEEK SEQFILE,IDXOFFoffset,0 THEN
* read long
READBLK IDXOFFvalue FROM SEQFILE, IDXOFFlength ELSE
pSTATUS = FALSE
GOTO SPIT.OUT.MESSAGE:
END
END ELSE
pSTATUS = FALSE
GOTO SPIT.OUT.MESSAGE:
END
* Convert value based on machine type
IF MACHINE.TYPE = UNIXmachine THEN
IDXOFFvalue = getUNIXlong
END ELSE
IDXOFFvalue = getXINUlong
END
* Change value based on mode
BEGIN CASE
CASE INDEX.MODE = ENABLED
* Unset bit 0
IDXOFFvalue = BITRESET(IDXOFFvalue, 0)
CASE INDEX.MODE = DISABLED
* Set bit 0
IDXOFFvalue = BITSET(IDXOFFvalue, 0)
CASE INDEX.MODE = CLEAR.TAG
* Unset bit 1
IDXOFFvalue = BITRESET(IDXOFFvalue, 1)
END CASE
* Convert this number back to ascii
number = IDXOFFvalue
GOSUB CONVERT.number.TO.ASCII:
* Go to location
SEEK SEQFILE,IDXOFFoffset,0 THEN
* Write out
WRITEBLK ASCII.NUMBER ON SEQFILE ELSE
pSTATUS = FALSE
END
END ELSE
pSTATUS = FALSE
END
SPIT.OUT.MESSAGE:
* Close
IF FILEopen = TRUE THEN
CLOSESEQ SEQFILE
END
* Print message
BEGIN CASE
CASE INDEX.MODE = ENABLED
BEGIN CASE
CASE USE.DICT = 0
IF pSTATUS = TRUE THEN
MESSAGE = UVREADMSG(35047,DICT:CURRENT.FILE)
END ELSE
MESSAGE = UVREADMSG(35050,DICT:CURRENT.FILE)
END
CASE USE.DICT = WANT.DICT
IF pSTATUS = TRUE THEN
MESSAGE = UVREADMSG(35045,DICT:CURRENT.FILE)
END ELSE
MESSAGE = UVREADMSG(35048,DICT:CURRENT.FILE)
END
CASE USE.DICT = WANT.PDICT
IF pSTATUS = TRUE THEN
MESSAGE = UVREADMSG(35046,DICT:CURRENT.FILE)
END ELSE
MESSAGE = UVREADMSG(35049,DICT:CURRENT.FILE)
END
END CASE
CASE INDEX.MODE = DISABLED
BEGIN CASE
CASE USE.DICT = 0
IF pSTATUS = TRUE THEN
MESSAGE = UVREADMSG(35053,DICT:CURRENT.FILE)
END ELSE
MESSAGE = UVREADMSG(35056,DICT:CURRENT.FILE)
END
CASE USE.DICT = WANT.DICT
IF pSTATUS = TRUE THEN
MESSAGE = UVREADMSG(35051,DICT:CURRENT.FILE)
END ELSE
MESSAGE = UVREADMSG(35054,DICT:CURRENT.FILE)
END
CASE USE.DICT = WANT.PDICT
IF pSTATUS = TRUE THEN
MESSAGE = UVREADMSG(35052,DICT:CURRENT.FILE)
END ELSE
MESSAGE = UVREADMSG(35055,DICT:CURRENT.FILE)
END
END CASE
CASE 1
MESSAGE = ""
END CASE
IF MESSAGE # "" THEN PRINT MESSAGE<1>
RETURN
!
* Change AKdirPATH in file header
!
MOVE.INDEX.PATH:
UPDATEpath = TRUE
* Get path
GOSUB GET.INDEX.PATH:
* Split into PARENT and CHILD
IF OS.TYPE = "MSWIN" THEN
INDEX.DIRPATH = CONVERT( "\", "/", INDEX.DIRPATH )
END
PARENT = FIELD(INDEX.DIRPATH,"/",1,COUNT(INDEX.DIRPATH,"/"))
CHILD = "/":FIELD(INDEX.DIRPATH,"/",DCOUNT(INDEX.DIRPATH,"/"),1)
IF CHILD = '/' THEN
CHILD = "/I_":DICT:CURRENT.FILE[1,LONGNAMES]
INDEX.DIRPATH = "No indices path currently defined."
END
IF INDEX(MOVE.PATH,"I_",1) THEN
CHILD = ""
END
* Display?
IF PROMPTING = TRUE THEN
* The current indices for this file are at unix path:
PRINT
CALL *UVPRINTMSG(32202, DICT:CURRENT.FILE:@fm:INDEX.DIRPATH:@fm:MOVE.PATH:CHILD)
INPUT ANX
ANX = UPCASE(ANX)
* If not a Y, then no update
IF ANX[1,1] # "Y" THEN UPDATEpath = FALSE
* Does path exist?
IF UPDATEpath = TRUE THEN
OPENPATH MOVE.PATH:CHILD TO TMPfile THEN
STATUS TMPstatus FROM TMPfile ELSE TMPstatus=""
* Check that is type1 or type19
IF TMPstatus<21> # 1 AND TMPstatus<21> # 19 THEN
* "Unix path is not a directory. Continue (Y/N)?"
PRINT;CALL *UVPRINTMSG(32203,"")
INPUT ANX
ANX = UPCASE(ANX)
* If not a Y, then no update
IF ANX[1,1] # "Y" THEN UPDATEpath = FALSE
END
CLOSE TMPfile
END ELSE
* "Unix path does not exist. Continue (Y/N)?"
PRINT;CALL *UVPRINTMSG(32204,"")
INPUT ANX
ANX = UPCASE(ANX)
* If not a Y, then no update
IF ANX[1,1] # "Y" THEN UPDATEpath = FALSE
END
END
END
* Make new path
INDEX.DIRPATH = MOVE.PATH:CHILD
* Make certain does not exceed the max chars in length
IF BYTELEN(INDEX.DIRPATH) > AKPATHlength THEN
* Index directory path name "%n" exceeds %i character limit.
PRINT;CALL *UVPRINTMSG(35026,INDEX.DIRPATH:@fm:AKPATHlength)
UPDATEpath = FALSE
END
* Change
IF UPDATEpath = TRUE THEN
* Write change
GOSUB WRITE.INDEX.PATH:
* "File header block updated."
CALL *UVPRINTMSG(32205,"")
END
* Close
CLOSESEQ SEQFILE
RETURN
!
* Clear AKdirPATH in file header
!
CLEAR.INDEX.PATH:
UPDATEpath = TRUE
* Get path
GOSUB GET.INDEX.PATH:
* Display?
IF PROMPTING = TRUE THEN
* The current indices for this file are at unix path:
PRINT
PRINT "The current indices for file '":DICT:CURRENT.FILE:"' are at unix path:"
PRINT
PRINT " ":INDEX.DIRPATH
PRINT
PRINT "Do you wish to remove this path (Y/N)? ":
INPUT ANX
ANX = UPCASE(ANX)
* If not a Y, then no update
IF ANX[1,1] # "Y" THEN UPDATEpath = FALSE
END
* Make new path
INDEX.DIRPATH = str(BYTE(0),AKPATHlength)
* Make certain does not exceed the max chars in length
IF BYTELEN(INDEX.DIRPATH) > AKPATHlength THEN
* Index directory path name "%n" exceeds %i character limit.
PRINT;CALL *UVPRINTMSG(35026,INDEX.DIRPATH:@fm:AKPATHlength)
UPDATEpath = FALSE
END
* Change
IF UPDATEpath = TRUE THEN
* Write change
GOSUB WRITE.INDEX.PATH:
* "File header block updated."
CALL *UVPRINTMSG(32205,"")
END
* Close
CLOSESEQ SEQFILE
RETURN
!
* Display AKdirPATH in file header
!
SHOW.INDEX.PATH:
* Get path
GOSUB GET.INDEX.PATH:
IF pSTATUS = FALSE THEN RETURN
* Partfile prefix
IF PARTFILE > 0 THEN
PRINT "Part File ":PARTFILE:":"
PRINT INDENT:
END
* "Indices for file '":DICT:CURRENT.FILE:"' reside in '":INDEX.DIRPATH:"'."
CALL *UVPRINTMSG(32206,DICT:CURRENT.FILE:@fm:INDEX.DIRPATH)
* Close
CLOSESEQ SEQFILE
RETURN
!
* Get the AKpath from the file header
!
GET.INDEX.PATH:
* Open file
GOSUB OPEN.FILE:
IF pSTATUS = FALSE THEN
* Unable to read index directory name in file header block.
PRINT;CALL *UVPRINTMSG(35030,"")
RETURN
END
* Go to location
SEEK SEQFILE,AKPATHoffset,0 ELSE
* Unable to read index directory name in file header block.
PRINT;CALL *UVPRINTMSG(35030,"")
pSTATUS = FALSE
RETURN
END
* Read in maximum bytes
READBLK INDEX.DIRPATH FROM SEQFILE,AKPATHlength ELSE
* Unable to read index directory name in file header block.
PRINT;CALL *UVPRINTMSG(35030,"")
pSTATUS = FALSE
RETURN
END
* Truncate after first char(0)
IF INDEX(INDEX.DIRPATH,BYTE(0),1) THEN
INDEX.DIRPATH = INDEX.DIRPATH[1,INDEX(INDEX.DIRPATH,BYTE(0),1)-1]
END
RETURN
!
* Write the AKpath to the file header
!
WRITE.INDEX.PATH:
* Open file
GOSUB OPEN.FILE:
IF pSTATUS = FALSE THEN
* Unable to write index directory name in file header block.
PRINT;CALL *UVPRINTMSG(35029,"")
RETURN
END
* Go to location
SEEK SEQFILE,AKPATHoffset,0 ELSE
* Unable to write index directory name in file header block.
PRINT;CALL *UVPRINTMSG(35029,"")
pSTATUS = FALSE
RETURN
END
* Pad to AKPATHlength
INDEX.DIRPATH = (INDEX.DIRPATH:STR(BYTE(0),AKPATHlength))("L#":AKPATHlength)
* Write in maximum bytes
WRITEBLK INDEX.DIRPATH ON SEQFILE ELSE
* Unable to write index directory name in file header block.
PRINT;CALL *UVPRINTMSG(35029,"")
pSTATUS = FALSE
RETURN
END
RETURN
!
* Open file sequentially
!
OPEN.FILE:
ABSOLUTE.FILE = FILstatus<27>
* If a DYNAMIC, make certain full path has DATA.30. A remote file
* should already have it, while a local file won't
IF FILstatus<21> = 30 AND FILstatus<27>[8] # "/DATA.30" THEN
ABSOLUTE.FILE := "/DATA.30"
END
* Open 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 ABSOLUTE.FILE TO SEQFILE ELSE
pSTATUS = FALSE
END
IF SYSTEM(100) THEN
* Restore the original sequential file map
IGNORE = NLSsetseqmap(OLD.SEQ.MAP)
END
RETURN
!
* Determine UNIX or XINU system
!
SYSTEM.TYPE:
* Seek to beginning of file
SEEK SEQFILE, 0, 0 ELSE
* "Unable to seq in "%s"."
PRINT;CALL *UVPRINTMSG(85310,ABSOLUTE.FILE)
pSTATUS = FALSE
RETURN
END
* Read first two characters
READBLK MACHINE.TYPE FROM SEQFILE, 2 ELSE
* Cannot read %s from %s file
PRINT;CALL *UVPRINTMSG(85310,"File Id":@fm:ABSOLUTE.FILE)
pSTATUS = FALSE
RETURN
END
* Convert - a UNIX system will have 'ACEF(base16)' or '44271(base10)'
MACHINE.TYPE = byteval(MACHINE.TYPE,1) * 256 + byteval(MACHINE.TYPE,2)
RETURN
!
* Convert a number to a LONG
!
CONVERT.number.TO.ASCII:
ASCII.NUMBER = STR(BYTE(0),4)
spot = 1
FOR p = 4 TO 1 STEP -1
temp = INT(number/POWER(p))
IF MACHINE.TYPE = UNIXmachine THEN
ASCII.NUMBER = BYTEreplace(ASCII.NUMBER,spot,1,BYTE(temp))
spot += 1
END ELSE
ASCII.NUMBER = BYTEreplace(ASCII.NUMBER,spot+(p-1),1,BYTE(temp))
END
* Decrement value
number -= (temp*POWER(p))
NEXT p
RETURN
!
* End of code
!
END
Reference in New Issue Copy Permalink