.TITLE FLIST - File LIST (Directory Manager) ;+ ; Copyright 1990-1991 by Hunter Goatley. This code may be freely distributed ; and modified for non-commercial purposes as long as this copyright notice ; is retained. ; ; If you make any changes, please let me know so that I can incorporate ; them. ; .IDENT /01-007/ ;======================================================================== ;= Never having time to rewrite files sure does affect the = ;= ease-of-reading, -modifying, and a lot of other things! = ;= My apologies to anyone who has to look at this code! = ;======================================================================== ;++ ; ; Routine: FLIST ; ; Author: Hunter Goatley ; Western Kentucky University ; Academic Computing, STH 226 ; Bowling Green, KY 42101 ; Voice: 502-745-5251 ; E-mail: GOATHUNTER@WKUVX1.bitnet ; ; Date: December 22, 1987 ; ; Functional Description: ; ; This program calls TPU with a section file that implements a ; directory manager, letting you see files, delete them, rename ; them, copy them, etc. ; ; Modified by: ; ; 01-007 Hunter Goatley 1-MAY-1991 15:09 ; Extended length of displayed filename by 1 more character. ; Added copying of MRN to COPY_FILE. Added ability to define ; and delete a logical in the job logical name table. Added ; ability to translate a logical. Changed size of USZ from ; 65535 to 65534; fixes bug in copying .TLB files. ; Removed setting of NAM FOP in INFAB; this was causing the ; NAM$W_DID field to be used, resulting in the incorrect ; placement of the copy. ; ; 01-006 Hunter Goatley 9-FEB-1991 15:12 ; Extended length of displayed filename by 8 characters. ; ; 01-005 Hunter Goatley 30-JUN-1990 21:54 ; Hacked together code to get and return the file name, sizes, ; and creation date. ; ; 01-004 Hunter Goatley 5-APR-1989 20:18 ; Added argument to TPU$CONTROL call to disable the message ; "Editing session is not being journaled". ; ; 01-003 Hunter Goatley February 24, 1988 ; Fixed bug that caused FLIST to bomb out. GETMSG_ARGS was in ; a NOWRT PSECT and ERR_RET was trying to write to it. Moved ; argument list to different PSECT. ; ; 01-002 Hunter Goatley January 16, 1988 ; Added code to accept a file specification on the command line. ; Use of this requires FLIST to be set up as a foreign command. ; ; 01-001 Hunter Goatley December 22, 1987 ; Original version. This version includes the original ; code that was written as a separate TPU$CALLUSER routine. ; ;-- .LIBRARY /SYS$LIBRARY:LIB.MLB/ .DSABL GLOBAL ; Declare external references .ENABL SUPPRESSION ; Don't list unreference symbols .NOSHOW BINARY ; Include binary in listings ; ; External system routines: ; .EXTRN EDT$EDIT ; Callable EDT .EXTRN LIB$DELETE_FILE ; Delete a file .EXTRN LIB$DELETE_LOGICAL ; Deassign a logical .EXTRN LIB$GET_FOREIGN ; Get DCL foreign command line .EXTRN LIB$RENAME_FILE ; Rename a file .EXTRN LIB$SET_LOGICAL ; Define a logical .EXTRN STR$COPY_DX ; Copy strings by descriptor .EXTRN TPU$CLEANUP ; Clean everything up .EXTRN TPU$CONTROL ; Turn control over to TPU .EXTRN TPU$EXECUTE_INIFILE ; Execute an INIT file .EXTRN TPU$FILEIO .EXTRN TPU$HANDLER ; TPU condition handler .EXTRN TPU$INITIALIZE ; Initialize TPU .EXTRN TPU$K_CALLUSER .EXTRN TPU$K_FILEIO .EXTRN TPU$K_FILENAME .EXTRN TPU$K_OPTIONS .EXTRN TPU$K_SECTIONFILE .EXTRN TPU$M_DELETE_CONTEXT .EXTRN TPU$M_DISPLAY .EXTRN TPU$M_SECTION $ATRDEF ; ACP QIO attribute codes $DSCDEF ; Descriptor symbols $FATDEF ; ACP record attributes $FABDEF ; FAB symbols $FIBDEF ; File Information Block symbols $IODEF ; I/O symbols $LIBDEF ; LIB$ status symbols $LNMDEF ; Logical name symbols $NAMDEF ; NAM symbols $RABDEF ; RAB symbols $RMSDEF ; RMS symbols $SBKDEF ; ACP QIO statistics block syms $SSDEF ; System service status symbols $STSDEF ; Status symbols .SHOW BINARY ; Include binary in listings BLANK = 32 ; ASCII blank FUNC_CODE = 1 * 4 INPUT_STR = 2 * 4 RETURN_STR = 3 * 4 .MACRO ON_ERR WHERE,?LABEL BLBS R0,LABEL BRW WHERE LABEL: .ENDM ON_ERR ;=============================================================================== ; ; Read-only data ; .PSECT _FLIST_DATA_RD,NOEXE,NOWRT,LONG,SHR,PIC INIT_ARGS: .LONG 1 ; TPU$INITIALIZE argument list .ADDRESS CALLBACK_BPV ; ... Bound Procedure Value ; ... for callback routine CALLBACK_BPV: ; Bound Procedure Value .ADDRESS INITIALIZE_CALLBACK ; Address of routine .LONG 0 ; Environment (passed in R1) ; CALLUSER_BPV: ; Bound Procedure Value .ADDRESS FLIST_CALLUSER ; Address of routine .LONG 0 ; Environment (passed in R1) ; CLEAN_ARGS: .LONG 1 ; TPU$CLEANUP argument list .ADDRESS CLEANUP_FLAG ; ... Cleanup options ; CLEANUP_FLAG: .LONG ; FILEIO_BPV: .ADDRESS TPU$FILEIO ; BPV for FILEIO routine .LONG 0 ; (points to TPU$FILEIO) ; OPTIONS_MASK: .LONG ; SECTION: .ASCII /FLIST_TPU_SECTION/ SEC_LEN = . - SECTION COPYFAO: .ASCID /!AF copied to !AF/ ; FAO string for COPIED message DELFAO: .ASCID /!AS deleted/ ; FAO string for DELETED message RENFAO: .ASCID /!AS renamed to !AS/ ; FAO string for RENAMED message JOB_LNM_TABLE: .ASCID /LNM$JOB/ ; Name of JOB logical name table LNM$TABLE: .ASCID /LNM$DCL_LOGICAL/ ; Logical name table name TRNLNM_ITMLST: .WORD LNM$C_NAMLENGTH ; Build item list for $TRNLNM .WORD LNM$_STRING ; Want equiv. string returned .ADDRESS RETMSG+8 ; ... Return it here .ADDRESS RETMSG ; ... Return length here ;=============================================================================== ; ; Read/Write data ; .PSECT _FLIST_DATA,NOEXE,WRT,LONG,SHR,PIC ; ; Item list returned to TPU$INITIALIZE. This list provides all information ; about all of the TPU options selected. The FILEIO descriptor is always ; present in the list. ; ; NOTE: To facilitate running FLIST without the need to relink, ; ITEM_LIST: .WORD 4 ; Item list descriptor for .WORD TPU$K_FILEIO ; ... FILEIO routine (points .ADDRESS FILEIO_BPV ; ... to BPV for default TPU .LONG 0 ; ... routine (TPU$FILEIO)) .WORD 4 ; Item list descriptor .WORD TPU$K_CALLUSER .ADDRESS CALLUSER_BPV .LONG 0 .WORD 4 .WORD TPU$K_OPTIONS .ADDRESS OPTIONS_MASK .LONG 0 .WORD SEC_LEN .WORD TPU$K_SECTIONFILE .ADDRESS SECTION .LONG 0 TPU_K_FILENAME: .WORD 0 ; Length filled in at run-time .WORD TPU$K_FILENAME .ADDRESS FOR_BUFF+8 .LONG 0 .LONG 0 .LONG 0 .LONG 0 .ALIGN LONG ; ;*** File Access Block for input ; INFAB: $FAB FAC=, - ; File Access (GET only) SHR= ; Sharing => allow others to read also ; ;*** Record Access Block for input ; INRAB: $RAB FAB=INFAB, - ; The File Access Block RAC=SEQ, - ; Record Access is sequential UBF=INREC, - ; Input buffer address USZ=65534 ; The max size of an input record ; ;*** File Access Block for output ; OUTFAB: $FAB FAC=, - ; File Access (PUT only) NAM=RESNAM ; ... Get the resultant name ; ;*** Record Access Block for output ; OUTRAB: $RAB FAB=OUTFAB, - ; The File Access Block RAC=SEQ, - ; Record Access is sequential RBF=INREC ; The record buffer address RESNAM: $NAM RSA=FINALNAM, - ; NAMe block used by $CREATE RSS=NAM$C_MAXRSS ; ... FINALNAM: .BLKB NAM$C_MAXRSS ; Buffer for resultant name .ALIGN LONG INREC: .BLKB 65536 ; Input buffer RETMSG: .WORD 256 ; Descriptor/buffer for messages .BYTE DSC$K_DTYPE_T ; ... to be returned .BYTE DSC$K_CLASS_S .ADDRESS .+4 .BLKB 256 FOR_BUFF: .WORD 256 ; LIB$GET_FOREIGN buffer .BYTE DSC$K_DTYPE_T ; ... .BYTE DSC$K_CLASS_S ; ... .ADDRESS .+4 ; ... .BLKB 256 ; ... GETMSG_ARGS: $GETMSG MSGLEN=RETMSG, - ; Argument list for $GETMSG call BUFADR=RETMSG ; ... to return error msg text .ALIGN LONG PARSE_FAB: $FAB FOP=NAM, - ; Options: NAM block NAM=PARSE_NAM ; NAM block address PARSE_NAM: $NAM ESA=PARSE_RESULT, - ; Resultant string address ESS=NAM$C_MAXRSS, - ; Buffer size NOP=SYNCHK PARSE_RESULT: .BLKB NAM$C_MAXRSS .ALIGN LONG ; ;*** File Access Block for RMS Parse & Search ; SEARCH_FAB: $FAB FNA = 10$,- ; Space for file spec to search FOP = NAM, - ; Use NAM block inputs NAM = SEARCH_NAM ; The address of the NAM block 10$: .BLKB NAM$C_MAXRSS ; Space for file spec .ALIGN LONG ; ;*** Record Access Block for input ; SEARCH_NAM: $NAM RSA=RES_FILNAM, - ; Buffer for resultant filename RSS=NAM$C_MAXRSS,- ; Resultant string area size ESA=EXP_FILNAM, - ; Resultant string address ESS=NAM$C_MAXRSS ; Buffer size RES_FILNAM: .BLKB NAM$C_MAXRSS ; The resultant string area EXP_FILNAM: .BLKB NAM$C_MAXRSS ; The resultant string area .ALIGN LONG FIB_DESC: .LONG 6*4 ; Build a short FIB to lookup .ADDRESS .+4 ; ... file names FIB: .BLKL 6 ; ... ATR: .WORD ATR$S_STATBLK ; The attribute item list tells .WORD ATR$C_STATBLK ; ... the ACP we want the file .ADDRESS STATBLK ; ... name .WORD ATR$S_CREDATE ; The attribute item list tells .WORD ATR$C_CREDATE ; ... the ACP we want the file .ADDRESS CREDATE ; ... name .WORD ATR$S_RECATTR ; The attribute item list tells .WORD ATR$C_RECATTR ; ... the ACP we want the file .ADDRESS RECATTR ; ... name .LONG 0 ; ... End of item list FILE_DISK_D: .LONG 0 ; Descriptor for the disk .ADDRESS FILE_DISK ; ... FILE_DISK: .BLKB 80 ; Space for the disk device name STATBLK: .BLKB ATR$S_STATBLK ; ACP QIO statistics block CREDATE: .BLKB ATR$S_CREDATE ; File creation date RECATTR: .BLKB ATR$S_RECATTR ; ACP QIO record attributes DISK_CHAN: .LONG 0 ; Space for I/O channel number QIO_IOSB: .QUAD 0 ; I/O Status Block FAO_FORMAT: $FAO CTRSTR = 10$,- ; $FAO argument list used to OUTBUF = RETMSG,- ; ... format the string to OUTLEN = RETMSG,- ; ... be returned to TPU P1 = 0,- ; ... (P1--P5 filled in at P2 = 0,- ; ... run-time) P3 = 0,- ; ... P4 = 0,- ; ... P5 = 0 ; ... .ALIGN LONG 10$: .ASCID \!39AD !7UL/!7 !%D\ .ALIGN LONG TRANSLATED_LOGICAL: .WORD LNM$C_NAMLENGTH ; Descriptor for equivalence str .BYTE DSC$K_DTYPE_T ; ... Text string .BYTE DSC$K_CLASS_S ; ... Static string .ADDRESS .+4 ; ... Buffer follows .BLKB LNM$C_NAMLENGTH ; ... ;+ ; ; FUNCTIONAL DESCRIPTION: ; ; FORMAL ARGUMENTS: ; ; SIDE EFFECTS: ; ; Invokes TPU. The section file is not closed as part of the cleanup ; for efficiency on subsequent calls. ; ;- .PSECT _FLIST_CODE,EXE,NOWRT,LONG,PIC,SHR .ENTRY FLIST,^M PUSHAW FOR_BUFF ; Get anything given on the CLRL -(SP) ; ... command line (use PUSHAQ FOR_BUFF ; ... LIB$GET_FOREIGN) CALLS #3,G^LIB$GET_FOREIGN ; ... MOVW FOR_BUFF,TPU_K_FILENAME ; Move length to item list ; 10$: MOVAB G^TPU$HANDLER,(FP) ; Set up condition handler to be ; ... the default TPU handler ; CALLG INIT_ARGS,G^TPU$INITIALIZE ; Initialize TPU BLBC R0,20$ ; Error? Return it ; CALLS #0,G^TPU$EXECUTE_INIFILE ; Execute the initialization BLBC R0,20$ ; Error? Return it ; PUSHAL #1 ; Disable "no journal" message CALLS #1,G^TPU$CONTROL ; Turn control over to VAXTPU BLBC R0,20$ ; Error? Return it PUSHL R0 ; Save the status ; CALLG CLEAN_ARGS,G^TPU$CLEANUP ; Clean up BLBC R0,20$ ; Error? Return it ; POPL R0 ; Restore TPU$CONTROL status 20$: BICL2 #STS$M_INHIB_MSG,R0 ; Turn off inhibit message ; ... on image exit RET ; Return to caller ;+ ; ; Routine: INITIALIZE_CALLBACK ; ; Functional description: ; ; This routine is called by TPU$INITIALIZE to set up the initialization ; parameters item list. The address of the item list is returned to ; TPU$INITIALIZE. ;- .ENTRY INITIALIZE_CALLBACK,^M<> MOVAB ITEM_LIST,R0 ; Now return item list address RET ; ... to TPU$INITIALIZE ;+ ; Author: Hunter Goatley ; Date: September 17, 1987 ; Purpose: Perform file manipulations for FLIST (a VAXTPU program). ; ; Modified by: ; ; 01-001 Hunter Goatley September 17, 1987 ; Original version. ;- .ENTRY FLIST_CALLUSER,^M CASEW @FUNC_CODE(AP),#0,#8 ; Base CASE on 4(AP) 10$: .WORD DELETE_FILE-10$ ; 0 -> delete the file .WORD RENAME_FILE-10$ ; 1 -> rename the file .WORD COPY_FILE-10$ ; 2 -> copy the file .WORD EDT_FILE-10$ ; 3 -> edit file with EDT .WORD FILE_PARSE-10$ ; 4 -> parse file specification .WORD SEARCH_FOR_FILES-10$ ; 5 -> search for files .WORD DEFINE_JOB_LOGICAL-10$ ; 6 -> DEFINE/JOB logical .WORD DELETE_JOB_LOGICAL-10$ ; 7 -> DEASSIGN/JOB a logical .WORD TRANSLATE_LOGICAL_NAME-10$ ; 8 -> Translate a logical RET ; Ignore anything else DELETE_FILE: PUSHL INPUT_STR(AP) CALLS #1,G^LIB$DELETE_FILE ; Delete the file BLBS R0,10$ ; Error? No, continue on BRW ERR_RET ; Error? Go return it 10$: $FAO_S CTRSTR=DELFAO, - ; Format the "deleted" OUTBUF=RETMSG, - ; ... message OUTLEN=RETMSG, - ; ... P1=INPUT_STR(AP) ; ... BRW OK_RET RENAME_FILE: MOVAQ -(SP),R3 MOVAQ -(SP),R4 MOVQ @INPUT_STR(AP),R1 ; Get the descriptor ; String is 2 ASCIC strings -> .ASCIC oldname + .ASCIC newname MOVZBL (R2)+,(R3) ; Get length of old filename MOVAL (R2),4(R3) ; Get address of old filename ADDL2 (R3),R2 ; Bump over the string MOVZBL (R2)+,(R4) ; Get length of new filename MOVAL (R2),4(R4) ; Get address of new filename SUBL2 #256,SP ; Allocate stack space PUSHAL (SP) ; Build a descriptor PUSHL #256 ; ... MOVL SP,R5 ; Get new space's address PUSHAQ (R5) ; Push the address CLRQ -(SP) ; Skip these CLRQ -(SP) ; Skip these CLRQ -(SP) ; Skip these CLRL -(SP) ; Skip these PUSHAQ (R3) ; Use old name as default PUSHAQ (R4) ; Rename the file PUSHAQ (R3) ; ... CALLS #11,G^LIB$RENAME_FILE ; ... BLBS R0,10$ ; Success? Go on BRW ERR_RET ; No - return the error message 10$: LOCC #BLANK,(R5),@4(R5) ; Look for blank at end SUBW2 R0,(R5) ; Get real length of resultant $FAO_S CTRSTR=RENFAO, - ; Format the "renamed" OUTBUF=RETMSG, - ; ... message OUTLEN=RETMSG, - ; ... P1=R3, - ; ... P2=R5 BRW OK_RET EDT_FILE: ; Edit file with EDT editor PUSHL INPUT_STR(AP) PUSHL INPUT_STR(AP) CALLS #2,G^EDT$EDIT ; Invoke callable EDT BLBS R0,10$ BRW ERR_RET 10$: CLRW RETMSG BRW OK_RET FILE_PARSE: MOVAL PARSE_FAB,R2 ; Point R3 to FAB MOVQ @INPUT_STR(AP),R0 ; Get string descriptor MOVB R0,FAB$B_FNS(R2) ; Store file name size MOVL R1,FAB$L_FNA(R2) ; Store file name address $PARSE FAB=(R2) ; Go parse it MOVAL PARSE_NAM,R2 ; Point to resultant NAM MOVZBL NAM$B_NAME(R2),R0 ; Get length of name ADDB2 NAM$B_TYPE(R2),R0 ; Get length of type ADDB2 NAM$B_VER(R2),R0 ; Add in length of version PUSHL NAM$L_NAME(R2) ; Build descriptor for return PUSHL R0 ; ... string PUSHAQ (SP) ; Copy string to TPU's buffer PUSHAQ @RETURN_STR(AP) ; ... CALLS #2,G^STR$COPY_DX ; ... RET ; Return to TPU COPY_FILE: MOVC5 #0,#0,#0,#NAM$C_MAXRSS,FINALNAM ; Clear out resultant name MOVAB INFAB,R2 ; Move addresses to registers MOVAB OUTFAB,R3 ; ... for efficiency MOVAB INRAB,R4 ; ... MOVAB OUTRAB,R5 ; ... MOVQ @INPUT_STR(AP),R6 ; Get descriptor of file names MOVZBL (R7)+,R0 ; Get the length $FAB_STORE - ; Store the filename in the FAB FAB=(R2), - ; ... FNA=(R7), - ; ... FNS=R0 ; ... $FAB_STORE - ; Store the filename in the FAB FAB=(R3), - ; ... Use for the default DNA=(R7), - ; ... file spec for the target DNS=R0 ; ... (for wildcarding) ADDL2 R0,R7 ; Bump over the filename MOVZBL (R7)+,R0 ; Get the length $FAB_STORE - ; Store the filename in the FAB FAB=(R3), - ; ... FNA=(R7), - ; ... FNS=R0 ; ... ; $OPEN FAB=(R2) ; Open the input file BLBS R0,10$ ; .... Error? Go report it BRW 80$ ; ... 10$: $CONNECT RAB=(R4) ; Connect the RAB to it BLBS R0,20$ ; .... Error? Go report it BRW 80$ ; ... ; 20$: MOVL FAB$L_ALQ(R2),FAB$L_ALQ(R3) ; Copy the Allocation size MOVW FAB$B_BKS(R2),FAB$B_BKS(R3) ; Copy the bucket size MOVL FAB$L_MRN(R2),FAB$L_MRN(R3) ; Copy the maximum record # MOVW FAB$W_MRS(R2),FAB$W_MRS(R3) ; Copy the Maximum Record Size MOVB FAB$B_ORG(R2),FAB$B_ORG(R3) ; Copy the file ORGanization MOVB FAB$B_RAT(R2),FAB$B_RAT(R3) ; Copy the Record ATtributes MOVB FAB$B_RFM(R2),FAB$B_RFM(R3) ; Copy the Record ForMat ; $CREATE FAB=(R3) ; Open the same file for output BLBS R0,30$ ; .... Error? Go report it BRW 80$ ; ... 30$: $CONNECT RAB=(R5) ; Connect BLBC R0,70$ ; .... Error? Go report it ; 40$: $READ RAB=(R4) ; Read a block of the file BLBS R0,50$ ; Success? Go on CMPL R0,#RMS$_EOF ; End of file? BEQL 60$ ; Yes --- go back BRB 70$ ; No - return the error 50$: MOVW RAB$W_RSZ(R4),RAB$W_RSZ(R5) ; Move the size to the OUTRAB $WRITE RAB=(R5) ; Write the modified record out BLBC R0,70$ ; Error? Return it BRB 40$ ; Go get next record and process it ; 60$: $CLOSE FAB=(R2) ; Close input file $CLOSE FAB=(R3) ; Close output file MOVZBL FAB$B_FNS(R2),R0 ; Convert the file name size MOVZBL RESNAM+NAM$B_RSL,R1 ; Convert resultant name size $FAO_S CTRSTR=COPYFAO, - ; Format the "copied" OUTBUF=RETMSG, - ; ... message OUTLEN=RETMSG, - ; ... P1=R0, - ; ... P2=FAB$L_FNA(R2), - ; ... P3=R1, - ; ... P4=RESNAM+NAM$L_RSA ; ... BRB OK_RET ; Return to caller 70$: PUSHL R0 ; Save the error status $CLOSE FAB=(R3) ; Close the file POPL R0 ; Restore the status 80$: PUSHL R0 ; Save the status $CLOSE FAB=(R2) ; Close the input file POPL R0 ; Restore the status ; BRB ERR_RET ; Go get the status message ERR_RET: MOVL R0,GETMSG_ARGS+GETMSG$_MSGID ; Move the value to arg list $GETMSG_G - ; Get the error message text GETMSG_ARGS ; ... OK_RET: PUSHAQ RETMSG ; Copy the "deleted" message PUSHL RETURN_STR(AP) ; ... to TPU's buffer CALLS #2,G^STR$COPY_DX ; ... MOVW #256,RETMSG ; Reset the descriptor size MOVL #SS$_NORMAL,R0 ; Return normal status RET ; Return to VMS SEARCH_FOR_FILES: MOVAL SEARCH_FAB,R6 ; Get FAB address MOVQ @INPUT_STR(AP),R0 ; Get descriptor passed in MOVZWL R0,R0 ; Get length of the string CMPB R0,FAB$B_FNS(R6) ; Is this the same name? BNEQ 10$ ; Branch if not same length CMPC3 R0,(R1),@FAB$L_FNA(R6) ; Check string itself BEQL 20$ ; Branch if same string ; ; A new search file specification has been given on this call. Copy the file ; spec to our local storage (the SEARCH_FAB already points to this data area). ; 10$: MOVB R0,FAB$B_FNS(R6) ; Save the length of string MOVC3 R0,(R1),@FAB$L_FNA(R6) ; Copy the file specification $PARSE FAB=(R6) ; Parse the file specification ON_ERR ERR_RET ; Branch to return any errors 20$: $SEARCH FAB=(R6) ; Search for the next file CMPL #RMS$_NMF,R0 ; No more files? BNEQ 30$ ; Branch if no more CLRW RETMSG ; Return a null string BRW 80$ ; ... 30$: ON_ERR ERR_RET ; Branch to return error MOVAL SEARCH_NAM,R7 ; Get address of NAM block MOVW NAM$W_FID(R7),FIB+FIB$W_FID ; Store the file ID in the MOVW NAM$W_FID+2(R7),FIB+FIB$W_FID+2 ; ... File Information Block MOVW NAM$W_FID+4(R7),FIB+FIB$W_FID+4 ; ... for the ACP QIOs ; ; See if it's the same device. If not, assign a channel to the new device. ; MOVZBL NAM$B_DEV(R7),R4 ; Get length of disk device MOVL NAM$L_DEV(R7),R5 ; Get address of disk device CMPW R4,FILE_DISK_D ; Is this the same disk? BNEQ 40$ ; Branch if not CMPC3 R4,(R5),FILE_DISK ; Is it the same disk? BEQL 60$ ; Branch if so 40$: MOVW R4,FILE_DISK_D ; Save the length MOVC3 R4,(R5),FILE_DISK ; Copy the disk string TSTW DISK_CHAN ; Is there a channel open? BEQL 50$ ; Branch if not $DASSGN_S - ; Deassign the disk I/O channel CHAN=DISK_CHAN ; ... 50$: $ASSIGN_S - ; Assign a channel to the new CHAN=DISK_CHAN,- ; ... disk device DEVNAM=FILE_DISK_D ; ... ON_ERR ERR_RET ; Branch to return any error 60$: MOVAL ATR,R0 ; Get Attribute list address MOVAL FIB_DESC,R1 ; Get FIB address $QIOW_S CHAN=DISK_CHAN,- ; Convert the FID to a file FUNC=#IO$_ACCESS,- ; ... specification IOSB=QIO_IOSB,- ; ... P1=(R1),- ; ... P5=R0 ; ... ON_ERR ERR_RET ; Branch to return error MOVZBL NAM$B_NAME(R7),R0 ; Get the length of the file ADDB2 NAM$B_TYPE(R7),R0 ; ... name, type, and version ADDB2 NAM$B_VER(R7),R0 ; ... MOVAL FAO_FORMAT,R1 ; Get the address of $FAO arglst MOVL R0,FAO$_P1(R1) ; Store the filename length MOVL NAM$L_NAME(R7),FAO$_P2(R1) ; Store its address ; ; For PDP-11 compatibility, the End-of-file block and the filesize are stored ; with the high- and low-words swapped. Before they can be put in the $FAO ; arglst, we have to rotate them so they're in the correct order. ; ; When the end-of-file position corresponds to a block boundary, by convention ; FAT$L_EFBLK contains the end-of-file VBN plus 1, and FAT$W_FFBYTE contains 0. ; MOVL RECATTR+FAT$L_EFBLK,R0 ; Get the EOF block # ROTL #16,R0,FAO$_P3(R1) ; Fix it up and store it TSTW RECATTR+FAT$W_FFBYTE ; Is it a block boundary? BNEQ 70$ ; Branch if not DECL FAO$_P3(R1) ; Yes - real VBN is (VBN-1) BGEQ 70$ ; Branch if not negative CLRL FAO$_P3(R1) ; If -1, make it 0 70$: MOVL STATBLK+SBK$L_FILESIZE,R0 ; Get the file size in blocks ROTL #16,R0,FAO$_P4(R1) ; Fix it up and store it MOVAL CREDATE,FAO$_P5(R1) ; Store creation date address $FAO_G (R1) ; Format the return string ON_ERR ERR_RET ; Branch on any error 80$: PUSHAQ RETMSG ; Return the file specification PUSHL RETURN_STR(AP) ; ... to TPU CALLS #2,G^STR$COPY_DX ; ... MOVW #256,RETMSG ; Reset buffer length MOVL #SS$_NORMAL,R0 ; Return normal status RET ; Return to VMS DEFINE_JOB_LOGICAL: MOVAQ -(SP),R3 MOVAQ -(SP),R4 MOVQ @INPUT_STR(AP),R1 ; Get the descriptor ; String is 2 ASCIC strings -> .ASCIC oldname + .ASCIC newname MOVZBL (R2)+,(R3) ; Get length of old filename MOVAL (R2),4(R3) ; Get address of old filename ADDL2 (R3),R2 ; Bump over the string MOVZBL (R2)+,(R4) ; Get length of new filename MOVAL (R2),4(R4) ; Get address of new filename PUSHAQ JOB_LNM_TABLE ; Push addr of lnm table name PUSHAQ (R4) ; Push addr of equiv. string PUSHAQ (R3) ; Push addr of logical name CALLS #3,G^LIB$SET_LOGICAL ; Go define the logical BLBC R0,10$ ; Branch on error CLRW RETMSG ; Go return null string BRW OK_RET ; .... 10$: BRW ERR_RET ; Go return the error DELETE_JOB_LOGICAL: PUSHAQ JOB_LNM_TABLE ; Push addr of lnm table name PUSHAQ @INPUT_STR(AP) ; Push addr of logical name CALLS #2,G^LIB$DELETE_LOGICAL ; Go deassign the logical BLBC R0,10$ ; Branch on error CLRW RETMSG ; Go return null string BRW OK_RET ; .... 10$: BRW ERR_RET ; Go return the error TRANSLATE_LOGICAL_NAME: $TRNLNM_S - ; Call $TRNLNM to translate it TABNAM=LNM$TABLE,- ; ... Look in process table LOGNAM=@INPUT_STR(AP),- ; ... Pass the logical name on ITMLST=TRNLNM_ITMLST ; ... BLBC R0,10$ ; Error? Return it BRW OK_RET ; Success: return equiv. string 10$: BRW ERR_RET ; ... .END FLIST