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
32
33
34
35
36
37
38
39
40
41
42
43 entries: procedure () options (variable);
44
45
46
47
48
49 ^L
50
51
52 dcl active_function bit (1) aligned;
53 dcl archive_bc fixed binary (24);
54 dcl archive_ptr pointer;
55 dcl arg_count fixed binary;
56 dcl argument character (argument_lth) based (argument_ptr);
57 dcl argument_lth fixed binary (21);
58 dcl argument_ptr pointer;
59 dcl c_ptr pointer;
60 dcl char_168 character (168);
61 dcl chars_left fixed bin;
62 dcl chase bit (1);
63 dcl code fixed binary (35);
64 dcl command_name character (32) varying;
65 dcl component character (32);
66 dcl dir character (168) unaligned;
67 dcl dir_dname character (168) unaligned;
68 dcl dir_ename character (32) unaligned;
69 dcl ename character (32);
70 dcl entry_index fixed bin;
71 dcl entry_type_count fixed bin;
72 dcl entry_type_no fixed bin;
73 dcl entry_type_ptr pointer;
74 dcl error entry () options (variable) variable;
75 dcl first_arg fixed binary;
76 dcl found_something bit (1) aligned;
77 dcl found_uid bit (1) aligned;
78 dcl fs_type character (32);
79 dcl get_argument entry (fixed binary, pointer, fixed binary (21), fixed binary (35)) variable;
80 dcl got_key bit (1) aligned;
81 dcl idx fixed binary;
82 dcl inhibit_error bit (1) aligned;
83 dcl jdx fixed binary;
84 dcl kdx fixed binary;
85 dcl kname_index fixed binary;
86 dcl line_length fixed bin;
87 dcl link_array_ptr ptr;
88 dcl n_link_names fixed bin (21);
89 dcl n_uids fixed bin (21);
90 dcl old_ename character (32);
91 dcl return_absolute_pathnames bit (1) aligned;
92 dcl return_names bit (1) aligned;
93 dcl return_value character (return_value_lth) varying based (return_value_ptr);
94 dcl return_value_lth fixed binary (21);
95 dcl return_value_ptr pointer;
96 dcl seg_ptr pointer;
97 dcl select_entry_type bit (1) aligned;
98 dcl space character (2) varying;
99 dcl starname_count fixed binary;
100 dcl starnames (20) character (168);
101 dcl system_area area based (system_area_ptr);
102 dcl system_area_ptr ptr;
103 dcl table_index fixed binary;
104 dcl 1 type_info aligned like suffix_info;
105 dcl uid_array_ptr ptr;
106 dcl unique_id bit (36) aligned;
107 ^L
108
109
110 dcl link_array (sys_info$max_seg_size / 8) char (32) aligned based (link_array_ptr);
111 dcl uid_array (sys_info$max_seg_size) bit (36) aligned based (uid_array_ptr);
112 dcl 1 entry_type aligned based (entry_type_ptr),
113 2 count fixed bin,
114 2 suffix (entry_type_count refer (entry_type.count)) char (32) unaligned;
115 ^L
116
117
118 dcl iox_$user_output ptr ext;
119 dcl active_fnc_err_ entry options (variable);
120 dcl archive_$get_component entry (ptr, fixed bin (24), char (*), ptr, fixed bin (24), fixed bin (35));
121 dcl archive_$next_component entry (ptr, fixed bin (24), ptr, fixed bin (24), char (*), fixed bin (35));
122 dcl com_err_ entry options (variable);
123 dcl check_star_name_$entry entry (char (*), fixed bin (35));
124 dcl cu_$af_arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
125 dcl cu_$af_return_arg entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
126 dcl cu_$arg_count entry (fixed binary);
127 dcl cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
128 dcl error_table_$archive_fmt_err fixed bin (35) ext static;
129 dcl error_table_$archive_pathname fixed bin (35) ext static;
130 dcl error_table_$bad_arg fixed bin (35) ext static;
131 dcl error_table_$badopt fixed binary (35) external;
132 dcl error_table_$no_s_permission fixed binary (35) external;
133 dcl error_table_$noarg fixed binary (35) external;
134 dcl error_table_$no_dir fixed bin (35) ext static;
135 dcl error_table_$noentry fixed bin (35) ext static;
136 dcl error_table_$nomatch fixed binary (35) external;
137 dcl error_table_$not_act_fnc fixed binary (35) external;
138 dcl error_table_$not_archive fixed bin (35) ext static;
139 dcl error_table_$too_many_args fixed bin (35) ext static;
140 dcl expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35));
141 dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
142 dcl expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35));
143 dcl fs_util_$get_type entry (char (*), char (*), char (*), fixed bin (35));
144 dcl fs_util_$suffix_info_for_type entry (char (*), ptr, fixed bin (35));
145 dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
146 dcl get_system_free_area_ entry () returns (pointer);
147 dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35));
148 dcl hcs_$get_uid_file entry (char (*), char (*), bit (36) aligned, fixed bin (35));
149 dcl hcs_$star_dir_list_ entry (char (*), char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35));
150 dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
151 dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
152 dcl ioa_ entry () options (variable);
153 dcl ioa_$nnl entry () options (variable);
154 dcl match_star_name_ entry (char (*), char (*), fixed bin (35));
155 dcl object_lib_$initiate entry (char(*), char(*), char(*), bit(1), ptr, fixed bin(24), bit(1), fixed bin(35));
156 dcl pathname_ entry (char(*), char(*)) returns(char(168));
157 dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35));
158 dcl requote_string_ entry (character (*)) returns (character (*));
159 dcl sys_info$max_seg_size fixed bin (35) ext static;
160 dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
161 ^L
162
163
164 dcl cleanup condition;
165
166
167
168 dcl (addr, after, before, binary, divide, hbound, index, length, max, null, rtrim, substr) builtin;
169 ^L
170
171
172
173
174
175
176
177
178
179
180
181
182
183 dcl MSF fixed bin static internal options (constant) init (3);
184
185 dcl SEGMENTS_EI static internal options (constant) init (1);
186 dcl DIRECTORIES_EI static internal options (constant) init (2);
187 dcl MSFS_EI static internal options (constant) init (3);
188 dcl LINKS_EI static internal options (constant) init (4);
189 dcl ENTRIES_EI static internal options (constant) init (5);
190 dcl BRANCHES_EI static internal options (constant) init (6);
191 dcl FILES_EI static internal options (constant) init (7);
192 dcl ZERO_SEGMENTS_EI static internal options (constant) init (8);
193 dcl MASTER_DIRECTORIES_EI static internal options (constant) init (9);
194 dcl NULL_LINKS_EI static internal options (constant) init (10);
195 dcl NONSEGMENTS_EI static internal options (constant) init (11);
196 dcl NONDIRECTORIES_EI static internal options (constant) init (12);
197 dcl NONMSFS_EI static internal options (constant) init (13);
198 dcl NONFILES_EI static internal options (constant) init (14);
199 dcl NONZERO_SEGMENTS_EI static internal options (constant) init (15);
200 dcl NONMASTER_DIRECTORIES_EI static internal options (constant) init (16);
201 dcl NONNULL_LINKS_EI static internal options (constant) init (17);
202 dcl NONZERO_FILES_EI static internal options (constant) init (18);
203 dcl NONZERO_MSFS_EI static internal options (constant) init (19);
204 dcl NONBRANCHES_EI static internal options (constant) init (20);
205 dcl NONLINKS_EI static internal options (constant) init (21);
206 dcl OBJECT_FILES_EI static internal options (constant) init (22);
207 dcl NONOBJECT_FILES_EI static internal options (constant) init (23);
208 dcl OBJECT_MSFS_EI static internal options (constant) init (24);
209 dcl NONOBJECT_MSFS_EI static internal options (constant) init (25);
210 dcl OBJECT_SEGMENTS_EI static internal options (constant) init (26);
211 dcl NONOBJECT_SEGMENTS_EI static internal options (constant) init (27);
212
213
214
215
216 dcl EXISTS_EI static internal options (constant) init (29);
217
218 dcl COMMAND_NAME (29) char (24) static internal options (constant) init (
219 "segments",
220 "directories",
221 "msfs",
222 "links",
223 "entries",
224 "branches",
225 "files",
226 "zero_segments",
227 "master_directories",
228 "null_links",
229 "nonsegments",
230 "nondirectories",
231 "nonmsfs",
232 "nonfiles",
233 "nonzero_segments",
234 "nonmaster_directories",
235 "nonnull_links",
236 "nonzero_files",
237 "nonzero_msfs",
238 "nonbranches",
239 "nonlinks",
240 "object_files",
241 "nonobject_files",
242 "object_msfs",
243 "nonobject_msfs",
244 "object_segments",
245 "nonobject_segments",
246 *,
247
248 "exists");
249
250 dcl SELECT_SW (29) fixed bin static internal options (constant) init (
251 2, 2, 2, 1, 3, 2, 2, 2, 2, 5,
252 3, 3, 3, 3, 3, 2, 5, 2, 2, 1,
253 2, 2, 2, 2, 2, 2, 2, 2, *);
254 Note
255
256
257 dcl TRUE bit (1) internal static options (constant) initial ("1"b);
258 dcl FALSE bit (1) internal static options (constant) initial ("0"b);
259 dcl KEY_NAME (47) char (24) int static options (constant) init (
260 "branch", "nonbranch",
261 "component",
262 "directory", "dir", "nondirectory", "nondir",
263 "entry",
264 "file", "nonfile",
265 "link", "nonlink",
266 "master_directory", "mdir", "nonmaster_directory", "nmdir",
267 "msf", "nonmsf",
268 "null_link", "nlink", "non_null_link", "nonnull_link", "nnlink",
269 "object_file", "obfile", "nonobject_file", "nobfile",
270 "object_msf", "obmsf", "nonobject_msf", "nobmsf",
271 "object_segment", "obseg", "nonobject_segment", "nobseg",
272 "segment", "seg", "nonsegment", "nonseg",
273 "nonzero_file", "nzfile",
274 "nonzero_msf", "nzmsf",
275 "zero_segment", "zseg", "nonzero_segment", "nzseg");
276 dcl INDEX_TAB (47) fixed bin static internal options (constant) init (
277 6, 20,
278 28,
279 2, 2, 12, 12,
280 5,
281 7, 14,
282 4, 21,
283 9, 9, 16, 16,
284 3, 13,
285 10, 10, 17, 17, 17,
286 22, 22, 23, 23,
287 24, 24, 25, 25,
288 26, 26, 27, 27,
289 1, 1, 11, 11,
290 18, 18,
291 19, 19,
292 8, 8, 15, 15);
293 dcl CHASE_OK (29) bit (1) unaligned internal static options (constant) initial (
294 "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b,
295 "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "0"b,
296 "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b);
297 dcl ROOT (29) bit (1) unaligned internal static options (constant) initial (
298 "0"b, "1"b, "0"b, "0"b, "1"b, "1"b, "0"b, "0"b, "1"b, "0"b,
299 "1"b, "0"b, "1"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b,
300 "1"b, "0"b, "1"b, "0"b, "1"b, "0"b, "1"b, "0"b, "0"b);
301 ^L
302
303
304
305
306
307
308
309
310
311
312 entry_index = ENTRIES_EI;
313 goto COMMON;
314
315 files:
316 entry () options (variable);
317
318 entry_index = FILES_EI;
319 go to COMMON;
320
321 segments:
322 segs:
323 entry () options (variable);
324
325 entry_index = SEGMENTS_EI;
326 go to COMMON;
327
328 directories:
329 dirs:
330 entry () options (variable);
331
332 entry_index = DIRECTORIES_EI;
333 go to COMMON;
334
335 links:
336 entry () options (variable);
337
338 entry_index = LINKS_EI;
339 go to COMMON;
340
341 branches:
342 entry () options (variable);
343
344 entry_index = BRANCHES_EI;
345 go to COMMON;
346
347 nonsegments:
348 nonsegs:
349 entry () options (variable);
350
351 entry_index = NONSEGMENTS_EI;
352 go to COMMON;
353
354 nondirectories:
355 nondirs:
356 entry () options (variable);
357
358 entry_index = NONDIRECTORIES_EI;
359 go to COMMON;
360
361 msfs:
362 entry options (variable);
363
364 entry_index = MSFS_EI;
365 goto COMMON;
366
367 zero_segments:
368 zsegs:
369 entry options (variable);
370
371 entry_index = ZERO_SEGMENTS_EI;
372 goto COMMON;
373
374 master_directories:
375 mdirs:
376 entry () options (variable);
377
378 entry_index = MASTER_DIRECTORIES_EI;
379 goto COMMON;
380
381 null_links:
382 nlinks:
383 entry () options (variable);
384
385 entry_index = NULL_LINKS_EI;
386 goto COMMON;
387
388 nonmsfs:
389 entry () options (variable);
390
391 entry_index = NONMSFS_EI;
392 goto COMMON;
393
394 nonfiles:
395 entry () options (variable);
396
397 entry_index = NONFILES_EI;
398 goto COMMON;
399
400 nonzero_segments:
401 nzsegs:
402 entry () options (variable);
403
404 entry_index = NONZERO_SEGMENTS_EI;
405 goto COMMON;
406
407 nonmaster_directories:
408 nmdirs:
409 entry () options (variable);
410
411 entry_index = NONMASTER_DIRECTORIES_EI;
412 goto COMMON;
413
414 nonnull_links:
415 nnlinks:
416 entry () options (variable);
417
418 entry_index = NONNULL_LINKS_EI;
419 goto COMMON;
420
421 nonzero_files:
422 nzfiles:
423 entry () options (variable);
424
425 entry_index = NONZERO_FILES_EI;
426 goto COMMON;
427
428 nonzero_msfs:
429 nzmsfs:
430 entry () options (variable);
431
432 entry_index = NONZERO_MSFS_EI;
433 goto COMMON;
434
435 object_files:
436 obfiles:
437 entry () options (variable);
438
439 entry_index = OBJECT_FILES_EI;
440 goto COMMON;
441
442 nonobject_files:
443 nobfiles:
444 entry () options (variable);
445
446 entry_index = NONOBJECT_FILES_EI;
447 goto COMMON;
448
449 object_msfs:
450 obmsfs:
451 entry () options (variable);
452
453 entry_index = OBJECT_MSFS_EI;
454 goto COMMON;
455
456 nonobject_msfs:
457 nobmsfs:
458 entry () options (variable);
459
460 entry_index = NONOBJECT_MSFS_EI;
461 goto COMMON;
462
463 object_segments:
464 obsegs:
465 entry () options (variable);
466
467 entry_index = OBJECT_SEGMENTS_EI;
468 goto COMMON;
469
470 nonobject_segments:
471 nobsegs:
472 entry () options (variable);
473
474 entry_index = NONOBJECT_SEGMENTS_EI;
475 goto COMMON;
476
477 nonbranches:
478 entry () options (variable);
479
480 entry_index = NONBRANCHES_EI;
481 goto COMMON;
482
483 nonlinks:
484 entry () options (variable);
485
486 entry_index = NONLINKS_EI;
487 goto COMMON;
488
489 exists:
490 entry () options (variable);
491
492 entry_index = EXISTS_EI;
493 goto COMMON;
494 ^L
495
496
497
498 COMMON:
499 system_area_ptr = get_system_free_area_ ();
500
501 star_list_branch_ptr,
502 star_list_names_ptr = null ();
503
504 space = "";
505
506 entry_type_ptr, seg_ptr, archive_ptr, link_array_ptr, uid_array_ptr = null ();
507
508 on condition (cleanup)
509 call Cleanup ();
510
511 command_name = COMMAND_NAME (entry_index);
512 found_something = FALSE;
513
514 call cu_$af_return_arg (arg_count, return_value_ptr, return_value_lth, code);
515
516 if code = error_table_$not_act_fnc
517 then do;
518 active_function = FALSE;
519 call cu_$arg_count (arg_count);
520 get_argument = cu_$arg_ptr;
521 error = com_err_;
522 end;
523
524 else do;
525 active_function = TRUE;
526 get_argument = cu_$af_arg_ptr;
527 error = active_fnc_err_;
528 end;
529
530 if entry_index = EXISTS_EI then do;
531 return_names = FALSE;
532 first_arg = 2;
533 if arg_count < 1 then do;
534 USAGE: call error (error_table_$noarg, command_name, "Usage: ^[[^]^a key star_name(s) {-control_arg(s)} ^[]^]", active_function, command_name, active_function);
535 return;
536 end;
537 call get_argument (1, argument_ptr, argument_lth, code);
538 if code ^= 0 then goto ARGERR;
539
540 if argument = "argument" then do;
541 found_something = (arg_count > 1);
542 goto DONE;
543 end;
544 else if arg_count < 2 then goto USAGE;
545
546 got_key = FALSE;
547 do kname_index = 1 to hbound (KEY_NAME, 1) while (^got_key);
548 got_key = (argument = KEY_NAME (kname_index));
549 end;
550 if ^got_key then do;
551 call error (0, command_name, "Invalid key ^a.", argument);
552 return;
553 end;
554
555 kname_index = kname_index - 1;
556 table_index = INDEX_TAB (kname_index);
557 end;
558 else do;
559 kname_index = 1;
560 return_names = TRUE;
561 first_arg = 1;
562 table_index = entry_index;
563 end;
564
565 star_select_sw = SELECT_SW (table_index);
566
567
568
569
570
571 starname_count = 0;
572 inhibit_error, chase, select_entry_type, return_absolute_pathnames = FALSE;
573
574 do idx = first_arg to arg_count;
575 call get_argument (idx, argument_ptr, argument_lth, code);
576 if code ^= 0 then do;
577 ARGERR: call error (code, command_name);
578 return;
579 end;
580 if substr (argument, 1, 1) = "-" then do;
581 if ((argument = "-absolute_pathname") | (argument = "-absp")) & return_names then return_absolute_pathnames = TRUE;
582 else if (argument = "-chase") & CHASE_OK (table_index)
583 then chase = TRUE;
584 else if (argument = "-no_chase") & CHASE_OK (table_index)
585 then chase = FALSE;
586 else if (argument = "-inhibit_error" | argument = "-ihe")
587 then inhibit_error = TRUE;
588 else if (argument = "-no_inhibit_error" | argument = "-nihe")
589 then inhibit_error = FALSE;
590 else if (table_index = ENTRIES_EI | table_index = FILES_EI | table_index = EXISTS_EI) & ((argument = "-select_entry_type") | (argument = "-slet")) then do;
591 if idx = arg_count then do;
592 call error (error_table_$noarg, command_name, "^a requires an entry type list.", argument);
593 return;
594 end;
595 idx = idx + 1;
596 call get_argument (idx, argument_ptr, argument_lth, code);
597 if code ^= 0 then goto ARGERR;
598 call process_entry_type_list (argument, entry_type_ptr, select_entry_type);
599 if ^select_entry_type then do;
600 call error (error_table_$bad_arg, command_name, "Invalid entry type selected. ^a", argument);
601 return;
602 end;
603 end;
604 else do;
605 call error (error_table_$badopt, command_name, "^a", argument);
606 return;
607 end;
608 end;
609 else do;
610 if starname_count = 20 then do;
611 call error (error_table_$too_many_args, command_name, "Only 20 starnames may be specified.");
612 goto ABORT;
613 end;
614 starname_count = starname_count + 1;
615 starnames (starname_count) = argument;
616 end;
617 end;
618
619 if starname_count = 0 then do;
620 call error (error_table_$noarg, command_name,
621 "^/ Usage: ^[[^;^]^a starnames {-control_arg^[s^]}^[]^;^]",
622 active_function, command_name, (CHASE_OK (table_index)), active_function);
623 goto ABORT;
624 end;
625
626 if star_select_sw = star_BRANCHES_ONLY & chase
627 then star_select_sw = star_ALL_ENTRIES;
628 ^L
629
630
631
632
633 if return_names then do;
634 if ^active_function then line_length, chars_left = get_line_length_$switch (iox_$user_output, (0));
635
636 call get_temp_segment_ ((command_name), link_array_ptr, code);
637
638 if code ^= 0 then do;
639 call error (code, command_name, "While getting temp segment.");
640 go to ABORT;
641 end;
642
643 n_link_names = 0;
644
645 call get_temp_segment_ ((command_name), uid_array_ptr, code);
646
647 if code ^= 0 then do;
648 call error (code, command_name, "While getting temp segment.");
649 go to ABORT;
650 end;
651
652 n_uids = 0;
653 end;
654
655 do idx = 1 to starname_count;
656
657 found_something = found_something | Process_Pathname (starnames (idx));
658 if found_something & ^return_names then goto DONE;
659 end;
660
661 DONE: if ^return_names then do;
662 if found_something then do;
663 if active_function then return_value = "true";
664 else call ioa_ ("true");
665 end;
666 else do;
667 if active_function then return_value = "false";
668 else call ioa_ ("false");
669 end;
670 end;
671 else do;
672 if ^found_something then do;
673 if active_function then return_value = "";
674 else call error ((0), command_name, "No entries found.");
675 end;
676 else if ^active_function then call ioa_ ("");
677 end;
678
679 ABORT:
680 call Cleanup ();
681 return;
682 ^L
683
684 Process_Pathname:
685 procedure (pathname) returns (bit (1));
686
687 dcl pathname character (*) parameter;
688 dcl result bit (1) aligned;
689 dcl idx fixed binary;
690
691 result = FALSE;
692
693 call expand_pathname_$component (pathname, dir, ename, component, code);
694 if code ^= 0 then goto PATH_ERR;
695
696 if component = "" & KEY_NAME (kname_index) = "component" then do;
697 code = error_table_$not_archive;
698 goto PATH_ERR;
699 end;
700
701 if component ^= "" & KEY_NAME (kname_index) ^= "component" then do;
702 code = error_table_$archive_pathname;
703 goto PATH_ERR;
704 end;
705
706 if (dir = ">") & (ename = "") then do;
707 if table_index = ENTRIES_EI then do;
708 if select_entry_type then
709 if entry_type_selected (entry_type_ptr, FS_OBJECT_TYPE_DIRECTORY) then call Return_Entry (ename, FALSE);
710 else return (FALSE);
711 else call Return_Entry (ename, FALSE);
712 end;
713 else if ROOT (table_index) then call Return_Entry (ename, FALSE);
714 else return (FALSE);
715 end;
716 else do;
717 call check_star_name_$entry (ename, code);
718 if ^((code = 0) | (code = 1) | (code = 2)) then goto PATH_ERR;
719 if table_index ^= ENTRIES_EI then do;
720 call Get_Star_Names ();
721 if code ^= 0 & code ^= error_table_$no_s_permission then do;
722 if code = error_table_$noentry | code = error_table_$no_dir | code = error_table_$nomatch then return (FALSE);
723 else goto PATH_ERR;
724 end;
725 do idx = star_branch_count + star_link_count to 1 by -1 while (return_names | ^result);
726 if Process_A_Name (table_index, addr (star_dir_list_branch (idx)))
727 then call Return_Entry (star_list_names (star_dir_list_branch (idx).nindex), ((star_dir_list_branch (idx).type) = Link));
728 end;
729 end;
730 else do;
731 result = Process_A_Name (table_index, null ());
732 end;
733 end;
734
735 call free_star_structures ();
736
737 return (result);
738
739 PATH_ERR:
740 if (length (space) ^= 0) & ^active_function then call ioa_ ("");
741 if ^inhibit_error then do;
742 call error (code, command_name, "^a", pathname);
743 goto ABORT;
744 end;
745 else return (FALSE);
746
747 Return_Entry: procedure (ename, is_link);
748
749 dcl ename char (*) parameter;
750 dcl is_link bit (1) parameter;
751 dcl temp_string character (256) varying;
752
753 if return_names then do;
754 if is_link then do;
755 call expand_pathname_ (dir, dir_dname, dir_ename, (0));
756 call hcs_$get_uid_file (dir_dname, dir_ename, unique_id, (0));
757 found_uid = FALSE;
758 do jdx = 1 to n_uids while (^found_uid);
759 if unique_id = uid_array (jdx) then do;
760 found_uid = TRUE;
761 do kdx = 1 to n_link_names;
762 if link_array (kdx) = ename then return;
763 end;
764 n_link_names = n_link_names + 1;
765 if n_link_names > hbound (link_array, 1) then do;
766 call error (0, command_name, "Too many links for internal array.");
767 goto ABORT;
768 end;
769 link_array (n_link_names) = ename;
770 end;
771 end;
772 if ^found_uid then do;
773 n_uids = n_uids + 1;
774 if n_uids > hbound (uid_array, 1) then do;
775 call error (0, command_name, "Too many entries for internal array.");
776 goto ABORT;
777 end;
778 uid_array (n_uids) = unique_id;
779 n_link_names = n_link_names + 1;
780 if n_link_names > hbound (link_array, 1) then do;
781 call error (0, command_name, "Too many links for internal array.");
782 goto ABORT;
783 end;
784 link_array (n_link_names) = ename;
785 end;
786 end;
787 else do;
788 call hcs_$get_uid_file (dir, ename, unique_id, (0));
789 do jdx = 1 to n_uids;
790 if unique_id = uid_array (jdx) then return;
791 end;
792 n_uids = n_uids + 1;
793 if n_uids > hbound (uid_array, 1) then do;
794 call error (0, command_name, "Too many entries for internal array.");
795 goto ABORT;
796 end;
797 uid_array (n_uids) = unique_id;
798 end;
799 if return_absolute_pathnames then if dir = ">" then temp_string = ">";
800 else temp_string = rtrim (dir) || ">";
801 else temp_string = "";
802
803 temp_string = temp_string || rtrim (ename);
804
805 if active_function then do;
806 return_value = return_value || space;
807 return_value = return_value || requote_string_ ((temp_string));
808 end;
809 else if chars_left > length (temp_string) + length (space) then do;
810 call ioa_$nnl (space || "^a", temp_string);
811 chars_left = chars_left - length (temp_string) - length (space);
812 end;
813 else do;
814 call ioa_$nnl ("^/^a", temp_string);
815 chars_left = max (0, line_length - length (temp_string));
816 end;
817
818 if active_function then space = " ";
819 else space = " ";
820
821 end;
822
823 result = TRUE;
824
825 end Return_Entry;
826 ^L
827 Process_A_Name: procedure (table_index, entry_ptr) returns (bit (1));
828
829 dcl table_index fixed binary parameter;
830 dcl entry_ptr pointer parameter;
831 dcl 1 entry aligned like star_dir_list_branch based (entry_ptr);
832 dcl type fixed bin (2);
833 dcl bit_count fixed bin (24);
834 dcl null_link bit (1);
835 dcl idx fixed binary;
836
837 if table_index ^= ENTRIES_EI then do;
838 type = entry.type;
839 bit_count = entry.bit_count;
840 if type = Link then do;
841 if ^chase then do;
842 call hcs_$status_minf (dir, star_list_names (entry.nindex), 1, (0), (0), code);
843 null_link = ^(code = 0);
844 end;
845 else call hcs_$status_minf (dir, star_list_names (entry.nindex), 1, type, bit_count, code);
846 end;
847 if type = Directory & bit_count > 0 then type = MSF;
848 end;
849
850 go to PROCESS (table_index);
851
852 PROCESS (1):
853 return ((type = Segment));
854
855 PROCESS (2):
856 return ((type = Directory & bit_count = 0));
857
858 PROCESS (3):
859 return ((type = MSF));
860
861 PROCESS (4):
862 PROCESS (20):
863 return ((type = Link));
864
865 PROCESS (5):
866 star_select_sw = star_ALL_ENTRIES;
867 if select_entry_type then do;
868 do entry_type_no = 1 to entry_type.count;
869 old_ename = ename;
870 if substr (entry_type.suffix (entry_type_no), 1, 1) = "-" then ;
871 else call expand_pathname_$add_suffix (old_ename, entry_type.suffix (entry_type_no), char_168, ename, code);
872 call Get_Star_Names;
873 do idx = star_branch_count + star_link_count to 1 by -1;
874 if star_dir_list_branch (idx).type = Link then do;
875 if ^chase then if entry_type_selected (entry_type_ptr, FS_OBJECT_TYPE_LINK)
876 then call Return_Entry (star_list_names (star_dir_list_branch (idx).nindex), TRUE);
877 else ;
878 else do;
879 call fs_util_$get_type (dir, star_list_names (star_dir_list_branch (idx).nindex), fs_type, code);
880 if fs_type = entry_type.suffix (entry_type_no)
881 then call Return_Entry (star_list_names (star_dir_list_branch (idx).nindex), FALSE);
882 end;
883 end;
884 else do;
885 call fs_util_$get_type (dir, star_list_names (star_dir_list_branch (idx).nindex), fs_type, code);
886 if fs_type = entry_type.suffix (entry_type_no)
887 then call Return_Entry (star_list_names (star_dir_list_branch (idx).nindex), FALSE);
888 end;
889 end;
890 if star_list_names_ptr ^= null () then do;
891 free star_list_names_ptr -> star_list_names;
892 free star_list_branch_ptr -> star_dir_list_branch;
893 end;
894 ename = old_ename;
895 end;
896 end;
897 else do;
898 call Get_Star_Names;
899 if ^return_names
900 then if star_branch_count + star_link_count > 0 then return (TRUE);
901 else ;
902 else do idx = star_branch_count + star_link_count to 1 by -1;
903 call Return_Entry (star_list_names (star_dir_list_branch (idx).nindex), (star_dir_list_branch (idx).type = Link));
904 end;
905 end;
906 return (result);
907
908 PROCESS (6):
909 PROCESS (21):
910 return ((type ^= Link));
911
912 PROCESS (7):
913 return ((type = Segment) | (type = MSF));
914
915 PROCESS (8):
916 return ((type = Segment) & (bit_count = 0));
917
918 PROCESS (9):
919 return ((entry.master_dir));
920
921 PROCESS (10):
922 return ((type = Link) & null_link);
923
924 PROCESS (11):
925 return ((type ^= Segment));
926
927 PROCESS (12):
928 return (^((type = Directory) & (bit_count = 0)));
929
930 PROCESS (13):
931 return (^(type = MSF));
932
933 PROCESS (14):
934 return (^((type = Segment) | (type = MSF)));
935
936 PROCESS (15):
937 return ((type = Segment) & (bit_count ^= 0));
938
939 PROCESS (16):
940 return ((type = Directory) & ^entry.master_dir);
941
942 PROCESS (17):
943 return ((type = Link) & ^(null_link));
944
945 PROCESS (18):
946 if (type = Segment) then
947 return (bit_count ^= 0);
948 else if (type = MSF) then
949 return (Msf_Nonzero (dir, star_list_names (entry.nindex), bit_count));
950 else return (FALSE);
951
952 PROCESS (19):
953 if (type = MSF) then
954 return (Msf_Nonzero (dir, star_list_names (entry.nindex), bit_count));
955 else return (FALSE);
956
957 PROCESS (22):
958 if (type = Segment | type = MSF) then
959 return (Check_Object_Segment (dir, star_list_names (entry.nindex)));
960 else return (FALSE);
961
962 PROCESS (23):
963 if (type = Segment | type = MSF) then
964 return (^Check_Object_Segment (dir, star_list_names (entry.nindex)));
965 else return (FALSE);
966
967 PROCESS (24):
968 if type = MSF then
969 return (Check_Object_Segment (dir, star_list_names (entry.nindex)));
970 else return (FALSE);
971
972 PROCESS (25):
973 if type = MSF then
974 return (^Check_Object_Segment (dir, star_list_names (entry.nindex)));
975 else return (FALSE);
976
977 PROCESS (26):
978 if type = Segment then
979 return (Check_Object_Segment (dir, star_list_names (entry.nindex)));
980 else return (FALSE);
981
982 PROCESS (27):
983 if type = Segment then
984 return (^Check_Object_Segment (dir, star_list_names (entry.nindex)));
985 else return (FALSE);
986
987 PROCESS (28):
988 call initiate_file_ (dir, star_list_names (entry.nindex), R_ACCESS, archive_ptr, archive_bc, code);
989 if archive_ptr = null () then goto PATH_ERR;
990
991 call check_star_name_$entry (component, code);
992 if code = 1 | code = 2 then return (process_component_starname (archive_ptr, archive_bc, component));
993 else do;
994 call archive_$get_component (archive_ptr, archive_bc, component, (null ()), (0), code);
995 if code = 0 then return (TRUE);
996 else if (code = error_table_$not_archive) | (code = error_table_$archive_fmt_err) then goto PATH_ERR;
997 else return (FALSE);
998 end;
999
1000 end Process_A_Name;
1001 ^L
1002
1003 Get_Star_Names: procedure;
1004
1005 star_branch_count, star_link_count = 0;
1006 call hcs_$star_dir_list_ (dir, ename, star_select_sw, system_area_ptr, star_branch_count, star_link_count, star_list_branch_ptr, star_list_names_ptr, code);
1007
1008 end Get_Star_Names;
1009 ^L
1010 Check_Object_Segment: procedure (dir, ename) returns (bit (1));
1011
1012 dcl (dir, ename) character (*) parameter;
1013
1014 seg_ptr = null ();
1015 call object_lib_$initiate (dir, ename, "", "1"b, seg_ptr, (0), (""b), code);
1016 call terminate_file_ (seg_ptr, (0), TERM_FILE_TERM, (0));
1017 return (code = 0);
1018
1019 end Check_Object_Segment;
1020
1021
1022 Msf_Nonzero: procedure (dir, ename, msf_indicator) returns (bit(1));
1023
1024 dcl (dir, ename) character (*) parameter;
1025 dcl msf_indicator fixed bin(24) parameter;
1026 dcl code fixed bin(35);
1027 dcl comp fixed bin;
1028 dcl comp_bit_count fixed bin(24);
1029 dcl msf_bit_count fixed bin(35);
1030 dcl msf_dir char(168);
1031
1032 msf_dir = pathname_ (dir, ename);
1033 msf_bit_count = 0;
1034 do comp = 0 to msf_indicator - 1;
1035 call hcs_$status_minf (msf_dir, ltrim(char(comp)),
1036 1, (0), comp_bit_count, code);
1037 if code = 0 then
1038 msf_bit_count = msf_bit_count + comp_bit_count;
1039 end;
1040 return (msf_bit_count > 0);
1041
1042 end Msf_Nonzero;
1043 ^L
1044
1045
1046 process_component_starname: proc (archive_ptr, archive_bc, c_starname) returns (bit (1));
1047
1048 dcl archive_bc fixed bin (24),
1049 archive_ptr ptr,
1050 c_name char (32),
1051 c_starname char (32);
1052
1053 c_ptr = null ();
1054 do while ("1"b);
1055 call archive_$next_component (archive_ptr, archive_bc, c_ptr, (0), c_name, code);
1056 if code ^= 0 then return (FALSE);
1057 if c_ptr = null () then return ("0"b);
1058 call match_star_name_ (c_name, c_starname, code);
1059 if code = 0 then return ("1"b);
1060 end;
1061
1062 end process_component_starname;
1063
1064 end Process_Pathname;
1065 ^L
1066
1067 Cleanup: procedure ();
1068
1069 if link_array_ptr ^= null ()
1070 then call release_temp_segment_ ((command_name), link_array_ptr, (0));
1071 if uid_array_ptr ^= null ()
1072 then call release_temp_segment_ ((command_name), uid_array_ptr, (0));
1073 call free_star_structures ();
1074 if seg_ptr ^= null () then call terminate_file_ (seg_ptr, (0), TERM_FILE_TERM, (0));
1075 if archive_ptr ^= null () then call terminate_file_ (seg_ptr, (0), TERM_FILE_TERM, (0));
1076 if entry_type_ptr ^= null () then free entry_type in (system_area);
1077
1078 end Cleanup;
1079 ^L
1080
1081 free_star_structures:
1082 procedure ();
1083
1084 if star_list_names_ptr ^= null ()
1085 then free star_list_names;
1086
1087 if star_list_branch_ptr ^= null ()
1088 then free star_dir_list_branch;
1089
1090 star_list_branch_ptr,
1091 star_list_names_ptr = null ();
1092
1093 end free_star_structures;
1094 ^L
1095
1096
1097 process_entry_type_list: procedure (entry_type_list, entry_type_struct_ptr, limit_entry_selections);
1098
1099 dcl entry_type_list char (*) parameter;
1100 dcl entry_type_struct_ptr pointer parameter;
1101 dcl limit_entry_selections
1102 bit (1) aligned parameter;
1103 dcl types_len fixed bin (24);
1104 dcl types_ptr pointer;
1105 dcl types char (types_len) based (types_ptr);
1106 dcl entry_type_no fixed bin;
1107 dcl this_type char (32);
1108
1109
1110
1111
1112 types_ptr = null ();
1113 on cleanup begin;
1114 if types_ptr ^= null () then free types in (system_area);
1115 end;
1116
1117 types_len = length (entry_type_list);
1118 allocate types set (types_ptr) in (system_area);
1119 types = entry_type_list;
1120
1121
1122
1123 do entry_type_count = 1
1124 repeat (entry_type_count + 1)
1125 while (index (types, ",") > 0);
1126 types = after (types, ",");
1127 end;
1128
1129
1130
1131 allocate entry_type
1132 set (entry_type_struct_ptr)
1133 in (system_area);
1134
1135 entry_type_struct_ptr -> entry_type.suffix (*) = "";
1136
1137
1138
1139 types = entry_type_list;
1140 type_info.version = SUFFIX_INFO_VERSION_1;
1141 entry_type_no = 1;
1142 do while (types ^= "");
1143 this_type = before (types, ",");
1144 if substr (this_type, 1, 1) ^= "-" then do;
1145 if this_type = "link" then this_type = FS_OBJECT_TYPE_LINK;
1146 else if this_type = "segment" then this_type = FS_OBJECT_TYPE_SEGMENT;
1147 else if this_type = "directory" then this_type = FS_OBJECT_TYPE_DIRECTORY;
1148 else if this_type = "multisegment_file" then this_type = FS_OBJECT_TYPE_MSF;
1149 else if this_type = "data_management_file" then this_type = FS_OBJECT_TYPE_DM_FILE;
1150 entry_type_struct_ptr -> entry_type.suffix (entry_type_no) = this_type;
1151 if this_type = FS_OBJECT_TYPE_LINK then entry_type_no = entry_type_no + 1;
1152
1153 else do;
1154 call fs_util_$suffix_info_for_type (this_type, addr (type_info), code);
1155 if code = 0 then entry_type_no = entry_type_no + 1;
1156 end;
1157 end;
1158 types = after (types, ",");
1159 end;
1160
1161
1162
1163 free types_ptr -> types
1164 in (system_area);
1165
1166 entry_type_struct_ptr -> entry_type.count = entry_type_no - 1;
1167 if entry_type_struct_ptr -> entry_type.count > 0 then limit_entry_selections = "1"b;
1168 else limit_entry_selections = "0"b;
1169
1170 return;
1171
1172 end process_entry_type_list;
1173
1174
1175
1176
1177
1178
1179 entry_type_selected: proc (entry_type_struct_ptr, fs_type) returns (bit (1) aligned);
1180
1181
1182 dcl entry_type_struct_ptr pointer parameter;
1183 dcl fs_type char (32) parameter;
1184 dcl entry_type_no fixed bin;
1185
1186 do entry_type_no = 1 to entry_type_struct_ptr -> entry_type.count;
1187 if entry_type_struct_ptr -> entry_type.suffix (entry_type_no) = fs_type then return ("1"b);
1188 end;
1189 return ("0"b);
1190
1191 end entry_type_selected;
1192 ^L
1193 %include access_mode_values;
1194 ^L
1195 %include copy_flags;
1196 ^L
1197 %include file_system_operations;
1198 ^L
1199 %include object_info;
1200 ^L
1201 %include star_structures;
1202 ^L
1203 %include status_structures;
1204 ^L
1205 %include suffix_info;
1206 ^L
1207 %include terminate_file;
1208
1209 end entries;