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 add_pnotice:
74 proc;
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94 %page;
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125 %page;
126
127
128
129
130 dcl current_year fixed bin,
131 current_year_a char (4),
132 DFcopy_right bit (1),
133 DFtrade_secret bit (1),
134 Farchive bit (1),
135 Fdisplay bit (1),
136 Fcopy_right bit (1),
137 Fmode_set bit (1),
138 Fmust_reset bit (1),
139 Fname bit (1),
140 Fpublic_domain bit (1),
141 Ftrade_secret bit (1),
142 i fixed bin (24),
143 Iarg fixed bin,
144 Idx1 fixed bin (24),
145 Itemplate fixed bin (24),
146 Larg fixed bin (21),
147 ME char (32),
148 Nargs fixed bin,
149 Parg ptr,
150 bit_count fixed bin (24),
151 code fixed bin (35),
152 common_archive_name
153 char (32),
154 component char (32),
155 doing_all_components
156 bit (1),
157 path char (168),
158 pdir char (168) var,
159 process_dir char (168),
160 save_name char (32),
161 save_text char (512) var,
162 seqno fixed bin (18),
163 SI_yrno fixed bin (24),
164 Sadd_default_pnotice
165 bit (1),
166 Sdfcopyright bit (1),
167 Sno_args_given bit (1),
168 Sold_style_pnotice
169 bit (1),
170 Sprt_notice bit (1),
171 source_year (10) fixed bin,
172 source_year_a (10) char (4),
173 used_old_argument
174 bit (1);
175
176
177
178
179 dcl add_char_offset_
180 entry (ptr, fixed bin (21)) returns (ptr) reducible,
181 archive entry options (variable),
182 archive_$get_component
183 entry (ptr, fixed bin (24), char (*), ptr,
184 fixed bin (24), fixed bin (35)),
185 archive_$next_component
186 entry (ptr, fixed bin (24), ptr, fixed bin (24),
187 char (*), fixed bin (35)),
188 char_offset_ entry (ptr) returns (fixed bin (21)) reducible,
189 check_star_name_$entry
190 entry (char (*), fixed bin (35)),
191 com_err_ entry () options (variable),
192 cu_$arg_count entry (fixed bin, fixed bin (35)),
193 cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
194 cu_$generate_call
195 entry (entry, ptr),
196 date_time_$format
197 entry (char (*), fixed bin (71), char (*), char (*))
198 returns (char (250) var),
199 expand_pathname_$component
200 entry (char (*), char (*), char (*), char (*),
201 fixed bin (35)),
202 get_ec_version_
203 entry (char (*), char (*), fixed bin, fixed bin (21),
204 fixed bin (35)),
205 get_group_id_ entry () returns (char (32)),
206 get_pdir_ entry () returns (char (168)),
207 get_temp_segment_
208 entry (char (*), ptr, fixed bin (35)),
209 hcs_$add_acl_entries
210 entry (char (*), char (*), ptr, fixed bin,
211 fixed bin (35)),
212 hcs_$delentry_seg
213 entry (ptr, fixed bin (35)),
214 hcs_$delete_acl_entries
215 entry (char (*), char (*), ptr, fixed bin,
216 fixed bin (35)),
217 hcs_$initiate_count
218 entry (char (*), char (*), char (*), fixed bin (24),
219 fixed bin (2), ptr, fixed bin (35)),
220 hcs_$list_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin,
221 fixed bin (35)),
222 hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr,
223 fixed bin (35)),
224 ioa_ entry () options (variable),
225 pathname_ entry (char (*), char (*)) returns (char (168)),
226 pathname_$component
227 entry (char (*), char (*), char (*))
228 returns (char (194)),
229 pnotice_mlr_ entry (ptr, fixed bin (21), ptr, fixed bin (21)),
230 pnotice_mrl_ entry (ptr, fixed bin (21), ptr, fixed bin (21)),
231 pnotice_paths_ entry (char (*), bit (*), ptr, fixed bin (35)),
232 release_temp_segment_
233 entry (char (*), ptr, fixed bin (35)),
234 terminate_file_
235 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
236
237
238
239 dcl Inconsistent_args
240 char (132) varying int static
241 init (
242 "^/The ""^a"" and ""^a"" may not be used together"),
243 Not_found char (132) varying int static
244 init (
245 "^/""^a"" not found in the pnotice search list.^/Use list pnotice_names to list valid names."
246 ),
247 True bit (1) int static options (constant) init ("1"b),
248 False bit (1) int static options (constant) init ("0"b),
249 sfx_string char (3) int static options (constant) init (" *
250 "),
251 STAR char (1) int static options (constant) init ("*"),
252 STARS char (200) int static options (constant)
253 init ((200)"*"),
254 SP_STAR char (2) int static options (constant) init (" *"),
255 SP_STAR_SP char (3) int static options (constant) init (" * "),
256 HT_SP_STAR char (3) int static options (constant) init (" *"),
257 HT_SP_NL char (3) int static options (constant) init ("
258 "),
259 SP char (1) int static options (constant) init (" "),
260 SPACES char (200) int static options (constant)
261 init ((200)" "),
262 NL char (1) int static options (constant) init ("
263 "),
264 NL_NL char (2) int static options (constant) init ("
265
266 "),
267 HT_SP_NL_VT_NP char (5) int static options (constant) init ("
268 ^K^L");
269
270
271
272
273 dcl (
274 error_table_$archive_component_modification,
275 error_table_$badopt,
276 error_table_$bad_file_name,
277 error_table_$improper_data_format,
278 error_table_$inconsistent,
279 error_table_$noarg,
280 error_table_$not_done,
281 error_table_$name_not_found,
282 error_table_$nostars,
283 error_table_$typename_not_found,
284 error_table_$wrong_no_of_args
285 ) fixed bin (35) ext static;
286
287
288
289 dcl (addr, addrel, addcharno, before, char, charno, clock, convert,
290 currentsize, dim, divide, hbound, index, length, lbound, ltrim, max,
291 null, ptr, reverse, rtrim, search, string, substr, verify)
292 builtin;
293
294
295
296 dcl argument char (Larg) based (Parg);
297
298
299
300
301 dcl (cleanup, not_in_write_bracket, no_write_permission)
302 condition;
303
304 %page;
305
306
307
308 ME = "add_pnotice";
309 Fdisplay = False;
310 goto COMMON;
311
312
313
314
315 display_pnotice:
316 entry;
317
318 ME = "display_pnotice";
319 Fdisplay = True;
320
321
322
323
324 COMMON:
325 arg_list_arg_count = 0;
326 Ppaths = null;
327 Pcomp_info = null;
328 Ptext = null;
329 path = "";
330 Farchive = False;
331 Sprt_notice = False;
332 current_year_a = date_time_$format ("^9999yc", clock (), "", "");
333 current_year = convert (current_year, current_year_a);
334 doing_all_components = False;
335 call init_structures (source_info, target_info);
336
337
338
339 on cleanup call clean_up;
340
341 target_info.long_output = True;
342 call init_variables;
343
344 call cu_$arg_count (Nargs, code);
345 if code ^= 0
346 then
347 do;
348 call com_err_ (code, ME, "");
349 return;
350 end;
351 if Nargs = 0
352 then
353 do;
354 call ioa_ (
355 "Syntax: ^a path {-control_args} For details, type: help ^a",
356 ME, ME);
357 return;
358 end;
359 do Iarg = 1 to Nargs;
360 call cu_$arg_ptr (Iarg, Parg, Larg, code);
361 if index (argument, "-") ^= 1
362 then
363 do;
364 if path = ""
365 then path = argument;
366 else
367 do;
368 call com_err_ (error_table_$wrong_no_of_args, ME, "^a
369 Multiple pathnames not allowed.", argument);
370 goto FATAL_ERROR;
371 end;
372 end;
373 else if (argument = "-trade_secret" | argument = "-public_domain")
374 then
375 do;
376 used_old_argument = True;
377 if argument = "-trade_secret" & ^Fdisplay then Ftrade_secret = True;
378 else if argument = "-public_domain" & ^Fdisplay
379 then Fpublic_domain = True;
380 end;
381 else if (argument = "-dts" | argument = "-default_trade_secret")
382 & ^Fdisplay
383 then DFtrade_secret = True;
384 else if (argument = "-dc" | argument = "-default_copyright") & ^Fdisplay
385 then DFcopy_right = True;
386 else if (argument = "-name" | argument = "-nm") & ^Fdisplay
387 then
388 do;
389 Iarg = Iarg + 1;
390 call cu_$arg_ptr (Iarg, Parg, Larg, code);
391 if code ^= 0
392 then
393 do;
394 NAME_ERR:
395 call com_err_ (code, ME, "
396 The -name control arg requires a pnotice name operand.
397 Use the list_pnotice_names command to print valid names.");
398 return;
399 end;
400 if index (argument, ".") ^= 0
401 then
402 do;
403 if reverse (before (reverse (argument), ".")) = "pnotice"
404 then
405 do;
406 code = error_table_$improper_data_format;
407 goto NAME_ERR;
408 end;
409 else ;
410 end;
411 if argument = "public_domain" then Fpublic_domain = True;
412 if reverse (before (reverse (argument), ".")) = "trade_secret"
413 then
414 do;
415 Ftrade_secret = True;
416 Fname = True;
417 source_info.notice_to_add.name = argument;
418 end;
419 else
420 do;
421 source_info.notice_to_add.name = argument;
422 Fname = True;
423 end;
424 end;
425 else if argument = "-long" | argument = "-lg"
426 then target_info.long_output = True;
427 else if argument = "-brief" | argument = "-bf"
428 then target_info.long_output = False;
429 else
430 do;
431 code = error_table_$badopt;
432 call com_err_ (code, ME);
433 goto FATAL_ERROR;
434 end;
435 end;
436
437 if Fdisplay
438 then
439 do;
440 call init_variables;
441 goto GET_TEMPLATES;
442 end;
443
444 if used_old_argument & Ftrade_secret & Fname
445 then
446 do;
447 code = error_table_$inconsistent;
448 call com_err_ (code, ME, Inconsistent_args, "-trade_secret", "-name");
449 goto FATAL_ERROR;
450 end;
451 if DFtrade_secret & Fname
452 then
453 do;
454 code = error_table_$inconsistent;
455 call com_err_ (code, ME, Inconsistent_args, "-default_trade_secret",
456 "-name");
457 goto FATAL_ERROR;
458 end;
459 if used_old_argument & Fpublic_domain & Fname
460 then
461 do;
462 code = error_table_$inconsistent;
463 call com_err_ (code, ME, Inconsistent_args, "-public_domain", "-name");
464 goto FATAL_ERROR;
465 end;
466 if Fpublic_domain & (Ftrade_secret | DFtrade_secret)
467 then
468 do;
469 code = error_table_$inconsistent;
470 call com_err_ (code, ME,
471 "The ""-public_domain"" control arg must be used alone.");
472 goto FATAL_ERROR;
473 end;
474 if DFcopy_right & Fname
475 then
476 do;
477 code = error_table_$inconsistent;
478 call com_err_ (code, ME, Inconsistent_args, "-default_copyright",
479 "-name");
480 goto FATAL_ERROR;
481 end;
482 GET_TEMPLATES:
483 if path = ""
484 then
485 do;
486 call com_err_ (error_table_$noarg, ME, "
487 No pathname specified.");
488 goto FATAL_ERROR;
489 end;
490
491
492
493
494 call pnotice_paths_ (ME, "00"b, Ppaths, code);
495
496 if code ^= 0
497 then
498 goto FATAL_ERROR;
499
500
501 if Fdisplay
502 then
503 goto EXPAND_PATH;
504
505
506 if (Ftrade_secret & ^Fname) | DFtrade_secret
507 then
508 do;
509 do Itemplate = 1 to pnotice_paths.Ntemplates
510 while (^pnotice_paths.templates (Itemplate).defaultTS);
511 end;
512 if Itemplate > pnotice_paths.Ntemplates
513 then
514 do;
515 code = error_table_$name_not_found;
516 call com_err_ (code, ME, Not_found, "default_trade_secret");
517 goto FATAL_ERROR;
518 end;
519 else source_info.notice_to_add.name =
520 before (pnotice_paths.templates (Itemplate).primary_name,
521 ".pnotice");
522 source_info.notice_to_add.type = TRADE_SECRET;
523 end;
524 else if Fpublic_domain
525 then
526 do;
527 do Itemplate = 1 to pnotice_paths.Ntemplates
528 while (pnotice_paths.templates (Itemplate).type ^= PUBLIC_DOMAIN);
529 end;
530 if Itemplate > pnotice_paths.Ntemplates
531 then
532 do;
533 code = error_table_$name_not_found;
534 call com_err_ (code, ME, Not_found, "public_domain");
535 goto FATAL_ERROR;
536 end;
537 else source_info.notice_to_add.name =
538 before (pnotice_paths.templates (Itemplate).primary_name,
539 ".pnotice");
540 source_info.notice_to_add.type = PUBLIC_DOMAIN;
541 end;
542 else if (Fname & Ftrade_secret & ^used_old_argument)
543 | (Fname & ^DFtrade_secret) | (Fname & ^Fpublic_domain)
544 then
545 do;
546 do Itemplate = 1 to pnotice_paths.Ntemplates
547 while (source_info.notice_to_add.name
548 ^=
549 before (pnotice_paths.templates (Itemplate).primary_name,
550 ".pnotice"));
551 end;
552 if Itemplate > pnotice_paths.Ntemplates
553 then
554 do;
555 code = error_table_$name_not_found;
556 call com_err_ (code, ME, Not_found, source_info.notice_to_add.name)
557 ;
558 goto FATAL_ERROR;
559 end;
560 if Ftrade_secret
561 then source_info.notice_to_add.type = TRADE_SECRET;
562 else source_info.notice_to_add.type = COPYRIGHT;
563 end;
564 else
565 do;
566 do Itemplate = 1 to pnotice_paths.Ntemplates
567 while (^pnotice_paths.templates (Itemplate).defaultC);
568 end;
569 if Itemplate > pnotice_paths.Ntemplates
570 then
571 do;
572 code = error_table_$name_not_found;
573 call com_err_ (code, ME, Not_found, "default_copyright");
574 goto FATAL_ERROR;
575 end;
576 else
577 do;
578 source_info.notice_to_add.name =
579 before (pnotice_paths.templates (Itemplate).primary_name,
580 ".pnotice");
581 source_info.notice_to_add.type = COPYRIGHT;
582 if ^DFcopy_right then Sno_args_given = True;
583 Sdfcopyright = True;
584 end;
585 end;
586 EXPAND_PATH:
587 call expand_pathname_$component (path, source_info.dir, source_info.entry,
588 component, code);
589
590
591
592
593 if code ^= 0
594 then
595 do;
596 call com_err_ (code, ME, path);
597 goto FATAL_ERROR;
598 end;
599 target_info.dir = source_info.dir;
600 if index (source_info.entry, ".") = 0
601 then
602 do;
603 code = error_table_$bad_file_name;
604 if source_info.archive_name ^= ""
605 then call com_err_ (code, ME,
606 "^/Entry must include language suffix. ^a",
607 pathname_$component (source_info.dir,
608 source_info.archive_name, source_info.entry));
609 else call com_err_ (code, ME,
610 "^/Entry must include language suffix. ^a",
611 pathname_ (source_info.dir, source_info.entry));
612 goto FATAL_ERROR;
613 end;
614 call check_star_name_$entry (source_info.entry, code);
615 if code ^= 0
616 then
617 do;
618 code = error_table_$nostars;
619 call com_err_ (code, ME, "^/Processing ^a.",
620 pathname_ (source_info.dir, source_info.entry));
621 goto FATAL_ERROR;
622 end;
623 if component ^= ""
624 then
625 do;
626 call check_star_name_$entry (component, code);
627 if code ^= 0
628 then
629 do;
630 code = error_table_$nostars;
631 call com_err_ (code, ME, "^/Processing ^a.",
632 pathname_$component (source_info.dir, source_info.entry,
633 component));
634 goto FATAL_ERROR;
635 end;
636 Farchive = True;
637 end;
638 else if component = ""
639 then if reverse (before (reverse (source_info.entry), ".")) = "archive"
640 then Farchive = True;
641 call hcs_$initiate_count (source_info.dir, source_info.entry, "",
642 bit_count, 0, source_info.Pentry, code);
643
644 if source_info.Pentry = null
645 then
646 do;
647 call com_err_ (code, ME, "^/Initiating ^a.",
648 pathname_ (source_info.dir, source_info.entry));
649 goto FATAL_ERROR;
650 end;
651 source_info.Lentry = divide (bit_count, 9, 21, 0);
652
653 if Farchive
654 then
655 do;
656 process_dir = get_pdir_ ();
657 pdir = rtrim (process_dir);
658 source_info.archive_name = source_info.entry;
659 common_archive_name = source_info.archive_name;
660
661 source_info.entry = component;
662 source_info.Parchive = source_info.Pentry;
663 source_info.Larchive = source_info.Lentry;
664 target_info.archive_name = source_info.archive_name;
665 target_info.Parchive = source_info.Pentry;
666 target_info.Larchive = source_info.Lentry;
667 if Fdisplay
668 then call ioa_ ("^a^[>^]^a:", source_info.dir, source_info.dir ^= ">",
669 source_info.archive_name);
670 call process_archive_components (source_info, target_info);
671 end;
672 else
673 do;
674 source_info.archive_name = "";
675 source_info.Parchive = null;
676 source_info.Larchive = 0;
677 target_info.archive_name = "";
678 target_info.Parchive = null;
679 target_info.Larchive = 0;
680 target_info.entry = source_info.entry;
681 target_info.Pentry = source_info.Pentry;
682 target_info.Lentry = source_info.Lentry;
683 call process_single_seg (source_info, target_info);
684 end;
685 NORMAL_EXIT:
686 FATAL_ERROR:
687 call clean_up;
688 return;
689
690
691 %page;
692
693
694
695 init_structures:
696 proc (SI, TI);
697
698 dcl 1 SI aligned like source_info,
699 1 TI aligned like target_info;
700
701 SI.version = V_source_info_1;
702 TI.version = V_target_info_1;
703 SI.archive_name = "";
704
705 init_structures$next_component:
706 entry (SI, TI);
707
708 SI.Pentry = null;
709 SI.ec_version = 0;
710 SI.text_pos = 0;
711 SI.cmt_bgn = "";
712 SI.cmt_end = "";
713 SI.Pold_box = null;
714 SI.Lold_box = 0;
715 SI.Nnotices = 0;
716 SI.notice_info (*).notice_name = "";
717 SI.notice_info (*).notice_date = "";
718 SI.notice_info (*).notice_type = 0;
719 TI.Pnew_box = null;
720 TI.Lnew_box = 0;
721 TI.Pstar_box = null;
722 TI.Lstar_box = 0;
723 TI.Nnotices = 0;
724 seqno = 0;
725 TI.notice (*) = "";
726
727 end init_structures;
728
729 %page;
730 init_variables:
731 proc;
732 Fname = False;
733 Fcopy_right = False;
734 DFcopy_right = False;
735 DFtrade_secret = False;
736 Sadd_default_pnotice = False;
737 Sdfcopyright = False;
738 Sno_args_given = False;
739 Fpublic_domain = False;
740 Ftrade_secret = False;
741 used_old_argument = False;
742 source_info.notice_to_add.name = "";
743 source_info.notice_to_add.type = 0;
744
745 end init_variables;
746 %page;
747
748
749
750 dcl 1 comp_info based (Pcomp_info),
751
752
753 2 Ncomp fixed bin,
754 2 array (0 refer (comp_info.Ncomp)),
755 3 name char (32),
756 3 ptr ptr,
757 3 length fixed bin (21);
758
759 dcl Lcomp fixed bin (21),
760 Pal ptr,
761 Parchive_paths ptr,
762 Pcomp_info ptr,
763 Pcomp ptr,
764 Pdesc ptr,
765 comp_bc fixed bin (24),
766 comp_name char (32),
767 paths (comp_info.Ncomp + 2) based (Parchive_paths) char (168);
768
769 process_archive_components:
770 proc (SI, TI);
771
772
773
774
775
776
777
778
779
780
781
782 dcl 1 SI aligned like source_info,
783
784 1 TI aligned like target_info;
785
786 dcl Acode fixed bin (35);
787 dcl COMPONENT char (Lcomp) based (Pcomp);
788
789 if ^Fdisplay
790 then
791 do;
792 Fmust_reset = False;
793 Fmode_set = False;
794 on cleanup
795 begin;
796 if Fmust_reset
797 then call check_acl$reset_acl (TI.Pentry, TI.dir, TI.entry,
798 Fmode_set);
799 end;
800 call get_temp_segment_ (ME, Pcomp_info, Acode);
801 if Acode ^= 0
802 then
803 do;
804 call com_err_ (Acode, ME, "
805 Obtaining temp seg for archive info.");
806 goto FATAL_ERROR;
807 end;
808 comp_info.Ncomp = 0;
809 end;
810 if SI.entry = ""
811 then
812 goto ALL_COMPONENTS;
813 else goto SINGLE_COMPONENT;
814
815
816 ALL_COMPONENTS:
817 doing_all_components = True;
818 Pcomp = null;
819 NEXT_COMPONENT:
820 call archive_$next_component (SI.Parchive, bit_count, Pcomp, comp_bc,
821 comp_name, Acode);
822 if Acode ^= 0
823 then
824 do;
825 call com_err_ (Acode, ME,
826 "^/Last component processed: ^a^/Error obtaining next component info.",
827 pathname_$component (SI.dir, SI.archive_name, SI.entry));
828 goto FATAL_ERROR;
829 end;
830 else if Pcomp = null
831 then
832 goto END_OF_COMPONENTS;
833 SI.entry = comp_name;
834 SI.Pentry = Pcomp;
835 TI.entry = comp_name;
836 TI.Pentry = Pcomp;
837 if ^get_language_info (SI)
838 then
839 goto NEXT_COMPONENT;
840 Lcomp = divide (comp_bc, 9, 21, 0);
841 SI.Lentry = Lcomp;
842 TI.Lentry = Lcomp;
843 call pnotice_parse (SI);
844 if Fdisplay
845 then
846 do;
847 call report (SI, TI);
848 end;
849 else
850 do;
851 if ^continue_processing (SI, TI)
852 then ;
853 else
854 do;
855 comp_info.Ncomp = comp_info.Ncomp + 1;
856 comp_info.array (Ncomp).length = Lcomp;
857 comp_info.array (Ncomp).name = SI.entry;
858 call hcs_$make_seg (process_dir, comp_info.array (Ncomp).name, "",
859 01010b, comp_info.array (Ncomp).ptr, Acode);
860
861 if Acode ^= 0
862 then
863 do;
864 call com_err_ (Acode, ME, "
865 Creating ^a>^a.", pdir, comp_info.array (Ncomp).name);
866 goto FATAL_ERROR;
867 end;
868 comp_info.array (Ncomp).ptr -> COMPONENT = COMPONENT;
869
870 call make_star_box (SI, TI);
871 TI.Pentry = comp_info.array (Ncomp).ptr;
872
873 TI.Pnew_box =
874 add_char_offset_ (TI.Pentry,
875 char_offset_ (SI.Pold_box) - char_offset_ (SI.Pentry));
876
877
878
879
880 TI.Lnew_box = TI.Lstar_box;
881 call insert_notice (SI, TI);
882 if TI.long_output
883 then if SI.archive_name ^= ""
884 then call ioa_ (
885 "^/The following notice was added to:^a^a^/^a",
886 " ",
887 pathname_$component (SI.dir, SI.archive_name,
888 SI.entry), save_name);
889 else call ioa_ (
890 "^/The following notice was added to ^a^a^/^a",
891 " ", pathname_ (SI.dir, SI.entry), save_name);
892 end;
893 end;
894 call init_structures$next_component (SI, TI);
895
896 goto NEXT_COMPONENT;
897
898
899 SINGLE_COMPONENT:
900 call archive_$get_component (SI.Parchive, bit_count, component, Pcomp,
901 comp_bc, Acode);
902 if Acode ^= 0
903 then
904 do;
905 call com_err_ (Acode, ME, "^/Processing ^a.",
906 pathname_$component (SI.dir, SI.archive_name, component));
907 goto FATAL_ERROR;
908 end;
909 SI.Pentry = Pcomp;
910 TI.entry = component;
911 TI.Pentry = Pcomp;
912 if ^get_language_info (SI)
913 then
914 do;
915 call com_err_ (error_table_$bad_file_name, ME, "
916 Single-component names not permitted. ^a", SI.entry);
917 goto FATAL_ERROR;
918 end;
919 Lcomp = divide (comp_bc, 9, 21, 0);
920 SI.Lentry = Lcomp;
921 TI.Lentry = Lcomp;
922 call pnotice_parse (SI);
923 if Fdisplay
924 then
925 do;
926 call report (SI, TI);
927 end;
928 else
929 do;
930 if ^continue_processing (SI, TI)
931 then ;
932 else
933 do;
934 comp_info.Ncomp = comp_info.Ncomp + 1;
935 comp_info.array (Ncomp).length = Lcomp;
936 comp_info.array (Ncomp).name = SI.entry;
937 call hcs_$make_seg (process_dir, comp_info.array (Ncomp).name, "",
938 01010b, comp_info.array (Ncomp).ptr, Acode);
939
940 if Acode ^= 0
941 then
942 do;
943 call com_err_ (Acode, ME, "
944 Creating ^a>^a.", pdir, comp_info.array (Ncomp).name);
945 goto FATAL_ERROR;
946 end;
947 comp_info.array (Ncomp).ptr -> COMPONENT = COMPONENT;
948
949 call make_star_box (SI, TI);
950 TI.Pentry = comp_info.array (Ncomp).ptr;
951
952 TI.Pnew_box =
953 add_char_offset_ (TI.Pentry,
954 char_offset_ (SI.Pold_box) - char_offset_ (SI.Pentry));
955 TI.Lnew_box = TI.Lstar_box;
956 call insert_notice (SI, TI);
957 if TI.long_output
958 then if SI.archive_name ^= ""
959 then call ioa_ ("The following notice was added to:^a^a^/^a",
960 " ",
961 pathname_$component (SI.dir, SI.archive_name,
962 SI.entry), save_name);
963 else call ioa_ ("The following notice was added to:^a^a^/^a",
964 " ", pathname_ (SI.dir, SI.entry), save_name);
965 end;
966 end;
967 END_OF_COMPONENTS:
968 if Fdisplay
969 then
970 return;
971 if comp_info.Ncomp = 0
972 then
973 return;
974
975
976 INIT_ARG_LIST:
977 Pal = addrel (Pcomp_info, currentsize (comp_info));
978 al.header.arg_count = comp_info.Ncomp + 2;
979 al.header.pad1 = "0"b;
980 al.header.call_type = Interseg_call_type;
981 al.header.desc_count = comp_info.Ncomp + 2;
982 al.header.pad2 = "0"b;
983
984 INIT_DESCRIPTOR_VALUES:
985 Pdesc = addrel (Pal, currentsize (al));
986 desc (*).version2_ = "1"b;
987 desc (*).type_ = char_desc;
988 desc (*).pack_ = "1"b;
989 desc (*).dimension_ = "0"b;
990 desc (*).scale_ = 0;
991 desc (*).precision_ = 0;
992
993 INIT_ARGUMENT_PATHS:
994 Parchive_paths = addrel (Pdesc, currentsize (desc));
995 paths (1) = "u";
996 paths (2) = rtrim (TI.dir) || ">" || TI.archive_name;
997
998 do Idx1 = 3 to comp_info.Ncomp + 2;
999 paths (Idx1) = pdir || ">" || comp_info.array (Idx1 - 2).name;
1000 end;
1001
1002 FINISH_ARGS_AND_DESCS:
1003 do Idx1 = 1 to comp_info.Ncomp + 2;
1004 desc (Idx1).precision_ = length (rtrim (paths (Idx1)));
1005 al.ap (Idx1) = addr (paths (Idx1));
1006 al.dp (Idx1) = addr (desc (Idx1));
1007 end;
1008
1009 call check_acl (TI.Parchive, TI.dir, TI.archive_name, Fmust_reset);
1010
1011 call cu_$generate_call (archive, Pal);
1012
1013
1014 if Fmust_reset
1015 then call check_acl$reset_acl (TI.Parchive, TI.dir, TI.archive_name,
1016 Fmode_set);
1017
1018
1019 end process_archive_components;
1020 %page;
1021
1022
1023
1024
1025 process_single_seg:
1026 proc (SI, TI);
1027 dcl 1 SI aligned like source_info,
1028 1 TI aligned like target_info;
1029
1030 Fmust_reset = False;
1031 Fmode_set = False;
1032 on cleanup
1033 begin;
1034 if Fmust_reset
1035 then call check_acl$reset_acl (TI.Pentry, TI.dir, TI.entry, Fmode_set);
1036
1037 end;
1038 if ^get_language_info (SI)
1039 then
1040 do;
1041 call com_err_ (error_table_$bad_file_name, ME, "
1042 Single-component names not permitted. ^a", SI.entry);
1043 goto FATAL_ERROR;
1044 end;
1045 call pnotice_parse (SI);
1046 if Fdisplay
1047 then
1048 do;
1049 call report (SI, TI);
1050 end;
1051 else
1052 do;
1053 if ^continue_processing (SI, TI) then goto FATAL_ERROR;
1054 call make_star_box (SI, TI);
1055 call check_acl (TI.Pentry, TI.dir, TI.entry, Fmust_reset);
1056
1057 TI.Pnew_box = SI.Pold_box;
1058 TI.Lnew_box = TI.Lstar_box;
1059 call insert_notice (SI, TI);
1060 if Fmust_reset
1061 then call check_acl$reset_acl (TI.Pentry, TI.dir, TI.entry, Fmode_set);
1062
1063 if TI.long_output
1064 then
1065 do;
1066 if ^Sdfcopyright
1067 then call ioa_ ("The following notice was added to:^a^a^/^a", " ",
1068 pathname_ (source_info.dir, source_info.entry),
1069 save_name);
1070 else if Sdfcopyright & Sprt_notice
1071 then call ioa_ ("The following notice was added to:^a^a^/^a", " ",
1072 pathname_ (source_info.dir, source_info.entry),
1073 save_name);
1074 end;
1075
1076 end;
1077 end process_single_seg;
1078 %page;
1079
1080
1081
1082
1083 get_language_info:
1084 proc (SI) returns (bit (1));
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098 dcl 1 SI aligned like source_info;
1099
1100 dcl Acode fixed bin (35),
1101 Ilang fixed bin,
1102 language char (8) var;
1103 %include pnotice_language_info_;
1104
1105
1106 SI.ec_version = 0;
1107 SI.text_pos = 0;
1108 if index (SI.entry, ".") = 0
1109 then
1110 return (False);
1111 language = reverse (before (reverse (SI.entry), "."));
1112
1113 do Ilang = 1
1114 to hbound (pnotice_language_info.languages.lang_array, 1)
1115 while (language
1116 ^= pnotice_language_info.languages.lang_array (Ilang).lang_name);
1117 end;
1118 if Ilang > pnotice_language_info.languages.N
1119 then
1120 do;
1121 Acode = error_table_$typename_not_found;
1122 if doing_all_components
1123 then
1124 do;
1125 if SI.archive_name ^= ""
1126 then call com_err_ (Acode, ME,
1127 "^/The ^a suffix is not supported because it is not defined in pnotice_language_info_.^/Entry was skipped: ^a",
1128 language,
1129 pathname_$component (SI.dir, SI.archive_name, SI.entry));
1130 else call com_err_ (Acode, ME,
1131 "^/The ^a suffix is not supported because it is not defined in pnotice_language_info_.^/Entry was skipped: ^a",
1132 language, pathname_ (SI.dir, SI.entry));
1133 return (False);
1134 end;
1135 else
1136 do;
1137 if reverse (before (reverse (SI.entry), ".")) = "archive"
1138 then call com_err_ (Acode, ME,
1139 "^/Archived archives are not supported.");
1140 else if SI.archive_name ^= ""
1141 then call com_err_ (Acode, ME,
1142 "^/The ^a suffix is not supported because it is not defined in pnotice_language_info_.^/Entry not processed: ^a",
1143 language,
1144 pathname_$component (SI.dir, SI.archive_name, SI.entry));
1145 else call com_err_ (Acode, ME,
1146 "^/The ^a suffix is not supported because it is not defined in pnotice_language_info_.^/Entry not processed: ^a",
1147 language, pathname_ (SI.dir, SI.entry));
1148 goto FATAL_ERROR;
1149 end;
1150 end;
1151
1152 SI.type = pnotice_language_info.languages.lang_array (Ilang).lang_type;
1153
1154 if SI.type < 1 | SI.type > 6
1155 then
1156 do;
1157 Acode = error_table_$typename_not_found;
1158 call com_err_ (Acode, ME,
1159 "
1160 Language type (^d) found for the ^a suffix in pnotice_language_info_ is not implemented.",
1161 SI.type, language);
1162 goto FATAL_ERROR;
1163 end;
1164 SI.cmt_bgn =
1165 pnotice_language_info.languages.lang_array (Ilang).comment_start;
1166 SI.cmt_end =
1167 pnotice_language_info.languages.lang_array (Ilang).comment_end;
1168
1169 if SI.type = 3
1170 then
1171 do;
1172 if SI.archive_name ^= ""
1173 then
1174 do;
1175 call com_err_ (error_table_$archive_component_modification, ME,
1176 "^/^a^/Processing of archived exec_coms is not supported.",
1177 pathname_ (SI.dir, SI.archive_name));
1178 goto FATAL_ERROR;
1179 end;
1180 call get_ec_version_ (SI.dir, SI.entry, SI.ec_version, SI.text_pos,
1181 Acode);
1182 if Acode ^= 0
1183 then
1184 do;
1185 call com_err_ (Acode, ME, "^/Getting ec version.");
1186 goto FATAL_ERROR;
1187 end;
1188 if SI.text_pos < 1
1189 then
1190 SI.text_pos = 1;
1191 if SI.ec_version = 1
1192 then SI.cmt_bgn = SI.cmt_bgn || SP;
1193 else SI.cmt_bgn = SI.cmt_bgn || "-";
1194 end;
1195 else if SI.type = 6
1196 then
1197 do;
1198 if SI.archive_name ^= ""
1199 then
1200 call com_err_ (error_table_$archive_component_modification, ME,
1201 "^/^a^/Processing of archived exec_coms is not supported.",
1202 pathname_ (SI.dir, SI.archive_name));
1203 else
1204 call com_err_ (error_table_$typename_not_found, ME,
1205 "^/^a^/Processing of info segments is not supported.",
1206 pathname_ (SI.dir, SI.entry));
1207 goto FATAL_ERROR;
1208 end;
1209
1210 return (True);
1211
1212 end get_language_info;
1213 %page;
1214
1215
1216
1217
1218 pnotice_parse:
1219 proc (SI);
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232 dcl 1 SI aligned like source_info;
1233
1234
1235
1236 dcl rest char (Lrest) based (Prest),
1237 Prest ptr,
1238 Lrest fixed bin (21),
1239 Icmt fixed bin (21),
1240 rest_ch (Lrest) char (1) based (Prest),
1241 cmt_bgn_length fixed bin (21),
1242 save_length fixed bin (21),
1243 save_ptr ptr,
1244 save_Prest ptr,
1245 Spnotice bit (1),
1246 Sstar_line bit (1);
1247
1248 dcl Pcomment ptr,
1249 Lcomment fixed bin (21),
1250 comment char (Lcomment) based (Pcomment),
1251 comment_chr (Lcomment) char (1) based (Pcomment),
1252 Pcomment_line ptr,
1253 Lcomment_line fixed bin (21),
1254 comment_line char (Lcomment_line) based (Pcomment_line);
1255
1256 dcl Ppnotice ptr,
1257 Lpnotice fixed bin (21),
1258 pnotice char (Lpnotice) based (Ppnotice),
1259 pnotice_chr (Lpnotice) char (1) based (Ppnotice),
1260 Ppnotice_line ptr,
1261 Lpnotice_line fixed bin (21),
1262 pnotice_line char (Lpnotice_line) based (Ppnotice_line);
1263
1264 dcl 1 pnotices based (Ppnotices),
1265 2 Nwords fixed bin (24),
1266 2 pword (0 refer (Nwords)) char (80) var,
1267 Ppnotices ptr;
1268
1269
1270 dcl 1 template based (Ptemplate),
1271 2 Twords fixed bin (24),
1272 2 tword (0 refer (Twords)) char (80) var,
1273 Ptemplate ptr;
1274
1275 dcl Ntemplates_parsed
1276 fixed bin;
1277
1278 dcl Ibreak fixed bin (21),
1279 Inonwhite fixed bin (21),
1280 Iskip fixed bin (21),
1281 Lword_text fixed bin (21),
1282 Pword_text ptr;
1283
1284 dcl word_text char (Lword_text) based (Pword_text),
1285 word_text_arr (Lword_text) char (1) based (Pword_text);
1286
1287
1288 dcl WORD_BREAKS char (30) var,
1289 SKIP_CHRS char (30) var;
1290
1291 dcl Acode fixed bin (35);
1292
1293
1294 SI.Pold_box = SI.Pentry;
1295 SI.Lold_box = 0;
1296 Prest = SI.Pentry;
1297 Lrest = SI.Lentry;
1298 Sold_style_pnotice = False;
1299 source_year (*) = 0;
1300 source_year_a (*) = " ";
1301 cmt_bgn_length = length (SI.cmt_bgn);
1302 goto TYPE (SI.type);
1303
1304 TYPE (1):
1305 TYPE (4):
1306 Icmt = verify (rest, HT_SP_NL_VT_NP);
1307
1308 if Icmt = 0
1309 then
1310 goto end_parse1;
1311 else
1312 do;
1313 Prest = addr (rest_ch (Icmt));
1314 Lrest = Lrest - (Icmt - 1);
1315 end;
1316
1317 if length (SI.cmt_bgn) > length (rest) then goto end_parse1;
1318
1319
1320 if SI.type = 4 & substr (rest, 1, length (SI.cmt_bgn)) ^= SI.cmt_bgn
1321 & substr (rest, 1, 2) = "
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332 if (index (comment, "PROPRIETARY") > 0
1333 | index (comment, "PUBLIC DOMAIN") > 0
1334 | index (comment, "Copyright") > 0)
1335 then save_length = save_length + Lcomment;
1336 end;
1337
1338 if save_length = 0
1339 then
1340 goto end_parse1;
1341
1342 Pcomment = save_ptr;
1343 Lcomment = save_length;
1344
1345 if ^valid_format ()
1346 then
1347 do;
1348 call com_err_ (error_table_$improper_data_format, ME,
1349 "^/^a^/^3xPnotice begin delimiters may not be on a line by themselves.",
1350 pathname_ (SI.dir, SI.entry));
1351 goto FATAL_ERROR;
1352 end;
1353 SI.Lold_box = Lcomment;
1354 call process_tokens;
1355
1356 end_parse1:
1357 goto PARSE_CLEANUP;
1358
1359
1360 TYPE (3):
1361 Prest = addr (rest_ch (SI.text_pos));
1362
1363 Lrest = Lrest - (SI.text_pos - 1);
1364 SI.Pold_box = Prest;
1365 TYPE (2):
1366 TYPE (5):
1367 Icmt = verify (rest, HT_SP_NL_VT_NP);
1368
1369 if Icmt = 0
1370 then
1371 goto end_parse2;
1372
1373 if (Icmt - 1) + length (SI.cmt_bgn) > length (rest)
1374 then
1375 goto end_parse2;
1376
1377 Prest = addr (rest_ch (Icmt));
1378 Lrest = Lrest - (Icmt - 1);
1379
1380 if substr (rest, 1, length (SI.cmt_bgn)) ^= SI.cmt_bgn
1381 then
1382 goto end_parse2;
1383
1384 Spnotice = True;
1385 save_ptr = Prest;
1386
1387 do while (Spnotice);
1388 Pcomment, save_Prest = Prest;
1389 Lcomment = Lrest;
1390 save_length = 0;
1391 Sstar_line = False;
1392
1393 if substr (comment, 1, length (SI.cmt_bgn)) ^= SI.cmt_bgn
1394 then Spnotice = False;
1395 else
1396 do;
1397 if (substr (comment, length (SI.cmt_bgn) + length (" "),
1398 length ("**********")) = "**********"
1399 | substr (comment, 1, length (SI.cmt_bgn)) = SI.cmt_bgn) &
1400
1401 (index (comment, "PROPRIETARY") > 0
1402 | index (comment, "PUBLIC DOMAIN") > 0
1403 | index (comment, "Copyright") > 0)
1404 then
1405 do;
1406 do while (Lcomment > 0);
1407 Pcomment_line = Pcomment;
1408 Lcomment_line = index (comment, NL);
1409 if Lcomment_line = 0 then Lcomment_line = Lcomment;
1410 Pcomment = addcharno (addr (comment_chr (Lcomment_line)), 1);
1411 Lcomment = Lcomment - Lcomment_line;
1412 save_length = save_length + Lcomment_line;
1413 if Lcomment_line
1414 > length (SI.cmt_bgn) + length (" ")
1415 + length ("**********")
1416 then if substr (comment_line,
1417 length (SI.cmt_bgn) + length (" "),
1418 length ("**********")) = "**********"
1419 then
1420 do;
1421 if ^Sstar_line
1422 then Sstar_line = True;
1423 else
1424 do;
1425 Prest =
1426 addcharno (addr (rest_ch (save_length)), 1);
1427 Lrest = Lrest - save_length;
1428 Lcomment = 0;
1429 end;
1430 end;
1431 end;
1432 if Prest = save_Prest
1433 then
1434 Spnotice = False;
1435 Icmt = verify (rest, HT_SP_NL_VT_NP);
1436 Prest = addr (rest_ch (Icmt));
1437 Lrest = Lrest - (Icmt - 1);
1438 if (substr (rest, length (SI.cmt_bgn) + length (" "),
1439 length ("**********")) ^= "**********"
1440 & substr (rest, 1, length (SI.cmt_bgn)) ^= SI.cmt_bgn)
1441 | Lrest = 0
1442 then Spnotice = False;
1443 end;
1444 else
1445 Spnotice = False;
1446 end;
1447 end;
1448
1449 Pcomment = save_ptr;
1450 Lcomment = charno (Prest) - charno (Pcomment) - 1;
1451 if Lcomment <= 0
1452 then
1453 goto end_parse2;
1454
1455 SI.Lold_box = Lcomment;
1456 call process_tokens;
1457
1458 end_parse2:
1459 PARSE_CLEANUP:
1460 if Ptemplate ^= null then call release_temp_segment_ (ME, Ptemplate, code);
1461
1462 if Ppnotices ^= null then call release_temp_segment_ (ME, Ppnotices, code);
1463
1464 return;
1465
1466
1467
1468 pnotice_found:
1469 proc returns (bit (1));
1470
1471 dcl Inl fixed bin (21);
1472
1473 Icmt = verify (rest, HT_SP_NL_VT_NP);
1474 if Icmt > 0
1475 then
1476 do;
1477 Prest = addr (rest_ch (Icmt));
1478 Lrest = Lrest - (Icmt - 1);
1479 end;
1480
1481 Pcomment = Prest;
1482
1483 if Sold_style_pnotice & substr (rest, 1, 2) ^= "
1484
1485
1486
1487
1488
1489 Inl = index (rest, NL);
1490 if Inl < length (cmt_bgn) + length (" ") + length ("**********")
1491 then return (False);
1492 if substr (rest, length (cmt_bgn) + length (" "),
1493 length ("**********")) ^= "**********"
1494 then return (False);
1495 end;
1496
1497 if (SI.cmt_bgn = SI.cmt_end) & ^Sold_style_pnotice
1498 then
1499 Lcomment =
1500 index (substr (rest, length (SI.cmt_bgn) + 1), SI.cmt_end)
1501 + length (SI.cmt_end);
1502 else Lcomment = index (rest, SI.cmt_end) - 1 + length (SI.cmt_end);
1503
1504 Lcomment = Lcomment + Icmt;
1505
1506
1507 Prest = addcharno (addr (rest_ch (Lcomment)), 1);
1508 Lrest = Lrest - Lcomment;
1509
1510 return (True);
1511
1512 end pnotice_found;
1513
1514 valid_format:
1515 proc returns (bit (1));
1516
1517 i = index (comment, NL);
1518 if i <= cmt_bgn_length + length (" ") + length ("**********")
1519 then return (False);
1520 if index (
1521 substr (comment, cmt_bgn_length + length (" "),
1522 length ("**********")), "**********") = 0
1523 then return (False);
1524
1525 return (True);
1526 end valid_format;
1527
1528 %page;
1529
1530
1531
1532 process_tokens:
1533 proc;
1534
1535
1536
1537
1538
1539
1540
1541
1542 dcl Scontinue bit (1),
1543 Sfound bit (1),
1544 Snomatch bit (1);
1545
1546
1547 call parse_source_init;
1548 call parse_templates_$init;
1549 if SI.type = 1 | SI.type = 4
1550 then
1551 WORD_BREAKS = HT_SP_STAR;
1552 else WORD_BREAKS = SI.cmt_bgn || HT_SP_STAR;
1553
1554 do while (Lcomment > 0);
1555 if get_pnotice_block ()
1556 then
1557 do;
1558 do while (parse_pnotice_$block ());
1559 Ntemplates_parsed = 0;
1560 Scontinue, Snomatch = True;
1561 do while (Scontinue);
1562 if parse_templates_$get_next ()
1563 then
1564 do;
1565 call parse_templates_$line;
1566 if Nwords ^= Twords
1567 then ;
1568 else
1569 do;
1570 Sfound = True;
1571 do i = 1 to Nwords while (Sfound);
1572 if pnotices.pword (i) = template.tword (i) then ;
1573 else if template.tword (i) = "<yr>"
1574 & verify (pnotices.pword (i), "0123456789") = 0
1575 & length (pnotices.pword (i)) = length ("1986")
1576 then ;
1577 else if template.tword (i) = "<yr>."
1578 & length (pnotices.pword (i)) = length ("1986.")
1579 &
1580 verify (
1581 substr (pnotices.pword (i), 1, length ("1986")),
1582 "0123456789") = 0
1583 &
1584 substr (pnotices.pword (i), length ("1986."),
1585 length (".")) = "."
1586 then ;
1587 else Sfound = False;
1588 end;
1589 if Sfound
1590 then if i - 1 = Nwords then Scontinue, Snomatch = False;
1591 end;
1592 end;
1593 else Scontinue = False;
1594 end;
1595
1596 if Snomatch
1597 then
1598 do;
1599 if SI.archive_name ^= ""
1600 then call com_err_ (error_table_$not_done, ME,
1601 "^/^a contains an unknown or illegal notice.",
1602 pathname_$component (SI.dir, SI.archive_name,
1603 SI.entry));
1604 else call com_err_ (error_table_$not_done, ME,
1605 "^/^a contains an unknown or illegal notice.",
1606 pathname_ (SI.dir, SI.entry));
1607 goto FATAL_ERROR;
1608 end;
1609 else call template_matched;
1610 end;
1611 end;
1612 else Lcomment = 0;
1613 end;
1614
1615 end process_tokens;
1616
1617
1618 ^L
1619
1620
1621 get_pnotice_block:
1622 proc returns (bit (1));
1623
1624 Spnotice = True;
1625 Sstar_line = False;
1626 Ppnotice = null;
1627 Lpnotice = 0;
1628 save_ptr = Pcomment;
1629 save_length = Lcomment;
1630
1631 do while (Spnotice);
1632 Pcomment_line = Pcomment;
1633 Lcomment_line = index (comment, NL);
1634 if Lcomment_line = 0
1635 then
1636 do;
1637 Lcomment_line = Lcomment;
1638 Lcomment = 0;
1639 end;
1640 else
1641 do;
1642 Pcomment = addcharno (addr (comment_chr (Lcomment_line)), 1);
1643 Lcomment = Lcomment - Lcomment_line;
1644 end;
1645 if Lcomment_line
1646 > cmt_bgn_length + length (" ") + length ("**********")
1647 then if substr (comment_line, cmt_bgn_length + length (" "),
1648 length ("**********")) = "**********"
1649 then
1650 do;
1651 if ^Sstar_line
1652 then
1653 do;
1654 Ppnotice = Pcomment_line;
1655 Sstar_line = True;
1656 end;
1657 else
1658 do;
1659 Sstar_line = False;
1660 Spnotice = False;
1661 end;
1662 end;
1663 if Ppnotice ^= null then Lpnotice = Lpnotice + Lcomment_line;
1664 end;
1665
1666 if Lpnotice > 0
1667 then
1668 do;
1669 if Lcomment > 0
1670 then
1671 do;
1672 Icmt = verify (comment, HT_SP_NL_VT_NP);
1673 if Icmt > 0
1674 then
1675 do;
1676 Pcomment = addr (comment_chr (Icmt));
1677 Lcomment = Lcomment - (Icmt - 1);
1678 end;
1679 else Lcomment = 0;
1680 end;
1681 return (True);
1682 end;
1683
1684 return (False);
1685
1686 end get_pnotice_block;
1687
1688
1689 ^L
1690
1691
1692 parse_source_init:
1693 proc;
1694
1695 SI_yrno = 0;
1696
1697 call get_temp_segment_ (ME, Ppnotices, Acode);
1698
1699 if Acode ^= 0
1700 then
1701 do;
1702 call com_err_ (Acode, ME, "
1703 Obtaining temp seg for pnotice parse.");
1704 goto FATAL_ERROR;
1705 end;
1706
1707 SKIP_CHRS = SI.cmt_bgn || SI.cmt_end || STAR || HT_SP_NL;
1708
1709 end parse_source_init;
1710
1711
1712 ^L
1713
1714
1715 template_matched:
1716 proc;
1717
1718 SI.Nnotices = SI.Nnotices + 1;
1719 if SI.Nnotices > dim (SI.notice_info, 1)
1720 then
1721 do;
1722 if SI.archive_name ^= ""
1723 then call ioa_ (
1724 "^a^/Has more notices than this procedure currently implements.^/Only ^d are allowed.",
1725 pathname_$component (SI.dir, SI.archive_name, SI.entry),
1726 dim (SI.notice_info, 1));
1727 else call ioa_ (
1728 "^a^/Has more notices than this procdure currently implements.^/Only ^d are allowed.",
1729 pathname_ (SI.dir, SI.entry), dim (SI.notice_info, 1));
1730 goto FATAL_ERROR;
1731 end;
1732 SI.notice_info (SI.Nnotices) = parse_templates_$get_template_pnotice ();
1733
1734 end template_matched;
1735
1736
1737 ^L
1738
1739
1740 parse_pnotice_:
1741 proc;
1742
1743 parse_pnotice_$block:
1744 entry returns (bit (1));
1745
1746 pnotices.Nwords = 0;
1747
1748 if verify (pnotice, SKIP_CHRS) = 0
1749 then
1750 Lpnotice = 0;
1751
1752 if Lpnotice = 0 then return (False);
1753
1754 do while (parse_pnotice_$get_line ());
1755 if verify (pnotice_line, SKIP_CHRS) = 0
1756 then
1757 do;
1758 if pnotices.Nwords = 0
1759 then ;
1760 else return (True);
1761 end;
1762 else call parse_pnotice_$line;
1763 end;
1764
1765 return (True);
1766
1767
1768
1769 parse_pnotice_$get_line:
1770 entry returns (bit (1));
1771
1772 dcl Iline fixed bin (24);
1773
1774 if length (pnotice) = 0 then return (False);
1775
1776 Iline = index (pnotice, NL);
1777 if Iline = 0 | Lpnotice - Iline = 0
1778 then
1779 do;
1780 Ppnotice_line = Ppnotice;
1781 Lpnotice_line = length (pnotice);
1782 Lpnotice = 0;
1783 end;
1784 else
1785 do;
1786 Ppnotice_line = Ppnotice;
1787 Lpnotice_line = Iline - 1;
1788 Ppnotice = addcharno (addr (pnotice_chr (Iline)), 1);
1789 Lpnotice = Lpnotice - Iline;
1790 end;
1791
1792 return (True);
1793
1794
1795
1796 parse_pnotice_$line:
1797 entry;
1798
1799 Pword_text = Ppnotice_line;
1800 Lword_text = Lpnotice_line;
1801 Inonwhite = verify (word_text, WORD_BREAKS);
1802
1803 if Inonwhite = 0 then Lword_text = 0;
1804 else if Inonwhite > 1
1805 then
1806 do;
1807 Pword_text = addr (word_text_arr (Inonwhite));
1808 Lword_text = length (word_text) - (Inonwhite - 1);
1809 end;
1810
1811 do while (Lword_text > 0);
1812 Ibreak = search (word_text, WORD_BREAKS);
1813 if Ibreak = 0 then Ibreak = length (word_text) + 1;
1814 if Ibreak > 1
1815 then
1816 do;
1817 pnotices.Nwords = pnotices.Nwords + 1;
1818 pnotices.pword (Nwords) = substr (word_text, 1, Ibreak - 1);
1819 if length (pnotices.pword (Nwords)) >= length ("1986")
1820 then if verify (substr (pnotices.pword (Nwords), 1, 4), "0123456789")
1821 = 0
1822 then
1823 call store_date;
1824 Pword_text = addr (word_text_arr (Ibreak));
1825 Lword_text = length (word_text) - (Ibreak - 1);
1826 end;
1827 Iskip = verify (word_text, WORD_BREAKS);
1828
1829 if Iskip > 0
1830 then
1831 do;
1832 Pword_text = addr (word_text_arr (Iskip));
1833 Lword_text = length (word_text) - (Iskip - 1);
1834 end;
1835 else Lword_text = 0;
1836 end;
1837
1838 return;
1839
1840
1841
1842 store_date:
1843 proc;
1844
1845 if length (pnotices.pword (Nwords)) = length ("1986.")
1846 then if substr (pnotices.pword (Nwords), length ("1986."), length ("."))
1847 ^= "."
1848 then goto RETURN;
1849
1850 SI_yrno = SI_yrno + 1;
1851 source_year_a (SI_yrno) = substr (pnotices.pword (Nwords), 1, 4);
1852 source_year (SI_yrno) =
1853 convert (source_year (SI_yrno), source_year_a (SI_yrno));
1854
1855 RETURN:
1856 end store_date;
1857
1858
1859 end parse_pnotice_;
1860
1861 %page;
1862
1863
1864
1865
1866 dcl Ltline fixed bin (21),
1867 Ptline ptr,
1868 tline char (Ltline) based (Ptline);
1869
1870
1871 parse_templates_:
1872 proc;
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883 parse_templates_$init:
1884 entry;
1885
1886 call get_temp_segment_ (ME, Ptemplate, Acode);
1887 if Acode ^= 0
1888 then
1889 do;
1890 call com_err_ (Acode, ME, "
1891 Obtaining temp seg for template parse.");
1892 goto FATAL_ERROR;
1893 end;
1894
1895 return;
1896
1897
1898
1899 parse_templates_$get_next:
1900 entry returns (bit (1));
1901
1902 Ntemplates_parsed = Ntemplates_parsed + 1;
1903
1904 if Ntemplates_parsed <= pnotice_paths.Ntemplates
1905 then
1906 do;
1907 Ptline = pnotice_paths.templates (Ntemplates_parsed).Ptemplate;
1908 Ltline =
1909 pnotice_paths.templates (Ntemplates_parsed).Ltemplate
1910 - length (NL);
1911 return (True);
1912 end;
1913
1914 return (False);
1915
1916
1917
1918
1919 parse_templates_$line:
1920 entry;
1921
1922 template.Twords = 0;
1923 Pword_text = Ptline;
1924 Lword_text = Ltline;
1925 WORD_BREAKS = WORD_BREAKS || NL;
1926
1927 Inonwhite = verify (tline, HT_SP_NL);
1928
1929 if Inonwhite = 0
1930 then
1931 Lword_text = 0;
1932 else if Inonwhite > 1
1933 then
1934 do;
1935 Pword_text = addr (word_text_arr (Inonwhite));
1936 Lword_text = length (word_text) - (Inonwhite - 1);
1937 end;
1938
1939 do while (Lword_text > 0);
1940 template.Twords = template.Twords + 1;
1941 Ibreak = search (word_text, WORD_BREAKS);
1942 if Ibreak = 0
1943 then
1944 do;
1945 template.tword (Twords) = substr (word_text, 1, length (word_text));
1946 Lword_text = 0;
1947 end;
1948 else
1949 do;
1950 template.tword (Twords) = substr (word_text, 1, Ibreak - 1);
1951 Pword_text = addr (word_text_arr (Ibreak));
1952 Lword_text = length (word_text) - (Ibreak - 1);
1953 Iskip = verify (word_text, WORD_BREAKS);
1954
1955 if Iskip > 0
1956 then
1957 do;
1958 Pword_text = addr (word_text_arr (Iskip));
1959 Lword_text = length (word_text) - (Iskip - 1);
1960 end;
1961 else Lword_text = 0;
1962 end;
1963 end;
1964
1965 return;
1966
1967
1968
1969
1970
1971 parse_templates_$get_template_pnotice:
1972 entry returns (1 aligned, 2 char (32), 2 char (4), 2 fixed bin, 2 fixed bin);
1973
1974 dcl 1 ret aligned,
1975 2 Aname char (32),
1976 2 Adate char (4),
1977 2 Atype fixed bin,
1978 2 Aseq fixed bin;
1979
1980
1981 ret.Aname =
1982 before (pnotice_paths.templates (Ntemplates_parsed).primary_name,
1983 ".pnotice");
1984 if SI_yrno > 0
1985 then ret.Adate = source_year_a (SI_yrno);
1986 else ret.Adate = "";
1987 ret.Atype = pnotice_paths.templates (Ntemplates_parsed).type;
1988 seqno = seqno + 1;
1989 ret.Aseq = seqno;
1990 return (ret);
1991
1992 end parse_templates_;
1993
1994
1995
1996
1997
1998 end pnotice_parse;
1999
2000
2001 %page;
2002
2003
2004
2005 continue_processing:
2006 proc (SI, TI) returns (bit (1));
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026 dcl 1 SI aligned like source_info,
2027
2028 1 TI aligned like target_info;
2029
2030
2031
2032 dcl Iname fixed bin,
2033 Idx1 fixed bin,
2034 Idx2 fixed bin,
2035 Acode fixed bin (35),
2036 match bit (1),
2037 addC bit (1),
2038 addTS bit (1),
2039 addPD bit (1),
2040 foundPD bit (1),
2041 foundC bit (1),
2042 foundTS bit (1);
2043
2044
2045 Acode = 0;
2046 addC = False;
2047 addTS = False;
2048 addPD = False;
2049 foundPD = False;
2050 foundC = False;
2051 match = False;
2052 Iname = 1;
2053
2054 if SI.Nnotices = 0
2055 then
2056 do;
2057 if ^Fname & ^Ftrade_secret & ^DFtrade_secret & ^Fcopy_right
2058 & ^DFcopy_right & ^Fpublic_domain
2059 then
2060 do;
2061 call com_err_ (0, ME, "
2062 No protection notices were found in ^a ^a^[>^]^[^a::^;^s^]^a^a", " ",
2063 SI.dir, SI.dir ^= ">", SI.archive_name ^= "", SI.archive_name,
2064 SI.entry, ".");
2065 return (False);
2066 end;
2067
2068 TI.Nnotices = 1;
2069 TI.notice (TI.Nnotices).name = SI.notice_to_add.name;
2070 TI.notice (TI.Nnotices).date = current_year_a;
2071 seqno = seqno + 1;
2072 TI.notice (TI.Nnotices).seq = ltrim (char (seqno));
2073 if Sdfcopyright then Sprt_notice = True;
2074 return (True);
2075 end;
2076
2077
2078
2079 if SI.notice_to_add.type = TRADE_SECRET then addTS = True;
2080 else if SI.notice_to_add.type = PUBLIC_DOMAIN then addPD = True;
2081 else addC = True;
2082 do Idx1 = 1 to SI.Nnotices;
2083 if SI.notice_info (Idx1).notice_type = TRADE_SECRET then foundTS = True;
2084 else if SI.notice_info (Idx1).notice_type = PUBLIC_DOMAIN
2085 then foundPD = True;
2086 else foundC = True;
2087 end;
2088 if foundC & foundTS
2089 then
2090 do;
2091 Acode = error_table_$not_done;
2092 if SI.archive_name ^= ""
2093 then call com_err_ (Acode, ME,
2094 "^/Processing ^a. The module has mixed copyright and trade secret notices.",
2095 pathname_$component (SI.dir, SI.archive_name, SI.entry));
2096 else call com_err_ (Acode, ME,
2097 "^/Processing ^a. The module has mixed copyright and trade secret notices.",
2098 pathname_ (SI.dir, SI.entry));
2099 return (False);
2100 end;
2101 if foundC & foundPD
2102 then
2103 do;
2104 Acode = error_table_$not_done;
2105 if SI.archive_name ^= ""
2106 then call com_err_ (Acode, ME,
2107 "^/Processing ^a. The module has mixed copyright and public domain notices.",
2108 pathname_$component (SI.dir, SI.archive_name, SI.entry));
2109 else call com_err_ (Acode, ME,
2110 "^/Processing ^a. The module has mixed copyright and public domain notices.",
2111 pathname_ (SI.dir, SI.entry));
2112 return (False);
2113 end;
2114 if foundTS & foundPD
2115 then
2116 do;
2117 Acode = error_table_$not_done;
2118 if SI.archive_name ^= ""
2119 then call com_err_ (Acode, ME,
2120 "^/Processing ^a. The module has mixed trade secret and public domain notices.",
2121 pathname_$component (SI.dir, SI.archive_name, SI.entry));
2122 else call com_err_ (Acode, ME,
2123 "^/Processing ^a. The module has mixed trade secret and public domain notices.",
2124 pathname_ (SI.dir, SI.entry));
2125 return (False);
2126 end;
2127 if addTS & foundTS
2128 then
2129 do;
2130 do Idx1 = 1 to SI.Nnotices
2131 while (SI.notice_to_add.name ^= SI.notice_info (Idx1).notice_name)
2132 ;
2133 end;
2134 if Idx1 ^> SI.Nnotices
2135 then
2136 do;
2137 Acode = error_table_$not_done;
2138 if SI.archive_name ^= ""
2139 then call com_err_ (Acode, ME,
2140 "^/Processing ^a.^/Duplicate Trade Secret notices not allowed.",
2141 pathname_$component (SI.dir, SI.archive_name, SI.entry));
2142 else call com_err_ (Acode, ME,
2143 "^/Processing ^a.^/Duplicate Trade Secret notices are not allowed.",
2144 pathname_ (SI.dir, SI.entry));
2145 return (False);
2146 end;
2147 end;
2148 else if addPD & foundPD
2149 then
2150 do;
2151 Acode = error_table_$not_done;
2152 if SI.archive_name ^= ""
2153 then call com_err_ (Acode, ME,
2154 "^/Processing ^a.^/Multiple Public Domain notices not allowed.",
2155 pathname_$component (SI.dir, SI.archive_name, SI.entry));
2156 else call com_err_ (Acode, ME,
2157 "^/Processing ^a.^/Multiple Public Domain notices not allowed.",
2158 pathname_ (SI.dir, SI.entry));
2159 return (False);
2160 end;
2161 else if addC & foundC then ;
2162 else
2163 do;
2164 Acode = error_table_$not_done;
2165 if SI.archive_name ^= ""
2166 then call com_err_ (Acode, ME,
2167 "^/Found ^[Copyright^;Trade Secret^;Public Domain^] notice in ^a.^/Cannot add ^a.",
2168 SI.notice_info (1).notice_type,
2169 pathname_$component (SI.dir, SI.archive_name, SI.entry),
2170 SI.notice_to_add.name);
2171 else call com_err_ (Acode, ME,
2172 "^/Found ^[Copyright^;Trade Secret^;Public Domain^] notice in ^a.^/Cannot add ^a.",
2173 SI.notice_info (1).notice_type, pathname_ (SI.dir, SI.entry),
2174 SI.notice_to_add.name);
2175 return (False);
2176 end;
2177
2178
2179 TI.Nnotices = 0;
2180 if ^Ftrade_secret & ^Fpublic_domain
2181 then
2182 if ok_nine_year_rule (SI)
2183 then
2184 do;
2185 do Idx1 = 1 to SI.Nnotices while
2186
2187
2188 ((SI.notice_to_add.name ^= SI.notice_info (Idx1).notice_name)
2189 | (SI.notice_to_add.name = SI.notice_info (Idx1).notice_name
2190 & current_year ^= source_year (Idx1)));
2191 end;
2192 if Idx1 > SI.Nnotices
2193 then
2194 do;
2195 TI.Nnotices = 1;
2196 TI.notice (1).name = SI.notice_to_add.name;
2197
2198 TI.notice (1).date = current_year_a;
2199
2200 seqno = seqno + 1;
2201 TI.notice (1).seq = ltrim (char (seqno));
2202 if Sdfcopyright then Sprt_notice = True;
2203 end;
2204 end;
2205
2206
2207 if Sno_args_given
2208 then if ^Sadd_default_pnotice
2209 then return (False);
2210
2211 if Fname & Ftrade_secret
2212 then
2213 do;
2214 TI.Nnotices = 1;
2215 TI.notice (1).name = SI.notice_to_add.name;
2216 seqno = seqno + 1;
2217 TI.notice (1).seq = ltrim (char (seqno));
2218 end;
2219
2220
2221 do Idx1 = 1 to SI.Nnotices - 1;
2222 do Idx2 = Idx1 + 1 to SI.Nnotices;
2223 if SI.notice_info (Idx1).notice_name
2224 = SI.notice_info (Idx2).notice_name
2225 & SI.notice_info (Idx1).notice_date
2226 = SI.notice_info (Idx2).notice_date
2227 then
2228 SI.notice_info (Idx2).notice_name = "";
2229 end;
2230 end;
2231
2232
2233 do Idx1 = 1 to SI.Nnotices;
2234 if SI.notice_info (Idx1).notice_name ^= ""
2235 then
2236 do;
2237 TI.Nnotices = TI.Nnotices + 1;
2238
2239 TI.notice (TI.Nnotices).name = SI.notice_info (Idx1).notice_name;
2240 TI.notice (TI.Nnotices).date = SI.notice_info (Idx1).notice_date;
2241 TI.notice (TI.Nnotices).seq =
2242 ltrim (char (SI.notice_info (Idx1).seq));
2243 end;
2244 end;
2245
2246
2247 if TI.Nnotices > 1 then call sort_pnotices (TI);
2248 do Idx1 = 1 to dim (SI.notice_info, 1)
2249 while (SI.notice_info (Idx1).notice_name ^= ""
2250 & SI.notice_info (Idx1).notice_name = TI.notice (Idx1).name
2251 & SI.notice_info (Idx1).notice_date = TI.notice (Idx1).date);
2252 end;
2253 if Idx1 - 1 > dim (SI.notice_info, 1)
2254 then
2255 return (False);
2256 else return (True);
2257
2258
2259 end continue_processing;
2260 %page;
2261
2262
2263
2264 sort_pnotices:
2265 proc (TI);
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279 dcl 1 V aligned,
2280 2 N fixed bin (18),
2281 2 vector (dim (TI.notice, 1)) ptr unaligned;
2282
2283 dcl 1 TI aligned like target_info;
2284
2285 dcl Idx1 fixed bin,
2286 Idx2 fixed bin;
2287 dcl 1 notice aligned like target_info.notice based;
2288 dcl 1 sorted_data (dim (TI.notice, 1)) aligned like target_info.notice;
2289 dcl sort_items_$char
2290 entry (ptr, fixed bin (24));
2291
2292 V.N = TI.Nnotices;
2293 do Idx1 = 1 to TI.Nnotices;
2294 V.vector (Idx1) = addr (TI.notice.sort_field (Idx1));
2295
2296 end;
2297 call sort_items_$char (addr (V),
2298 length (string (TI.notice.sort_field (1))));
2299
2300
2301
2302 Idx2 = 1;
2303 do Idx1 = V.N to 1 by -1;
2304 sorted_data (Idx2) = V.vector (Idx1) -> notice;
2305 Idx2 = Idx2 + 1;
2306 end;
2307 do Idx2 = Idx2 to dim (sorted_data, 1);
2308 string (sorted_data (Idx2)) = "";
2309 end;
2310
2311 TI.notice (*) = sorted_data (*);
2312
2313 end sort_pnotices;
2314
2315 %page;
2316
2317
2318
2319
2320 ok_nine_year_rule:
2321 proc (SI) returns (bit (1));
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336 dcl 1 SI aligned like source_info;
2337
2338 dcl continue bit (1),
2339 new_pnotice_vers
2340 char (32) var,
2341 new_pnotice_date
2342 char (4),
2343 current_pnotice_vers
2344 char (32) var,
2345 current_pnotice_date
2346 char (4);
2347
2348 dcl HBull_name_array
2349 (5) char (80) varying int static options (constant)
2350 init ("HIS", "HIS_A", "HIS_B", "MIT_HIS", "MIT_HIS_A");
2351
2352 dcl most_recent_date
2353 char (4),
2354 Idx2 fixed bin;
2355
2356 continue = True;
2357 new_pnotice_vers = before (SI.notice_to_add.name, ".");
2358 new_pnotice_date = current_year_a;
2359 most_recent_date = "";
2360
2361 if Sno_args_given
2362 then
2363 do Idx1 = 1 to SI.Nnotices;
2364 if SI.notice_info (Idx1).notice_name = new_pnotice_vers
2365
2366 then
2367 do;
2368 Sadd_default_pnotice = False;
2369 return (Sadd_default_pnotice);
2370 end;
2371 if most_recent_date < SI.notice_info (Idx1).notice_date
2372 then most_recent_date = SI.notice_info (Idx1).notice_date;
2373 end;
2374
2375 do Idx1 = 1 to SI.Nnotices while (continue);
2376
2377 current_pnotice_vers = SI.notice_info (Idx1).notice_name;
2378 current_pnotice_date = SI.notice_info (Idx1).notice_date;
2379
2380 if Sno_args_given
2381 then
2382 do;
2383 if SI.notice_info (Idx1).notice_date = most_recent_date
2384 then
2385 do Idx2 = lbound (HBull_name_array, 1)
2386 to hbound (HBull_name_array, 1);
2387 if SI.notice_info (Idx1).notice_name = HBull_name_array (Idx2)
2388
2389 then Sadd_default_pnotice = True;
2390 end;
2391 else Sadd_default_pnotice = False;
2392
2393 return (Sadd_default_pnotice);
2394 end;
2395
2396 if current_pnotice_vers = new_pnotice_vers
2397 then
2398 do;
2399 if current_year <= source_year (Idx1) + 9
2400 then
2401
2402 continue = False;
2403 end;
2404 end;
2405 return (continue);
2406
2407 end ok_nine_year_rule;
2408
2409 %page;
2410
2411
2412
2413
2414 dcl Lmax_line fixed bin (21),
2415 Lmove fixed bin (21),
2416 Lsave fixed bin (21),
2417 Ltext fixed bin (21),
2418 Psave ptr,
2419 Ptext ptr,
2420 move char (Lmove) based,
2421
2422 save_chr (Lsave) char (1) based (Psave),
2423 star_box char (target_info.Lstar_box)
2424 based (target_info.Pstar_box);
2425
2426 make_star_box:
2427 proc (SI, TI);
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437 dcl 1 SI aligned like source_info,
2438
2439 1 TI aligned like target_info;
2440
2441 dcl box_line char (128) var,
2442 Idate fixed bin,
2443 Inotice fixed bin,
2444 Nnotices_in_box
2445 fixed bin;
2446
2447 box_line = "";
2448 Nnotices_in_box = 0;
2449 Ltext = 0;
2450 Lmove = 0;
2451 if Ptext = null
2452 then
2453 do;
2454 call get_temp_segment_ (ME, Ptext, code);
2455
2456 if code ^= 0
2457 then
2458 do;
2459 call com_err_ (code, ME, "
2460 Obtaining temp seg for text and star box.");
2461 goto FATAL_ERROR;
2462 end;
2463 end;
2464 else Ptext = ptr (Ptext, 0);
2465
2466
2467 Psave = Ptext;
2468
2469 do Inotice = 1 to TI.Nnotices;
2470 do Itemplate = 1 to pnotice_paths.Ntemplates;
2471
2472 if TI.notice (Inotice).name
2473 =
2474 before (pnotice_paths.templates (Itemplate).primary_name,
2475 ".pnotice")
2476 then
2477 do;
2478 Lmove = pnotice_paths.templates (Itemplate).Ltemplate + 1;
2479 Psave -> move =
2480 pnotice_paths.templates (Itemplate).Ptemplate -> move;
2481
2482 substr (Psave -> move, Lmove, 1) = NL;
2483
2484
2485 Idate = 0;
2486 Idate = index (Psave -> move, "<yr>");
2487 if Idate ^= 0
2488 then substr (Psave -> move, Idate, 4) = TI.notice (Inotice).date;
2489 Ltext = Ltext + Lmove;
2490 if Inotice = 1
2491 then
2492 do;
2493 save_text = substr (Psave -> move, 1, Ltext);
2494 save_name = SI.notice_to_add.name;
2495 end;
2496 Lsave = Lmove + 1;
2497 Psave = addr (save_chr (Lsave));
2498 Nnotices_in_box = Nnotices_in_box + 1;
2499
2500 end;
2501 end;
2502 end;
2503 if Nnotices_in_box ^= TI.Nnotices
2504 then
2505 do;
2506 if SI.archive_name ^= ""
2507 then call com_err_ (0, ME,
2508 "^/A programming error has occurred while processing ^a.^/Total number of notices (^d) is inconsistent with target information (^d).^/Operation not performed.",
2509 pathname_$component (SI.dir, SI.archive_name, SI.entry),
2510 Nnotices_in_box, TI.Nnotices);
2511 else call com_err_ (0, ME,
2512 "^/A programming error has occurred while processing ^a.^/Total number of notices (^d) is inconsistent with target information (^d).^/Operation not performed.",
2513 pathname_ (SI.dir, SI.entry), Nnotices_in_box, TI.Nnotices);
2514 goto FATAL_ERROR;
2515 end;
2516 call find_line$init (Ptext, Ltext);
2517 Lmax_line = 0;
2518 do while (find_line ());
2519 Lmax_line = max (Lmax_line, length (line));
2520
2521 end;
2522
2523 TI.Pstar_box = Psave;
2524
2525 TI.Lstar_box = 0;
2526 call add_text$init (addr (TI));
2527 goto TYPE (SI.type);
2528
2529 TYPE (1):
2530 TYPE (4):
2531
2532 call add_text$var (SI.cmt_bgn);
2533 call add_text$fixed (SP);
2534 call add_text$substr (STARS, Lmax_line + length ("* *"));
2535 call add_text$fixed (NL);
2536 call add_text$substr (SPACES, length (SI.cmt_bgn) + length (SP));
2537 call add_text$fixed (STAR);
2538 call add_text$substr (SPACES, Lmax_line + length (" "));
2539 call add_text$fixed (STAR);
2540 call add_text$fixed (NL);
2541
2542 call find_line$init (Ptext, Ltext);
2543 do while (find_line ());
2544 call add_text$substr (SPACES, length (SI.cmt_bgn) + length (SP));
2545 call add_text$fixed (STAR);
2546 call add_text$fixed (SP);
2547 call add_text$fixed (line);
2548 call add_text$substr (SPACES, Lmax_line - length (line));
2549 call add_text$fixed (sfx_string);
2550 end;
2551 call add_text$substr (SPACES, length (SI.cmt_bgn) + length (SP));
2552 call add_text$substr (STARS, Lmax_line + length ("* *"));
2553 call add_text$fixed (SP);
2554 call add_text$var (SI.cmt_end);
2555 if SI.Nnotices = 0
2556 then
2557 call add_text$fixed (NL_NL);
2558 else call add_text$fixed (NL);
2559
2560 return;
2561
2562 TYPE (2):
2563 TYPE (3):
2564 TYPE (5):
2565
2566 call add_text$var (SI.cmt_bgn);
2567 call add_text$fixed (SP);
2568 call add_text$substr (STARS, Lmax_line + 4);
2569 call add_text$fixed (NL);
2570 call add_text$var (SI.cmt_bgn);
2571 call add_text$fixed (SP_STAR);
2572 call add_text$substr (SPACES, Lmax_line + 2);
2573 call add_text$fixed (STAR);
2574 call add_text$fixed (NL);
2575
2576 call find_line$init (Ptext, Ltext);
2577 do while (find_line ());
2578 call add_text$var (SI.cmt_bgn);
2579 call add_text$fixed (SP_STAR_SP);
2580 call add_text$fixed (line);
2581 call add_text$substr (SPACES, Lmax_line - length (line));
2582 call add_text$fixed (sfx_string);
2583 end;
2584 call add_text$var (SI.cmt_bgn);
2585 call add_text$fixed (SP);
2586 call add_text$substr (STARS, Lmax_line + 4);
2587 if SI.type ^= 5
2588 then call add_text$fixed (NL);
2589 return;
2590 end make_star_box;
2591 %page;
2592
2593
2594
2595 add_text:
2596 proc;
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606 dcl Lold_text fixed bin (21);
2607 dcl TIptr ptr;
2608 dcl 1 TI aligned like target_info based (TIptr);
2609
2610 add_text$init:
2611 entry (Aptr);
2612 dcl Aptr ptr;
2613
2614 TIptr = Aptr;
2615 return;
2616
2617 add_text$fixed:
2618 entry (new_text);
2619
2620 dcl new_text char (*);
2621
2622
2623 Lold_text = TI.Lstar_box;
2624 TI.Lstar_box = TI.Lstar_box + length (new_text);
2625 substr (star_box, Lold_text + 1) = new_text;
2626 return;
2627
2628 add_text$var:
2629 entry (new_var_text);
2630
2631 dcl new_var_text char (*) var;
2632
2633
2634 Lold_text = TI.Lstar_box;
2635 TI.Lstar_box = TI.Lstar_box + length (new_var_text);
2636 substr (star_box, Lold_text + 1) = new_var_text;
2637 return;
2638
2639 add_text$substr:
2640 entry (Astring, Alength);
2641
2642 dcl Astring char (*),
2643 Alength fixed bin (21);
2644
2645 Lold_text = TI.Lstar_box;
2646 TI.Lstar_box = TI.Lstar_box + Alength;
2647 substr (star_box, Lold_text + 1) = substr (Astring, 1, Alength);
2648 return;
2649
2650 end add_text;
2651
2652 %page;
2653
2654
2655
2656
2657 check_acl:
2658 proc (Aptr, Adir, Aentry, Amust_reset);
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670 dcl Aptr ptr,
2671 Adir char (*),
2672 Aentry char (*),
2673 Amode_set bit (1),
2674 Amust_reset bit (1);
2675 dcl Acode fixed bin (35),
2676 old_mode bit (36) aligned;
2677
2678
2679 dcl 1 acle (1),
2680
2681 2 name char (32) aligned,
2682 2 mode bit (36) aligned,
2683 2 mbz bit (36) aligned,
2684 2 code fixed bin (35);
2685
2686 dcl 1 del_acl (1),
2687 2 name char (32) aligned,
2688 2 code fixed bin (35);
2689
2690 dcl one_word char (4) based,
2691 error_table_$lower_ring
2692 fixed bin (35) ext static,
2693 error_table_$user_not_found
2694 fixed bin (35) ext static;
2695
2696 Amust_reset = False;
2697 on not_in_write_bracket
2698 begin;
2699 call com_err_ (error_table_$lower_ring, ME, "
2700 Writing ^a>^a.", Adir, Aentry);
2701 goto FATAL_ERROR;
2702 end;
2703
2704 on no_write_permission goto FORCE_ACL;
2705 Aptr -> one_word = Aptr -> one_word;
2706 return;
2707
2708
2709 FORCE_ACL:
2710 acle (1).name = get_group_id_ ();
2711 acle (1).mode = "0"b;
2712 acle (1).mbz = "0"b;
2713 acle (1).code = 0;
2714 call hcs_$list_acl (Adir, Aentry, null, null, addr (acle), 1, Acode);
2715 if acle (1).code ^= 0
2716 then if acle (1).code = error_table_$user_not_found
2717 then
2718 Amode_set = False;
2719 else goto ERROR;
2720 else
2721 do;
2722 if Acode ^= 0
2723 then
2724 do;
2725 acle (1).code = Acode;
2726 goto ERROR;
2727 end;
2728 Amode_set = True;
2729 old_mode = acle (1).mode;
2730 end;
2731 acle (1).mode = "101"b;
2732 acle (1).mbz = "0"b;
2733 acle (1).code = 0;
2734 call hcs_$add_acl_entries (Adir, Aentry, addr (acle), 1, Acode);
2735 if Acode ^= 0
2736 then
2737 do;
2738 call com_err_ (Acode, ME, "
2739 Unable to force write access for ^a to ^a>^a.", acle (1).name, Adir, Aentry);
2740 goto FATAL_ERROR;
2741 end;
2742 Amust_reset = True;
2743 return;
2744 ERROR:
2745 call com_err_ (acle (1).code, ME, "
2746 When listing ^a's access to ^a>^a", acle (1).name, Adir, Aentry);
2747 goto FATAL_ERROR;
2748
2749
2750
2751
2752 check_acl$reset_acl:
2753 entry (Aptr, Adir, Aentry, Amode_set);
2754
2755 acle (1).name = get_group_id_ ();
2756
2757 if Amode_set
2758 then
2759 do;
2760 acle (1).mode = old_mode;
2761 acle (1).mbz = "0"b;
2762 acle (1).code = 0;
2763 call hcs_$add_acl_entries (Adir, Aentry, addr (acle), 1, Acode);
2764 if acle (1).code ^= 0
2765 then
2766 do;
2767 call com_err_ (Acode, ME, "
2768 Restoring access for ^a to ^a>^a.", acle (1).name, Adir, Aentry);
2769 return;
2770 end;
2771 end;
2772 else
2773 do;
2774 del_acl (1).name = acle (1).name;
2775 del_acl (1).code = 0;
2776 call hcs_$delete_acl_entries (Adir, Aentry, addr (del_acl), 1, Acode);
2777 if Acode ^= 0 then call com_err_ (Acode, ME, "
2778 Removing access for ^a to ^a>^a.", del_acl (1).name, Adir, Aentry);
2779 return;
2780 end;
2781 return;
2782
2783 end check_acl;
2784
2785 %page;
2786
2787
2788
2789
2790 dcl Lline fixed bin (21),
2791 Ltemp fixed bin (21),
2792 Pline ptr,
2793 Ptemp ptr,
2794 line char (Lline) based (Pline),
2795
2796 temp char (Ltemp) based (Ptemp),
2797
2798 temp_chr (Ltemp) char (1) based (Ptemp);
2799
2800 find_line:
2801 proc returns (bit (1));
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814 if Ltemp <= 0
2815 then return (False);
2816 else
2817 do;
2818 Pline = Ptemp;
2819 Lline = search (temp, NL);
2820 Ptemp = addcharno (addr (temp_chr (Lline)), 1);
2821 Ltemp = Ltemp - Lline;
2822 Lline = Lline - 1;
2823 end;
2824 return (True);
2825
2826
2827
2828
2829 find_line$init:
2830 entry (Pstr, Lstr);
2831 dcl Pstr ptr,
2832 Lstr fixed bin (21);
2833 Ptemp = Pstr;
2834 Ltemp = Lstr;
2835 return;
2836
2837 find_line$remainder_length:
2838 entry returns (fixed bin (21));
2839
2840 return (Ltemp);
2841
2842 end find_line;
2843
2844
2845
2846
2847 %page;
2848
2849
2850 dcl new_box char (target_info.Lnew_box)
2851 based (target_info.Pnew_box);
2852
2853 insert_notice:
2854 proc (SI, TI);
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867 dcl 1 SI aligned like source_info,
2868
2869 1 TI aligned like target_info;
2870
2871
2872
2873 dcl Psource ptr,
2874 Ptarget ptr;
2875
2876 Psource = addcharno (TI.Pnew_box, SI.Lold_box);
2877 Ptarget = addcharno (TI.Pnew_box, TI.Lnew_box);
2878
2879
2880 if TI.Lnew_box > SI.Lold_box
2881 then
2882 call pnotice_mrl_ (Psource, SI.Lentry - SI.Lold_box, Ptarget,
2883 SI.Lentry - SI.Lold_box);
2884 else if TI.Lnew_box < SI.Lold_box
2885 then
2886
2887 call pnotice_mlr_ (Psource, SI.Lentry - SI.Lold_box, Ptarget,
2888 SI.Lentry - SI.Lold_box);
2889
2890 TI.Lentry = (SI.Lentry - SI.Lold_box) + TI.Lnew_box;
2891
2892 new_box = star_box;
2893
2894
2895
2896
2897 call terminate_file_ (TI.Pentry, TI.Lentry * 9, TERM_FILE_TRUNC_BC, code);
2898
2899
2900
2901
2902 end insert_notice;
2903 %page;
2904
2905
2906
2907 dcl Lt fixed bin (21),
2908 Pt ptr,
2909 template char (Lt) based,
2910 dt char (4);
2911
2912
2913 report:
2914 proc (SI, TI);
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925 dcl 1 SI aligned like source_info;
2926 dcl 1 TI aligned like target_info;
2927 dcl Inotice fixed bin,
2928 Itemplate fixed bin;
2929 dcl pnames (SI.Nnotices) char (32);
2930 dcl Iyr fixed bin (24);
2931
2932
2933 if SI.Nnotices = 0
2934 then
2935 do;
2936 if ^imbedded_notices (SI)
2937 then if SI.archive_name ^= ""
2938 then call ioa_ ("Warning: ^a has no protection notice.",
2939 pathname_$component (SI.dir, SI.archive_name, SI.entry))
2940 ;
2941 else call ioa_ ("Warning: ^a has no protection notice.",
2942 pathname_ (SI.dir, SI.entry));
2943 else if SI.archive_name ^= ""
2944 then call ioa_ ("Warning: ^a has an imbedded notice.",
2945 pathname_$component (SI.dir, SI.archive_name, SI.entry));
2946 else call ioa_ ("Warning: ^a has an imbedded notice.",
2947 pathname_ (SI.dir, SI.entry));
2948 return;
2949 end;
2950 if TI.long_output
2951 then
2952 do;
2953 call ioa_ ("^[^5x^a^2s^;^s^a>^a^/^]", SI.archive_name ^= "", SI.entry,
2954 SI.dir, SI.entry);
2955 do Inotice = 1 to SI.Nnotices;
2956 do Itemplate = 1 to pnotice_paths.Ntemplates;
2957 if (SI.notice_info (Inotice).notice_name
2958 =
2959 before (pnotice_paths.templates (Itemplate).primary_name,
2960 ".pnotice"))
2961 then
2962 do;
2963 Lt = pnotice_paths.templates (Itemplate).Ltemplate;
2964 Pt = pnotice_paths.templates (Itemplate).Ptemplate;
2965
2966 if index (Pt -> template, "<yr>") = 0
2967 then call ioa_ ("^a^/", Pt -> template);
2968 else
2969 do;
2970 Iyr = index (Pt -> template, "<yr>");
2971 dt = SI.notice_info (Inotice).notice_date;
2972 call print_template (Pt, Lt, Iyr, dt);
2973 end;
2974 Itemplate = pnotice_paths.Ntemplates;
2975 end;
2976 end;
2977 end;
2978 end;
2979 else
2980 do;
2981 do Idx1 = 1 to SI.Nnotices;
2982 pnames (Idx1) = SI.notice_info (Idx1).notice_name;
2983 end;
2984 call ioa_ ("^[^5x^a^2s^;^s^a>^a^/^]^(^40t^a^/^)",
2985 SI.archive_name ^= "", SI.entry, SI.dir, SI.entry, pnames);
2986 end;
2987 end report;
2988 %page;
2989 print_template:
2990 proc (Ppt, Plt, Pyr, Pdt);
2991
2992 dcl Ppt ptr,
2993 Plt fixed bin (21),
2994 Pyr fixed bin (24),
2995 Pdt char (4),
2996 store_template char (Plt),
2997 store_templateb
2998 char (Plt) based;
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009 store_template = Ppt -> store_templateb;
3010 substr (store_template, Pyr, 4) = Pdt;
3011 call ioa_ ("^a^/", store_template);
3012 return;
3013
3014 end print_template;
3015
3016
3017 %page;
3018
3019
3020
3021
3022 imbedded_notices:
3023 proc (SI) returns (bit (1));
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035 dcl 1 SI aligned like source_info;
3036 dcl sub_seg char (Lsub) based (Psub),
3037 Iseg fixed bin,
3038 Lseg fixed bin (21),
3039 Lsub fixed bin (21),
3040 Pseg ptr,
3041 Psub ptr;
3042
3043 Pseg = SI.Pentry;
3044 Lseg = SI.Lentry;
3045 Psub = Pseg;
3046 Lsub = 0;
3047 call find_line$init (Pseg, Lseg);
3048 do Iseg = 1 to 60 while (find_line ());
3049
3050 Lsub = Lsub + length (line) + length (NL);
3051 end;
3052 if (index (sub_seg, "Copyright") = 0 & index (sub_seg, "PROPRIETARY") = 0
3053 & index (sub_seg, "PUBLIC") = 0)
3054 then return (False);
3055 else return (True);
3056 end imbedded_notices;
3057
3058 %page;
3059
3060
3061 clean_up:
3062 proc;
3063
3064
3065 if ^Farchive
3066 then
3067 do;
3068 if source_info.Pentry ^= null
3069 then call terminate_file_ (source_info.Pentry, bit_count,
3070 TERM_FILE_TERM, code);
3071 end;
3072 else
3073 do;
3074 if Pcomp_info ^= null
3075 then
3076 do;
3077 do Idx1 = 1 to comp_info.Ncomp;
3078
3079 if comp_info.array (Idx1).ptr ^= null
3080 then
3081 do;
3082 call hcs_$delentry_seg (comp_info.array (Idx1).ptr, code);
3083 end;
3084 end;
3085 call release_temp_segment_ (ME, Pcomp_info, code);
3086
3087 end;
3088 if source_info.archive_name ^= ""
3089 then call terminate_file_ (source_info.Parchive, bit_count,
3090 TERM_FILE_TERM, code);
3091 else if source_info.Pentry ^= null
3092 then call terminate_file_ (source_info.Pentry, bit_count,
3093 TERM_FILE_TERM, code);
3094 end;
3095
3096
3097 if Ppaths ^= null
3098 then
3099 do;
3100 do Itemplate = 1 to dim (pnotice_paths.templates, 1);
3101 call terminate_file_ (pnotice_paths.templates (Itemplate).Ptemplate,
3102 pnotice_paths.templates (Itemplate).Ltemplate * 9,
3103 TERM_FILE_TERM, code);
3104 end;
3105 call release_temp_segment_ (ME, Ppaths, code);
3106 end;
3107
3108
3109 if Ptext ^= null then call release_temp_segment_ (ME, Ptext, code);
3110
3111
3112
3113 end clean_up;
3114 %page;
3115
3116
3117
3118 %include arg_list;
3119 dcl arg_list_arg_count
3120 fixed bin;
3121 dcl 1 al aligned based (Pal),
3122
3123 2 header like arg_list.header,
3124 2 ap (0 refer (al.header.arg_count)) ptr,
3125
3126 2 dp (0 refer (al.header.desc_count)) ptr;
3127
3128 %page;
3129 %include descriptor;
3130 dcl 1 desc (comp_info.Ncomp + 2) aligned based (Pdesc) like desc_;
3131
3132 %page;
3133 %include desc_types;
3134 %page;
3135 %include pnotice_paths;
3136 %page;
3137 %include pnotice_source_info;
3138 %page;
3139 %include pnotice_target_info;
3140 %page;
3141 %include terminate_file;
3142
3143 end add_pnotice;