COMPILATION LISTING OF SEGMENT hp_delete Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 10/25/83 1530.5 mst Tue Options: optimize map 1 /* *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 4* * * 5* * Copyright (c) 1972 by Massachusetts Institute of * 6* * Technology and Honeywell Information Systems, Inc. * 7* * * 8* *********************************************************** */ 9 10 11 /* Delete a segment or directory (including inferior segments/links/directories) 12* regardless of logical volume mounting, connection failure, etc. */ 13 14 /* Last modified: 15* April 1979 by D. Spector: created 16**/ 17 18 hp_delete: 19 hpdl: 20 procedure; 21 22 /* AUTOMATIC */ 23 24 declare answer char (3) varying; 25 declare area_ptr ptr; 26 declare argl fixed binary; 27 declare argp ptr; 28 declare code fixed binary (35); 29 declare count fixed binary; 30 declare dirname char (168); 31 declare entryname char (32); 32 declare i fixed binary; 33 declare pathname char (168); 34 declare type fixed binary (2); 35 1 1 /* BEGIN INCLUDE FILE query_info.incl.pl1 TAC June 1, 1973 */ 1 2 /* Renamed to query_info.incl.pl1 and cp_escape_control added, 08/10/78 WOS */ 1 3 /* version number changed to 4, 08/10/78 WOS */ 1 4 /* Version 5 adds explanation_(ptr len) 05/08/81 S. Herbst */ 1 5 /* Version 6 adds literal_sw, prompt_after_explanation switch 12/15/82 S. Herbst */ 1 6 1 7 dcl 1 query_info aligned, /* argument structure for command_query_ call */ 1 8 2 version fixed bin, /* version of this structure - must be set, see below */ 1 9 2 switches aligned, /* various bit switch values */ 1 10 3 yes_or_no_sw bit (1) unaligned init ("0"b), /* not a yes-or-no question, by default */ 1 11 3 suppress_name_sw bit (1) unaligned init ("0"b), /* do not suppress command name */ 1 12 3 cp_escape_control bit (2) unaligned init ("00"b), /* obey static default value */ 1 13 /* "01" -> invalid, "10" -> don't allow, "11" -> allow */ 1 14 3 suppress_spacing bit (1) unaligned init ("0"b), /* whether to print extra spacing */ 1 15 3 literal_sw bit (1) unaligned init ("0"b), /* ON => do not strip leading/trailing white space */ 1 16 3 prompt_after_explanation bit (1) unaligned init ("0"b), /* ON => repeat question after explanation */ 1 17 3 padding bit (29) unaligned init (""b), /* pads it out to t word */ 1 18 2 status_code fixed bin (35) init (0), /* query not prompted by any error, by default */ 1 19 2 query_code fixed bin (35) init (0), /* currently has no meaning */ 1 20 1 21 /* Limit of data defined for version 2 */ 1 22 1 23 2 question_iocbp ptr init (null ()), /* IO switch to write question */ 1 24 2 answer_iocbp ptr init (null ()), /* IO switch to read answer */ 1 25 2 repeat_time fixed bin (71) init (0), /* repeat question every N seconds if no answer */ 1 26 /* minimum of 30 seconds required for repeat */ 1 27 /* otherwise, no repeat will occur */ 1 28 /* Limit of data defined for version 4 */ 1 29 1 30 2 explanation_ptr ptr init (null ()), /* explanation of question to be printed if */ 1 31 2 explanation_len fixed bin (21) init (0); /* user answers "?" (disabled if ptr=null or len=0) */ 1 32 1 33 dcl query_info_version_3 fixed bin int static options (constant) init (3); 1 34 dcl query_info_version_4 fixed bin int static options (constant) init (4); 1 35 dcl query_info_version_5 fixed bin int static options (constant) init (5); 1 36 dcl query_info_version_6 fixed bin int static options (constant) init (6); /* the current version number */ 1 37 1 38 /* END INCLUDE FILE query_info.incl.pl1 */ 36 37 38 /* EXTERNAL */ 39 40 declare absolute_pathname_ entry (char (*), char (*), fixed binary (35)); 41 declare com_err_ entry options (variable); 42 declare com_err_$suppress_name entry options (variable); 43 declare command_query_ entry options (variable); 44 declare cu_$arg_count entry (fixed binary); 45 declare cu_$arg_ptr entry (fixed binary, ptr, fixed binary, fixed binary (35)); 46 declare error_table_$link external fixed binary (35); 47 declare error_table_$moderr external fixed binary (35); 48 declare error_table_$nomatch external fixed binary (35); 49 declare expand_pathname_ entry (char (*), char (*), char (*), fixed binary (35)); 50 declare get_system_free_area_ entry () returns (ptr); 51 declare hcs_$star_ entry (char (*), char (*), fixed binary (2), ptr, fixed binary, ptr, ptr, 52 fixed binary (35)); 53 declare hcs_$status_minf entry (char (*), char (*), fixed binary (1), fixed binary (2), fixed binary (24), 54 fixed binary (35)); 55 declare hcs_$terminate_file entry (char (*), char (*), fixed binary (1), fixed binary (35)); 56 declare hphcs_$delentry_file entry (char (*), char (*), fixed binary (35)); 57 declare system_privilege_$check_mode_reset 58 entry (char (*), char (*), fixed binary (35)); 59 60 /* BUILTIN */ 61 62 declare (addr, null, rtrim) builtin; 63 64 /* MISCELLANEOUS */ 65 66 declare arg char (argl) based (argp); 67 declare cleanup condition; 68 declare linkage_error condition; 69 declare me char (32) initial ("hp_delete") internal static options (constant); 70 71 /* Start of command */ 72 73 /* Set up handler for insufficient access to gates */ 74 75 on linkage_error 76 begin; 77 call com_err_ (error_table_$moderr, me, "hphcs_ and/or system_privilege_"); 78 go to quit; 79 end; 80 81 /* Make sure there is one argument */ 82 83 call cu_$arg_count (count); 84 if count ^= 1 85 then do; 86 call com_err_$suppress_name (0, me, "Usage: ^a pathname", me); 87 return; 88 end; 89 90 /* Get the pathname argument */ 91 92 call cu_$arg_ptr (1, argp, argl, code); 93 if code ^= 0 94 then go to error; 95 96 /* Find branch type */ 97 98 call expand_pathname_ (arg, dirname, entryname, code); 99 if code ^= 0 100 then go to error; 101 call absolute_pathname_ (arg, pathname, (0)); 102 call hcs_$status_minf (dirname, entryname, 0, type, (0), code); 103 if code ^= 0 104 then go to error; 105 106 /* Refuse to delete links due to ambiguity of chasing */ 107 108 if type = 0 /* Link */ 109 then do; 110 call com_err_ (error_table_$link, me, "^a.", pathname); 111 return; 112 end; 113 114 /* Query user whether to go ahead with deletion */ 115 116 query_info.version = query_info_version_4; 117 query_info.yes_or_no_sw = "1"b; 118 query_info.suppress_name_sw = "1"b; 119 call command_query_ (addr (query_info), answer, me, "Do you really want to delete the^[ segment^; directory^] ^a ?", 120 type = 1, pathname); 121 if answer ^= "yes" /* Note dependency on English! */ 122 then return; 123 124 /* Do the deletion */ 125 126 area_ptr = get_system_free_area_ (); /* For hcs_$star_ */ 127 call delete_branch (dirname, entryname, type); 128 129 /* Done */ 130 131 return; 132 133 /* Error handling */ 134 135 error: 136 call com_err_ (code, me, "^a.", arg); 137 quit: 138 return; 139 140 /* Subroutines */ 141 142 /* Delete a branch (seg, dir, or link) */ 143 144 delete_branch: 145 procedure (dirname, entryname, type); 146 147 declare dirname char (168); 148 declare entryname char (32); 149 declare type fixed binary (2); 150 151 declare 1 entries (entry_count) aligned based (entry_ptr), 152 2 type fixed binary (2) unsigned unaligned, 153 2 nnames fixed binary (16) unsigned unaligned, 154 2 nindex fixed binary (18) unsigned unaligned; 155 declare entry_count fixed binary; 156 declare entry_ptr ptr; 157 declare i fixed binary; 158 declare n_ptr ptr; 159 declare names (100) char (32) based (n_ptr); 160 declare pathname char (168); 161 162 /* Construct pathname */ 163 164 if dirname = ">" 165 then pathname = ">" || entryname; 166 else pathname = rtrim (dirname) || ">" || entryname; 167 168 /* Reset security_out_of_service switch if set */ 169 170 if type = 2 /* Directory */ 171 then call system_privilege_$check_mode_reset (dirname, entryname, (0)); 172 173 /* Delete the branch */ 174 175 if type = 2 /* Directory */ 176 /* Delete the contents of a directory */ 177 then do; 178 179 /* Handle errors and quit/release */ 180 181 entry_ptr = null; 182 n_ptr = null; 183 on cleanup 184 call clean; /* Free allocated storage */ 185 186 /* Find all entrynames in this directory */ 187 188 call hcs_$star_ (pathname, "**", 3, area_ptr, entry_count, entry_ptr, n_ptr, code); 189 if code ^= 0 190 then if code ^= error_table_$nomatch 191 then do; 192 call com_err_ (code, me, pathname); 193 go to quit; 194 end; 195 196 /* Delete all branches contained in this directory */ 197 198 do i = 1 to entry_count; 199 call delete_branch (pathname, names (entries (i).nindex), (entries (i).type)); 200 end; 201 202 /* Clean up process changes caused by hcs_$star_ */ 203 204 call clean; /* Free allocated storage */ 205 call hcs_$terminate_file (dirname, entryname, 0, (0)); 206 end; 207 208 /* Delete the segment itself */ 209 210 call hphcs_$delentry_file (dirname, entryname, code); 211 if code ^= 0 212 then do; 213 call com_err_ (code, me, pathname); 214 go to quit; 215 end; 216 return; 217 218 /* Subroutine to free storage used by hcs_$star_ */ 219 220 clean: 221 procedure; 222 if entry_ptr ^= null 223 then free entries; 224 if n_ptr ^= null 225 then free names; 226 return; 227 end; /* clean */ 228 229 end; /* delete_branch */ 230 231 end; /* hp_delete */ SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 10/25/83 1441.4 hp_delete.pl1 >spec>on>eod-fix>hp_delete.pl1 36 1 03/11/83 1204.3 query_info.incl.pl1 >ldd>include>query_info.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. absolute_pathname_ 000010 constant entry external dcl 40 ref 101 addr builtin function dcl 62 ref 119 119 answer 000100 automatic varying char(3) dcl 24 set ref 119* 121 answer_iocbp 6 000250 automatic pointer initial level 2 dcl 1-7 set ref 1-7* area_ptr 000102 automatic pointer dcl 25 set ref 126* 188* arg based char unaligned dcl 66 set ref 98* 101* 135* argl 000104 automatic fixed bin(17,0) dcl 26 set ref 92* 98 98 101 101 135 135 argp 000106 automatic pointer dcl 27 set ref 92* 98 101 135 cleanup 000000 stack reference condition dcl 67 ref 183 code 000110 automatic fixed bin(35,0) dcl 28 set ref 92* 93 98* 99 102* 103 135* 188* 189 189 192* 210* 211 213* com_err_ 000012 constant entry external dcl 41 ref 77 110 135 192 213 com_err_$suppress_name 000014 constant entry external dcl 42 ref 86 command_query_ 000016 constant entry external dcl 43 ref 119 count 000111 automatic fixed bin(17,0) dcl 29 set ref 83* 84 cp_escape_control 1(02) 000250 automatic bit(2) initial level 3 packed unaligned dcl 1-7 set ref 1-7* cu_$arg_count 000020 constant entry external dcl 44 ref 83 cu_$arg_ptr 000022 constant entry external dcl 45 ref 92 dirname 000112 automatic char(168) unaligned dcl 30 in procedure "hpdl" set ref 98* 102* 127* dirname parameter char(168) unaligned dcl 147 in procedure "delete_branch" set ref 144 164 166 170* 205* 210* entries based structure array level 1 dcl 151 ref 222 entry_count 000100 automatic fixed bin(17,0) dcl 155 set ref 188* 198 222 entry_ptr 000102 automatic pointer dcl 156 set ref 181* 188* 199 199 222 222 entryname parameter char(32) unaligned dcl 148 in procedure "delete_branch" set ref 144 164 166 170* 205* 210* entryname 000164 automatic char(32) unaligned dcl 31 in procedure "hpdl" set ref 98* 102* 127* error_table_$link 000024 external static fixed bin(35,0) dcl 46 set ref 110* error_table_$moderr 000026 external static fixed bin(35,0) dcl 47 set ref 77* error_table_$nomatch 000030 external static fixed bin(35,0) dcl 48 ref 189 expand_pathname_ 000032 constant entry external dcl 49 ref 98 explanation_len 14 000250 automatic fixed bin(21,0) initial level 2 dcl 1-7 set ref 1-7* explanation_ptr 12 000250 automatic pointer initial level 2 dcl 1-7 set ref 1-7* get_system_free_area_ 000034 constant entry external dcl 50 ref 126 hcs_$star_ 000036 constant entry external dcl 51 ref 188 hcs_$status_minf 000040 constant entry external dcl 53 ref 102 hcs_$terminate_file 000042 constant entry external dcl 55 ref 205 hphcs_$delentry_file 000044 constant entry external dcl 56 ref 210 i 000104 automatic fixed bin(17,0) dcl 157 set ref 198* 199 199* linkage_error 000266 stack reference condition dcl 68 ref 75 literal_sw 1(05) 000250 automatic bit(1) initial level 3 packed unaligned dcl 1-7 set ref 1-7* me 000000 constant char(32) initial unaligned dcl 69 set ref 77* 86* 86* 110* 119* 135* 192* 213* n_ptr 000106 automatic pointer dcl 158 set ref 182* 188* 199 224 224 names based char(32) array unaligned dcl 159 set ref 199* 224 nindex 0(18) based fixed bin(18,0) array level 2 packed unsigned unaligned dcl 151 ref 199 null builtin function dcl 62 ref 1-7 1-7 1-7 181 182 222 224 padding 1(07) 000250 automatic bit(29) initial level 3 packed unaligned dcl 1-7 set ref 1-7* pathname 000174 automatic char(168) unaligned dcl 33 in procedure "hpdl" set ref 101* 110* 119* pathname 000110 automatic char(168) unaligned dcl 160 in procedure "delete_branch" set ref 164* 166* 188* 192* 199* 213* prompt_after_explanation 1(06) 000250 automatic bit(1) initial level 3 packed unaligned dcl 1-7 set ref 1-7* query_code 3 000250 automatic fixed bin(35,0) initial level 2 dcl 1-7 set ref 1-7* query_info 000250 automatic structure level 1 dcl 1-7 set ref 119 119 query_info_version_4 constant fixed bin(17,0) initial dcl 1-34 ref 116 question_iocbp 4 000250 automatic pointer initial level 2 dcl 1-7 set ref 1-7* repeat_time 10 000250 automatic fixed bin(71,0) initial level 2 dcl 1-7 set ref 1-7* rtrim builtin function dcl 62 ref 166 status_code 2 000250 automatic fixed bin(35,0) initial level 2 dcl 1-7 set ref 1-7* suppress_name_sw 1(01) 000250 automatic bit(1) initial level 3 packed unaligned dcl 1-7 set ref 118* 1-7* suppress_spacing 1(04) 000250 automatic bit(1) initial level 3 packed unaligned dcl 1-7 set ref 1-7* switches 1 000250 automatic structure level 2 dcl 1-7 system_privilege_$check_mode_reset 000046 constant entry external dcl 57 ref 170 type based fixed bin(2,0) array level 2 in structure "entries" packed unsigned unaligned dcl 151 in procedure "delete_branch" ref 199 type 000246 automatic fixed bin(2,0) dcl 34 in procedure "hpdl" set ref 102* 108 119 127* type parameter fixed bin(2,0) dcl 149 in procedure "delete_branch" ref 144 170 175 version 000250 automatic fixed bin(17,0) level 2 dcl 1-7 set ref 116* yes_or_no_sw 1 000250 automatic bit(1) initial level 3 packed unaligned dcl 1-7 set ref 117* 1-7* NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. i automatic fixed bin(17,0) dcl 32 query_info_version_3 internal static fixed bin(17,0) initial dcl 1-33 query_info_version_5 internal static fixed bin(17,0) initial dcl 1-35 query_info_version_6 internal static fixed bin(17,0) initial dcl 1-36 NAMES DECLARED BY EXPLICIT CONTEXT. clean 001236 constant entry internal dcl 220 ref 183 204 delete_branch 000617 constant entry internal dcl 144 ref 127 199 error 000563 constant label dcl 135 ref 93 99 103 hp_delete 000147 constant entry external dcl 18 hpdl 000137 constant entry external dcl 18 quit 000615 constant label dcl 137 ref 78 193 214 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1542 1612 1271 1552 Length 2026 1271 50 200 250 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME hpdl 246 external procedure is an external procedure. on unit on line 75 86 on unit delete_branch 172 internal procedure enables or reverts conditions. on unit on line 183 64 on unit clean 64 internal procedure is called by several nonquick procedures. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME delete_branch 000100 entry_count delete_branch 000102 entry_ptr delete_branch 000104 i delete_branch 000106 n_ptr delete_branch 000110 pathname delete_branch hpdl 000100 answer hpdl 000102 area_ptr hpdl 000104 argl hpdl 000106 argp hpdl 000110 code hpdl 000111 count hpdl 000112 dirname hpdl 000164 entryname hpdl 000174 pathname hpdl 000246 type hpdl 000250 query_info hpdl THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_e_as alloc_cs cat_realloc_cs call_ext_out_desc call_ext_out call_int_this call_int_other return tra_ext enable shorten_stack ext_entry int_entry free_based THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. absolute_pathname_ com_err_ com_err_$suppress_name command_query_ cu_$arg_count cu_$arg_ptr expand_pathname_ get_system_free_area_ hcs_$star_ hcs_$status_minf hcs_$terminate_file hphcs_$delentry_file system_privilege_$check_mode_reset THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$link error_table_$moderr error_table_$nomatch LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 1 7 000104 18 000136 75 000155 77 000171 78 000214 83 000217 84 000226 86 000231 87 000264 92 000265 93 000304 98 000306 99 000336 101 000340 102 000365 103 000424 108 000426 110 000430 111 000457 116 000460 117 000462 118 000464 119 000466 121 000534 126 000541 127 000550 131 000562 135 000563 137 000615 144 000616 164 000624 166 000647 170 000710 175 000735 181 000741 182 000743 183 000744 188 000766 189 001036 192 001044 193 001064 198 001067 199 001077 200 001124 204 001126 205 001132 210 001162 211 001205 213 001210 214 001231 216 001234 220 001235 222 001243 224 001252 226 001261 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group BULL including BULL HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell BULL Inc., Groupe BULL and BULL HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, BULL or BULL HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by BULL HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved