MODULE DUMP$HEADER (
	IDENT='V04-000',
	ADDRESSING_MODE(EXTERNAL=GENERAL,
	NONEXTERNAL=LONG_RELATIVE)
	) =
BEGIN
!
!
!****************************************************************************
!*									    *
!*  COPYRIGHT (c) 1978, 1980, 1982, 1984 BY				    *
!*  DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASSACHUSETTS.		    *
!*  ALL RIGHTS RESERVED.						    *
!* 									    *
!*  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:  File dump utility
!
! ABSTRACT:
!	This module contains the routines that dump file headers.
!
! ENVIRONMENT:
!	VAX native, user mode.
!
!--
!
!
! AUTHOR:  Martin L. Jack	 CREATION DATE:  16-Aug-1981
!
! MODIFIED BY:
!
!	V03-006	LMP0176		L. Mark Pilant,		6-Dec-1983  9:52
!		Use the correct display width in the call to $FORMAT_ACL.
!		Also, fix a bug in the code that displays the file name
!		extension.
!
!	V03-005	LMP0128		L. Mark Pilant,		13-Jul-1983  11:56
!		Track changes made to $FH2DEF and friends.
!
!	V03-004	LMP0100		L. Mark Pilant,		14-Apr-1983  8:47
!		Convert to the new system service $FORMAT_ACL.
!
!	V03-003	ACG0325		Andrew C. Goldstein,	4-Apr-1983  17:38
!		Fix file header area length check
!
!	V03-002	LMP0050		L. Mark Pilant,		8-Oct-1982  12:50
!		Add the ability to dump the ACL if it exists.
!
!	V03-001	MLJ0090		Martin L. Jack,	6-May-1982  7:52
!		Avoid clobbering checksum word for blocks that are not file
!		headers.
!
!	V03-003	MLJ0080		Martin L. Jack,	17-Feb-1982  16:04
!		Add FAT$W_GBC.
!
!	V03-002	MLJ0045		Martin L. Jack,	12-Sep-1981  17:00
!		Allow file header dump for tape.
!
!	V03-001	MLJ0041		Martin L. Jack,	3-Sep-1981  21:33
!		Add FCH$V_ERASE.
!
!--

LIBRARY 'SYS$LIBRARY:LIB.L32';
REQUIRE 'SRC$:DUMPRE';


FORWARD ROUTINE
	DUMP$HEADER: 	NOVALUE,	! Dump header(s) for current input file
	CHECK_HEADER,			! Validate file header
	DUMP$FAO_:	NOVALUE,	! Format information into line
	DUMP$EOL:	NOVALUE,	! Write line buffer
	DUMP$PUT_FAO_:	NOVALUE,	! Format information and write buffer
	FORMAT_BIT_STRING:
			NOVALUE,	! Format a bit string
	FORMAT_CODED_VALUE:
			NOVALUE,	! Format a coded value
	FORMAT_DATE_VALUE:
			NOVALUE,	! Format a standard system date
	FORMAT_ODS1_DATE_VALUE:
			NOVALUE,	! Format an ODS-1 date
	FORMAT_PROTECTION:
			NOVALUE,	! Format a protection value
	FORMAT_RMS_ATTRIBUTES:
			NOVALUE,	! Format RMS attributes area
	DUMP$ONE_HEADER;		! Dump block as a header, if valid


EXTERNAL ROUTINE
	CHECKSUM,			! Compute file header checksum
	MAKE_STRING,			! Convert ODS-1 filename to ASCII
	DUMP$BLANK_LINE:NOVALUE,	! Write blank line
	DUMP$DUMP_BUFFER: NOVALUE,	! Dump one buffer
	DUMP$NEW_PAGE:	NOVALUE,	! Force page break
	DUMP$OUTPUT_GETMSG: NOVALUE,	! Write gotten message
	DUMP$PUT_LINE:	NOVALUE;	! Write line


EXTERNAL
	DUMP$GL_FLAGS:	BBLOCK,		! General flags
	DUMP$GL_IDESC:	BBLOCK,		! Descriptor for input filename
	DUMP$GL_INAM:	REF BBLOCK,	! Input NAM block
	DUMP$GL_OUTDESC:BBLOCK,		! Descriptor for output buffer
	DUMP$GL_WIDTH;			! Width of output medium


EXTERNAL LITERAL
	DUMP$_HEADER,
	DUMP$_READHEADER;


OWN
	LINE_DESC:	VECTOR[2];


MACRO
	DUMP$PUT_FAO(A)=
	    DUMP$PUT_FAO_(UPLIT BYTE (%ASCIC A)
	    %IF NOT %NULL(%REMAINING) %THEN , %FI %REMAINING) %,

	DUMP$FAO(A)=
	    DUMP$FAO_(UPLIT BYTE (%ASCIC A)
	    %IF NOT %NULL(%REMAINING) %THEN , %FI %REMAINING) %;

GLOBAL ROUTINE DUMP$HEADER: NOVALUE=

!++
!
! FUNCTIONAL DESCRIPTION:
!	This routine dumps the file header(s) for the current input file.
!
! INPUT PARAMETERS:
!	NONE
!
! IMPLICIT INPUTS:
!	NONE
!
! OUTPUT PARAMETERS:
!	NONE
!
! IMPLICIT OUTPUTS:
!	NONE
!
! ROUTINE VALUE:
!	NONE
!
! SIDE EFFECTS:
!	NONE
!
!--

BEGIN
LOCAL
	NAM:		REF BBLOCK,	! Pointer to input file NAM block
	DESC:		VECTOR[2],	! Utility descriptor
	HEADER_DESC:	VECTOR[2],	! Header block descriptor
	CHANNEL:	WORD,		! Channel assigned to input device
	FIB:		BBLOCK[10],	! FIB
	ATR_DESC:	BBLOCK[12],	! ACP attributes list
	HEADER:		BBLOCK[512]	! File header
			VOLATILE,
	STATUS,				! Status variable
	IOSB:		VECTOR[4,WORD];	! I/O status block


! Get a descriptor for the device name and assign a channel to the device.
!
NAM = .DUMP$GL_INAM;
DESC[0] = .NAM[NAM$B_DEV];
DESC[1] = .NAM[NAM$L_DEV];
STATUS = $ASSIGN(DEVNAM=DESC, CHAN=CHANNEL);
IF NOT .STATUS
THEN
    BEGIN
    SIGNAL(DUMP$_READHEADER, 1, DUMP$GL_IDESC, .STATUS);
    RETURN;
    END;


! Initialize to read the primary file header.
!
DESC[0] = 10;
DESC[1] = FIB;
FIB[FIB$L_ACCTL] = 0;
FIB[FIB$W_FID_NUM] = .NAM[NAM$W_FID_NUM];
FIB[FIB$W_FID_SEQ] = .NAM[NAM$W_FID_SEQ];
FIB[FIB$W_FID_RVN] = .NAM[NAM$W_FID_RVN];
ATR_DESC[ATR$W_SIZE] = ATR$S_HEADER;
ATR_DESC[ATR$W_TYPE] = ATR$C_HEADER;
ATR_DESC[ATR$L_ADDR] = HEADER;
ATR_DESC[8,0,32,0] = 0;


! Loop until there are no more headers to be dumped.
!
WHILE TRUE DO
    BEGIN

    ! Read the file header.
    !
    STATUS = $QIOW(
	FUNC=IO$_ACCESS,
	CHAN=.CHANNEL,
	IOSB=IOSB,
	P1=DESC,
	P5=ATR_DESC);
    IF .STATUS THEN STATUS = .IOSB[0];
    IF NOT .STATUS
    THEN
	BEGIN
	SIGNAL(DUMP$_READHEADER, 1, DUMP$GL_IDESC, .STATUS);
	EXITLOOP;
	END;


    ! Dump the file header that was just read.
    !
    IF .DUMP$GL_FLAGS[DUMP$V_FORMATTED]
    THEN
	BEGIN
	DUMP$NEW_PAGE();
	DUMP$OUTPUT_GETMSG(DUMP$_HEADER, %B'0001');
	DUMP$BLANK_LINE();
	DUMP$ONE_HEADER(HEADER);
	END
    ELSE
	BEGIN
	HEADER_DESC[0] = 512;
	HEADER_DESC[1] = HEADER;
	DUMP$DUMP_BUFFER(HEADER_DESC, SS$_NORMAL, TRUE);
	END;


    ! Get the file ID of the next extension header, if any.
    !
    IF .HEADER[FH2$B_STRUCLEV] EQL 2
    THEN
	BEGIN
	FIB[FIB$W_FID_NUM] = .HEADER[FH2$W_EX_FIDNUM];
	FIB[FIB$W_FID_SEQ] = .HEADER[FH2$W_EX_FIDSEQ];
	FIB[FIB$B_FID_NMX] = .HEADER[FH2$B_EX_FIDNMX];
	IF .HEADER[FH2$B_EX_FIDRVN] NEQ 0
	    THEN FIB[FIB$B_FID_RVN] = .HEADER[FH2$B_EX_FIDRVN];
	END
    ELSE
	BEGIN LOCAL MAP_AREA: REF BBLOCK;
	MAP_AREA = HEADER + .HEADER[FH1$B_MPOFFSET]*2;
	FIB[FIB$W_FID_NUM] = .MAP_AREA[FM1$W_EX_FILNUM];
	FIB[FIB$W_FID_SEQ] = .MAP_AREA[FM1$W_EX_FILSEQ];
	END;


    ! If no more extension headers, we are done.
    !
    IF .FIB[FIB$W_FID_NUM] EQL 0 THEN EXITLOOP;
    END;


! All done.  Deassign the channel and return.
!
$DASSGN(CHAN=.CHANNEL);
END;

ROUTINE CHECK_HEADER(HEADER)=

!++
!
! FUNCTIONAL DESCRIPTION:
!	This routine validates a block as a file header.
!
! INPUT PARAMETERS:
!	HEADER		- Pointer to block.
!
! IMPLICIT INPUTS:
!	NONE
!
! OUTPUT PARAMETERS:
!	NONE
!
! IMPLICIT OUTPUTS:
!	NONE
!
! ROUTINE VALUE:
!	0 if the block is not a valid header
!	1 if the block is a valid ODS-1 header
!	2 if the block is a valid ODS-2 header
!
! SIDE EFFECTS:
!	NONE
!
!--

BEGIN
MAP
	HEADER:		REF BBLOCK;	! Pointer to file header
LOCAL
	SAVE_CHECK;			! Save checksum word


! Ensure that the checksum is correct.
!
SAVE_CHECK = .HEADER[FH2$W_CHECKSUM];
IF NOT CHECKSUM(.HEADER)
THEN
    BEGIN
    HEADER[FH2$W_CHECKSUM] = .SAVE_CHECK;
    RETURN 0;
    END;


! Basic validity test for an ODS-2 header.
!
IF .HEADER[FH2$B_STRUCLEV] EQL 2
THEN
    BEGIN
    IF
	.HEADER[FH2$B_IDOFFSET] LSSU $BYTEOFFSET (FH2$L_HIGHWATER)/2 OR
	.HEADER[FH2$B_MPOFFSET] LSSU .HEADER[FH2$B_IDOFFSET] OR
	.HEADER[FH2$B_ACOFFSET] LSSU .HEADER[FH2$B_MPOFFSET] OR
	.HEADER[FH2$B_RSOFFSET] LSSU .HEADER[FH2$B_ACOFFSET] OR
	.HEADER[FH2$B_MAP_INUSE] GTRU .HEADER[FH2$B_ACOFFSET] - .HEADER[FH2$B_MPOFFSET]
    THEN
	RETURN 0
    ELSE
	RETURN 2;
    END;


! Basic validity test for an ODS-1 header.
!
IF .HEADER[FH2$B_STRUCLEV] EQL 1
THEN
    BEGIN
    LOCAL
	MAP_AREA:	REF BBLOCK;	! Pointer to map area


    ! Check the area offsets, the extension RVN, and the retrieval pointer
    ! data for consistency.
    !
    IF .HEADER[FH1$B_IDOFFSET] NEQ FH1$C_LENGTH / 2
    THEN
	RETURN 0;


    MAP_AREA = .HEADER + .HEADER[FH1$B_MPOFFSET]*2;
    IF
	.MAP_AREA[FM1$B_EX_RVN] NEQ 0 OR
	.MAP_AREA[FM1$B_COUNTSIZE] NEQ 1 OR
	.MAP_AREA[FM1$B_LBNSIZE] NEQ 3 OR
	.MAP_AREA[FM1$B_INUSE] GTRU .MAP_AREA[FM1$B_AVAIL] OR
	.MAP_AREA[FM1$B_AVAIL] GTRU 255 - (.MAP_AREA + FM1$C_POINTERS - .HEADER) / 2
    THEN
	RETURN 0
    ELSE
	RETURN 1;
    END;


RETURN 0;
END;

ROUTINE DUMP$FAO_(CTRL,PARAM): NOVALUE=

!++
!
! FUNCTIONAL DESCRIPTION:
!	This routine interfaces to FAO to format information into the line.
!
! INPUT PARAMETERS:
!	CTRL		- ASCIC control string
!	PARAM...	- Parameters required by the control string (if any)
!
! IMPLICIT INPUTS:
!	NONE
!
! OUTPUT PARAMETERS:
!	NONE
!
! IMPLICIT OUTPUTS:
!	Information formatted into the line buffer.
!
! ROUTINE VALUE:
!	NONE
!
! SIDE EFFECTS:
!	NONE
!
!--

BEGIN
MAP
	CTRL:		REF VECTOR[,BYTE];	! ASCIC control string
LOCAL
	OUTLEN:		WORD,			! $FAO resultant length
	DESC:		VECTOR[2];		! Control string descriptor


DESC[0] = .CTRL[0];
DESC[1] = CTRL[1];
$FAOL(CTRSTR=DESC, OUTLEN=OUTLEN, OUTBUF=LINE_DESC, PRMLST=PARAM);
LINE_DESC[0] = .LINE_DESC[0] - .OUTLEN;
LINE_DESC[1] = .LINE_DESC[1] + .OUTLEN;
END;

ROUTINE DUMP$EOL: NOVALUE=

!++
!
! FUNCTIONAL DESCRIPTION:
!	This routine writes the contents of the line buffer and reinitializes
!	for a new line.
!
! INPUT PARAMETERS:
!	NONE
!
! IMPLICIT INPUTS:
!	LINE_DESC	- Descriptor for line.
!
! OUTPUT PARAMETERS:
!	NONE
!
! IMPLICIT OUTPUTS:
!	NONE
!
! ROUTINE VALUE:
!	NONE
!
! SIDE EFFECTS:
!	NONE
!
!--

BEGIN
LINE_DESC[0] = .DUMP$GL_WIDTH - .LINE_DESC[0];
LINE_DESC[1] = .DUMP$GL_OUTDESC[DSC$A_POINTER];
DUMP$PUT_LINE(LINE_DESC);
LINE_DESC[0] = .DUMP$GL_WIDTH;
END;

ROUTINE DUMP$PUT_FAO_(FAO,PARAM): NOVALUE=

!++
!
! FUNCTIONAL DESCRIPTION:
!	This routine combines the actions of DUMP$FAO_ and DUMP$EOL.
!
! INPUT PARAMETERS:
!	As for DUMP$FAO_.
!
! IMPLICIT INPUTS:
!	NONE
!
! OUTPUT PARAMETERS:
!	NONE
!
! IMPLICIT OUTPUTS:
!	NONE
!
! ROUTINE VALUE:
!	NONE
!
! SIDE EFFECTS:
!	NONE
!
!--

BEGIN
BUILTIN
	CALLG,
	AP;


CALLG(.AP, DUMP$FAO_);
DUMP$EOL();
END;

ROUTINE FORMAT_BIT_STRING(VALUE,CODES): NOVALUE=

!++
!
! FUNCTIONAL DESCRIPTION:
!	This routine formats a bit mask.
!
! INPUT PARAMETERS:
!	VALUE		- The bit mask value.
!	CODES		- Pointer to a PLIT of ASCIC bit names.
!
! IMPLICIT INPUTS:
!	NONE
!
! OUTPUT PARAMETERS:
!	NONE
!
! IMPLICIT OUTPUTS:
!	NONE
!
! ROUTINE VALUE:
!	NONE
!
! SIDE EFFECTS:
!	The listing is produced.
!
!--

BEGIN
MAP
	CODES:		REF VECTOR;	! Value names
LOCAL
	INIT_USED,			! Initial used space on line
	V;				! Local copy of value


INIT_USED = .DUMP$GL_WIDTH - .LINE_DESC[0];
V = .VALUE;
IF .V EQL 0
THEN
    DUMP$FAO('<none specified>')
ELSE
    INCR N FROM 0 TO 31 DO
	BEGIN
	IF .V
	THEN
	    BEGIN
	    IF (IF .N GEQU .CODES[-1] THEN TRUE ELSE .CODES[.N] EQL 0)
	    THEN
		BEGIN
		IF .LINE_DESC[0] LSSU 8
		THEN
		    BEGIN
		    DUMP$EOL(); 
		    DUMP$FAO('!#* ', .INIT_USED);
		    END;
		DUMP$FAO('Bit !UL', .N);
		END
	    ELSE
		BEGIN
		IF .LINE_DESC[0] LSSU 2 + .VECTOR[.CODES[.N], 0; ,BYTE]
		THEN
		    BEGIN
		    DUMP$EOL(); 
		    DUMP$FAO('!#* ', .INIT_USED);
		    END;
		DUMP$FAO('!AC', .CODES[.N]);
		END;
	    V = .V<1,31>;
	    IF .V EQL 0 THEN EXITLOOP;
	    DUMP$FAO(', ');
	    END
	ELSE
	    V = .V<1,31>;
	END;
DUMP$EOL();
END;

ROUTINE FORMAT_CODED_VALUE(VALUE,CODES): NOVALUE=

!++
!
! FUNCTIONAL DESCRIPTION:
!	This routine formats a coded integer value.
!
! INPUT PARAMETERS:
!	VALUE		- The coded value.
!	CODES		- Pointer to a PLIT of ASCIC value names.
!
! IMPLICIT INPUTS:
!	NONE
!
! OUTPUT PARAMETERS:
!	NONE
!
! IMPLICIT OUTPUTS:
!	NONE
!
! ROUTINE VALUE:
!	NONE
!
! SIDE EFFECTS:
!	The listing is produced.
!
!--

BEGIN
MAP
	CODES:		REF VECTOR;	! Value names


IF .VALUE GEQU .CODES[-1]
THEN
    DUMP$PUT_FAO('!UL', .VALUE)
ELSE
    DUMP$PUT_FAO('!AC', .CODES[.VALUE]);
END;

ROUTINE FORMAT_DATE_VALUE(VALUE): NOVALUE=

!++
!
! FUNCTIONAL DESCRIPTION:
!	This routine formats a standard system date.
!
! INPUT PARAMETERS:
!	VALUE		- Pointer to the system date.
!
! IMPLICIT INPUTS:
!	NONE
!
! OUTPUT PARAMETERS:
!	NONE
!
! IMPLICIT OUTPUTS:
!	NONE
!
! ROUTINE VALUE:
!	NONE
!
! SIDE EFFECTS:
!	The listing is produced.
!
!--

BEGIN
MAP
	VALUE:		REF VECTOR;	! Pointer to date


IF .VALUE[0] EQL 0
THEN
    DUMP$PUT_FAO('<none specified>')
ELSE
    DUMP$PUT_FAO('!%D', .VALUE);
END;

ROUTINE FORMAT_ODS1_DATE_VALUE(VALUE): NOVALUE=

!++
!
! FUNCTIONAL DESCRIPTION:
!	This routine formats an ODS-1 date.
!
! INPUT PARAMETERS:
!	VALUE		- Pointer to the ODS-1 date.
!
! IMPLICIT INPUTS:
!	NONE
!
! OUTPUT PARAMETERS:
!	NONE
!
! IMPLICIT OUTPUTS:
!	NONE
!
! ROUTINE VALUE:
!	NONE
!
! SIDE EFFECTS:
!	The listing is produced.
!
!--

BEGIN
MAP
	VALUE:		REF VECTOR[,BYTE];	! Pointer to date


IF .VALUE[0] EQL 0
THEN
    DUMP$FAO('<none specified>')
ELSE
    BEGIN
    DUMP$FAO('!AF-!AF-19!AF',
	2, VALUE[0],
	3, VALUE[2],
	2, VALUE[5]);
    IF .VALUE[7] NEQ 0
    THEN
	DUMP$FAO(' !AF:!AF:!AF',
	    2, VALUE[7],
	    2, VALUE[9],
	    2, VALUE[11]);
    END;
DUMP$EOL();
END;

ROUTINE FORMAT_PROTECTION(PROT,CODES): NOVALUE=

!++
!
! FUNCTIONAL DESCRIPTION:
!	This routine formats a protection value.
!
! INPUT PARAMETERS:
!	PROT		- A protection value.
!	CODES		- The four letter codes, e.g. 'RWED'.
!
! IMPLICIT INPUTS:
!	NONE
!
! OUTPUT PARAMETERS:
!	NONE
!
! IMPLICIT OUTPUTS:
!	NONE
!
! ROUTINE VALUE:
!	NONE
!
! SIDE EFFECTS:
!	The listing is produced.
!
!--

BEGIN
MAP
	PROT:		BITVECTOR[16],	! Protection value
	CODES:		VECTOR[,BYTE];	! Letter codes
BIND
	WHO = UPLIT (
	    UPLIT BYTE (%ASCIC 'S:'),
	    UPLIT BYTE (%ASCIC ', O:'),
	    UPLIT BYTE (%ASCIC ', G:'),
	    UPLIT BYTE (%ASCIC ', W:'))
	: VECTOR;


INCR I FROM 0 TO 3 DO
    BEGIN
    DUMP$FAO('!AC', .WHO[.I]);
    INCR J FROM 0 TO 3 DO
	BEGIN
	IF NOT .PROT[.I*4+.J] THEN DUMP$FAO('!AD', 1, CODES[.J]);
	END;
    END;


DUMP$EOL();
END;

ROUTINE FORMAT_RMS_ATTRIBUTES(FAT): NOVALUE=

!++
!
! FUNCTIONAL DESCRIPTION:
!	This routine formats the RMS attributes.
!
! INPUT PARAMETERS:
!	FAT		- Pointer to attributes area.
!
! IMPLICIT INPUTS:
!	NONE
!
! OUTPUT PARAMETERS:
!	NONE
!
! IMPLICIT OUTPUTS:
!	NONE
!
! ROUTINE VALUE:
!	NONE
!
! SIDE EFFECTS:
!	NONE
!
!--

BEGIN
MAP
	FAT:		REF BBLOCK;	! Pointer to RMS attributes area
BUILTIN
	ROT;
BIND
	RTYPE_CODES = PLIT(
	    UPLIT BYTE (%ASCIC 'Undefined'),
	    UPLIT BYTE (%ASCIC 'Fixed'),
	    UPLIT BYTE (%ASCIC 'Variable'),
	    UPLIT BYTE (%ASCIC 'Variable with fixed control'),
	    UPLIT BYTE (%ASCIC 'RMS-11 stream'),
	    UPLIT BYTE (%ASCIC 'LF-terminated stream'),
	    UPLIT BYTE (%ASCIC 'CR-terminated stream')),
	FILEORG_CODES = PLIT(
	    UPLIT BYTE (%ASCIC 'Sequential'),
	    UPLIT BYTE (%ASCIC 'Relative'),
	    UPLIT BYTE (%ASCIC 'Indexed'),
	    UPLIT BYTE (%ASCIC 'Direct')),
	RATTRIB_CODES = PLIT(
	    UPLIT BYTE (%ASCIC 'FORTRAN carriage control'),
	    UPLIT BYTE (%ASCIC 'Implied carriage control'),
	    UPLIT BYTE (%ASCIC 'Print carriage control'),
	    UPLIT BYTE (%ASCIC 'Non-spanned'));


DUMP$PUT_LINE($DESCRIPTOR('    VAX-11 RMS attributes'));
DUMP$FAO('!8* Record type:!22* ');
    FORMAT_CODED_VALUE(.FAT[FAT$V_RTYPE], RTYPE_CODES);
DUMP$FAO('!8* File organization:!16* ');
    FORMAT_CODED_VALUE(.FAT[FAT$V_FILEORG], FILEORG_CODES);
DUMP$FAO('!8* Record attributes:!16* ');
    FORMAT_BIT_STRING(.FAT[FAT$B_RATTRIB], RATTRIB_CODES);
DUMP$PUT_FAO('!8* Record size:!22* !UL',
    .FAT[FAT$W_RSIZE]);
DUMP$PUT_FAO('!8* Highest block:!20* !UL',
    ROT(.FAT[FAT$L_HIBLK], 16));
DUMP$PUT_FAO('!8* End of file block:!16* !UL',
    ROT(.FAT[FAT$L_EFBLK], 16));
DUMP$PUT_FAO('!8* End of file byte:!17* !UL',
    .FAT[FAT$W_FFBYTE]);
DUMP$PUT_FAO('!8* Bucket size:!22* !UL',
    .FAT[FAT$B_BKTSIZE]);
DUMP$PUT_FAO('!8* Fixed control area size:!10* !UL',
    .FAT[FAT$B_VFCSIZE]);
DUMP$PUT_FAO('!8* Maximum record size:!14* !UL',
    .FAT[FAT$W_MAXREC]);
DUMP$PUT_FAO('!8* Default extension size:!11* !UL',
    .FAT[FAT$W_DEFEXT]);
DUMP$PUT_FAO('!8* Global buffer count:!14* !UL',
    .FAT[FAT$W_GBC]);
DUMP$PUT_FAO('!8* Directory version limit:!10* !UL',
    .FAT[FAT$W_VERSIONS]);
END;

GLOBAL ROUTINE DUMP$ONE_HEADER(HEADER)=

!++
!
! FUNCTIONAL DESCRIPTION:
!	This routine dumps one block as a file header if it is valid.
!
! INPUT PARAMETERS:
!	HEADER		- Pointer to block.
!
! IMPLICIT INPUTS:
!	NONE
!
! OUTPUT PARAMETERS:
!	NONE
!
! IMPLICIT OUTPUTS:
!	NONE
!
! ROUTINE VALUE:
!	True if the block was a valid file header and was dumped,
!	otherwise false.
!
! SIDE EFFECTS:
!	NONE
!
!--

BEGIN
MAP
	HEADER:		REF BBLOCK;		! Pointer to file header
LOCAL
	STRUCLEV,				! Structure level
	IDENT_AREA:	REF BBLOCK,		! Pointer to ident area
	IDENT_LENGTH,				! Length of ident area
	MAP_AREA:	REF BBLOCK,		! Pointer to map area
	MAP_LENGTH,				! Length of map area
	ACE_POINTER	: REF BBLOCK,		! Pointer to current ACE
	ACE_BINDESC	: BBLOCK [8],		! Descriptor to binary ACE
	ACE_TXTDESC	: BBLOCK [8],		! Descriptor to converted ACE
	ACE_TEXT	: BBLOCK [512];		! Storage for converted ACE
BIND
	FCH_CODES = PLIT(
	    0,
	    UPLIT BYTE (%ASCIC 'No backup'),
	    UPLIT BYTE (%ASCIC 'Write-back cache'),
	    UPLIT BYTE (%ASCIC 'Read check'),
	    UPLIT BYTE (%ASCIC 'Write check'),
	    UPLIT BYTE (%ASCIC 'Contiguous best try'),
	    UPLIT BYTE (%ASCIC 'Deaccess locked'),
	    UPLIT BYTE (%ASCIC 'Contiguous'),
	    0, 0, 0,
	    UPLIT BYTE (%ASCIC 'Corrupted Access Control List'),
	    UPLIT BYTE (%ASCIC 'Spool file'),
	    UPLIT BYTE (%ASCIC 'Directory'),
	    UPLIT BYTE (%ASCIC 'Suspected bad blocks'),
	    UPLIT BYTE (%ASCIC 'Marked for delete'),
	    UPLIT BYTE (%ASCIC 'Space not charged'),
	    UPLIT BYTE (%ASCIC 'Erase on delete')),
	FJN_CODES = PLIT(
	    UPLIT BYTE (%ASCIC 'Accessible only in recovery unit'),
	    UPLIT BYTE (%ASCIC 'Enable recovery unit journal'),
	    UPLIT BYTE (%ASCIC 'Before image journal'),
	    UPLIT BYTE (%ASCIC 'After image journal'),
	    UPLIT BYTE (%ASCIC 'Audit trail journal')),
	PLACEMENT_CODES = PLIT(
	    UPLIT BYTE (%ASCIC 'Exact'),
	    UPLIT BYTE (%ASCIC 'Cylinder boundary'),
	    0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	    UPLIT BYTE (%ASCIC 'Specific LBN'),
	    UPLIT BYTE (%ASCIC 'Specific RVN'));
BUILTIN
	ROT;


! Validate the header.
!
STRUCLEV = CHECK_HEADER(.HEADER);
IF .STRUCLEV EQL 0 THEN RETURN 0;


! Initialize.
!
LINE_DESC[0] = .DUMP$GL_WIDTH;
LINE_DESC[1] = .DUMP$GL_OUTDESC[DSC$A_POINTER];
IDENT_AREA = .HEADER + .HEADER[FH2$B_IDOFFSET]*2;
MAP_AREA = .HEADER + .HEADER[FH2$B_MPOFFSET]*2;
IDENT_LENGTH = .MAP_AREA - .IDENT_AREA;
MAP_LENGTH = HEADER[FH2$W_CHECKSUM] - .MAP_AREA;


! If the header is valid, dump it in the proper format.
!
DUMP$PUT_LINE($DESCRIPTOR('Header area'));
DUMP$PUT_FAO('    Identification area offset:!11* !UL',
    .HEADER[FH2$B_IDOFFSET]);
DUMP$PUT_FAO('    Map area offset:!22* !UL',
    .HEADER[FH2$B_MPOFFSET]);
IF .STRUCLEV EQL 2
THEN
    BEGIN
    LOCAL
	P:		REF BBLOCK;

    DUMP$PUT_FAO('    Access control area offset:!11* !UL',
	.HEADER[FH2$B_ACOFFSET]);
    DUMP$PUT_FAO('    Reserved area offset:!17* !UL',
	.HEADER[FH2$B_RSOFFSET]);
    DUMP$PUT_FAO('    Extension segment number:!13* !UL',
	.HEADER[FH2$W_SEG_NUM]);
    DUMP$PUT_FAO('    Structure level and version:!10* !UL, !UL',
	.HEADER[FH2$B_STRUCLEV],
	.HEADER[FH2$B_STRUCVER]);
    DUMP$PUT_FAO('    File identification:!18* (!UL,!UL,!UL)',
	.HEADER[FH2$W_FID_NUM] + .HEADER[FH2$B_FID_NMX]^16,
	.HEADER[FH2$W_FID_SEQ],
	.HEADER[FH2$B_FID_RVN]);
    DUMP$PUT_FAO('    Extension file identification:!8* (!UL,!UL,!UL)',
	.HEADER[FH2$W_EX_FIDNUM] + .HEADER[FH2$B_EX_FIDNMX]^16,
	.HEADER[FH2$W_EX_FIDSEQ],
	.HEADER[FH2$B_EX_FIDRVN]);
    FORMAT_RMS_ATTRIBUTES(HEADER[FH2$W_RECATTR]);
    DUMP$FAO('    File characteristics:!17* ');
	FORMAT_BIT_STRING(.HEADER[FH2$L_FILECHAR], FCH_CODES);
%(
    DUMP$FAO('    Record protection:!20* ');
	FORMAT_PROTECTION(.HEADER[FH2$W_RECPROT], 'RWCD');
)%
    DUMP$PUT_FAO('    Map area words in use:!16* !UL',
	.HEADER[FH2$B_MAP_INUSE]);
    DUMP$PUT_FAO('    Access mode:!26* !UL',
	.HEADER[FH2$B_ACC_MODE]);
    DUMP$PUT_FAO('    File owner UIC:!23* !%I',
	.HEADER[FH2$L_FILEOWNER]);
    DUMP$FAO('    File protection:!22* ');
	FORMAT_PROTECTION(.HEADER[FH2$W_FILEPROT], 'RWED');
    DUMP$PUT_FAO('    Back link file identification:!8* (!UL,!UL,!UL)',
	.HEADER[FH2$W_BK_FIDNUM] + .HEADER[FH2$B_BK_FIDNMX]^16,
	.HEADER[FH2$W_BK_FIDSEQ],
	.HEADER[FH2$B_BK_FIDRVN]);
    DUMP$FAO('    Journal control flags:!16* ');
	FORMAT_BIT_STRING(.HEADER[FH2$B_JOURNAL], FJN_CODES);
    DUMP$PUT_FAO('    Highest block written:!16* !UL',
	(IF .HEADER[FH2$L_HIGHWATER] GTR 0
	THEN .HEADER[FH2$L_HIGHWATER] - 1 ELSE 0));
    DUMP$BLANK_LINE();
    DUMP$PUT_LINE($DESCRIPTOR('Identification area'));
    IF .IDENT_LENGTH GEQU $BYTEOFFSET(FI2$W_REVISION)
    THEN
	IF .HEADER[FH2$B_MPOFFSET] - .HEADER[FH2$B_IDOFFSET]
	GEQU ($BYTEOFFSET (FI2$T_FILENAMEXT) + FI2$S_FILENAMEXT) / 2
	THEN
	    DUMP$PUT_FAO('    File name:!28* !AF!AF',
		FI2$S_FILENAME, IDENT_AREA[FI2$T_FILENAME],
		FI2$S_FILENAMEXT, IDENT_AREA[FI2$T_FILENAMEXT])
	ELSE
	    DUMP$PUT_FAO('    File name:!28* !AF',
		FI2$S_FILENAME, IDENT_AREA[FI2$T_FILENAME]);
    IF .IDENT_LENGTH GEQU $BYTEOFFSET(FI2$Q_CREDATE)
    THEN
	DUMP$PUT_FAO('    Revision number:!22* !UL',
	    .IDENT_AREA[FI2$W_REVISION]);
    IF .IDENT_LENGTH GEQU $BYTEOFFSET(FI2$Q_REVDATE)
    THEN
	BEGIN
	DUMP$FAO('    Creation date:!24* ');
	FORMAT_DATE_VALUE(IDENT_AREA[FI2$Q_CREDATE]);
	END;
    IF .IDENT_LENGTH GEQU $BYTEOFFSET(FI2$Q_EXPDATE)
    THEN
	BEGIN
	DUMP$FAO('    Revision date:!24* ');
	FORMAT_DATE_VALUE(IDENT_AREA[FI2$Q_REVDATE]);
	END;
    IF .IDENT_LENGTH GEQU $BYTEOFFSET(FI2$Q_BAKDATE)
    THEN
	BEGIN
	DUMP$FAO('    Expiration date:!22* ');
	FORMAT_DATE_VALUE(IDENT_AREA[FI2$Q_EXPDATE]);
	END;
    IF .IDENT_LENGTH GEQU FI2$C_LENGTH
    THEN
	BEGIN
	DUMP$FAO('    Backup date:!26* ');
	FORMAT_DATE_VALUE(IDENT_AREA[FI2$Q_BAKDATE]);
	END;
    DUMP$BLANK_LINE();
    DUMP$PUT_LINE($DESCRIPTOR('Map area'));
    DUMP$PUT_LINE($DESCRIPTOR('    Retrieval pointers'));
    P = .MAP_AREA;
    UNTIL .P GEQA .MAP_AREA + .HEADER[FH2$B_MAP_INUSE]*2 DO
	BEGIN
	IF .P[FM2$V_FORMAT] EQL FM2$C_PLACEMENT
	THEN
	    BEGIN
	    DUMP$FAO('!8* Placement control:  ');
	    FORMAT_BIT_STRING(.P[0,0,14,0], PLACEMENT_CODES);
	    P = .P + 2;
	    END
	ELSE
	    BEGIN
	    LOCAL
		COUNT, LBN;

	    CASE .P[FM2$V_FORMAT] FROM FM2$C_FORMAT1 TO FM2$C_FORMAT3 OF
		SET

		[FM2$C_FORMAT1]:
		    BEGIN
		    COUNT = .P[FM2$B_COUNT1];
		    LBN = .P[FM2$W_LOWLBN];
		    LBN<16,16> = .P[FM2$V_HIGHLBN];
		    P = .P + 4;
		    END;

		[FM2$C_FORMAT2]:
		    BEGIN
		    COUNT = .P[FM2$V_COUNT2];
		    LBN = .P[FM2$L_LBN2];
		    P = .P + 6;
		    END;

		[FM2$C_FORMAT3]:
		    BEGIN
		    COUNT = ROT(..P, 16) AND (1^30-1);
		    LBN = .P[FM2$L_LBN3];
		    P = .P + 8;
		    END;

		TES;

	    DUMP$PUT_FAO('!8* Count: !10UL!8* LBN: !10UL',
		.COUNT + 1,
	    	.LBN);
	    END;
	END;
    IF .HEADER[FH2$B_ACOFFSET] NEQ .HEADER[FH2$B_RSOFFSET]
    THEN
	BEGIN
	DUMP$BLANK_LINE ();
	DUMP$PUT_LINE ($DESCRIPTOR ('Access Control List'));
	ACE_POINTER = .HEADER + .HEADER[FH2$B_ACOFFSET]*2;
	CH$FILL (0, 8, ACE_BINDESC);
	CH$FILL (0, 8, ACE_TXTDESC);
	UNTIL .ACE_POINTER[ACE$B_SIZE] EQL 0
	   OR .ACE_POINTER GEQA .HEADER + .HEADER[FH2$B_RSOFFSET]*2
	DO
	    BEGIN
	    ACE_BINDESC[DSC$W_LENGTH] = .ACE_POINTER[ACE$B_SIZE];
	    ACE_BINDESC[DSC$A_POINTER] = .ACE_POINTER;
	    ACE_TXTDESC[DSC$W_LENGTH] = 512;
	    ACE_TXTDESC[DSC$A_POINTER] = ACE_TEXT;
	    $FORMAT_ACL (ACLENT = ACE_BINDESC,
			 ACLLEN = ACE_TXTDESC[DSC$W_LENGTH],
			 ACLSTR = ACE_TXTDESC,
			 WIDTH = %REF (80),
			 TRMDSC = $DESCRIPTOR (%CHAR (13), %CHAR (10)),
			 INDENT = %REF (4));
	    DUMP$PUT_LINE (ACE_TXTDESC);
	    ACE_POINTER = .ACE_POINTER + .ACE_POINTER[ACE$B_SIZE];
	    END;
	END;
    IF .HEADER[FH2$B_RSOFFSET] NEQ $BYTEOFFSET (FH2$W_CHECKSUM) / 2
    THEN
	BEGIN
	DUMP$BLANK_LINE ();
	DUMP$PUT_LINE ($DESCRIPTOR ('User reserved area'));
	P = .HEADER + .HEADER[FH2$B_RSOFFSET]*2;
	DO
	    BEGIN
	    CASE HEADER[FH2$W_CHECKSUM] - .P FROM 1 TO 3 OF
		SET
		[1]:		BEGIN
				DUMP$PUT_FAO ('          !XB     "!AF"',
					      .P[0, 0, 8, 0], 1, .P);
				P = .P + 1;
				END;
		[2]:		BEGIN
				DUMP$PUT_FAO ('        !XW    "!AF"',
					      .P[0, 0, 16, 0], 2, .P);
				P = .P + 2;
				END;
		[3]:		BEGIN
				DUMP$PUT_FAO ('      !6XL   "!AF"',
					      .P[0, 0, 24, 0], 3, .P);
				P = .P + 3;
				END;
		[OUTRANGE]:	BEGIN
				DUMP$PUT_FAO ('    !XL  "!AF"',
					      .P[0, 0, 32, 0], 4, .P);
				P = .P + 4;
				END;
		TES
	    END
	UNTIL .P GEQA HEADER[FH2$W_CHECKSUM];
	END;
    END
ELSE
    BEGIN
    LOCAL
	P:		REF BBLOCK,
	FILE_NAME:	VECTOR[20,BYTE],
	FILE_LENGTH;


    DUMP$PUT_FAO('    File identification:!18* (!UL,!UL)',
	.HEADER[FH1$W_FID_NUM],
	.HEADER[FH1$W_FID_SEQ]);
    DUMP$PUT_FAO('    Structure level and version:!10* !UL, !UL',
	.HEADER[FH2$B_STRUCLEV],
	.HEADER[FH2$B_STRUCVER]);
    DUMP$PUT_FAO('    File owner UIC:!23* !%I',
	.HEADER[FH1$B_UICGROUP]^16 OR .HEADER[FH1$B_UICMEMBER]);
    DUMP$FAO('    File protection:!22* ');
	FORMAT_PROTECTION(.HEADER[FH1$W_FILEPROT], 'RWED');
    DUMP$FAO('    File characteristics:!17* ');
	FORMAT_BIT_STRING(.HEADER[FH1$W_FILECHAR], FCH_CODES);
    FORMAT_RMS_ATTRIBUTES(HEADER[FH1$W_RECATTR]);
    DUMP$BLANK_LINE();
    DUMP$PUT_LINE($DESCRIPTOR('Identification area'));
    FILE_LENGTH = MAKE_STRING(
	IDENT_AREA[FI1$W_FILENAME] - $BYTEOFFSET(NMB$W_NAME),
	FILE_NAME);
    DUMP$PUT_FAO('    File name:!28* !AF',
	.FILE_LENGTH, FILE_NAME);
    DUMP$PUT_FAO('    Revision number:!22* !UL',
	.IDENT_AREA[FI1$W_REVISION]);
    DUMP$FAO('    Revision date:!24* ');
	FORMAT_ODS1_DATE_VALUE(IDENT_AREA[FI1$T_REVDATE]);
    DUMP$FAO('    Creation date:!24* ');
	FORMAT_ODS1_DATE_VALUE(IDENT_AREA[FI1$T_CREDATE]);
    DUMP$FAO('    Expiration date:!22* ');
	FORMAT_ODS1_DATE_VALUE(IDENT_AREA[FI1$T_EXPDATE]);
    DUMP$BLANK_LINE();
    DUMP$PUT_LINE($DESCRIPTOR('Map area'));
    DUMP$PUT_FAO('    Extension segment number:!13* !UL',
	.MAP_AREA[FM1$B_EX_SEGNUM]);
    DUMP$PUT_FAO('    Extension file identification:!8* (!UL,!UL,!UL)',
	.MAP_AREA[FM1$W_EX_FILNUM],
	.MAP_AREA[FM1$W_EX_FILSEQ],
	.MAP_AREA[FM1$B_EX_RVN]);
    DUMP$PUT_FAO('    Retrieval pointer count size:!9* !UL',
	.MAP_AREA[FM1$B_COUNTSIZE]);
    DUMP$PUT_FAO('    Retrieval pointer LBN size:!11* !UL',
	.MAP_AREA[FM1$B_LBNSIZE]);
    DUMP$PUT_FAO('    Map area words in use:!16* !UL',
	.MAP_AREA[FM1$B_INUSE]);
    DUMP$PUT_FAO('    Map area words available:!13* !UL',
	.MAP_AREA[FM1$B_AVAIL]);
    DUMP$PUT_LINE($DESCRIPTOR('    Retrieval pointers'));
    P = .MAP_AREA + FM1$C_POINTERS;
    UNTIL .P GEQA .MAP_AREA + FM1$C_POINTERS + .MAP_AREA[FM1$B_INUSE]*2 DO
	BEGIN
	DUMP$PUT_FAO('!8* Count: !10UL!8* LBN: !10UL',
	    .P[FM1$B_COUNT] + 1,
	    .P[FM1$W_LOWLBN] + .P[FM1$B_HIGHLBN]^16);
	P = .P + 4;
	END;
    END;
DUMP$BLANK_LINE();
DUMP$PUT_FAO('Checksum:!33* !UL',
    .HEADER[FH2$W_CHECKSUM]);


RETURN 1;
END;

END
ELUDOM