1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31 delete:
32 dl:
33 procedure options (variable);
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
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
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 ) 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;
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;
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;
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
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 = ""
354
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
438 if ^query_sw
439 then do;
440 call dl_handler_$dirdelete (myname, dn, en, code);
441
442 if code ^= 0
443 then go to NEXT_ARG;
444 end;
445 end;
446 end;
447
448 else do;
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;
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;
487 if ^modify (dn, starname)
488 then go to NEXT_ARG;
489 if long_sw & ^query_each_sw
490 then do;
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
506 if code ^= 0
507 then go to NEXT_ARG;
508 end;
509
510
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;
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;
650 delete_one:
651 proc;
652
653
654
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;
708 modify:
709 proc (a_dn, a_en) returns (bit (1));
710
711
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);
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
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;