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
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110 Note
111
112
113
114
115
116
117
118
119
120
121
122 print:
123 pr:
124 procedure;
125
126 dcl arg char (arg_len) unaligned based (arg_ptr);
127 dcl arg_len fixed bin (21);
128 dcl arg_list_ptr ptr;
129 dcl arg_ptr ptr;
130 dcl c fixed bin (35);
131 dcl error_code fixed bin (35);
132 dcl exclude_arg_count fixed bin;
133 dcl forcount fixed bin;
134 dcl from_line fixed bin;
135 dcl from_page fixed bin;
136 dcl from_regexpr char (from_regexpr_len + 2)
137 based (from_regexpr_ptr);
138 dcl from_regexpr_len fixed bin (21);
139 dcl from_regexpr_ptr ptr;
140 dcl iarg fixed bin;
141 dcl indentation fixed bin (21);
142 dcl input_path_count fixed bin;
143 dcl junk fixed bin;
144 dcl last_count fixed bin;
145 dcl left_col fixed bin;
146 dcl match_arg_count fixed bin;
147 dcl nargs fixed bin;
148 dcl output_buffer_size fixed bin;
149 dcl out_switch ptr;
150
151
152
153 dcl right_col fixed bin;
154 dcl star_sel fixed bin (2);
155 dcl switch_name char (32);
156 dcl to_line fixed bin;
157 dcl to_page fixed bin;
158 dcl to_regexpr_len fixed bin (21);
159 dcl to_regexpr_ptr ptr;
160
161 dcl 1 sws,
162 2 check_lines bit (1),
163 2 dont_want_archive bit (1),
164 2 from_line_given bit (1),
165 2 from_page_given bit (1),
166 2 had_an_arg bit (1),
167 2 last_given bit (1),
168 2 no_heading bit (1),
169 2 no_vertsp bit (1),
170 2 one_iox_call bit (1),
171 2 paging bit (1),
172 2 pause_after_page bit (1),
173 2 pause_before_print bit (1),
174 2 print_quick_way bit (1),
175 2 print_trailing_nls bit (1),
176 2 to_line_given bit (1),
177 2 to_page_given bit (1),
178 2 want_heading bit (1),
179 2 want_line_numbers bit (1);
180
181 dcl archive_$next_component_info
182 entry (ptr, fixed bin (24), ptr, ptr,
183 fixed bin (35));
184 dcl check_star_name_$entry entry (char (*), fixed bin (35));
185 dcl com_err_ entry options (variable);
186 dcl cu_$arg_count entry (fixed bin, fixed bin (35));
187 dcl cu_$arg_list_ptr entry (ptr);
188 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21),
189 fixed bin (35));
190 dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21),
191 fixed bin (35), ptr);
192 dcl cv_dec_check_ entry (char (*), fixed bin (35))
193 returns (fixed bin);
194 dcl date_time_$format entry (char (*), fixed bin (71), char (*),
195 char (*)) returns (char (250) var);
196 dcl expand_pathname_$component
197 entry (char (*), char (*), char (*), char (*),
198 fixed bin (35));
199 dcl get_system_free_area_ entry () returns (ptr);
200 dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr,
201 fixed bin, ptr, ptr, fixed bin (35));
202 dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1),
203 fixed bin (2), fixed bin (24), fixed bin (35));
204 dcl initiate_file_ entry (char (*), char (*), bit (*), ptr,
205 fixed bin (24), fixed bin (35));
206 dcl ioa_$ioa_switch entry options (variable);
207 dcl ioa_$ioa_switch_nnl entry options (variable);
208 dcl ioa_$rsnp entry options (variable);
209 dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35));
210 dcl iox_$get_line entry (ptr, ptr, fixed bin (21),
211 fixed bin (21), fixed bin (35));
212 dcl iox_$look_iocb entry (char (*), ptr, fixed bin (35));
213 dcl iox_$put_chars entry (ptr, ptr, fixed bin (21),
214 fixed bin (35));
215 dcl match_star_name_ entry (char (*), char (*), fixed bin (35));
216 dcl msf_manager_$close entry (ptr);
217 dcl msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr,
218 fixed bin (24), fixed bin (35));
219 dcl msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35))
220 ;
221 dcl pathname_ entry (char (*), char (*))
222 returns (char (168));
223 dcl pathname_$component entry (char (*), char (*), char (*))
224 returns (char (194));
225 dcl print_conv_$print_conv_
226 entry;
227 dcl prt_conv_ entry (ptr, fixed bin (21), ptr,
228 fixed bin (21), ptr);
229 dcl search_file_ entry (ptr, fixed bin (21), fixed bin (21),
230 ptr, fixed bin (21), fixed bin (21),
231 fixed bin (21), fixed bin (21), fixed bin (35))
232 ;
233 dcl search_file_$silent entry (ptr, fixed bin (21), fixed bin (21),
234 ptr, fixed bin (21), fixed bin (21),
235 fixed bin (21), fixed bin (21), fixed bin (35))
236 ;
237 dcl terminate_file_ entry (ptr, fixed bin (24), bit (*),
238 fixed bin (35));
239
240 dcl (addr, clock, codeptr, divide, index, length, max, min, mod, null,
241 reverse, rtrim, search, string, substr, sum, unspec)
242 builtin;
243 dcl cleanup condition;
244
245 dcl CR char (1) int static options (constant)
246 init ("^M");
247 dcl NL char (1) int static options (constant) init ("
248 ");
249 dcl NLCRVTNP char (4) int static options (constant) init ("
250 ^M^K^L");
251 dcl NP char (1) int static options (constant) init ("^L");
252 dcl NUL char (1) int static options (constant)
253 init ("^@");
254 dcl VT char (1) int static options (constant) init ("^K");
255 dcl LONGEST_SEARCH_FILE_REXP
256 fixed bin static options (constant) init (132);
257 dcl MAX_BUFFER_LTH fixed bin int static options (constant)
258 init (1025);
259 dcl 1 type static options (constant),
260 2 NOSTAR fixed bin (35) init (0),
261 2 STAR fixed bin (35) init (1),
262 2 STARSTAR fixed bin (35) init (2);
263 dcl TERMINATE_SEG bit (4) internal static options (constant)
264 init ("0010"b);
265
266 dcl error_table_$bad_conversion
267 fixed bin (35) ext static;
268 dcl error_table_$badopt fixed bin (35) ext static;
269 dcl error_table_$dirseg fixed bin (35) ext static;
270 dcl error_table_$inconsistent
271 fixed bin (35) ext static;
272 dcl error_table_$long_record
273 fixed bin (35) ext static;
274 dcl error_table_$noarg fixed bin (35) ext static;
275 dcl error_table_$no_component
276 fixed bin (35) ext static;
277 dcl error_table_$nomatch fixed bin (35) ext static;
278 dcl error_table_$regexp_undefined
279 fixed bin (35) ext static;
280 dcl error_table_$zero_length_seg
281 fixed bin (35) ext static;
282 dcl iox_$user_input ptr ext static;
283 dcl iox_$user_output ptr ext static;
284 %page (2);
285
286
287
288
289 star_sel = star_BRANCHES_ONLY;
290 from_line, from_page = 1;
291 to_page = -1;
292 match_arg_count, exclude_arg_count, to_line, indentation, forcount,
293 from_regexpr_len, to_regexpr_len, input_path_count = 0;
294 string (sws) = "0"b;
295 right_col = MAX_BUFFER_LTH;
296 last_count, left_col = 1;
297
298 pcip = addr (PCI);
299 unspec (PCI) = ""b;
300 pci.cv_proc = codeptr (print_conv_$print_conv_);
301 pci.line = 1;
302 pci.phys_line_length = MAX_BUFFER_LTH;
303 pci.ctl_char = "1"b;
304 pci.lpi = 6;
305 pci.sheets_per_page = 1;
306 pci.top_label_line = "";
307 pci.bot_label_line = "";
308 pci.overflow_off = "1"b;
309 pci.label_wksp = null;
310 pci.label_nelem = 0;
311 switch_name = "user_output";
312 out_switch = iox_$user_output;
313
314
315
316 call cu_$arg_list_ptr (arg_list_ptr);
317 call cu_$arg_count (nargs, error_code);
318 if error_code ^= 0
319 then
320 do;
321 call com_err_ (error_code, "print");
322 return;
323 end;
324
325 do iarg = 1 to nargs;
326 call cu_$arg_ptr (iarg, arg_ptr, arg_len, error_code);
327 if error_code ^= 0
328 then
329 do;
330 ARG_READ_ERR:
331 call com_err_ (error_code, "print", "Argument ^d.", iarg);
332 RETURN:
333 return;
334 end;
335
336 if index (arg, "-") ^= 1
337 then
338 do;
339 junk = cv_dec_check_ (arg, error_code);
340
341 if error_code = 0
342 then
343 do;
344 if input_path_count = 0
345 then goto its_a_name;
346
347 if junk = 0
348 then
349 do;
350 error_code = error_table_$bad_conversion;
351 goto ARG_ERR;
352 end;
353
354 if ^sws.from_line_given
355 then
356 do;
357 from_line = junk;
358 sws.from_line_given = "1"b;
359 end;
360
361 else if ^sws.to_line_given
362 then
363 do;
364 to_line = junk;
365 sws.to_line_given = "1"b;
366 end;
367
368 else
369 do;
370 call com_err_ (error_table_$inconsistent, "print",
371 "Only one line range is allowed. ^a", arg);
372 return;
373 end;
374 sws.had_an_arg = "1"b;
375 end;
376
377 else
378 do;
379 if search (arg, "*?") ^= 0
380 then input_path_count = input_path_count + 1;
381 its_a_name:
382 input_path_count = input_path_count + 1;
383 end;
384 end;
385
386 else
387 do;
388 sws.had_an_arg = "1"b;
389
390 if arg = "-name" | arg = "-nm"
391 then
392 do;
393 iarg = iarg + 1;
394
395 if iarg > nargs
396 then
397 do;
398 miss_arg:
399 call com_err_ (error_table_$noarg, "print",
400 "After ^a.", arg);
401 return;
402 end;
403 input_path_count = input_path_count + 1;
404 end;
405
406 else if arg = "-from" | arg = "-fm"
407 then call GET_FROM_TO (sws.from_line_given, from_regexpr_ptr,
408 from_regexpr_len, from_line);
409
410 else if arg = "-to"
411 then call GET_FROM_TO (sws.to_line_given, to_regexpr_ptr,
412 to_regexpr_len, to_line);
413
414 else if arg = "-for"
415 then forcount = GETNUM ();
416
417 else if arg = "-from_page"
418 then
419 do;
420 sws.from_page_given = "1"b;
421 from_page = GETNUM ();
422 end;
423
424 else if arg = "-to_page"
425 then
426 do;
427 sws.to_page_given = "1"b;
428 to_page = GETNUM ();
429 end;
430
431 else if arg = "-indent" | arg = "-ind" | arg = "-in"
432 then indentation = GETNUM ();
433
434 else if arg = "-last" | arg = "-lt"
435 then
436 do;
437 sws.last_given = "1"b;
438 last_count = GETNUM ();
439 end;
440
441 else if arg = "-left_col" | arg = "-lc"
442 then left_col = GETNUM ();
443
444 else if arg = "-right_col" | arg = "-rc"
445 then right_col = GETNUM ();
446
447 else if arg = "-line_length" | arg = "-ll"
448 then pci.phys_line_length = GETNUM ();
449
450 else if arg = "-page_length" | arg = "-pl"
451 then
452 do;
453 pci.page_length = GETNUM ();
454 pci.overflow_off = "0"b;
455 end;
456
457 else if arg = "-phys_page_length" | arg = "-ppl"
458 then pci.phys_page_length = GETNUM ();
459
460 else if arg = "-stop" | arg = "-sp"
461 then
462 do;
463 sws.pause_after_page = "1"b;
464 sws.pause_before_print = "1"b;
465 end;
466
467 else if arg = "-wait" | arg = "-wt"
468 then sws.pause_before_print = "1"b;
469
470 else if arg = "-header" | arg = "-he"
471 then
472 do;
473 sws.want_heading = "1"b;
474 sws.no_heading = "0"b;
475 end;
476
477 else if arg = "-no_header" | arg = "-nhe"
478 then sws.no_heading = "1"b;
479
480 else if arg = "-no_archive" | arg = "-nac"
481 then sws.dont_want_archive = "1"b;
482
483 else if arg = "-archive" | arg = "-ac"
484 then sws.dont_want_archive = "0"b;
485
486 else if arg = "-no_vertsp"
487 then sws.no_vertsp = "1"b;
488
489 else if arg = "-vertsp"
490 then sws.no_vertsp = "0"b;
491
492 else if arg = "-match"
493 then
494 do;
495 if iarg >= nargs
496 then goto miss_arg;
497
498 iarg = iarg + 1;
499 match_arg_count = match_arg_count + 1;
500 end;
501
502 else if arg = "-ex" | arg = "-exclude"
503 then
504 do;
505 if iarg >= nargs
506 then goto miss_arg;
507
508 iarg = iarg + 1;
509 exclude_arg_count = exclude_arg_count + 1;
510 end;
511
512 else if arg = "-number" | arg = "-nb"
513 then sws.want_line_numbers = "1"b;
514
515 else if arg = "-chase"
516 then star_sel = star_ALL_ENTRIES;
517
518 else if arg = "-no_chase"
519 then star_sel = star_BRANCHES_ONLY;
520
521 else if arg = "-output_switch" | arg = "-osw"
522 then
523 do;
524 iarg = iarg + 1;
525 call cu_$arg_ptr (iarg, arg_ptr, arg_len, error_code);
526 if error_code ^= 0
527 then goto ARG_READ_ERR;
528
529 call iox_$look_iocb (arg, out_switch, error_code);
530 if error_code ^= 0
531 then
532 do;
533 call com_err_ (error_code, "print",
534 "Looking for output switch ^a", arg);
535 goto RETURN;
536 end;
537 switch_name = arg;
538 end;
539
540 else
541 do;
542 error_code = error_table_$badopt;
543 ARG_ERR:
544 call com_err_ (error_code, "print", "^a", arg);
545 return;
546 end;
547 end;
548 end;
549
550
551
552 if input_path_count = 0
553 then
554 do;
555 call com_err_ (error_table_$noarg, "print", "No pathname given.");
556 return;
557 end;
558
559 if (switch_name ^= "user_output")
560 & (sws.pause_before_print | sws.pause_after_page)
561 then
562 do;
563 call com_err_ (error_table_$inconsistent, "print",
564 "-output_switch cannot be used with ^[-stop^;-wait^].",
565 sws.pause_after_page);
566 return;
567 end;
568
569 if (sws.to_page_given | sws.from_page_given)
570 & (sws.from_line_given | sws.to_line_given)
571 then
572 do;
573 call com_err_ (error_table_$inconsistent, "print",
574 "Page and line specifiers cannot be used together.");
575 return;
576 end;
577
578 if sws.from_line_given & sws.last_given
579 then
580 do;
581 call com_err_ (error_table_$inconsistent, "print",
582 "-from and -last cannot be used together.");
583 return;
584 end;
585
586 if sws.to_line_given & sws.from_line_given & to_line < from_line
587 & from_regexpr_len + to_regexpr_len = 0
588 then
589 do;
590 call com_err_ (error_table_$inconsistent, "print",
591 "-from ^d > -to ^d", from_line, to_line);
592 return;
593 end;
594
595 if sws.from_page_given & sws.to_page_given & to_page < from_page
596 then
597 do;
598 call com_err_ (error_table_$inconsistent, "print",
599 "-from_page ^d > -to_page ^d", from_page, to_page);
600 return;
601 end;
602
603 if right_col < left_col
604 then
605 do;
606 call com_err_ (error_table_$inconsistent, "print",
607 "-left_col ^d > -right_col ^d", left_col, right_col);
608 return;
609 end;
610
611 if pci.phys_line_length < 5
612 then
613 do;
614 call com_err_ (0, "print",
615 "Implementation restriction: -line_length must be greater than 4."
616 );
617 return;
618 end;
619
620 sws.check_lines = match_arg_count > 0 | exclude_arg_count > 0;
621
622 sws.paging =
623 (pci.page_length ^= 0) | (pci.phys_page_length ^= 0)
624 | sws.from_page_given | sws.to_page_given;
625
626 sws.print_quick_way =
627 (left_col <= 1) & (right_col = MAX_BUFFER_LTH)
628 & (pci.phys_line_length = MAX_BUFFER_LTH) & (^sws.paging)
629 & (mod (indentation, 10) = 0) & (^sws.no_vertsp);
630
631 sws.one_iox_call =
632 (forcount = 0) & ^sws.from_page_given & ^sws.to_page_given
633 & (indentation = 0) & ^sws.pause_after_page & ^sws.no_vertsp
634 & ^sws.from_line_given & ^sws.to_line_given & ^sws.last_given
635 & ^sws.check_lines & ^sws.want_line_numbers;
636
637 output_buffer_size = min (pci.phys_line_length, MAX_BUFFER_LTH);
638
639 if right_col = MAX_BUFFER_LTH
640 then right_col = output_buffer_size;
641
642 if pci.phys_line_length = MAX_BUFFER_LTH
643 then pci.phys_line_length = output_buffer_size;
644
645 pci.rmarg = output_buffer_size;
646
647 if pci.page_length = 0
648 then pci.page_length = 131071;
649
650 if pci.phys_page_length = 0
651 then pci.phys_page_length = 66;
652
653 if input_path_count = 1 & ^sws.had_an_arg
654 then sws.want_heading, sws.print_trailing_nls = "1"b;
655
656 else if input_path_count > 1
657 then sws.want_heading = "1"b;
658
659 if sws.no_heading
660 then sws.want_heading = "0"b;
661
662 match_arg_count = max (match_arg_count, 1);
663 exclude_arg_count = max (exclude_arg_count, 1);
664
665 %page (2);
666
667
668 GET_FROM_TO:
669 proc (bv_had, bv_regexpr_ptr, bv_regexpr_len, bv_line);
670
671 dcl bv_had bit (1),
672 bv_regexpr_ptr ptr,
673 bv_regexpr_len fixed bin (21),
674 bv_line fixed bin;
675
676 dcl range_arg char (6) var;
677
678 if iarg >= nargs
679 then goto miss_arg;
680
681 range_arg = arg;
682 iarg = iarg + 1;
683
684 call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code, arg_list_ptr);
685 if error_code ^= 0
686 then goto ARG_READ_ERR;
687
688 junk = cv_dec_check_ (arg, error_code);
689
690 if bv_had
691 then
692 do;
693 call com_err_ (error_table_$inconsistent, "print",
694 "Only one line range is allowed. ^a ^[^i^;^s^a^]", range_arg,
695 (error_code ^= 0), junk, arg);
696 goto RETURN;
697 end;
698
699 bv_had = "1"b;
700
701 if arg_len >= 2 &
702 index (arg, "/") = 1 & index (reverse (arg), "/") = 1
703 then
704 do;
705 if arg_len = 2
706 then error_code = error_table_$regexp_undefined;
707 else call search_file_$silent (arg_ptr, 2, arg_len - 2, arg_ptr, 1,
708 arg_len, 0, 0, error_code);
709 if error_code ^= 0 & error_code ^= error_table_$nomatch
710 then
711 do;
712 call com_err_ (error_code, "print", "^a ^a", range_arg, arg);
713 goto RETURN;
714 end;
715
716 if arg_len > LONGEST_SEARCH_FILE_REXP + 2
717 then
718 do;
719 call com_err_ (0, "print",
720 "Regular expressions may not be longer than ^d characters. ^/^-^a",
721 LONGEST_SEARCH_FILE_REXP + 2, arg);
722 goto RETURN;
723 end;
724
725 bv_regexpr_ptr = arg_ptr;
726 bv_regexpr_len = arg_len - 2;
727 end;
728
729 else
730 do;
731 bv_line = cv_dec_check_ (arg, error_code);
732 if error_code ^= 0 | bv_line < 1
733 then
734 do;
735 error_code = error_table_$bad_conversion;
736 ARG_OPERAND_ERR:
737 call com_err_ (error_code, "print", "^a ^a", range_arg, arg);
738 go to RETURN;
739 end;
740 end;
741
742 return;
743
744
745
746 GETNUM:
747 entry () returns (fixed bin);
748
749 dcl answer fixed bin;
750
751 range_arg = arg;
752 iarg = iarg + 1;
753 call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code, arg_list_ptr);
754 if error_code ^= 0
755 then goto ARG_READ_ERR;
756
757 answer = cv_dec_check_ (arg, error_code);
758 if error_code ^= 0 | answer < 1
759 then
760 do;
761 error_code = error_table_$bad_conversion;
762 goto ARG_OPERAND_ERR;
763 end;
764 return (answer);
765
766 end GET_FROM_TO;
767 %page;
768
769
770 begin;
771
772 dcl arg_token char (6) var;
773 dcl star_area area based (star_area_ptr);
774 dcl star_area_ptr ptr;
775 dcl star_entry_array (star_entry_count) fixed bin
776 based (star_entry_array_ptr);
777 dcl star_entry_array_ptr ptr;
778 dcl match_string_ptr (match_arg_count) ptr;
779 dcl match_string_len (match_arg_count) fixed bin (21);
780 dcl match_string_count fixed bin;
781 dcl exclude_string_ptr (exclude_arg_count) ptr;
782 dcl exclude_string_len (exclude_arg_count) fixed bin (21);
783 dcl exclude_string_count fixed bin;
784 dcl ever_printed bit (1);
785 dcl ever_had_err bit (1);
786 dcl ever_found_from bit (1);
787 dcl ever_found_page bit (1);
788 dcl seg_ptr ptr;
789 dcl FCB_ptr ptr;
790 dcl had_err bit (1);
791 dcl dir_name char (168);
792 dcl entry_name char (32);
793 dcl archive_element char (32);
794 dcl entry_star_type fixed bin (35);
795 dcl archive_element_star_type
796 fixed bin (35);
797 dcl archive_elements_found bit (1);
798 dcl star_entry_array_index fixed bin;
799 dcl star_entry_name char (32);
800
801 ever_printed, ever_had_err, ever_found_from, ever_found_page = "0"b;
802 match_string_count, exclude_string_count = 0;
803
804 if sws.check_lines
805 then
806 do iarg = 1 to nargs;
807 call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code,
808 arg_list_ptr);
809 if error_code ^= 0
810 then goto ARG_READ_ERR;
811
812 if arg = "-match"
813 then
814 do;
815 iarg = iarg + 1;
816 call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code,
817 arg_list_ptr);
818 if error_code ^= 0
819 then goto ARG_READ_ERR;
820
821 if arg_len >= 2 &
822 index (arg, "/") = 1 & index (reverse (arg), "/") = 1
823 then
824 do;
825
826 if arg_len = 2
827 then c = error_table_$regexp_undefined;
828 else call search_file_$silent (arg_ptr, 2,
829 arg_len - 2, arg_ptr, 1, arg_len, 0, 0, c);
830 if c ^= 0 & c ^= error_table_$nomatch
831 then
832 do;
833 call com_err_ (c, "print", "-match ^a", arg);
834 goto RETURN;
835 end;
836 end;
837
838 match_string_count = match_string_count + 1;
839 match_string_ptr (match_string_count) = arg_ptr;
840 match_string_len (match_string_count) = arg_len;
841 end;
842
843 else if arg = "-ex" | arg = "-exclude"
844 then
845 do;
846 arg_token = arg;
847 iarg = iarg + 1;
848 call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code,
849 arg_list_ptr);
850 if error_code ^= 0
851 then goto ARG_READ_ERR;
852
853 if arg_len >= 2 &
854 index (arg, "/") = 1 & index (reverse (arg), "/") = 1
855 then
856 do;
857
858 if arg_len = 2
859 then c = error_table_$regexp_undefined;
860 else call search_file_$silent (arg_ptr, 2,
861 arg_len - 2, arg_ptr, 1, arg_len, 0, 0, c);
862 if c ^= 0 & c ^= error_table_$nomatch
863 then
864 do;
865 call com_err_ (c, "print", "^a ^a", arg_token,
866 arg);
867 goto RETURN;
868 end;
869 end;
870
871 exclude_string_count = exclude_string_count + 1;
872 exclude_string_ptr (exclude_string_count) = arg_ptr;
873 exclude_string_len (exclude_string_count) = arg_len;
874 end;
875
876 else if arg = "-name" | arg = "-nm"
877 then iarg = iarg + 1;
878 end;
879
880 star_area_ptr = get_system_free_area_ ();
881 star_names_ptr, star_entry_ptr, star_entry_array_ptr, seg_ptr,
882 FCB_ptr = null;
883
884 on cleanup call CLEANER;
885
886 input_path_count = 0;
887
888
889
890 do iarg = 1 to nargs;
891 had_err = "0"b;
892 call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code,
893 arg_list_ptr);
894 if error_code ^= 0
895 then goto ARG_READ_ERR;
896
897 junk = cv_dec_check_ (arg, error_code);
898 if error_code = 0 & input_path_count > 0
899 then ;
900
901 else if index (arg, "-") = 1
902 then
903 do;
904 if arg = "-name" | arg = "-nm"
905 then
906 do;
907 iarg = iarg + 1;
908 call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len,
909 error_code, arg_list_ptr);
910 if error_code ^= 0
911 then goto ARG_READ_ERR;
912
913 goto segname;
914 end;
915
916 else if arg = "-from" | arg = "-fm" | arg = "-to"
917 | arg = "-for" | arg = "-from_page" | arg = "-to_page"
918 | arg = "-indent" | arg = "-ind" | arg = "-in"
919 | arg = "-left_col" | arg = "-lc" | arg = "-right_col"
920 | arg = "-rc" | arg = "-line_length" | arg = "-ll"
921 | arg = "-page_length" | arg = "-pl"
922 | arg = "-phys_page_length" | arg = "-ppl"
923 | arg = "-match" | arg = "-exclude" | arg = "-ex"
924 | arg = "-output_switch" | arg = "-osw" | arg = "-last"
925 | arg = "-lt"
926 then iarg = iarg + 1;
927 end;
928
929 else
930 do;
931 segname:
932 call expand_pathname_$component (arg, dir_name, entry_name,
933 archive_element, error_code);
934 if error_code ^= 0
935 then goto ARG_ERR;
936
937 input_path_count = input_path_count + 1;
938
939 call check_star_name_$entry (entry_name, entry_star_type);
940
941 if entry_star_type ^= type.NOSTAR
942 & entry_star_type ^= type.STAR
943 & entry_star_type ^= type.STARSTAR
944 then
945 do;
946 had_err = "1"b;
947 call com_err_ (entry_star_type, "print", "^a",
948 entry_name);
949 end;
950
951 else
952 do;
953 if archive_element = ""
954 then archive_element_star_type = type.NOSTAR;
955 else call check_star_name_$entry (archive_element,
956 archive_element_star_type);
957
958 if archive_element_star_type ^= type.NOSTAR
959 & archive_element_star_type ^= type.STAR
960 & archive_element_star_type ^= type.STARSTAR
961 then
962 do;
963 had_err = "1"b;
964 call com_err_ (archive_element_star_type, "print",
965 "^a", archive_element);
966 end;
967
968 else
969 do;
970 archive_elements_found = "0"b;
971
972 if entry_star_type = type.NOSTAR
973 then
974 call PRINT_ONE_ENTRYNAME (dir_name,
975 entry_name, archive_element,
976 star_SEGMENT);
977
978 else
979 do;
980 call hcs_$star_ (dir_name, entry_name,
981 star_sel, star_area_ptr,
982 star_entry_count, star_entry_ptr,
983 star_names_ptr, error_code);
984 if error_code ^= 0
985 then
986 do;
987 call com_err_ (error_code, "print",
988 "^a",
989 pathname_ (dir_name, entry_name))
990 ;
991 had_err = "1"b;
992 end;
993
994 else
995 do;
996 allocate star_entry_array
997 set (star_entry_array_ptr)
998 in (star_area);
999
1000 do star_entry_array_index = 1
1001 to star_entry_count;
1002 star_entry_array (
1003 star_entry_array_index) =
1004 star_entry_array_index;
1005 end;
1006
1007 call SORT_STAR_ARRAY;
1008
1009 do star_entry_array_index = 1
1010 to star_entry_count;
1011 star_entry_name =
1012 star_names (
1013 star_entries (
1014 star_entry_array (
1015 star_entry_array_index))
1016 .nindex);
1017 call PRINT_ONE_ENTRYNAME (dir_name,
1018 star_entry_name,
1019 archive_element,
1020 (
1021 star_entries (
1022 star_entry_array (
1023 star_entry_array_index)).type)
1024 );
1025 end;
1026 end;
1027
1028 call CLEANER;
1029 end;
1030 end;
1031 end;
1032
1033 if ^had_err & archive_element ^= "" & ^archive_elements_found
1034 then
1035 do;
1036 had_err = "1"b;
1037 error_code = error_table_$no_component;
1038
1039 call com_err_ (error_code, "print", "^a",
1040 pathname_$component (dir_name, entry_name,
1041 archive_element));
1042 end;
1043 end;
1044
1045 if had_err
1046 then ever_had_err = "1"b;
1047 end;
1048
1049 if ^ever_printed & ^ever_had_err
1050 then
1051 do;
1052 if sws.from_line_given & ^ever_found_from & ^sws.last_given
1053 then if from_regexpr_len > 0
1054 then call com_err_ (0, "print", "^a not matched.",
1055 from_regexpr);
1056 else call com_err_ (0, "print", "Line ^d not found.",
1057 from_line);
1058
1059 else if sws.from_page_given & ^ever_found_page
1060 then call com_err_ (0, "print", "Page ^d not found.", from_page);
1061
1062 else call com_err_ (0, "print", "No lines selected.");
1063 end;
1064
1065 else if sws.print_trailing_nls & ^ever_had_err
1066 then call ioa_$ioa_switch (out_switch, "^/");
1067
1068
1069
1070 ^L
1071
1072
1073 SORT_STAR_ARRAY:
1074 proc;
1075
1076 dcl d fixed bin,
1077 swap bit (1),
1078 t fixed bin;
1079
1080 d = star_entry_count;
1081 do while (d > 1);
1082 d = divide (d + 1, 2, 17, 0);
1083 swap = "1"b;
1084 do while (swap);
1085 swap = "0"b;
1086 do star_entry_array_index = 1 to star_entry_count - d;
1087 if star_names (
1088 star_entries (star_entry_array (star_entry_array_index))
1089 .nindex)
1090 >
1091 star_names (
1092 star_entries (star_entry_array (star_entry_array_index + d))
1093 .nindex)
1094 then
1095 do;
1096 swap = "1"b;
1097 t = star_entry_array (star_entry_array_index);
1098 star_entry_array (star_entry_array_index) =
1099 star_entry_array (star_entry_array_index + d);
1100 star_entry_array (star_entry_array_index + d) = t;
1101 end;
1102 end;
1103 end;
1104 end;
1105
1106 end SORT_STAR_ARRAY;
1107 %page;
1108 CLEANER:
1109 proc;
1110
1111 if star_names_ptr ^= null
1112 then free star_names in (star_area);
1113
1114 if star_entry_ptr ^= null
1115 then free star_entries in (star_area);
1116
1117 if star_entry_array_ptr ^= null
1118 then free star_entry_array in (star_area);
1119
1120 if FCB_ptr ^= null
1121 then call msf_manager_$close (FCB_ptr);
1122
1123 else if seg_ptr ^= null
1124 then call terminate_file_ (seg_ptr, (0), TERMINATE_SEG, (0));
1125
1126 star_names_ptr, star_entry_ptr, star_entry_array_ptr, seg_ptr, FCB_ptr =
1127 null;
1128
1129 end CLEANER;
1130 %page (2);
1131
1132
1133
1134
1135
1136 PRINT_ONE_ENTRYNAME:
1137 proc (dirname, ename, arch_elem_wanted, en_type);
1138
1139 dcl dirname char (168);
1140 dcl ename char (32);
1141 dcl arch_elem_wanted char (32);
1142 dcl en_type fixed bin (2) uns;
1143
1144
1145 dcl 1 sws1,
1146 2 doing_archive bit (1),
1147 2 found_first bit (1),
1148 2 found_last bit (1),
1149 2 found_to bit (1),
1150 2 last_msf_component bit (1),
1151
1152 2 more_in_archive bit (1),
1153 2 print_heading_first
1154 bit (1),
1155 2 stop_after_first_elem
1156 bit (1),
1157 2 paused bit (1);
1158
1159 dcl 1 ACI like archive_component_info aligned;
1160 dcl (
1161 ARCH_COMP init (3),
1162 MSF_COMP init (2),
1163 SEG init (1)
1164 ) fixed bin int static options (constant);
1165 dcl bitc fixed bin (24);
1166 dcl comp_ptr ptr;
1167
1168 dcl component char (seg_charct) based (comp_ptr);
1169 dcl ec1 fixed bin (35);
1170 dcl entry_type fixed bin (2);
1171 dcl error_code fixed bin (35);
1172 dcl indent_string char (indentation) init ("");
1173 dcl last_line_number fixed bin;
1174 dcl line_count fixed bin;
1175 dcl last_slew char (1);
1176 dcl line_length fixed bin (21);
1177 dcl line_number fixed bin;
1178 dcl msf_component fixed bin;
1179 dcl msf_component_count fixed bin (24);
1180 dcl output_buffer char (MAX_BUFFER_LTH);
1181 dcl output_buffer_ch (MAX_BUFFER_LTH) char (1)
1182 defined output_buffer;
1183 dcl output_buffer_length fixed bin (21);
1184 dcl page_number fixed bin;
1185 dcl seg_charct fixed bin (21);
1186 dcl seg_type fixed bin;
1187
1188 dcl segment char (seg_charct) based (seg_ptr);
1189 dcl slew char (1);
1190 dcl vt_length fixed bin (21);
1191 dcl wanted_elem char (32);
1192
1193 call iox_$control (out_switch, "reset_more", null (), (0));
1194
1195
1196 last_line_number = 0;
1197 last_slew = NUL;
1198 sws1.doing_archive, sws1.found_to, sws1.paused = "0"b;
1199 sws1.last_msf_component = "1"b;
1200
1201 call initiate_file_ (dirname, ename, R_ACCESS, seg_ptr, bitc, error_code);
1202
1203 if seg_ptr = null
1204 then
1205 do;
1206 call hcs_$status_minf (dirname, ename, 1, entry_type,
1207 msf_component_count, ec1);
1208 if ec1 ^= 0
1209 then
1210 do;
1211 if en_type = star_LINK
1212 then return;
1213
1214 else
1215 do;
1216 error_code = ec1;
1217 abort:
1218 call com_err_ (error_code, "print", "^a",
1219 pathname_ (dirname, ename));
1220 had_err = "1"b;
1221 return;
1222 end;
1223 end;
1224
1225 if entry_type ^= star_DIRECTORY
1226 then goto abort;
1227
1228
1229
1230 if msf_component_count < 1
1231 then
1232 do;
1233 if en_type ^= star_SEGMENT
1234 then return;
1235 error_code = error_table_$dirseg;
1236
1237 goto abort;
1238 end;
1239
1240
1241
1242 else
1243 do;
1244 seg_type = MSF_COMP;
1245 call msf_manager_$open (dirname, ename, FCB_ptr, error_code);
1246 if error_code ^= 0
1247 then goto abort;
1248
1249 call RESET;
1250
1251 if sws.last_given
1252 then
1253 do;
1254 from_line = 0;
1255
1256 if sws.to_line_given & to_regexpr_len = 0
1257 then from_line = max (to_line - last_count + 1, 1);
1258
1259 else
1260 do;
1261 do msf_component = 0
1262 to msf_component_count - 1
1263 while (^sws1.found_to);
1264 call msf_manager_$get_ptr (FCB_ptr,
1265 msf_component, "0"b, comp_ptr, bitc,
1266 error_code);
1267 if error_code ^= 0
1268 then goto MSF_err;
1269
1270 seg_charct = divide (bitc + 8, 9, 21, 0);
1271
1272 if seg_charct > 0
1273 then
1274 do;
1275 call COUNT_LINES (component,
1276 msf_component
1277 = msf_component_count - 1,
1278 line_count, sws1.found_to);
1279 from_line = from_line + line_count;
1280 end;
1281 end;
1282 from_line = max (from_line - last_count + 1, 1);
1283 end;
1284 end;
1285
1286 line_number = 1;
1287 sws1.paused = "0"b;
1288
1289 do msf_component = 0 to msf_component_count - 1
1290 while (^sws1.found_last);
1291
1292 call msf_manager_$get_ptr (FCB_ptr, msf_component, "0"b,
1293 comp_ptr, bitc, error_code);
1294 if error_code ^= 0
1295 then goto MSF_err;
1296
1297 sws1.last_msf_component =
1298 (msf_component = msf_component_count - 1);
1299 seg_charct = divide (bitc + 8, 9, 21, 0);
1300 if seg_charct = 0
1301 then error_code = error_table_$zero_length_seg;
1302
1303 else call PRINT_ONE_SEG (component);
1304
1305 if ^sws1.last_msf_component
1306 then if substr (component, seg_charct, 1) ^= NL
1307 then line_number = line_number - 1;
1308 end;
1309
1310 MSF_err:
1311 if error_code ^= 0
1312 then
1313 do;
1314 had_err = "1"b;
1315 call com_err_ (error_code, "print",
1316 "Component ^d of multisegment file ^a.",
1317 msf_component, pathname_ (dirname, ename));
1318 end;
1319
1320 call msf_manager_$close (FCB_ptr);
1321 end;
1322 return;
1323 end;
1324
1325
1326
1327 error_code = 0;
1328 sws1.doing_archive =
1329 arch_elem_wanted ^= ""
1330 | (^sws.dont_want_archive
1331 & index (reverse (rtrim (ename)), reverse (".archive")) = 1);
1332
1333
1334
1335 if sws1.doing_archive
1336 then
1337 do;
1338 seg_type = ARCH_COMP;
1339 stop_after_first_elem = (archive_element_star_type = type.NOSTAR);
1340
1341 if arch_elem_wanted = ""
1342 then
1343 do;
1344 wanted_elem = "**";
1345 stop_after_first_elem = "0"b;
1346 end;
1347 else wanted_elem = arch_elem_wanted;
1348
1349 comp_ptr = null;
1350 ACI.version = ARCHIVE_COMPONENT_INFO_VERSION_1;
1351 sws1.more_in_archive = "1"b;
1352
1353 do while (sws1.more_in_archive & error_code = 0);
1354 call archive_$next_component_info (seg_ptr, bitc, comp_ptr,
1355 addr (ACI), error_code);
1356 if error_code = 0
1357 then
1358 do;
1359 if comp_ptr = null
1360 then sws1.more_in_archive = "0"b;
1361
1362 else
1363 do;
1364 call match_star_name_ (ACI.name, wanted_elem,
1365 error_code);
1366 if error_code ^= 0
1367 then error_code = 0;
1368 else
1369 do;
1370 call RESET;
1371
1372 seg_charct =
1373 divide (ACI.comp_bc + 8, 9, 21, 0);
1374 if seg_charct = 0
1375 then
1376 do;
1377 call com_err_ (
1378 error_table_$zero_length_seg,
1379 "print", "^a",
1380 pathname_$component (dirname, ename,
1381 ACI.name));
1382 had_err = "1"b;
1383 end;
1384
1385 else
1386 do;
1387 archive_elements_found = "1"b;
1388
1389 if sws.last_given
1390
1391 then
1392 do;
1393 if sws.to_line_given
1394 & to_regexpr_len = 0
1395 then from_line =
1396 max (to_line
1397 - last_count + 1, 1);
1398 else
1399 do;
1400 call COUNT_LINES (component,
1401 "1"b, from_line,
1402 sws1.found_to);
1403 from_line =
1404 max (from_line
1405 - last_count + 1, 1);
1406 end;
1407 end;
1408
1409 line_number = 1;
1410 sws1.paused = "0"b;
1411
1412 call iox_$control (out_switch,
1413 "reset_more", null (), (0));
1414
1415
1416
1417 call PRINT_ONE_SEG (component);
1418
1419 if stop_after_first_elem
1420 then sws1.more_in_archive = "0"b;
1421 end;
1422 end;
1423 end;
1424 end;
1425 end;
1426 end;
1427
1428
1429
1430 else
1431 do;
1432 seg_type = SEG;
1433 call RESET;
1434
1435 seg_charct = divide (bitc + 8, 9, 21, 0);
1436 if seg_charct ^= 0
1437 then
1438 do;
1439 if sws.last_given
1440 then
1441 do;
1442 if sws.to_line_given & to_regexpr_len = 0
1443 then from_line = max (to_line - last_count + 1, 1);
1444 else
1445 do;
1446 call COUNT_LINES (segment, "1"b, from_line,
1447 sws1.found_to);
1448 from_line = max (from_line - last_count + 1, 1);
1449 end;
1450 end;
1451
1452 line_number = 1;
1453 sws1.paused = "0"b;
1454
1455 call PRINT_ONE_SEG (segment);
1456 end;
1457
1458 else error_code = error_table_$zero_length_seg;
1459 end;
1460
1461 call terminate_file_ (seg_ptr, (0), TERMINATE_SEG, (0));
1462
1463 seg_ptr = null;
1464 if error_code ^= 0
1465 then
1466 do;
1467 had_err = "1"b;
1468 call com_err_ (error_code, "print", "^a",
1469 pathname_ (dirname, ename));
1470 end;
1471
1472 return;
1473 %page;
1474
1475
1476 RESET:
1477 proc;
1478
1479 sws1.print_heading_first = sws.want_heading;
1480
1481 pci.level, pci.pos, pci.slew_residue, pci.sav_pos, pci.esc_state,
1482 pci.esc_num = 0;
1483 pci.temp, sws1.found_first, sws1.found_last = "0"b;
1484 page_number, pci.line = 1;
1485 line_count = 0;
1486 slew = NL;
1487 end RESET;
1488 %page;
1489
1490
1491 COUNT_LINES:
1492 proc (seg, last_seg, lines, found_to);
1493
1494
1495
1496 dcl seg char (*);
1497 dcl last_seg bit (1);
1498 dcl lines fixed bin;
1499 dcl found_to bit (1);
1500
1501
1502
1503 dcl c fixed bin (35),
1504 char_index fixed bin (21);
1505
1506 char_index = 0;
1507 lines = 0;
1508
1509 do while (char_index < seg_charct);
1510 line_length = index (substr (seg, char_index + 1), NL);
1511 if line_length > 0
1512 then lines = lines + 1;
1513 else
1514 do;
1515 if last_seg
1516 then
1517 lines = lines + 1;
1518 line_length = length (substr (seg, char_index + 1));
1519 end;
1520
1521 if to_regexpr_len > 0
1522 then
1523 do;
1524 call search_file_ (to_regexpr_ptr, 2, to_regexpr_len, addr (seg),
1525 char_index + 1, char_index + line_length, 0, 0, c);
1526 if c = 0
1527 then
1528 do;
1529 found_to = "1"b;
1530 if substr (seg, char_index + line_length, length (NL))
1531 ^= NL
1532 then
1533 lines = lines + 1;
1534 return;
1535 end;
1536 end;
1537 char_index = char_index + line_length;
1538 end;
1539
1540 end COUNT_LINES;
1541 %page;
1542
1543
1544
1545
1546
1547
1548 PRINT_ONE_SEG:
1549 proc (segment);
1550
1551 dcl segment char (*);
1552
1553 dcl char_index fixed bin (21);
1554 dcl line_count_this_page fixed bin;
1555 dcl line_length fixed bin (21);
1556 dcl print_this_line bit (1);
1557 dcl region_begin fixed bin (21);
1558 dcl seg_ptr ptr;
1559 dcl segarray (seg_charct) char (1) based (seg_ptr);
1560
1561 seg_ptr = addr (segment);
1562
1563 char_index, line_count_this_page = 0;
1564
1565 if (sws.print_quick_way & sws.one_iox_call)
1566 then
1567 PRINT_QUICK_WAY:
1568 do;
1569 if sws.pause_before_print
1570 then call PAUSE;
1571
1572 call PRINT_HEAD;
1573 call PRINT_STRING (seg_ptr, seg_charct);
1574 ever_printed = "1"b;
1575 return;
1576 end PRINT_QUICK_WAY;
1577
1578 PRINT_SEG:
1579 do while (char_index < seg_charct & ^sws1.found_last);
1580
1581
1582 line_length = index (substr (segment, char_index + 1), NL);
1583 if line_length = 0
1584 then line_length = length (substr (segment, char_index + 1));
1585
1586 call PRINT_ONE_LINE ();
1587 line_number = line_number + 1;
1588
1589 end PRINT_SEG;
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599 if (seg_type ^= MSF_COMP | sws1.last_msf_component)
1600 &
1601 ^(pci.line = 1 & pci.pos = 0 & pci.level = 0 & pci.slew_residue = 0)
1602 then
1603 do;
1604
1605 if pci.pos > 0 | pci.slew_residue = -1
1606 then
1607 do;
1608 slew = NL;
1609 call SLEW ();
1610 end;
1611
1612 if sws.paging
1613 then
1614 do;
1615 slew = NP;
1616 call SLEW ();
1617 end;
1618 end;
1619
1620 return;
1621 %page;
1622
1623
1624
1625
1626
1627 PRINT_ONE_LINE:
1628 proc;
1629
1630 print_this_line = "1"b;
1631
1632 call CHECK_FROM_LINE ();
1633 if print_this_line
1634 then call CHECK_TO_LINE ();
1635 if print_this_line
1636 then print_this_line = MATCH_EXCLUDE ();
1637
1638 if print_this_line
1639 then
1640 if sws.to_page_given
1641 then if page_number > to_page
1642 then
1643 do;
1644 sws1.found_last = "1"b;
1645 return;
1646 end;
1647
1648 if print_this_line & (page_number >= from_page)
1649 then
1650 do;
1651 if sws.pause_before_print & ^sws1.paused
1652 then
1653 do;
1654 call PAUSE;
1655 sws1.paused = "1"b;
1656 end;
1657
1658 call PRINT_HEAD;
1659 ever_found_page = "1"b;
1660 ever_printed = "1"b;
1661 end;
1662 else print_this_line = "0"b;
1663
1664 if sws.print_quick_way
1665 then
1666 do;
1667 if print_this_line
1668 then call PROCESS_LINE_VIA_IOX (addr (segarray (char_index + 1)),
1669 line_length);
1670
1671 end;
1672 else
1673 do;
1674 if ^sws.no_vertsp
1675 then
1676 do;
1677 vt_length =
1678 index (substr (segment, char_index + 1, line_length), VT)
1679 ;
1680 do while (vt_length > 0);
1681 call
1682 PROCESS_LINE_VIA_PRT_CONV (
1683 addr (segarray (char_index + 1)), vt_length,
1684 print_this_line, "0"b, "1"b);
1685 char_index = char_index + vt_length;
1686 line_length = line_length - vt_length;
1687 vt_length =
1688 index (substr (segment, char_index + 1, line_length),
1689 VT);
1690 end;
1691 end;
1692
1693 call
1694 PROCESS_LINE_VIA_PRT_CONV (addr (segarray (char_index + 1)),
1695 line_length, print_this_line, "0"b, "0"b);
1696 end;
1697
1698 char_index = char_index + line_length;
1699
1700 if forcount > 0
1701 then
1702 do;
1703 if line_count >= forcount
1704 then
1705 do;
1706 sws1.found_last = "1"b;
1707 seg_charct = char_index + line_length;
1708 end;
1709 end;
1710
1711 end PRINT_ONE_LINE;
1712 %page;
1713
1714
1715 CHECK_FROM_LINE:
1716 proc;
1717
1718 dcl c fixed bin (35);
1719
1720 region_begin = char_index;
1721 if sws1.found_first
1722 then return;
1723
1724 if from_regexpr_len > 0
1725 then
1726 do;
1727 call search_file_ (from_regexpr_ptr, 2, from_regexpr_len,
1728 addr (segment), char_index + 1, char_index + line_length, 0, 0,
1729 c);
1730 if c = 0
1731 then
1732 do;
1733 ever_found_from, sws1.found_first = "1"b;
1734 from_line = line_number;
1735 end;
1736 else print_this_line = "0"b;
1737 end;
1738 else if line_number >= from_line
1739 then ever_found_from, sws1.found_first = "1"b;
1740 else print_this_line = "0"b;
1741
1742 end CHECK_FROM_LINE;
1743 %page;
1744
1745
1746 CHECK_TO_LINE:
1747 proc;
1748
1749 dcl c fixed bin (35);
1750
1751 if ^sws.to_line_given & (forcount = 0)
1752 then return;
1753
1754 if to_regexpr_len > 0
1755 then
1756 do;
1757 call search_file_ (to_regexpr_ptr, 2, to_regexpr_len,
1758 addr (segment), char_index + 1, char_index + line_length, 0, 0,
1759 c);
1760 if c = 0
1761 then
1762 do;
1763 sws1.found_last = "1"b;
1764 seg_charct = char_index + line_length;
1765 end;
1766 end;
1767
1768 else if to_line > 0
1769 then
1770 do;
1771 if line_number >= to_line
1772 then
1773 do;
1774 if substr (segment, char_index + line_length, 1) = NL
1775 then
1776 do;
1777 sws1.found_last = "1"b;
1778 seg_charct = char_index + line_length;
1779 end;
1780 end;
1781 end;
1782
1783 end CHECK_TO_LINE;
1784 %page;
1785
1786
1787 LINENO_AND_INDENT:
1788 proc (strike_level, chars_for_line);
1789
1790 dcl strike_level fixed bin,
1791 chars_for_line fixed bin (21);
1792
1793 if last_slew = ""
1794 then
1795 do;
1796 last_line_number = line_number;
1797 last_slew = slew;
1798 return;
1799 end;
1800
1801 if sws.want_line_numbers
1802 then if strike_level = 0 & last_slew ^= CR
1803 then if line_number ^= last_line_number
1804 then call ioa_$ioa_switch_nnl (out_switch, "^8i ", line_number)
1805 ;
1806 else call ioa_$ioa_switch_nnl (out_switch, "^8i+ ", line_number)
1807 ;
1808 else call ioa_$ioa_switch_nnl (out_switch, "^-");
1809 last_line_number = line_number;
1810 last_slew = slew;
1811
1812 if indentation > 0 & chars_for_line > 0
1813 then call PRINT_STRING (addr (indent_string), indentation);
1814
1815 end LINENO_AND_INDENT;
1816 %page (2);
1817
1818
1819
1820
1821
1822 MATCH_EXCLUDE:
1823 proc returns (bit (1));
1824
1825 dcl jj fixed bin;
1826 dcl c fixed bin (35);
1827 dcl srchp ptr,
1828 srchl fixed bin (21);
1829 dcl srch char (srchl) based (srchp);
1830 dcl (matched, excluded) bit (1);
1831
1832 if ^sws.check_lines
1833 then return ("1"b);
1834
1835 matched = "0"b;
1836 do jj = 1 to match_string_count while (^matched);
1837 srchp = match_string_ptr (jj);
1838 srchl = match_string_len (jj);
1839
1840 if srchl > 2 & index (srch, "/") = 1 & index (reverse (srch), "/") = 1
1841 then
1842 do;
1843 call search_file_ (srchp, 2, srchl - 2, addr (segment),
1844 char_index + 1, char_index + line_length, 0, 0, c);
1845 if c = 0
1846 then matched = "1"b;
1847 end;
1848
1849 else if index (substr (segment, char_index + 1, line_length), srch)
1850 ^= 0
1851 then matched = "1"b;
1852 end;
1853
1854 if match_string_count > 0 & ^matched
1855 then return ("0"b);
1856
1857 excluded = "0"b;
1858 do jj = 1 to exclude_string_count;
1859 srchp = exclude_string_ptr (jj);
1860 srchl = exclude_string_len (jj);
1861
1862 if srchl > 2 & index (srch, "/") = 1 & index (reverse (srch), "/") = 1
1863 then
1864 do;
1865 call search_file_ (srchp, 2, srchl - 2, addr (segment),
1866 char_index + 1, char_index + line_length, 0, 0, c);
1867 if c = 0
1868 then excluded = "1"b;
1869 end;
1870
1871 else if index (substr (segment, char_index + 1, line_length), srch)
1872 ^= 0
1873 then excluded = "1"b;
1874 end;
1875
1876 return (^excluded);
1877
1878 end MATCH_EXCLUDE;
1879 %page;
1880
1881
1882 PAUSE:
1883 proc;
1884
1885 dcl buffer char (256);
1886
1887 error_code = error_table_$long_record;
1888 do while (error_code = error_table_$long_record);
1889
1890 call iox_$get_line (iox_$user_input, addr (buffer), 256, (0),
1891 error_code);
1892 end;
1893
1894 call iox_$control (iox_$user_input, "resetread", null, (0));
1895
1896 end PAUSE;
1897
1898 %page;
1899
1900
1901
1902
1903
1904 PRINT_HEAD:
1905 proc;
1906
1907 dcl date char (64) var,
1908 head_line char (250),
1909 head_line_len fixed bin (21);
1910
1911 if ^sws1.print_heading_first
1912 then return;
1913
1914 if sws1.doing_archive
1915 then
1916 do;
1917 date = date_time_$format ("date_time", ACI.time_modified, "", "");
1918 call ioa_$rsnp ("^/^2-^a::^a^-^a^/", head_line, head_line_len,
1919 ename, ACI.name, date);
1920 end;
1921
1922 else
1923 do;
1924 date = date_time_$format ("date_time", clock (), "", "");
1925 call ioa_$rsnp ("^/^2-^a^-^a^2/", head_line, head_line_len, ename,
1926 date);
1927 end;
1928 if sws.print_quick_way | sws.one_iox_call
1929 then call PRINT_STRING (addr (head_line), head_line_len);
1930 else
1931 do;
1932 call PROCESS_LINE_VIA_PRT_CONV (addr (head_line), head_line_len,
1933 "1"b, "1"b, "0"b);
1934 line_count = line_count - 1;
1935 end;
1936 sws1.print_heading_first = "0"b;
1937
1938 end PRINT_HEAD;
1939 %page;
1940
1941
1942 PRINT_STRING:
1943 proc (ptr, len);
1944
1945 dcl ptr ptr,
1946 len fixed bin (21);
1947
1948 call iox_$put_chars (out_switch, ptr, len, error_code);
1949 if error_code ^= 0
1950 then
1951 do;
1952 call com_err_ (error_code, "print", "Writing to switch ^a.",
1953 switch_name);
1954 go to RETURN;
1955 end;
1956
1957 end PRINT_STRING;
1958 %page;
1959
1960
1961
1962
1963
1964
1965 PROCESS_LINE_VIA_IOX:
1966 proc (line_ptr_parm, line_len_parm);
1967
1968 dcl line_ptr_parm ptr,
1969 line_len_parm fixed bin (21);
1970
1971 dcl end_of_output_line fixed bin (21);
1972
1973
1974 dcl line_len fixed bin (21),
1975 line_ptr ptr,
1976 line char (line_len) based (line_ptr),
1977 line_array (line_len) char (1) based (line_ptr);
1978
1979 line_ptr = line_ptr_parm;
1980 line_len = line_len_parm;
1981
1982 do while (line_len > 0);
1983 end_of_output_line = search (line, NLCRVTNP);
1984 if end_of_output_line > 0
1985 then
1986 do;
1987 slew = line_array (end_of_output_line);
1988 end_of_output_line = end_of_output_line - 1;
1989 end;
1990
1991 else
1992 do;
1993 slew = "";
1994 end_of_output_line = length (line);
1995 end;
1996
1997 ever_found_page = "1"b;
1998 call LINENO_AND_INDENT (0, end_of_output_line);
1999
2000 if end_of_output_line ^= 0
2001 then call PRINT_STRING (addr (line), end_of_output_line);
2002
2003 call SLEW ();
2004
2005 if (end_of_output_line + 1) < line_len
2006 then line_ptr = addr (line_array (end_of_output_line + 2));
2007 line_len = line_len - (end_of_output_line + 1);
2008
2009 end;
2010
2011 line_count = line_count + 1;
2012
2013 end PROCESS_LINE_VIA_IOX;
2014 %page;
2015
2016
2017
2018
2019
2020
2021
2022
2023 PROCESS_LINE_VIA_PRT_CONV:
2024 proc (line_ptr_parm, line_len_parm, print_this_line, header, vertical_tab);
2025
2026 dcl line_ptr_parm ptr,
2027 line_len_parm fixed bin (21),
2028 print_this_line bit (1),
2029
2030
2031
2032
2033
2034 header bit (1),
2035 vertical_tab bit (1);
2036
2037
2038 dcl chars_done fixed bin (21);
2039 dcl chars_for_line fixed bin (21);
2040 dcl chars_to_do fixed bin (21);
2041 dcl (saved_line_length, saved_rmarg)
2042 fixed bin;
2043
2044 dcl line_len fixed bin (21),
2045 line_ptr ptr,
2046 line char (line_len) based (line_ptr),
2047 line_array (line_len) char (1) based (line_ptr);
2048
2049 if header
2050 then
2051 do;
2052 saved_line_length = pci.phys_line_length;
2053 pci.phys_line_length = length (output_buffer);
2054 saved_rmarg = pci.rmarg;
2055 pci.rmarg = length (output_buffer);
2056 end;
2057
2058 line_ptr = line_ptr_parm;
2059 line_len = line_len_parm;
2060
2061 chars_to_do = length (line);
2062 do while (chars_to_do > 0 | pci.slew_residue > 0);
2063 line_count_this_page = pci.line;
2064
2065
2066 call prt_conv_ (addr (line), chars_to_do, addr (output_buffer),
2067 output_buffer_length, addr (pci));
2068 chars_done = length (line) - chars_to_do;
2069
2070 if chars_done > 0
2071
2072
2073
2074 then line_ptr = addr (line_array (chars_done));
2075
2076 slew = output_buffer_ch (output_buffer_length);
2077
2078 output_buffer_length = output_buffer_length - 1;
2079
2080
2081
2082 if vertical_tab & slew = NL
2083 then
2084 do;
2085 slew = VT;
2086 pci.slew_residue = 0;
2087 end;
2088
2089 if header
2090
2091 then chars_for_line = output_buffer_length;
2092 else chars_for_line =
2093 min (right_col, output_buffer_length) - left_col + 1;
2094
2095
2096 if chars_for_line < 0
2097 then chars_for_line = 0;
2098
2099 if print_this_line & (page_number >= from_page)
2100 then
2101 do;
2102 ever_found_page = "1"b;
2103 if ^header
2104 then call LINENO_AND_INDENT (pci.level, chars_for_line);
2105 call PRINT_STRING (addr (output_buffer_ch (left_col)),
2106 chars_for_line);
2107 call SLEW ();
2108 end;
2109 if chars_done < line_len
2110 then line_ptr = addr (line_array (2));
2111 line_len = line_len - chars_done;
2112
2113
2114
2115
2116
2117 if slew = NP
2118 then
2119 do;
2120 page_number = page_number + 1;
2121 if sws.to_page_given
2122 then
2123 do;
2124 if page_number > to_page
2125 then
2126 do;
2127 sws1.found_last = "1"b;
2128 return;
2129 end;
2130 end;
2131 end;
2132 end;
2133
2134 if header
2135 then
2136 do;
2137 pci.phys_line_length = saved_line_length;
2138 pci.rmarg = saved_rmarg;
2139 end;
2140
2141 line_count = line_count + 1;
2142
2143 end PROCESS_LINE_VIA_PRT_CONV;
2144 %page;
2145
2146
2147 SLEW:
2148 proc;
2149
2150 dcl needct fixed bin;
2151
2152 if slew = ""
2153 then return;
2154
2155 if slew = CR
2156 then go to real_slew;
2157
2158 if slew = NP
2159 then
2160 do;
2161 if sws.pause_after_page
2162 then
2163 do;
2164 call PRINT_STRING (addr (NL), 1);
2165 call PAUSE;
2166 end;
2167 else if ^sws.no_vertsp
2168 then goto real_slew;
2169
2170 else
2171 do;
2172 needct = pci.phys_page_length - line_count_this_page + 1;
2173 call ioa_$ioa_switch_nnl (out_switch, "^v/", needct);
2174 line_count_this_page = 0;
2175 end;
2176 end;
2177
2178 else if slew = VT
2179 then go to real_slew;
2180
2181
2182 else
2183 do;
2184 line_count_this_page = line_count_this_page + 1;
2185 real_slew:
2186 call PRINT_STRING (addr (slew), 1);
2187 end;
2188
2189 end SLEW;
2190
2191 end PRINT_ONE_SEG;
2192
2193 end PRINT_ONE_ENTRYNAME;
2194
2195 end;
2196 ^L
2197 %include prt_conv_info;
2198
2199 dcl 1 PCI like pci aligned;
2200 %page;
2201 %include star_structures;
2202 %page;
2203 %include archive_component_info;
2204 %page;
2205 %include access_mode_values;
2206
2207 end print;