| Here's a program to do what you want.
It checks for the SUPERVISOR translation of SYS$INPUT
(Assuming your command file does an ASSIGN/USER to define SYS$INPUT
to point to SYS$COMMAND; the super value of the logical SYS$INPUT
still points to the disk file.)
It does and OPEN and DISPLAY on that file to get the File ID and
then uses an ACP QIO to get the full filespec.
Note that the ACP$C_FILE_SPEC attribute didn't get documented until
V4.4; it may exist in previous versions of VMS.
If you make this a subroutine, you may want to do a IO$_DEACCESS
and a $DASSGN before returning the filespec.
Enjoy!
-Rick
PROGRAM FIND_CMD_FILE
C
C PROGRAM DESCRIPTION:
C
C Obtain the name of the DCL command file
C this program was run with
C
C AUTHORS:
C
C Rick Murphy
C
C CREATION DATE: 11-May-1987
C
C
C C H A N G E L O G
C
C Date | Name | Description
C----------------+-------+-----------------------------------------------------
C [change_entry]
C
IMPLICIT NONE
INCLUDE '($SYSSRVNAM)'
INCLUDE '($PSLDEF)'
INCLUDE '($FABDEF)'
INCLUDE '($NAMDEF)'
INCLUDE '($IODEF)'
INCLUDE '($ATRDEF)'
STRUCTURE /ATRLIST/ ! ACP Attribute list
INTEGER*2 ITEM_SIZE
INTEGER*2 ITEM_CODE
INTEGER*4 ITEM_ADDR
END STRUCTURE !ATRLIST
STRUCTURE /FIBDEF/ ! Short FIB
INTEGER*4 FIB$L_ACCTL
INTEGER*2 FIB$W_FID(3)
END STRUCTURE
RECORD /FABDEF/ FAB
RECORD /NAMDEF/ NAM
RECORD /FIBDEF/ FIB
RECORD /ATRLIST/ ATTRIB_LIST(2)
INTEGER*4 STATUS
CHARACTER*9 INPUT_NAME/'SYS$INPUT'/
INTEGER*4 I
INTEGER*2 ACP_IOSB(4)
CHARACTER*512 FILE_SPEC
INTEGER*2 FILE_SPEC_LEN
INTEGER*2 CHAN
INTEGER*4 FIB_DESCR(2)
CHARACTER*16 DEVICE_NAME
EQUIVALENCE (FILE_SPEC_LEN,FILE_SPEC)
C
C Set up the FAB
C
FAB.FAB$B_BID = FAB$C_BID
FAB.FAB$B_BLN = FAB$C_BLN
FAB.FAB$B_SHR = FAB$M_GET .OR. FAB$M_PUT .OR. FAB$M_UPD
FAB.FAB$L_FOP = FAB$M_NAM
FAB.FAB$B_FNS = 9
FAB.FAB$L_FNA = %LOC(INPUT_NAME)
FAB.FAB$L_NAM = %LOC(NAM)
FAB.FAB$B_ACMODES = PSL$C_SUPER
C
C Set up the NAM
C
NAM.NAM$B_BID = NAM$C_BID
NAM.NAM$B_BLN = NAM$C_BLN
STATUS = sys$OPEN (
1 FAB,,)
IF (.NOT. STATUS) THEN
TYPE *,'Error in $OPEN'
CALL SYS$EXIT(%VAL(STATUS))
END IF
STATUS = SYS$DISPLAY(FAB,,)
IF (.NOT. STATUS) THEN
TYPE *,'Error in $DISPLAY'
CALL SYS$EXIT(%VAL(STATUS))
END IF
STATUS = SYS$CLOSE(FAB,,)
IF (.NOT. STATUS) THEN
TYPE *,'Error in $CLOSE'
CALL SYS$EXIT(%VAL(STATUS))
END IF
C
C Assign a channel
C The device name is in the FAB as an ASCIC string.
C *you may want to check the device class before continuing,
C *as the ACP QIO will die if it's a terminal...
C
I = ICHAR(NAM.NAM$T_DVI)
DEVICE_NAME = NAM.NAM$T_DVI(2:I+1) // ':'
STATUS = sys$assign (
1 DEVICE_NAME,
1 CHAN,,)
IF (.NOT. STATUS) THEN
TYPE *,'Error in $ASSIGN'
CALL SYS$EXIT(%VAL(STATUS))
ENDIF
C
C Set up the FIB
C
DO I = 1, 3
FIB.FIB$W_FID(I) = NAM.NAM$W_FID(I)
ENDDO
FIB.FIB$L_ACCTL = 0
ATTRIB_LIST(1).ITEM_SIZE = 512
ATTRIB_LIST(1).ITEM_CODE = ATR$C_FILE_SPEC
ATTRIB_LIST(1).ITEM_ADDR = %LOC(FILE_SPEC)
ATTRIB_LIST(2).ITEM_SIZE = 0
ATTRIB_LIST(2).ITEM_CODE = 0
FIB_DESCR(1) = 10
FIB_DESCR(2) = %LOC(FIB)
STATUS = sys$qiow (,
1 %VAL(CHAN),
1 %VAL(IO$_ACCESS),
1 ACP_IOSB,,,
1 FIB_DESCR,,,,
1 ATTRIB_LIST,)
IF (.NOT. STATUS) THEN
TYPE *,'Error in ACP Access Function'
CALL SYS$EXIT(%VAL(STATUS))
END IF
IF (.NOT. ACP_IOSB(1)) THEN
TYPE *,'Error in ACP Access Function'
CALL SYS$EXIT(%VAL(ACP_IOSB(1)))
END IF
C
C The file spec comes back as a word-counted ascic string.
C Extract the relevant portion
C
FILE_SPEC = FILE_SPEC(2:2+FILE_SPEC_LEN)
CALL STR$TRIM(FILE_SPEC,FILE_SPEC,I)
TYPE *,'Command file is',FILE_SPEC(1:I)
CALL EXIT
END
|
| RE: .1 Rick, I tried that with the program below the FF. It always complains
about a bad IFI (RMS-F-IFI). The translation seems to be OK. Is the $DISPLAY
really going to connect you back to the right IFAB? Comments welcome; I've
been asked this question many times and I'd love to see an answer myself...
= Giles =
.title PROC - find and print name of calling procedure
$lnmdef
$rmsdef
$fabdef
$namdef
namlen = 60
.psect PDATA,nowrt,long
inp: .ascid /SYS$INPUT/
tab: .ascid /LNM$FILE_DEV/
itm: .word namlen,LNM$_STRING
.long buf
.long len
.long 0
.psect DATA,wrt,long
buf: .blkb namlen
len: .blkl 1
fab: $fab nam=namblk
namblk: $nam rsa=filename,rss=namlen
filedesc:
.blkl 1
.long filename
filename:
.blkb namlen
.psect CODE,nowrt,long
.entry PROC,^m<>
;
; Translate SYS$INPUT to buf
;
$TRNLNM_S -
lognam=inp,-
tabnam=tab,-
itmlst=itm
blbc r0,error
;
; Plug the IFI into the FAB and $DISPLAY it
;
moval fab,r9
movw buf+2,fab$w_ifi(r9)
$display -
fab=fab
blbc r0,error
;
; Print the resultant string
;
moval namblk,r9
movzbl nam$b_rsl(r9),filedesc
pushaq filedesc
calls #1,g^LIB$PUT_OUTPUT
blbc r0,error
ret
error: $EXIT_S r0
.end PROC
|
| Re: .3
Two things...
You need to set the FAB$M_PPF_IND bit into the IFI to tell RMS
it's really OK to use it as an indirect IFI to a process perm. file.
Plus, you need to check the supervisor mode logical as I said above.
The attached version of your program works.. however, as this is
for a customer, the FORTRAN version is better; it uses only documented
interfaces. (The PPF access stuff is not.)
-Rick
.title PROC - find and print name of calling procedure
$lnmdef
$rmsdef
$fabdef
$namdef
$psldef
namlen = 60
.psect PDATA,nowrt,long
inp: .ascid /SYS$INPUT/
tab: .ascid /LNM$FILE_DEV/
itm: .word namlen,LNM$_STRING
.long buf
.long len
.long 0
.psect DATA,wrt,long
buf: .blkb namlen
len: .blkl 1
fab: $fab nam=namblk
namblk: $nam rsa=filename,rss=namlen
filedesc:
.blkl 1
.long filename
filename:
.blkb namlen
.psect CODE,nowrt,long
.entry PROC,^m<>
;
; Translate SYS$INPUT to buf
;
$TRNLNM_S -
lognam=inp,-
tabnam=tab,-
itmlst=itm,-
acmode=#psl$c_super
blbc r0,error
;
; Plug the IFI into the FAB and $DISPLAY it
;
moval fab,r9
bisw3 #fab$m_ppf_ind, buf+2,fab$w_ifi(r9)
$display -
fab=fab
blbc r0,error
;
; Print the resultant string
;
moval namblk,r9
movzbl nam$b_rsl(r9),filedesc
pushaq filedesc
calls #1,g^LIB$PUT_OUTPUT
blbc r0,error
ret
error: $EXIT_S r0
.end PROC
|