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)',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