Trailing-Edge
-
PDP-10 Archives
-
bb-h138f-bm
-
7-sources/rmsopn.b36
There are 11 other files named rmsopn.b36 in the archive. Click here to see a list.
!<BLF/REQUIRE 'RMSBLF.REQ'>
%TITLE 'RMSOPN - RMS-20 $OPEN/$CREATE Verbs'
MODULE RMSOPN (IDENT = '3.0(656)'
) =
BEGIN
!
! COPYRIGHT (c) 1984, 1986 BY
! DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
! ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
! INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
! COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
! OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
! TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
! AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
! CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!
!++
! FACILITY: RMS
!
! ABSTRACT:
!
! OPENER contains all routines which process the
! $OPEN and $CREATE macros in RMS-20.
!
! ENVIRONMENT: User mode
!
! AUTHOR: Ron Lusk , CREATION DATE: 25-Mar-83
!
! MODIFIED BY:
!
! Ron Lusk, 20-Dec-83 : VERSION 2.0
! 01 - Clean up BLISS code
! 02 - (AWN) Make OFILE able to open LPT:
! 03 - Do no locking when FB$SMU is set.
! 414 - Fix missing parentheses in DOOPEN
! 444 - When only reading, open file Read-Unrestricted.
!
! Andrew Nourse, 5-Apr-85 : Version 3.0
! 501 - Put in code for remote file access
! 502 - Change over to new standard names
! 504 - Implement Image (RFM=UDF) Mode
! 507 - Implement $Parse and $Search
! 545 - Return resultant on local $Create or $Open
! 550 - Put FST address in FAB before calling F$OPEN for FFF; process
! errors appropriately. (RL)
! 556 - Don't put the jfn in the Fab in GETJFN, that may break other things
! 557 - Use new place in FST for Fop
! 565 - (RL) Return STV from FFF call
! 566 - Handle parse-only remote jfn correctly
! 577 - Handle 8-bit ASCII correctly
! 600 - Set up byte size for LSA files
! 602 - Check byte size on $Create
! 607 - Check file existence before $OPEN/$CREATE;
! earlier call for CHECKXAB to prevent dummy
! file creation for bad XAB chain.
! 613 - Add DIL8 type class to support DIL formatted 8-bit
! records generated (only) by DIU
! 621 - Make FOP=SUP kill an existing file on $CREATE if
! CIF not set.
! 654 - Set the creation and read dates on $CREATE if there is a date XAB.
! 656 - (GAS, 15-Oct-86) Write the protection into the XABPRO on $OPEN, and
! use protection in XABPRO to set the file's protection on $CREATE.
!--
!
! TABLE OF CONTENTS
!
!
! $OPEN - $OPEN processor
! $CREATE - $CREATE processor
! OFILE - get a JFN and open the file
! DOOPEN - perform rest of file opening
!
!
! INCLUDE FILES:
!
REQUIRE 'rmsreq'; ! Standard definitions
REQUIRE 'rmsosd'; ! OS-dependent definitions
!
! MACROS:
!
!<BLF/MACRO>
MACRO
!
! Macro to exit an open routine successfully
!
openexit =
BEGIN
oaflags = 0; ! No unwind needed
usrret () ! Jump to user
END
%;
!
! EQUATED SYMBOLS:
!
BUILTIN SCANN;
%IF NOT %DECLARED ($DvRmt) ! Temp definition
%THEN LITERAL $DvRmt=$DvAts; ! until Monsym has it right !a501
%FI
MAP
!
! RMSLIB cannot define these externals as MONWORD (because
! a library file cannot reference a structure from a library
! file) so MAP them instead.
!
dvflgs : monword, ! Device flags (from DVCHAR)
fdbword1 : monword; ! First word of FDB
GLOBAL BIND
!
! Error-mapping tables defined for the $CREATE/$OPEN calls
!
opnerrtab = $oserrmap ( ! Error code map
<er$fsi, gjfx4, gjfx5, gjfx6, ! Invalid file specification
gjfx7, gjfx8, gjfx9, gjfx10, !
gjfx11, gjfx12, gjfx13, gjfx14, !
gjfx31, gjfx33, gjfx34, gjfx43>, !
<er$fnf, gjfx16, gjfx17, gjfx18, ! File not found
gjfx19, gjfx20, gjfx24, !
gjfx28, gjfx32, opnx2>, !
<er$fex, gjfx27>, ! File already exists
<er$prv, gjfx35, gjfx44, opnx3, ! Access privileges needed
opnx4, opnx6, opnx15>, !
<er$dev, gjfx38>, ! Bad device
<er$flk, opnx9>); ! File locked
!
! OWN STORAGE:
!
! None.
!
! EXTERNAL REFERENCES:
!
! DAP$OPENFILE, DAP$MERGE, F$Open
EXTERNAL ROUTINE
F$Open,
R$Null,
RL$Merge,
Psizefile, ! 621
Truncfile : NOVALUE; ! 621
FORWARD ROUTINE getjfn,
dapprotra;
!
%SBTTL '$OPEN - open existing file'
GLOBAL ROUTINE $open (fabblock, errorreturn) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine processes the $OPEN service. It is
! called directly from the RMS-20 verb dispatcher.
! This routine upon completion will exit directly back
! to the RMS-20 exit processing routine.
!
! FORMAL PARAMETERS
!
! FABBLOCK - user's File Access Block
!
! ** Inputs **
!
! FABBLS - Block size for file
! FABFAC - File access value
! FABFOP - File options
! FABFNA - File specification address (or pointer)
! FABJFN - JFN of file
! FABSHR - File sharing value
!
! ** Outputs **
!
! FABDEV - Device characteristics
! FABIFI - Internal file identifier
! FABJFN - JFN of file
! FABORG - File organization
! FABRAT - Record attributes
! FABRFM - Record format
! FABSTS - Completion status code
! FABSTV - Additional status information
!
!
! ERRORRETURN - user's error handling routine
!
! IMPLICIT INPUTS
!
! ?
!
! ROUTINE VALUE:
!
! None.
!
! SIDE EFFECTS:
!
! ?
!
!--
BEGIN
!++
! ******** Flow of $OPEN routine ********
!
! 1) Open the file
! 2) Lock the file
! 3) Process file prologue
! 4) Update fields in user FAB
! 5) Create the File Status Block
! 6) Check for all errors in $OPEN request
!--
rmsentry ('$OPEN');
!+
! Fetch the user's FAB and error address.
!-
fab = .fabblock; ! Get address of FAB
erradr = .errorreturn; ! and user error address
errorblock (fab); ! All errors go to the FAB
!
! Make sure this is a FAB.
!
IF .fab [blocktype] NEQ fabcode THEN usererror (er$fab);
IF .fab [blocklength] LSS v1fabsize THEN usererror (er$bln);
oaflags = 0; ! Clear the open-abort flags
!+
! Open the file.
!-
IF ofile (gj_old) NEQ true ! Try to open the file
THEN
rmsbug (msgfailure);
setflag (oaflags, abrclose); ! File is open
!+
! Now do the rest of the processing for local files
!-
IF .fst [fst$v_remote] EQL 0
THEN
BEGIN
!+
! We must make sure the file exists. This check must be
! made because if the user gave us a JFN, we have no way
! of checking if it is associated with an existing file
! without reading the FDB (which we did in OFILE).
!-
IF .fdbword1 [fb_nxf] ! File does not exist
THEN
oabort (er$fnf);
!+
! Perform the rest of the $OPEN service processing.
!-
doopen ();
END; ! End of local file processing
openexit ! Return to user
END; ! End of $OPEN
%SBTTL '$CREATE - create a file'
GLOBAL ROUTINE $create (fabblock, errorreturn) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Create a new file for use by RMS-20. An option
! (CIF) is supported which will $OPEN the file if it
! already exists.
!
! FORMAL PARAMETERS
!
! FABBLOCK - user's File Access Block
!
! ** Inputs **
!
! FABBLS - Block size for file
! FABBKS - Bucket size for file
! FABFAC - File access value
! FABFOP - File options
! FABFNA - File specification address (or pointer)
! FABJFN - JFN of file
! FABMRN - Maximum record number
! FABMRS - Maximum record size
! FABORG - File organization
! FABRAT - Record attributes
! FABRFM - Record format
! FABSHR - File sharing value
! FABXAB - Address of XAB chain
!
! ** Outputs **
!
! FABBLS - Block size of file [?]
! FABDEV - Device characteristics
! FABIFI - Internal file identifier
! FABJFN - JFN of file
! FABSTS - Completion status code
! FABSTV - Additional status information
!
!
! ERRORRETURN - user's error handling routine
!
! IMPLICIT INPUTS
!
! ?
!
! ROUTINE VALUE:
!
! None.
!
! SIDE EFFECTS:
!
! ?
!
!--
BEGIN
regs;
LOCAL
temp : BLOCK [1],
diskflag, ! Flag if device is a disk
plgsec, ! Plog page with section number
gtjfnbits; ! Bits for GTJFN JSYS
rmsentry ('$CREATE');
fab = .fabblock; ! Get address of FAB
erradr = .errorreturn; ! and user error address
errorblock (fab); ! Send all errors to FAB
!
! Check block-type code of FAB.
!
IF .fab [blocktype] NEQ fabcode THEN usererror (er$fab);
IF .fab [blocklength] LSS v1fabsize THEN usererror (er$bln);
!
! Must do output on $CREATE.
!
IF chkflag (fab [fabfac, 0], axwrt) EQL 0 THEN usererror (er$fac);
! Check byte size
IF ( .fab[Fab$v_Bsz] EQL 0 )
OR ( .fab[Fab$v_Bsz] GTR %BPUNIT )
THEN usererror ( Rms$_Bsz ); !a602
oaflags = 0; ! Clear the abort flags
!
! Determine the bits for the GTJFN JSYS.
!
gtjfnbits = gj_new; ! Default is error if old file
IF chkflag (fab [fabfop, 0], fopcif) NEQ 0
THEN
gtjfnbits = 0 ! Just open if exists
ELSE
IF chkflag (fab [fabfop, 0], fopsup) NEQ 0 ! Supersede file
THEN
gtjfnbits = gj_fou;
!+
! Open the file.
!-
IF ofile (.gtjfnbits) NEQ true ! Shouldn't fail
THEN
rmsbug (msgfailure);
!+
! Set the flag which indicates the file is open and must
! be closed.
!-
setflag (oaflags, abrclose);
!+
! Local File Create
!-
IF .fst [fst$v_remote] EQL 0
THEN
BEGIN
!+
! For convenience, determine if device is a disk.
!-
IF .dvflgs[DV_TYP] EQL $DVDSK ! Is it a disk device?
THEN diskflag = TRUE ! Yes, it is
ELSE diskflag = FALSE; ! No, it is not a disk device
!+
! At this point, we must check to see if the file exists
! and if the user specified the "CREATE IF" file option.
! If so, we must continue as if this were a regular $OPEN
! macro. However, for non-disk devices, the $CREATE will
! always form a new file.
!-
IF NOT .fdbword1 [fb_nxf] ! Non-existent file?
THEN
IF .diskflag ! Does the file exist?
THEN BEGIN ! Yes, the file exists
! Does user want to open the file if it exists?
IF (chkflag (fab [fabfop, 0], fopcif) NEQ 0)
THEN ! Do the $OPEN
BEGIN
doopen (); ! Proceed as if $OPEN
openexit ! Return if successful
END;
!+ 621
! File exists and CIF was not set. If SUP is set, proceed with $CREATE
! after blowing the file away, else ER$FEX.
!-
IF (chkflag (fab[fabfop, 0], fopsup) EQL 0) ! SUP on?
THEN oabort (er$fex) ! No
ELSE ! Yes
BEGIN
LOCAL p_in_file;
p_in_file = psizefile (.userjfn); ! Get filesize
Truncfile (.userjfn, 0, .p_in_file); ! Blow file away
IF NOT chfdb ( ! File is null
$xwd ($fbsiz,.userjfn),
-1,
0)
THEN monerr ();
END;
END;
! File is local and may exist. Set the creation and read date times.
IF .diskflag ! Is it a disk file?
THEN BEGIN ! The file needs its date set
LOCAL xab_pointer : REF $XABDAT_DECL; ! Current XAB
! Find any interesting XABs and set the file as specified
xab_pointer = .fab[FAB$A_XAB]; ! Point to the user's xab
WHILE .xab_pointer NEQ 0 DO ! Search through XAB chain
BEGIN
BIND uxab = UADDR(.xab_pointer): $XABDAT_DECL;
! We only care about protection and date XABs.
SELECTONE .uxab[XAB$V_COD] OF
SET
[XAB$K_DAT]: BEGIN ! Yes, check it out
IF .uxab[XAB$G_CDT] NEQ 0 ! creation date
THEN IF NOT CHFDB ($XWD ($FBWRT, .userjfn),
-1,
.uxab[XAB$G_CDT])
THEN MONERR (); ! Punt off if it fails
IF .uxab[XAB$G_RDT] NEQ 0 ! A read date?
THEN IF NOT CHFDB ($XWD ($FBREF, .userjfn),
-1,
.uxab[XAB$G_RDT])
THEN MONERR (); ! Punt off if it fails
END;
! Set the file's protection as specified by the user
! Note: we don't check the protection code at all
! and the "system" priv is ignored since this doesn't
! exist under TOPS-20 (WHEEL or OPERATOR can always do
! anything to any file).
[XAB$K_PRO]: BEGIN
LOCAL protcode;
BIND pxab = uxab : $XABPRO_DECL;
protcode = dapprotra(.pxab[XAB$V_PROTOWN])^12 +
dapprotra(.pxab[XAB$V_PROTGRP])^6 +
dapprotra(.pxab[XAB$V_PROTWLD]);
IF .protcode NEQ 0
THEN IF NOT CHFDB ($XWD ($FBPRT, .userjfn),
%O'777777',
.protcode)
THEN MONERR ();
END;
TES; ! End of SELECTONE
! Point to next xab and loop if not at the end yet
xab_pointer = .uxab[XAB$A_NXT]; ! Point to next XAB
END; ! End of UNTIL .xab_pointer NEQ 0
END; ! End of file_is_not_remote code
! Set up the file class
IF (fst[FST$H_FILE_CLASS] = UCLASS(.fab)) EQL 0
THEN BEGIN
IF .fab[FAB$V_RFM] EQL FAB$K_UDF
THEN fst[FST$H_FILE_CLASS] = TYP$K_IMAGE;
IF .fab[FAB$V_MACY11]
THEN fst[FST$H_FILE_CLASS] = TYP$K_MACY11;
END;
!+
! Reset system-level file class field in the FDB.
!-
IF (.fab [Fab$v_rfm] NEQ Fab$k_Stm) AND ! Not ASCII Stream file and
(.fab [Fab$v_rfm] NEQ Fab$k_Lsa) AND ! not LSA file !m504
(.fab [fab$v_rfm] NEQ Fab$k_Udf) ! not image file !a504
THEN
BEGIN
!
! Make sure that this is a disk. Otherwise,
! it's an error.
!
IF .diskflag EQL false THEN usererror (er$dev); ! must be on disk
IF NOT chfdb ( ! Change file class field
$xwd ($fbctl, .userjfn), ! Word to change,,JFN
fb_fcf, ! Bits to change
fld ($fbrms, fb_fcf)) ! Value to assign bits
THEN
monerr ();
!+
! Now, set the byte size in the FDB to be 36.
! This is not required for the monitor but is
! a good thing to do at this point.
!-
IF NOT chfdb ( ! Set byte size
$xwd ($fbbyv, .userjfn), ! Word to change,,JFN
fb_bsz, ! Bits to change
fld (rmsbytesize, fb_bsz)) ! New value for bytesize
THEN
monerr ();
!+
! Get a free page for the File Prologue.
!-
IF (plogpage = gpage (1)) EQL false ! No more memory?
THEN
oabort (er$dme);
!
! Set up a temporary pointer to this page, and
! map in page 0 from the file to create the prologue.
fpt = .plogpage^p2w; ! Set pointer
!
! Get page including section number for PAGIN
!
plgsec = .plogpage OR (.rmssec^s2p);
pagin (.userjfn, ! JFN
0, ! Page
.plgsec, ! Into
axupd, ! Access
1); ! Count
!+
! Set up the file prologue.
!-
setplog (); ! Set up the file prologue
setflag (oaflags, abrplogpage); ! Remember this was done
END
ELSE
BEGIN ! Set byte size for LSA
! and stream files
IF .fab [faborg, 0] NEQ orgseq ! ORG must be sequential
THEN
oabort (er$rfm);
IF .Fab [Fab$v_Rfm] EQL Fab$k_Udf ! 'Image' file !a504
THEN
BEGIN
!+
! An Image File (RFM=UDF) contains (presumably) binary data
! has no prologue, and we set the file byte size
! to the real one in BSZ
!-
Fst[Fst$h_File_Class] = Typ$k_Image; ! UDF implies image !a575
IF .diskflag NEQ false
THEN
BEGIN
IF NOT sfbsz (.userjfn, .Fab [Fab$v_Bsz] ) ! Set byte size
THEN monerr (); ! for the open
IF NOT chfdb ( ! Set byte size
$xwd ($fbbyv, .userjfn), ! Word to change,,JFN
fb_bsz, ! Bits to change
fld ( .Fab [Fab$v_Bsz] , fb_bsz)) ! New bytesize
THEN monerr ();
END
END
ELSE IF .fab [Fab$v_Rfm] EQL Fab$k_Lsa ! Line-sequenced?
THEN
BEGIN
IF NOT sfbsz (.userjfn, rmsbytesize) ! Set byte size
THEN monerr ();
END
ELSE
IF .diskflag NEQ false
THEN
BEGIN !m577
IF NOT sfbsz (.userjfn, .Fab [Fab$v_Bsz] ) ! Set byte size
THEN monerr (); ! for the open
IF NOT chfdb ( ! Set byte size
$xwd ($fbbyv, .userjfn), ! Word to change,,JFN
fb_bsz, ! Bits to change
fld ( .Fab [Fab$v_Bsz] , fb_bsz)) ! bytesize !m577
THEN monerr ();
END
END;
!+
! Set up the File Status Table.
!-
IF setfst () EQL false ! Quit if we can't do it
THEN
oabort (.usrsts);
setflag (oaflags, abrfst); ! Remember this
fst [fstsof] = .fst [fstlobyte]; ! Initialize file size to
! size of prologue.
!+
! Indicate that this is a new file and we are not locking.
!-
fst [fstflags] = (.fst [fstflags] OR flgnewfile) AND !
( NOT flglocking);
!
! Check for errors.
!
IF ferror () EQL false ! Quit if errors
THEN
oabort (.usrsts);
!+
! For indexed files, we must now create the rest of the
! file prologue.
!-
IF idxfile
THEN
BEGIN
!607
!+
! XAB chain has already been checked in OFILE before we get here.
! If the XABs were OK, we can set up the rest of the File
! Prologue. If we can't do that, quit with an error.
!-
IF idxfilprolog () EQL false THEN oabort (er$dme);
!+
! We have now created the Prologue. However, we must read
! the prologue back in and set up the special internal
! data structures (Key Blocks).
!-
IF readadb (.fpt) EQL false ! Get the ADB
THEN
oabort (.usrsts);
fst [fstadb] = .adb; ! Save address in FST
setflag (oaflags, abradb); ! Remember we read the ADB
IF setkdb (.fpt) EQL false ! Set up KDBs
THEN
oabort (.usrsts)
END;
!+
! We can now flush the free page that we used to create
! the File Prologue (if this is an RMS file).
!-
IF rmsfile
THEN
BEGIN
rtrace (%STRING (' Flushing prologue page...', !
%CHAR (13), %CHAR (10)));
pagout (.userjfn, 0, .plogpage, 1); ! Write it out
ppage (.plogpage, ! Page number
1, ! Count
true) ! Destroy the page
END;
!
! Return file-ID.
fab [fabifi, 0] = .fst; ! Return FST address as IFI
fab [fabjfn, 0] = .userjfn; ! Set it in FAB
END; ! End of Local $Create code
openexit ! Return to user
END; ! End of $CREATE
%SBTTL 'OFILE - do file opening'
GLOBAL ROUTINE ofile (gtjfnbits) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine does the actual file open operation for the
! $OPEN macro. It is called only from $OPEN and $CREATE.
! It does a GTJFN if the user did not give us a JFN.
!
! If the file is local it will OPENF it.
! If the file is remote it will call DAP$OPEN.
! If the user supplied a filespec of the form
! Node"user pass acct"::file, the GTJFN will fail,
! but the filespec is actually valid for RMS.
! In this case a GTJFN will be performed after reformatting
! the filespec into node::filespec;userid:user;password:pass
!
! It also performs some minimal checking to
! make sure that the device is a proper one for the
! file. These checks are performed here only because
! there are certain errors which will prevent the file
! from being opened successfully, so it is better if
! we can give the user an intelligent error message,
! instead of one from the monitor.
!
! FORMAL PARAMETERS
!
! GTJFNBITS - bits for GTJFN JSYS
!
! IMPLICIT INPUTS
!
! ?
!
! COMPLETION CODES:
!
! TRUE - always
!
! SIDE EFFECTS:
!
! ?
!
!--
BEGIN
LOCAL
temp,
mask, ! Mask bits for device field
openbsz, ! Byte size for the OPENF
filedesc,
existflag; ! 607
TRACE ('OFILE');
!+
! Release 1 supports a new mode: "Transparent" read.
! This is designated by FABFAC = 0 and FABSHR ignored, and
! means allow read no matter what.
!-
IF .fab [fabfac, 0] EQL axnil ! Transparent read?
THEN
fab [fabshr, 0] = axnil; ! Yes - sharing irrelevant.
!+
! Allocate some core for File Status Table to set up three fields.
! If the fst is not already there
!-
IF .Fab[Fab$a_Ifi] NEQ 0 ! If FST exists !m566
THEN fst=.Fab[Fab$a_Ifi] ! then use it !a507
ELSE !a507
BEGIN
IF (fst = gmem (fst$k_bln)) EQL false ! Room for FST? !m502
THEN
returnstatus (er$dme); ! No - error
fst [fst$h_bln] = fst$k_bln; ! Set up blocklength !m502
fst [fst$h_bid] = fst$k_bid; ! Set up block id !a504
setflag (oaflags, abrfst); ! Flush FST on aborting
END; !a507
!+
! Get a JFN if we haven't been given one.
!-
GetJfn( .GtJfnBits );
setflag (oaflags, abrclose); ! Close file on errors
existflag = true; !607 assume all files exist
fdbword1 = 0; !607 Set only for disk files
!+
! We must now determine the device characteristics of this file.
!-
IF (.userjfn LSS $ErBas) ! If we have a JFN, not an error code
AND (.userjfn GTR 0) ! or nothing
THEN
BEGIN
dvflgs = devchar (.userjfn); ! Get device flags (20 format)
IF .dvflgs[dv_typ] EQL $DvRmt ! Is it a remote filespec? !a501
THEN
BEGIN
fst[fst$v_remote] = fab[fab$v_remote] = 1;
RLJFN( .UserJfn ); ! Release the JFN !a566
UserJfn = 0; ! and clear it !a566
END;
!+ 607
! If the file is local, determine whether it exists or not. If we're
! trying to $OPEN a non-existent file, complain now before any OPENF
! so we don't possibly create a trash file--e.g. if our JFN is the result
! of an OFP $PARSE so it never had GJ%OLD set. If the GTFDB fails, we
! must have been handed a bad user JFN.
!-
IF NOT .fst[fst$v_remote] !607 If file is local disk
AND .dvflgs[dv_typ] EQL $dvdsk !607
THEN !607 see if it exists or not
BEGIN
IF NOT gtfdb ( !607 Get some of the FDB
.userjfn, !607 JFN
$xwd (1, $fbctl), !607 One word, starting at .FBCTL
fdbword1) !607 Put it here
THEN
BEGIN
GetEr( $FhSlf ; UsrStv );!607 Return an STV
oabort (er$jfn); !607 JFN not good enough for OPEN
END;
IF .fdbword1[fb_nxf] !607 flag existence/non-existence
THEN existflag=false !607
ELSE existflag=true; !607
IF .existflag EQL false !607 If files does not exist
AND (.GtJfnBits AND gj_old) NEQ 0 !607 and we're trying to open it
THEN oabort (er$fnf); !607 complain
END;
END; !607 end real JFN
!+ 607
! If the file is indexed, and we're going to create it, check the user's
! XAB chain for errors. If the XABs are bad for any reason, abort right
! now so a trash file is not created. Note that for local files for
! which CIF was set the file's existence has been determined by existflag.
! Remote files will always have .existflag=true: we can't determine here
! whether a remote $CREATE with a bad XAB chain may create a trash file
! on failure.
!-
IF .Fab[Fab$v_org] EQL Fab$k_Idx !607 if file is indexed
AND .existflag EQL false !607 and does not exist
THEN
BEGIN
IF .GtJfnBits NEQ 0 !607 If no CIF was set
THEN
BEGIN
IF checkxab () EQL false THEN oabort (.usrsts); !607
END;
END;
IF .fst [fst$v_remote] !M501 If file is remote,
THEN ! use DAP to open it
BEGIN
LOCAL function_code;
fst[fst$h_bid]=fst$k_bid; ! Set up FST, SETFST is not used here
fst[fst$a_flink]=.fst; ! No streams active yet
!d574
IF (.gtjfnbits AND gj_old) NEQ 0
THEN function_code = Dap$k_Open
ELSE function_code = Dap$k_Create;
dap$openfile ( .fab, .function_code, 0, 0 );
IF .fab [fab$h_sts] NEQ Rms$_Suc ! If we didn't win
THEN usererror ( .fab [fab$h_sts] ); ! Check for success or error
fab[fab$a_ifi] = .fst; ! Return file-ID !a574
fst[fst$h_rfm] = .fab[fab$v_rfm];
fst[fst$b_fac] = .fab[fab$h_fac];
fst[fst$h_mrs] = .fab[fab$h_mrs];
fst[fst$g_mrn] = .fab[fab$g_mrn];
fst[fst$h_fop] = .fab[fab$h_fop]; ! Copy fop to new place !m557
fst[fst$h_rat] = .fab[fab$h_rat];
fst[fst$h_bsz] = .fab[fab$v_bsz];
fst[fst$h_org] = .fab[fab$v_org];
fst[fst$a_blink]=fst[fst$a_flink]=.fst; ! Link to self !a501
fst[fst$h_device_type]=dvdsk; !? Assume disk for now !a501
END
ELSE
BEGIN ! Local File setup
BIND Nam=UAddr( .Fab[Fab$a_Nam] ): $Nam_decl; !a545vv
IF Nam NEQ 0
THEN
BEGIN
!+
! Return resultant name to user if he gave us a NAM block
!-
IF .Nam[Nam$h_Bid] NEQ Nam$k_Bid ! It really is a name block
THEN UserError( Rms$_Nam ); ! isn't it? !a575
IF .Nam[Nam$h_Bln] EQL Nam$k_Bln ! Check the length !a575
THEN ! If wrong ignore block
BEGIN ! (error would break FTS)
IF NOT .Fab[Fab$v_Nam] ! Unless Open by NAM block
THEN Nam[Nam$g_Wcc] = 0; ! Clear wildcard context !a572
RL$Merge( .Fab, Merge$M_Point, R$Null )
END;
END; !a545^^
!+ 607
! At this point we have read the .FBCTL word of the FDB
! into FDBWORD1, which for non-disk files will be zero.
! We must determine what "class" the file belong to
! (i.e., it is either an RMS-file or an ASCII-file).
! However, for non-disk files, this will obviously not
! work, so we have cleared the variable FDBWORD1 first, to
! make sure that the check below results in this file
! being classified as an ASCII file.
!-
!d607
!+
! We must determine if this is an RMS-20 file. If so, we
! can open it in 36-bit mode. If not (i.e., it's a stream
! or LSA file), then we must open it in 7-bit mode so the
! monitor EOF pointer doesn't get rounded up to the
! nearest full word.
!-
openbsz = rmsbytesize; ! Assume RMS file
IF .fdbword1 [fb_fcf] NEQ $fbrms ! Is it really RMS?
THEN
openbsz = asciibytesize; ! No - use 7-bit mode
!++
! Set up for the OPENF JSYS. Start by setting the access
! bits necessary.
!--
BEGIN
LOCAL
open_error, ! Error code from OPENF
openbits : monword; ! Bits for OPENF
mask = 0; ! Clear device flag
IF ((.fab [fabfac, 0] AND axget) NEQ 0) ! Doing input?
THEN
mask = dv_in; ! Device can do input
!+
! Set up the file byte size, and set the read and "Don't
! update to disk" bits.
!
!
! *** Note that sequential/relative files will not be
! updated to disk automatically by RMS. ***
!-
openbits = (.openbsz^opfbszlsh) + of_dud; ![2] !M444
IF .dvflgs [dv_in] ![2] If readable
THEN
openbits = .openbits OR of_rd; ![2] open for read
IF ((.fab [fabfac, 0] AND axwrt) NEQ 0) ! If an output mode
THEN
BEGIN
mask = .mask OR dv_out; ! Must be output device
openbits [of_wr] = 1; ! Set write bit
openbits [of_thw] = 1; ! Open thawed !A444
END ! !M444
ELSE ! !A444
openbits [of_rdu] = 1; !Read unrestricted !A444
!+
! Quickly check for some device errors.
!-
IF (.dvflgs AND .mask) NEQ .mask OR ! Can't do operation
(.dvflgs [dv_typ] EQL $dvmta) ! MTA
THEN
usererror (er$dev);
IF NOT openf (.userjfn, .openbits; open_error) ! Open the file
THEN
mapcodes (.open_error, er$cof, opnerrtab);
END;
!+
! Set the device characteristic flags in the user's FAB.
!-
mask = 0; ! Collect bits here
IF ((.dvflgs AND dv_dir) NEQ 0) ! Directory device
THEN
mask = devmdi;
temp = .dvflgs [dv_typ]; ! Get device class
IF .temp EQL $dvmta ! Magtape?
THEN
setflag (mask, devsqd); ! Yes - Sequential device
IF .temp EQL $dvtty ! TTY:?
THEN
setflag (mask, devtrm); ! Terminal
IF (.temp GEQ $dvlpt) AND ! LPT:, CDR:, or TTY:
(.temp LEQ $dvtty)
THEN
BEGIN
setflag (mask, devrec); ! Record device
IF .temp NEQ $dvcdr ! TTY, LPT are CCL
THEN
setflag (mask, devccl)
END;
fab [fabdev, 0] = .mask; ! Return flags to user
END; ! Local File processing
RETURN true ! Return OK
END; ! End of OFILE
%SBTTL 'GetJfn -- Get a JFN for the file described by the FAB'
GLOBAL ROUTINE GetJfn ( GtJfnBits: BITVECTOR[%BPVAL] ) =
!+
! FUNCTIONAL DESCRIPTION:
!
! Get a JFN for the file described by the FAB.
!
! FORMAL PARAMETER:
!
! GtJfnBits: Bits to pass to GTJFN JSYS.
!
! RETURN VALUE:
!
! Flags,,JFN from GTJFN JSYS
!
! IMPLICIT OUTPUTS:
!
! UserJfn: set to new JFN
!
!-
BEGIN
MAP UserJfn: MonWord;
LOCAL
bits_and_jfn,
fs_ptr,
delim_ptr;
IF (UserJfn = .Fab[Fab$h_Jfn]) NEQ 0 ! We already have a JFN
THEN
BEGIN
LOCAL
file_status : monword;
IF NOT gtsts (.userjfn; file_status) THEN monerr ();
IF .file_status [gs_opn] ! File already open
OR (.file_status EQL 0) ! or invalid JFN
THEN
usererror (er$jfn)
ELSE
RETURN .UserJfn; ! JFN is OK. return.
END;
fs_ptr = UAPointer ( .fab [fab$a_fna] );
! Globalize Bytepointer
!+
! Try to do a GTJFN on the file
!-
IF NOT gtjfn (.gtjfnbits OR gj_sht, ! Flags
.fs_ptr; ! Pointer to file specification
userjfn, ! Return the JFN
delim_ptr) ! and updated pointer !a501
THEN ! JSYS failed
BEGIN ! GTJFN Failed...
SELECT .userjfn OF !M501 VV
SET
[gjfx38]: ! Output-Only Device
IF .fab [fabfac, 0] EQL axput
THEN ! Only ask for output
BEGIN
IF gtjfn (gj_sht, .fs_ptr; userjfn)
THEN mapcodes (.userjfn, er$cgj, opnerrtab)
END
ELSE mapcodes (.userjfn, er$dev, opnerrtab); !m531
[gjfx55]: ! Illegal to use Node Name
IF gtjfn (gj_sht+gj_ofg, .fs_ptr; userjfn)
THEN
fab [ fab$v_remote ] = fst [ fst$v_remote] = 1
ELSE
mapcodes (.userjfn, er$cgj, opnerrtab);
[OTHERWISE]:
!+
! Make sure we did not get fooled by node"user pass"::filespec
! If we get that, GTJFN will terminate on the quote
!-
IF SCANN (delim_ptr) EQL %C'"' !A501 vv
THEN
fab [fab$v_remote] = fst [fst$v_remote] = 1
ELSE
mapcodes (.userjfn, er$cgj, opnerrtab);
TES;
Bits_and_Jfn = .UserJfn; ! Save the flags to return !a566
UserJfn = .UserJfn<rh>; ! Flush the flags !a566
END
ELSE
BEGIN ! The GTJFN succeeded
LOCAL
file_status : monword;
IF .UserJfn[GJ_NOD] ! If a node name is given !a575
THEN fab [fab$v_remote] = fst [fst$v_remote] = 1;
!+
! Make sure we did not get fooled by node"user pass"::filespec
! If we get that, GTJFN will terminate on the quote
!-
IF SCANN (delim_ptr) EQL %C'"' !A501 vv
THEN !D575
BEGIN
rljfn (.userjfn); ! Get rid of JFN, file is remote
! we only had JFN on part of the spec
fab [fab$v_remote] = fst [fst$v_remote] = 1;
userjfn = 0;
END
ELSE
!+
! File is local.
! JFN must be ok but must not be associated
! with an open file.
!-
BEGIN
Bits_and_Jfn = .UserJfn; ! Save Flags,,Jfn !a566
UserJfn<lh>=0; ! Clear flags !a566
IF NOT gtsts (.userjfn; file_status) THEN monerr ();
! Removed check for parse-only JFN. It is legal now. !d507
IF .file_status [gs_opn] ! File already open
THEN
usererror (er$jfn);
END; ! Local file
END;
.Bits_And_Jfn ! Return value !a566
END; ! GetJfn
%SBTTL 'DOOPEN - finish opening file'
GLOBAL ROUTINE doopen : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! DOOPEN completes the opneing of a file for RMS-20.
! This routine does not acquire a JFN or open the
! file. Hoever, it performs all other functions
! necessary to set up a file for later processing.
!
! This routine is called only on $OPEN or $CREATE when
! the CIF bit is set and the file already exists.
!
! The following operations are performed by this
! routine:
!
! 1) Lock the file.
! 2) Map in page zero of the file (disk only).
! 3) For RMS files, read the prologue;
! Non-RMS files, determine if ASCII or LSA.
! 4) Update the user's FAB.
! 5) Set up the FST.
! 6) Check for errors in user call.
! 7) For indexed files, process rest of prologue.
!
! FORMAL PARAMETERS
!
! None.
!
! IMPLICIT INPUTS
!
! ?
!
! ROUTINE VALUE:
!
! None.
!
! SIDE EFFECTS:
!
! ?
!
!--
BEGIN
LOCAL
dstatus, ! To hold DISPFILE status
temp : REF BLOCK,
plgsec, ! PLOGPAGE + section offset
firstword : BLOCK [1],
fileheader;
TRACE ('DOOPEN');
!+
! We must now keep track of what operations have been
! performed during the open processing, so that if a
! problem occurs later, we can unwind easily. This is
! done by setting a bit in OAFLAGS for each operation
! which we might need to undo later. For starters, note
! that the file is open and must be closed on an error.
!-
setflag (oaflags, abrclose);
!
! Locking possibly applies is this is a disk file,
! unless this is a transparent read or LIBOL SMU is
! underway.
!
IF (.dvflgs [dv_typ] EQL $dvdsk) AND ! Must be disk...
(.fab [fabfac, 0] NEQ axnil) AND ! ...not transparent !M404
((.fab [fabfac, 0] AND fb$smu) EQL 0) ! ...not doing SMU !A404!M414
THEN
BEGIN
temp = enqblk; ! Assume we will block
IF (.fab [fabfop, 0] AND fopwat) EQL 0 ! Do we wait?
THEN
temp = enqaa; ! No, file must be available
$callos (er$flk, (fileq (enqcall, .temp)));
setflag (oaflags, abrunlock) ! Flag that we've locked file
END;
!+
! Process the prologue.
!-
!+
! We must now read the first word of the file in order to
! make sure that it is a proper RMS-20 file, or to
! dtermine whether this is an ASCII or LSA file. However,
! for carriage-control devices, we don't want to do this.
! Therefore we must first clear the local variable to make
! sure that this file is treated as an ASCII file (i.e.,
! the LSB will be off in each word).
!-
firstword = 0; ! For carriage-control devices
!
! Is this a disk?
!
IF .dvflgs [dv_typ] EQL $dvdsk ! Disk
THEN ! Get info from FDB for FAB, &
BEGIN ! Determine type from 1st word
GTFDB( .UserJfn, (1^18)+$Fbbyv, fdbbyv ); ! Get number of pages in file
Fab[Fab$g_Alq] = .fdbbyv<rh>;
IF (plogpage = gpage (1)) EQL false ! Get memory
THEN
oabort (er$dme);
setflag (oaflags, abrplogpage); ! Flag that page is in
!+
! If the file is null (i.e., page 0
! doesn't exist, then the next instruction
! will generate an illegal read error.
! Thus, we must make sure the page exists
! before we try to read it.
!-
IF pagexist (.userjfn, 0)
THEN
BEGIN !PAGE 0 EXISTS
!
! Get page number including our section number
!
plgsec = .plogpage OR (.rmssec^s2p);
pagin (.userjfn, ! JFN
0, ! Page
.plgsec, ! Into
axget, ! Access
1); ! Count
fpt = .plogpage^p2w; ! Set up prologue pointer
firstword = .fpt [wholeword]; ! Get 1st word of file
END;
END;
!+
! We must determine if this file is one which was created
! by RMS-20. This is indicated by the "file class" field
! in the FDB. If this is an RMS-20 file, then we must
! read in the file descriptive information contained in
! the file prologue and use it to determine if the user
! has made any errors, and move some of its contents into
! the user's FAB.
!-
IF .firstword [blocktype] EQL fpblock ! Is it a prologue?
THEN ! Copy prologue data to FAB
BEGIN
!+
! Make sure this is a disk file.
!-
IF .dvflgs [dv_typ] NEQ $dvdsk ! RMS file must be on disk
THEN
oabort (er$dev);
!+
! Update user parameter section of FAB.
!-
fab [faborg, 0] = .fpt [fptorg]; ! File organization
fab [fabrat, 0] = .fpt [fptrat]; ! File attributes
fab [fabmrs, 0] = .fpt [fptmrs]; ! Maximum record number
fab [fabmrn, 0] = .fpt [fptmrn]; ! Maximum file size
fab [fabbsz, 0] = .fpt [fptbsz]; ! Byte size
fab [fabbks, 0] = .fpt [fptbks]; ! Bucket size
fab [fabrfm, 0] = .fpt [fptrfm]; ! Record format
END
ELSE
BEGIN ! Clear FAB for ASCII files
rtrace (%STRING (' Clearing FAB for Non-RMS file...', !m504
%CHAR (13), %CHAR (10)));
CASE ( fst[fst$h_File_Class] = UClass( .fab ) ) !a504
FROM 0 TO Typ$k_Class_Max OF !a504
SET !a504
[0,
Typ$k_Ascii]: !a524
BEGIN
IF .firstword [blocktype] EQL fpblock ! RMS file
THEN ! , but bad FDB?
BEGIN
fileproblem (fe$bfc); ! Bad file class
usrret ()
END;
IF (.firstword AND bitn (35)) NEQ 0 ! LSA file?
THEN
temp = Fab$k_Lsa ! Sequenced if bit 35
ELSE
temp = Fab$k_Stm ! Ascii stream file
END;
[Typ$k_Image, !m561
Typ$k_Byte, !m561
Typ$k_DIL8]:
IF .Fab[Fab$h_Mrs] EQL 0 ! 0 record size !a561
THEN !a561
BEGIN ! 0 record size cannot be image, make !a561vv
Fst[Fst$h_File_Class] = Typ$k_Ascii; ! Ascii
IF (.firstword AND bitn (35)) NEQ 0 ! LSA file?
THEN
temp = Fab$k_Lsa ! Sequenced if bit 35
ELSE
temp = Fab$k_Stm ! Ascii stream file
END !a561^^
ELSE temp = Fab$k_Udf;
[Typ$k_Macy11]:
BEGIN
temp = Fab$k_Udf;
Fab[Fab$v_Macy11] = 1;
END;
[OUTRANGE]:
BEGIN
temp = .Fab[Fab$v_Rfm]; ! Use user-specified RFM !a524
!
! Provide access to the FST for the
! FFF routines, and put the JFN in the
! FST (so we won't have to erase it later
! from the FAB in case of an error).
!
fst [fst$h_jfn] = .userjfn; ! Set up JFN !A550
fab [fab$a_ifi] = .fst; ! FFF will globalize !A550
!
! Call the FFF routines
!
f$open (.fab); !m524
usrstv = .rab [rab$h_stv]; ! Return STV value !A565
!+
! If we did not succeed, we want to
! zero the IFI field, since RMS proper
! doesn't know we set it. Then, we
! will return the usual error.
!-
IF NOT $rms_status_ok (.fab) !a524
THEN
BEGIN
fab [fab$h_jfn] = 0; ! Zero JFN !A550
fab [fab$a_ifi] = 0; ! Zero FST !A550
usererror (.fab [fab$h_sts]); ! Return error !a524
END;
END;
TES; !a504^^
Fab[Fab$v_Rfm] = Fst[Fst$h_Rfm] = .temp; !a524
SELECT .temp OF
SET
[Fab$k_Lsa]: ! LSA file? !m524
!+
! For LSA files, we must change the file byte size back to 36,
! since we need to read it in binary mode.
! But we should tell user & RMS that it has the usual Ascii size
!-
BEGIN
Fab [Fab$v_Bsz] = Fst [Fst$h_Bsz] = asciibytesize; !a600
IF NOT sfbsz (.userjfn, rmsbytesize) ! Set bytesize
THEN
monerr ();
END;
[Fab$k_Udf,
Fab$k_Stm]: !m577
!+
! If it is Image or Ascii, set the Jfn byte size to the file byte size
!-
BEGIN
LOCAL filebytesize;
IF .dvflgs [dv_typ] EQL $dvdsk ! Disk !m577
THEN
BEGIN
IF NOT gtfdb ( ! Get some of the FDB
.userjfn, ! JFN
$xwd (1, $fbbyv), ! One word, starting at .FBBYV
filebytesize) ! Put it here
THEN monerr ();
filebytesize = .Pointr(filebytesize,fb_bsz); ! Get from FDB
END
ELSE filebytesize = 0;
IF .filebytesize EQL 0 ! 0 is illegal !a566
THEN filebytesize = ! So use
(IF .temp EQL Fab$k_Stm THEN asciibytesize ! normal char size
ELSE %BPVAL); ! word size !m577
IF (.filebytesize EQL %BPVAL) ! 36 bit bytes?
AND (.temp EQL Fab$k_Stm) ! in a stream file.
THEN filebytesize = asciibytesize; ! No way. It was written by
! retarded software !a600
Fab [Fab$v_Bsz] = Fst [Fst$h_Bsz] = .filebytesize;
IF .dvflgs [dv_typ] EQL $dvdsk ! Disk !m577
THEN
IF NOT sfbsz( .userjfn, .filebytesize ) ! Set bytesize
THEN monerr ();
END;
[Fab$k_Stm,
Fab$k_Lsa]:
fab [fab$h_mrs] = 0; ! No maximum record size
TES;
fab [fab$v_org] = orgseq; ! Sequential file organization
!d504 fab [fab$h_mrs] = 0; ! No maximum record size
fab [fab$g_mrn] = 0; ! No maximum record count
fab [fab$h_rat] = 0; ! No record attributes apply
!d504 fab [fab$v_bsz] = asciibytesize ! Reset if ASCII
END;
!+
! Set up the File Status Table.
!-
IF setfst () EQL false ! Initialize FST
THEN
oabort (.usrsts);
setflag (oaflags, abrfst); ! We got core for FST
!+
! If we are locking, set flag in FST.
!-
IF chkflag (oaflags, abrunlock) NEQ 0 ! Locking? (from OAFLAGS)
THEN
setflag (fst [fstflags], flgflocked);
!+
! Check for all errors in $OPEN/$CREATE request.
!-
IF ferror () EQL false ! False if errors
THEN
oabort (.usrsts);
!+
! If this is an indexed file, we must process the rest of
! the file prologue. We did not perform the function
! earlier in the open processing because there was no
! information that we needed, and flushing the internal
! blocks, etc., is a painful operation. Thus, we only
! process the rest of the prologue after we have performed
! all normal checking operations on the file.
!-
IF idxfile
THEN
BEGIN
!+
! First, read in the Area Descriptor Block.
!-
IF readadb (.fpt) EQL false ! Get ADB
THEN
oabort (.usrsts);
fst [fstadb] = .adb; ! Save address in FST
setflag (oaflags, abradb); ! Flag that we have ADB
!+
! Next, set up all key descriptors and
! link them to the FST.
!-
IF setkdb (.fpt) EQL false ! Set up KDBs
THEN
oabort (.usrsts);
END;
!+
! If the user has given us an XAB chain, we fill
! it in for him.
!-
IF .fab [fabxab, 0] NEQ 0
THEN
IF (dstatus = dispfile ()) NEQ true ! Display file
THEN
BEGIN
usrsts = .dstatus; ! Save result
oabort (.usrsts);
END;
!+
! If this is a disk file, we must give back the free page
! which we got earlier to read in the File Prologue.
!-
IF dasd
THEN
ppage (.plogpage, ! Page number
1, ! Count of pages
true); ! Unmap this page
!+
! Finally, return the file-ID of this file to the
! user's FAB.
!-
fab [fab$a_ifi] = .fst; ! Return file-ID
fab [fabjfn, 0] = .userjfn; ! Set it in FAB
RETURN
END; ! End of DOOPEN
GLOBAL ROUTINE chkremote =
!++
! FUNCTIONAL DESCRIPTION:
!
! Determine if the file specified in the FAB is remote
!
! FORMAL PARAMETERS
!
! None.
!
! IMPLICIT INPUTS
!
! The JFN provided in the FAB, if any
! otherwise, the filespec pointed to by the FAB
!
! ROUTINE VALUE:
!
! TRUE if the file is remote
! FALSE if it is local
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN
IF .fab[fab$h_jfn] NEQ 0
THEN
BEGIN
LOCAL nodename: VECTOR[CH$ALLOCATION(9)],
nodeptr: INITIAL(CH$PTR(nodename));
jfns ( nodeptr, .fab[fab$h_jfn], js_nod ; nodeptr );
(.nodeptr NEQ CH$PTR(nodename)) ! If it moved, there's a nodename.
END ! so return the truth of the relational
ELSE (find_substring(.fab[fab$a_fna] ,pp('::')) NEQ 0)
! return the truth of this relational
END;
ROUTINE dapprotra (p_dap_bits) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! Translate dap protection bits to TOPS20 protection bits. DAP
! protection bits are mapped roughly to the TOPS20 protection bits based
! on the following:
!
! DAP protection bit TOPS-20 protection code
! bit 0 (deny read access) code 40 (read access)
! bit 1/3 (deny write/delete access) code 20 (write/delete access)
! bit 2 (deny execute access) code 10 (execute access)
! bit 4/8 (deny append/extend access) code 04 (append access)
! bit 5 (deny directory list access) code 02 (directory list)
!
! FORMAL PARAMETERS
!
! p_dap_bits: dap protection to translate
!
! IMPLICIT INPUTS
!
! None.
!
! ROUTINE VALUE:
!
! TOPS20 protection code.
!
!--
LOCAL retcode;
BIND dap_bits = p_dap_bits : BITVECTOR[36];
retcode = %O'76'; ! Assume full access
%(
IF .dap_bits[XAB$M_NOREAD] ! Deny read access?
THEN retcode = .retcode AND NOT %O'40'; ! Yes, turn off read access bit
IF .dap_bits[XAB$M_NOWRITE] ! Deny write?
THEN retcode = .retcode AND NOT %O'20'; ! Yes, turn off delete access bit
IF .dap_bits[XAB$M_NOEXECUTE] ! Deny execute access?
THEN retcode = .retcode AND NOT %O'10'; ! Yes, turn off execute access bit
IF .dap_bits[XAB$M_NOAPPEND] ! Deny append?
THEN retcode = .retcode AND NOT %O'04'; ! Yes, turn off append access bit
IF .dap_bits[XAB$M_NOLIST] ! Deny directory list access?
THEN retcode = .retcode AND NOT %O'02'; ! Yes, turn off directory access bit
)%
IF .dap_bits[0] ! Deny read access?
THEN retcode = .retcode AND NOT %O'40'; ! Yes, turn off read access bit
IF .dap_bits[1] ! Deny write access?
THEN retcode = .retcode AND NOT %O'20'; ! Yes, turn off delete access bit
IF .dap_bits[2] ! Deny execute access?
THEN retcode = .retcode AND NOT %O'10'; ! Yes, turn off execute access bit
IF .dap_bits[4] ! Deny append access?
THEN retcode = .retcode AND NOT %O'04'; ! Yes, turn off append access bit
IF .dap_bits[5] ! Deny directory list access?
THEN retcode = .retcode AND NOT %O'02'; ! Yes, turn off directory access bit
IF .retcode EQL %O'76' ! Make me happy by using 77 for
THEN retcode = %O'77'; ! the full access protection
RETURN .retcode; ! Return the code we created
END; ! end of dapprotra
END ! End of Module OPENER
ELUDOM