.TITLE RSO_CLOSE .IDENT /V2.000/ .ENABLE SUPPRESSION .DISABLE GLOBAL,DEBUG,TRACEBACK .SUBTITLE Declarations and COMMONs ;+ ; Version: VMS 4.1 ; Language: MACRO-32 ; Date: 23-Oct-85 ; Author: Victor Lindsey ; ; The information in this document is subject to change without ; notice and should not be construed as a commitment by VLSystems ; to support it at this time, unless such is stated elsewhere in ; writing. This software is being made available free of charge to ; U.S. DECUS members for use on Digital Equipment Corp. VAX computers ; running VMS version 4.1 or later. Neither the author nor VLSystems ; warrants this software for any purpose; those who elect to use this ; code do so at their own risk. ; ; Submitted to the VAX SIG DECUS Library in May, 1986 ; ; Description: ; RSO_CLOSE does a "behind BASIC's back" close taking advantage ; of RMS features normally denied to BASIC users. Care must be ; taken when using RSO_CLOSE because when the I/O channel is ; CLOSEd by RSO_CLOSE, BASIC's exit handler for cleaning up ; what-BASIC-thinks-are-still-OPENed-channels is still "active" ; and must be "de-fused". Such is accomplished by reusing the ; channel with an OPEN that will fail with a trappable "?Fatal ; system I/O error" condition. See RSTSOPEN's RSOTEST.BAS for ; an example of how it is done. ; ; Requirements: ; RSO_CLOSE expects a BASIC environment and will behave as a ; BASIC utility in regards to improper number of arguments ; passed. While five arguments are required, only the first ; argument must be specified (the RMS internal file identifier). ; The other arguments are optional--however, it makes little ; sense to use this routine unless at least one of these optional ; arguments is specified (better to use BASIC's CLOSE statement ; instead). ; ; Inputs: ; FAB_IFI_PW (passed by reference) ; WORD value specifying the RMS internal file identifier ; that BASIC received when file was OPENed. This is NOT ; the channel number that the user uses for regular OPENs ; under BASIC. Can be retrieved through use of RSO_OPENI ; or RSO_OPENO when the file was OPENed. THIS VALUE IS ; REQUIRED! ; ; REVISION_DATE_PQ (passed by reference) ; Optional QUADWORD value (VMS internal format for ; absolute date/time) which when specified, will ; override what VMS normally puts there when file is ; CLOSEd. ; ; N.REVISIONS_PW (passed by reference) ; Optional WORD value which when specified, will ; override what VMS normally put there as to the ; number of times this file has been revised when ; file is CLOSEd. ; ; UIC_PL (passed by reference) ; Optional LONGWORD value which when specified, will ; change the file's ownership (UIC). Usually requires ; GRPPRV or SYSPRV privileges. ; ; PROTECTION.CODE_PW (passed by reference) ; Optional WORD value which when specified, will ; change the file's protection code. Usually requires ; that the user "owns" the file, or that the user ; has GRPPRV or SYSPRV privileges. Format is the ; ones-complement of the VMS internal representation ; of RMS protection code (as returned from RSO_OPEN ; routines); for example: ; ; +-------------------------------+ ; |System | Owner | Group | World | ; |R W E D|R W E D|R W E D|R W E D| ; +-------------------------------+ ; | | ; bit 15 bit 0 ; ; where a "set" bit indicates "access permitted"; a ; "cleared" bit indicates "access denied". ; ; Outputs: ; Double-LONGWORD value returned ; Usually treated as a QUADWORD where the low order ; part (R0) is the RMS status code of the CLOSE performed ; and the high order part (R1) is the system status code ; of the CLOSE performed. ;- ; ; Macro definitions go here ; ; The following "homegrown" macros (which are .NLISTed below) are: ; ; .EVENUP n round up to multiple of "n" ; .EVENDOWN n round down to multiple of "n" ; .DSECT n start definition of offsets section ; .PBLKx n,var define ".BLKx n" offset of positive value var ; .NBLKx n,var define ".BLKx n" offset of negative value var ; .NOCROSS .NOSHOW CONDITIONALS,EXPANSIONS,DEFINITIONS .NLIST ; Suppress listing here to save on paper .MACRO .BLKDEF .IRPC $$$TMP, .MACRO .PBLK'$$$TMP SIZE=1,NAME .NLIST .IIF NOT_BLANK,NAME, NAME=. .BLK'$$$TMP SIZE .LIST .ENDM .PBLK'$$$TMP .MACRO .NBLK'$$$TMP SIZE=1,NAME .NLIST .BLK'$$$TMP - .IIF NOT_BLANK,NAME, NAME=. .LIST .ENDM .NBLK'$$$TMP .ENDR .ENDM .BLKDEF .BLKDEF ; Define .PBLKx and .NBLKx macros .MDELETE .BLKDEF .MACRO .EVENDOWN ALIGN=2 .NLIST .BLKB -<<.&^X7FFF>-<<<.&^X7FFF>/ALIGN>*ALIGN>> .LIST .ENDM .EVENDOWN .MACRO .EVENUP ALIGN=2 .NLIST .BLKB <.&^X7FFF>-<<<.&^X7FFF>/ALIGN>*ALIGN> .LIST .ENDM .EVENUP .MACRO .DSECT START=0,CRF .NLIST .PSECT .ABS_ABS. ,NOPIC,CON,ABS,LCL,NOSHR,NOEXE,NORD,NOWRT,BYTE .=START .IF BLANK CRF .LIST .MEXIT .ENDC .IF IDENTICAL CRF CREF .CROSS .LIST .MEXIT .ENDC .IF IDENTICAL CRF NOCREF .NOCROSS .LIST .MEXIT .ENDC .WARN ; .DSECT 2nd arg not CREF/NOCREF .LIST .ENDM .DSECT .LIST .SHOW BINARY,CALLS ; ; Macroes (which are .NLISTed below) are: ; $FABDEF, $XABDEF, $XABPRODEF, $XABRDTDEF, $BASDEF, $NAMDEF ; .NOCROSS .NOSHOW CONDITIONALS,EXPANSIONS,DEFINITIONS .NLIST ; Suppress listing here to save on paper .MACRO $DEFINI STRUC,GBL,DOT=0 ; Use our own "$DEFINI" macro so that... .SAVE LOCAL_BLOCK ;...we can suppresses DEBUG and TRACEBACK .NOCROSS .IIF DIF ,.ENABLE SUPPRESSION .PSECT $ABS$,ABS .DISABLE DEBUG,TRACEBACK $GBLINI GBL .=DOT .ENDM $DEFINI $FABDEF .MDELETE $FABDEF $XABDEF .MDELETE $XABDEF $XABPRODEF .MDELETE $XABPRODEF $XABRDTDEF .MDELETE $XABRDTDEF $BASDEF .MDELETE $BASDEF $NAMDEF .MDELETE $NAMDEF .LIST .SHOW BINARY,CALLS .EXTERNAL LIB$STOP .EXTERNAL SYS$CLOSE .CROSS .ENABLE DEBUG,TRACEBACK ; ; Define Argument List ; .DSECT ,CREF .PBLKB ,N.ARGS ; Number of arguments (always 0) .PBLKB 3 ; (undefined bytes) .PBLKA ,FAB_IFI_PW ; RMS Internal File Identifier .PBLKA ,REVISION_DATE_PQ ; (internal VMS QUADWORD) .PBLKA ,N.REVISIONS_PW ; Number of revisions .PBLKA ,UIC_PL ; User Identification Code .PBLKA ,PROTECTION_CODE_PW ; (complement of VMS internal format) .EVENUP 4 N.ARGS.DEFINED = <./4>-1 ; ; Define Scratch Area Offsets ; .DSECT ,CREF .NBLKB FAB$C_BLN,FAB .EVENDOWN 4 .NBLKB XAB$C_RDTLEN,RDT_XAB ; Revision_date XAB to add for FAB .EVENDOWN 4 .NBLKB XAB$C_PROLEN,PRO_XAB ; Protection_code XAB to add for FAB .EVENDOWN 4 NL.SCRATCH.AREA = -<.> .SUBTITLE RSO_CLOSE Code ; ;;;;;;;; Execution begins here ; .PSECT _RSO_CODE, PIC,CON,REL,LCL, SHR, EXE, RD,NOWRT,LONG .ENTRY RSO_CLOSE,^M SUBL2 #NL.SCRATCH.AREA,SP ; Allocate scratch area CMPB #N.ARGS.DEFINED,- N.ARGS(AP) ; Correct number of arguments? BLSSU 5$ ; No, skip ahead if too many BEQL 10$ ; Yes, skip to continue PUSHL #BAS$_TOOFEWARG ; Signal "?Too few arguments" BRB 8$ 5$: PUSHL #BAS$_TOOMANARG ; Signal "?Too many arguments" 8$: CALLS #1.,G^LIB$STOP ; ; Initialize FAB, XABPRO, and XABRDT ; 10$: MOVAB FAB(FP),R7 ; Setup FAB pointer MOVC5 #0,(FP),#0,#FAB$C_BLN,(R7) ; Zero FAB fields MOVB #FAB$C_BID,FAB$B_BID(R7) ; Store FAB id byte MOVB #FAB$C_BLN,FAB$B_BLN(R7) ; Store FAB block length MOVAB RDT_XAB(FP),R8 ; Setup XABRDT pointer MOVAB (R8),FAB$L_XAB(R7) ; Link FAB to XABRDT MOVC5 #0,(FP),#0,#XAB$C_RDTLEN,(R8) ; Zero XABRDT MOVB #XAB$C_RDT,XAB$B_COD(R8) ; Set XABRDT code in this XAB MOVB #XAB$C_RDTLEN,XAB$B_BLN(R8) ; Store XABRDT block length MOVAB PRO_XAB(FP),R9 ; Setup XABPRO pointer MOVAB (R9),XAB$L_NXT(R8) ; Link XABRDT to XABPRO MOVC5 #0,(FP),#0,#XAB$C_PROLEN,(R9) ; Zero XABPRO MOVB #XAB$C_PRO,XAB$B_COD(R9) ; Set XABPRO code in this XAB MOVB #XAB$C_PROLEN,XAB$B_BLN(R9) ; Store XABPRO block length ; CLRL XAB$L_NXT(R9) ; Set end of FAB's XAB chain ; ; Load CLOSE arguments from the RSF table ; MOVAB @FAB_IFI_PW(AP),R0 ; FAB's IFI BEQL 11$ ; Skip if not given (use zero instead) MOVW (R0),FAB$W_IFI(R7) ;...else load it 11$: MOVAQ @REVISION_DATE_PQ(AP),R0 ; Revision date BEQL 12$ ; Skip if not given (use zero instead) MOVQ (R0),XAB$Q_RDT(R8) ;...else load it 12$: MOVAW @N.REVISIONS_PW(AP),R0 ; Number of revisions BEQL 13$ ; Skip if not given (use zero instead) MOVW (R0),XAB$W_RVN(R8) ;...else load it 13$: MOVAL @UIC_PL(AP),R0 ; User Identification Code BEQL 14$ ; Skip if not given (use zero instead) MOVL (R0),XAB$L_UIC(R9) ;...else load it 14$: MOVAW @PROTECTION_CODE_PW(AP),R0 ; VMS Protection Code BEQL 15$ ; Skip if not given (use zero instead) MCOMW (R0),XAB$W_PRO(R9) ;...else load it 15$: ; ; Now perform the CLOSE ; CLOSE: $CLOSE FAB=(R7) MOVL FAB$L_STV(R7),R1 ; "Other" half of returned quadword ; ;;;;;;;;;;;;;;; Normal exit ; EXIT: RET .END