1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1988                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1983 *
  6         *                                                         *
  7         *********************************************************** */
  8 
  9 
 10 
 11 /****^  HISTORY COMMENTS:
 12   1) change(86-07-17,Houck), approve(86-07-17,MCR7487), audit(86-08-14,Wong),
 13      install(86-09-04,MR12.0-1148):
 14      Changed the query_each_sw and -query_all_sw switches so that the
 15      -query_each and -query_all arguments would be processed as per Multics
 16      argument processing conventions.
 17   2) change(88-07-06,TLNguyen), approve(88-07-06,MCR7922),
 18      audit(88-07-08,Parisek), install(88-07-12,MR12.2-1055):
 19      Change the delete command to use error_table_$bad_file_name to report an
 20      error when a null characters string is specified in place of path
 21      argument.
 22   3) change(89-01-16,TLNguyen), approve(89-01-27,MCR8047),
 23      audit(89-02-06,Parisek), install(89-02-27,MR12.3-1015):
 24      Issue an extra query to protect directories whose safety switches are
 25      set and a starname is specified in place of a directory path.
 26                                                    END HISTORY COMMENTS */
 27 
 28 
 29 /* format: style2,idind30,indcomtxt */
 30 
 31 delete:
 32 dl:
 33      procedure options (variable);
 34 
 35 /**** Implements these commands:
 36 
 37       delete file_paths {-control_args}
 38 
 39       l_delete file_paths {-control_args}
 40 
 41       delete_dir directory_paths {-control_args}
 42 
 43       unlink link_paths {-control_args}
 44 
 45       and the obsolete delete_force command equivalent to "delete -force".
 46       Rewritten 01/11/80 by S. Herbst */
 47 /* Modified: 30 June 1980 by G. Palter to fix bug where error messages are meaningless */
 48 /* Fixed bugs and added -absolute_pathname and -entryname 07/19/82 S. Herbst */
 49 /* Fixed nomatch error message 11/08/82 S. Herbst */
 50 /* Fixed "dl ** -qye -long" to print individual queries 12/13/82 S. Herbst */
 51 /* Modified 2/20/83 Jay Pattin for object_type_ */
 52 /* Modified 6/9/83 Jay Pattin. Added l_delete, Changed to use delete_options, added -no_force */
 53 /* 830927 BIM for object_type_ --> fs_util_ */
 54 /* Fixed dl -chase to delete segments 06/25/84 S. Herbst */
 55 /* Modified 12/03/84 by Matthew Pierret: to print helpful message if the
 56    directory could not be deleted because it contained a protected
 57    data management file and a transaction is in progress (code
 58    returned from delete_ is error_table_$no_delete_dir_transaction).
 59    This means that the actual file deletion will be done when the
 60    transaction completes. */
 61 /* Modified 850206 MSharpe to replace -fcnt with -inase/inaee */
 62 
 63 /* format: off */
 64 %page; %include delete_options;
 65 %page; %include branch_status;
 66 %page; %include star_structures;
 67 %page; %include suffix_info;
 68 %page; %include copy_flags;
 69 %page;
 70 
 71 /* format: on */
 72           dcl     1 si                          aligned like suffix_info;
 73 
 74           dcl     1 query_array                 (query_bound) based (query_ptr),
 75                     2 query_dn                  char (168),
 76                     2 query_en                  char (32);
 77 
 78           dcl     (old_query_ptr, query_ptr)    ptr;
 79           dcl     (new_query_bound, old_query_bound, query_bound, query_count)
 80                                                 fixed bin;
 81 
 82 
 83           dcl     1 entries                     (ecount) based (entries_ptr),
 84                     2 type                      bit (2) unaligned,
 85                     2 nnames                    bit (16) unaligned,
 86                     2 nindex                    bit (18) unaligned;
 87 
 88           dcl     names                         (99 /* arbitrary */) char (32) aligned based (names_ptr);
 89 
 90           dcl     arg                           char (arg_len) based (arg_ptr);
 91           dcl     fs_util_type                  char (32);
 92           dcl     (dn, print_path, target_dn)   char (168);
 93           dcl     (en, myname, starname, target_en, thing, things, what)
 94                                                 char (32);
 95 
 96           dcl     area                          area based (area_ptr);
 97 
 98           dcl     (absp_sw, brief_sw, chase_sw, chased, force_sw, force_no_type_sw, long_sw, query_sw, query_all_sw,
 99                   query_each_sw, safety_sw, same_dir_sw, saved_force_sw, some_args, some_matches, yes_sw)
100                                                 bit (1);
101 
102           dcl     (area_ptr, arg_ptr, entries_ptr, names_ptr)
103                                                 ptr;
104           dcl     QUERY_LIMIT fixed bin int static options (constant) init (20);
105 
106           dcl     (
107                   NO_CHASE                      init (0),
108                   CHASE                         init (1)
109                   )                             fixed bin (1) int static options (constant);
110           dcl     (
111                   NO_STAR_NAME                  init (0),
112                   STAR_NAME                     init (1),
113                   STAR_STAR_NAME                init (2)
114                   )                             fixed bin (35) int static options (constant);
115 
116           dcl     entry_type                    fixed bin (2);
117           dcl     (arg_count, arg_len, ecount, i, j)
118                                                 fixed bin;
119           dcl     bit_count                     fixed bin (24);
120           dcl     (code, star_code)             fixed bin (35);
121 
122           dcl     error_table_$action_not_performed
123                                                 fixed bin (35) ext;
124           dcl     error_table_$bad_file_name    fixed bin (35) ext;
125           dcl     error_table_$badopt           fixed bin (35) ext;
126           dcl     error_table_$incorrect_access fixed bin (35) ext;
127           dcl     dm_error_$no_delete_dir_transaction
128                                                 fixed bin (35) ext;
129           dcl     error_table_$no_info          fixed bin (35) ext;
130           dcl     error_table_$no_s_permission  fixed bin (35) ext;
131           dcl     error_table_$noentry          fixed bin (35) ext;
132           dcl     error_table_$nomatch          fixed bin (35) ext;
133           dcl     error_table_$root             fixed bin (35) ext;
134 
135           dcl     (
136                   com_err_,
137                   com_err_$suppress_name
138                   )                             entry options (variable);
139           dcl     check_star_name_$entry        entry (char (*), fixed bin (35));
140           dcl     command_query_$yes_no         entry options (variable);
141           dcl     cu_$arg_count                 entry (fixed bin, fixed bin (35));
142           dcl     cu_$arg_ptr                   entry (fixed bin, ptr, fixed bin, fixed bin (35));
143           dcl     delete_$path                  entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35));
144           dcl     dl_handler_$dblstar           entry (char (*), char (*), char (*), fixed bin (35));
145           dcl     dl_handler_$dirdelete         entry (char (*), char (*), char (*), fixed bin (35));
146           dcl     expand_pathname_              entry (char (*), char (*), char (*), fixed bin (35));
147           dcl     get_system_free_area_         entry returns (ptr);
148           dcl     get_wdir_                     entry returns (char (168));
149           dcl     hcs_$get_link_target          entry (char (*), char (*), char (*), char (*), fixed bin (35));
150           dcl     hcs_$get_safety_sw            entry (char (*), char (*), bit (1), fixed bin (35));
151           dcl     hcs_$star_                    entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr,
152                                                 fixed bin (35));
153           dcl     hcs_$status_long              entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
154           dcl     hcs_$status_minf              entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
155                                                 fixed bin (35));
156           dcl     ioa_                          entry options (variable);
157           dcl     installation_tools_$delentry_file
158                                                 entry (char (*), char (*), fixed bin (35));
159           dcl     fs_util_$get_type             entry (character (*), character (*), character (*), fixed binary (35));
160           dcl     fs_util_$suffix_info_for_type entry (character (*), pointer, fixed binary (35));
161           dcl     pathname_                     entry (char (*), char (*)) returns (char (168));
162 
163           dcl     (addr, codeptr, fixed, index, null, string, substr, unspec)
164                                                 builtin;
165 
166           dcl     (cleanup, linkage_error)      condition;  /*^L                                                        */
167           myname = "delete";
168           thing = "file";
169           things = "files";
170           string (delete_options) = ""b;
171           delete_options.question, delete_options.segment = "1"b;
172           force_sw = "0"b;
173           go to COMMON;
174 
175 l_delete:
176 ldl:
177      entry;
178 
179           myname = "l_delete";
180           thing = "file";
181           things = "files";
182           string (delete_options) = ""b;
183           force_sw = "1"b;
184           delete_options.question, delete_options.force, delete_options.segment, delete_options.library,
185                delete_options.raw = "1"b;
186           go to COMMON;
187 
188 delete_force:
189 deleteforce:
190 df:
191      entry;                                                 /* OBSOLETE */
192 
193           myname = "delete_force";
194           thing = "file";
195           things = "files";
196           string (delete_options) = ""b;
197           force_sw = "1"b;
198           delete_options.force, delete_options.segment = "1"b;
199           go to COMMON;
200 
201 delete_dir:
202 dd:
203      entry options (variable);
204 
205           myname = "delete_dir";
206           thing = "directory";
207           things = "directories";
208           string (delete_options) = ""b;
209           delete_options.force, delete_options.question, delete_options.directory = "1"b;
210           force_sw = "0"b;
211           go to COMMON;
212 
213 unlink:
214 ul:
215      entry options (variable);
216 
217           myname = "unlink";
218           thing = "link";
219           things = "links";
220           string (delete_options) = ""b;
221           delete_options.link = "1"b;
222           force_sw = "0"b;
223 
224 
225 COMMON:
226           call cu_$arg_count (arg_count, code);
227           if code ^= 0
228           then do;
229                     call com_err_ (code, myname);
230                     return;
231                end;
232 
233           si.version = SUFFIX_INFO_VERSION_1;
234           entries_ptr, names_ptr, query_ptr = null;
235 
236           absp_sw, brief_sw, chase_sw, force_no_type_sw, long_sw, query_sw, query_all_sw, query_each_sw, some_args = "0"b;
237           if delete_options.library
238           then force_no_type_sw = "1"b;
239 
240           do i = 1 to arg_count;
241 
242                call cu_$arg_ptr (i, arg_ptr, arg_len, code);
243                if code ^= 0 then do;
244                     call com_err_ (code, myname);
245                     return;
246                end;
247 
248                if index (arg, "-") ^= 1
249                then some_args = "1"b;
250 
251                else if arg = "-absolute_pathname" | arg = "-absp"
252                then absp_sw = "1"b;
253                else if arg = "-brief" | arg = "-bf"
254                then brief_sw = "1"b;
255                else if arg = "-chase" & myname = "delete"
256                then chase_sw = "1"b;
257                else if arg = "-no_chase" & myname = "delete"
258                then chase_sw = "0"b;
259                else if arg = "-entryname" | arg = "-etnm"
260                then absp_sw = "0"b;
261                else if arg = "-force" | arg = "-fc"
262                then delete_options.force, force_sw = "1"b;
263                else if arg = "-no_force" | arg = "-nfc"
264                then delete_options.force, force_sw = "0"b;
265                else if arg = "-interpret_as_standard_entry" | arg = "-inase"
266                then force_no_type_sw, delete_options.raw = "1"b;
267                else if arg = "-interpret_as_extended_entry" | arg = "-inaee"
268                then force_no_type_sw, delete_options.raw = "0"b;
269                else if arg = "-long" | arg = "-lg"
270                then long_sw = "1"b;
271                else if arg = "-name" | arg = "-nm"
272                then do;
273                          i = i + 1;
274                          if i > arg_count
275                          then do;
276                                    call com_err_ (0, myname, "No value specified for -name");
277                                    return;
278                               end;
279                          some_args = "1"b;
280                     end;
281                else if arg = "-query_each" | arg = "-qye"
282                then do;
283 
284                          query_each_sw, query_sw = "1"b;
285                          query_all_sw = "0"b;
286                     end;
287                else if arg = "-query_all" | arg = "-qya"
288                then do;
289 
290                          query_all_sw, query_sw = "1"b;
291                          query_each_sw = "0"b;
292                     end;
293 
294 
295                else do;
296                          call com_err_ (error_table_$badopt, myname, "^a", arg);
297                          return;
298                     end;
299           end;
300 
301           if ^some_args
302           then do;
303                     call com_err_$suppress_name (0, myname, "Usage:  ^a ^a_paths {-control_args}", myname, thing);
304                     return;
305                end;
306 
307           if delete_options.library
308           then do;
309                     on linkage_error
310                          begin;                             /* check for installation_tools_ access */
311                               call com_err_ (0, myname, "This command requires access to the installation_tools_ gate.");
312                               goto MAIN_RETURN;
313                          end;
314 
315                     arg_ptr = codeptr (installation_tools_$delentry_file);
316                                                             /* provoke linkage error */
317                     revert linkage_error;
318                end;
319 
320           on cleanup
321                begin;
322                     call star_cleanup;
323                     if query_ptr ^= null
324                     then free query_array in (area);
325                end;
326 
327           if query_all_sw
328           then do;
329                     query_bound = QUERY_LIMIT;
330                     area_ptr = get_system_free_area_ ();
331 
332                     allocate query_array in (area) set (query_ptr);
333                     query_count = 0;
334                end;
335           else area_ptr = null;
336 
337           do i = 1 to arg_count;
338 
339                call cu_$arg_ptr (i, arg_ptr, arg_len, code);
340 
341                if index (arg, "-") = 1
342                then if arg = "-name" | arg = "-nm"
343                     then do;
344                               i = i + 1;
345                               call cu_$arg_ptr (i, arg_ptr, arg_len, code);
346 
347                               dn = get_wdir_ ();
348                               en, starname = arg;
349                               go to NO_STARS;
350                          end;
351                     else go to NEXT_ARG;
352 
353                if arg = ""                         /* a null string such as "", " ", "    "  is specified
354                                                       in place of path argument */
355                then do;
356                          call com_err_ (error_table_$bad_file_name, myname, """""");
357                          go to NEXT_ARG;
358                     end;
359 
360                call expand_pathname_ (arg, dn, starname, code);
361                if code ^= 0
362                then do;
363                          call com_err_ (code, myname, "^a", arg);
364                          go to NEXT_ARG;
365                     end;
366 
367                call check_star_name_$entry (starname, star_code);
368                if star_code = NO_STAR_NAME
369                then do;
370 
371                          en = starname;
372 
373 NO_STARS:
374                          chased = "0"b;
375 
376 STATUS:
377                          call hcs_$status_minf (dn, en, NO_CHASE, entry_type, bit_count, code);
378                          if code ^= 0
379                          then do;
380 PATH_ERROR:
381                                    if ^brief_sw | (code ^= error_table_$noentry & code ^= error_table_$nomatch)
382                                    then call com_err_ (code, myname, "^a", pathname_ (dn, en));
383                                    go to NEXT_ARG;
384                               end;
385 
386                          if ^force_no_type_sw & entry_type ^= star_LINK
387                          then do;
388                                    call fs_util_$get_type (dn, en, fs_util_type, code);
389                                    if code = 0 & fs_util_type ^= FS_OBJECT_TYPE_DIRECTORY
390                                    then do;
391                                              entry_type = star_SEGMENT;
392                                              if ^delete_options.segment
393                                              then do;
394                                                        call fs_util_$suffix_info_for_type (fs_util_type, addr (si), (0));
395                                                        call com_err_ (code, myname, "^a is a ^a. Use delete.",
396                                                             pathname_ (dn, en), si.type_name);
397                                                        goto NEXT_ARG;
398                                                   end;
399                                         end;
400                               end;
401 
402                          if entry_type = star_LINK
403                          then do;
404                                    if ^delete_options.link
405                                    then do;
406                                              if chase_sw & ^chased
407                                              then do;
408                                                        call hcs_$get_link_target (dn, en, target_dn, target_en, code);
409                                                        if code ^= 0
410                                                        then do;
411                                                                  call com_err_ (code, myname, "Unable to chase link ^a",
412                                                                       pathname_ (dn, en));
413                                                                  go to NEXT_ARG;
414                                                             end;
415                                                        dn = target_dn;
416                                                        en = target_en;
417                                                        chased = "1"b;
418                                                        go to STATUS;
419                                                   end;
420                                              call com_err_ (0, myname, "^a is a link. Use unlink.", pathname_ (dn, en));
421                                              go to NEXT_ARG;
422                                         end;
423                               end;
424 
425                          else if entry_type = star_DIRECTORY & bit_count = 0
426                          then do;
427                                    if ^delete_options.directory
428                                    then do;
429                                              call com_err_ (0, myname, "^a is a directory. Use delete_dir.",
430                                                   pathname_ (dn, en));
431                                              go to NEXT_ARG;
432                                         end;
433                                    if ^force_sw
434                                    then do;
435                                              if ^modify (dn, en)
436                                              then go to NEXT_ARG;
437                                                             /* ^modify prints err msg */
438                                              if ^query_sw
439                                              then do;
440                                                        call dl_handler_$dirdelete (myname, dn, en, code);
441                                                             /* Do you want to delete the directory dn>en? */
442                                                        if code ^= 0
443                                                        then go to NEXT_ARG;
444                                                   end;
445                                         end;
446                               end;
447 
448                          else do;                           /* segment or MSF */
449                                    if ^delete_options.segment
450                                    then do;
451                                              call com_err_ (0, myname,
452                                                   "^a is a ^[multisegment file^;segment^]. Use delete.",
453                                                   pathname_ (dn, en), entry_type = star_DIRECTORY);
454                                              go to NEXT_ARG;
455                                         end;
456                               end;
457 
458                          if absp_sw
459                          then print_path = pathname_ (dn, en);
460                          else print_path = en;
461 
462                          call delete_one;
463 
464                     end;
465 
466                else if star_code = STAR_NAME | star_code = STAR_STAR_NAME
467                then do;                                     /* star convention */
468 
469                          if area_ptr = null
470                          then area_ptr = get_system_free_area_ ();
471                          entries_ptr, names_ptr = null;
472 
473                          if delete_options.link | chase_sw
474                          then entry_type = star_ALL_ENTRIES;
475                          else entry_type = star_BRANCHES_ONLY;
476 
477                          call hcs_$star_ (dn, starname, entry_type, area_ptr, ecount, entries_ptr, names_ptr, code);
478                          if code ^= 0
479                          then do;
480                                    if ^brief_sw | code ^= error_table_$nomatch
481                                    then call com_err_ (code, myname, "^a", pathname_ (dn, starname));
482                                    go to NEXT_ARG;
483                               end;
484 
485                          if (delete_options.directory | star_code = STAR_STAR_NAME) & ^force_sw
486                          then do;                           /* dd, dl **, or ul **  */
487                                    if ^modify (dn, starname)
488                                    then go to NEXT_ARG;
489                                    if long_sw & ^query_each_sw
490                                    then do;                 /* combine the ** or dd query with -long query */
491                                              long_sw = "0"b;
492                                              query_all_sw, query_sw = "1"b;
493                                              if query_ptr = null
494                                              then do;
495                                                        query_bound = QUERY_LIMIT;
496                                                        area_ptr = get_system_free_area_ ();
497 
498                                                        allocate query_array in (area) set (query_ptr);
499                                                        query_count = 0;
500                                                   end;
501                                         end;
502                                    if ^query_sw
503                                    then do;
504                                              call dl_handler_$dblstar (myname, dn, starname, code);
505                                                             /* Do you want to delete/unlink 'starname' in dn? */
506                                              if code ^= 0
507                                              then go to NEXT_ARG;
508                                         end;
509 
510                                                             /* query again for protected dirs because a starname is specified. */
511                                    if delete_options.directory & (star_code = STAR_NAME | star_code = STAR_STAR_NAME)
512                                    then delete_options.force = "0"b;
513 
514                               end;
515 
516                          some_matches = "0"b;
517 
518                          do j = 1 to ecount;
519 
520                               en = names (fixed (entries.nindex (j), 17));
521 
522                               if ^force_no_type_sw & entries.type (j) ^= link_type
523                               then do;
524                                         call fs_util_$get_type (dn, en, fs_util_type, code);
525                                         if code = 0 & fs_util_type ^= FS_OBJECT_TYPE_DIRECTORY
526                                         then entries.type (j) = segment_type;
527                                    end;
528 
529                               if entries.type (j) = link_type
530                               then do;
531                                         if chase_sw
532                                         then do;
533                                                   some_matches = "1"b;
534                                                   call hcs_$get_link_target (dn, en, target_dn, target_en, code);
535                                                   if code ^= 0
536                                                   then do;
537                                                             call com_err_ (code, myname, "Unable to chase link ^a",
538                                                                  pathname_ (dn, en));
539                                                             go to NEXT_MATCH;
540                                                        end;
541                                                   dn = target_dn;
542                                                   en = target_en;
543                                                   call hcs_$status_minf (dn, en, NO_CHASE, entry_type, bit_count, code);
544                                                   if entry_type = star_LINK
545                                                        | (entry_type = star_DIRECTORY & bit_count = 0)
546                                                   then go to NEXT_MATCH;
547                                              end;
548                                         else if ^delete_options.link
549                                         then go to NEXT_MATCH;
550                                    end;
551                               else if entries.type (j) = segment_type
552                               then do;
553 FILE:
554                                         if ^delete_options.segment
555                                         then go to NEXT_MATCH;
556                                    end;
557                               else do;                      /* directory or MSF */
558                                         call hcs_$status_minf (dn, en, NO_CHASE, entry_type, bit_count, code);
559                                         if bit_count ^= 0
560                                         then go to FILE;
561                                         if ^delete_options.directory
562                                         then go to NEXT_MATCH;
563                                    end;
564 
565                               some_matches = "1"b;
566 
567                               if absp_sw
568                               then print_path = pathname_ (dn, en);
569                               else print_path = en;
570 
571                               call delete_one;
572 
573                               if code = error_table_$incorrect_access | code = error_table_$no_info
574                               then do;
575                                         call star_cleanup;
576                                         go to NEXT_ARG;
577                                    end;
578 NEXT_MATCH:
579                          end;
580 
581                          call star_cleanup;
582 
583                          if ^some_matches
584                          then do;
585                                    if ^brief_sw
586                                    then call com_err_ (0, myname, "No ^a selected by starname.  ^a", things,
587                                              pathname_ (dn, starname));
588                                    go to NEXT_ARG;
589                               end;
590                     end;
591                else call com_err_ (star_code, myname, "^a", pathname_ (dn, starname));
592 
593 NEXT_ARG:
594           end;
595 
596           if query_all_sw & query_count > 0
597           then do;
598 
599                     if myname = "delete" | myname = "delete_force"
600                     then what = "Files";
601                     else if myname = "delete_dir"
602                     then what = "Directories";
603                     else what = "Links";
604 
605                     same_dir_sw = "1"b;
606                     do i = 2 to query_count;
607                          if query_dn (i) ^= query_dn (1)
608                          then same_dir_sw = "0"b;
609                     end;
610 
611                     call ioa_ ("^a to be deleted^[ in ^a^]:", what, same_dir_sw, query_dn (1));
612 
613                     do i = 1 to query_count;
614                          if same_dir_sw
615                          then call ioa_ ("^3x^a", query_en (i));
616                          else call ioa_ ("^3x^a", pathname_ (query_dn (i), query_en (i)));
617                     end;
618 
619                     call command_query_$yes_no (yes_sw, 0, myname, "", "Delete?");
620 
621                     if yes_sw
622                     then do i = 1 to query_count;
623                               call delete_$path (query_dn (i), query_en (i), string (delete_options), myname, code);
624                               if code = 0 | code = error_table_$action_not_performed
625                               then do;
626                                         if long_sw
627                                         then if absp_sw
628                                              then call ioa_ ("Deleted ^a", pathname_ (query_dn (i), query_en (i)));
629                                              else call ioa_ ("Deleted ^a", query_en (i));
630                                    end;
631                               else if code = dm_error_$no_delete_dir_transaction
632                               then call com_err_ (code, myname, "^/The contents of ^a ^a^/^a^/^a",
633                                         pathname_ (query_dn (i), query_en (i)), "which do not need to wait until the",
634                                         "transaction commits have been deleted.  The directory itself can be",
635                                         "deleted after the transaction ends.");
636 
637                               else call com_err_ (code, myname, "^a", pathname_ (query_dn (i), query_en (i)));
638 
639                          end;
640                end;
641 
642           if query_all_sw
643           then do;
644                     free query_array in (area);
645                     query_ptr = null;
646                end;
647 
648 MAIN_RETURN:
649           return;                                           /*^L                                                        */
650 delete_one:
651      proc;
652 
653 /* This internal procedure remembers the pathname dn>en if -query_all,
654    else implements -query_each and -long and deletes the single entry dn>en. */
655 
656           code = 0;
657 
658           if query_all_sw
659           then do;
660                     query_count = query_count + 1;
661                     if query_count > query_bound
662                     then call grow_query_array;
663                     query_dn (query_count) = dn;
664                     query_en (query_count) = en;
665                     return;
666                end;
667 
668           saved_force_sw = delete_options.force;
669 
670           if query_each_sw
671           then do;
672                     safety_sw = "0"b;
673                     if ^delete_options.link
674                     then do;
675                               call hcs_$get_safety_sw (dn, en, safety_sw, 0);
676                               call hcs_$status_long (dn, en, NO_CHASE, addr (branch_status), null, 0);
677                          end;
678 
679                     call command_query_$yes_no (yes_sw, 0, myname, "",
680                          "^[Unlink^;Delete^] ^a ?^[^[ (safety switch is on)^]^[ (copy switch is on)^]^]",
681                          delete_options.link, print_path, ^delete_options.link, safety_sw, branch_status.copy_switch);
682 
683                     if ^yes_sw
684                     then return;
685 
686                     if safety_sw | branch_status.copy_switch
687                     then delete_options.force = "1"b;
688                end;
689 
690           call delete_$path (dn, en, string (delete_options), myname, code);
691           if code ^= 0
692           then do;
693                     if code = dm_error_$no_delete_dir_transaction
694                     then call com_err_ (code, myname, "^/The contents of ^a ^a^/^a^/^a", pathname_ (dn, en),
695                               "which do not need to wait until the",
696                               "transaction commits have been deleted.  The directory itself can be",
697                               "deleted after the transaction ends.");
698                     else if code ^= error_table_$action_not_performed
699                     then call com_err_ (code, myname, "^a", pathname_ (dn, en));
700                end;
701 
702           else if long_sw & ^query_each_sw
703           then call ioa_ ("Deleted ^a ^a", thing, print_path);
704 
705           delete_options.force = saved_force_sw;
706 
707      end delete_one;                                        /*^L                                                        */
708 modify:
709      proc (a_dn, a_en) returns (bit (1));
710 
711 /* This internal procedure returns "1"b if the user has modify on the directory a_dn */
712 
713           dcl     (a_dn, a_en)                  char (*);
714 
715           call hcs_$status_long (a_dn, "", CHASE, addr (branch_status), null, code);
716           if code = error_table_$root
717           then return ("1"b);                               /* ignore and let hardcore catch moderr */
718           if code ^= 0 & code ^= error_table_$no_s_permission
719           then do;
720                     call com_err_ (code, myname, "Unable to check access to ^a", a_dn);
721                     return ("0"b);
722                end;
723           if substr (branch_status.mode, 4, 1)
724           then return ("1"b);
725           call com_err_ (error_table_$incorrect_access, myname, "^a", pathname_ (a_dn, a_en));
726           return ("0"b);
727 
728      end modify;
729 
730 
731 
732 grow_query_array:
733      proc;
734 
735 /* This internal procedure doubles the size of query_array */
736 
737           old_query_ptr = query_ptr;
738           old_query_bound = query_bound;
739           query_bound, new_query_bound = query_bound * 2;
740           allocate query_array in (area) set (query_ptr);
741           query_bound = old_query_bound;
742           unspec (query_ptr -> query_array) = unspec (old_query_ptr -> query_array);
743           free old_query_ptr -> query_array in (area);
744           query_bound = new_query_bound;
745 
746      end grow_query_array;
747 
748 
749 
750 star_cleanup:
751      proc;
752 
753           if entries_ptr ^= null
754           then free entries in (area);
755           if names_ptr ^= null
756           then free names in (area);
757           entries_ptr, names_ptr = null;
758 
759      end star_cleanup;
760 
761 
762      end delete;