From:	IN%"eeliason%astrog.span@Sds.Sdsc.Edu" 19-MAY-1989 18:20
To:	TOBY@PETVAX.LRSM.UPENN.EDU
Subj:	CDOPEN,CDREAD,CDCLOSE in file CD_ACCESS.FOR

Return-path: eeliason%astrog.span@Sds.Sdsc.Edu
Received: from Sds.Sdsc.Edu by PETVAX.LRSM.UPENN.EDU via TCP; Fri May 19 18:19
 EST
Received: from astrog.span by Sds.Sdsc.Edu with VMSmail ; Fri, 19 May 89
 22:19:44 GMT
Date: Fri, 19 May 89 22:19:44 GMT
From: eeliason%astrog.span@Sds.Sdsc.Edu
Subject: CDOPEN,CDREAD,CDCLOSE in file CD_ACCESS.FOR
To: TOBY@PETVAX.LRSM.UPENN.EDU
Message-Id: <890519221944.21c00d2f@Sds.Sdsc.Edu>
X-ST-Vmsmail-To: SDS::"TOBY@PETVAX.LRSM.UPENN.EDU"

	subroutine cdopen (file_nam, chan, sblk, fsize, ierr)
C
C_TITLE	CDOPEN locates the specified CDROM file and returns file parameters
C
C_ARGS
	character*50	file_nam	!input - cdopen entry point; 
C					File specification, must include
C					file_name and ext, may include
C					device, directory and version;
C					ddcn:[dir1.dir2...]file_name.ext;v
	integer*4	chan		!return - cdopen entry point; 
C					The channel assigned to the CDROM
C					device by cdopen.
C					input - cdatt entry point;
C					The channel assigned by cdopen
C					which must be supplied when cdatt 
C					is called.
	integer*4	sblk		!return - cdopen entry point; 
C					The starting block of the file
C					just opened.  This value is
C					required input for calls to 
C					cdread.
	integer*4	fsize		!return - cdopen entry point; 
C					The size of the file in bytes.
	integer*4	ierr		!return - cdopen entry point;
C					Error return value,
C					0 = no error, -1 = fatal error
C					return - cdatt entry point;
C					Same as for cdopen entry point
C
C	The following arguments provide return data for the cdatt entry
C	point only.  They are not to be included in the cdopen call. 
C
	byte		abuf(2048)	!return - cdatt entry point; 
C					The user supplied buffer which
C					will contain the attribute record
C					on return.
	integer*4	att_blk		!return - cdatt entry point; 
C					The length in blocks of the
C					attribute record.
	integer*4	stid		!return - cdatt entry point;
C					The standard ID of the format
C					in which the CDROM was written.
C					   1  -  High Sierra
C					   2  -  ISO
C_VARS
	include '($syssrvnam)'		!FORTRAN system service definitions
	include '($iodef)'		!FORTRAN I/O definitions
	include '($ssdef)'		!FORTRAN system definitions
C
C_DESC	CDOPEN is part of a package of low level routines which give the
C	caller access to data written on a CDROM.  This package includes
C	CDOPEN, CDATT, CDREAD AND CDCLOSE.  CDOPEN must be called first to 
C	assign a channel to the CDROM reader and to find and open the 
C	requested file.  If the user desires the extended attribute record
C	(if it exists), he must make a call to CDATT IMMEDIATELY after a
C	successful call to CDOPEN FOR THAT SAME FILE.  NOTE: CDATT is not a
C	separate subroutine but is an entry point within the CDOPEN routine.
C	Once the CDROM file is opened, CDREAD can be used to read blocks of 
C	data.  CDCLOSE deassigns the channel to the CDROM reader which was 
C	assigned by CDOPEN in effect closing the file.
C
C	These routines work at the block level.  In particular, CDREAD 
C	returns in block size chunks.  It does not do any logical record 
C	handling.  The calling program must take care of any record 
C	deblocking.  The routines use a standard 512 byte block.  CDOPEN 
C	converts the file starting block to this convention if the volume 
C	was written using a different block size.  The number of bytes
C	returned by cdread is 512 times the number of blocks requested.
C
C	The routines recognize and can access both the ISO and High Sierra
C	CDROM formats.  This occurs automatically and is transparent to 
C	to the caller.  If the CDROM was not written in a recognized
C	format, CDOPEN will issue an error message and return to the caller
C	with an error condition - without opening the file.
C
C	The CDOPEN routine will use the value assigned to the PIC$CDROM 
C	logical name as defaults if it is defined.  The user will want to
C	assign a value to PIC$CDROM if the cdreader device on his system
C	is other than DUB0: or if he will be consistantly using a specific
C	directory on the CDROM disk.  Particularly if the device is not 
C	DUB0:, it will be desirable to have PIC$CDROM defined in the system 
C	logical name table.  Either a device, a directory or both may be 
C	assigned to the logical name.  The DCL command is
C
C		$DEFINE/SYS PIC$CDROM ddcu:[directory]
C
C	Examples:
C
C		$DEFINE/SYS PIC$CDROM DUA2:
C		$DEFINE PIC$CDROM DUB1:[MIRANDA]
C		$DEFINE PIC$CDROM [URANUS.C2678XXX]
C
C	Before running any programs built with this subroutine, the user
C	must make the CDROM disk volume available to the system.  
C
C		+ Insert the correct disk into the drive.  
C
C		+ Issue the DCL mount command with foreign qualifier
C			i.e. $MOUNT/FOREIGN DUB0:
C
C	CDOPEN locates the file specified by the caller.  Defaults for the 
C	device and directory are taken from the user defined logical name 
C	PIC$CDROM if it exists.  If not provided by PIC$CDROM, the device 
C	defaults to DUB0: and the directory to the highest level (root) 
C	directory.  Any user specified device or directory included in the 
C	file specification supercede the defaults.  After assigning a channel 
C	to the CDROM device, the routine searches down the directory tree to 
C	the requested level and then searches for the file name.  If the file 
C	is found, the assigned channel, the file starting block, the size of 
C	the file in bytes and an error value of 0 (sucessful completion) is 
C	returned to the calling program.  If any error condition is 
C	encountered, an appropriate message is issued and an error value of 
C	-1 is returned.
C
C	CDATT is a separate entry point in the CDOPEN routine.  It uses
C	information obtained by cdopen about the file but not returned to
C	the caller.  The entry point and argument list for cdatt can be
C	found on the last page of the cdopen subroutine listing.  The data 
C	in the user supplied attribute buffer and length variable should 
C	be valid if the error value is 0 on return.  If the extended 
C	attribute record does not exist or a read error occurs, the 
C	appropriate error message is issued and an error value 	of -1 is 
C	returned.  Information on the content and format of the extended 
C	attribute record can be found in the ISO standard 9660, "Information 
C	processing - Volume and file structure of CD-ROM for information 
C	interchange" (1988) in section 9.5 starting page 23.  An identifier
C	indicating whether the disk was written in ISO or High Sierra
C	format is also returned to the user from CDATT.
C
C_CALLS	The routine calls the subroutine
C
C		CDSTAND
C
C	which determines in which standard, ISO or HIGH SIERRA, the CDROM
C	was written.  An error return indicates an unacceptable standard.
C
C	The routine calls the PICS system subroutine
C
C		B2B
C
C	to copy byte strings.
C
C	The following VMS system routines are also used:
C
C		str$upcase
C		sys$assign
C		sys$qiow
C		lib$sys_trnlog
C
C_HIST	2Apr87, DMcMacken, ISD, U.S.G.S., Flagstaff, Original Version
C_END
C******************************************************************************
c
c	local variables
c
	byte		ibuf(6144)	!I/O buffer
	byte		dbuf(300)	!directory buffer
	integer*2	log_blk_sz	!disk logical block size
	integer*2	blk_fac		!disk blocking factor
	integer*4	log_blk		!disk logical block             
	integer*4	blk_len		!no bytes to read
	integer*2	iosb(4)		!I/O status block
	integer*4	status		!system call return status
	character*4	dev		!device name
	integer*4	mrk		!string pointer
	integer*4	mrk2		!string pointer
	character*50	file_up		!uppercase copy of file_nam
	character*50	dir_str1	!subdirectory string 1
	character*50	dir_str2	!subdirectory string 2
	character*50	direc		!directory string
	character*50	file		!file string
	integer*4	root_blk	!root directory location
	integer*4	dir_blk		!directory location pointer
	integer*4	root_len	!root directory size
	integer*4	dir_len		!directory record length
	integer*4	dir_sz		!directory size
	integer*2	file_flg	!file flags
	integer*4	fid_len		!length of file identifier
	integer*4	ndx		!do loop index
	logical		found		!file found flag
	integer*4	att_len		!length of extended attribute record
	integer*4	nxt_blk		!next directory block pointer
	integer*2	num_sec		!number sectors in directory
	integer*2	i_sec		!directory sector index
	integer*2	sdx		!standard index
	integer*2	rb(2)		!root directory block indices
	integer*2	rl(2)		!root dirctory length indices
	integer*2	lbs(2)		!logical block size indices
	integer*2	db(2)		!directory block pointer indices
	integer*2	ds(2)		!dirctory size indices
	integer*2	ff(2)		!file flags indices
	character*50	default_str	!default device/directory string
	character*4	default_dev	!default device
	character*50	default_dir	!default directory
	integer*4	version_num	!file version number
	logical*2	version_flag	!flag whether user input file version
	character*9	cdrom_log	!device/directory logical name
	integer*4	tst_ver		!test version number from directory
	integer*4	tst_len		!length of file name to test
	logical*2	fnd_version	!found a version of file flag
	logical*2	no_ver		!directory file name has no version
	integer*4	sysout		!VMS sus$output unit number
	parameter	(sysout=6)
c
	data	rb /183, 159/
	data	rl /191, 167/
	data	lbs /137, 129/
	data	db /3, 3/
	data	ds /11, 11/
	data	ff /25, 26/
	data	cdrom_log /'PIC$CDROM'/
c
c	assume no errors
c
 	ierr = 0
c
c	determine device and directory defaults
c
	status = lib$sys_trnlog (cdrom_log,, default_str,,,)
	if (status .ne. SS$_NORMAL) then
c		write (sysout, 5000) status, cdrom_log, default_str
c5000	format (' status = ', i5 /
c	1	' cdrom_log = ', a /
c	2	' default_str = ', a)
		default_str = ' '
	endif
	mrk = index (default_str, ':')
	mrk2 = index (default_str, ']')
	if (mrk .eq. 0) then
		default_dev = 'DUB0'
	else
		default_dev = default_str(1:mrk-1)
	endif
	if (mrk2 .eq. 0) then
		default_dir = ' '
	else
		default_dir = default_str(mrk+2:mrk2-1)
	endif
c
c	parse file name string
c
	call str$upcase (file_up, file_nam)
	mrk = index (file_up, ':')
	mrk2 = index (file_up, ']')
	if (mrk .eq. 0) then
		dev = default_dev
	else
		dev = file_up(1:mrk-1)
	endif
	if (mrk2 .ne. 0) then
		direc = file_up(mrk+2:mrk2-1)
		file = file_up(mrk2+1:50)
		if (direc .eq. 'ROOT') direc = ' '
	else
		direc = default_dir
		file = file_up(mrk+1:50)
	endif
c
c	test whether caller provided version number
c
	mrk = index (file, ';')
	if (mrk .eq. 0) then
		version_flag = .false.
	else
		version_flag = .true.
	endif
	version_num = 0
	tst_ver = 0
c
c	search for file
c
	chan = 0
	sblk = 0
	fsize = 0
c
c	open channel to device
c
	status = sys$assign (dev, chan,,)
	if (.not. status) then
		write (sysout, 7000)
7000	format (' **** CDOPEN - error assigning channel to device ****')
		ierr = -1
		return
	endif
c
c	read volume descriptor block
c
	log_blk = 64
	blk_len = 2048
	status = sys$qiow (, %val(chan), %val(io$_readlblk),
	1				iosb,,, ibuf, %val(blk_len),
	2				%val(log_blk),,,)
	if (.not. status .or. iosb(1) .lt. 0) then
		write (sysout, 7001)
7001	format (' **** CDOPEN - error reading volume descriptor block ',
	1	'****')
		ierr = -1
		return
	endif
c
c	determine standard
c	get needed parameters
c
	call cdstand (ibuf, sdx, ierr)
	if (ierr .lt. 0) then
		write (sysout, 7005)
7005	format (' **** CDOPEN - invalid CDROM standard ****')
		return
	endif
	call b2b (ibuf(rb(sdx)), root_blk, 4)
	call b2b (ibuf(rl(sdx)), root_len, 4)
	call b2b (ibuf(lbs(sdx)), log_blk_sz, 2)
c                          
c	search directory tree
c	starting at root
c
	blk_fac = log_blk_sz/512
	log_blk = root_blk*blk_fac
	blk_len = root_len
	mrk2 = index(direc, ' ') - 1
	if (mrk2 .le. 0) then
		mrk = 0
		found = .true.
	else
		mrk = 1
	endif
	do while (mrk .ne. 0)
c
c	determine name of directory we want on this level
c
		mrk = index (direc, '.')     
		if (mrk .eq. 0) then
			dir_str1 = direc
		else
			dir_str1 = direc(1:mrk-1)
	 		direc = direc(mrk+1:50)
		endif
		nxt_blk = log_blk
		num_sec = (blk_len + 2047)/2048
		blk_len = 2048
		i_sec = 0
		found = .false.
		do while (i_sec .lt. num_sec .and. .not. found)
		i_sec = i_sec + 1
c
c	read directory block
c
		status = sys$qiow (, %val(chan),
	1				%val(io$_readlblk), iosb,,, 
	2				ibuf, %val(blk_len),
	3				%val(nxt_blk),,,)
		if (.not. status .or. iosb(1) .lt. 0) then
			write (sysout, 7002)
7002	format (' **** COPEN - error reading directory block ****')
			ierr = -1
			return
		endif
c
c	scan directory entries on level
c
		if (i_sec .eq. 1) then
			mrk2 = ibuf(1) + 1
			mrk2 = ibuf(mrk2) + mrk2
		else
			mrk2 = 1
		endif
		dir_str2 = ' '
	   	do while (mrk2 .lt. blk_len .and.
	1				ibuf(mrk2) .ne. 0 .and.
	2				dir_str1 .ne. dir_str2)
c
c	copy entry to directory buffer
c
			dir_len = ibuf(mrk2)
			call b2b (ibuf(mrk2), dbuf, dir_len)
			call b2b (dbuf(db(sdx)), dir_blk, 4)
			call b2b (dbuf(ds(sdx)), dir_sz, 4)
			call b2b (dbuf(ff(sdx)), file_flg, 2)
c
c	construct directory name string from entry
c
			if (btest(file_flg, 1)) then
				fid_len = dbuf(33)
				dir_str2 = ' '
				call b2b (dbuf(34), %ref(dir_str2), fid_len)
 			endif
c
c	save pointer in case this is it
c	point to next directory entry
c
			log_blk = dir_blk*blk_fac
			mrk2 = mrk2 + dir_len
		enddo
c
c	set values depending on whether we found it or not
c
		if (dir_str1 .eq. dir_str2) then
			blk_len = dir_sz
			found = .true.
		else
			found = .false.
		endif
		nxt_blk = nxt_blk + 4
		enddo
		if (.not. found) mrk = 0
	enddo
c
c	finished search of directories
c	now get file (if possible)
c
	if (found) then
c
c	open bottom directory
c
   	    found = .false.
	    fnd_version = .false.
	    num_sec = (blk_len + 2047)/2048
	    blk_len = 2048
	    i_sec = 0
	    do while (i_sec .lt. num_sec .and. .not. found)
		i_sec = i_sec + 1
		status = sys$qiow (, %val(chan), %val(io$_readlblk),
	1				iosb,,, ibuf, %val(blk_len),
	2				%val(log_blk),,,)
 		if (.not. status .or. iosb(1) .lt. 0) then
			write (sysout, 7002)
			ierr = -1
			return
		endif
c
c	search directory for file name
c
		if (i_sec .eq. 1) then
			mrk2 = ibuf(1) + 1
			mrk2 = ibuf(mrk2) + mrk2
		else
			mrk2 = 1
		endif
		dir_str2 = ' '
	   	do while (mrk2 .lt. blk_len .and.
	1				ibuf(mrk2) .ne. 0 .and.
	2				.not. found)
c
c	copy entry into directory buffer
c
			dir_len = ibuf(mrk2)
			call b2b (ibuf(mrk2), dbuf, dir_len)
			call b2b (dbuf(db(sdx)), dir_blk, 4)
			call b2b (dbuf(ds(sdx)), dir_sz, 4)
			call b2b (dbuf(ff(sdx)), file_flg, 2)
c
c	construct file name string from entry
c
			fid_len = dbuf(33)
			dir_str2 = ' '
			call b2b (dbuf(34), %ref(dir_str2), fid_len)
c
c	separate file name and version number if necessary
c
			if (version_flag) then
				tst_len = 50
			else
				tst_len = index (dir_str2, ';') - 1
				if (tst_len .le. 0) then
					tst_len = 50
					no_ver = .true.
				else
					no_ver = .false.
					mrk = index (dir_str2, ' ') - 1
					if (mrk .lt. 0) mrk = 50
					read (dir_str2((tst_len+2):mrk), 
	1				    6000) tst_ver
6000	format (i3)
				endif
			endif
c
c	point to next directory entry
c
			mrk2 = mrk2 + dir_len
c
c	set flags and/or return values
c
			if (file .eq. dir_str2(:tst_len)) then
				if (version_flag .or. no_ver .or.
	1			    tst_ver .gt. version_num) then
					att_len = dbuf(2)
					sblk = blk_fac *
	1					(dir_blk + att_len)
			     		fsize = dir_sz
					if (version_flag) then
				     	    found = .true.
					else
					    fnd_version = .true.
					endif
				endif
			endif
		enddo
		log_blk = log_blk + 4
	    enddo
	else
	    tst_len = index (direc, ' ') - 1
	    if (tst_len .lt. 0) tst_len = 50
		if (tst_len .gt. 0) then
		    write (sysout, 7003) dev, direc(:tst_len)
7003	format (' **** CDOPEN - directory not found ****'/
	1	x, a, ':[', a, ']')
		else
		    write (sysout, 7008) dev
7008	format (' **** CDOPEN - directory not found ****'/
	1	x, a, ':[ROOT]')
		endif
	    ierr = -1
	endif
c
c	tell user that file was not found
c
	if (fnd_version) found = .true.
	if (.not. found) then
		tst_len = index (direc, ' ') - 1
		if (tst_len .lt. 0) tst_len = 50
		    if (tst_len .gt. 0) then
			write (sysout, 7006) dev, direc(:tst_len), file
7006	format (' **** CDOPEN - file not found ****'/ 
	1	 x, a, ':[', a, ']', a)
		    else
			write (sysout, 7009) dev, file
7009	format (' **** CDOPEN - file not found ****'/ 
	1	 x, a, ':[ROOT]', a)
		    endif
		ierr = -1
	endif
c
c	go back to caller
c
	return
c
c	entry to obtain extended attribute record
c
	entry cdatt (chan, abuf, att_blk, stid, ierr)
c
	ierr = 0
	if (att_len .eq. 0) then
		write (sysout, 7007)
7007	format (' **** CDOPEN - there is no extended attribute record ',
	1	'****')
		ierr = -1
		return
	endif
	log_blk = blk_fac*dir_blk
	blk_len = 512*blk_fac*att_len
	att_blk = att_len
	stid = sdx
	status = sys$qiow (, %val(chan), %val(io$_readlblk),
	1		iosb,,, abuf, %val(blk_len),
	2		%val(log_blk),,,)
	if (.not. status .or. iosb(1) .lt. 0) then
		write (sysout, 7004)
7004	format (' **** CDOPEN - error reading extended attribute ',
	1	'record ****')
		ierr = -1
	endif
c
	return
c
	end
	subroutine cdstand (ibuf, sdx, ierr)
C_TITLE	CDSTAND determines the CDROM format standard
C_ARGS
	byte		ibuf(6144)	!input, volume descriptor buffer
	integer*2	sdx		!return, standard index
	integer*4	ierr		!return, error value
C_VARS	none
C_DESC	This routine determines whether the cdrom being accessed is
C	in ISO or High Sierra format.  If the routine is unable to
C	determine the standard, a negative error value is returned.
C_HIST	3Aug88, DMcMacken, ISD, USGS, Flagstaff, Original Version
C_END
C******************************************************************************
c
c	local variables
c
	logical*2	isoflg		!flag indicating ISO standard
	logical*2	hisflg		!High Sierra standard flag
	integer*2	ndx		!character counter for loop
	byte		isostd(5)	!ISO identifying string
	byte		hisstd(5)	!High Sierra identifying string
c
	data	isostd /'C', 'D', '0', '0', '1'/
	data	hisstd /'C', 'D', 'R', 'O', 'M'/
c
c	assume there will be no error
c
	ierr = 0
c
c	determine the standard
c
	isoflg = .true.
	hisflg = .false.
	ndx = 1
	do while (isoflg .and. ndx .le. 5)
		if (ibuf(ndx + 1) .ne. isostd(ndx)) isoflg = .false.
		ndx = ndx + 1
	enddo
c
c	if not ISO try High Sierra
c
	if (.not. isoflg) then
		hisflg = .true.
		ndx = 1
		do while (hisflg .and. ndx .le. 5)
			if (ibuf(ndx + 9) .ne. hisstd(ndx)) hisflg = .false.
			ndx = ndx + 1
		enddo
	endif
c
c	set standard index
c
	if (isoflg) then
		sdx = 2
	else if (hisflg) then
		sdx = 1
	else
		sdx = 0
		ierr = -1
	endif
c
	return
	end
	subroutine cdread (chan, sblk, vblk, nblk, ibuf, ierr)
C
C_TITLE	CDREAD reads nblk's from vblk of CDROM file open by CDOPEN
C
C_ARGS
	integer*4	chan		!input - channel number of device
	integer*4	sblk		!input - starting block of file
	integer*4	vblk		!input - requested virtual block no.
	integer*4	nblk		!input - number of blocks to transfer
	byte		ibuf(4096)	!return - data in user supplied buffer
	integer*4	ierr		!return - error return
C					0 = successful, -1 = failure
C
C_VARS
	include '($syssrvnam)'		!FORTRAN system service defintions
	include '($iodef)'		!FORTRAN I/O definitions
C
C_DESC	This routine calls a VMS system service to read  logical blocks
C	from a CDROM file.  The file must first have been opened by a 
C	call to CDOPEN to assign the channel (chan) and to provide the
C	starting block (sblk) of the file.  The user must supply the
C	virtual block number (vblk - sequential block number from beginning
C	of file) and the number of blocks (nblk - 512 byte blocks) to
C	read.  The user must also supply a buffer (ibuf) large enough to
C	hold the blocks requested.  If the read is successful a value of
C	zero (0) is returned in the variable ierr; otherwise a -1 is
C	returned.
C
C_HIST	6Apr87, DMcMacken, ISD, U.S.G.S., Flagstaff, Original Verson
C
C_END
C******************************************************************************
c
c	local variables
c
	integer*4	log_blk		!logical block to read
	integer*4	blk_len		!number of bytes to read
	integer*4	status		!system call return status
	integer*2	iosb(4)		!I/O status block
	integer*4	sysout		!VMS sys$output logical unit
	parameter	(sysout=6)
c
c	assume no errors
c
	ierr = 0
c
c	compute QIO parameters
c
	log_blk = sblk + vblk - 1
    	blk_len = 512*nblk
c
c	get block for caller
c
	status = sys$qiow (, %val(chan), %val(io$_readlblk), iosb,,,
	1		ibuf, %val(blk_len), %val(log_blk),,,)
	if (.not. status .or. iosb(1) .lt. 0) then
		write (sysout, 7000)
7000	format (' **** CDREAD - error reading CDROM ****')
		ierr = -1
	endif
c
	return
	end
	subroutine cdclose (chan, ierr)
C
C_TITLE	CDCLOSE closes (deassigns) the channel opened by CDOPEN
C
C_ARG
	integer*4	chan		!input, channel assigned by CDOPEN
	integer*4	ierr		!return, error return
C					0 = successful, -1 = fatal error
C_VARS
	include '($syssrvnam)'		!FORTRAN system service definitions
C_DESC	This routine calls a VMS system routine to deassign the channel
C	speccified by the caller.  This is equivalent to closing the file
C	associated with the channel "chan."
C
C_HIST	6Apr87, DMcMacken, ISD, U.S.G.S., Flagstaff, Original Version
C_END
C******************************************************************************
c
c	local variables
c
	integer*4	status		!system service return status
	integer*4	sysout		!VMS sys$output unit number
	parameter	(sysout=6)
c
	ierr = 0
	status = sys$dassgn (%val(chan))
	if (.not. status) then
		write (sysout, 7000)
7000	format (' **** CDCLOSE - error deassigning channel ****')
		ierr = -1
	endif
c
	return
	end