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 archive: ac: proc;
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87 dcl moi char (8) aligned init ("archive");
88
89
90 dcl archive_data_$active bit (1) aligned external;
91
92 dcl (archive_data_$ident,
93 archive_data_$fence) ext char (8) aligned;
94
95 dcl error_table_$incorrect_access external fixed bin (35);
96 dcl error_table_$namedup external fixed bin (35);
97 dcl error_table_$no_append external fixed bin (35);
98 dcl error_table_$no_s_permission external fixed bin (35);
99 dcl error_table_$noentry external fixed bin (35);
100 dcl error_table_$moderr external fixed bin (35);
101 dcl error_table_$rqover external fixed bin (35);
102 dcl error_table_$segknown external fixed bin (35);
103
104 dcl archive_key_$last_index external fixed bin (17);
105
106 declare 1 archive_key_$begin_table (100 ) aligned ext,
107 2 key char (4),
108 2 bits unaligned,
109 3 action bit (2),
110
111
112
113 3 update bit (1),
114 3 append bit (1),
115 3 copy bit (1),
116 3 delete bit (1),
117 3 force bit (1),
118 3 long bit (1),
119 3 zero_arg_ok bit (1),
120 3 star_ok bit (1),
121 3 empty_ok bit (1),
122 3 no_orig_ok bit (1),
123 3 brief_bit bit (1);
124
125 declare 1 key_template aligned based (keyp),
126 2 key char (4),
127 2 bits unaligned,
128 3 action bit (2),
129
130
131
132 3 update bit (1),
133 3 append bit (1),
134 3 copy bit (1),
135 3 delete bit (1),
136 3 force bit (1),
137 3 long bit (1),
138 3 zero_arg_ok bit (1),
139 3 star_ok bit (1),
140 3 empty_ok bit (1),
141 3 no_orig_ok bit (1),
142 3 brief_bit bit (1);
143
144 dcl key_index fixed bin (17),
145 keyp ptr;
146
147 dcl (mcode, code, savecode, max_length) fixed bin (35);
148 dcl (i, j, k) fixed bin (17);
149 dcl wdct fixed bin (19);
150 dcl lastarg fixed bin (17);
151 dcl curlen fixed bin (17);
152 dcl bcnt fixed bin (24),
153 gbct fixed bin (24) initial (0);
154 dcl noroomsw bit (1) initial ("1"b);
155 dcl header_printed bit (1) initial (""b);
156 dcl first_line_sw bit (1) init ("1"b);
157
158
159
160
161 dcl stack_space (1024) fixed bin (35) init ((1024) 0);
162
163 dcl (sp, new_sp) pointer aligned;
164 dcl (dcount, lcount) fixed bin (17) aligned;
165
166 dcl (NONGLOBAL_ELEMENT_SIZE init (53), GLOBAL_ELEMENT_SIZE init (10))
167 fixed bin int static options (constant);
168
169 dcl 1 nonglobal (2500) aligned based (sp),
170 2 component_name char (32) aligned,
171 2 component_path char (168) aligned,
172 2 component_code fixed bin (35) aligned,
173 2 flags fixed bin (3) aligned,
174 2 ngtype bit (2) unaligned;
175
176 dcl 1 global (2500) aligned based (sp),
177 2 gcomponent_name char (32) aligned,
178 2 gflags fixed bin (3) aligned,
179 2 gtype bit (2) unaligned;
180
181
182
183
184
185
186
187
188
189
190 dcl (dn, initpath, archive_dir, new_archive_dir) char (168) aligned,
191 time char (16) aligned,
192 timenow char (16) aligned,
193 patharg char (pathlen) based (pathptr),
194 pathlen fixed bin (17),
195 pathptr ptr,
196 keyb char (key_l) based (key_p),
197 key_l fixed bin (17),
198 key_p ptr;
199 dcl arglist_ptr ptr;
200
201 dcl archive_name char (32) aligned initial (""),
202 temp_name char (32) aligned static init ("archive_temp_.archive"),
203 act_com char (8) aligned,
204 key char (4) aligned;
205
206 dcl buffer char (150) varying;
207 dcl (optr, cptr, p1_orig) ptr init (null);
208 dcl tptr ptr static init (null);
209 dcl (p1, p2) ptr init (null);
210
211 dcl iflag fixed bin (3);
212
213 dcl amsw fixed bin (17) init (0);
214
215 dcl cleanup_temp bit (1) internal static init (""b);
216
217 declare 1 aux_wstructure aligned,
218 2 mustfree bit (1) init (""b),
219 2 ecount fixed bin,
220 2 my_wdir char (168),
221 2 eptr ptr init (null),
222 2 nptr ptr init (null);
223
224 dcl auxw_ptr ptr;
225
226 dcl 1 query_info aligned,
227 2 version fixed bin init (1),
228 2 yes_or_no_sw bit (1) unal init ("1"b),
229 2 supress_name_sw bit (1) unal init ("0"b),
230 2 extra bit (34) unal,
231 2 status_code fixed bin (35),
232 2 query_code fixed bin (35);
233
234 dcl 1 seg_acl aligned,
235 2 userid char (32),
236 2 access bit (36),
237 2 ex_access bit (36),
238 2 status fixed bin (35);
239
240 dcl 1 delete_acl aligned,
241 2 userid char (32),
242 2 status fixed bin (35);
243
244 dcl mustreprotect bit (1) init (""b);
245 dcl entry_type bit (2);
246 dcl typef fixed bin (2);
247 dcl stars_found bit (1) init (""b);
248 dcl found_something_sw bit (1) init (""b);
249 dcl updated_something_sw bit (1) init (""b);
250
251 dcl 1 mask based aligned,
252 2 keep bit (36 - maskl) unaligned,
253 2 kill bit (maskl) unaligned;
254 dcl maskl fixed bin;
255 dcl array (wdct) fixed bin (35) based,
256 fix17 fixed bin (35),
257 fix35 fixed bin (35) based,
258
259 1 stat,
260 2 type bit (2) unaligned,
261 2 pad bit (34) unaligned,
262 2 dtm bit (36),
263 2 pad1 (5) bit (36),
264 2 len,
265 3 cur bit (12) unaligned,
266 3 bitcnt bit (24) unaligned,
267 2 pad2 (2) bit (36),
268
269 dtm bit (36) aligned,
270
271 (copy, delete, force, long) bit (1) init (""b),
272 update bit (1) init (""b),
273 append bit (1) init (""b),
274 dlast fixed bin (17) init (0),
275 last fixed bin (17) init (0),
276 dontcopy fixed bin (17) init (0),
277
278 char8 picture "zzzzzzz9",
279 char32 char (32) aligned;
280
281 dcl (header_length init (25),
282 header_length_bits init (900)) fixed bin static;
283
284 dcl 1 archive based (p1) aligned,
285 2 hbgn char (8),
286 2 pad1 char (4),
287 2 name char (32),
288 2 timeup char (16),
289 2 mode char (4),
290 2 time char (16),
291 2 pad char (4),
292 2 bcnt char (8),
293 2 hend char (8),
294 2 begin fixed bin;
295
296 dcl 1 modeb aligned based (addr (mode)),
297 2 pad bit (32) unaligned,
298 2 r bit (1) unaligned,
299 2 e bit (1) unaligned,
300 2 w bit (1) unaligned,
301 2 obsolete bit (1) unaligned,
302 mode fixed bin (5);
303 dcl amode fixed bin (5);
304
305 dcl 1 contents_overlay aligned based,
306 2 offset_space (offset_words) fixed bin,
307 2 contents (new_words - offset_words) fixed bin;
308
309 dcl orig_bc fixed bin (24);
310 dcl (new_words, offset_words, orig_words) fixed bin (21);
311
312 dcl iox_$error_output ptr external;
313
314 dcl check_star_name_$entry entry (char (*)aligned, fixed bin (35)),
315 clock_ returns (fixed bin (71)),
316 cu_$arg_ptr entry (fixed bin (17), ptr, fixed bin (17), fixed bin (35)),
317 cu_$arg_list_ptr returns (ptr),
318 cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr),
319 cu_$arg_count returns (fixed bin (17)),
320 expand_pathname_$add_suffix entry (char (*), char (*), char (*) aligned, char (*) aligned, fixed bin (35)),
321 expand_pathname_ entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35)),
322 get_group_id_ entry returns (char (32) aligned),
323 get_group_id_$tag_star entry returns (char (32) aligned),
324 get_pdir_ returns (char (168) aligned),
325 get_wdir_ returns (char (168) aligned),
326
327 (com_err_, command_query_, ioa_, ioa_$ioa_switch) entry options (variable),
328
329 fs_util_$get_max_length entry (char (*) aligned, char (*) aligned, fixed bin (35), fixed bin (35)),
330 hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin, fixed bin, ptr, fixed bin (35)),
331 hcs_$terminate_noname entry (ptr, fixed bin (35)),
332 hcs_$terminate_seg entry (ptr, fixed bin (1), fixed bin (35)),
333 hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35)),
334 hcs_$set_bc entry (char (*) aligned, char (*) aligned, fixed bin (24), fixed bin (35)),
335 hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)),
336 hcs_$add_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)),
337 hcs_$delete_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)),
338 hcs_$chname_seg entry (ptr, char (*) aligned, char (*) aligned, fixed bin (35)),
339 hcs_$truncate_seg entry (ptr, fixed bin (21), fixed bin (35)),
340 hcs_$star_list_ entry (char (*)aligned, char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35)),
341 hcs_$status_long entry (char (*) aligned, char (*) aligned, fixed bin, ptr, ptr, fixed bin (35)),
342 hcs_$status_minf entry (char (*) aligned, char (*) aligned, fixed bin, fixed bin (2), fixed bin, fixed bin (35)),
343 hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35)),
344 hcs_$delentry_file entry (char (*) aligned, char (*) aligned, fixed bin (35)),
345 hcs_$delentry_seg entry (ptr, fixed bin (35)),
346 initiate_file_ entry (char (*) aligned, char (*) aligned, bit (*), pointer, fixed bin (24), fixed bin (35)),
347 pathname_ entry (char (*) aligned, char (*) aligned) returns (char (168)),
348 term_ entry (char (*) aligned, char (*) aligned, fixed bin (35)),
349
350 dl_handler_ entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35)),
351 dl_handler_$noquestion entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35)),
352 nd_handler_ entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35)),
353
354 archive_util_$first_element entry (ptr, fixed bin (35)),
355 archive_util_$next_element entry (ptr, fixed bin (35)),
356 archive_aux_$listwdir entry (ptr, fixed bin (35)),
357 archive_aux_$inwdir entry (ptr, char (32) aligned, bit (36) aligned, bit (2)) returns (bit (1)),
358 archive_aux_$free entry (ptr),
359 archive_aux_$active entry (bit (1) aligned),
360 archive_star_ entry (char (*) aligned, char (*) aligned, char (*) aligned, ptr, fixed bin),
361
362 convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)),
363 date_time_$fstime entry (fixed bin (35), char (*) aligned),
364 date_time_ entry (fixed bin (71), char (*) aligned),
365 cv_dec_ entry (char (*) aligned) returns (fixed bin (24));
366
367 dcl (addr, addrel, bin, bit, divide, fixed, max, null, ptr, rel, size, substr) builtin;
368
369 dcl (cleanup, record_quota_overflow) condition;
370
371 dcl action fixed bin (2);
372 %page;
373
374
375
376 if archive_data_$active then call archive_aux_$active (archive_data_$active);
377
378 if archive_data_$active then return;
379
380 lastarg = cu_$arg_count ();
381
382 arglist_ptr = cu_$arg_list_ptr ();
383 go to SKIPENTRY;
384
385
386
387 star_entry: entry (dummy_key, dummy_name, dummy_arglist_ptr, dummy_lastarg);
388
389 dcl dummy_arglist_ptr ptr;
390 dcl dummy_lastarg fixed bin;
391 dcl (dummy_key, dummy_name) char (*);
392
393 arglist_ptr = dummy_arglist_ptr;
394 lastarg = dummy_lastarg;
395 stars_found = "1"b;
396
397 SKIPENTRY:
398
399 sp = addr (stack_space);
400 auxw_ptr = addr (aux_wstructure);
401 call cu_$arg_ptr (1, key_p, key_l, code);
402 if code ^= 0 then go to NARG;
403 if key_l <= 4 then key = keyb;
404 else do;
405 KEYERR: call com_err_ ((0), moi, "Unrecognized key - ^a", keyb);
406 goto RETURN;
407 end;
408 do key_index = archive_key_$last_index to 1 by -1 while (key ^= archive_key_$begin_table (key_index).key);end;
409 if key_index = 0 then go to KEYERR;
410
411 keyp = addr (archive_key_$begin_table (key_index));
412
413 copy = key_template.copy;
414 update = key_template.update;
415 append = key_template.append;
416 delete = key_template.delete;
417 force = key_template.force;
418 long = key_template.long;
419 header_printed = key_template.brief_bit;
420
421 action = bin (key_template.action, 17);
422
423 if action = 1
424 then if update
425 then act_com = "update ";
426 else if append
427 then act_com = "append ";
428 else act_com = "replace ";
429
430 call cu_$arg_ptr (2, pathptr, pathlen, code);
431 if code ^= 0 then do;
432 NARG: if append | delete then call com_err_ (0, moi, "Usage: ^a key archive_path component_names", moi);
433 else call com_err_ (0, moi, "Usage: ^a key archive_path {component_names}", moi);
434 goto RETURN;
435 end;
436
437 call expand_pathname_$add_suffix (patharg, "archive", archive_dir, archive_name, code);
438 if code ^= 0 then do;
439 call com_err_ (code, moi, patharg);
440 goto RETURN;
441 end;
442
443 call check_star_name_$entry (archive_name, code);
444 if code ^= 0 then do;
445 if code = 1 | code = 2 then
446 if ^key_template.star_ok then
447 call com_err_ ((0), moi, "Star convention cannot be used with this key. ^a", key);
448
449 else call archive_star_ (archive_dir, archive_name, key, arglist_ptr, lastarg);
450
451 else call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name));
452
453 go to RETURN;
454 end;
455 %page;
456 my_wdir = get_wdir_ ();
457 on condition (cleanup) call clean_up;
458
459 call initiate_file_ (archive_dir, archive_name, R_ACCESS, p1, orig_bc, code);
460 p1_orig = p1;
461 if p1 ^= null then do;
462 call hcs_$fs_get_mode (p1, amode, code);
463 if code = 0 then if ^addr (amode) -> modeb.r then code = error_table_$moderr;
464 if code ^= 0 then do;
465 ERROR_RETURN:
466 call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name));
467 goto RETURN;
468 end;
469
470 call fs_util_$get_max_length (archive_dir, archive_name, max_length, code);
471 if code ^= 0 then go to ERROR_RETURN;
472
473 call archive_util_$first_element (p1, savecode);
474 if savecode = 2 then do;
475 FERROR: call com_err_ (0, moi, "Format error in ^a", pathname_ (archive_dir, archive_name));
476 if p2 ^= null then if copy then call hcs_$delentry_seg (p2, code);
477 go to COMRETN;
478 end;
479 end;
480
481 if ^key_template.no_orig_ok then if p1 = null then do;
482 NOARCHIVE: call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name));
483 goto COMRETN;
484 end;
485
486 if ^key_template.empty_ok then if savecode = 1 then do;
487 call com_err_ (0, moi, "^a is empty.", pathname_ (archive_dir, archive_name));
488 go to COMRETN;
489 end;
490
491 if copy then do;
492 if p1 = null then do;
493 call com_err_ (0, moi, "Attempt to use copy feature when original not found. ^a",
494 pathname_ (archive_dir, archive_name));
495 go to COMRETN;
496 end;
497 if archive_dir = my_wdir then do;
498 call com_err_ (0, moi, "Attempt to copy onto original. ^a",
499 pathname_ (archive_dir, archive_name));
500 goto COMRETN;
501 end;
502 new_archive_dir = my_wdir;
503 end;
504
505 else new_archive_dir = archive_dir;
506
507 %page;
508 if lastarg < 3 then if action = 1 then do;
509 call hcs_$star_list_ (my_wdir, "**", 2, null, dcount, lcount, null, null, code);
510 if dcount+lcount > 113 then do;
511 call hcs_$make_seg ("", "", "", 01010b, sp, code);
512 if code ^= 0 then do;
513 call com_err_ (code, moi);
514 go to COMRETN; end;
515 end;
516 end;
517
518 if lastarg * NONGLOBAL_ELEMENT_SIZE > size (stack_space) then do;
519 call hcs_$make_seg ("", "", "", 01010b, sp, code);
520 if sp = null then do;
521 call com_err_ (code, moi);
522 go to COMRETN; end;
523 do i = 1 to lastarg-2;
524 component_code (i) = 0;
525 flags (i) = 0;
526 ngtype (i) = ""b;
527 end;
528 end;
529 %page;
530 do i = 3 to lastarg;
531 call cu_$arg_ptr_rel (i, pathptr, pathlen, code, arglist_ptr);
532 if code ^= 0 then go to BADARG;
533 if pathlen = 0 then go to NEXTARG;
534
535 if action = 0 | action = 3 then do;
536 component_name (last+1) = patharg;
537 goto CHECKARG;
538 end;
539
540 call expand_pathname_ (patharg, component_path (last + 1), component_name (last + 1), code);
541 if code ^= 0 then do;
542 BADARG: call com_err_ (code, moi, patharg);
543 goto NEXTARG;
544 end;
545 CHECKARG: do j = last to 1 by -1 while (component_name (j) ^= component_name (last+1));end;
546 if j ^= 0 then do;
547 call com_err_ ((0), moi, "Duplicated request for this component. ^a", component_name (last+1));
548 goto NEXTARG;
549 end;
550 last = last + 1;
551 NEXTARG:
552 end;
553
554 if ^key_template.zero_arg_ok then if last = 0 then do;
555 call com_err_ ((0), moi, "Some component names must be specified with this key - ^a", key);
556 go to COMRETN;
557 end;
558
559 if lastarg >= 3
560 then if last = 0
561 then go to COMRETN;
562 if action ^= 0 then archive_data_$active = "1"b;
563
564 go to FANOUT (action);
565
566
567
568 %page;
569 FANOUT (0):
570 TABLE_HANDLER:
571
572 do while (p1 ^= null);
573
574 if last ^= 0 then do;
575 do i = last to 1 by -1 while (component_name (i) ^= p1 -> archive.name);end;
576 if i = 0 then go to TNXT;
577 flags (i) = 1;
578 end;
579
580 if ^header_printed then do;
581 call ioa_ ("^/^-^a^/", pathname_ (archive_dir, archive_name));
582 if long then call ioa_ (" name^3- updated mode^-modified^- length^/");
583 else call ioa_ (" updated^2- name^/");
584 header_printed = "1"b;
585 end;
586
587 if long then call ioa_ ("^32a^17a^5a^16a^a",
588 p1 -> archive.name,
589 p1 -> archive.timeup,
590 p1 -> archive.mode,
591 p1 -> archive.time,
592 p1 -> archive.bcnt);
593 else call ioa_ ("^20a^a", p1 -> archive.timeup, p1 -> archive.name);
594
595 TNXT:
596 call archive_util_$next_element (p1, code);
597 if code = 2 then go to FERROR;
598 end;
599 call ioa_ ("");
600
601 go to NOT_FOUND_CHECKER;
602 %page;
603 FANOUT (1):
604 REPLACE_HANDLER:
605
606
607 if p1 = null then if last = 0 then do;
608 code = error_table_$noentry;
609 go to NOARCHIVE;
610 end;
611
612 call date_time_ ((clock_ ()), timenow);
613
614 if last = 0 then do;
615 call archive_aux_$listwdir (auxw_ptr, code);
616 if code ^= 0 then do;
617 call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name));
618 go to COMRETN;
619 end;
620 end;
621
622 if savecode = 1 then p1 = null;
623
624 do while (p1 ^= null);
625 if last = 0 then do;
626 call rcmp;
627 end;
628 else do;
629 do i = last to 1 by -1 while (component_name (i) ^= p1 -> archive.name);end;
630 if i = 0 then do;
631 call ccmp;
632 end;
633 else do;
634 if append then do;
635 flags (i) = 5;
636 call ccmp;
637 end;
638 else do;
639 flags (i) = 1;
640 call rcmp;
641 end;
642 end;
643 end;
644 call archive_util_$next_element (p1, code);
645 if code = 2 then go to FERROR;
646 end;
647
648 if update then goto MOVE_ARCHIVE;
649 do i = 1 to last;
650 if flags (i) = 0 then do;
651 call rcmp;
652 if flags (i) = 0 then flags (i) = 4;
653 end;
654 end;
655 %page;
656
657
658 MOVE_ARCHIVE:
659 if dontcopy ^= 0 then do;
660 call hcs_$set_bc (new_archive_dir, archive_name, gbct, code);
661 if code ^= 0 then do;
662 call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name));
663 go to COMRETN;
664 end;
665 call hcs_$terminate_noname (p2, fix17);
666 if code = 0 then if delete then go to DELT;
667 else go to NOT_FOUND_CHECKER;
668 end;
669
670 if amsw = 0 then go to NOT_FOUND_CHECKER;
671
672 if ^addr (amode) -> modeb.w then do;
673 query_info.status_code = error_table_$moderr;
674 call ask_question;
675 seg_acl.userid = get_group_id_ ();
676 seg_acl.access = "101"b;
677 seg_acl.ex_access = "0"b;
678 call hcs_$add_acl_entries (new_archive_dir, archive_name, addr (seg_acl), 1, mcode);
679 if mcode ^= 0 then go to MOVE_ERROR;
680 else mustreprotect = "1"b;
681 end;
682
683 orig_words = bc_to_rec (orig_bc) * 1024;
684 new_words = bc_to_rec (gbct) * 1024;
685
686 if new_words > orig_words then do;
687 on record_quota_overflow begin;
688 mcode = error_table_$rqover;
689 call hcs_$truncate_seg (p1_orig, orig_words, 0);
690 go to MOVE_ERROR;
691 end;
692
693 offset_words = orig_words;
694 p1_orig -> contents = ptr (p2, 0) -> contents;
695 revert record_quota_overflow;
696 end;
697
698 offset_words = 0;
699 p1_orig -> contents = ptr (p2, 0) -> contents;
700
701 if "0"b then do;
702 MOVE_ERROR: call com_err_ (mcode, moi, "Archive ^a not updated.", pathname_ (archive_dir, archive_name));
703 call hcs_$set_bc_seg (tptr, gbct, code);
704 call hcs_$chname_seg (tptr, temp_name, archive_name, code);
705 if code = 0 then tptr = null;
706 archive_dir = get_pdir_ ();
707 if code ^= 0 then archive_name = "temp.archive";
708 call ioa_ ("A copy of the updated archive can be found in [pd]>^a", archive_name);
709 go to NOT_FOUND_CHECKER;
710 end;
711 call hcs_$set_bc (new_archive_dir, archive_name, gbct, savecode);
712 if savecode ^= 0 then call com_err_ (savecode, moi, "^a", pathname_ (archive_dir, archive_name));
713 else if p2 ^= null then call hcs_$truncate_seg (p2, 0, code);
714
715 if new_words < orig_words then call hcs_$truncate_seg (p1_orig, new_words, 0);
716 if mustreprotect then do;
717 delete_acl.userid = seg_acl.userid;
718 call hcs_$delete_acl_entries (new_archive_dir, archive_name, addr (delete_acl), 1, code);
719 if code ^= 0 then do;
720 call com_err_ (code, moi, "^a", pathname_ (archive_dir, archive_name));
721 goto COMRETN;
722 end;
723 end;
724 cleanup_temp = ""b;
725 if ^delete | savecode ^= 0 then go to NOT_FOUND_CHECKER;
726
727 DELT: ;
728 do i = 1 to max (last, dlast);
729 if last ^= 0 then do;
730 if flags (i) = 1 | flags (i) = 4 then
731 call delete_seg (component_path (i), component_name (i), ngtype (i), code);
732 end;
733 else do;
734 if gflags (i) = 1 | gflags (i) = 4 then
735 call delete_seg (my_wdir, gcomponent_name (i), gtype (i), code);
736 end;
737 end;
738 if last = 0 then go to COMRETN;
739
740 NOT_FOUND_CHECKER:
741 do i = 1 to last;
742 iflag = flags (i);
743 if iflag = 0 then
744 call com_err_ (0, moi, "^a not found in ^a",
745 component_name (i), pathname_ (archive_dir, archive_name));
746 else if iflag = 2 then
747 call com_err_ (component_code (i), moi, "Could not append ^a to ^a",
748 pathname_ (component_path (i), component_name (i)), pathname_ (archive_dir, archive_name));
749 else if iflag = 3 then
750 if update & component_code (i) = 0 then do;
751 if updated_something_sw then call com_err_ (0, moi,
752 "Did not update ^a because latest copy already in ^a",
753 component_name (i), pathname_ (archive_dir, archive_name));
754 end;
755 else do;
756 if found_something_sw | nonglobal (i).component_code ^= 0 then
757 call com_err_ (nonglobal (i).component_code, moi, "Could not replace ^a in ^a",
758 pathname_ (nonglobal (i).component_path, nonglobal (i).component_name), pathname_ (archive_dir, archive_name));
759 end;
760 else if iflag = 4 & p1_orig ^= null & ^append then do;
761 call ioa_ ("^[archive: ^;^9x^]^a appended to ^a", first_line_sw,
762 pathname_ (component_path (i), component_name (i)),
763 pathname_ (archive_dir, archive_name));
764 first_line_sw = "0"b;
765 end;
766 else if iflag = 5 then
767 call com_err_ (0, moi, "Did not append ^a because copy found in ^a",
768 component_name (i), pathname_ (archive_dir, archive_name));
769 else if iflag = 6
770 then call com_err_ (0, moi, "Archive segment overflow. Could not ^a ^a in ^a",
771 act_com, pathname_ (component_path (i), component_name (i)), pathname_ (archive_dir, archive_name));
772
773 end;
774
775 if update then
776 if ^found_something_sw then call com_err_ (0, moi,
777 "No matching segments^[ in ^a^;^s^]; no components were updated in archive ^a",
778 last = 0, archive_dir, pathname_ (archive_dir, archive_name));
779 else if ^updated_something_sw then call com_err_ (0, moi,
780 "Archive ^a contains the latest versions; no components were updated^[ from ^a^].",
781 pathname_ (archive_dir, archive_name), last = 0, archive_dir);
782
783 COMRETN: ;
784
785 call clean_up;
786 RETURN: return;
787
788
789
790
791 clean_up: proc;
792
793 if sp ^= addr (stack_space) then do; call hcs_$delentry_seg (sp, code);
794 call hcs_$terminate_noname (sp, code); end;
795 if aux_wstructure.mustfree then call archive_aux_$free (auxw_ptr);
796 if p1_orig ^= null then call hcs_$terminate_noname (p1_orig, code);
797 archive_data_$active = ""b;
798
799 end clean_up;
800
801 %page;
802 FANOUT (2):
803 XTRACT_HANDLER:
804
805 XTRACT_LOOP:
806 do i = last to 1 by -1 while (component_name (i) ^= p1 -> archive.name);end;
807 if i ^= 0 then nonglobal (i).flags = 1;
808 else if last ^= 0 then do;
809 if delete then call ccmp;
810 go to XTRACT_NXT;
811 end;
812 if last = 0 then initpath = my_wdir;
813 else initpath = component_path (i);
814
815 bcnt = cv_dec_ (p1 -> archive.bcnt);
816 wdct = divide (bcnt+35, 36, 17, 0);
817
818 if wdct > max_length then go to FERROR;
819
820 if p1 -> archive.mode = "" then mode = 01010b;
821 else do;
822 mode = 0;
823 if substr (p1 -> archive.mode, 1, 1) = "r" then mode = 01000b;
824 if substr (p1 -> archive.mode, 2, 1) = "e" then mode = mode + 00100b;
825 if substr (p1 -> archive.mode, 3, 1) = "w" then mode = mode + 00010b;
826 end;
827
828 MAKEIT: ;
829 call hcs_$make_seg (initpath, p1 -> archive.name, "", 01011b, cptr, code);
830 if cptr = null then do;
831 if code = error_table_$incorrect_access then
832 call com_err_ (error_table_$no_append, moi, "^a", initpath);
833 else call com_err_ (code, moi, "^a", pathname_ (initpath, p1 -> archive.name));
834
835 if nonglobal (i).flags = 1 then do;
836 if delete then do;
837 nonglobal (i).flags = 7;
838 call ccmp;
839 end;
840 end;
841
842 nonglobal (i).component_code = code;
843 goto XTRACT_NXT;
844 end;
845
846 if delete then do;
847 amsw = 1;
848 if i ^= 0 then nonglobal (i).flags = 1;
849 end;
850
851 if code ^= 0 then do;
852 if ^force then call nd_handler_ (moi, initpath, p1 -> archive.name, code);
853 else do;
854 call hcs_$status_minf (initpath, p1 -> archive.name, 0, typef, j, code);
855 call delete_seg (initpath, p1 -> archive.name, bit (typef, 2), code);
856 end;
857 if code = 0 then do;
858 call hcs_$make_seg (initpath, p1 -> archive.name, "", 01011b, cptr, code);
859 if code ^= 0 then do;
860 if code = error_table_$incorrect_access then code = error_table_$no_append;
861 call com_err_ (code, moi, "^a", initpath);
862 if cptr ^= null then call hcs_$terminate_noname (cptr, code);
863 SKIP_COMPONENT: if delete then call ccmp;
864 go to XTRACT_NXT;
865 end;
866 end;
867 else go to SKIP_COMPONENT;
868 end;
869
870 cptr -> array = addr (p1 -> archive.begin) -> array;
871 call hcs_$set_bc (initpath, p1 -> archive.name, bcnt, code);
872 if mode ^= 01010b then do;
873 seg_acl.userid = get_group_id_$tag_star ();
874 seg_acl.access = bit (bin (mode, 4), 4);
875 seg_acl.ex_access = "0"b;
876 call hcs_$add_acl_entries (initpath, p1 -> archive.name, addr (seg_acl), 1, code);
877 end;
878 call hcs_$terminate_seg (cptr, 0, code);
879
880 XTRACT_NXT:
881 call archive_util_$next_element (p1, code);
882 if code = 2 then go to FERROR;
883 if p1 ^= null then go to XTRACT_LOOP;
884
885 if delete then do;
886 delete = "0"b;
887 go to CHECK_DELETED;
888 end;
889 else go to NOT_FOUND_CHECKER;
890 %page;
891 FANOUT (3):
892 DELETE_HANDLER:
893
894 do while (p1 ^= null);
895 do i = last to 1 by -1 while (component_name (i) ^= p1 -> archive.name);end;
896 if i = 0 then do; call ccmp; end;
897 else do;amsw = 1; flags (i) = 1;end;
898
899 call archive_util_$next_element (p1, code);
900 if code = 2 then go to FERROR;
901 end;
902
903 CHECK_DELETED:
904 if p2 = null then do;
905 call makenew;
906 do i = 1 to last while (nonglobal (i).component_code = 0); end;
907 if i > last then
908 call ioa_ ("archive: All components of ^a have been deleted.",
909 pathname_ (archive_dir, archive_name));
910 end;
911 go to MOVE_ARCHIVE;
912
913 %page;
914
915
916 rcmp: proc;
917 if last ^= 0 then do;
918 nonglobal (i).component_code = 0;
919 char32 = nonglobal (i).component_name;
920 initpath = nonglobal (i).component_path;
921 end;
922 else do;
923 char32 = p1 -> archive.name;
924 initpath = my_wdir;
925 if ^archive_aux_$inwdir (auxw_ptr, p1 -> archive.name, dtm, entry_type) then goto MUSTCOPY;
926 end;
927
928 call initiate_file_ (initpath, char32, R_ACCESS, optr, bcnt, code);
929 if code ^= 0 then do;
930 if last = 0 then call com_err_ (code, moi, "^a", pathname_ (initpath, char32));
931 else nonglobal (i).component_code = code;
932 end;
933
934 if optr = p1_orig then do;
935 flags (i) = 3;
936 go to MUSTCOPY;
937 end;
938 if optr = null then
939 do;
940 MUSTCOPY:
941 if last ^= 0 then
942 if append then flags (i) = 2;
943 else flags (i) = 3;
944 MUSTCOPY2:
945 if p1 ^= null then do;
946 call ccmp;
947 end;
948 return;
949 end;
950
951 found_something_sw = "1"b;
952
953 call hcs_$fs_get_mode (optr, mode, code);
954 if code = 0 then if ^modeb.r then code = error_table_$moderr;
955 if code ^= 0 then do;
956 REPLERR: if last = 0 then call com_err_ (code, moi, "^a", pathname_ (initpath, char32));
957 else component_code (i) = code;
958 call hcs_$terminate_noname (optr, code);
959 go to MUSTCOPY;
960 end;
961
962 call hcs_$status_long (initpath, char32, 0, addr (stat), null, code);
963 if code ^= 0 & code ^= error_table_$no_s_permission then go to REPLERR;
964 if last ^= 0 then ngtype (i) = stat.type;
965 if stat.type = "00"b then do;
966 call hcs_$status_long (initpath, char32, 1, addr (stat), null, code);
967 if code ^= 0 & code ^= error_table_$no_s_permission then go to REPLERR;
968 end;
969 if last ^= 0 then dtm = stat.dtm;
970 curlen = fixed (stat.cur, 12);
971 if bc_to_rec (bcnt) < curlen then do;
972 call com_err_ (0, moi, "Bit count is inconsistent with current length for ^a^[>^]^a",
973 initpath, initpath ^= ">", char32);
974 if last = 0 then call ioa_$ioa_switch (iox_$error_output, "Component was not updated in ^a",
975 pathname_ (archive_dir, archive_name));
976 go to MUSTCOPY;
977 end;
978 call date_time_$fstime (addr (dtm) -> fix35, time);
979 if update then do;
980 if p1 ^= null then
981 if convert_time (time) <= convert_time (p1 -> archive.time) then do;
982 call hcs_$terminate_noname (optr, code);
983 go to MUSTCOPY;
984 end;
985 updated_something_sw = "1"b;
986 end;
987 if delete then
988 if last = 0 then do;
989 dlast = dlast + 1;
990 if dlast * GLOBAL_ELEMENT_SIZE > size (stack_space) then do;
991 call hcs_$make_seg ("", "", "", 01010b, new_sp, code);
992 if new_sp = null then do;
993 call com_err_ (code, moi);
994 go to COMRETN;
995 end;
996 do k = 1 to dlast - 1;
997 new_sp -> global (k) = sp -> global (k);
998 end;
999 sp = new_sp;
1000 end;
1001 gflags (dlast) = 1;
1002 gtype (dlast) = entry_type;
1003 gcomponent_name (dlast) = char32;
1004 end;
1005
1006 if p2 = null then call makenew;
1007
1008 wdct = divide (bcnt+35, 36, 17, 0);
1009
1010 if (bin (rel (p2), 18, 0) + wdct + header_length) > max_length
1011 then do;
1012
1013 if last = 0
1014 then do;
1015
1016 if copy then dn = new_archive_dir;
1017 else dn = archive_dir;
1018 call com_err_ (0, moi, "Archive segment overflow. Could not ^a ^a in ^a",
1019 act_com, char32, pathname_ (dn, archive_name));
1020 if dlast = 0 then dlast = 1;
1021 gflags (dlast) = 7;
1022 go to MUSTCOPY2;
1023
1024 end;
1025
1026 iflag = flags (i);
1027 flags (i) = 6;
1028 if iflag = 0
1029 then go to RCMPRTN;
1030
1031 go to MUSTCOPY2;
1032
1033
1034 end;
1035
1036 amsw = 1;
1037
1038 p2 -> archive.pad, p2 -> archive.pad1 = " ";
1039 p2 -> archive.hbgn = archive_data_$ident;
1040 p2 -> archive.hend = archive_data_$fence;
1041 p2 -> archive.name = char32;
1042
1043 char8 = bcnt;
1044 p2 -> archive.bcnt = char8;
1045 p2 -> archive.timeup = timenow;
1046 p2 -> archive.time = time;
1047
1048 p2 -> archive.mode = "";
1049 if modeb.r then substr (p2 -> archive.mode, 1, 1) = "r";
1050 if modeb.e then substr (p2 -> archive.mode, 2, 1) = "e";
1051 if modeb.w then substr (p2 -> archive.mode, 3, 1) = "w";
1052
1053 p2 = addrel (p2, header_length);
1054 gbct = gbct + header_length_bits;
1055 p2 -> array = optr -> array;
1056 maskl = wdct*36 - bcnt;
1057 if maskl ^= 0 then addrel (p2, wdct-1) -> mask.kill = ""b;
1058 p2 = addrel (p2, wdct);
1059 gbct = gbct + wdct*36;
1060
1061 if update & last = 0 then do;
1062 if copy then dn = new_archive_dir;
1063 else dn = archive_dir;
1064 call ioa_ ("^[archive: ^;^9x^]^a updated in ^a", first_line_sw, char32,
1065 pathname_ (dn, archive_name));
1066 first_line_sw = "0"b;
1067 end;
1068
1069 RCMPRTN: call hcs_$terminate_noname (optr, code);
1070 end rcmp;
1071 %page;
1072
1073 ccmp: proc;
1074
1075 if p2 = null then call makenew;
1076
1077 bcnt = cv_dec_ (p1 -> archive.bcnt) + header_length_bits;
1078 wdct = divide (bcnt+35, 36, 17, 0);
1079
1080 if wdct > max_length then go to FERROR;
1081
1082 if (bin (rel (p2), 18, 0) + wdct) > max_length
1083 then do;
1084
1085 call com_err_ (0, moi, "Archive segment overflow while copying ^a in ^a
1086 Archive not updated.", p1 -> archive.name, pathname_ (archive_dir, archive_name));
1087
1088 go to COMRETN;
1089
1090 end;
1091
1092 p2 -> array = p1 -> array;
1093 gbct = gbct + wdct*36;
1094 p2 = addrel (p2, wdct);
1095
1096 end ccmp;
1097 %page;
1098
1099
1100 makenew: proc;
1101
1102 dcl error fixed bin (35);
1103
1104 if copy | p1_orig = null then do;
1105 dontcopy = 1;
1106 CREATE: call hcs_$make_seg (new_archive_dir, archive_name, "", 01011b, p2, error);
1107 if error ^= 0 then do;
1108 if error = error_table_$namedup | error = error_table_$segknown then do;
1109 call nd_handler_ (moi, new_archive_dir, archive_name, error);
1110 if error = 0 then go to CREATE;
1111 call hcs_$terminate_noname (p2, code);
1112 p2 = null;
1113 go to COMRETN;
1114 end;
1115 call com_err_ (error, moi, "^a", pathname_ (new_archive_dir, archive_name));
1116 go to COMRETN;
1117 end;
1118
1119 call fs_util_$get_max_length (new_archive_dir, archive_name, max_length, error);
1120 if code ^= 0 then do;
1121 call com_err_ (error, moi, "^a", pathname_ (new_archive_dir, archive_name));
1122 go to COMRETN;
1123 end;
1124 if orig_bc = 0 then orig_bc = max_length * 36;
1125
1126 if ^copy then do;
1127 call ioa_ ("archive: Creating ^a", pathname_ (archive_dir, archive_name));
1128 p1_orig = p2;
1129 end;
1130 else call ioa_ ("archive: Copying ^a", pathname_ (archive_dir, archive_name));
1131
1132 return;
1133 end;
1134
1135
1136 if tptr = null then do;
1137 call hcs_$make_seg ("", temp_name, "", 01011b, tptr, error);
1138 if tptr = null then do;
1139 call com_err_ (error, moi, "[pd]>^a", temp_name);
1140 go to COMRETN;
1141 end;
1142 end;
1143 else if cleanup_temp then call hcs_$truncate_seg (tptr, 0, error);
1144
1145 p2 = tptr;
1146 cleanup_temp = "1"b;
1147
1148 end makenew;
1149
1150 %page;
1151 bc_to_rec: proc (P_bc) returns (fixed bin);
1152
1153 dcl P_bc fixed bin (24);
1154
1155 if P_bc = 0 then return (0);
1156 else return (divide (P_bc - 1, 36 * 1024, 17, 0) + 1);
1157
1158 end bc_to_rec;
1159
1160
1161
1162 delete_seg: proc (path, entry, dtype, dcode);
1163
1164 dcl (path, entry) char (*) aligned,
1165 dtype bit (2),
1166 dcode fixed bin (35);
1167 dcl ccode fixed bin (35);
1168
1169 call term_ (path, entry, dcode);
1170 if dtype = "00"b then do;
1171 call hcs_$initiate (path, entry, "", 0, 1, cptr, dcode);
1172 if cptr = null then return;
1173 call hcs_$delentry_seg (cptr, dcode);
1174 end;
1175 else call hcs_$delentry_file (path, entry, dcode);
1176 if dcode = 0 then return;
1177
1178 if ^force then call dl_handler_ (moi, path, entry, dcode);
1179 else call dl_handler_$noquestion (moi, path, entry, dcode);
1180
1181 if dtype = "00"b then call hcs_$delentry_seg (cptr, ccode);
1182 else call hcs_$delentry_file (path, entry, ccode);
1183 if dcode = 0 then dcode = ccode;
1184
1185 if dcode ^= 0 then call com_err_ (0, moi, "Could not delete ^a", pathname_ (path, entry));
1186
1187 end delete_seg;
1188
1189
1190
1191 convert_time: proc (P_str) returns (fixed bin (71));
1192
1193 dcl P_str char (*) aligned;
1194 dcl fixed_time fixed bin (71);
1195
1196 call convert_date_to_binary_ ((P_str), fixed_time, code);
1197 if code ^= 0 then return (0);
1198 else return (fixed_time);
1199
1200 end convert_time;
1201
1202
1203
1204 ask_question: proc;
1205
1206
1207
1208 call command_query_ (addr (query_info), buffer, moi,
1209 "Do you want to update the protected segment ^a ?", pathname_ (new_archive_dir, archive_name));
1210
1211 if substr (buffer, 1, 2) = "no" then goto COMRETN;
1212
1213 end ask_question;
1214
1215 %page;
1216 %include access_mode_values;
1217 end archive;