open-insight/SYSPROG/STPROC/SYSLISTS_SETALIAS_SUB.txt
2024-03-25 15:17:34 -07:00

1032 lines
27 KiB
Plaintext

SUBROUTINE SYSLISTS_SETALIAS_SUB(VOLUME, ACCOUNT, PASSWORD, TABLE, ALIASNAME, OPTIONS)
$INSERT U2ATVARS
Declare Function DO_XSWAP
*#ADDED 1,2
*#SOURCE SYSPROCS
* MTR 12-6-06 Compiled for Arev32/OI80
*#CTO
*#Precompile
*
*#FLAVOR AREV32
*÷ COMMON Variables (Terminate with '%') :
*÷ LABELED COMMON Variables (Terminate with '@') :
*÷ EQUATE Variables (Terminate with '$') :
*$INSERT AREV_BP, COPYRIGHT
* This insert contains the copyright message. This insert should be
* inserted into all programs.
Copy_%%_Right = 'Copyright (C) 1994 Revelation Technologies, Inc.'
* Source Date: 11:35:08 06 MAY 1994 Build ID: AREV_HR*3.1.39 Level: 3.13
*$insert arev_bp, logical
equ otherwise$ to 1
equ true$ to 1
equ false$ to 0
equ yes$ to 1
equ no$ to 0
* Source Date: 12:39:24 10 MAY 1994 Build ID: AREV_HR*3.1.41 Level: 3.13
*$INSERT AREV_BP, FILE.SYSTEM.EQUATES
* Advanced Revelation filing system action codes.
EQU READ.RECORD TO 1
EQU READO.RECORD TO 2
EQU WRITE.RECORD TO 3
EQU DELETE.RECORD TO 4
EQU LOCK.RECORD TO 5
EQU UNLOCK.RECORD TO 6
EQU SELECT TO 7
EQU READNEXT TO 8
EQU CLEARSELECT TO 9
EQU CLEARFILE TO 10
EQU OPEN.FILE TO 11
EQU CREATE.FILE TO 12
EQU RENAME.FILE TO 13
EQU MOVE.FILE TO 14
EQU DELETE.FILE TO 15
EQU OPEN.MEDIA TO 16
EQU CREATE.MEDIA TO 17
EQU READ.MEDIA TO 18
EQU WRITE.MEDIA TO 19
EQU UNLOCK.ALL TO 20
EQU FLUSH TO 21
EQU INSTALL TO 22
*EQU RESERVED TO 23
*EQU RESERVED TO 24
*EQU RESERVED TO 25
EQU OMNI.SCRIPT TO 26
* Following OMNI.SCRIPT sub-codes are passed in the FMC
EQU OMNIBUS_LIST$ TO 'GROUP_NUMBER'
EQU OMNIBUS_CALL$ TO 0 ;* Required
EQU SMART_TEST$ TO 1 ;* Required - returns 0 in FLAG if
* bond is NOT smart. Otherwise returns
* an intelligence factor in FLAG.
EQU SCRIPT_CALL$ TO 2 ;* Intelligent database language script
* for smart bonds only
EQU SCRIPT_OK_CALL$ TO 3 ;* For smart bonds only. If true then
* asynchronous processesing is used.
EQU CLOSE.MEDIA TO 27
EQU RECORD.COUNT TO 28
EQU REMAKE.FILE TO 29
EQU CREATE.INDEX TO 30
EQU DELETE.INDEX TO 31
EQU UPDATE.INDEX TO 32
EQU SELECT.INDEX TO 33
EQU READNEXT.INDEX TO 34
* Source Date: 16:41:43 12 JAN 1993 Build ID: OI*1.0.10 Level: 2.0
*$INSERT AREV_BP, FSERRORS_HDR
* Advanced Revelation Filing System Error reporting protocol
*
* Error conditions are to be returned by BFSs and MFSs in the @FILE.ERROR
* variable. Each error code has an associated severity level.
* If an error condition is encountered, the filing system code should set
* 1. @FILE.ERROR to the associated code and fill in the message and detail
* as appropriate
* 2. Set STATUS() to the associated severity level
* 3. Set the FLAG (7th argument) to FALSE$ to indicate an operational failure.
*
* If FLAG is set to false, then the operation is defined to have failed.
* It is important for the application to know that a WRITE or DELETE was
* in fact not performed. Setting FLAG to FALSE is not an appropriate protocol
* for communicating any non-failure (informational) condition from the
* filing system.
*
* "Core" error codes are blocked in groups of 100 and are integer codes.
* Block 0 - 99 is allocated for logical error reporting.
* Block 100 - 199 is allocated for Revelation system BFS error codes.
* Block 200 - 299 is allocated for Revelation system MFS error codes.
* Block 300 - 399 is allocated for BOND.SUBS errors
* Blcok 400 - 499 is allocated for System, RTP, and R/BASIC cursor errors
*
* Some codes are intrinsically specific to the function of a particular
* BFS or MFS. Others may be and should be generally applied to a variety
* of filing systems. For example, code 100 is the standard status return in
* case of an attempt to read or delete a record which does not exist.
*
* Block BS - Bond-subs - is allocated for codes associated with the BOND.SUBS
* routine.
*
* Every error code should have an associated message in the MESSAGES file.
* The ID of the message should be error code preceeded by "FS".
* For example, code 105 would have an associated message "FS105"
* If any parameters are to be passed to this message they should appear in
* the FSMSG field of @FILE.ERROR. This field may be multivalued.
*---- FILING SYSTEM SEVERITY LEVEL CODES --------
* Value of STATUS() on return from Filing System.
*
Equate Fs_Informational$ To -2 ;* @File.Error contain FYI info.
EQUATE FS_USER_ABORT$ TO -1 ;* The user pressed [Esc], SPECIAL!
EQUATE FSLOGICAL$ TO 0 ;* Data does not meet logical constraints
EQUATE FSPHYSICAL$ TO 1 ;* Structural or operational error (retryable)
EQUATE FSFATAL$ TO 2 ;* Structural or operational error (fatal)
*---- FILE.ERROR FIELD STRUCTURE -------
EQUATE FSCODE$ TO 1 ;* error or status code identifier
EQUATE FSMSG$ TO 2 ;* error message data
EQUATE FSDETAIL$ TO 3 ;* file system dependent detail data
EQUATE FS_PREFIX$ TO 'FS' ;* used by OE for set_status Pat Oct/04/91
* Source Date: 11:34:13 10 MAY 1994 Build ID: AREV_HR*3.1.40 Level: 3.13
*$Insert SYSTABLE_NAMES
*compile insert SYSTABLE_NAMES
equ sysdict_file$ to "SYSDICT"
equ sysenv_file$ to "SYSENV"
equ syslists_file$ to "SYSLISTS"
equ syslogins_file$ to "SYSLOGINS"
equ sysobj_file$ to "SYSOBJ"
equ sysprocs_file$ to "SYSPROCS"
equ sysptrs_file$ to "SYSPTRS"
equ systables_file$ to "SYSTABLES"
equ sysviews_file$ to "SYSVIEWS"
equ sysvolumes_file$ to "SYSVOLUMES"
equ systypes_file$ to "SYSTYPES"
equ systypemaps_file$ to "SYSTYPEMAPS"
equ sysprocindex_file$ to "SYSPROCINDEX"
equ syscolumns_file$ to "SYSCOLUMNS"
equ accessible_columns$ to "ACCESSIBLE_COLUMNS"
equ syslhgroup_file$ to "SYSLHGROUP"
equ syslhverify_file$ to "SYSLHVERIFY"
equ importexport_file$ to "IMPORTEXPORT"
equ OsFile$ to "WINDOWS"
equ LogFile$ to "LOG"
equ SYSREPOS_FILE$ to "SYSREPOS"
equ SYSREPOS_TEMP_FILE$ to "SYSREPOS_TEMP"
equ SYSREPOSTYPES_FILE$ to "SYSREPOSTYPES"
equ SYSAPPS_FILE$ to "SYSAPPS"
equ SYSREPOSLOCKS_FILE$ to "SYSREPOSLOCKS"
equ SYSREPOSLOG_FILE$ to "SYSREPOSLOG"
equ SYSREPOSWINS_FILE$ to "SYSREPOSWINS"
equ SYSREPOSWINEXES_FILE$ to "SYSREPOSWINEXES"
equ SYSREPOSEVENTS_FILE$ to "SYSREPOSEVENTS"
equ SYSREPOSEVENTEXES_FILE$ to "SYSREPOSEVENTEXES"
equ SYSREPOSCLASSES_FILE$ to "SYSREPOSCLASSES"
equ SYSREPOSPOPUPS_FILE$ to "SYSREPOSPOPUPS"
equ SYSREPOSMESSAGES_FILE$ to "SYSREPOSMESSAGES"
equ SYSREPOSAPPNOTES_FILE$ to "SYSREPOSAPPNOTES"
equ SYSREPOSREPORTS_FILE$ to "SYSREPOSREPORTS"
equ SYSREPOSRELEASES_FILE$ to "SYSREPOSRELEASES"
equ SYSREPOSVIEWS_FILE$ to "SYSREPOSVIEWS"
equ SYSREPOSSTORAGE_FILE$ to "SYSREPOSSTORAGE"
equ SYSREPOSTYPEFAMILIES_FILE$ to "SYSREPOSTYPEFAMILIES"
equ SYSREPOSDATASOURCES_FILE$ to "SYSREPOSDATASOURCES"
equ SYSREPOSDBCOMPONENTS_FILE$ to "SYSREPOSDBCOMPONENTS"
equ SYSREPOSDBCOMPONENTEXES_FILE$ to "SYSREPOSDBCOMPONENTEXES"
equ sysreposxml_file$ to "SYSREPOSXML"
equ sysreposlanguage_file$ to "SYSREPOSLANGUAGE"
EQU SYSREPOSMENUCONTEXT_FILE$ TO 'SYSREPOSMENUCONTEXT'
EQU AVERYLABELS_FILE$ TO 'AVERYLABELS'
* MTR 12-6-06 FOR aREV32
Equ DefaultSysAliasFile$ To "SYSALIAS"
Equ SysAliasesFile$ To "SYSALIASES"
* Source Date: 10:20:52 22 SEP 2003 Build ID: OI*7.0.0 Level: 2.61
*$INSERT SYSCOMMON
*compile insert SysCommon
******************************************************************************
*
* This program is proprietary and is not to be used by or disclosed
* to others, nor is it to be copied without written permission from
* Revelation Technologies, Inc.
*
* Name : SysCommon
* Description: OpenEngine System Common variable declarations
*
* History : (date, initials, notes)
* 08-13-91 ba original programmer
* 10-31-91 rkh removed SC_TIMEDATE_FMT (#215), per fix 4831 and 4813
* 01-18-94 gg changed SC_UNUSED73 to SC_CONCURRENCY
* 04-05-94 Pat changed SC_UNUSED_107 to SC_ENGINE_LOGGING_REQ;the
* semaphore between oengine.exe and revexec.dll
* 04-25-94 Slj changed SC_UNUSED_78 to SC_ATWINDOW for event handlers
* 05-16-94 Pat change SC_UNUSED_165 to SC_CTRL_TYPES
* 06-13-94 tmc 10695 changed SC_ARRAY_VOLUMES to dim of 6 (was 5)
* 06-24-95 gg 11322 changed SC_UNUSED_155 to SC_DATASOURCETYPE
* 07-17-95 cp 11322 changed SC_UNUSED_154 to SC_XO_DEFAULTS
* 03-05-96 cp 11777 added SC_LHLICENSING SC_LHENABLED SC_LHFILESUSED
* (160-162)
* 08-05-96 gg 11853 changed PROGRAMS_DIM$ from '0299' to '0499'
* 06-23/97 cp added support for SYSLOGINS table (201-203)
*
******************************************************************************
equ FRAMES_DIM$ to 49
equ PROGRAMS_DIM$ to '0499' ;* appears in obj code's literal pool
equ SC_ARRAY_VOLUMES_OFFSET$ to 17
equ SC_ARRAY_TABLES_OFFSET$ to 19
*
SYSCOM SC_ATRM
SYSCOM SC_ATFM
SYSCOM SC_ATVM
SYSCOM SC_ATSVM
SYSCOM SC_TM
SYSCOM SC_STM
SYSCOM SC_CRLF
SYSCOM SC_FILE_SYSENV
SYSCOM SC_TIMEDATA
SYSCOM SC_FILE_SYSPTRS
SYSCOM SC_PROGLIST
SYSCOM SC_PROGRAMS(PROGRAMS_DIM$)
SYSCOM SC_FSTACK(1)
SYSCOM SC_FRAMELIST
SYSCOM SC_FRAMES(FRAMES_DIM$)
SYSCOM SC_FILE_VOLUMES
SYSCOM SC_ARRAY_VOLUMES(6)
SYSCOM SC_FILE_TABLES
SYSCOM SC_ARRAY_TABLES(5)
SYSCOM SC_FILES_NO_DETACH
SYSCOM SC_RTP1
SYSCOM SC_AFSNAMES
SYSCOM SC_FILE_SYSOBJ
SYSCOM SC_FILE_SYSDICT
SYSCOM SC_USER
SYSCOM SC_DBID
SYSCOM SC_LIST
SYSCOM SC_TODAY
SYSCOM SC_SUNDAY0
SYSCOM SC_SUNDAY7
SYSCOM SC_ATUSER0
SYSCOM SC_ATUSER1
SYSCOM SC_ATUSER2
SYSCOM SC_ATUSER3
SYSCOM SC_ATUSER4
SYSCOM SC_CURR_PROGRAM
SYSCOM SC_CURRENT_LINE
SYSCOM SC_SYSTEM_STATE
SYSCOM SC_DBG_BUFFER
SYSCOM SC_WORKLIST
SYSCOM SC_ATID
SYSCOM SC_ATREC
SYSCOM SC_DATA_LIST
SYSCOM SC_ADMIN
SYSCOM SC_SQL_PARAMS
SYSCOM SC_SQL_CURSPARAMS
SYSCOM SC_SQL_NCACHEIDS
SYSCOM SC_SQL_NCACHEDATA(8)
SYSCOM SC_FILE_SYSPROCS
SYSCOM SC_FLAGS
SYSCOM SC_SYSPROCNAMES
SYSCOM SC_SQL_SQBUFFS(20)
SYSCOM SC_SQL_SQBUFF_CURS
SYSCOM SC_SQL_CURS_SQBUFF
SYSCOM SC_SQL_CURSSLOTS
SYSCOM SC_SQL_PROJEX
SYSCOM SC_ATLIMIT
SYSCOM SC_NEXT_GROUP
SYSCOM SC_PRI_NAME
SYSCOM SC_PRI_DICT
SYSCOM SC_PRI_FILE
SYSCOM SC_COMPILER
SYSCOM SC_ATLIST_ACTIVE
SYSCOM SC_LIST_OFF
SYSCOM SC_REDUCTION_SPEC
SYSCOM SC_SORT_SPEC
SYSCOM SC_ATANS
SYSCOM SC_ATDICT
SYSCOM SC_SQL_FIRSTIDS
SYSCOM SC_SQL_LASTIDS
SYSCOM SC_SQL_SKIPWHERE
SYSCOM SC_SQL_LIKE
SYSCOM SC_CONCURRENCY
SYSCOM SC_ATCONV
SYSCOM SC_ATFORMAT
SYSCOM SC_ATHEADER
SYSCOM SC_DATE_FORMAT
SYSCOM SC_ATWINDOW
SYSCOM SC_IO_PROC
SYSCOM SC_ATRECUR0
SYSCOM SC_ATRECUR1
SYSCOM SC_ATRECUR2
SYSCOM SC_ATRECUR3
SYSCOM SC_ATRECUR4
SYSCOM SC_MVCOUNT
SYSCOM SC_ATRECCOUNT
SYSCOM SC_ATQUERY_DICT
SYSCOM SC_DST_RECORDS(9)
SYSCOM SC_DST_OFFSETS(9)
SYSCOM SC_DST_HANDLES(9)
SYSCOM SC_DST_HASHTABLES(9)
SYSCOM SC_ATLPTRWIDE
SYSCOM SC_ATLPTRHIGH
SYSCOM SC_FVSYSREPOS
SYSCOM SC_FVSYSREPOSLOG
SYSCOM SC_FILE_REPOSEXE
* SYSCOM SC_UNUSED_97
SYSCOM SC_ATTCL_STACK
SYSCOM SC_DRIVER
SYSCOM SC_LONG_LIST
SYSCOM SC_LIST_LEVEL
SYSCOM SC_ATCURSORS(8,12)
SYSCOM SC_SORT_FILE
SYSCOM SC_APPID
SYSCOM SC_APPINFO
SYSCOM SC_NEXTREQARGS
SYSCOM SC_IDXSVR
SYSCOM SC_ENGINE_LOGGING_REQ
SYSCOM SC_HUSH
SYSCOM SC_UNUSED_109
SYSCOM SC_ATSTATION
SYSCOM SC_UNUSED_111
SYSCOM SC_LINEAR_HASH_FRAMES
SYSCOM SC_ATHEADING
SYSCOM SC_ATFOOTING
SYSCOM SC_ATPAGE
SYSCOM SC_ATBREAK1
SYSCOM SC_ATBREAK2
SYSCOM SC_ATBREAK3
SYSCOM SC_ATFIRST_PAGE
SYSCOM SC_ATFIRST_COLHEAD
SYSCOM SC_ATCOLHEADING
SYSCOM SC_ATCOLLENGTH
SYSCOM SC_ATCOLHEAD
SYSCOM SC_ATCHACTIVE
SYSCOM SC_EXT_LIST
SYSCOM SC_CMDLINE
SYSCOM SC_LOCKED_USER_ID
SYSCOM SC_LABELED_COMMON_NAMES
SYSCOM SC_LABELED_COMMON_SPTS
SYSCOM SC_ATREDUCTION_DONE
SYSCOM SC_ATRETURN_VALUE
SYSCOM SC_XLATE_KEYS
SYSCOM SC_XLATE_LRU
SYSCOM SC_SYS_LOCKS(8)
SYSCOM SC_USER_LIST
SYSCOM SC_ADMIN_LIST
SYSCOM SC_PASSWORD_LIST
SYSCOM SC_XLATE_RESET
SYSCOM SC_PROT_DOCONV
SYSCOM SC_PROT_DEFCONV
SYSCOM SC_PROT_LOCKMODE
SYSCOM SC_PROT_HANDLES
SYSCOM SC_PROT_TABLEDATA
SYSCOM SC_PROT_TRANSSTATE
SYSCOM SC_PROT_TRANSDATA
SYSCOM SC_PROT_CONSISTENCY
SYSCOM SC_PROT_TABLELOCKS(8)
SYSCOM SC_PROT_LOCKDATA(7)
SYSCOM SC_PROT_TRANSHANDLES
SYSCOM SC_PROT_CURSCONV
SYSCOM SC_PROT_SPECS
SYSCOM SC_PROT_SPECS_LRU
SYSCOM SC_UNUSED_153
SYSCOM SC_XO_DEFAULTS
SYSCOM SC_DATASOURCETYPE
SYSCOM SC_ATPSEUDO
SYSCOM SC_UNUSED_157
SYSCOM SC_ATUPPER_CASE
SYSCOM SC_ATLOWER_CASE
SYSCOM SC_LHLICENSING
SYSCOM SC_LHENABLED
SYSCOM SC_LHFILESUSED
SYSCOM SC_UNUSED_163
SYSCOM SC_UNUSED_164
SYSCOM SC_CTRL_TYPES
SYSCOM SC_REPOSMIRROR
SYSCOM SC_ATDEFAULT_STOPS
SYSCOM SC_UNUSED_168
SYSCOM SC_QHANDLE
SYSCOM SC_REQID
SYSCOM SC_EXEC_COMMAND
SYSCOM SC_SPSTATUS
SYSCOM SC_SPSTATCODE
SYSCOM SC_SPSTATTEMPL
SYSCOM SC_SPABORT
SYSCOM SC_SPTYPE
SYSCOM SC_SPARGDTYPES
SYSCOM SC_SPRECDTYPES
SYSCOM SC_SPWRECDTYPES
SYSCOM SC_UNUSED_180
SYSCOM SC_UNUSED_181
SYSCOM SC_UNUSED_182
SYSCOM SC_UNUSED_183
SYSCOM SC_UNUSED_184
SYSCOM SC_UNUSED_185
SYSCOM SC_UNUSED_186
SYSCOM SC_UNUSED_187
SYSCOM SC_UNUSED_188
SYSCOM SC_UNUSED_189
SYSCOM SC_ENCACTIVE
SYSCOM SC_UNUSED_191
SYSCOM SC_UNUSED_192
SYSCOM SC_UNUSED_193
SYSCOM SC_UNUSED_194
SYSCOM SC_DICT_MODE
SYSCOM SC_UNUSED_196
SYSCOM SC_UNUSED_197
SYSCOM SC_UNUSED_198
SYSCOM SC_UNUSED_199
SYSCOM SC_UNUSED_200
SYSCOM SC_FILE_SYSLOGINS
SYSCOM SC_KEY_SYSLOGINS
SYSCOM SC_LOGGED_ON
SYSCOM SC_CHAR_MAPS
SYSCOM SC_ATFILE_ERROR
SYSCOM SC_MEM_ALLOC
SYSCOM SC_INDEXLIST
SYSCOM SC_ATROLLOUT_FILE
SYSCOM SC_ATFILE_ERROR_MODE
SYSCOM SC_LOCKED_TABLES
SYSCOM SC_EP
SYSCOM SC_LND_DATA
SYSCOM SC_LND_NAMES
SYSCOM SC_LND_POINT
*SYSCOM SC_UNUSED_215
SYSCOM SC_HW_ENV
* MTR 11-3-06 SYSCOM SC_UNUSED_216
SYSCOM SC_ATLEVEL
SYSCOM SC_ATPRECISION
SYSCOM SC_CM_NAMES
SYSCOM SC_CM_POINT
SYSCOM SC_ATENVIRON_SET
*
* mtr 12-6-06
* We extended the SC addressspace to 250 today in order to bring back more of the system common needed for Arev32, and to add some more as needed for the pick compatibility.
SYSCOM SC_SAVE(8,26)
SYSCOM SC_ATCRT_MAX_Y
SYSCOM SC_DEMO
SYSCOM SC_TCL_STATE
SYSCOM SC_RESET_ROUTINE
SYSCOM SC_ATSENTENCE
SYSCOM SC_FILE_VOC
SYSCOM SC_DICT_VOC
SYSCOM SC_CHAIN_LINE
SYSCOM SC_PARSE_TCL
SYSCOM SC_VERB
SYSCOM SC_VERBS_FILE
SYSCOM SC_BREAKKEY
SYSCOM SC_ABORT_FLAG
SYSCOM SC_ATSCREEN_SAVE
SYSCOM SC_ATVIEW_MODE
SYSCOM SC_VIEW_SCREEN
SYSCOM SC_VIEW_PARAMS
SYSCOM SC_MULTI_LIMIT
SYSCOM SC_CURR_EXEC_CNT
SYSCOM SC_FROM_PROC
SYSCOM SC_ATSAVE_SELECT
SYSCOM SC_BREAK_TABLE
SYSCOM SC_TRACE_TABLE
SYSCOM SC_PROMPT_STR
SYSCOM SC_OPTIONS
SYSCOM SC_OPTLIST
SYSCOM SC_MOD_FLAGS
SYSCOM SC_LOADER_SEMAPHORE
*
EQU NETWORK.FLAG TO BITAND(RUNTIME(),32768)
EQU NETWORK.MASK TO \48692047656E6521\
*
* Meta objects are stored in the FRAMES array so they can be thrown
* out by the garbage collect if necessary.
*
EQU ROS.FRAME.CACHE TO 0
EQU ROS.FRAME.CACHE.TOP TO 9
EQU OCONV.RUN TO SC_FRAMES(10)
EQU WITH.RUN TO SC_FRAMES(11)
EQU WITH0.RUN TO SC_FRAMES(12)
EQU SORT.RUN TO SC_FRAMES(13)
EQU TEMPLATE.CACHE TO 14
EQU TEMPLATE.NAMES TO SC_FRAMES(14)
EQU TEMPLATE.CACHE.TOP TO 40
EQU XLATE.CACHE TO 41
EQU XLATE.CACHE.TOP TO 49
EQU NULL$ TO ""
EQU SPACE$ TO \20\
EQU DBODELIM$ TO \2E\ ;* Databse owner delimiter "."
*÷ MESSAGES called (Terminate with '$') :
EQU BADPASS$ TO "W125" ;* Incorrect password
EQU BADACCT$ TO "W116" ;* Invalid account name
EQU UNAVAIL$ TO "W505" ;* X is unavailable after Y
EQU MISMATCH$ TO "W500" ;* Mismatch between volumes and files
EQU NOEXIST$ TO "W517" ;* Unable to attach "file" in the "account" on the "volume"
*÷ DECLARED - FUNCTIONS called :
DECLARE FUNCTION UNASSIGNED
*÷ DECLARED - SUBROUTINES called :
DECLARE SUBROUTINE RTP49
*÷÷ PROGRAM TOP
!
IF UNASSIGNED(Options) THEN Options = NULL$
IF UNASSIGNED(AliasName) THEN
AliasName = DefaultSysAliasFile$
END
SaveAlias = AliasName
@FILE.ERROR = NULL$
Errors = NULL$
SysUser = SC_USER
CONVERT ".$-" TO "___" IN SysUser
*
IF @USERNAMENE 'SYSPROG' THEN
IF Account NE 'GLOBAL' THEN
IF Account NE @USERNAMETHEN
READ Rec FROM SC_FILE_SYSENV, Account THEN
IF Rec<1> = 'ACCOUNT' THEN
Encrypt.Data = Password
IF LEN(Encrypt.Data) THEN
gosub ENCRYPT.DATA
END
IF Rec<6> = Encrypt.Data ELSE
IF Rec<7> THEN
EncryptedPassword = Encrypt.Data
Ok = FALSE$
Cnt = COUNT(Rec<7>, @VM) + (Rec<7> NE NULL$)
For J = 1 to Cnt
Encrypt.Data = Rec<7, J>
gosub ENCRYPT.DATA
IF Encrypt.Data = EncryptedPassword THEN
Ok = TRUE$
END
Next J
IF Ok ELSE
Errors := @RM : BADPASS$
END
END ELSE
Errors := @RM : BADPASS$
END
END
END ELSE
Errors := @RM : BADACCT$ : @fm : Account
END
END ELSE
Errors := @RM : BADACCT$ : @fm : Account
END
END
END
END
IF Errors ELSE
IF Table[1, 5] = "DATA." THEN
RealName = Table[6, len(table)]
END ELSE
RealName = Table
END
RTP49(Volume, 0, VolumeRec, NULL$)
IF @FILE.ERROR THEN
Errors := @RM : @FILE.ERROR
END ELSE
VolumeFiles = VolumeRec<3>
MapFS = VolumeRec<4>
CONVERT @VM TO @SVM IN MapFS
Pos = COUNT(MapFS, @SVM)
IF Pos THEN
MapFS1 = MapFS<1, 1, 1>
MapBFS = MapFS<1, 1, Pos + 1>
END ELSE
MapFS1 = MapFS
MapBFS = MapFS
END
MapHandle = VolumeRec<5>
gosub SET_QFILE
IF Status THEN
IF WRITE.OPT OR INDEX(Options, "W", 1) THEN
* FOO If DO_OPEN('',SysAliasesFile$ ,FileQfiles ) ELSE
OPEN SYSALIASESFILE$ TO FILEQFILES ELSE
FileQfiles = SC_FILE_VOC
END
CTO%KPLK=0;CALL WRITE_LOCK(FileQfiles,AliasName ,DefaultSysAliasFile$:@FM:Account:@FM:Table:@fm:Volume ,'',CTO%KPLK);if CTO%KPLK = '0' ELSE
Errors := @RM : @FILE.ERROR
END
END
IF Table[1, 5] = "DICT." OR TABLE[1, 5] = "DATA." or table[1,1] = '!' ELSE
RealName = 'DICT.' : Table
AliasName = 'DICT.' : AliasName
gosub SET_QFILE
IF Status THEN
RealName = '!' : Table
AliasName = '!' : AliasName[6,len(aliasname)]
gosub SET_QFILE
END
END
VolumeRec<3> = VolumeFiles
GOSUB_PARAM = Volume:@FM:VolumeRec
gosub WRITE_VOLUMES
END ELSE
Errors := @RM : NOEXIST$ : @FM : RealName : @VM : Account : @VM : Volume
END
END
END
IF Errors THEN
@FILE.ERROR = Errors[2, LEN(Errors)]
STATUS() = FSLOGICAL$
END ELSE
@FILE.ERROR = NULL$
END
TRANSFER SaveAlias TO AliasName
return
*-----------------------------------------------------------------------------
SET_QFILE:
Status = FALSE$
IF RealName = "REVMEDIA" THEN
IF Account = "SYSPROG" THEN
gosub DETACH_FILE
GOSUB_PARAM = AliasName:@FM:Volume:@FM:RealName:@FM:Account:@FM:MapFS:@FM:MapHandle
gosub WRITE_FILES
LOCATE AliasName IN VolumeFiles USING @VM SETTING I ELSE
VolumeFiles = INSERT(VolumeFiles,1,I,0,AliasName)
END
Status = TRUE$
return
END
END
gosub GET_FILE_REC
IF Status THEN
gosub DETACH_FILE
FileRec = FileRec<2>
IF MapBFS NE "RTP59" THEN
IF RealName[1, 5] = "DICT." THEN
FileRec = INSERT(FileRec, 1, 1, 0, "DICT.MFS")
END
LOCATE "PROTECT.MFS" IN FileRec USING @VM SETTING Pos THEN
IF POS > 1 THEN
FileRec = DELETE(FileRec, 1, Pos, 0)
FileRec = INSERT(FileRec, 1, 1, 0, "PROTECT.MFS")
END
END
END
*--> 12-25-93 - janem - bug #12320, #13921
If Table[1,5] = 'DATA.' Then
Locate "SI.MFS" in FileRec Using @vm Setting Pos Then
FileRec = Delete(Filerec,1,Pos,0)
End
End
*--> 12-25-93 - janem - bug #12320, #13921
GOSUB_PARAM = AliasName:@FM:Volume:@FM:RealName:@FM:Account:@FM:INSERT(FileRec,1,-1,0,MapFS)
gosub WRITE_FILES
LOCATE AliasName IN VolumeFiles USING @VM SETTING Pos ELSE
VolumeFiles = INSERT(VolumeFiles, 1, Pos, 0, AliasName)
END
BEGIN CASE
CASE AliasName = SysPtrs_File$
If DO_OPEN('',SysPtrs_File$ ,SC_FILE_VOC ) ELSE
Status = FALSE$
END
CASE AliasName = SysDict_File$
If DO_OPEN('',SysDict_File$ ,SC_DICT_VOC ) ELSE
Status = FALSE$
END
CASE AliasName = SysObj_File$
If DO_OPEN('',SysObj_File$ ,SC_FILE_VERBS ) ELSE
Status = FALSE$
END
END CASE
IF Status ELSE
Errors := @RM : UNAVAIL$ : @FM : AliasName : @VM : "SetAlias_Sub"
END
END
return
*----------------------------------------------------------------------------
GET_FILE_REC:
Status = FALSE$
NameTemp = RealName
IF NameTemp[1,1] = '!' THEN
Bang = '!'
NameTemp[1,1] = NULL$
END ELSE
Bang = ''
END
IF NameTemp[1,5] = "DICT " OR NameTemp[1,5] = "DICT." THEN
Dict = "DICT."
NameTemp[1,5] = ''
NameTemp = DO_XSWAP('TRIM',NameTemp)
END ELSE
Dict = NULL$
END
If NameTemp[1,5] = "DATA " or NameTemp[1,5] = "DATA." Then
Dict = "DATA."
NameTemp[1,5] = ''
NameTemp = DO_XSWAP('TRIM',NameTemp)
End
UserSpec = ''
AtIX = INDEX(NameTemp, DBODELIM$, 1)
IF AtIX THEN
UserSpec = NameTemp[1, AtIX - 1]
NameTemp[1,AtIX] = ''
END
IF UserSpec THEN
RealName = Bang:Dict:UserSpec:DBODELIM$:NameTemp
END ELSE
RealName = Bang:Dict:SysUser:DBODELIM$:NameTemp
END
call @MapFS1(READO.RECORD, MapFS, MapHandle, RealName:'*':Account, '', FileRec, Status)
if status else
CALL @MapFS1(READO.RECORD, MapFS, MapHandle, RealName:'*GLOBAL', '', FileRec, Status)
if status then
Account = 'GLOBAL'
end else
RealName = Bang:Dict:NameTemp
CALL @MapFS1(READO.RECORD, MapFS, MapHandle, RealName:'*':Account, '', FileRec, Status)
if status else
CALL @MapFS1(READO.RECORD, MapFS, MapHandle, RealName:'*GLOBAL', '', FileRec, Status)
if status then
Account = 'GLOBAL'
end
end
end
end
return
*----------------------------------------------------------------------------
DETACH_FILE:
GOSUB_PARAM = AliasName
gosub READ_FILES
IF GOSUB_RETURN THEN
OrgVolume = GOSUB_RETURN<1>
IF OrgVolume NE Volume THEN
GOSUB_PARAM = OrgVolume
gosub READ_VOLUMES
IF GOSUB_RETURN THEN
LOCATE AliasName IN GOSUB_RETURN<3> USING @VM SETTING I THEN
GOSUB_PARAM = OrgVolume:@FM:DELETE(GOSUB_RETURN, 3, I, 0)
gosub WRITE_VOLUMES
END ELSE
Errors := @RM : MISMATCH$ : @FM : "SetAlias_Sub"
END
END ELSE
Errors := @RM : MISMATCH$ : @FM : "SetAlias_Sub"
END
END
END
return
*$INSERT AREV_BP, FILE_VOL_GOSUB
*
*
!
*
* This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied
* without written permission from COSMOS, INC.
*
!
*
*÷ VERSION : Arev 2.0
*
*÷ PURPOSE : Simulate READ, WRITE and DELETE calls to the FILES and
* VOLUMES files.
* It is 3 times faster to retrieve information directly
* from the system variables as opposed to using the
* RTP50 filing system.
*
*÷ AUTHOR : John Paul Voelk
*
*÷ CREATED : 9-11-89
*
*÷ PROCEDURES :
*
*÷ WARNINGS :
*
!
*÷ REVISION HISTORY (Most CURRENT first) :
* DATE IMPLEMENTOR FUNCTION
* -------- ----------- --------
* DD-MM-YY initials Modification
!
*÷ THEORY OF OPERATION :
READ_FILES:
*
* Pass in Record to be read in GOSUB_PARAM variable. Record is returned
* in the GOSUB_RETURN variable. If this is null (0 length) then the
* record doesn't exist.
*
GOSUB_RETURN = ''
LOCATE GOSUB_PARAM IN SC_ARRAY_TABLES(0) USING @FM SETTING GOSUB_TMP THEN
GOSUB_RETURN = SC_ARRAY_TABLES(1)<GOSUB_TMP>:@FM:SC_ARRAY_TABLES(2)<GOSUB_TMP>:@FM:SC_ARRAY_TABLES(3)<GOSUB_TMP>:@FM:SC_ARRAY_TABLES(4)<GOSUB_TMP>
END
return
WRITE_FILES:
*
* Pass in all fields to be written (including the key), in order and @FM
* delimited in the GOSUB_PARAM variable.
*
LOCATE GOSUB_PARAM<1> IN SC_ARRAY_TABLES(0) USING @FM SETTING GOSUB_TMP THEN
SC_ARRAY_TABLES(1)<GOSUB_TMP> = GOSUB_PARAM<2>
SC_ARRAY_TABLES(2)<GOSUB_TMP> = GOSUB_PARAM<3>
SC_ARRAY_TABLES(3)<GOSUB_TMP> = GOSUB_PARAM<4>
SC_ARRAY_TABLES(4)<GOSUB_TMP> = GOSUB_PARAM<5>
SC_ARRAY_TABLES(5)<GOSUB_TMP> = GOSUB_PARAM<6>
END ELSE
SC_ARRAY_TABLES(0) := @FM:GOSUB_PARAM<1>
SC_ARRAY_TABLES(1) := @FM:GOSUB_PARAM<2>
SC_ARRAY_TABLES(2) := @FM:GOSUB_PARAM<3>
SC_ARRAY_TABLES(3) := @FM:GOSUB_PARAM<4>
SC_ARRAY_TABLES(4) := @FM:GOSUB_PARAM<5>
SC_ARRAY_TABLES(5) := @FM:GOSUB_PARAM<6>
END
return
DELETE_FILES:
*
* Pass in key name or filename of file to be removed in the GOSUB_PARAM
* variable.
*
LOCATE GOSUB_PARAM IN SC_ARRAY_TABLES(0) USING @FM SETTING GOSUB_TMP THEN
SC_ARRAY_TABLES(0) = DELETE(SC_ARRAY_TABLES(0), GOSUB_TMP, 0, 0)
SC_ARRAY_TABLES(1) = DELETE(SC_ARRAY_TABLES(1), GOSUB_TMP, 0, 0)
SC_ARRAY_TABLES(2) = DELETE(SC_ARRAY_TABLES(2), GOSUB_TMP, 0, 0)
SC_ARRAY_TABLES(3) = DELETE(SC_ARRAY_TABLES(3), GOSUB_TMP, 0, 0)
SC_ARRAY_TABLES(4) = DELETE(SC_ARRAY_TABLES(4), GOSUB_TMP, 0, 0)
SC_ARRAY_TABLES(5) = DELETE(SC_ARRAY_TABLES(5), GOSUB_TMP, 0, 0)
END
return
*
READ_VOLUMES:
*
* Pass in Record to be read in GOSUB_PARAM variable. Record is returned
* in the GOSUB_RETURN variable. If this is null (0 length) then the
* record doesn't exist.
*
GOSUB_RETURN = ''
LOCATE GOSUB_PARAM IN SC_ARRAY_VOLUMES(0) USING @FM SETTING GOSUB_TMP THEN
GOSUB_RETURN = SC_ARRAY_VOLUMES(1)<GOSUB_TMP>:@FM:SC_ARRAY_VOLUMES(2)<GOSUB_TMP>
GOSUB_RETURN := @FM:SC_ARRAY_VOLUMES(3)<GOSUB_TMP>:@FM:SC_ARRAY_VOLUMES(4)<GOSUB_TMP>
GOSUB_RETURN := @FM:SC_ARRAY_VOLUMES(5)<GOSUB_TMP>
END
return
WRITE_VOLUMES:
*
* Pass in all fields to be written (including the key), in order and @FM
* delimited in the GOSUB_PARAM variable.
*
LOCATE GOSUB_PARAM<1> IN SC_ARRAY_VOLUMES(0) USING @FM SETTING GOSUB_TMP THEN
SC_ARRAY_VOLUMES(1)<GOSUB_TMP> = GOSUB_PARAM<2>
SC_ARRAY_VOLUMES(2)<GOSUB_TMP> = GOSUB_PARAM<3>
SC_ARRAY_VOLUMES(3)<GOSUB_TMP> = GOSUB_PARAM<4>
SC_ARRAY_VOLUMES(4)<GOSUB_TMP> = GOSUB_PARAM<5>
SC_ARRAY_VOLUMES(5)<GOSUB_TMP> = GOSUB_PARAM<6>
END ELSE
SC_ARRAY_VOLUMES(0) := @FM:GOSUB_PARAM<1>
SC_ARRAY_VOLUMES(1) := @FM:GOSUB_PARAM<2>
SC_ARRAY_VOLUMES(2) := @FM:GOSUB_PARAM<3>
SC_ARRAY_VOLUMES(3) := @FM:GOSUB_PARAM<4>
SC_ARRAY_VOLUMES(4) := @FM:GOSUB_PARAM<5>
SC_ARRAY_VOLUMES(5) := @FM:GOSUB_PARAM<6>
END
return
DELETE_VOLUMES:
*
* Pass in key name or filename of file to be removed in the GOSUB_PARAM
* variable.
*
LOCATE GOSUB_PARAM IN SC_ARRAY_VOLUMES(0) USING @FM SETTING GOSUB_TMP THEN
SC_ARRAY_VOLUMES(0) = DELETE(SC_ARRAY_VOLUMES(0), GOSUB_TMP, 0, 0)
SC_ARRAY_VOLUMES(1) = DELETE(SC_ARRAY_VOLUMES(1), GOSUB_TMP, 0, 0)
SC_ARRAY_VOLUMES(2) = DELETE(SC_ARRAY_VOLUMES(2), GOSUB_TMP, 0, 0)
SC_ARRAY_VOLUMES(3) = DELETE(SC_ARRAY_VOLUMES(3), GOSUB_TMP, 0, 0)
SC_ARRAY_VOLUMES(4) = DELETE(SC_ARRAY_VOLUMES(4), GOSUB_TMP, 0, 0)
SC_ARRAY_VOLUMES(5) = DELETE(SC_ARRAY_VOLUMES(5), GOSUB_TMP, 0, 0)
END
return
* Source Date: 11:38:47 13 NOV 1990 Build ID: AREV*2.0.108 Level: 2.1
*$INSERT AREV_BP, ENCRYPT.DATA.GOSUB
ENCRYPT.DATA:
I = 1234567
LOOP
WHILE ENCRYPT.DATA NE ''
I = MOD(I,390001) * SEQ(ENCRYPT.DATA[1,1]) + 1
ENCRYPT.DATA[1,1] = ''
REPEAT
LOOP
ENCRYPT.DATA := CHAR(65+MOD(I,50))
I = INT(I/50)
WHILE I
REPEAT
return
* Source Date: 10:20:16 03 FEB 1988 Build ID: 1.0 Level: 2.0
* Source Date: 09:49:41 16 JUN 1994 Build ID: AREV_HR*3.1.56 Level: 3.13
* PreCompiled On 12/06/2006 at 04:41:49PM OpenInsight version CTO