NOTE:

This version of BLOCKO.VAX contains a correction. In the original version, 
a process is not guaranteed that the XAB blocks will be there once the file 
is opened. Therefore, in certain cases the XAB address that was saved in 
the first useropen to be used in the second would not be a valid one 
because the XAB blocks had disappeared. Only the FAB, RAB and NAM blocks 
will remain defined while the file is open.

To correct this problem, the author now builds an XAB summary block and 
calls the RMS $DISPLAY service to fill in the summary block about the rest 
of the chain. He then obtains a section of memory using $EXPREG to save the 
XAB block chain and rebuilds them (if any) using the RMS $DISPLAY routine 
of the opened file. This time, however, the blocks are saved so that they 
may be used in the second useropen when creating the new file. The XAB 
chain contains XAB blocks which define the extended file attributes.



$ FORTRAN/CHECK TEST_COPY_FILE,UTL_COPY_FILE,UTL___COPY_FILE_FROM,-
UTL___COPY_FILE_TO,UTL___FILL_XABALL,UTL___FILL_XABKEY
$ LINK TEST_COPY_FILE,-
	UTL_COPY_FILE,-
	UTL___COPY_FILE_FROM,-
	UTL___COPY_FILE_TO,-
	UTL___FILL_XABALL,-
	UTL___FILL_XABKEY






	IMPLICIT NONE

	CHARACTER*80	INFILE, OUTFILE
	INTEGER*4	INLEN, OUTLEN
	INTEGER*4	STATUS
	INTEGER*4	UTL_COPY_FILE

10	WRITE( 6, '(1X,A,$)' )'Input file to copy: '
	READ( 5, '(Q,A)', ERR=10, END=9999 )INLEN, INFILE
	IF( INLEN .LT. 1 )GOTO 10
20	WRITE( 6, '(1X,A,$)' )'Output file: '
	READ( 5, '(Q,A)', ERR=20, END=9999 )OUTLEN, OUTFILE
	IF( OUTLEN .LT. 1 )GOTO 20

	CALL LIB$INIT_TIMER()

	STATUS = UTL_COPY_FILE( INFILE(1:INLEN), OUTFILE(1:OUTLEN) )
	CALL LIB$SIGNAL( %VAL(STATUS) )

	CALL LIB$SHOW_TIMER()

9999	END





	OPTIONS /CHECK /EXTEND_SOURCE

	INTEGER*4 FUNCTION UTL_COPY_FILE( FROM, TO )
C 
C FUNCTIONAL DESCRIPTION:	
C 
C	 This function copies 1 file to another.  Both files must NOT be open
C	when this routine is called.  All RMS errors are passed back to the 
C	calling program.
C 
C IMPLICIT INPUTS:
C 
C	 FROM - file to copy from
C	 VMS usage: char_string
C	 type:      character string
C	 access:    readonly
C	 mechanism: by descriptor, dynamic string
C	  
C	 TO - file to copy to
C	 VMS usage: char_string
C	 type:      character string
C	 access:    readonly
C	 mechanism: by descriptor, dynamic string
C	  
C IMPLICIT OUTPUTS:
C 
C	none
C 
C FUNCTION VALUE:
C 
C	 VMS usage: cond_value
C	 type:      longword (unsigned)
C	 access:    write-only
C	 mechanism: by value
C	  
C SIDE EFFECTS:
C 
C	 none
C 
	IMPLICIT NONE

	INCLUDE '($SSDEF)'
	INCLUDE '($RMSDEF)'
	INCLUDE '($FABDEF)'
	INCLUDE '($RABDEF)'
	INCLUDE '($XABDEF)'
	INCLUDE '($XABALLDEF)'
	INCLUDE '($XABKEYDEF)'
	INCLUDE '($XABSUMDEF)'
	INCLUDE '($SYSSRVNAM)'

	STRUCTURE /XAB_DEF/
		UNION
		MAP
			RECORD /XABALLDEF/ XABALLDEF
		ENDMAP
		MAP
			RECORD /XABKEYDEF/ XABKEYDEF
		ENDMAP
		MAP
			RECORD /XABSUMDEF/ XABSUMDEF
		ENDMAP
		MAP
			RECORD /XABDEF/ XABDEF
		ENDMAP
		ENDUNION
	ENDSTRUCTURE

	PARAMETER	BUFSIZ = 51200
	CHARACTER*(*)	FROM
	CHARACTER*(*)	TO
	CHARACTER*(BUFSIZ)	BUFFER
	EXTERNAL	UTL___COPY_FILE_FROM
	EXTERNAL	UTL___COPY_FILE_TO
	INTEGER*4	ILUN_FROM
	INTEGER*4	ILUN_TO
	INTEGER*4	IOS
	INTEGER*4	STATUS
	INTEGER*4	XABBUF(2)
	RECORD		/FABDEF/ INFAB
	RECORD		/RABDEF/ INRAB, OUTRAB
	RECORD		/XAB_DEF/ XAB
	COMMON		/RMSCOM/ INFAB, INRAB, OUTRAB, XAB, XABBUF


	! Open file to copy from using a useropen (COPY_FILE_FROM) function 
	! which will load fab_from structure and rab_from structure.

	CALL UTL_GET_LUN( ILUN_FROM )

	OPEN( UNIT=ILUN_FROM, FILE=FROM, STATUS='OLD', 
	1	USEROPEN=UTL___COPY_FILE_FROM, IOSTAT=IOS )
	IF( IOS .NE. 0 )THEN
		CALL ERRSNS( IOS,,,, UTL_COPY_FILE )
		RETURN
	ENDIF

	! Open file to copy to using a useropen (COPY_FILE_TO) function which
	! will load rab_to structure.

	CALL UTL_GET_LUN( ILUN_TO )

	OPEN( UNIT=ILUN_TO, FILE=TO, STATUS='OLD', 
	1	USEROPEN=UTL___COPY_FILE_TO, IOSTAT=IOS )
	IF( IOS .NE. 0 )THEN
		CALL ERRSNS( IOS,,,, UTL_COPY_FILE )
		RETURN
	ENDIF

	! Buffer size = BUFSIZ bytes (BUFSIZ/512 blocks)

	INRAB.RAB$W_USZ = BUFSIZ
	INRAB.RAB$L_UBF = %LOC(BUFFER)
	OUTRAB.RAB$L_RBF   = %LOC(BUFFER)

	! Read and write only as many bytes as were read

	STATUS = SYS$READ( INRAB )
	DO WHILE( STATUS )
		OUTRAB.RAB$W_RSZ = INRAB.RAB$W_RSZ
		STATUS = SYS$WRITE( OUTRAB )
		STATUS = SYS$READ( INRAB )
	ENDDO

	CLOSE( ILUN_FROM )
	CLOSE( ILUN_TO )

	IF( STATUS .EQ. RMS$_EOF )THEN
		! If last error was RMS$_EOF then everything went ok
		UTL_COPY_FILE = SS$_NORMAL
	ELSE
		UTL_COPY_FILE = STATUS
	ENDIF

	END





	OPTIONS /CHECK /EXTEND_SOURCE

	INTEGER*4 FUNCTION UTL___COPY_FILE_FROM( FAB, RAB, ILUN )
C 
C FUNCTIONAL DESCRIPTION:	
C 
C	 This function acts as a useropen routine for the UTL_COPY_FILE
C	routine.  This useropen opens the file to be copied for BLOCK I/O
C	and saves the FAB block to be used by UTL___COPY_FILE_TO.
C 
C IMPLICIT INPUTS:
C 
C	 FAB - File access block
C	 VMS usage: fab
C	 type:      longword (unsigned)
C	 access:    modify
C	 mechanism: by reference, array reference
C	  
C	 RAB - Read access block
C	 VMS usage: rab
C	 type:      longword (unsigned)
C	 access:    modify
C	 mechanism: by reference, array reference
C	  
C	 ILUN - logical unit number
C	 VMS usage: longword_signed
C	 type:      longword integer (signed)
C	 access:    readonly
C	 mechanism: by reference
C	  
C IMPLICIT OUTPUTS:
C 
C	 none
C 
C FUNCTION VALUE:
C 
C	 VMS usage: cond_value
C	 type:      longword (unsigned)
C	 access:    write-only
C	 mechanism: by value
C	  
C SIDE EFFECTS:
C 
C	 none
C 
	IMPLICIT NONE

	INCLUDE '($FABDEF)'
	INCLUDE '($RABDEF)'
	INCLUDE '($XABDEF)'
	INCLUDE '($XABALLDEF)'
	INCLUDE '($XABKEYDEF)'
	INCLUDE '($XABSUMDEF)'
	INCLUDE '($SYSSRVNAM)'

	STRUCTURE /XAB_DEF/
		UNION
		MAP
			RECORD /XABALLDEF/ XABALLDEF
		ENDMAP
		MAP
			RECORD /XABKEYDEF/ XABKEYDEF
		ENDMAP
		MAP
			RECORD /XABSUMDEF/ XABSUMDEF
		ENDMAP
		MAP
			RECORD /XABDEF/ XABDEF
		ENDMAP
		ENDUNION
	ENDSTRUCTURE

	INTEGER*4	ADDRESS, OLD_ADDRESS
	INTEGER*4	AREA
	INTEGER*4	ILUN
	INTEGER*4	KEY
	INTEGER*4	NPAGES
	INTEGER*4	XABBUF(2)
	RECORD		/FABDEF/ FAB, INFAB
	RECORD		/RABDEF/ RAB, INRAB, OUTRAB
	RECORD		/XAB_DEF/ XAB
	COMMON		/RMSCOM/ INFAB, INRAB, OUTRAB, XAB, XABBUF

	! Set the block I/O in the FAC

	FAB.FAB$B_FAC = FAB.FAB$B_FAC .OR. FAB$M_BIO

	! Initilize XAB summary

	XAB.XABDEF.XAB$B_BLN	= XAB$C_SUMLEN
	XAB.XABDEF.XAB$B_COD	= XAB$C_SUM
	XAB.XABDEF.XAB$L_NXT	= 0
	FAB.FAB$L_XAB		= %LOC(XAB)

	! SYS$OPEN used to open an existing file

	UTL___COPY_FILE_FROM = SYS$OPEN( FAB )
	IF( .NOT. UTL___COPY_FILE_FROM )RETURN

	! Connect channel to file

	UTL___COPY_FILE_FROM = SYS$CONNECT( RAB )
	IF( .NOT. UTL___COPY_FILE_FROM )RETURN

	! Save ABs for reading

	INRAB = RAB
	INFAB = FAB

	! Fill in XABSUM
                     
	UTL___COPY_FILE_FROM = SYS$DISPLAY( FAB )
	IF( .NOT. UTL___COPY_FILE_FROM )RETURN

	! Get virtual memory based on space needed for XAB'S

	NPAGES = (XAB.XABSUMDEF.XAB$B_NOA * XAB$C_ALLLEN) + 
	1	 (XAB.XABSUMDEF.XAB$B_NOK * XAB$C_KEYLEN)
	NPAGES = (NPAGES + 511) / 512

	IF( NPAGES .EQ. 0 )RETURN

	UTL___COPY_FILE_FROM = SYS$EXPREG( %VAL(NPAGES), XABBUF,,, )
	IF( .NOT. UTL___COPY_FILE_FROM )RETURN

	! Loop through XABS filling in data

	ADDRESS = XABBUF(1)
	OLD_ADDRESS = %LOC(XAB)

	! Do Areas

	IF( XAB.XABSUMDEF.XAB$B_NOA .GT. 0 )THEN
		DO AREA = 0, XAB.XABSUMDEF.XAB$B_NOA-1
			CALL UTL___FILL_XABALL( %VAL(ADDRESS), 
	1					%VAL(OLD_ADDRESS), 
	1					AREA )
			OLD_ADDRESS = ADDRESS
			ADDRESS = ADDRESS + XAB$C_ALLLEN
		ENDDO
	ENDIF

	! Do Keys

	IF( XAB.XABSUMDEF.XAB$B_NOK .GT. 0 )THEN
		DO KEY = 0, XAB.XABSUMDEF.XAB$B_NOK-1
			CALL UTL___FILL_XABKEY( %VAL(ADDRESS), 
	1					%VAL(OLD_ADDRESS), 
	1					KEY )
			OLD_ADDRESS = ADDRESS
			ADDRESS = ADDRESS + XAB$C_KEYLEN
		ENDDO
	ENDIF

	UTL___COPY_FILE_FROM = SYS$DISPLAY( FAB )

	END






	OPTIONS /CHECK /EXTEND_SOURCE

	INTEGER*4 FUNCTION UTL___COPY_FILE_TO( FAB, RAB, ILUN )
C 
C FUNCTIONAL DESCRIPTION:	
C 
C	 This function acts as a useropen routine for the UTL_COPY_FILE
C	routine.  This useropen opens the file to be created.
C	It is created using the FAB that was RETURNed by UTL___COPY_FILE_FROM
C	as a template, so as to retain the file characteristics of the
C	file being copied to.
C 
C IMPLICIT INPUTS:
C 
C	 FAB - File access block
C	 VMS usage: fab
C	 type:      longword (unsigned)
C	 access:    modify
C	 mechanism: by reference, array reference
C	  
C	 RAB - Read access block
C	 VMS usage: rab
C	 type:      longword (unsigned)
C	 access:    modify
C	 mechanism: by reference, array reference
C	  
C	 ILUN - logical unit number
C	 VMS usage: longword_signed
C	 type:      longword integer (signed)
C	 access:    readonly
C	 mechanism: by reference
C	  
C FUNCTION VALUE:
C 
C	 VMS usage: cond_value
C	 type:      longword (unsigned)
C	 access:    write-only
C	 mechanism: by value
C	  
C SIDE EFFECTS:
C 
C	 none
C 
	IMPLICIT NONE

	INCLUDE '($FABDEF)'
	INCLUDE '($RABDEF)'
	INCLUDE '($XABDEF)'
	INCLUDE '($XABALLDEF)'
	INCLUDE '($XABKEYDEF)'
	INCLUDE '($XABSUMDEF)'
	INCLUDE '($SYSSRVNAM)'

	STRUCTURE /XAB_DEF/
		UNION
		MAP
			RECORD /XABALLDEF/ XABALLDEF
		ENDMAP
		MAP
			RECORD /XABKEYDEF/ XABKEYDEF
		ENDMAP
		MAP
			RECORD /XABSUMDEF/ XABSUMDEF
		ENDMAP
		MAP
			RECORD /XABDEF/ XABDEF
		ENDMAP
		ENDUNION
	ENDSTRUCTURE

	INTEGER*4	ILUN
	INTEGER*4	OUTADR, OUTLEN
	INTEGER*4	XABBUF(2)
	RECORD		/FABDEF/ FAB, INFAB
	RECORD		/RABDEF/ RAB, INRAB, OUTRAB
	RECORD		/XAB_DEF/ XAB
	COMMON		/RMSCOM/ INFAB, INRAB, OUTRAB, XAB, XABBUF


	! Set the block I/O in the FAC
	FAB.FAB$B_FAC = FAB.FAB$B_FAC .OR. FAB$M_BIO

	FAB.FAB$L_ALQ = INFAB.FAB$L_ALQ ! Allocation quantity
	FAB.FAB$B_BKS = INFAB.FAB$B_BKS ! Bucket size MIN(((MAX(RECL+24,BLOCKSIZE)+511/512,32)
	FAB.FAB$W_BLS = INFAB.FAB$W_BLS ! Block size
	FAB.FAB$L_CTX = INFAB.FAB$L_CTX ! Context
	FAB.FAB$W_DEQ = INFAB.FAB$W_DEQ ! Default file extension quantity
	FAB.FAB$B_FAC = INFAB.FAB$B_FAC ! File access
	FAB.FAB$L_FOP = INFAB.FAB$L_FOP ! File processing OPTIONS
	FAB.FAB$B_FSZ = INFAB.FAB$B_FSZ ! Fixed area control size
	FAB.FAB$W_GBC = INFAB.FAB$W_GBC ! Global buffer count
	FAB.FAB$L_MRN = INFAB.FAB$L_MRN ! Maximum record number
	FAB.FAB$W_MRS = INFAB.FAB$W_MRS ! Maximum record size
	FAB.FAB$B_ORG = INFAB.FAB$B_ORG ! File organization
	FAB.FAB$B_RAT = INFAB.FAB$B_RAT ! Record attributes
	FAB.FAB$B_RFM = INFAB.FAB$B_RFM ! Record format
	FAB.FAB$B_RTV = INFAB.FAB$B_RTV ! Retrieval window size
	FAB.FAB$B_SHR = INFAB.FAB$B_SHR ! File sharing
	FAB.FAB$L_XAB = %LOC(XAB)       ! Extended attribute block address

	! SYS$CREATE creates a new version of the file

	UTL___COPY_FILE_TO = SYS$CREATE( FAB )
	IF( .NOT. UTL___COPY_FILE_TO )RETURN

	! Connect a channel to this 'NEW' file

	UTL___COPY_FILE_TO = SYS$CONNECT( RAB )
	IF( .NOT. UTL___COPY_FILE_TO )RETURN

	! Save RAB for writing

	OUTRAB = RAB

	! Lose the memory

	CALL SYS$DELTVA( XABBUF )

	END





	OPTIONS /CHECK /EXTEND_SOURCE

	SUBROUTINE UTL___FILL_XABALL( NEW_XAB, LAST_XAB, AREA )

	IMPLICIT NONE

	INCLUDE '($XABDEF)'
	INCLUDE '($XABALLDEF)'
	INCLUDE '($XABKEYDEF)'
	INCLUDE '($XABSUMDEF)'

	STRUCTURE /XAB_DEF/
		UNION
		MAP
			RECORD /XABALLDEF/ XABALLDEF
		ENDMAP
		MAP
			RECORD /XABKEYDEF/ XABKEYDEF
		ENDMAP
		MAP
			RECORD /XABSUMDEF/ XABSUMDEF
		ENDMAP
		MAP
			RECORD /XABDEF/ XABDEF
		ENDMAP
		ENDUNION
	ENDSTRUCTURE

	INTEGER*4	AREA
	RECORD /XAB_DEF/ NEW_XAB, LAST_XAB

	LAST_XAB.XABDEF.XAB$L_NXT = %LOC(NEW_XAB)

	NEW_XAB.XABDEF.XAB$B_BLN = XAB$C_ALLLEN
	NEW_XAB.XABDEF.XAB$B_COD = XAB$C_ALL
	NEW_XAB.XABDEF.XAB$L_NXT = 0
	NEW_XAB.XABALLDEF.XAB$B_AID = AREA

	RETURN

	END





	OPTIONS /CHECK /EXTEND_SOURCE

	SUBROUTINE UTL___FILL_XABKEY( NEW_XAB, LAST_XAB, KEY )

	IMPLICIT NONE

	INCLUDE '($XABDEF)'
	INCLUDE '($XABALLDEF)'
	INCLUDE '($XABKEYDEF)'
	INCLUDE '($XABSUMDEF)'
	INCLUDE '($SYSSRVNAM)'

	STRUCTURE /XAB_DEF/
		UNION
		MAP
			RECORD /XABALLDEF/ XABALLDEF
		ENDMAP
		MAP
			RECORD /XABKEYDEF/ XABKEYDEF
		ENDMAP
		MAP
			RECORD /XABSUMDEF/ XABSUMDEF
		ENDMAP
		MAP
			RECORD /XABDEF/ XABDEF
		ENDMAP
		ENDUNION
	ENDSTRUCTURE

	RECORD /XAB_DEF/ NEW_XAB, LAST_XAB
	INTEGER*4	KEY

	LAST_XAB.XABDEF.XAB$L_NXT = %LOC(NEW_XAB)

	NEW_XAB.XABDEF.XAB$B_BLN = XAB$C_KEYLEN
	NEW_XAB.XABDEF.XAB$B_COD = XAB$C_KEY
	NEW_XAB.XABDEF.XAB$L_NXT = 0
	NEW_XAB.XABKEYDEF.XAB$B_REF = KEY

	RETURN

	END