	program BRUSHELL
**************************************************************
*                                                            *
* Load PDP 11/73 (23) BRU Study sets onto the VAX:	     *
*                                                            *
* Development Environment:VAX/VMS			     *
*                                                            *
* Programmer : Bruce Prendergast                             *
*                                                            *
* Date : November 3, 1988                                    *
*                                                            *
* Program structure:                                         *
*                                                            *
*                This program is an interface to the DECUS   *
*		 VMS program BRUREAD. BRUREAD loads PDP 11   *
*	 	 BRU sets but creates subdirectories when    *
*		 doing so. In our environments here at PKLAB,*
*		 the A/D data is collected in UIC [10,1]. The*
*		 tape label comes from [1,5] which the system*
*		 places as a "label" at the start of tape so *
*	         which enables operating only in APPEND mode.*
*		 The label name is BRULAB.BCK and BRUREAD    *
*		 will create a directory tree:		     *
*			...DATA_DIRECTORY.BRULAB.BCK.001005] *
*		 for the label and:			     *
*		 	...DATA_DIRECTORY.SUBNNNN.BCK.010001]*
*		 for the patient study when NNNN is the study*
*	         number. BRUREAD is managed by renaming the  *
*		 loaded datasets to the target directory and *
*	         deleting the resultant directory trees crea-*
*                ted created by BRUREAD.	     	     *
*							     *
**************************************************************
**************************************************************
C
C	The system accepts qualifiers via CLD for program control.
C	
C	THIS SYSTEM USES MTA0: AS THE DEFAULT TAPE DEVICE.
C
C	/DIRECTORY
C	  The [sub]directory name may be given with or without the "[" and
C         "]" punctuation marks in which case the system determines the 
C	  remainder of the directory context. 
C
C	  The directory name may be complete in that it takes a form of
C	  of USER$ACCOUNT:[...SUBDIRECTORY] and no context is determined.
C	  The presence of the punctuation mark ":" defines this situation.
C	  THE RULE IS: THE PRESENCE OF THE PUNCTUATION MARK ":" DETERMINES
C	  A COMPLETE DIRECTORY CONTEXT
C	 
C	  There may be no DIRECTORY declaration present in which case the
C	  default is the current directory. THE RULE IS: NO DIRECTORY
C	  DECLARATION USES THE CURRENT DIRECTORY
C
C	/SELECT
C	  A numeric value[list]. If not given, then the next study_set on 
C         the tape is selected. If the tape contains the following BRU sets
C	  then the option /SELECT=(1,4,5) will load study_sets SUB1234.BCK,
C         SUB1237.BCK, and SUB0192.BCK.
C
C		BRULAB.BCK
C		SUB1234.BCK
C		SUB1235.BCK
C		SUB1236.BCK
C		SUB1237.BCK
C		SUB0192.BCK
C
C	/NODISMOUNT
C	  Since the DIRECTORY qualifier applies to one account, the BRUSHELL
C	  program is allowed to exit without dismounting the tape drive. It 
C	  is expected to be rerun immediately with a NOMOUNT qualifier. A 
C	  new SELECT qualifier will refer to only those studysets yet to be 
C	  loaded.
C
C	/NOMOUNT
C	  See the above discussion. 
C
C-------------------------------------------
C *** common definitions 
C
	integer*4 creation_time(2),status
	integer*2 original_protection
	character home_directory*128
	common /bru_shell/creation_time,status,
     1	    original_protection,home_directory
C-------------------------------------------

	integer*4 BCK_directory_count,future_time(2)
	character BCK_directory_name*128,BCK_subdirectory_name*128,
     1	    BCK_search_subdirectory_name*128
	character BCK_directory_list(50)*128

	integer*4 system_time(2),delta_time(2),time_difference(2)
	logical*4 l_delta_time(2)
	equivalence (delta_time(1),L_delta_time(1))

	integer*4 context,alternate_status,cli_status

	integer*2 new_protection,verify_protection

	integer*2 select_index,select_count,select_list(50),
     1	    start_index,select_next,name_length
	character select_value*6,ascii_delta_time*23
	logical entry_not_inserted,loading_system_pool,
     1	    files_were_moved,name_is_numeric

	integer*4 cli$present,cli$get_value,sys$setddir

	external lib$find_file,lib$delete_file,lib$sys_trnlog,
     1	    lib$get_ef,lib$free_ef,lib$get_lun,lib$free_lun,
     2	    lib$find_file_end,lib$getdvi,cli$_comma,cli$_absent,
     3	    lib$set_logical,lib$addx,lib$subx

	character home_device*128,
     1	    target_directory*128,full_context_name*128,
     2	    actual_name*128,wanted_set_name*128,study_number*4,
     3	    loaded_name*128,candidate_to_delete*128
	
	include '($rmsdef)'
	include '($ssdef)'
	include '($dvidef)'
	include '($syssrvnam)'
	include '($mntdef)'
	include '($dmtdef)'
	include '($psldef)'

C----------------------
C *** mount definitions
C----------------------
	structure /item_list/
	    union
		map
		    integer*2 item_length,item_code
		    integer*4 item_address,item_return_length_address
		end map
		map
		    integer*4 end_list
		end map
	    end union
	end structure

	record/item_list/ mount_list(3)

        integer*4 mount_flags /0/
	volatile mount_flags

  	integer*4 flags_return_length,device_return_length,
     1	    disk_free_blocks

	character tape_device_name*6

C----------------------------------------------------------------
C----------------------------------------------------------------
C *** IMPORTANT IMPORTANT IMPORTANT
C     The symbol below is set true for our lab, Pathokinesiology.
C     Any other users of this software should set this value to
C     .FALSE.. This label processes bru backup tapes from our A/D
C     systems according to our own protocols.
C
	logical pk_lab,DECUS
	pk_lab=.false.
	DECUS=.NOT. pk_lab
C
C----------------------------------------------------------------
C----------------------------------------------------------------

C--------------------------------------------
C--------------------------------------------
C *** IMPORTANT IMPORTANT IMPORTANT
C     MTA0 is our default 9T tape subsystem.
C     Change the statement below accordingly.
C
	tape_device_name='_MTA0:'
C
C--------------------------------------------
C--------------------------------------------

C--------------------------------------------
C----------------------------------------------------
C *** IMPORTANT IMPORTANT IMPORTANT
C     Delta time before the "midnight scarfer" arrives
C
	ascii_delta_time='14 ::'
C
C--------------------------------------------
C--------------------------------------------

	lunout=6
	open(unit=lunout,name='SYS$OUTPUT:',status='new')
C---------------------------------------------
C *** get the SELECT list. These are the 
C     relative numbers of the BRUsets desired.
C---------------------------------------------
	status=-1
	select_list(1)=1
	select_count=1
	if (cli$present('SELECT')) then
	    select_count=0
	    status=%loc(CLI$_COMMA)
	    do while (status .eq. %loc(CLI$_COMMA))
	        status=cli$get_value('SELECT',select_value)
		i=index(select_value,' ')-1
		if (i .gt. 2) then
		   write(lunout,*)' Select List Error!'
		   call exit
		end if
		decode(i,'(I<i>)',select_value)select_index
		if (status .ne. %loc(CLI$_ABSENT)) then
		    if (select_count .ne. 0) then
		    	i=0
		    	entry_not_inserted=.true.
		    	do while ((i .lt. select_count) .and. 
     1			    (entry_not_inserted))
			    i=i+1
C--------------------------------
C *** insert item in ordered list
C--------------------------------
			    if (select_list(i) .gt. select_index) then
			     	do j=select_count,i,-1
				    select_list(j+1)=select_list(j)
			        end do
C------------------
C *** in the middle
C------------------
			        select_list(i)=select_index
			        select_count=select_count+1
			        entry_not_inserted=.false.
			    end if
		        end do
		        if (entry_not_inserted) then
C--------------------
C *** at the very end
C--------------------
			    select_count=select_count+1
			    select_list(select_count)=select_index
		        end if
		    else
C----------------------------
C *** the first one to insert
C----------------------------
		    	select_count=1
		    	select_list(1)=select_index
		    end if
		end if
	    end do
	end if
C------------------------
C *** build mount command
C------------------------
	mount_list(1).item_length=6
	mount_list(1).item_code=(MNT$_DEVNAM)
	mount_list(1).item_address=%loc(tape_device_name)
	mount_list(1).item_return_length_address=
     1	    %loc(device_return_length)

	mount_list(2).item_length=4
	mount_list(2).item_code=(MNT$_FLAGS)
	mount_flags= MNT$M_FOREIGN+MNT$M_OVR_VOLO
	mount_list(2).item_address=%loc(mount_flags)
	mount_list(2).item_return_length_address=
     1	    %loc(flags_return_length)
	mount_list(3).end_list=0
C-----------------------------
C *** Must remember where I am
C-----------------------------
	status=lib$sys_trnlog('SYS$DISK',name_length,
     1	    home_device,,(PSL$C_SUPER))
	status=sys$setddir(,,home_directory)
	j=index(home_device,':')
	home_directory=home_device(1:j)//home_directory
	target_directory=home_directory

	if (cli$present('DIRECTORY')) then
C-----------------------------
C *** get the target directory
C-----------------------------
	    status=cli$get_value('DIRECTORY',target_directory)
C-----------
C *** no ":"	    
C-----------
	    if (index(target_directory,':') .eq. 0) then
		if (index(target_directory,'[') .eq. 0) then
		    i=index(target_directory,' ')-1
		    target_directory='['//target_directory(1:i)//']'
		end if
C---------------------------
C *** establish full context
C---------------------------
		status=lib$find_file
     1		    (target_directory,full_context_name,context)
C-----------------------------------
C *** destroy current search context
C-----------------------------------
		target_directory=full_context_name
     1		    (1:index(full_context_name,']'))
		status=lib$find_file_end(context)
	    end if
C-----------------------------
C *** move to target directory
C-----------------------------
	    status=lib$set_logical('SYS$DISK',target_directory
     1		(1:index(target_directory,':')))
	    if (.not. status) call lib$signal(%val(status))
	    status=sys$setddir(target_directory,,)
	    if (.not. status) call lib$signal(%val(status))
	end if

C---------------------------------------
C *** get the current default protection
C---------------------------------------
	status=sys$setdfprot(,original_protection)
C------------------------------------------------------------
C *** if this is the system pool EMGWORK:[SYSTEMEMG] then the
C     W:RD protection must be removed. Otherwise remove O:D
C------------------------------------------------------------
	loading_system_pool=.false.
	if (target_directory(1:19) .eq. 'EMGWORK:[SYSTEMEMG]')
     1	    loading_system_pool=.true.

C---------------------------
C *** Do this if .NOT. DECUS
C---------------------------
	if (pk_lab) then
	    if (loading_system_pool) then
	        new_protection=original_protection .and. '6FFF'X
	    else
	    	new_protection=original_protection .and. 'FF7F'X
	    end if
	end if
C----------------------------------------------------------
C *** turn on default USER:DELETE protection bits for DECUS
C----------------------------------------------------------
	if (.not. pk_lab)
     1	    new_protection=original_protection .and. 'FF7F'X
	    
	status=sys$setdfprot(new_protection)
	status=sys$setdfprot(,verify_protection)
	
C-----------------------------
C *** now get disk information
C-----------------------------
	status=lib$getdvi((DVI$_FREEBLOCKS),,
     1	    target_directory,
     2	    disk_free_blocks)
C------------------------------
C *** look at the return status
C------------------------------
	call analyze_status
C-----------------------------
C *** gotta have at least 50k!
C-----------------------------
	if (disk_free_blocks .lt. 50000) then
	    write(lunout,*)' Not enough available disk space!'
	    if (cli$present('DIRECTORY')) then
	    	alternate_status=lib$set_logical
     1		    ('SYS$DISK',target_directory
     2		    (1:index(target_directory,':')))
	        if (.not. alternate_status) call lib$signal
     1		    (%val(alternate_status))
	        alternate_status=sys$setddir(home_directory,,)
	    end if
	    status=sys$setdfprot(original_protection)
	    call exit
	end if
C--------------------------------------------
C *** CHECK FOR residual label if .NOT. DECUS
C--------------------------------------------
	if (pk_lab) then
	    status=lib$find_file('BRULAB.DIR',actual_name,context)
	    if (status .eq. RMS$_NORMAL) 
     1		call delete_directory_tree('BRULAB')
	    status=lib$find_file_end(context)
	end if
C-------------------------------------------
C *** and an uncompleted load if .NOT. DECUS
C-------------------------------------------
	if (pk_lab) then
	    status=lib$find_file('SUB*.DIR',actual_name,context)
	    if (RMS$_NORMAL .eq. status) then
	    	actual_name=actual_name(index(actual_name,']')+1:)
	    	call delete_directory_tree
     1		    (actual_name(1:index(actual_name,'.')-1))
	    end if
	    status=lib$find_file_end(context)
	end if
C-------------------------------------------------------------
C *** if the target_directory is the system EMG pool and
C     this is NOT DECUS then put the midnight scarfer to work.
C-------------------------------------------------------------
	if (pk_lab) then
	    if (loading_system_pool) then
C------------------------
C *** get the system time
C------------------------
		status=sys$gettim(system_time)
		call analyze_status
C---------------------------------
C *** convert delta time to binary
C---------------------------------
		status=sys$bintim(ascii_delta_time,delta_time)
		call analyze_status
C-----------------------------------------------------
C *** A 2's complement is really a 1's complement plus 
C     one. but system accuracy doesn't require it
C-----------------------------------------------------
		do i=1,2
		    l_delta_time(i)=jnot(l_delta_time(i))
		end do
C-----------------------------------------
C *** scan the pool for expired study sets
C-----------------------------------------
		status=lib$find_file(
     1		    '*.*;*',candidate_to_delete,context) 	
		do while ((status .ne. RMS$_NMF) .and.
     1		    (status .ne. RMS$_FNF))
		    call get_creation_time(candidate_to_delete)
C-------------------------
C *** delete it if expired
C-------------------------

C--------------------------------------
C *** now calculate the expiration date
C--------------------------------------
		    status=lib$addx(creation_time,delta_time,future_time,)
		    call analyze_status
		    status=lib$subx(system_time,future_time,time_difference)
		    call analyze_status
		    if (time_difference(2) .ge. 0)
     1			status=lib$delete_file(candidate_to_delete)
		    status=lib$find_file('*.*;*',candidate_to_delete,context)	
		end do
		status=lib$find_file_end(context)
	    end if
	end if
C----------------------------
C *** mount the tape if I can
C----------------------------
	cli_status=cli$present('NOMOUNT')
	if (cli_status .eq. %loc(CLI$_ABSENT)) then
	    status=sys$mount(mount_list)
	    call analyze_status
	end if
C--------------------------------------
C *** look for a label on the first one
C--------------------------------------
	cli_status=cli$present('NOMOUNT')
	select_index=1
	start_index=1
	select_next=1
C--------------------------------------------------------------
C *** do this if .NOT. DECUS. Always load the first studyset.
C     It is either a LABEL or an early unlabelled tape. If it
C     is an early tape then adjust the loop loading parameters.
C--------------------------------------------------------------
	if (pk_lab) then
	    if (cli_status .eq. %loc(CLI$_ABSENT)) then
	    	status=lib$spawn(
     1		    'BRUREAD/rewind/select=*.* '//TAPE_DEVICE_NAME)
		call analyze_status
	    	status=lib$find_file('BRULAB.DIR',
     1		    wanted_set_name,context)
	    	alternate_status=lib$find_file_end(context)
	    	if (status .eq. RMS$_NORMAL) then
		    call delete_directory_tree('BRULAB')
	        else
C---------------------
C *** get study number
C---------------------
		    status=lib$find_file('SUB*.DIR',
     1		        wanted_set_name,context)
		     alternate_status=lib$find_file_end(context)
		    i=index(wanted_set_name,'.DIR')
		    study_number=wanted_set_name(i-4:i-1)
C-----------------------------------------
C *** see if I want it and if I do move it
C-----------------------------------------
		    if (select_index .eq. 
     1		    	select_list(select_index)) then
		    	status=lib$rename_file('[.SUB'//study_number//
     1			    '...]*'//study_number//'*.*;*',
     2			    target_directory)
		        select_next=2
		    end if
		    call delete_directory_tree('SUB'//study_number)
		    start_index=2
		end if
	    end if
	end if
C------------------------
C *** load the study sets
C------------------------
	do select_index=start_index,select_list(select_count)
C-------------------------------------------
C *** beyond the label, load it if necessary
C-------------------------------------------
	    if (select_index .eq. select_list(select_next)) then
		select_next=select_next+1
		status=lib$spawn(
     1		    'BRUREAD/norewind/select=*.* '//TAPE_DEVICE_NAME)
		call analyze_status
C-------------------------------------------
C *** I have loaded a BRU set here for DECUS
C     Now I must find the directory stack
C-------------------------------------------
		if (DECUS) then
		    BCK_directory_count=0
		    status=lib$find_file(
     1			target_directory//'*.DIR',
     2			BCK_directory_name,context)
		    do while ((status .ne. RMS$_NMF) .and.
     1			(status .ne. RMS$_FNF))
			if (status .eq. RMS$_NORMAL) then
			    BCK_directory_count=
     1				BCK_directory_count+1
			    BCK_directory_list(BCK_directory_count)=
     1				BCK_directory_name
			end if
			status=lib$find_file(
     1			    '[.*]BCK.DIR',BCK_directory_name,context)
		    end do
C-----------------------------------------------------------
C *** There may be subdirectories (ie, more than one UIC) so
C     take the BCK directories and find all subdirectories
C     that are numeric. I does this because BRUREAD creates
C     subdirectories with UIC numbers.
C-----------------------------------------------------------
		    status=lib$find_file_end(context)
		    BCK_subdirectory_count=0
		    if (BCK_directory_count .ne. 0) then
			do i=1,BCK_directory_count
			    files_were_moved=.false.
			    BCK_search_subdirectory_name=
     1				BCK_directory_list(i)
			    j=index(BCK_search_subdirectory_name,']')
			    BCK_search_subdirectory_name(j:j)='.'
			    j=index(BCK_search_subdirectory_name,'.DIR')
			    BCK_search_subdirectory_name(j:)=']*.DIR'
C----------------------------------------------
C *** Start the search for subdirectories
C     Remember to throw away any intermediate
C     directories which have non-numeric names.
C----------------------------------------------
			    status=lib$find_file(
     1				BCK_search_subdirectory_name,
     2				BCK_subdirectory_name,context)
			    do while ((status .ne. RMS$_FNF) .and.
     1				(status .ne. RMS$_NMF)) 
				j=index(BCK_subdirectory_name,'.DIR')-1
				k=index(BCK_subdirectory_name,']')+1
C--------------------------------------------------------
C *** the directory name must be six characters inclusive
C--------------------------------------------------------
				if (j-k .eq. 5) then
				    name_is_numeric=.true.
				    do m=1,6
					l=k+m-1
				        n=ichar(
     1					    BCK_subdirectory_name(l:l))-48
					if ((n .lt. 0) .or. (n .gt. 9))
     1					    name_is_numeric=.false.
				    end do
C------------------------------------------------------
C *** numeric subdirectory name of six digits (RSX UIC)
C------------------------------------------------------
				    if (name_is_numeric) then
					k=index(BCK_subdirectory_name,']')
				        BCK_subdirectory_name(k:k)='.'
				        k=index(BCK_subdirectory_name,
     1					    '.DIR')
					BCK_subdirectory_name(k:k)=']'
					status=lib$rename_file(
     1				    	    BCK_subdirectory_name(1:k)
     1					    //'*.*;*',target_directory)
					call analyze_status
					files_were_moved=.true.
				    end if
				end if
			    	status=lib$find_file(
     1				    BCK_search_subdirectory_name,
     2				    BCK_subdirectory_name,context)
			    end do
C---------------------------------------------------
C *** if I moved any files then delete the directory
C---------------------------------------------------
			    if (files_were_moved) then
				BCK_subdirectory_name=
     1				    BCK_directory_list(i)
				k=index(BCK_subdirectory_name,']')-1
  				l=k
				do while (BCK_subdirectory_name
     1				    (l:l) .ne. '.')
				    l=l-1
				end do
				l=l+1
C---------------------------------------------------------
C *** since I am deleting a directory tree, the VAX CANNOT
C     HAVE ANY PRIVATE SUBDIRECTORY NAMES OF SIX DIGITS.
C     These types of subdirectories are the domain of BRU-
C     READ only. Sorry folks but that is the way it is!
C---------------------------------------------------------
				call delete_directory_tree(
     1				    BCK_subdirectory_name(l:k))
			    end if
			end do		
		    end if
		end if
C------------------------
C *** LOAD PK_LAB BRU SET
C------------------------
		if (pk_lab) then
		    status=lib$find_file('SUB*.DIR',
     1		    	wanted_set_name,context)
		    alternate_status=lib$find_file_end(context)
		    i=index(wanted_set_name,'.DIR')
		    study_number=wanted_set_name(i-4:i-1)
C--------------------------------------------------------------------
C *** if this is EMGWORK:[SYSTEMEMG] then I cannot load the study_set
C--------------------------------------------------------------------

C-----------------------------------
C *** DECUS does not have SYSTEMEMG!
C-----------------------------------
		    status=RMS$_FNF
		    if (loading_system_pool) then
		        status=lib$find_file('EMGWORK:[*]'//study_number//
     1			    '.TXT;*',loaded_name,context)
		        alternate_status=lib$find_file_end(context)
		    end if
C---------------------------------
C *** the search status tells all!
C---------------------------------
		    if (status .eq. RMS$_FNF) 
     1		        status=lib$rename_file('[.SUB'//study_number//
     2		        '...]*'//study_number//'*.*;*',
     3		        target_directory)
		    call delete_directory_tree('SUB'//study_number)
C--------------------------------
C *** now remove world protection
C--------------------------------
		    if (loading_system_pool) then
		        status=RMS$_NORMAL
		        do while (status .EQ. RMS$_NORMAL)
		            status=lib$find_file('EMGWORK:[SYSTEMEMG]'
     1			        //study_number//'*.*;*',
     2			        loaded_name,context)
		            if (status .eq. RMS$_NORMAL)
     1			        call disable_world_protection(loaded_name)
		        end do
		        alternate_status=lib$find_file_end(context)
		    end if
     		end if
	    else
		status=lib$spawn(
     1		    'BRUREAD/norewind/exclude=*.* '//TAPE_DEVICE_NAME)
		call analyze_status
	    end if
	end do
C-----------------------------------------
C *** all done. Restore original directory
C-----------------------------------------
	if (cli$present('DIRECTORY')) then
	    	alternate_status=lib$set_logical
     1		    ('SYS$DISK',home_directory
     2		    (1:index(home_directory,':')))
	    if (.not. alternate_status) call lib$signal
     1		(%val(alternate_status))
	    alternate_status=sys$setddir(home_directory,,)
	end if
C----------------------------
C *** and protection defaults
C----------------------------
	status=sys$setdfprot(original_protection)
C-----------------------
C *** check for dismount
C-----------------------
	cli_status=cli$present('NODISMOUNT')
	if (cli_status .eq. %loc(CLI$_ABSENT)) then
	    status=sys$dismou(tape_device_name,)
	    if (.not. status) call lib$signal(%val(status))
	end if
	call exit
	end

	SUBROUTINE analyze_status
**************************************************************
*                                                            *
* Analyze return status and restore environment on an error  *
*                                                            *
* Development Environment:VAX/VMS			     *
*                                                            *
* Programmer : Bruce Prendergast   (DAARC Librarian)	     *
*	       Los Amigos research and Education Institute   *
*	       12808 Erickson				     *
*	       Downey, California 90242			     *
*	       (213) 940-7177			 	     *
*	       (213) 803-6117 (fax)			     *
*                                                            *
* Date : November 3, 1988                                    *
*                                                            *
**************************************************************
**************************************************************
C-------------------------------------------
C *** common definitions 
C
	integer*4 creation_time(2),status
	integer*2 original_protection
	character home_directory*128
	common /bru_shell/creation_time,status,
     1	    original_protection,home_directory
C-------------------------------------------

	integer*4 alternate_status,cli$present
	external lib$set_logical

	include '($syssrvnam)'
	
	if (.not. status) then
	    if (cli$present('DIRECTORY')) then
	    	alternate_status=lib$set_logical
     1		    ('SYS$DISK',home_directory
     2		    (1:index(home_directory,':')))
	        if (.not. alternate_status) call lib$signal
     1		    (%val(alternate_status))
	        alternate_status=sys$setddir(home_directory,,)
	    end if
C-----------------------
C *** restore protection
C-----------------------
	    alternate_status=sys$setdfprot(original_protection)
	    call lib$signal(%val(status))
	end if
	return
	end


	SUBROUTINE DELETE_DIRECTORY_TREE(directory_name)
**************************************************************
*                                                            *
* Delete Directory Tree					     *
*                                                            *
* Development Environment:VAX/VMS			     *
*                                                            *
* Programmer : Bruce Prendergast   (DAARC Librarian)	     *
*	       Los Amigos research and Education Institute   *
*	       12808 Erickson				     *
*	       Downey, California 90242			     *
*	       (213) 940-7177			 	     *
*	       (213) 803-6117 (fax)			     *
*                                                            *
* Date : November 3, 1988                                    *
*                                                            *
* Program structure:                                         *
*                                                            *
*                Program is called from BRUSHELL, the PKLAB  *
*	         interface to BRUREAD. The complete contents *
*		 of the directory are deleted along with the *
*		 directory itself. The user of this system   *
*		 must be positioned to the "PARENT" of the   *
*		 directory being deleted.	             *
*						             *
*		 Entry is with a simple name and no control  *
*		 characters. The user must be located in:    *
*			USER$ACCOUNT:[PARENT.DAUGHTER]       *
*		 to delete the directory:		     *
*		 	USER$ACCOUNT:[PARENT.DAUGHTER.SON].  *
*		 In the example above, the entering argument *
*		 for this subroutine would be the character  *
*		 string "SON".				     *
*							     *
**************************************************************
**************************************************************
C-------------------------------------------
C *** common definitions for locate_and_process_xab
C
	integer*4 creation_time(2),status
	integer*2 original_protection
	character home_directory*128
	common /bru_shell/creation_time,status,
     1	    original_protection,home_directory
C-------------------------------------------

C----------------------------
C *** delete a directory tree
C----------------------------
	external lib$find_file,lib$delete_file
	character directory_name*(*),file_to_delete*128
	character directory_stack(200)*128,next_directory*128
	character search_name*128,delete_name*128
	integer*4 context,stack_count
	logical stack_has_not_changed,debug
	include '($syssrvnam)'
	include '($rmsdef)'

C-----------------------------------------
C *** obtain context for initial directory
C-----------------------------------------
	delete_name=directory_name
	status=lib$find_file
     1	    ('[.'//delete_name//']',file_to_delete,context)
C-----------------------------------
C *** destroy current search context
C-----------------------------------
	status=lib$find_file_end(context)
C-----------------------------------------------------
C *** Make a search string from the directory context.
C     The system returns a ...DIRECTORY].; and this
C     will be changed to ...]DIRECTORY.DIR which is 
C     the same form placed on the stack from a search.
C-----------------------------------------------------
	i=index(file_to_delete,']')
	j=i-1
C-------------------------------------------------
C *** In the system here at PKLAB, I know that the
C     directory that I am deleting IS NOT a root
C     tree. If it is then the logic below must
C     be modified.
C-------------------------------------------------
	do while (file_to_delete(j:j) .ne. '.')
	    j=j-1
	end do
	file_to_delete=file_to_delete
     1	    (1:index(file_to_delete,']')-1)//'.DIR'
	file_to_delete(j:j)=']'
	stack_count=stack_count+1
	directory_stack(stack_count)=file_to_delete
C----------------------------------------------------------
C *** The stack has been preset for a kick start! Let's go!
C----------------------------------------------------------
	do while (stack_count .gt. 0)
	    status=RMS$_NMF
	    context=0
	    delete_name=directory_stack(stack_count)
	    i=index(delete_name,']')
	    j=index(delete_name,'.DIR')
C---------------------------------------------------
C *** Look for lower level directories and stack 'em
C---------------------------------------------------
	    search_name=delete_name
     1		(1:index(delete_name,'.DIR')-1)//'*...]*.*;*'
	    search_name(i:i)='.'
	    status=lib$find_file(search_name,file_to_delete,context)
	    stack_has_not_changed=.true.
	    do while ((status .ne. RMS$_NMF) .and. 
     1		(status .ne. RMS$_FNF))
C-------------------------------------------------------
C *** if a lower level directory was found then stack it
C-------------------------------------------------------
		if (index(file_to_delete,'.DIR') .ne. 0) then
C--------------------------------------------------------
C *** directories are deleted last, so it must be stacked
C--------------------------------------------------------
		    stack_count=stack_count+1
		    directory_stack(stack_count)=file_to_delete
C---------------------------------------------------------
C *** Build search string for lower level directory search
C---------------------------------------------------------
		    stack_has_not_changed=.false.
		    k=index(file_to_delete,']')
		    l=index(file_to_delete,'.DIR')
		    file_to_delete(k:k)='.'
		    search_name=file_to_delete(1:l-1)//'...]*.*;*'
C-----------------------------------
C *** destroy current search context
C-----------------------------------
		    status=lib$find_file_end(context)
		else
C---------------------------------------------------
C *** not a lower level directory so I can delete it
C---------------------------------------------------
		    status=lib$delete_file(file_to_delete)
		end if
C-------------
C *** get next
C-------------
		status=lib$find_file(search_name,
     2		    file_to_delete,context)
	    end do
C-------------------------------------------------------
C *** either only files or an empty directory, delete it
C-------------------------------------------------------
	    if (stack_has_not_changed) then
C-----------------------------
C *** disable world protection
C-----------------------------
		call disable_world_protection(delete_name)
		status=lib$delete_file(delete_name)
C------------------------
C *** destroy old context
C------------------------
		status=lib$find_file_end(context)
C-------------
C *** pop next
C-------------
		stack_count=stack_count-1
	    end if
	end do
	return
	end

	subroutine disable_world_protection(file_name)
**************************************************************
*                                                            *
* Disable world protection for directories created by 	     *
* DECUS BRUREAD	     					     *
*                                                            *
* Development Environment:VAX/VMS 4.6   Fortran 4.4	     *
*                                                            *
* Programmer : Bruce Prendergast                             *
*                                                            *
* Date : September 3, 1990				     *
*                                                            *
* Program structure:                                         *
*                                                            *
*                This program is called from the main program*
*		 when PK_LAB is .TRUE.. It is also called by *
*		 DELETE_DIRECTORY_TREE when a directory is   *
*		 being deleted.				     *
*						 	     *
*		 The creation date is communicated via label *
*		 common.	     			     *
*							     *
**************************************************************
**************************************************************
	CHARACTER*(*) FILE_NAME
	external open_directory

	OPEN(UNIT=1,FILE=FILE_NAME,STATUS='OLD',
     1	    USEROPEN=OPEN_DIRECTORY)
	return
	END

	INTEGER FUNCTION OPEN_DIRECTORY(FAB,RAB,LUN)
C-------------------------------------------
C *** common definitions 
C
	integer*4 creation_time(2),status
	integer*2 original_protection
	character home_directory*128
	common /bru_shell/creation_time,status,
     1	    original_protection,home_directory
C-------------------------------------------

	INTEGER*4 LUN,xab,next_xab
	logical xab_found,read_XAB$Q_CDT,set_XAB$W_PRO
	byte xab_code

C--------------------------
C *** REQUIRED DECLARATIONS
C--------------------------
	INCLUDE '($RABDEF)'
	INCLUDE '($FABDEF)'
	INCLUDE '($SYSSRVNAM)'

	INCLUDE '($XABDEF)'
	INCLUDE '($XABDATDEF)'
	INCLUDE '($XABPRODEF)'
C------------------------------------
C *** new xab in case I can't find it
C------------------------------------
	STRUCTURE /MAPPED_XABPRO/
	    UNION
		MAP
		    RECORD /XABDEF/ MAP_XAB
	  	END MAP
		MAP
		    RECORD /XABPRODEF1/ MAP_XABPRO
		END MAP
	    END UNION
	END STRUCTURE
	RECORD /MAPPED_XABPRO/ XABPRO
C----------------------------
C *** EXISTING XAB, HOPEFULLY
C----------------------------
	STRUCTURE /ALLOCATED_XABPRO/
	    UNION
		MAP
		    RECORD /XABDEF/ MAP_XAB
	  	END MAP
		MAP
		    RECORD /XABPRODEF1/ MAP_XABPRO
		END MAP
	    END UNION
	END STRUCTURE
	RECORD /ALLOCATED_XABPRO/ EXISTING_XABPRO
	    
	RECORD /FABDEF/ FAB
	RECORD /RABDEF/ RAB
C--------------
C *** REQUIRED!
C--------------
	FAB.FAB$B_BID=FAB$C_BID
	FAB.FAB$B_BLN=FAB$C_BLN

	RAB.RAB$B_BID=RAB$C_BID
	RAB.RAB$B_BLN=RAB$C_BLN
C---------------------
C *** IDENTIFY NEW XAB
C---------------------
	XABPRO.MAP_XAB.XAB$B_COD=XAB$C_PRO
	XABPRO.MAP_XAB.XAB$B_BLN=XAB$C_PROLEN
C-----------------
C *** CHAIN IN XAB
C-----------------
	EXISTING_XABPRO.MAP_XAB.XAB$B_COD=XAB$C_PRO
	EXISTING_XABPRO.MAP_XAB.XAB$B_BLN=XAB$C_PROLEN

	FAB.FAB$L_XAB=%LOC(EXISTING_XABPRO)
	EXISTING_XABPRO.MAP_XAB.XAB$L_NXT=0
C--------------
C *** OPEN FILE
C--------------
	STATUS=SYS$OPEN(FAB)
	call analyze_status
C-------------------------------
C *** OPEN WAS OKAY, CONNECT RAB
C-------------------------------
	STATUS=SYS$CONNECT(RAB)
	open_directory=status
	call analyze_status
C----------------------------------------
C *** set the protection bits that I need
C----------------------------------------
	xab_found=.false.
	set_XAB$W_PRO=.true.
	xab=FAB.FAB$L_XAB
	xab_code=XAB$C_PRO
	do while ((.not. xab_found) .and. (xab .ne. 0))
	     call locate_and_process_xab(%val(xab),next_xab,xab_found,
     1				xab_code,read_XAB$Q_CDT,set_XAB$W_PRO)
	    if (.not. xab_found) xab=next_xab
	end do
C-----------------------------
C *** not found, build new XAB
C-----------------------------
	if (.not. xab_found) then
	    XABPRO.MAP_XAB.XAB$L_NXT=FAB.FAB$L_XAB
	    FAB.FAB$L_XAB=%LOC(XABPRO)
	    XABPRO.MAP_XABPRO.XAB$W_PRO='0FFF'X
	end if
C--------------
C *** I'm done!
C--------------
	STATUS=SYS$CLOSE(FAB)
	return
	end

	subroutine locate_and_process_xab(xab,next_xab,xab_found,
     1				xab_code,read_XAB$Q_CDT,set_XAB$W_PRO)
**************************************************************
*                                                            *
* Map and locate XAB					     *
*                                                            *
* Development Environment:VAX/VMS 4.6   Fortran 4.4	     *
*                                                            *
* Programmer : Bruce Prendergast                             *
*                                                            *
* Date : September 3, 1990				     *
*                                                            *
* Program structure:                                         *
*                                                            *
*                This program is called from the the two open*
*		 function, OPEN_DIRECTORY and OPEN_FILE. It  *
*		 searches for the proper XAB and returns/sets*
*		 the values required. It will read the crea- *
*		 tion time or set the protection keys. 	     *
*							     *
**************************************************************
**************************************************************
C-------------------------------------------
C *** common definitions 
C
	integer*4 creation_time(2),status
	integer*2 original_protection
	character home_directory*128
	common /bru_shell/creation_time,status,
     1	    original_protection,home_directory
C-------------------------------------------
	logical xab_found,read_XAB$Q_CDT,set_XAB$W_PRO	    	
	integer*4 next_xab
	byte xab_code

	INCLUDE '($XABDEF)'
	INCLUDE '($XABDATDEF)'
	INCLUDE '($XABPRODEF)'

	STRUCTURE /MAPPED_XAB/
	    UNION
		MAP
		    RECORD /XABDEF/ MAP_XAB
	  	END MAP
		MAP
		    RECORD /XABPRODEF1/ MAP_XABPRO
		END MAP
		MAP
		    RECORD /XABDATDEF/ MAP_XABDAT
		END MAP
	    END UNION
	END STRUCTURE

	RECORD /MAPPED_XAB/ XAB
C----------------------------
C *** look at the current XAB
C----------------------------
	if (XAB.MAP_XAB.XAB$B_COD .EQ. xab_code) then
	   xab_found=.true.
	else
	   next_xab=XAB.MAP_XAB.XAB$L_NXT
	   return
	end if

C-----------------------
C *** read creation time
C-----------------------
	if (read_XAB$Q_CDT) then
	    do i=1,2
		creation_time(i)=XAB.MAP_XABDAT.XAB$Q_CDT(i)
	    end do
	    read_XAB$Q_CDT=.FALSE.
	end if
C------------------------
C *** set protection bits
C------------------------
	if (set_XAB$W_PRO) then
	    XAB.MAP_XABPRO.XAB$W_PRO='0FFF'X
	    set_XAB$W_PRO=.FALSE.
	end if
	return
	end

	subroutine get_creation_time(file_name)
**************************************************************
*                                                            *
* Read file creation date and time from XABDAT	             *
*                                                            *
* Development Environment:VAX/VMS 4.6   Fortran 4.4	     *
*                                                            *
* Programmer : Bruce Prendergast                             *
*                                                            *
* Date : September 3, 1990				     *
*                                                            *
* Program structure:                                         *
*                                                            *
*                This program is only called from the main   *
*		 gram and is only called for PK_LAB true, ie.*
*	         NON DECUS. It is only called if the target  *
*		 directory is EMGWORK:[SYSTEMEMG], (the EMG  *
*		 pool). Any expired files are deleted.       *
*						 	     *
*		 The expiration date is communicated back to *
*		 the main program via label common.	     *
*							     *
**************************************************************
**************************************************************
	CHARACTER*(*) FILE_NAME
	external open_file

	OPEN(UNIT=1,FILE=FILE_NAME,STATUS='OLD',
     1	    USEROPEN=OPEN_FILE)
	return
	END

	INTEGER FUNCTION OPEN_FILE(FAB,RAB,LUN)
C------------------------------------------------------------
C *** common definitions 
C
	integer*4 creation_time(2),status
	integer*2 original_protection
	character home_directory*128
	common /bru_shell/creation_time,status,
     1	    original_protection,home_directory
C------------------------------------------------------------
	logical xab_found,read_XAB$Q_CDT,set_XAB$W_PRO	    	
	byte xab_code
	INTEGER*4 LUN,xab,next_xab

C--------------------------
C *** REQUIRED DECLARATIONS
C--------------------------
	INCLUDE '($RABDEF)'
	INCLUDE '($FABDEF)'
	INCLUDE '($SYSSRVNAM)'

	INCLUDE '($XABDEF)'
	INCLUDE '($XABDATDEF)'

	STRUCTURE /MAPPED_XAB/
	    UNION
		MAP
		    RECORD /XABDEF/ MAP_XAB
	  	END MAP
		MAP
		    RECORD /XABDATDEF/ MAP_XABDAT
		END MAP
	    END UNION
	END STRUCTURE
	    
	RECORD /MAPPED_XAB/ EXISTING_XAB

	RECORD /FABDEF/ FAB
	RECORD /RABDEF/ RAB

C--------------
C *** REQUIRED!
C--------------
	FAB.FAB$B_BID=FAB$C_BID
	FAB.FAB$B_BLN=FAB$C_BLN

	RAB.RAB$B_BID=RAB$C_BID
	RAB.RAB$B_BLN=RAB$C_BLN

	EXISTING_XAB.MAP_XAB.XAB$B_COD=XAB$C_DAT
	EXISTING_XAB.MAP_XAB.XAB$B_BLN=XAB$C_DATLEN

	FAB.FAB$L_XAB=%LOC(EXISTING_XAB)
C--------------
C *** OPEN FILE
C--------------
	STATUS=SYS$OPEN(FAB)
	call analyze_status
C-------------------------------
C *** OPEN WAS OKAY, CONNECT RAB
C-------------------------------
	STATUS=SYS$CONNECT(RAB)
	open_file=status
	call analyze_status
C------------------------------
C *** CLEAR CREATION DATE FIRST
C------------------------------
	CREATION_TIME(1)=0
	CREATION_TIME(2)=0
C---------------------------
C *** get creation date/time
C---------------------------
	xab_found=.false.
	read_XAB$Q_CDT=.true.
	xab=FAB.FAB$L_XAB
	xab_code=XAB$C_DAT
	do while ((.not. xab_found) .and. (xab .ne. 0))
	    call locate_and_process_xab(%val(xab),next_xab,xab_found,
     1		xab_code,read_XAB$Q_CDT,set_XAB$W_PRO)
	    if (.not. xab_found) xab=next_xab
	end do
C--------------------------
C *** CLOSE FILE AND RETURN
C--------------------------
	STATUS=SYS$CLOSE(FAB)
	return
	end

