.TITLE	lib_file_attributes
	.IDENT	/1-001/
;_____________________________________________________________________________
; FACILITY:	LIB, Local General Utility Library
;
; ABSTRACT:	A routine to return certain FAB and XAB fields for an RMS file.
;		The routine uses the VMS item_list_3 data type to pass
;		requested items.
;
; RESTRICTION:  Does not read or write any length data associated with each
;		item.  This may produce unexpected results when an item is
;		requested using a data type of the incorrect size.
;
; ENVIRONMENT:	Runs at any access mode, AST reentrant.
;_____________________________________________________________________________
; Author:	Tim Cook, 24-FEB-1988
;

	$LIBDEF
	$SSDEF
	$DSCDEF
	$NAMDEF
	$XABDATDEF
	$XABFHCDEF
	$XABPRODEF
	$XABSUMDEF
	$XABALLDEF

	file_name = 4
	pascal_file_var = 8
	item_list = 12
	min_arguments = 3

	byte_size = 1
	word_size = 2
	longword_size = 4
	quadword_size = 8

	item_code = 2
	buffer_address = 4
	retlength_address = 8
	item_length = 12

	min_item = 1

;		FAB fields
	rms__alq = 1		; Alocation quantity (blocks)
	rms__bks = 2		; Bucket size
	rms__bls = 3		; Magnetic tape block size
	rms__deq = 4		; Default file extension quantity
	rms__dev = 5		; Device characteristics
	rms__fac = 6		; File access
	rms__fop = 7		; File-processing options
	rms__fsz = 8		; Fixed length control area size
	rms__gbc = 9		; Global buffer count
	rms__ifi = 10		; Internal file identifier
	rms__mrn = 11		; Maximum record number
	rms__mrs = 12		; Maximum record size
	rms__org = 13		; File organization
	rms__rat = 14		; Record attributes
	rms__rfm = 15		; Record format
	rms__sdc = 16		; Secondary device characteristics
	rms__shr = 17		; File sharing
	rms__sts = 18		; Completion status code
	rms__stv = 19		; Status value (I/O chan if succ. OPEN)
	rms__xab = 20		; Extended attribute block address

;		XABDAT fields
	rms__bdt = 21		; Backup date and time
	rms__cdt = 22		; Creation date and time
	rms__edt = 23		; Expiration date and time
	rms__rdt = 24		; Revision date and time
	rms__rvn = 25		; Revision number

;		XABFHC fields
	rms__ebk = 26		; End-of-file block
	rms__ffb = 27		; First free byte in the end-of-file block
	rms__lrl = 28		; Longest record length
	rms__sbn = 29		; Starting logical block number
	rms__verlimit = 30	; Version limit

;		XABPRO fields
	rms__grp = 31		; Group number of file owner
	rms__mbm = 32		; Member number of file owner
	rms__mtacc = 33		; Magnetic tape accessibility
	rms__pro = 34		; File protection
	rms__uic = 35		; User Identification Code

;		XABSUM fields
	rms__noa = 36		; Number of allocation areas defined
	rms__nok = 37		; Number of keys defined
	rms__pvn = 38		; Prologue version number

;		XABALL fields
	rms__aid = 39		; Area identification number
	rms__aln = 40		; Alignment boundary type
	rms__a_alq = 41		; Area allocation quantity
	rms__aop = 42		; Allocation options
	rms__bkz = 43		; Area bucket size
	rms__a_deq = 44		; Area default extension quantity
	rms__loc = 45		; Area position
	rms__rfi = 46		; Related file identifier
	rms__vol = 47		; Related volume number

;		Block addresses
	rms__fabadr = 48	; Address of FAB
	rms__xabdatadr = 49	; Address of XABDAT
	rms__xabfhcadr = 50	; Address of XABFHC
	rms__xabproadr = 51	; Address of XABPRO
	rms__xabsumadr = 52	; Address of XABSUM
	rms__xaballadr = 53	; Address of XABALL

	max_item = 53

	.PSECT	_fa_data NOEXE, RD, WRT, NOSHR, PIC, LONG

fab:
	$FAB	XAB = xabdat
xabdat:
	$XABDAT NXT = xabfhc
xabfhc:
	$XABFHC NXT = xabpro
xabpro:
	$XABPRO	NXT = xabsum
xabsum:
	$XABSUM	NXT = xaball
xaball:
	$XABALL


	.PSECT	_fa_code EXE, NOWRT, SHR, PIC, CON, REL

	.ENTRY	lib_file_attributes ^M<R2,R3>

	CMPB	(AP), #min_arguments
	BGEQU	args_ok
	MOVL	#SS$_INSFARG, R0	; Insufficient call arguments
	RET

args_ok:
	TSTL	pascal_file_var(AP)
	BNEQ	file_var		; Given file_var, so use it

	MOVAB	fab, R2			; Pointer to FAB being used
	MOVL	file_name(AP), R0
	JSB	G^STR$ANALYZE_SDESC_R1
	CMPL	R0, #NAM$C_MAXRSS
	BLEQU	filename_ok
	MOVL	#LIB$_INVFILSPE, R0	; Invalid file specification
	RET
filename_ok:
	MOVB	R0, FAB$B_FNS(R2)
	MOVL	R1, FAB$L_FNA(R2)
	PUSHL	#0			; success routine
	PUSHL	#0			; error routine
	PUSHL	R2			; FAB address
	CALLS	#3, SYS$OPEN
	BLBS	R0, open_ok
	RET

file_var:
	PUSHL	pascal_file_var(AP)
	CALLS	#1, G^PAS$FAB
	MOVL	R0, R2
	MOVAB	xabdat, FAB$L_XAB(R2)
	PUSHL	#0			; success routine
	PUSHL	#0			; error routine
	PUSHL	R2			; FAB address
	CALLS	#3, SYS$DISPLAY
	BLBS	R0, open_ok
	RET
	
open_ok:

; Process item_list

	SUBL3	#item_length, item_list(AP), R3	; Points to -1th item
item_loop:
	ADDL	#item_length, R3	; Shift pointer to next item
	TSTL	(R3)			; Item list terminated by
	BNEQ	10$			;  null longword
	BRW	no_more_items
10$:	CASEW	item_code(R3), #min_item, #max_item

; pc$ represents the contents of PC after the execution of the CASE instruction

pc$:	.WORD	alq - pc$		; FAB fields
	.WORD	bks - pc$	
	.WORD	bls - pc$
	.WORD	deq - pc$
	.WORD	dev - pc$
	.WORD	fac - pc$
	.WORD	fop - pc$
	.WORD	fsz - pc$
	.WORD	gbc - pc$
	.WORD	ifi - pc$
	.WORD	mrn - pc$
	.WORD	mrs - pc$
	.WORD	org - pc$
	.WORD	rat - pc$
	.WORD	rfm - pc$
	.WORD	sdc - pc$
	.WORD	shr - pc$
	.WORD	sts - pc$
	.WORD	stv - pc$
	.WORD	xab - pc$
	.WORD	bdt - pc$		; XABDAT fields
	.WORD	cdt - pc$
	.WORD	edt - pc$
	.WORD	rdt - pc$
	.WORD	rvn - pc$
	.WORD	ebk - pc$		; XABFHC fields
	.WORD	ffb - pc$
	.WORD	lrl - pc$
	.WORD	sbn - pc$
	.WORD	verlimit - pc$
	.WORD	grp - pc$		; XABPRO fields
	.WORD	mbm - pc$
	.WORD	mtacc - pc$
	.WORD	pro - pc$
	.WORD	uic - pc$
	.WORD	noa - pc$		; XABSUM fields
	.WORD	nok - pc$
	.WORD	pvn - pc$
	.WORD	aid - pc$		; XABALL fields
	.WORD	aln - pc$
	.WORD	a_alq - pc$
	.WORD	aop - pc$
	.WORD	bkz - pc$
	.WORD	a_deq - pc$
	.WORD	loc - pc$
	.WORD	rfi - pc$
	.WORD	vol - pc$
	.WORD	fabadr - pc$		; Block addresses
	.WORD	xabdatadr - pc$
	.WORD	xabfhcadr - pc$
	.WORD	xabproadr - pc$
	.WORD	xabsumadr - pc$
	.WORD	xaballadr - pc$
otherwise:
	PUSHL	#0			; success routine
	PUSHL	#0			; error routine
	PUSHL	R2			; FAB address
	CALLS	#3, SYS$CLOSE
	BLBC	R0, 20$
	MOVL	#LIB$_INVARG, R0	; Item code is not known
20$:	RET

alq:	MOVL	FAB$L_ALQ(R2), @buffer_address(R3)
	BRW	item_loop
bks:	MOVB	FAB$B_BKS(R2), @buffer_address(R3)
	BRW	item_loop
bls:	MOVW	FAB$W_BLS(R2), @buffer_address(R3)
	BRW	item_loop
deq:	MOVW	FAB$W_DEQ(R2), @buffer_address(R3)
	BRW	item_loop
dev:	MOVL	FAB$L_DEV(R2), @buffer_address(R3)
	BRW	item_loop
fac:	MOVB	FAB$B_FAC(R2), @buffer_address(R3)
	BRW	item_loop
fop:	MOVL	FAB$L_FOP(R2), @buffer_address(R3)
	BRW	item_loop
fsz:	MOVB	FAB$B_FSZ(R2), @buffer_address(R3)
	BRW	item_loop
gbc:	MOVW	FAB$W_GBC(R2), @buffer_address(R3)
	BRW	item_loop
ifi:	MOVW	FAB$W_IFI(R2), @buffer_address(R3)
	BRW	item_loop
mrn:	MOVL	FAB$L_MRN(R2), @buffer_address(R3)
	BRW	item_loop
mrs:	MOVW	FAB$W_MRS(R2), @buffer_address(R3)
	BRW	item_loop
org:	MOVB	FAB$B_ORG(R2), @buffer_address(R3)
	BRW	item_loop
rat:	MOVB	FAB$B_RAT(R2), @buffer_address(R3)
	BRW	item_loop
rfm:	MOVB	FAB$B_RFM(R2), @buffer_address(R3)
	BRW	item_loop
sdc:	MOVL	FAB$L_SDC(R2), @buffer_address(R3)
	BRW	item_loop
shr:	MOVB	FAB$B_SHR(R2), @buffer_address(R3)
	BRW	item_loop
sts:	MOVL	FAB$L_STS(R2), @buffer_address(R3)
	BRW	item_loop
stv:	MOVL	FAB$L_STV(R2), @buffer_address(R3)
	BRW	item_loop
xab:	MOVL	FAB$L_XAB(R2), @buffer_address(R3)
	BRW	item_loop
bdt:	MOVQ	xabdat+XAB$Q_BDT, @buffer_address(R3)
	BRW	item_loop
cdt:	MOVQ	xabdat+XAB$Q_CDT, @buffer_address(R3)
	BRW	item_loop
edt:	MOVQ	xabdat+XAB$Q_EDT, @buffer_address(R3)
	BRW	item_loop
rdt:	MOVQ	xabdat+XAB$Q_RDT, @buffer_address(R3)
	BRW	item_loop
rvn:	MOVW	xabdat+XAB$W_RVN, @buffer_address(R3)
	BRW	item_loop
ebk:	MOVL	xabfhc+XAB$L_EBK, @buffer_address(R3)
	BRW	item_loop
ffb:	MOVW	xabfhc+XAB$W_FFB, @buffer_address(R3)
	BRW	item_loop
lrl:	MOVW	xabfhc+XAB$W_LRL, @buffer_address(R3)
	BRW	item_loop
sbn:	MOVL	xabfhc+XAB$L_SBN, @buffer_address(R3)
	BRW	item_loop
verlimit:
	MOVW	xabfhc+XAB$W_VERLIMIT, @buffer_address(R3)
	BRW	item_loop
grp:	MOVW	xabpro+XAB$W_GRP, @buffer_address(R3)
	BRW	item_loop
mbm:	MOVW	xabpro+XAB$W_MBM, @buffer_address(R3)
	BRW	item_loop
mtacc:	MOVB	xabpro+XAB$B_MTACC, @buffer_address(R3)
	BRW	item_loop
pro:	MOVW	xabpro+XAB$W_PRO, @buffer_address(R3)
	BRW	item_loop
uic:	MOVL	xabpro+XAB$L_UIC, @buffer_address(R3)
	BRW	item_loop
noa:	MOVB	xabsum+XAB$B_NOA, @buffer_address(R3)
	BRW	item_loop
nok:	MOVB	xabsum+XAB$B_NOK, @buffer_address(R3)
	BRW	item_loop
pvn:	MOVW	xabsum+XAB$W_PVN, @buffer_address(R3)
	BRW	item_loop
aid:	MOVB	xaball+XAB$B_AID, @buffer_address(R3)
	BRW	item_loop
aln:	MOVB	xaball+XAB$B_ALN, @buffer_address(R3)
	BRW	item_loop
a_alq:	MOVL	xaball+XAB$L_ALQ, @buffer_address(R3)
	BRW	item_loop
aop:	MOVB	xaball+XAB$B_AOP, @buffer_address(R3)
	BRW	item_loop
bkz:	MOVB	xaball+XAB$B_BKZ, @buffer_address(R3)
	BRW	item_loop
a_deq:	MOVW	xaball+XAB$W_DEQ, @buffer_address(R3)
	BRW	item_loop
loc:	MOVL	xaball+XAB$L_LOC, @buffer_address(R3)
	BRW	item_loop
rfi:	MOVW	xaball+XAB$W_RFI, @buffer_address(R3)
	BRW	item_loop
vol:	MOVW	xaball+XAB$W_VOL, @buffer_address(R3)
	BRW	item_loop

fabadr:	MOVL	R2, @buffer_address(R3)
	BRW	item_loop
xabdatadr:
	MOVAB	xabdat, @buffer_address(R3)
	BRW	item_loop
xabfhcadr:
	MOVAB	xabfhc, @buffer_address(R3)
	BRW	item_loop
xabproadr:
	MOVAB	xabpro, @buffer_address(R3)
	BRW	item_loop
xabsumadr:
	MOVAB	xabsum, @buffer_address(R3)
	BRW	item_loop
xaballadr:
	MOVAB	xaball, @buffer_address(R3)
	BRW	item_loop

no_more_items:
	TSTL	pascal_file_var(AP)	; Used file var, so don't close
	BNEQ	return

	PUSHL	#0			; success routine
	PUSHL	#0			; error routine
	PUSHL	R2			; FAB address
	CALLS	#3, SYS$CLOSE
return:	RET
	.END