1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1990   *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1983 *
  6         *                                                         *
  7         *********************************************************** */
  8 
  9 
 10 
 11 /****^  HISTORY COMMENTS:
 12   1) change(90-07-30,Bubric), approve(90-07-30,MCR8185), audit(90-09-12,Vu),
 13      install(90-09-20,MR12.4-1026):
 14      Fix delete_$path to handle extended objects which are directories.
 15   2) change(92-09-24,Vu), approve(92-09-24,MCR8266), audit(92-09-24,Zimmerman),
 16      install(92-10-06,MR12.5-1025):
 17      Fixed dl command for deleting forum.
 18                                                    END HISTORY COMMENTS */
 19 
 20 
 21 /* format: style2,idind30,indcomtxt */
 22 
 23 delete_$path:
 24      procedure (dirname, entryname, a_switches, caller, code);
 25 
 26 /* The delete_ subroutine takes care of deleting branches and unlinking links.  It
 27    can ask questions if access is incorrect to the segment, and attempt to force delete access.
 28 
 29    The path entry is called with the pathname of the thing to be deleted or unlinked.
 30    The switches argument tells delete_ what it is to do:
 31 
 32    1. force_sw      If ON, delete_ attempts to delete protected
 33    .                as well as unprotected entries.
 34    2. question_sw   If ON and force_sw is OFF, delete_ queries the user
 35    .                about deleting protected entries. If force_sw is ON
 36    .                and ename refers to a directory, delete_ prints a
 37    .                message for each entry under that directory that
 38    .                cannot be deleted.
 39    3. directory_sw  A directory can be deleted only if ON.
 40    4. segment_sw    A segment can be deleted only if ON.
 41    5. link_sw       A link can be unlinked only if ON.
 42    6. chase_sw      If ON, delete_ deletes through links.
 43    7. lib_sw        If ON, calls through installation_tools_.
 44    8. raw_sw        If ON, delete_$path calls hcs_ and not object_type_.
 45 
 46    Initially coded April 1972 by Dan Bricklin.
 47    Modified on November 1972 by E. Stone for new directory control
 48    Modified on Jan 1974 by E. Stone to reflect that error_table_$moderr not returned from delentry
 49    Modified on May 15, 1974 by Kobziar to delete initiate acl if seg not deleted.
 50    Modified on Oct 1, 1974 by J. Whitmore to attempt to delete a directory before calling del_dir_tree also
 51    to correct a bad error code if the ptr entry is called with a null pointer.
 52    Modified on 8/27/75 to prevent infinite delete_again, etc. loops.
 53    Modified April 1976 by Larry Johnson for master directories.
 54    Modified Oct 4, 1979 by M. Pierret to skip unnecessary calls to term_$nomakeunknown.
 55    Modified to work on mailboxes and queues 03/28/80 S. Herbst
 56    Modified 30 June 1980 by G. Palter to make delete_$path not loop on inner ring segments and make delete_$ptr work again
 57    Modified 21 October 1980 by G. Palter to not loop on inner ring segments with names shorter than 4 characters
 58    Modified 01/17/83 by S. Herbst to recognize et_$action_not_performed fom dl_handler_
 59    Modified 1/26/83 Jay Pattin for object_type_, added raw_sw
 60    Modified 3/15/83 Jay Pattin to terminate segments when user answers no to "delete?" query
 61    Modified 830927 BIM for object_type_ --> fs_util_.
 62    Modified 831022 BIM to fix bug in descriptor checking for bit (6).
 63    Modified 831027 BIM to never terminate until after checking safety switch.
 64    Modified 840626 to suppress ssw/copysw query when force-deleting dir.
 65    Modified 841119 MAP to generate all abs pathnames by using pathname_.
 66    Modified 841203 Matthew Pierret: to not delete a directory which contains
 67    a protected data management file if a transaction is in
 68    progress.  This is because deletion of dm files is delayed
 69    until the transaction commits.
 70    Modified 850124 Steve Herbst to call hcs_$get_segment_ptr_path rather
 71           than initiate a segment.
 72    Modified 850206 Keith Loepere for correct error code $moderr instead of
 73           $incorrect_access from hcs_$star_.
 74 */
 75 
 76           dcl     a_switches                    bit (36) aligned;
 77           dcl     all                           fixed bin (2) init (3);
 78           dcl     bitcount                      fixed bin (24);
 79           dcl     caller                        char (*);
 80           dcl     code                          fixed bin (35);
 81           dcl     com_err_                      entry options (variable);
 82           dcl     delete_$path                  entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35));
 83           dcl     directory_contents_code       fixed bin (35);
 84           dcl     dirname                       char (*);
 85           dcl     dl_handler_$switches          entry (char (*), char (*), char (*), bit (36) aligned, fixed bin (35));
 86           dcl     dname                         char (168);
 87           dcl     ecount                        fixed bin;
 88           dcl     ename                         char (32);
 89           dcl     entryname                     char (*);
 90           dcl     eptr                          pointer;
 91           dcl     etype                         bit (2);
 92           dcl     fs_util_type                  char (32);
 93           dcl     get_group_id_$tag_star        entry returns (char (32) aligned);
 94           dcl     get_system_free_area_         entry returns (ptr);
 95           dcl     path_entry                    bit (1);
 96           dcl     fs_util_$get_type             entry (character (*), character (*), character (*), fixed binary (35));
 97           dcl     fs_util_$delentry_file        entry (character (*), character (*), fixed binary (35));
 98 
 99           dcl     hcs_$add_dir_acl_entries      entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
100           dcl     hcs_$delentry_file            entry (char (*), char (*), fixed bin (35));
101           dcl     hcs_$fs_get_path_name         entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
102           dcl     hcs_$get_link_target          entry (char (*), char (*), char (*), char (*), fixed bin (35));
103           dcl     hcs_$get_safety_sw_seg        entry (pointer, bit (1) aligned, fixed bin (35));
104           dcl     hcs_$get_segment_ptr_path     entry (char (*), char (*), ptr, bit (36) aligned, fixed bin (35));
105           dcl     hcs_$lv_attached              entry (bit (36) aligned, fixed bin (35));
106           dcl     hcs_$star_                    entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr,
107                                                 fixed bin (35));
108           dcl     hcs_$status_minf              entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
109                                                 fixed bin (35));
110           dcl     hcs_$status_long              entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
111           dcl     installation_tools_$delentry_file
112                                                 entry (char (*), char (*), fixed bin (35));
113           dcl     i                             fixed bin;
114           dcl     init_acl_sw                   bit (1) aligned init ("0"b);
115           dcl     mdc_$delete_dir               entry (char (*), char (*), fixed bin (35));
116           dcl     name                          char (32);
117           dcl     nptr                          pointer;
118           dcl     operation                     char (6);
119           dcl     pathname_                     entry (char (*), char (*)) returns (char (168));
120           dcl     pname                         char (168);
121           dcl     safety_switch                 bit (1) aligned;
122           dcl     segp                          ptr;
123           dcl     segptr                        ptr;
124           dcl     term_$seg_ptr                 entry (pointer, fixed binary (35));
125           dcl     type                          fixed bin (2);
126 
127           dcl     error_table_$action_not_performed
128                                                 ext fixed bin (35);
129           dcl     error_table_$copy_sw_on       ext fixed bin (35);
130           dcl     dm_error_$delete_pending_transaction
131                                                 ext fixed bin (35);
132           dcl     error_table_$dirseg           ext fixed bin (35);
133           dcl     error_table_$fulldir          ext fixed bin (35);
134           dcl     error_table_$incorrect_access ext fixed bin (35);
135           dcl     error_table_$invalidsegno     ext fixed bin (35);
136           dcl     error_table_$master_dir       ext fixed bin (35);
137           dcl     error_table_$moderr           ext fixed bin (35);
138           dcl     dm_error_$no_delete_dir_transaction
139                                                 ext fixed bin (35);
140           dcl     error_table_$nondirseg        ext fixed bin (35);
141           dcl     error_table_$not_a_branch     ext fixed bin (35);
142           dcl     error_table_$safety_sw_on     ext fixed bin (35);
143 
144 
145           dcl     (addr, fixed, null, rtrim, string, substr)
146                                                 builtin;
147 
148 
149           dcl     1 dir_acl                     aligned,
150                     2 userid                    char (32),
151                     2 mode                      bit (36),
152                     2 status                    fixed bin (35);
153 
154           dcl     1 entries                     (ecount) aligned based (eptr),
155                     2 type                      bit (2) unaligned,
156                     2 nnames                    bit (16) unaligned,
157                     2 nindex                    bit (18) unaligned;
158 
159           dcl     names                         (1000) char (32) aligned based (nptr);
160 
161 
162           dcl     1 lbranch                     aligned,    /* structure returned by status_long */
163                     2 type                      bit (2) unaligned,
164                     2 nnames                    fixed bin (15) unaligned,
165                     2 nrp                       bit (18) unaligned,
166                     2 dtm                       bit (36),
167                     2 dtu                       bit (36),
168                     2 mode                      bit (5) unaligned,
169                     2 raw_mode                  bit (5) unaligned,
170                                                             /* raw mode from acl entry */
171                     2 pad1                      bit (8) unaligned,
172                     2 records                   fixed bin (17) unaligned,
173                     2 dtd                       bit (36),   /* date time segment and branch dumped */
174                     2 dtem                      bit (36),   /* date time branch modified */
175                     2 lvid                      bit (36),   /* logical volume id (sons_lvid for dirs) */
176                     2 curlen                    fixed bin (11) unaligned,
177                                                             /* highest 1024-word block used */
178                     2 bitcnt                    bit (24) unaligned,
179                                                             /* bit count */
180                     2 did                       bit (4) unaligned,
181                     2 mdid                      bit (4) unaligned,
182                     2 copysw                    bit (1) unaligned,
183                     2 tpd                       bit (1) unaligned,
184                     2 pad3                      bit (8) unaligned,
185                     2 rbs                       (0:2) fixed bin (5) unaligned,
186                     2 uid                       bit (36);
187 %page;
188 %include delete_options;
189 %include std_descriptor_types;
190 
191 %include dl_handler_options;
192 
193 %include suffix_info;
194 %include copy_flags;
195 ^L
196 /* Initialize variables.  Set code to zero, and remember that we have the pathname
197    of the thing to be deleted (the ptr entry does not provide it). */
198 
199           code = 0;
200           dname = dirname;
201           ename = entryname;
202           path_entry = "1"b;
203           segp = null;
204           call check_switches (3);
205 
206 /* Find out what type of branch this is.  Then dispatch to the appropriate action routine,
207    or error message.  Note that a directory with a non-zero bitcount
208    is considered to be a segment - an MSF */
209 
210 check_type:
211           call hcs_$status_minf (dname, ename, 0, type, bitcount, code);
212           if code ^= 0
213           then return;
214 
215           if ^delete_options.raw & type ^= 0
216           then do;
217                     call fs_util_$get_type (dname, ename, fs_util_type, code);
218                                                             /* Is this Xobj (not link to Xobj)? */
219                     if code = 0 & (substr (fs_util_type, 1, 1) ^= "-" | fs_util_type = FS_OBJECT_TYPE_DM_FILE)
220                     then do;                                /* - at beginning implies standard object, but */
221                                                             /* this program treats DM files as extended */
222                                                             /* rather than standard objects */
223                               /* if extended object, don't try to initiate */
224                               if type = 1 & ^delete_options.segment
225                               then goto is_segment;
226                               goto call_delete;
227                          end;
228                end;
229 
230           if type = 0
231           then /* link */
232                if ^delete_options.link
233                then go to is_link;
234                else if delete_options.chase
235                then do;
236                          call hcs_$get_link_target (dname, ename, dname, ename, code);
237                          if code ^= 0
238                          then return;                       /* chase the link and start again */
239                          go to check_type;
240                     end;
241                else go to unlink_link;
242 
243           else if type = 1
244           then /* segment */
245                if ^delete_options.segment
246                then go to is_segment;
247                else go to delete_segment;
248 
249           else if type = 2
250           then /* directory */
251                if bitcount ^= 0
252                then do;
253                          if ^delete_options.segment
254                          then go to is_segment;
255                          type = 3;                          /* msf */
256                          go to delete_msf;
257                     end;
258 
259                else if ^delete_options.directory
260                then go to is_directory;
261                else go to delete_directory;
262 
263 
264 /* Call term_ on the segment to be deleted. */
265 /* Initiate it here, so we can take advantage of segptr if we have it */
266 
267 delete_segment:
268           if segp = null ()
269           then do;
270                     call hcs_$get_segment_ptr_path (dirname, ename, segp, "0"b, code);
271                     if segp ^= null ()                      /* segment was previously initiated */
272                     then do;
273                               call hcs_$get_safety_sw_seg (segp, safety_switch, (0));
274                               if safety_switch
275                               then go to protected_by_switch;
276                               /*** * We don't check the copy switch, it is too much pain. */
277                               call term_$seg_ptr (segp, (0));
278                                                             /* begone! */
279                          end;
280                     segp = null ();
281                end;
282           else do;
283                     call hcs_$fs_get_path_name (segp, dname, (0), ename, code);
284                     if code ^= 0
285                     then return;
286                end;
287 
288 
289 unlink_link:
290 call_delete:
291           if delete_options.library
292           then call installation_tools_$delentry_file (dname, ename, code);
293           else if delete_options.raw | type = 0             /* flush links with hcs_ */
294           then call hcs_$delentry_file (dname, ename, code);
295           else call fs_util_$delentry_file (dname, ename, code);
296 
297           if code ^= 0
298           then if code = error_table_$copy_sw_on | code = error_table_$safety_sw_on
299                then
300 protected_by_switch:                                        /* come here to avoid terminating before asking question */
301                     do;                                     /* entry is protected - see whether to force */
302                          if (^delete_options.force & ^delete_options.question)
303                          then return;
304 
305                          string (dl_handler_options) = ""b;
306                          dl_handler_options.no_question = delete_options.force;
307                          dl_handler_options.raw = delete_options.raw;
308                          dl_handler_options.library = delete_options.library;
309 
310                          call dl_handler_$switches (caller, dname, ename, string (dl_handler_options), code);
311 
312                          if code = 0
313                          then go to call_delete;
314                          else return;
315                     end;
316           return;
317 
318 
319 /* Delete a directory.  MSF's (directories with non-zero bitcounts) are treated the same way */
320 
321 delete_msf:
322 delete_directory:
323           call hcs_$delentry_file (dname, ename, code);     /* try to delete it first */
324           if code = error_table_$fulldir
325           then do;                                          /* have to delete its contents */
326 delete_contents:
327                     call hcs_$status_long (dname, ename, 0, addr (lbranch), null, code);
328                                                             /* must find out if mounted before deleting */
329                     if code ^= 0
330                     then return;
331                     call hcs_$lv_attached (lbranch.lvid, code);
332                     if code ^= 0
333                     then return;
334                     pname = pathname_ (rtrim (dname), ename);
335 list_again:
336                     call hcs_$star_ (pname, "**", all, get_system_free_area_ (), ecount, eptr, nptr, code);
337                     if code ^= 0
338                     then do;
339                               if code = error_table_$moderr
340                               then do;                      /* force dir access */
341                                         if init_acl_sw
342                                         then return;
343                                         dir_acl.userid = get_group_id_$tag_star ();
344                                         dir_acl.mode = "111"b;
345                                         dir_acl.status = 0;
346                                         call hcs_$add_dir_acl_entries (dname, ename, addr (dir_acl), 1, code);
347                                         init_acl_sw = "1"b;
348                                         if code = 0 & dir_acl.status = 0
349                                         then go to list_again;
350                                    end;
351                               if delete_options.question
352                               then call com_err_ (code, caller, "Unable to delete ^a", pname);
353                               return;
354                          end;
355                     directory_contents_code = 0;
356                     do i = 1 to ecount;
357                          name = names (fixed (entries (i).nindex));
358                          etype = entries (i).type;
359                          delete_options.link, delete_options.segment = "1"b;
360                          init_acl_sw = "0"b;
361 delete_again:
362                          call delete_$path (pname, name, (string (delete_options)), caller, code);
363                                                             /* recurse */
364                          if code ^= 0
365                          then do;
366                                    if code = error_table_$incorrect_access
367                                    then do;                 /* force dir access */
368                                              if init_acl_sw
369                                              then return;
370                                              dir_acl.userid = get_group_id_$tag_star ();
371                                              dir_acl.mode = "111"b;
372                                              dir_acl.status = 0;
373                                              call hcs_$add_dir_acl_entries (dname, ename, addr (dir_acl), 1, code);
374                                              init_acl_sw = "1"b;
375                                              if code = 0 & dir_acl.status = 0
376                                              then go to delete_again;
377                                         end;
378                                    if code = error_table_$action_not_performed
379                                    then do;
380                                              directory_contents_code = code;
381                                              go to endloop;
382                                         end;
383                                    if directory_contents_code ^= error_table_$action_not_performed
384                                         & (code = dm_error_$delete_pending_transaction
385                                         | code = dm_error_$no_delete_dir_transaction)
386                                    then directory_contents_code = dm_error_$no_delete_dir_transaction;
387                                    else directory_contents_code = error_table_$action_not_performed;
388                                    if delete_options.question
389                                    then if code = dm_error_$delete_pending_transaction
390                                         then call com_err_ (code, caller, " ^a>^a", pname, name);
391                                         else do;
392                                                   if etype = "00"b
393                                                   then operation = "unlink";
394                                                   else operation = "delete";
395                                                   call com_err_ (code, caller, "Unable to ^a ^a>^a", operation, pname,
396                                                        name);
397                                              end;
398                               end;
399 endloop:
400                     end;
401                     code = directory_contents_code;
402                     if code = 0
403                     then go to delete_directory;            /* try again now that contents are deleted */
404                end;
405           else if code = error_table_$copy_sw_on | code = error_table_$safety_sw_on
406           then do;
407                     string (dl_handler_options) = ""b;
408                     dl_handler_options.no_question = ^delete_options.question | delete_options.force;
409                     dl_handler_options.raw = delete_options.raw;
410                     dl_handler_options.library = delete_options.library;
411 
412                     if delete_options.question | delete_options.force
413                                                             /* either dl handler will ask, or it is licensed to fix things without asking */
414                     then call dl_handler_$switches (caller, dname, ename, string (dl_handler_options), code);
415                     else return;
416                     if code = 0
417                     then go to delete_directory;
418                end;
419 
420           else if code = error_table_$master_dir
421           then do;                                          /* must call mdc to delete this */
422                     call mdc_$delete_dir (dname, ename, code);
423                     if code ^= 0
424                     then if code = error_table_$fulldir
425                          then go to delete_contents;
426                end;
427 
428           return;
429 
430 
431 
432 
433 
434 
435 ptr:
436      entry (segptr, a_switches, caller, code);
437 
438 
439 /* The ptr entry is similar to the path entry, except that the caller already has a ptr to the
440    segment, so we might as well save the initiate call.  You can only have a ptr to a segment (not
441    a link, directory, or MSF). */
442 
443 
444 
445 
446           if segptr = null
447           then do;
448                     code = error_table_$invalidsegno;
449                     return;
450                end;
451 
452           code = 0;
453           segp = segptr;
454           path_entry = "0"b;
455           type = 1;
456 
457           call check_switches (2);
458           if ^delete_options.segment
459           then go to is_segment;
460           go to delete_segment;
461 
462 
463 
464 
465 
466 
467 is_link:
468           code = error_table_$not_a_branch;
469           return;
470 
471 is_segment:
472           code = error_table_$nondirseg;
473           return;
474 
475 is_directory:
476           code = error_table_$dirseg;
477           return;
478 %page;
479 check_switches:                                             /* Need to check whether old style call where switches were */
480      proc (switch_arg);                                     /* declared bit (6) */
481 
482           dcl     switch_arg                    fixed bin;
483           dcl     (size, type)                  fixed bin;
484           dcl     arg_ptr                       ptr,
485                   arg                           bit (6) based (arg_ptr);
486           dcl     cu_$arg_list_ptr              entry returns (ptr);
487           dcl     cu_$arg_ptr                   entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
488           dcl     decode_descriptor_            entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin,
489                                                 fixed bin);
490 
491           call decode_descriptor_ (cu_$arg_list_ptr (), switch_arg, type, ("0"b), (0), size, (0));
492 
493 /**** * THIS DEPENDS ON THE FACT THE A CHAR (*) IN THE ARG LIST
494       CAUSES ALL ARGUMENTS TO HAVE DESCRIPTORS! */
495           if type = bit_dtype & size = 36
496           then /* bit (36) */
497                string (delete_options) = a_switches;
498           else do;
499                     call cu_$arg_ptr (switch_arg, arg_ptr, (0), (0));
500                     substr (string (delete_options), 1, 6) = arg;
501                     substr (string (delete_options), 6) = ""b;
502                end;
503 
504           return;
505      end check_switches;
506 
507 
508      end;