1
2
3
4
5
6
7
8
9
10 update_seg: us: procedure
11 options ( rename (( alloc_, smart_alloc_ )) );
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 dcl com_err_ entry options (variable),
71 command_query_ entry options (variable),
72 condition_ entry (char(*), entry),
73 condition_interpreter_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char(*), ptr, ptr),
74 continue_to_signal_ entry (fixed bin(35)),
75 cu_$arg_count entry (fixed bin),
76 cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin(35)),
77 cu_$cl entry,
78 cu_$level_get entry returns (fixed bin),
79 cv_dec_check_ entry (char(*), fixed bin(35)) returns (fixed bin(35)),
80 cv_mode_ entry (char(*), bit(36) aligned, fixed bin(35)),
81 cv_userid_ entry (char(*)) returns (char(32)),
82 date_time_ entry (fixed bin(71), char(*) aligned),
83 date_time_$fstime entry (fixed bin(35), char(*) aligned),
84 equal_ entry (ptr, ptr, ptr, fixed bin(35)),
85 expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin(35)),
86 find_condition_info_ entry (ptr, ptr, fixed bin(35)),
87 get_group_id_$tag_star entry returns (char(32) aligned),
88 get_process_id_ entry returns (bit(36) aligned),
89 get_wdir_ entry returns (char(168) aligned),
90 hcs_$delentry_file entry (char(*), char(*), fixed bin(35)),
91 ioa_$ioa_stream entry options (variable),
92 ios_$attach entry (char(*), char(*), char(*), char(*), bit(72) aligned),
93 ios_$detach entry (char(*), char(*), char(*), bit(72) aligned),
94 msa_manager_$area_handler entry (ptr, char(*), ptr, ptr, bit(1) aligned),
95 msa_manager_$make_special entry (fixed bin, char(*), char(*), ptr, fixed bin, ptr, fixed bin(35)),
96 msa_manager_$initiate entry (char(*), char(*), ptr, fixed bin, ptr, fixed bin(35)),
97 msa_manager_$terminate entry (ptr, fixed bin(35)),
98 msf_manager_$adjust entry (ptr, fixed bin, fixed bin(24), bit(3), fixed bin(35)),
99 msf_manager_$close entry (ptr),
100 msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35)),
101 upd_print_acl_ entry (ptr, fixed bin, bit(*)),
102 reversion_ entry (char(*)),
103 set_lock_$lock entry (bit(36) aligned, fixed bin, fixed bin(35)),
104 set_lock_$unlock entry (bit(36) aligned, fixed bin(35)),
105 suffixed_name_$find entry (char(*), char(*), char(*), char(*), fixed bin(2), fixed bin(5),
106 fixed bin(35)),
107 suffixed_name_$new_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)),
108 upd_add_task_$init entry (ptr, ptr),
109 upd_add_task_$reset entry (ptr),
110 upd_gen_call_ entry (ptr, ptr),
111 upd_print_err_ entry options (variable),
112 upd_task_ entry (bit(1), ptr, entry, ptr),
113 upd_thread_task_ entry (ptr, ptr);
114
115 dcl upd_install_task_ entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
116 (3) char(168), (3) char(32), (3) fixed bin(5), (3) ptr, (3) fixed bin, (3) ptr,
117 (3) fixed bin, bit(36) aligned, ptr, fixed bin(18), bit(1), char(168) aligned,
118 fixed bin(35), fixed bin(35)),
119 upd_install_task_$init entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
120 bit(1), bit(1), ptr, char(32) aligned),
121 upd_describe_task_ entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
122 ptr, char (168) aligned, ptr, fixed bin(35) ),
123 upd_subtask_ entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
124 ptr, ptr);
125
126 dcl (addr, baseno, clock, dim, fixed, index, length, max, mod, null, size, substr)
127 builtin;
128
129 dcl (error_table_$bad_conversion,
130 error_table_$bad_ring_brackets,
131 error_table_$badcall,
132 error_table_$badopt,
133 error_table_$dirseg,
134 error_table_$fatal_error,
135 error_table_$improper_data_format,
136 error_table_$invalid_lock_reset,
137 error_table_$segno_in_use,
138 error_table_$locked_by_this_process,
139 error_table_$lock_wait_time_exceeded,
140 error_table_$moderr,
141 error_table_$namedup,
142 error_table_$noentry,
143 error_table_$not_done,
144 error_table_$out_of_bounds,
145 error_table_$out_of_sequence,
146 error_table_$seg_not_found,
147 error_table_$seglock,
148 error_table_$too_many_names,
149 error_table_$too_many_acl_entries,
150 error_table_$wrong_no_of_args)
151 fixed bin(35) ext static;
152
153 dcl (sys_info$default_max_length,
154 sys_info$max_seg_size) fixed bin ext static;
155
156 dcl area area based (Pmsa_ptr);
157
158 dcl (argp, fp, p, q, inp, rqp, desp) ptr;
159
160 dcl (logp, msa_ptr) ptr int static init (null);
161
162 dcl Pmsa_ptr ptr based (msa_ptr);
163
164 dcl a fixed bin,
165 argi fixed bin,
166 argl fixed bin,
167 code fixed bin(35),
168 f fixed bin,
169 fail fixed bin,
170 fl fixed bin,
171 (i, j) fixed bin,
172 mode fixed bin(5),
173 n fixed bin,
174 nargs fixed bin,
175 npath fixed bin,
176 option fixed bin,
177 r fixed bin,
178 state fixed bin,
179 status bit(72) aligned,
180 type fixed bin(2);
181
182 dcl arg char(argl) based (argp);
183
184 dcl answer char(3) aligned,
185 date char(24) aligned,
186 dir (3) char(168),
187 doc_dir char(168) aligned,
188 docsw bit(1) init ("0"b),
189 dummy char(1),
190 eqseg char(32),
191 fcbp ptr,
192 function char(fl) based (fp),
193 init_log_segment char(168) aligned,
194 listdir char(168),
195 Llistdir fixed bin,
196 listseg char(32),
197 logdir char(168) int static,
198 logseg char(32) int static,
199 maxl fixed bin(18) init (0),
200 proc char(10) aligned int static init ("update_seg"),
201 seg (3) char(32),
202 tseg char(32),
203 Version_No char(4) aligned int static init ("1.6"),
204 xxx char(16);
205
206 dcl ctlw bit(36) aligned,
207 eqsw bit(1) aligned,
208 nofillsw bit(1) aligned,
209 rstrtsw bit(1) aligned,
210 stopsw bit(1) aligned,
211 sws bit(36) aligned;
212
213 dcl owp ptr;
214
215
216 dcl 1 request_option_word aligned based (owp),
217 (2 archivesw bit (1),
218 2 old_namesw bit (1),
219 2 spec_segsw bit (1),
220 2 logsw bit (1),
221 2 defersw bit (1),
222 2 mlsw bit (1),
223 2 pad bit (30)) unal;
224
225 dcl 1 print_option_word aligned based (owp),
226 (2 errorsw bit (1),
227 2 briefsw bit (1),
228 2 longsw bit (1),
229 2 log_sw bit (1),
230 2 pad bit (32)) unal;
231
232 dcl 1 clear_option_word aligned based (owp),
233 (2 cerrorsw bit (1),
234 2 uidsw bit (1),
235 2 pad bit (34)) unal;
236
237 dcl 1 install_option_word aligned based (owp),
238 (2 stopsw bit (1),
239 2 pad bit (35)) unal;
240
241 dcl 1 init_option_word aligned based (owp),
242 (2 restartsw bit (1),
243 2 padd bit (2),
244 2 log_sw bit (1),
245 2 pad bit (32)) unal;
246
247 dcl (endlabel, errlabel) label local;
248
249 dcl faultlabel label local init (logerr);
250
251
252
253 dcl 1 stat based (addr (status)),
254 2 code fixed bin(35);
255
256
257 dcl 1 global_default aligned int static,
258 2 log_directory char (168) aligned init (""),
259 2 rb (3) fixed bin init (1,5,5),
260 2 acl,
261 3 n fixed bin init (1),
262 3 a1,
263 4 userid char(32) init ("*.*.*"),
264 4 mode bit(36) init ("1100"b),
265 4 bits bit(36) init ("0"b),
266 4 code fixed bin(35) init (0),
267 3 a2 (29),
268 4 userid char(32),
269 4 mode bit(36),
270 4 pad bit(36),
271 4 code fixed bin(35);
272
273 dcl 1 t aligned,
274 2 log_directory char (168) aligned,
275 2 rb (3) fixed bin,
276 2 acl (3),
277 3 n fixed bin,
278 3 a (30),
279 4 userid char(32),
280 4 mode bit(36),
281 4 pad bit(36),
282 4 code fixed bin(35),
283 2 names (3),
284 3 n fixed bin,
285 3 a (30),
286 4 name char(32),
287 4 pcode fixed bin(35),
288 4 rcode fixed bin(35);
289
290 dcl 1 default aligned based,
291 2 log_directory char (168) aligned,
292 2 rb (3) fixed bin,
293 2 acl,
294 3 n fixed bin,
295 3 a (30),
296 4 userid char(32),
297 4 mode bit(36),
298 4 pad bit(36),
299 4 code fixed bin(35);
300
301 dcl 1 acl (n) aligned based,
302 2 userid char(32),
303 2 mode bit(36),
304 2 pad bit(36),
305 2 code fixed bin(35);
306
307 dcl 1 names (n) aligned based,
308 2 name char(32),
309 2 pcode fixed bin(35),
310 2 rcode fixed bin(35);
311
312 dcl 1 in aligned based(inp),
313 2 temp ptr init (null),
314 2 taskp ptr init (null),
315 2 code fixed bin(35) init (0),
316 2 sev fixed bin init (0),
317 2 seqno fixed bin init (0),
318 2 io_name char (32) aligned init ("");
319
320 dcl 1 desc aligned based (desp),
321 2 taskp ptr init (null),
322 2 code fixed bin(35) init (0),
323 2 sev fixed bin init (0),
324 2 seqno fixed bin init (1),
325 2 temp ptr init (null);
326
327 dcl 1 rq aligned based(rqp),
328 2 temp ptr init (null),
329 2 taskp ptr init (null),
330 2 ap (3) ptr init ((3) null),
331 2 np (3) ptr init ((3) null),
332 2 an (3) fixed bin init ((3) 0),
333 2 nn (3) fixed bin init ((3) 0),
334 2 code fixed bin(35) init (0),
335 2 sev fixed bin init (0),
336 2 seqno fixed bin init (0),
337 2 dir (3) char(168) unal,
338 2 seg (3) char(32) unal,
339 2 rb (3) fixed bin(5),
340 2 maxlen fixed bin(18),
341 2 options bit(36);
342
343 dcl 1 log aligned based (logp),
344 2 version char(4) aligned,
345 2 init_id bit(36),
346 2 selfp ptr,
347 2 areap ptr,
348 2 linkp ptr,
349 2 listp ptr,
350 2 processp ptr,
351 2 nullp ptr,
352 2 lock,
353 3 word bit(36) aligned,
354 3 group_id char(32) aligned,
355 2 fcn (4),
356 3 group_id char(32) aligned,
357
358 3 date fixed bin(35),
359 2 sw aligned,
360 (3 full_recovery bit(1),
361 3 special_segs bit(1),
362 3 error bit(1),
363 3 logging_sw bit(1)) unal,
364 2 d,
365 3 log_directory char (168) aligned,
366 3 rb (3) fixed bin,
367 3 acl,
368 4 n fixed bin,
369 4 a (30),
370 5 userid char(32),
371 5 mode bit(36),
372 5 bits bit(36),
373 5 code fixed bin(35),
374 2 description ptr,
375 2 t,
376 3 taskp ptr,
377 3 temp ptr,
378 3 code fixed bin(35),
379 3 sev fixed bin,
380 3 seqno fixed bin,
381 2 area area;
382
383 dcl function_table (20) char(16) aligned int static init (
384 "set_defaults",
385 "print_defaults",
386 "initiate",
387 "print",
388 "add",
389 "replace",
390 "move",
391 "delete",
392 "install",
393 "de_install",
394 "clear",
395 "list",
396 "sd",
397 "pd",
398 "in",
399 "pr",
400 "rp",
401 "mv",
402 "dl",
403 "ls");
404
405 dcl function_index (20) fixed bin int static init (
406 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
407 1, 2, 3, 4, 6, 7, 8, 12);
408
409 dcl option_table (44) char(16) aligned int static init (
410 "-acl",
411 "-delete_acl",
412 "-set_acl",
413 "-ring_brackets",
414 "-name",
415 "-delete_name",
416 "-add_name",
417 "-old_name",
418 "-archive",
419 "-severity",
420 "-restart",
421 "-stop",
422 "-error",
423 "-brief",
424 "-long",
425 "-special_seg",
426 "-log",
427 "-defer",
428 "-uid",
429 "-set_log_dir",
430 "-max_length",
431 "-da",
432 "-sa",
433 "-rb",
434 "-nm",
435 "-dn",
436 "-an",
437 "-onm",
438 "-ac",
439 "-sv",
440 "-rt",
441 "-er",
442 "-bf",
443 "-lg",
444 "-ss",
445 "-df",
446 "-sld",
447 "-ml",
448
449
450 "-initial_acl",
451 "-iacl",
452 "-fill",
453 "-fi",
454 "-no_fill",
455 "-nfi");
456
457 dcl option_index (44) fixed bin int static init (
458 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21,
459 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 14, 15, 16, 18, 20, 21,
460 22, 22, 23, 23, 24, 24);
461
462 dcl option_matrix (24, 12) fixed bin int static init (
463 1, 0, 1, 0, 1, 1, 1, 0, 0, 0, 0, 0,
464 0, 0, 0, 0, 2, 2, 2, 0, 0, 0, 0, 0,
465 0, 0, 0, 0, 3, 3, 3, 0, 0, 0, 0, 0,
466 4, 0, 4, 0, 4, 4, 4, 0, 0, 0, 0, 0,
467 0, 0, 0, 0, 5, 5, 5, 0, 0, 0, 0, 0,
468 0, 0, 0, 0, 6, 6, 6, 0, 0, 0, 0, 0,
469 0, 0, 0, 0, 7, 7, 7, 0, 0, 0, 0, 0,
470 0, 0, 0, 0, 0, 8, 0, 0, 0, 0, 0, 0,
471 0, 0, 0, 0, 9, 9, 9, 0, 0, 0, 0, 0,
472 0, 0, 0, 0, 0, 0, 0, 0, 10, 10, 0, 0,
473 0, 0, 11, 0, 0, 0, 0, 0, 0, 0, 0, 0,
474 0, 0, 0, 0, 0, 0, 0, 0, 12, 12, 0, 0,
475 0, 0, 0, 13, 0, 0, 0, 0, 0, 0, 13, 0,
476 0, 0, 0, 14, 0, 0, 0, 0, 0, 0, 0, 14,
477 0, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 15,
478 0, 0, 0, 0, 16, 16, 16, 16, 0, 0, 0, 0,
479 0, 0, 17, 17, 17, 17, 17, 17, 0, 0, 0, 0,
480 0, 0, 0, 0, 18, 18, 18, 18, 0, 0, 0, 0,
481 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 19, 0,
482 20, 0, 20, 0, 0, 0, 0, 0, 0, 0, 0, 0,
483 0, 0, 0, 0, 21, 21, 21, 0, 0, 0, 0, 0,
484 0, 0, 0, 0, 22, 22, 22, 0, 0, 0, 0, 0,
485 0, 0, 23, 0, 0, 0, 0, 0, 0, 0, 0, 0,
486 0, 0, 24, 0, 0, 0, 0, 0, 0, 0, 0, 0);
487
488 dcl path_matrix (12, 3) fixed bin int static init (
489 0, 0, 0,
490 1, 0, 0,
491 1, 0, 0,
492 1, 0, 0,
493 1, 3, 0,
494 1, 2, 3,
495 2, 3, 0,
496 2, 0, 0,
497 1, 0, 0,
498 1, 0, 0,
499 1, 0, 0,
500 1, 0, 0);
501
502 dcl pmax (12) fixed bin int static init (0, 1, 1, 1, 2, 3, 2, 1, 1, 1, 1, 1),
503 pmin (12) fixed bin int static init (0, 0, 0, 0, 2, 2, 2, 1, 0, 0, 0, 0);
504
505 dcl fail_max fixed bin(35) int static init (5),
506 fail_min fixed bin(35) int static init (1);
507
508 dcl 1 query_info aligned int static,
509 2 version fixed bin init (2),
510 2 yes_no_sw bit(1) unal init ("1"b),
511 2 suppress_name bit(1) unal init ("0"b),
512 2 status fixed bin(35) init (0),
513 2 code fixed bin(35) init (0);
514
515 dcl cleanup condition;
516
517
518
519
520 owp = addr(sws);
521
522 call cu_$arg_count (nargs);
523 if nargs = 0 then do;
524 call com_err_ (error_table_$wrong_no_of_args, (proc),
525 "^/Calling sequence is:^-^a <function> <args> <options>",
526 (proc));
527 return;
528 end;
529 argi = 1;
530 call cu_$arg_ptr (argi, fp, fl, code);
531 if code ^= 0 then
532 go to argerr;
533 do i = 1 to dim (function_table, 1);
534 if function = function_table(i) then do;
535 f = function_index(i);
536 on cleanup begin;
537 call ios_$detach ( "installation_list_", "", "", status);
538 call ios_$detach ( "installation_error_", "", "", status);
539 call unlock_log;
540 end;
541 go to init(f);
542 end;
543 end;
544 call com_err_(error_table_$badcall, (proc), "Unknown updater function specified. ""^a""", function);
545 return;
546
547
548 init(1):
549 join0: p = addr (t);
550 q = addr (global_default);
551 p -> default = q -> default;
552 go to join1;
553
554
555 init(2): npath = 0;
556 go to join1;
557
558
559 init(3): npath = 0;
560 rstrtsw = "0"b;
561 sws = "0"b;
562 nofillsw = "0"b;
563 go to join0;
564
565 init(11): endlabel = return;
566 init(4):
567 init(12): sws = "0"b;
568 npath = 0;
569 go to join1;
570
571
572 init(5):
573 init(6):
574 init(7):
575 init(8): npath = 0;
576 fail = 1;
577 call init_log ("1"b);
578 do i = 1 to 3;
579 dir(i), seg(i) = "";
580 t.acl(i).n, t.names(i).n = 0;
581 end;
582 p = addr (t);
583 q = addr (log.d);
584 p -> default = q -> default;
585 if f ^= 5 then
586 t.acl(1).n = 0;
587 if (f = 6) | (f = 7) then do i = 1 to 3;
588 t.rb(i) = 0;
589 end;
590 npath = 0;
591 sws = "0"b;
592 maxl = sys_info$default_max_length;
593 go to join1;
594
595
596 init(9): stopsw = "0"b;
597 init(10): npath = 0;
598 fail = 1;
599
600
601 join1: option = 0;
602 eqsw = "0"b;
603 nxtarg: argi = argi + 1;
604 if argi > nargs then
605 go to aend(option);
606 call cu_$arg_ptr (argi, argp, argl, code);
607 if code ^= 0 then do;
608 argp = addr (dummy);
609 argl = 0;
610 argerr: call com_err_(code, (proc), """^a"" (arg ^d)", arg, argi);
611 go to return;
612 end;
613 if substr (arg, 1, 1) = "-" then
614 go to aend(option);
615 else
616 go to aarg(option);
617
618 ckopt: if argi > nargs then
619 go to start(f);
620 do i = 1 to dim (option_table, 1);
621 if arg = option_table(i) then do;
622 option = option_matrix(option_index(i), f);
623 if option = 0 then
624 go to badopt;
625 go to abgn(option);
626 end;
627 end;
628 badopt: call com_err_(error_table_$badopt, (proc), "^a", arg);
629 go to return;
630
631 logerr: call com_err_(error_table_$out_of_sequence, (proc), "^/^a.^/^a^a ^a.",
632 "No installation object (io) segment is active", "Type: """,
633 (proc), "initiate <io_path_name>"" to initiate an io segment");
634
635 return: call unlock_log;
636 return_without_unlocking:
637 return;
638
639
640
641
642
643 aarg(0): npath = npath + 1;
644 if npath > pmax(f) then
645 go to path_err;
646 if arg ^= "" then do;
647 j = path_matrix (f, npath);
648 dir(j), seg(j) = "";
649 call expand_path_(argp, argl, addr (dir(j)), addr (seg(j)), code);
650 if code ^= 0 then
651 go to argerr;
652 i = index (seg(j), "=");
653 if i ^= 0 then if eqsw then do;
654 tseg = seg(j);
655 call equal_(addr (eqseg), addr (tseg), addr (seg(j)), code);
656 if code ^= 0 then
657 go to argerr;
658 end;
659 eqseg = seg(j);
660 eqsw = "1"b;
661 end;
662 go to nxtarg;
663
664 aend(0): go to ckopt;
665
666
667 abgn(1):
668 abgn(2):
669 abgn(3): a = option;
670 state = 0;
671 n = 0;
672 go to nxtarg;
673
674 aarg(1):
675 aarg(2):
676 aarg(3): if state = 0 then do;
677 n = n + 1;
678 if n > dim (t.acl.a, 2) then do;
679 call com_err_(error_table_$too_many_acl_entries, (proc),
680 "^/Only ^d acl entries may be specified after the ^a control argument.",
681 dim (t.acl.a, 2), (option_table(option)));
682 go to return;
683 end;
684 t.acl(a).a(n).code = 0;
685 if a = 2 then do;
686 t.acl(a).a(n).mode = "0"b;
687 go to aarg2a;
688 end;
689 call cv_mode_(arg, t.acl(a).a(n).mode, code);
690 if code ^= 0 then
691 go to argerr;
692 t.acl(a).a(n).userid = "*.*.*";
693 state = 1;
694 end;
695 else do;
696 aarg2a: t.acl(a).a(n).userid = cv_userid_(arg);
697 state = 0;
698 end;
699 go to nxtarg;
700
701 aend(1):
702 aend(2):
703 aend(3): t.acl(a).n = n;
704 go to ckopt;
705
706
707 abgn(4): n = 0;
708 go to nxtarg;
709
710 aarg(4): n = n + 1;
711 r = cv_dec_check_(arg, code);
712 if code ^= 0 then do;
713 code = error_table_$bad_conversion;
714 go to argerr;
715 end;
716 if r <= 0 then
717 go to rberr;
718 if r > 7 then
719 go to rberr;
720 if n ^= 1 then if r < t.rb(n-1) then do;
721 rberr: code = error_table_$bad_ring_brackets;
722 go to argerr;
723 end;
724 t.rb(n) = r;
725 if n = 3 then
726 option = 0;
727 go to nxtarg;
728
729 aend(4): if n = 0
730 then do;
731 n = 1;
732 t.rb(n) = max((cu_$level_get()), 5);
733 end;
734 if n < 3
735 then do i = n+1 to 3;
736 t.rb(i) = max((cu_$level_get()), t.rb(i-1), 5);
737 end;
738 option = 0;
739 go to ckopt;
740
741
742 abgn(5):
743 abgn(6):
744 abgn(7): a = option - 4;
745 n = 0;
746 go to nxtarg;
747
748 aarg(5):
749 aarg(6):
750 aarg(7): n = n + 1;
751 if n > dim (t.names.a, 2) then do;
752 call com_err_(error_table_$too_many_names, (proc),
753 "^/Only ^d names may be specified after the ^a control argument.",
754 dim (t.names.a, 2), (option_table (option)));
755 go to return;
756 end;
757 t.names(a).a(n).name = arg;
758 t.names(a).a(n).pcode = error_table_$not_done;
759 t.names(a).a(n).rcode = 0;
760 go to nxtarg;
761
762 aend(5):
763 aend(6):
764 aend(7): t.names(a).n = n;
765 go to ckopt;
766
767
768 abgn(8): old_namesw = "1"b;
769 go to endopt;
770
771
772 abgn(9): archivesw = "1"b;
773 go to endopt;
774
775
776 abgn(10): go to nxtarg;
777
778 aarg(10): fail = cv_dec_check_ (arg, code);
779 if code ^= 0 then do;
780 call com_err_(error_table_$bad_conversion, (proc), "Argument ^a ^a.",
781 arg, "could not be converted to a severity number");
782 go to return;
783 end;
784 go to nxtarg;
785
786 aend(10): if (fail < fail_min) | (fail > fail_max) then do;
787 call com_err_(error_table_$out_of_bounds, (proc), "^d^/^a ^d to ^d.", fail,
788 "Failure severity must be a number from", (fail_min), (fail_max));
789 return;
790 end;
791 go to ckopt;
792
793
794 abgn(11): rstrtsw = "1"b;
795 substr (sws, 1, 1) = "1"b;
796 go to endopt;
797
798
799 abgn(12): stopsw = "1"b;
800 go to endopt;
801
802
803 abgn(13): substr (sws, 1, 1) = "1"b;
804 go to endopt;
805
806
807 abgn(14): briefsw = "1"b;
808 go to endopt;
809
810
811 abgn(15): longsw = "1"b;
812 go to endopt;
813
814
815 abgn(16): spec_segsw = "1"b;
816 go to endopt;
817
818
819 abgn(17): substr (sws, 4, 1) = "1"b;
820 if f = 3
821 then go to nxtarg;
822 else go to endopt;
823
824
825 aarg(17): init_log_segment = "";
826 call expand_path_ ( argp, argl, addr(init_log_segment), null, code);
827 if code ^= 0
828 then go to argerr;
829 go to endopt;
830
831 aend(17): init_log_segment = "";
832 go to ckopt;
833
834 abgn(18): defersw = "1"b;
835 go to endopt;
836
837
838 abgn(19): uidsw = "1"b;
839 go to endopt;
840
841
842 abgn(20): goto nxtarg;
843
844
845 aarg(20): doc_dir = "";
846 if arg ^= "" then
847 call expand_path_(argp, argl, addr(doc_dir), null, code);
848 if code ^= 0
849 then goto argerr;
850 t.log_directory = doc_dir;
851 docsw = "1"b;
852 goto endopt;
853
854
855 aend(20): code = error_table_$wrong_no_of_args;
856 goto argerr;
857
858
859 abgn(21): mlsw = "1"b;
860 go to nxtarg;
861
862
863 aarg(21): maxl = cv_dec_check_ (arg, code);
864 if code ^= 0 then do;
865 call com_err_ (error_table_$bad_conversion, (proc), "Argument ^a ^a.",
866 arg, "could not be converted to a proper length" );
867 go to return;
868 end;
869 go to endopt;
870
871
872 aend(21): maxl = sys_info$max_seg_size;
873 go to ckopt;
874
875
876 abgn(22): substr(sws, 7, 1) = "1"b;
877 if f = 5
878 then t.acl(1).n = 0;
879 go to endopt;
880
881
882 abgn(23): nofillsw = "0"b;
883 go to endopt;
884
885
886 abgn(24): nofillsw = "1"b;
887 go to endopt;
888
889
890 endopt: option = 0;
891 go to nxtarg;
892
893
894
895
896
897
898 start(1): p = addr (global_default);
899 q = addr (t);
900 p -> default = q -> default;
901 return;
902
903
904
905 start(2): call ios_$attach ("installation_list_", "syn", "user_output", "w", status);
906 faultlabel = start2a;
907
908
909 call init_log ((npath > 0));
910
911 if logp = null then
912 go to start2a;
913 p = addr (log.d);
914 call ioa_$ioa_stream ("installation_list_",
915 "^/Defaults for ^a>^a^/^5xring brackets:^/^-^d,^d,^d^/^5xACL:",
916 logdir, logseg, p->default.rb(1), p->default.rb(2), p->default.rb(3));
917 call upd_print_acl_ (addr (p->default.acl.a), p->default.acl.n, "100"b);
918 if p->default.log_directory ^= ""
919 then call ioa_$ioa_stream ("installation_list_",
920 "^5xdocumentation directory:^/^-^a", p->default.log_directory);
921 start2a: p = addr (global_default);
922 call ioa_$ioa_stream ("installation_list_",
923 "^/Global defaults^/^5xring brackets:^/^-^d,^d,^d^/^5xACL:",
924 p->default.rb(1), p->default.rb(2), p->default.rb(3));
925 call upd_print_acl_ (addr (p->default.acl.a), p->default.acl.n, "100"b);
926 if p->default.log_directory ^= ""
927 then call ioa_$ioa_stream ("installation_list_",
928 "^5xdocumentation directory:^/^-^a", p->default.log_directory);
929 call ioa_$ioa_stream ("installation_list_", "");
930 go to clean_up;
931
932
933 start(3): call init_log (rstrtsw);
934 p = addr (log.d);
935 q = addr (t);
936 p -> default = q -> default;
937 log.fcn(1).date = fs_date();
938 log.fcn(1).group_id = log.lock.group_id;
939 if docsw then
940 if log.processp ^= null then
941
942 call com_err_ (error_table_$out_of_sequence, (proc), "^/^a ^a>^a^/^a.^/^a.",
943 "Installation object (io) segment", logdir, logseg, "has previously been installed",
944 "The documentation directory has not be changed");
945 if logsw then do;
946 if log.processp ^= null then
947 call com_err_ (error_table_$out_of_sequence, (proc), "^/^a ^a>^a^/^a.^/^a^/^a",
948 "Installation object (io) segment", logdir, logseg, "has previously been installed",
949 "The installation description cannot be changed.",
950 "As a result, the ""-log"" argument has been ignored.");
951 else
952 call get_reason(Pmsa_ptr, nofillsw, log.description);
953
954
955 end;
956 go to return;
957
958
959 start(4): call init_log ("1"b);
960 call ios_$attach ("installation_list_", "syn", "user_output", "w", status);
961 call ios_$attach ("installation_error_", "syn", "error_output", "w", status);
962
963 if logsw then do;
964 if log.description ^= null then
965
966 call upd_describe_task_ ( "000001"b, log.nullp, log.nullp, 0, 0, log.nullp, 0,
967 log.nullp, log.d.log_directory, log.description, log.fcn(3).date);
968 goto skip_print;
969 end;
970 ctlw = substr("000001"b || sws,1, length(ctlw));
971 call condition_("task_linkage_err_", linkage_err);
972 call upd_task_("0"b, (log.listp), upd_gen_call_, addr (ctlw));
973
974 skip_print:
975 call ioa_$ioa_stream ("installation_list_", "");
976 go to clean_up;
977
978
979 start(5):
980 start(6):
981 start(7):
982 start(8): if log.processp ^= null then do;
983
984 call com_err_ (error_table_$out_of_sequence, (proc), "^/^a ^a>^a^/^a.^/^a.",
985 "Installation object (io) segment", logdir, logseg, "has previously been installed",
986 "No more installation requests may be added to the segment");
987 go to return;
988 end;
989 if npath < pmin(f) then do;
990 path_err: if pmin(f) = pmax(f) then
991 eqseg = "^/^a^/^a ""^a"" ^a: ^d.";
992 else
993 eqseg = "^/^a^/^a ""^a"" ^a: ^d or ^d.";
994 call com_err_(error_table_$wrong_no_of_args, (proc), eqseg,
995 "The number of path names which must be specified",
996 "with the", (function_table(f)), "function is", (pmin(f)), (pmax(f)));
997 go to return;
998 end;
999 if f = 6 then if npath = 2 then do;
1000 dir(3) = dir(2);
1001 seg(3) = seg(1);
1002
1003 end;
1004 if ( f = 5 | f = 6) then if npath = 2 then
1005 if t.names(1).n ^= 0 then
1006 seg(3) = t.names(1).a(1).name;
1007
1008 call condition_ ("area", msa_manager_$area_handler );
1009
1010 allocate rq in (area);
1011 do i = 1 to 3;
1012 rq.dir(i) = dir(i);
1013 rq.seg(i) = seg(i);
1014 rq.rb(i) = t.rb(i);
1015 n = t.acl(i).n;
1016 if n ^= 0 then do;
1017 allocate acl in (area) set (p);
1018 q = addr (t.acl(i).a(1));
1019 p -> acl = q -> acl;
1020 rq.ap(i) = p;
1021 rq.an(i) = n;
1022 end;
1023 n = t.names(i).n;
1024 if n ^= 0 then do;
1025 allocate names in (area) set (p);
1026 q = addr (t.names(i).a(1));
1027 p -> names = q -> names;
1028 rq.np(i) = p;
1029 rq.nn(i) = n;
1030 end;
1031 end;
1032 rq.options = sws;
1033 rq.maxlen = maxl;
1034 ctlw = "01"b;
1035 errlabel = command_ignored;
1036 call ios_$attach ("installation_error_", "syn", "error_output", "w", status);
1037
1038 call condition_("task_error_", task_error);
1039 call condition_("task_linkage_err_", linkage_err);
1040 call condition_("thread_task_", thread_task);
1041 call upd_add_task_$init (Pmsa_ptr, log.linkp);
1042 call upd_install_task_(ctlw, Pmsa_ptr, log.nullp, rq.code, rq.sev, rq.taskp, rq.seqno,
1043 rq.dir, rq.seg, rq.rb, rq.ap, rq.an, rq.np, rq.nn, rq.options, rq.temp, rq.maxlen,
1044 log.sw.full_recovery, log.d.log_directory, log.fcn(3).date, log.fcn(4).date);
1045 log.sw.special_segs = log.sw.special_segs | substr (sws, 3, 1);
1046 log.sw.logging_sw = log.sw.logging_sw | substr (sws, 4, 1);
1047 log.fcn(1).date = fs_date();
1048 log.fcn(1).group_id = log.lock.group_id;
1049 go to cleanerr;
1050 command_ignored:
1051 call com_err_ (error_table_$fatal_error, (proc),
1052 "^/As a result, the ""^a ^a"" command has been ignored.",
1053 (proc), (function_table(f)));
1054 log.sw.error = "0"b;
1055 go to cleanerr;
1056
1057
1058 start(9): call init_log ("1"b);
1059 if log.listp = null then do;
1060 nolistp: call com_err_(error_table_$out_of_sequence, (proc), "^/Installation log is empty. ^a>^a.",
1061 logdir, logseg );
1062 goto return;
1063 end;
1064 if log.processp = log.listp then
1065 if log.sw.error then do;
1066 endlabel = start9a;
1067 ctlw = "00000000010"b;
1068 go to start11a;
1069 end;
1070 start9a: endlabel = full_recovery_off;
1071
1072 ctlw = "00101"b;
1073 xxx = "Installation";
1074 log.fcn(3).date = fs_date();
1075 log.fcn(3).group_id = log.lock.group_id;
1076 log.fcn(4).date = 0;
1077 go to start9b;
1078
1079 start(10):call init_log ("1"b);
1080 if log.listp = null
1081 then goto nolistp;
1082 if log.fcn(3).date = 0 then do;
1083 call com_err_(error_table_$out_of_sequence, (proc),
1084 "^/Installation Object segment ^a>^a has NOT been ""installed"".",
1085 logdir, logseg );
1086 goto return;
1087 end;
1088 endlabel = clean_up;
1089 ctlw = "10101"b;
1090 xxx = "De-installation";
1091 log.fcn(4).date = fs_date();
1092 log.fcn(4).group_id = log.lock.group_id;
1093
1094 start9b: if stopsw then
1095 errlabel = abort;
1096 else
1097 errlabel = recover;
1098 call ios_$attach ("installation_list_", "syn", "user_output", "w", status);
1099 call ios_$attach ("installation_error_", "syn", "error_output", "w", status);
1100
1101 call condition_("task_error_", task_error);
1102 call condition_("task_linkage_err_", linkage_err);
1103 call condition_("thread_task_", thread_task);
1104 call condition_ ("area", msa_manager_$area_handler);
1105
1106 call condition_ ( "any_other", default_handler );
1107
1108 call upd_add_task_$init (Pmsa_ptr, log.linkp);
1109 if log.processp = null then do;
1110 allocate in in (area);
1111 in.io_name = logseg;
1112 call upd_install_task_$init ("01"b, Pmsa_ptr, log.nullp, in.code, in.sev, in.taskp, in.seqno,
1113 log.sw.special_segs, log.sw.full_recovery, in.temp, in.io_name);
1114
1115 log.processp = log.listp;
1116 if log.description ^= null then
1117 log.sw.logging_sw = "1"b;
1118 if log.sw.logging_sw then do;
1119 allocate desc in (area);
1120 call upd_describe_task_ ("01"b, Pmsa_ptr, log.nullp, desc.code, desc.sev,
1121 desc.taskp, desc.seqno, desc.temp, log.d.log_directory, log.description, log.fcn(3).date);
1122 end;
1123 end;
1124 rerun: call upd_subtask_(ctlw, Pmsa_ptr, log.nullp, log.t.code, log.t.sev, log.t.taskp, log.t.seqno,
1125 log.processp, log.t.temp);
1126 go to endlabel;
1127
1128 recover: call reversion_ ("any_other");
1129 substr (ctlw, 1, 1) = ^(substr (ctlw, 1, 1));
1130 call com_err_(error_table_$fatal_error, (proc), "^/^a aborted. The installation will be de-installed.", xxx);
1131 errlabel = abort;
1132 endlabel = clean_up;
1133 xxx = "Error recovery";
1134 log.fcn(4).date = fs_date();
1135 log.fcn(4).group_id = log.lock.group_id;
1136 go to rerun;
1137
1138 abort: call reversion_ ("any_other");
1139 call com_err_(error_table_$fatal_error, (proc), "^a aborted.", xxx);
1140 go to clean_up;
1141
1142 full_recovery_off:
1143 log.sw.full_recovery = "0"b;
1144 go to clean_up;
1145
1146
1147
1148
1149 start(11):call init_log("1"b);
1150 if cerrorsw then
1151 if log.listp ^= null then
1152 if log.processp ^= log.listp then do;
1153 call com_err_ (error_table_$out_of_sequence, (proc),
1154 "^/Performing the ""^a ^a -error"" function at this time^/will render ^a>^a unusable.",
1155 (proc), (function_table(f)), logdir, logseg);
1156 goto return;
1157 end;
1158 ctlw = substr("000000000"b || sws,1,length(ctlw));
1159 start11a: call condition_("task_linkage_err_", linkage_err);
1160 call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
1161
1162 log.fcn(2).date = fs_date();
1163 log.fcn(2).group_id = log.lock.group_id;
1164 if ctlw & "00000000010"b then
1165 log.sw.error = "0"b;
1166 go to endlabel;
1167
1168
1169 start(12):call init_log("1"b);
1170 call suffixed_name_$new_suffix (logseg, "io", "il", listseg, code);
1171
1172 listdir = get_wdir_();
1173 Llistdir = mod (index (listdir, " ")+168, 169);
1174 call msf_manager_$open (listdir, listseg, fcbp, code);
1175 if code = 0 then do;
1176 call msf_manager_$adjust (fcbp, 0, 0, "111"b, code);
1177 if code ^= 0 then
1178 go to listerr;
1179 end;
1180 else if code = error_table_$noentry then;
1181 else do;
1182 listerr: call com_err_ (code, (proc),
1183 "^/Installation list (il) segment ^a>^a cannot be created.", listdir, listseg);
1184 go to return;
1185 end;
1186 call msf_manager_$close (fcbp);
1187
1188 call ios_$attach ("installation_list_", "file_", substr (listdir, 1, Llistdir) || ">" || listseg,
1189 "w", status);
1190 if stat.code ^= 0 then do;
1191 code = stat.code;
1192 go to listerr;
1193 end;
1194 call ios_$attach ("installation_error_", "syn", "installation_list_", "w", status);
1195
1196 call condition_ ("task_linkage_err_", linkage_err);
1197
1198 call date_time_ (clock(), date);
1199 call ioa_$ioa_stream ("installation_list_", "^|^/^a^2x^a>^a^2/^20a^a",
1200 "INSTALLATION OBJECT SEGMENT", logdir, logseg,
1201 "Listed on:", date);
1202
1203 call date_time_$fstime (log.fcn(1).date, date);
1204 call ioa_$ioa_stream ("installation_list_", "^20a^a^/^20a^a (^a ^a)^/^20a^a",
1205 "Created by:", log.fcn(1).group_id,
1206 "Created with:", (proc), "MIS Version", log.version,
1207 "Created on:", date);
1208
1209 if log.fcn(2).date ^= 0 then do;
1210 call date_time_$fstime (log.fcn(2).date, date);
1211 call ioa_$ioa_stream ("installation_list_", "^20a^a^/^20a^a",
1212 "Cleared by:", log.fcn(2).group_id,
1213 "Cleared on:", date);
1214 end;
1215
1216 if log.fcn(3).date ^= 0 then do;
1217 call date_time_$fstime (log.fcn(3).date, date);
1218 call ioa_$ioa_stream ("installation_list_", "^20a^a^/^20a^a",
1219 "Installed by:", log.fcn(3).group_id,
1220 "Installed on:", date);
1221 end;
1222
1223 if log.fcn(4).date ^= 0 then do;
1224 call date_time_$fstime (log.fcn(4).date, date);
1225
1226 call ioa_$ioa_stream ("installation_list_", "^/INSTALLATION HAS BEEN DE-INSTALLED");
1227 call ioa_$ioa_stream ("installation_list_", "^20a^a^/^20a^a",
1228 "De-installed by:", log.fcn(4).group_id,
1229 "De-installed on:", date);
1230 end;
1231
1232
1233 if log.description ^= null then do;
1234 call ioa_$ioa_stream ("installation_list_", "^/DOCUMENTATION DESCRIPTION FOLLOWS:");
1235
1236 call upd_describe_task_ ( "00000100100"b, log.nullp, log.nullp, 0, 0, log.nullp, 0,
1237 log.nullp, "", log.description, log.fcn(3).date);
1238 end;
1239
1240 call ioa_$ioa_stream ("installation_list_", "^3/SUMMARY OF THE INSTALLATION:");
1241 ctlw = "00000101000"b;
1242 call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
1243
1244
1245 if log.sw.error then do;
1246 call ioa_$ioa_stream ("installation_list_", "^3/SUMMARY OF ERRORS WHICH OCCURRED DURING INSTALLATION:");
1247 ctlw = "00000110000"b;
1248 call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
1249 end;
1250 else if log.fcn(3).date ^= 0 then
1251 call ioa_$ioa_stream ("installation_list_", "^3/NO ERRORS OCCURRED DURING INSTALLATION.");
1252 else
1253 call ioa_$ioa_stream ("installation_list_",
1254 "^3/INSTALLATION OBJECT SEGMENT HAS N^H_O^H_T^H_ BEEN INSTALLED.");
1255
1256 if ^briefsw then do;
1257 call ioa_$ioa_stream ("installation_list_",
1258 "^5/A DESCRIPTION OF THE INSTALLATION FOLLOWS.^|^/INSTALLATION DESCRIPTION:");
1259 ctlw = "00000100000"b;
1260 call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
1261 end;
1262
1263 if longsw then do;
1264 call ioa_$ioa_stream ("installation_list_", "^5/INSTALLATION DETAILS FOLLOW:");
1265 ctlw = "00000100100"b;
1266 call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
1267 end;
1268
1269
1270 clean_up: call ios_$detach ("installation_list_", "", "", status);
1271 cleanerr: call ios_$detach ("installation_error_", "", "", status);
1272
1273 go to return;
1274
1275
1276
1277
1278
1279
1280 init_log: procedure (sw);
1281
1282
1283 dcl sw bit(1) aligned;
1284
1285 dcl process_id bit(36) aligned;
1286
1287 dcl seg_fault_error condition;
1288
1289
1290 if npath = 0 then do;
1291 on seg_fault_error begin;
1292 logp = null;
1293 go to faultlabel;
1294 end;
1295 if logp ^= null then
1296 if logp = log.selfp then do;
1297 revert seg_fault_error;
1298 call validate_user;
1299 return;
1300 end;
1301 logp = null;
1302 go to faultlabel;
1303 end;
1304 logp = null;
1305 msa_ptr = null;
1306 logdir = dir(1);
1307 call suffixed_name_$find (logdir, seg(1), "io", logseg, type, mode, code);
1308
1309
1310
1311 if sw then do;
1312 if code ^= 0 then do;
1313 re_init_fail: call com_err_ (code, (proc),
1314 "^/Installation object (io) segment ^a>^a cannot be re-initiated.", logdir, seg(1));
1315 go to return_without_unlocking;
1316 end;
1317 if type = 2 then do;
1318 call com_err_ (error_table_$dirseg, (proc), "^/^a>^a ^a.^/^a.", logdir, logseg,
1319 "is a directory",
1320 "It cannot be re-initiated as an installation object (io) segment");
1321 go to return_without_unlocking;
1322 end;
1323 if mod (mode, 4) = 0 then do;
1324 code = error_table_$moderr;
1325 go to re_init_fail;
1326 end;
1327 call msa_manager_$initiate (logdir, logseg, msa_ptr, (size(log)), logp, code);
1328 if code ^= 0 then do;
1329 if code = error_table_$segno_in_use then
1330
1331
1332
1333 call com_err_ (code, (proc), "^/^a ^a>^a^/^a ^o (octal).^/^a^/^a ^a again.",
1334 "A component of the installation object (io) segment", logdir, logseg,
1335 "must be initiated with the segment number", fixed (baseno(msa_ptr), 35),
1336 "Please terminate the segment which is now known",
1337 "by this number, and re-initiate", logseg);
1338 else
1339 if code = error_table_$noentry then do;
1340
1341 call com_err_ (code, (proc), "^/^a ^a>^a^/^a.^/^a.",
1342 "The first component of the installation object (io) segment", logdir, logseg,
1343 "was discovered to be missing",
1344 "The installation object (io) segment cannot be re-initiated");
1345 go to return_without_unlocking;
1346 end;
1347 else
1348 if code = error_table_$seg_not_found then
1349
1350
1351
1352 call com_err_ ( code, (proc), "^/^a ^a>^a^/^a.^/^a.",
1353 "A component of the installation object (io) segment", logdir, logseg,
1354 "was discovered to be missing. A new component was created to replace it",
1355 "Some data may be missing" );
1356 else
1357 if code = error_table_$improper_data_format then
1358
1359
1360 call com_err_ (code, (proc), "^/^a>^a ^a.^/^a.",
1361 logdir, logseg, "does not have the format of an installation object (io) segment",
1362 "Please check its consistency" );
1363 else
1364 call com_err_ ( code, (proc), "^a>^a", logdir, logseg);
1365 go to return;
1366 end;
1367 if msa_ptr = null then
1368 go to re_init_fail;
1369 if log.init_id = "0"b then do;
1370 call msa_manager_$terminate (msa_ptr, code);
1371
1372 logp, msa_ptr = null;
1373 go to init_high;
1374 end;
1375 call validate_user;
1376 process_id = get_process_id_();
1377 if log.init_id ^= process_id then
1378 call upd_add_task_$reset (log.linkp);
1379 log.init_id = process_id;
1380 end;
1381
1382 else do;
1383 if code = 0 then do;
1384 call com_err_ (error_table_$namedup, (proc),
1385 "^/Installation object (io) segment ^a>^a already exists.", logdir, logseg);
1386 go to return_without_unlocking;
1387 end;
1388 if code ^= error_table_$noentry then do;
1389 randomerr: call com_err_ (code, (proc),
1390 "^/^a ^a>^a ^a", "Installation object segment", logdir, seg(1),
1391 "cannot be initiated.");
1392 go to return_without_unlocking;
1393 end;
1394 init_high: call msa_manager_$make_special (256, logdir, logseg, msa_ptr, (size(log)), logp, code);
1395 if code ^= 0 then do;
1396 msa_ptr = null;
1397 if sw then go to randomerr;
1398 if code = error_table_$segno_in_use then do;
1399
1400 call hcs_$delentry_file ( logdir, logseg, (0) );
1401 call com_err_ (code, (proc), "^/^a. ^a>^a ^a.^/^a.",
1402 "No high segment numbers are available", logdir, logseg,
1403 "cannot be initiated",
1404 "Type: ""new_proc"" and try again");
1405
1406 go to return_without_unlocking;
1407 end;
1408 go to randomerr;
1409 end;
1410
1411 log.lock.word = "0"b;
1412 log.lock.group_id = get_group_id_$tag_star();
1413 log.version = Version_No;
1414 call validate_user;
1415 log.areap = msa_ptr;
1416 log.d.log_directory = "";
1417 log.init_id = "0"b;
1418 log.selfp = logp;
1419 log.linkp,
1420 log.listp,
1421 log.processp,
1422 log.nullp,
1423 log.description,
1424 log.t.taskp,
1425 log.t.temp = null;
1426 log.fcn.group_id = log.lock.group_id;
1427
1428
1429 log.fcn.date,
1430 log.d.rb(1),
1431 log.d.rb(2),
1432 log.d.rb(3),
1433 log.d.acl.n,
1434 log.t.code,
1435 log.t.sev = 0;
1436
1437 log.t.seqno = 32767;
1438
1439 log.sw.full_recovery = "1"b;
1440 log.sw.special_segs,
1441 log.sw.error,
1442 log.sw.logging_sw = "0"b;
1443
1444 log.init_id = get_process_id_();
1445 end;
1446
1447 end init_log;
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458 validate_user: procedure;
1459
1460 if log.version ^= Version_No then do;
1461
1462 call com_err_ (error_table_$fatal_error, (proc),
1463 "^a>^a was created with MIS Version ^a.^/^a ^a.^/^a ^a ^a ^a.", logdir, logseg,
1464 log.version, "The version you are now using is MIS Version ", Version_No,
1465 "As a result, the", (proc), (function_table(f)), "command has been ignored");
1466 logp = null;
1467 go to return;
1468 end;
1469
1470 call set_lock_$lock (log.lock.word, 0, code);
1471 if code ^= 0 then
1472 if code = error_table_$invalid_lock_reset then;
1473
1474
1475 else if code = error_table_$locked_by_this_process then
1476 call com_err_ (code, (proc), "^/^a ^a>^a.^/^a ^a ^a function.",
1477 "Non-fatal error encountered while locking", logdir, logseg,
1478 (proc), "will continue performing the", (function_table(f)));
1479 else if code = error_table_$lock_wait_time_exceeded then do;
1480 lockerr: call com_err_ (error_table_$seglock, (proc), "^/^a ^a>^a^/^a ^a.^/The ""^a ^a"" ^a.",
1481 "Installation object (io) segment", logdir, logseg,
1482 "is already being manipulated by", log.lock.group_id,
1483 (proc), (function_table(f)), "command cannot be performed");
1484 go to return_without_unlocking;
1485 end;
1486 else
1487 go to lockerr;
1488 if log.lock.group_id ^= get_group_id_$tag_star() then do;
1489
1490
1491
1492 call command_query_ (addr (query_info), answer, (proc),
1493 "^a>^a ^a ^a.^/^a ""^a ^a"" command?",
1494 logdir, logseg, "was created by", log.lock.group_id,
1495 "Do you still wish to issue the", (proc), (function_table(f)));
1496
1497 if answer = "yes" then
1498 log.lock.group_id = get_group_id_$tag_star();
1499
1500 else do;
1501 logp = null;
1502 go to return;
1503 end;
1504 end;
1505 end validate_user;
1506
1507
1508
1509
1510
1511
1512
1513 unlock_log: procedure;
1514
1515 if logp ^= null then if log.lock.word then do;
1516 call set_lock_$unlock (log.lock.word, code);
1517 if code ^= 0 then
1518 call com_err_ (code, (proc), "^/While unlocking ^a>^a.", logdir, logseg);
1519 end;
1520 end unlock_log;
1521
1522
1523
1524
1525
1526
1527 fs_date: procedure returns (fixed bin(35));
1528
1529 dcl date fixed bin(35),
1530 date_str bit(36) aligned based (addr (date)),
1531 time fixed bin(71),
1532 time_str bit(72) aligned based (addr (time));
1533
1534 time = clock();
1535 date_str = substr (time_str, 21, 36);
1536 return (date);
1537
1538 end fs_date;
1539
1540
1541
1542
1543
1544
1545 thread_task: procedure (mcp, name, wcp, taskp, csw);
1546
1547
1548 dcl mcp ptr,
1549 name char(*),
1550 wcp ptr,
1551 taskp ptr,
1552 csw bit(1) aligned;
1553
1554 call upd_thread_task_(log.listp, taskp);
1555 end thread_task;
1556
1557
1558
1559
1560
1561
1562 task_error: procedure (mcp, name, wcp, sp, csw);
1563
1564 dcl mcp ptr,
1565 name char(*),
1566 wcp ptr,
1567 sp ptr,
1568 csw bit(1) aligned;
1569
1570 dcl 1 s aligned based (sp),
1571 2 proc char(32) unal,
1572 2 entry char(32) unal,
1573 2 code fixed bin(35),
1574 2 sev fixed bin,
1575 2 string char(200);
1576
1577
1578 log.sw.error = "1"b;
1579 if s.sev >= fail then do;
1580 call upd_print_err_(s.code, s.sev, "^NError^O", "", s.proc, s.entry, s.string);
1581 go to errlabel;
1582 end;
1583 else
1584 call upd_print_err_ (s.code, s.sev, "Warning", "", s.proc, s.entry, s.string);
1585 end task_error;
1586
1587
1588
1589
1590
1591 linkage_err: procedure (mcp, name, wcp, sp, csw);
1592
1593
1594 dcl mcp ptr,
1595 name char(*),
1596 wcp ptr,
1597 sp ptr,
1598 csw bit(1) aligned;
1599
1600 dcl 1 s aligned based (sp),
1601 2 proc char(32),
1602 2 entry char(32),
1603 2 code fixed bin(35),
1604 2 sev fixed bin,
1605 2 rname char(32),
1606 2 ename char(32);
1607
1608
1609 call upd_print_err_(s.code, s.sev, "Task linkage error", "", s.proc, s.entry,
1610 "Entry point referenced was ^a$^a", s.rname, s.ename);
1611 call cu_$cl;
1612 end linkage_err;
1613
1614
1615
1616
1617
1618
1619
1620
1621 default_handler: procedure;
1622
1623
1624 dcl 1 cond_info aligned,
1625 2 mcptr ptr,
1626 2 version fixed bin,
1627 2 condition_name char(32) var,
1628 2 infop ptr,
1629 2 wcptr ptr,
1630 2 loc_ptr ptr,
1631 2 flags aligned,
1632 3 crawlout bit(1) unal,
1633 3 pad1 bit(35) unal,
1634 2 pad_word bit(36) aligned,
1635 2 user_loc ptr,
1636 2 pad(4) bit(36) aligned;
1637
1638 call find_condition_info_ ( null, addr(cond_info), code);
1639 if code ^= 0 then do;
1640 call ioa_$ioa_stream ("error_output", "Error: Unknown signal has been received." );
1641 go to errlabel;
1642 end;
1643
1644 if cond_info.condition_name = "alrm" then do;
1645 continue: call continue_to_signal_ (code);
1646 return;
1647 end;
1648 if cond_info.condition_name = "signal_io_" then
1649 go to continue;
1650
1651 if cond_info.condition_name = "cput" then
1652 go to continue;
1653 if cond_info.condition_name = "linkage_error" then
1654 go to continue;
1655 if cond_info.condition_name = "mme2" then debug
1656 go to continue;
1657 if cond_info.condition_name = "quit" then
1658 go to continue;
1659 if cond_info.condition_name = "command_error" then
1660 go to continue;
1661 if cond_info.condition_name = "finish" then
1662 go to continue;
1663 if cond_info.condition_name = "stack" then
1664 go to continue;
1665 if cond_info.condition_name = "program_interrupt" then
1666 return;
1667 if cond_info.condition_name = "stringsize" then do;
1668 call ioa_$ioa_stream ("error_output", "Error: stringsize condition occurred.");
1669 go to STOP;
1670 end;
1671
1672 call condition_interpreter_ (null(), null(), 0, 3, cond_info.mcptr, (cond_info.condition_name),
1673 cond_info.wcptr, cond_info.infop);
1674 if stopsw then do;
1675 STOP: call ioa_$ioa_stream ("error_output",
1676 "Returning to command level. Type: ""start"" to begin recovery operations.");
1677 call cu_$cl();
1678 go to recover;
1679 end;
1680
1681 go to errlabel;
1682
1683 end default_handler;
1684
1685
1686
1687
1688 get_reason: proc (areap, nofillsw, rcp);
1689
1690
1691
1692
1693
1694 dcl
1695 areap ptr,
1696 nofillsw bit(1) aligned,
1697 rcp ptr;
1698
1699 dcl
1700 (error_table_$end_of_info,
1701 error_table_$short_record,
1702 error_table_$not_detached) ext static fixed bin(35);
1703 dcl
1704 code fixed bin(35),
1705 i fixed bin,
1706 total fixed bin,
1707 null builtin,
1708 substr builtin,
1709 break_sw bit (1),
1710 tab_sw bit(1),
1711 nelemt fixed bin(21),
1712 blockp ptr,
1713 buffp ptr;
1714
1715 dcl buffer char (512) aligned;
1716
1717 dcl out_buffer char (16384) aligned;
1718
1719 dcl Area area based (areap);
1720
1721 dcl 1 block based (blockp),
1722 2 editsw bit(1),
1723 2 no_chars fixed bin(35),
1724 2 string char (total refer (block.no_chars));
1725
1726 dcl term_line (4) char (1) init (
1727 ".",
1728 "?",
1729 ":",
1730 ";");
1731
1732 dcl HT char (1) int static options(constant) init(" ");
1733 dcl NL char (1) int static options(constant) init ("
1734 ");
1735
1736 dcl
1737 ioa_ entry options (variable),
1738 iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)),
1739 iox_$find_iocb entry ( char(*), ptr, fixed bin(35)),
1740 iox_$open entry ( ptr, fixed bin, bit(1) aligned, fixed bin(35)),
1741 iox_$get_line entry ( ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)),
1742 iox_$detach_iocb entry ( ptr, fixed bin(35)),
1743 iox_$close entry ( ptr, fixed bin(35));
1744 dcl
1745 iocb_ptr ptr,
1746 atd char(256),
1747 switch_name char(32),
1748 Path bit(1),
1749 ref_ptr ptr;
1750
1751 total = 0;
1752 out_buffer = "";
1753 ref_ptr = null;
1754 buffp = addr(buffer);
1755
1756 if init_log_segment ^= ""
1757 then Path = "1"b;
1758 else Path = "0"b;
1759
1760 if Path then do;
1761 switch_name = "upd_init_log_sw_";
1762 atd = "vfile_ " || init_log_segment;
1763 call iox_$attach_name ( switch_name, iocb_ptr, atd, ref_ptr, code);
1764 if ( code ^= 0 ) & (code ^= error_table_$not_detached) then do;
1765 call com_err_ (code, (proc), "Attaching ^a.^/^a",
1766 init_log_segment,
1767 "The ""log"" information remains unchanged.");
1768 return;
1769 end;
1770
1771 call iox_$open ( iocb_ptr, 1, "0"b, code);
1772 if code ^= 0 then do;
1773 call com_err_ (code, (proc), "Opening ^a^/^a",
1774 init_log_segment,
1775 "The ""log"" information remains unchanged.");
1776 go to DETACH_ILS;
1777 end;
1778 end;
1779 else do;
1780 call iox_$find_iocb ( "user_input", iocb_ptr, code );
1781 if code ^=0 then do;
1782 call com_err_ ( code, (proc),
1783 "Attaching ""user_input"".^/^a",
1784 "the ""log"" information remains unchanged.");
1785 end;
1786 call ioa_ ("Input");
1787 end;
1788 tab_sw = "0"b;
1789
1790 read: call iox_$get_line (iocb_ptr, buffp, length(buffer), nelemt, code);
1791 if code = error_table_$end_of_info
1792 then go to process;
1793 if (code ^= 0) & (code ^= error_table_$short_record) then do;
1794 call com_err_ (code, (proc), "Reading ""log"" information.^/^a",
1795 "The ""log"" information remains unchanged.");
1796 go to RETURN;
1797 end;
1798 if nelemt = 2
1799 then if substr(buffer,1,1) = "."
1800 then goto process;
1801 if (total + (nelemt-1)) >= length(out_buffer)
1802 then goto warn;
1803
1804 if nofillsw then do;
1805
1806 if total + nelemt >= length(out_buffer)
1807 then goto warn;
1808 substr(out_buffer,(total+1),nelemt) = substr(buffer,1,nelemt);
1809 total = total + nelemt;
1810 end;
1811 else do;
1812 tab: i = index(substr (buffer, 1, nelemt), HT);
1813
1814 if i ^= 0 then do;
1815 substr( buffer,i,1) = " ";
1816 tab_sw = "1"b;
1817 go to tab;
1818 end;
1819 break_sw = "0"b;
1820 do i = 1 to 4;
1821 if substr(buffer,(nelemt-1),1) = term_line(i)
1822 then break_sw = "1"b;
1823 end;
1824 if break_sw then do;
1825 substr(buffer,nelemt,2) = " ";
1826 nelemt = nelemt + 2;
1827 end;
1828
1829 if substr(buffer, 1, 1) = " " then
1830 if total ^= 0 then do;
1831 total = total + 1;
1832 substr(out_buffer,total,1) = NL;
1833 end;
1834 if total ^= 0
1835 then if substr(out_buffer,total,1) ^= NL
1836 then if substr(out_buffer,total,1) ^= " " then do;
1837 total = total + 1;
1838 substr(out_buffer,total,1) = " ";
1839 end;
1840
1841 if total + (nelemt-1) >= length(out_buffer)
1842 then goto warn;
1843 substr(out_buffer,(total+1),(nelemt-1)) = substr(buffer,1,(nelemt-1));
1844 total = total + (nelemt -1);
1845 end;
1846
1847 goto read;
1848
1849 process:
1850 if total = 0 then do;
1851 rcp = null;
1852 go to RETURN;;
1853 end;
1854 allocate block in (Area) set (blockp);
1855 blockp->block.editsw = nofillsw;
1856 blockp->block.no_chars = total;
1857 blockp->block.string = substr(out_buffer,1,total);
1858 rcp = blockp;
1859 if tab_sw then
1860 call ioa_ ( "Warning: tabs have been converted to single blanks.^/");
1861 RETURN: code = 0;
1862 if Path
1863 then call iox_$close ( iocb_ptr, code);
1864 if code ^= 0
1865 then call com_err_ (code, (proc), "Closing ""log"" info.");
1866 DETACH_ILS:
1867 if Path
1868 then call iox_$detach_iocb ( iocb_ptr, code);
1869 if code ^= 0
1870 then call com_err_ (code, (proc), "Detaching ""log"" info.");
1871 return;
1872
1873 warn:
1874 call ioa_("Maximum number of characters have been entered.^/""Input"" mode is terminated");
1875 goto process;
1876 end;
1877
1878 end update_seg;