1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76 canonicalize:
77 canon:
78 proc;
79
80
81
82
83
84
85
86 dcl Access_ptr ptr;
87
88
89
90
91
92
93
94
95
96 dcl 1 Access aligned based (Access_ptr),
97 2 version char (8),
98 2 set fixed bin,
99 2 type fixed bin (2),
100 2 old_mode bit (36),
101 2 dir char (168) unaligned,
102 2 ent char char (32) unaligned;
103
104 dcl Arg_len fixed bin;
105 dcl Arg_numb fixed bin;
106 dcl Arg_ptr ptr;
107 dcl Arg_count fixed bin;
108
109 dcl Area_ptr ptr;
110 dcl Bead_ptr ptr;
111 dcl Bead_storage (1024) fixed bin;
112 dcl Bead_storage_size fixed bin;
113 dcl Beg_line fixed bin (21);
114 dcl Bitc fixed bin (24);
115 dcl Cantab_flag bit (1) aligned;
116 dcl Chars_in_line fixed bin (21);
117 dcl Chars_to_remove fixed bin (21);
118 dcl Charx fixed bin;
119 dcl Col fixed bin;
120 dcl Create_temp_msf_flag bit (1) aligned;
121 dcl Desired_access bit (36);
122 dcl Dn char (168);
123 dcl Do_not_create_temp_msf_flag bit (1) aligned;
124 dcl Ec fixed bin (35);
125 dcl En char (32);
126 dcl Eof_flag bit (1) aligned;
127 dcl Eqln char (32);
128 dcl Everytab fixed bin;
129 dcl Fs_util_type char (32);
130 dcl Have_infile_flag bit (1) aligned;
131 dcl Have_outfile_flag bit (1) aligned;
132 dcl Ii fixed bin (21);
133 dcl In_everytab fixed bin;
134 dcl In_nstops fixed bin;
135 dcl In_msf_comp_bitc fixed bin (24);
136
137 dcl In_msf_total_original_comps fixed bin (24);
138 dcl Input_msf_comp_index fixed bin;
139 dcl Input_msf_comp_ptr ptr;
140 dcl Input_msf_fcb_ptr ptr;
141 dcl In_stops (40) fixed bin;
142 dcl In_stopx fixed bin;
143 dcl Jj fixed bin (21);
144 dcl Kk fixed bin (21);
145 dcl Lth fixed bin (21);
146 dcl Mm fixed bin;
147 dcl Nch fixed bin (21);
148 dcl Next_pos fixed bin;
149 dcl Nonexistent_outfile_flag bit (1) aligned;
150 dcl Nstops fixed bin;
151 dcl Obuf_ptr ptr;
152 dcl Out_seg_ptr ptr;
153 dcl Outc_ptr ptr;
154 dcl Out_dname char (168);
155 dcl Out_ename char (32);
156 dcl Outc_len fixed bin (21);
157 dcl Output_segment_length_in_words fixed bin (19);
158 dcl Overwrite_exist_path_flag bit (1);
159 dcl Ox fixed bin (21);
160 dcl Spaces_to_go fixed bin;
161 dcl Second_temp_seg_ptr ptr;
162 dcl Specified_infile_type fixed bin (2);
163 dcl Specified_temp_file_flag bit (1) aligned;
164 dcl Seg_ptr ptr;
165 dcl Stops (40) fixed bin;
166 dcl Stopx fixed bin;
167 dcl Subroutine_call_flag bit (1) aligned;
168 dcl Tab_flag bit (1) aligned;
169 dcl Target_tabstop fixed bin;
170 dcl Temp_msf_comp_bitc fixed bin (24);
171 dcl Temp_msf_fcb_ptr ptr;
172 dcl Temp_ptr ptr;
173 dcl Temp_dn char (168);
174 dcl Temp_en char (32);
175 dcl Temp_seg_len fixed bin (21);
176 dcl Temp_seg_len_in_chars fixed bin (21);
177 dcl Temp_seg_ptr ptr;
178 dcl Temp_msf_total_components fixed bin (24);
179 dcl Temp_msf_comp_index fixed bin;
180 dcl Temp_msf_comp_ptr ptr;
181 dcl This_tabstop fixed bin;
182
183
184
185 dcl Arg char (Arg_len) based (Arg_ptr);
186
187 dcl Bcs char (Lth) based (Seg_ptr) aligned;
188
189
190 dcl 1 Bead (Bead_storage_size) based (Bead_ptr) aligned,
191 2 loc fixed bin (26) unal,
192 2 char char (1) unal;
193
194 dcl Obuf char (512) based (Obuf_ptr);
195
196
197 dcl Outc char (Outc_len) based (Outc_ptr);
198
199 dcl Second_temp_seg char (Temp_seg_len_in_chars) based (Second_temp_seg_ptr);
200
201 dcl Temp_seg char (Temp_seg_len_in_chars) based (Temp_seg_ptr);
202
203 dcl System_area area based (Area_ptr);
204
205 dcl Word_array (Output_segment_length_in_words) bit (36) based;
206
207
208
209 dcl (
210 addr,
211 copy,
212 divide,
213 hbound,
214 index,
215 max,
216 min,
217 null,
218 rank,
219 reverse,
220 rtrim,
221 search,
222 substr,
223 unspec,
224 verify
225 ) builtin;
226
227
228 dcl (cleanup, record_quota_overflow) condition;
229
230
231 dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35));
232 dcl access_$reset entry (ptr, fixed bin (35));
233 dcl access_$set_temporarily entry (char (*), char (*), fixed bin (2), bit (*), ptr, fixed bin (35));
234 dcl active_fnc_err_ entry options (variable);
235 dcl archive_$next_component entry (ptr, fixed bin (24), ptr, fixed bin (24), char (*), fixed bin (35));
236 dcl com_err_ entry options (variable);
237 dcl com_err_$suppress_name entry options (variable);
238 dcl command_query_$yes_no entry () options (variable);
239 dcl cu_$arg_count entry (fixed bin, fixed bin (35));
240 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
241 dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
242 dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35));
243 dcl dm_error_$file_in_use fixed bin (35) external;
244 dcl (
245 error_table_$active_function,
246 error_table_$archive_pathname,
247 error_table_$bad_arg,
248 error_table_$badopt,
249 error_table_$dirseg,
250 error_table_$empty_file,
251 error_table_$rqover,
252 error_table_$noarg,
253 error_table_$noentry,
254 error_table_$no_m_permission,
255 error_table_$no_r_permission,
256 error_table_$no_w_permission,
257 error_table_$not_seg_type,
258 error_table_$zero_length_seg
259 ) fixed bin (35) external;
260
261 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
262 dcl fs_util_$get_type entry (char (*), char (*), char (*), fixed bin (35));
263 dcl get_equal_name_ entry (char (*), char (*), char (*), fixed bin (35));
264 dcl get_group_id_ entry returns (char (32) aligned);
265 dcl get_pdir_ entry returns (char (168));
266 dcl get_system_free_area_ entry () returns (ptr);
267 dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35));
268 dcl hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35));
269 dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
270 dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
271 dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
272 dcl initiate_file_$create entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35));
273 dcl msf_manager_$adjust entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35));
274 dcl msf_manager_$close entry (ptr);
275 dcl msf_manager_$msf_get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
276 dcl msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35));
277 dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35));
278 dcl pathname_ entry (char (*), char (*)) returns (char (168));
279 dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35));
280 dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
281 dcl unique_chars_ entry (bit (*)) returns (char (15));
282
283
284 dcl 1 oi aligned like object_info;
285
286
287 dcl ACL_REPLACED fixed bin (2) int static options (constant) init (2);
288
289 dcl HT char (1) int static options (constant) init (" ");
290 dcl NLVTFF char (3) int static options (constant) init ("^K^L
291 ");
292 dcl SP char (1) int static options (constant) init (" ");
293 dcl BS char (1) int static options (constant) init ("^H");
294 dcl CR char (1) int static options (constant) init ("^M");
295 dcl SPBSCRHT char (4) int static options (constant) init (" ^H^M ");
296 dcl HTSP char (2) int static options (constant) init (" ");
297 dcl BSCR char (2) int static options (constant) init ("^H^M");
298
299 dcl COMPONENT_ZERO fixed bin int static options (constant) init (0);
300
301 dcl DIRECTORY fixed bin (2) int static options (constant) init (2);
302 dcl MSF fixed bin (2) int static options (constant) init (3);
303 dcl SEGMENT fixed bin (2) int static options (constant) init (1);
304
305 dcl FALSE bit (1) int static options (constant) init ("0"b);
306 dcl TRUE bit (1) int static options (constant) init ("1"b);
307
308 dcl PRECISION_FIXED_BIN_17 fixed bin int static options (constant) init (17);
309 dcl PRECISION_FIXED_BIN_19 fixed bin int static options (constant) init (19);
310 dcl PRECISION_FIXED_BIN_21 fixed bin int static options (constant) init (21);
311
312 dcl SWITCHES bit (6) int static options (constant) init ("100111"b);
313 dcl THREE_BIT_SWITCH bit (3) int static options (constant) init ("111"b);
314
315 dcl ME char (12) int static options (constant) init ("canonicalize");
316
317
318 %page;
319
320
321 call initialization;
322
323 call parsing_input_arguments;
324 if Ec ^= 0 then return;
325
326 if ^Have_infile_flag then do;
327 call com_err_$suppress_name ((0), ME, "Usage: ^a path1 {path2} {-control_args}", ME);
328 return;
329 end;
330
331 if ^Have_outfile_flag then
332 Desired_access = RW_ACCESS;
333 else Desired_access = R_ACCESS;
334
335 on cleanup begin;
336 call clean_up;
337 call term_segs;
338 end;
339
340
341
342 call get_temp_segment_ (ME, Outc_ptr, Ec);
343 if Ec ^= 0 then do;
344 call com_err_ (Ec, ME, "Cannot get temp segment.");
345 return;
346 end;
347
348 if ^Specified_temp_file_flag then do;
349
350 call get_temp_segment_ (ME, Temp_seg_ptr, Ec);
351 if Ec ^= 0 then do;
352 call com_err_ (Ec, ME, "Cannot get temp segment.");
353 return;
354 end;
355 end;
356 else do;
357 call hcs_$make_seg (Temp_dn, Temp_en, "", RW_ACCESS_BIN, Temp_seg_ptr, Ec);
358 if Ec ^= 0 then do;
359 call com_err_ (Ec, ME, "^a", pathname_ (Temp_dn, Temp_en));
360 return;
361 end;
362 end;
363
364
365 call hcs_$status_minf (Dn, En, 1, Specified_infile_type, Bitc, Ec);
366 if Ec ^= 0 then do;
367 call com_err_ (Ec, ME, "^a", pathname_ (Dn, En));
368 call release_temp_segment_ (ME, Outc_ptr, (0));
369 call release_temp_segment_ (ME, Temp_seg_ptr, (0));
370 return;
371 end;
372
373 if Specified_infile_type = SEGMENT then
374 call canon_segment;
375
376 else if Specified_infile_type = DIRECTORY then
377 call canon_msf;
378
379 else do;
380 call com_err_ (error_table_$not_seg_type, ME, "^a", pathname_ (Dn, En));
381 call release_temp_segment_ (ME, Outc_ptr, (0));
382 call release_temp_segment_ (ME, Temp_seg_ptr, (0));
383 return;
384 end;
385
386 call clean_up;
387 call term_segs;
388
389
390 return;
391
392
393 %page;
394 parsing_input_arguments: proc;
395
396
397
398
399
400 Ec = 0;
401
402 call cu_$arg_count (Arg_count, Ec);
403 if Ec ^= 0 then do;
404 if Ec = error_table_$active_function then call active_fnc_err_ (Ec, ME);
405 else call com_err_ (Ec, ME);
406 return;
407 end;
408
409 do Arg_numb = 1 to Arg_count;
410 call cu_$arg_ptr (Arg_numb, Arg_ptr, Arg_len, Ec);
411 if Ec ^= 0 then do;
412 call com_err_ (Ec, ME);
413 return;
414 end;
415
416 if index (Arg, "-") = 1 then do;
417 if Arg = "-output_tabs" | Arg = "-otabs" then do;
418 Tab_flag = TRUE;
419
420 Arg_numb = Arg_numb + 1;
421 if Arg_numb > Arg_count then do;
422 Ec = error_table_$noarg;
423 call com_err_ (Ec, ME);
424 return;
425 end;
426
427 call continue_parsing_arguments;
428 if Ec ^= 0 then return;
429 end;
430 else if Arg = "-no_output_tabs" | Arg = "-notabs" then Tab_flag = FALSE;
431 else if Arg = "-input_tabs" | Arg = "-itabs" then do;
432 Arg_numb = Arg_numb + 1;
433 if Arg_numb > Arg_count then do;
434 Ec = error_table_$noarg;
435 call com_err_ (Ec, ME);
436 return;
437 end;
438
439 call continue_parsing_arguments;
440 if Ec ^= 0 then return;
441 end;
442 else if Arg = "-force" | Arg = "-fc" then Overwrite_exist_path_flag = TRUE;
443 else if Arg = "-no_force" | Arg = "-nfc" then Overwrite_exist_path_flag = FALSE;
444 else if Arg = "-temp_file" | Arg = "-tf" then do;
445 Specified_temp_file_flag = TRUE;
446
447 if Arg_numb = Arg_count then do;
448 Ec = -1;
449 call com_err_ (0, ME, "Missing PATH argument for ^a.", Arg);
450 return;
451 end;
452 else do;
453 Arg_numb = Arg_numb + 1;
454 call cu_$arg_ptr (Arg_numb, Arg_ptr, Arg_len, Ec);
455 if Ec ^= 0 then do;
456 call com_err_ (Ec, ME, "Cannot get PATH argument for -temp_file.");
457 return;
458 end;
459
460 if index (Arg, "-") = 1 then do;
461
462 Ec = error_table_$badopt;
463 call com_err_ (Ec, ME, "^a. Missing PATH argument for -temp_file.", Arg);
464 return;
465 end;
466
467 call expand_pathname_ (Arg, Temp_dn, Temp_en, Ec);
468 if Ec ^= 0 then do;
469 call com_err_ (Ec, ME, "Cannot expand the given PATH argument ^a for -temp_file.", Arg);
470 return;
471 end;
472
473 call get_equal_name_ (En, Temp_en, Temp_en, Ec);
474
475 if Ec ^= 0 then do;
476 call com_err_ (Ec, ME, "Cannot get an equal name similar to the original input file name ^a", pathname_ (Dn, En));
477 return;
478 end;
479 end;
480 end;
481 else do;
482 Ec = error_table_$badopt;
483 call com_err_ (Ec, ME, "^a", Arg);
484 return;
485 end;
486 end;
487 else if ^Have_infile_flag then do;
488 call expand_pathname_ (Arg, Dn, En, Ec);
489 if Ec ^= 0 then do;
490 call com_err_ (Ec, ME, "Cannot expand the given input path1 ^a", Arg);
491 return;
492 end;
493 Have_infile_flag = TRUE;
494 end;
495 else if ^Have_outfile_flag then do;
496 Have_outfile_flag = TRUE;
497 call expand_pathname_ (Arg, Out_dname, Eqln, Ec);
498 if Ec ^= 0 then do;
499 call com_err_ (Ec, ME, "Cannot expand the specified output path2 ^a", Arg);
500 return;
501 end;
502
503 call get_equal_name_ (En, Eqln, Out_ename, Ec);
504 if Ec ^= 0 then do;
505 call com_err_ (Ec, ME, "Cannot get an equal name similar to the original file name ^a", pathname_ (Dn, En));
506 return;
507 end;
508 end;
509 else do;
510 Ec = error_table_$bad_arg;
511 call com_err_$suppress_name (Ec, ME, "Usage: ^a path1 {path2} {-control_args}", ME);
512 return;
513 end;
514 end;
515
516 return;
517
518
519 %page;
520 continue_parsing_arguments: proc;
521
522 call cu_$arg_ptr (Arg_numb, Arg_ptr, Arg_len, Ec);
523 if Ec ^= 0 then do;
524 call com_err_ (Ec, ME, "^a", Arg);
525 return;
526 end;
527
528 if Arg = "-every" | Arg = "-ev" then do;
529 Arg_numb = Arg_numb + 1;
530 if Arg_numb > Arg_count then do;
531 Ec = error_table_$noarg;
532 call com_err_ (Ec, ME, "Missing value for ^a", Arg);
533 return;
534 end;
535
536 call cu_$arg_ptr (Arg_numb, Arg_ptr, Arg_len, Ec);
537 if Ec ^= 0 then do;
538 call com_err_ (Ec, ME);
539 return;
540 end;
541
542 if Tab_flag then Everytab = cv_dec_check_ (Arg, Ec);
543 else In_everytab = cv_dec_check_ (Arg, Ec);
544
545 if Ec ^= 0 then do;
546 Ec = error_table_$bad_arg;
547 call com_err_ (Ec, ME, "^a", Arg);
548 return;
549 end;
550 end;
551 else do;
552 if Tab_flag then call grab_tabs (Stops, Nstops);
553 else call grab_tabs (In_stops, In_nstops);
554
555 if Ec ^= 0 then return;
556 end;
557
558 return;
559
560 end continue_parsing_arguments;
561
562
563 %page;
564 grab_tabs: proc (p_stops, p_nstop);
565
566
567 dcl p_nstop fixed bin,
568 p_stops (*) fixed bin;
569
570
571
572 Ec = 0;
573 Kk = 1;
574 do while (Kk < Arg_len);
575 Jj = index (substr (Arg, Kk), ",");
576 if Jj = 0 then Jj = Arg_len - Kk + 2;
577
578 Mm = cv_dec_check_ (substr (Arg, Kk, Jj - 1), Ec);
579 if Ec ^= 0 then do;
580 Ec = error_table_$bad_arg;
581 call com_err_ (Ec, ME, "^a", substr (Arg, Kk, Jj - 1));
582 return;
583 end;
584
585 p_nstop = p_nstop + 1;
586 if p_nstop > hbound (p_stops, 1) - 1 then do;
587 Ec = -1;
588 call com_err_ (0, ME, "Too many ^[output^;input^] tabstops: ^d - max is ^d", Tab_flag, Mm, hbound (p_stops, 1) - 1);
589 return;
590 end;
591
592 p_stops (p_nstop) = Mm;
593 Kk = Kk + Jj;
594 end;
595
596 return;
597
598 end grab_tabs;
599
600
601 %page;
602 end parsing_input_arguments;
603
604
605 %page;
606 canonicalize_tabs_:
607 entry (p_input_ptr, p_input_len, p_output_ptr, p_output_len, p_tab_flag, p_code);
608
609 dcl p_tab_flag bit (1);
610
611
612
613 call initialization;
614
615 Tab_flag = p_tab_flag;
616 if Tab_flag then Everytab = 10;
617
618 goto NON_MSF_COMMON;
619
620
621
622 canonicalize_:
623 entry (p_input_ptr, p_input_len, p_output_ptr, p_output_len, p_code);
624
625 dcl p_code fixed bin (35);
626 dcl p_input_ptr ptr;
627 dcl p_input_len fixed bin (21);
628 dcl p_output_ptr ptr;
629 dcl p_output_len fixed bin (21);
630
631
632
633 call initialization;
634
635 NON_MSF_COMMON:
636 p_code = 0;
637
638 Seg_ptr = p_input_ptr;
639 Lth = p_input_len;
640
641 if Lth = 0 then do;
642 p_code = error_table_$zero_length_seg;
643 return;
644 end;
645
646 on cleanup call clean_up;
647
648 call get_temp_segment_ (ME, Outc_ptr, p_code);
649
650 if p_code ^= 0 then return;
651
652
653
654 call get_temp_segment_ (ME, Temp_seg_ptr, p_code);
655 if p_code ^= 0 then return;
656
657
658 Do_not_create_temp_msf_flag = TRUE;
659
660 call do_canon;
661
662 if Ec ^= 0 then p_code = Ec;
663 else do;
664 p_output_ptr -> Temp_seg = Temp_seg;
665 p_output_len = Temp_seg_len_in_chars;
666 end;
667
668 Seg_ptr = null;
669
670 call clean_up;
671
672 return;
673
674
675 %page;
676 validate_access: proc (p_dir, p_ename, p_type, p_desired_access, p_overwritten_flag);
677
678
679
680
681
682
683
684
685
686
687
688
689 dcl p_desired_access bit (*);
690 dcl (p_dir, p_ename) char (*);
691 dcl p_type char (*);
692 dcl p_overwritten_flag bit (1);
693
694
695 dcl full_pathname char (168);
696 dcl grand_dn char (168);
697 dcl mode fixed bin (5);
698 dcl msf_directory_pathname char (168);
699 dcl parents_dn char (32);
700 dcl ring fixed bin;
701 dcl user_id char (32);
702
703
704
705 Ec = 0;
706 full_pathname = " ";
707 grand_dn = " ";
708 mode = 0;
709 msf_directory_pathname = " ";
710 parents_dn = " ";
711 ring = -1;
712 user_id = " ";
713
714 on cleanup call clean_up;
715
716 call absolute_pathname_ (p_dir, full_pathname, Ec);
717 if Ec ^= 0 then do;
718 call com_err_ (Ec, ME, "Cannot get the absolute pathname of the directory ^a", p_dir);
719 return;
720 end;
721 call expand_pathname_ (full_pathname, grand_dn, parents_dn, Ec);
722 if Ec ^= 0 then do;
723 call com_err_ (Ec, ME, "Cannot expand the directory ^a", full_pathname);
724 return;
725 end;
726
727 user_id = get_group_id_ ();
728 call hcs_$get_user_effmode (grand_dn, parents_dn, user_id, ring, mode, Ec);
729 if Ec ^= 0 then do;
730 call com_err_ (Ec, ME, "Cannot get the user effective mode of directory ^a", pathname_ (grand_dn, parents_dn));
731 return;
732 end;
733
734 if (mode ^= M_ACCESS_BIN) & (mode ^= SM_ACCESS_BIN) & (mode ^= SMA_ACCESS_BIN) then do;
735 Ec = error_table_$no_m_permission;
736 call com_err_ (Ec, ME, "^a", pathname_ (grand_dn, parents_dn));
737 return;
738 end;
739
740 if p_type = FS_OBJECT_TYPE_SEGMENT then do;
741 call command_query_$yes_no (p_overwritten_flag, (0), ME, "", "Do you want to update the protected file ^a?", pathname_ (p_dir, p_ename));
742 if ^p_overwritten_flag then return;
743
744 call access_$set_temporarily (p_dir, p_ename, SEGMENT, p_desired_access, Access_ptr, Ec);
745 if Ec ^= 0 then do;
746 call com_err_ (Ec, ME, "Cannot set ""write"" access mode on ^a", pathname_ (p_dir, p_ename));
747 return;
748 end;
749 end;
750
751 if p_type = FS_OBJECT_TYPE_MSF then do;
752 msf_directory_pathname = pathname_ (p_dir, p_ename);
753 call hcs_$get_user_effmode (msf_directory_pathname, "0", user_id, ring, mode, Ec);
754 if Ec ^= 0 then do;
755 call com_err_ (Ec, ME, "Cannot get effective access mode of component 0 for MSF ^a", pathname_ (p_dir, p_ename));
756 return;
757 end;
758
759 if (mode = N_ACCESS_BIN) | (mode = E_ACCESS_BIN) | (mode = W_ACCESS_BIN) then do;
760 Ec = error_table_$no_r_permission;
761 call com_err_ (Ec, ME, "^a", pathname_ (p_dir, p_ename));
762 return;
763 end;
764
765 else if (mode = R_ACCESS_BIN) | (mode = RE_ACCESS_BIN) then do;
766 call command_query_$yes_no (p_overwritten_flag, (0), ME, "", "Do you want to update the protected file ^a?",
767 pathname_ (p_dir, p_ename));
768 if ^p_overwritten_flag then return;
769
770 call access_$set_temporarily (p_dir, p_ename, MSF, p_desired_access, Access_ptr, Ec);
771 if Ec ^= 0 then do;
772 call com_err_ (Ec, ME, "Cannot set ""write"" access mode on ^a", pathname_ (p_dir, p_ename));
773 return;
774 end;
775 end;
776
777
778 else call command_query_$yes_no (p_overwritten_flag, (0), ME, "", "Do you want to overwrite ^a?", pathname_ (p_dir, p_ename));
779 end;
780
781 return;
782
783 end validate_access;
784
785
786 %page;
787 canon_msf: proc;
788
789
790
791
792
793 Note
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832 In_msf_total_original_comps = Bitc;
833
834 on cleanup call clean_up;
835
836 if Bitc = 0 then do;
837 call com_err_ (error_table_$dirseg, ME, "Cannot canonicalize a directory. ^a", pathname_ (Dn, En));
838 return;
839 end;
840
841 call get_specified_file_type (Dn, En, Fs_util_type);
842 if Ec ^= 0 then return;
843
844 if ^Have_outfile_flag then do;
845 call validate_access (Dn, En, Fs_util_type, RW_ACCESS, Overwrite_exist_path_flag);
846 if Ec ^= 0 then return;
847
848 if ^Overwrite_exist_path_flag then return;
849 end;
850 else do;
851 call initiate_specified_output_file;
852 if Ec ^= 0 then return;
853
854 if ^Nonexistent_outfile_flag & ^Overwrite_exist_path_flag then return;
855 end;
856
857
858 call msf_manager_$open (Dn, En, Input_msf_fcb_ptr, Ec);
859 if Ec ^= 0 then do;
860 call com_err_ (Ec, ME, "Cannot open MSF input file. ^a", pathname_ (Dn, En));
861 return;
862 end;
863
864
865 do Input_msf_comp_index = COMPONENT_ZERO to (In_msf_total_original_comps - 1);
866
867 call msf_manager_$msf_get_ptr (Input_msf_fcb_ptr, Input_msf_comp_index, FALSE, Input_msf_comp_ptr, In_msf_comp_bitc, Ec);
868 if Ec ^= 0 then do;
869 if Seg_ptr ^= null then
870 Seg_ptr = null;
871 call com_err_ (Ec, ME, "Cannot get component ^d of input MSF ^a.", Input_msf_comp_index, pathname_ (Dn, En));
872 return;
873 end;
874
875 Seg_ptr = Input_msf_comp_ptr;
876
877 Lth = divide (In_msf_comp_bitc + (BITS_PER_CHAR - 1), BITS_PER_CHAR, PRECISION_FIXED_BIN_21, 0);
878
879 if Lth = 0 then do;
880 Seg_ptr = null;
881 Ec = error_table_$empty_file;
882 call com_err_ (Ec, ME, "The component ^d of the input MSF ^a is empty.", Input_msf_comp_index, rtrim (pathname_ (Dn, En)));
883 return;
884 end;
885
886 call do_canon;
887
888 if Ec ^= 0 then do;
889 Seg_ptr = null;
890 return;
891 end;
892
893 Eof_flag = FALSE;
894 end;
895
896 if ^Create_temp_msf_flag then do;
897 if ^Have_outfile_flag then do;
898 call copy_temp_seg_into_msf (Dn, En, Input_msf_fcb_ptr, COMPONENT_ZERO, Input_msf_comp_ptr, In_msf_comp_bitc,
899 Temp_msf_total_components);
900 if Ec ^= 0 then return;
901
902 call msf_manager_$adjust (Input_msf_fcb_ptr, COMPONENT_ZERO, In_msf_comp_bitc, THREE_BIT_SWITCH, Ec);
903 if Ec ^= 0 then do;
904 Seg_ptr = null;
905 call com_err_ (Ec, ME, "Cannot adjust component ^d of MSF ^a", COMPONENT_ZERO, rtrim (pathname_ (Dn, En)));
906 return;
907 end;
908 end;
909 else do;
910 if Out_seg_ptr ^= null then
911
912 call copy_temp_seg_into_segment;
913
914 else if Nonexistent_outfile_flag then do;
915
916
917 call initiate_file_$create (Out_dname, Out_ename, RW_ACCESS, Out_seg_ptr, Nonexistent_outfile_flag, Bitc, Ec);
918 if Ec ^= 0 then do;
919 Seg_ptr = null;
920 call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
921 return;
922 end;
923
924 call copy_temp_seg_into_segment;
925 end;
926
927 else if Fs_util_type = FS_OBJECT_TYPE_MSF then do;
928
929 call copy_temp_seg_into_spec_pth2_MSF;
930 if Ec ^= 0 then do;
931 Seg_ptr = null;
932 return;
933 end;
934 end;
935 end;
936 end;
937 else do;
938 if Temp_seg_len_in_chars > 0 then do;
939 call temp_seg_to_temp_msf;
940 if Ec ^= 0 then return;
941 end;
942
943 if ^Have_outfile_flag then do;
944 call temp_msf_to_infile_or_outfile (Dn, En);
945 if Ec ^= 0 then return;
946 end;
947 else do;
948
949 call msf_manager_$open (Out_dname, Out_ename, Input_msf_fcb_ptr, Ec);
950 if Ec ^= 0 then do;
951 if Ec ^= error_table_$noentry then do;
952 call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
953 return;
954 end;
955 else Ec = 0;
956 end;
957
958 call temp_msf_to_infile_or_outfile (Out_dname, Out_ename);
959 if Ec ^= 0 then return;
960
961 if Out_seg_ptr ^= null then Out_seg_ptr = null;
962 end;
963 end;
964
965 return;
966
967 end canon_msf;
968
969
970 %page;
971 canon_segment: proc;
972
973
974
975
976
977 Note
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016 on cleanup call clean_up;
1017
1018 if Bitc = 0 then do;
1019 call com_err_ (error_table_$zero_length_seg, ME, "^a", pathname_ (Dn, En));
1020 return;
1021 end;
1022
1023 call initiate_file_ (Dn, En, Desired_access, Seg_ptr, Bitc, Ec);
1024 if Ec ^= 0 then do;
1025 if Ec = error_table_$no_w_permission then do;
1026 Fs_util_type = FS_OBJECT_TYPE_SEGMENT;
1027 call validate_access (Dn, En, Fs_util_type, Desired_access, Overwrite_exist_path_flag);
1028 if Ec ^= 0 then return;
1029 if ^Overwrite_exist_path_flag then return;
1030
1031 call initiate_file_ (Dn, En, Desired_access, Seg_ptr, Bitc, (0));
1032 end;
1033 else do;
1034 call com_err_ (Ec, ME, "^a", pathname_ (Dn, En));
1035 return;
1036 end;
1037 end;
1038
1039 if ^Have_outfile_flag & ^Overwrite_exist_path_flag then do;
1040 call command_query_$yes_no (Overwrite_exist_path_flag, (0), ME, "", "Do you want to overwrite ^a?", pathname_ (Dn, En));
1041 if ^Overwrite_exist_path_flag then return;
1042
1043 Fs_util_type = FS_OBJECT_TYPE_SEGMENT;
1044 end;
1045
1046 call archive_$next_component (Seg_ptr, Bitc, (null ()), (0), (""), Ec);
1047 if Ec = 0 then do;
1048 Ec = error_table_$archive_pathname;
1049 call com_err_ (Ec, ME, "The specified path is an archive. ^a", pathname_ (Dn, En));
1050 return;
1051 end;
1052
1053 oi.version_number = object_info_version_2;
1054 call object_info_$brief (Seg_ptr, Bitc, addr (oi), Ec);
1055 if Ec = 0 then do;
1056 Ec = error_table_$bad_arg;
1057 call com_err_ (Ec, ME, "The specified path is an object segment. ^a", pathname_ (Dn, En));
1058 return;
1059 end;
1060
1061 Lth = divide (Bitc + (BITS_PER_CHAR - 1), BITS_PER_CHAR, PRECISION_FIXED_BIN_21, 0);
1062
1063 if Have_outfile_flag then do;
1064 call initiate_specified_output_file;
1065 if Ec ^= 0 then return;
1066
1067 if ^Nonexistent_outfile_flag & ^Overwrite_exist_path_flag then return;
1068 end;
1069 else Out_seg_ptr = Seg_ptr;
1070
1071
1072 call do_canon;
1073 if Ec ^= 0 then return;
1074
1075 if ^Create_temp_msf_flag then do;
1076 if Out_seg_ptr ^= null then
1077
1078
1079 call copy_temp_seg_into_segment;
1080
1081 else if Nonexistent_outfile_flag then do;
1082 call initiate_file_$create (Out_dname, Out_ename, RW_ACCESS, Out_seg_ptr, Nonexistent_outfile_flag, Bitc, Ec);
1083 if Ec ^= 0 then do;
1084 call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
1085 return;
1086 end;
1087
1088 call copy_temp_seg_into_segment;
1089 end;
1090
1091 else do;
1092 call copy_temp_seg_into_spec_pth2_MSF;
1093 if Ec ^= 0 then return;
1094 end;
1095
1096 call terminate_file_ (Seg_ptr, (0), TERM_FILE_TERM, (0));
1097 end;
1098 else do;
1099 if Temp_seg_len_in_chars > 0 then do;
1100 call temp_seg_to_temp_msf;
1101 if Ec ^= 0 then return;
1102 end;
1103
1104 if ^Have_outfile_flag then do;
1105 call msf_manager_$open (Dn, En, Input_msf_fcb_ptr, Ec);
1106 if Ec ^= 0 then do;
1107 call com_err_ (Ec, ME, "^a", pathname_ (Dn, En));
1108 return;
1109 end;
1110
1111 call temp_msf_to_infile_or_outfile (Dn, En);
1112 if Ec ^= 0 then return;
1113
1114 Seg_ptr = null;
1115 end;
1116 else do;
1117
1118
1119 call msf_manager_$open (Out_dname, Out_ename, Input_msf_fcb_ptr, Ec);
1120 if Ec ^= 0 then do;
1121 if Ec ^= error_table_$noentry then do;
1122 call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
1123 return;
1124 end;
1125 else Ec = 0;
1126
1127 end;
1128
1129 call temp_msf_to_infile_or_outfile (Out_dname, Out_ename);
1130 if Ec ^= 0 then do;
1131 if Nonexistent_outfile_flag then
1132 call delete_$path (Out_dname, Out_ename, SWITCHES, ME, (0));
1133 return;
1134 end;
1135
1136
1137 call terminate_file_ (Seg_ptr, (0), TERM_FILE_TERM, (0));
1138 end;
1139 end;
1140
1141 return;
1142
1143 end canon_segment;
1144
1145
1146 %page;
1147 clean_up: proc;
1148
1149
1150
1151 if Access_ptr ^= null then do;
1152 if Create_temp_msf_flag then do;
1153
1154 if Fs_util_type = FS_OBJECT_TYPE_SEGMENT then do;
1155
1156 Access.type = MSF;
1157 Access.set = ACL_REPLACED;
1158 Access.old_mode = R_ACCESS;
1159 call access_$reset (Access_ptr, (0));
1160 end;
1161
1162 if Fs_util_type = FS_OBJECT_TYPE_MSF then
1163 call access_$reset (Access_ptr, (0));
1164 end;
1165 else if Fs_util_type ^= " " then do;
1166 if Fs_util_type = FS_OBJECT_TYPE_MSF then
1167
1168 Access.type = SEGMENT;
1169
1170 call access_$reset (Access_ptr, (0));
1171 end;
1172 end;
1173
1174 if Input_msf_fcb_ptr ^= null then do;
1175 call msf_manager_$close (Input_msf_fcb_ptr);
1176 if Seg_ptr ^= null then Seg_ptr = null;
1177
1178 end;
1179
1180 if Temp_msf_fcb_ptr ^= null then do;
1181 call msf_manager_$close (Temp_msf_fcb_ptr);
1182 if Out_seg_ptr ^= null then Out_seg_ptr = null;
1183 end;
1184
1185 if Temp_ptr ^= null then free Temp_ptr -> Bead;
1186
1187 if Outc_ptr ^= null then
1188 call release_temp_segment_ (ME, Outc_ptr, (0));
1189
1190 if Temp_seg_ptr ^= null then do;
1191 if ^Specified_temp_file_flag then
1192 call release_temp_segment_ (ME, Temp_seg_ptr, (0));
1193 else do;
1194 Temp_seg_ptr = null;
1195 call delete_$path (Temp_dn, Temp_en, SWITCHES, ME, (0));
1196 end;
1197 end;
1198
1199 if Second_temp_seg_ptr ^= null then
1200 call release_temp_segment_ (ME, Second_temp_seg_ptr, (0));
1201
1202 return;
1203
1204 end clean_up;
1205
1206
1207
1208
1209
1210 term_segs:
1211 proc;
1212
1213 if Out_seg_ptr = Seg_ptr then Out_seg_ptr = null;
1214
1215 if Seg_ptr ^= null then
1216 call terminate_file_ (Seg_ptr, (0), TERM_FILE_TERM, (0));
1217
1218 if Out_seg_ptr ^= null then
1219 call terminate_file_ (Out_seg_ptr, (0), TERM_FILE_TERM, (0));
1220
1221 end term_segs;
1222
1223
1224
1225 %page;
1226 copy_temp_seg_into_msf: proc (p_dn, p_en, p_fcb_ptr, p_comp_index, p_comp_ptr, p_comp_bitc, p_temp_msf_total_components);
1227
1228
1229
1230
1231
1232
1233 dcl (p_dn, p_en) char (*);
1234 dcl (p_comp_ptr, p_fcb_ptr) ptr;
1235 dcl p_comp_index fixed bin;
1236 dcl (p_comp_bitc, p_temp_msf_total_components) fixed bin (24);
1237
1238
1239
1240 Ec = 0;
1241
1242 on cleanup call clean_up;
1243
1244 on record_quota_overflow begin;
1245 Ec = error_table_$rqover;
1246 call msf_manager_$close (p_fcb_ptr);
1247 revert record_quota_overflow;
1248 goto temp_seg_to_msf_ERROR_RETURN;
1249 end;
1250
1251 call msf_manager_$msf_get_ptr (p_fcb_ptr, p_comp_index, TRUE, p_comp_ptr, p_comp_bitc, Ec);
1252 if Ec ^= 0 then do;
1253 call msf_manager_$close (p_fcb_ptr);
1254
1255 if Fs_util_type = FS_OBJECT_TYPE_MSF then
1256 call com_err_ (Ec, ME, "Cannot get component ^d of specified output MSF ^a", p_comp_index, pathname_ (p_dn, p_en));
1257 else call com_err_ (Ec, ME, "Cannot get component ^d of temp MSF ^a", p_comp_index, pathname_ (p_dn, p_en));
1258
1259 return;
1260 end;
1261
1262 p_comp_ptr -> Temp_seg = Temp_seg;
1263
1264 if (p_comp_index = 0) & (p_temp_msf_total_components = 0) then
1265
1266 p_temp_msf_total_components = 1;
1267
1268
1269 p_comp_bitc = Temp_seg_len_in_chars * BITS_PER_CHAR;
1270
1271 temp_seg_to_msf_ERROR_RETURN:
1272
1273 return;
1274
1275 end copy_temp_seg_into_msf;
1276
1277
1278 %page;
1279 copy_temp_seg_into_spec_pth2_MSF: proc;
1280
1281
1282
1283
1284
1285
1286 call msf_manager_$open (Out_dname, Out_ename, Temp_msf_fcb_ptr, Ec);
1287 if Ec ^= 0 then do;
1288 call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
1289 return;
1290 end;
1291
1292 call copy_temp_seg_into_msf (Out_dname, Out_ename, Temp_msf_fcb_ptr, Temp_msf_comp_index, Temp_msf_comp_ptr,
1293 Temp_msf_comp_bitc, Temp_msf_total_components);
1294 if Ec ^= 0 then return;
1295
1296 call msf_manager_$adjust (Temp_msf_fcb_ptr, (Temp_msf_comp_index), Temp_msf_comp_bitc, THREE_BIT_SWITCH, Ec);
1297 if Ec ^= 0 then do;
1298 call msf_manager_$close (Temp_msf_fcb_ptr);
1299 call com_err_ (Ec, ME, "Cannot adjust component ^d of MSF ^a", Temp_msf_comp_index, pathname_ (Out_dname, Out_ename));
1300 return;
1301 end;
1302
1303 return;
1304
1305 end copy_temp_seg_into_spec_pth2_MSF;
1306
1307
1308 %page;
1309 copy_temp_seg_into_segment: proc;
1310
1311
1312
1313
1314
1315 Note
1316
1317
1318
1319
1320 dcl output_segment_length_in_bits fixed bin (24);
1321
1322
1323
1324 output_segment_length_in_bits = 0;
1325
1326 on cleanup call clean_up;
1327
1328 on record_quota_overflow begin;
1329 Ec = error_table_$rqover;
1330 revert record_quota_overflow;
1331 goto temp_seg_to_segment_ERROR_RETURN;
1332 end;
1333
1334 Output_segment_length_in_words = divide (Temp_seg_len_in_chars + (CHARS_PER_WORD - 1), CHARS_PER_WORD, PRECISION_FIXED_BIN_19, 0);
1335 call terminate_file_ (Out_seg_ptr, (Output_segment_length_in_words), TERM_FILE_TRUNC, Ec);
1336 if Ec ^= 0 then do;
1337 if Out_seg_ptr = Seg_ptr then
1338 call com_err_ (Ec, ME, "^a", pathname_ (Dn, En));
1339 else call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
1340 return;
1341 end;
1342
1343 Out_seg_ptr -> Word_array (Output_segment_length_in_words) = FALSE;
1344
1345 Out_seg_ptr -> Temp_seg = Temp_seg;
1346
1347 output_segment_length_in_bits = Temp_seg_len_in_chars * BITS_PER_CHAR;
1348 call terminate_file_ (Out_seg_ptr, (output_segment_length_in_bits), TERM_FILE_BC, Ec);
1349 if Ec ^= 0 then do;
1350 if Out_seg_ptr = Seg_ptr then
1351 call com_err_ (Ec, ME, "^a", pathname_ (Dn, En));
1352 else call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
1353 return;
1354 end;
1355
1356 temp_seg_to_segment_ERROR_RETURN:
1357 call terminate_file_ (Out_seg_ptr, (0), TERM_FILE_TERM, Ec);
1358
1359 return;
1360
1361 end copy_temp_seg_into_segment;
1362
1363
1364 %page;
1365 do_canon: procedure;
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396 dcl available_pos_for_insertion fixed bin (21);
1397 dcl next_char_pos fixed bin (21);
1398 dcl remaining_pos_for_insertion fixed bin (21);
1399 dcl slew_index fixed binary (21);
1400 dcl slew_present_flag bit (1);
1401
1402 %page;
1403
1404
1405 Ec = 0;
1406 available_pos_for_insertion = 0;
1407 remaining_pos_for_insertion = 0;
1408 Obuf_ptr = null;
1409 Beg_line = 1;
1410
1411 on cleanup call clean_up;
1412
1413 Bead_storage_size = hbound (Bead_storage, 1);
1414
1415 Bead_ptr = addr (Bead_storage);
1416 Area_ptr = get_system_free_area_ ();
1417
1418 do while (^Eof_flag);
1419 Outc_len, Ox = 0;
1420
1421 Nch = 0;
1422 Obuf_ptr = addr (substr (Bcs, Beg_line, 1));
1423
1424 Chars_in_line = search (substr (Bcs, Beg_line), NLVTFF);
1425
1426 if Chars_in_line = 0 then do;
1427 slew_present_flag = FALSE;
1428 Chars_in_line = Lth - Beg_line + 2;
1429
1430 end;
1431 else slew_present_flag = TRUE;
1432
1433 Beg_line = Beg_line + Chars_in_line;
1434 if Beg_line > Lth then Eof_flag = TRUE;
1435
1436 slew_index = Chars_in_line;
1437
1438
1439 Chars_to_remove = verify (reverse (substr (Obuf_ptr -> Bcs, 1, Chars_in_line - 1)), SPBSCRHT);
1440 if Chars_to_remove = 0 then Chars_to_remove = Chars_in_line;
1441
1442 Chars_in_line = Chars_in_line - Chars_to_remove + 1;
1443
1444 Col, Jj, In_stopx, Stopx, Next_pos = 1;
1445 if search (substr (Obuf_ptr -> Bcs, 1, Chars_in_line - 1), BSCR) ^= 0 then do;
1446 do while (Jj <= Chars_in_line - 1);
1447 if substr (Obuf, Jj, 1) = BS then do;
1448 Ii = verify (substr (Obuf, Jj, Chars_in_line - Jj), BS) - 1;
1449 Jj = Jj + Ii;
1450 Col = max (Col - Ii, 1);
1451 end;
1452 else if substr (Obuf, Jj, 1) = CR then do;
1453 Col = 1;
1454 Jj = Jj + 1;
1455 end;
1456 else if substr (Obuf, Jj, 1) = HT then do;
1457 Ii = verify (substr (Obuf, Jj, Chars_in_line - Jj), HT) - 1;
1458 if In_nstops > 0 then do;
1459 if Col >= In_stops (In_nstops) then Col = Col + Ii;
1460 else do;
1461 do In_stopx = In_stopx to In_nstops + 1
1462 while (Col >= In_stops (In_stopx));
1463 end;
1464 if In_stopx + Ii > In_nstops then
1465 Col = In_stops (min (In_stopx + Ii - 1, In_nstops)) + In_stopx + Ii - 1 - In_nstops;
1466 else Col = In_stops (In_stopx + Ii - 1);
1467 end;
1468 end;
1469 else Col = In_everytab * (divide (Col - 1, In_everytab, PRECISION_FIXED_BIN_17, 0) + Ii) + 1;
1470
1471 Jj = Jj + Ii;
1472 end;
1473 else if substr (Obuf, Jj, 1) = SP then do;
1474 Ii = verify (substr (Obuf, Jj, Chars_in_line - Jj), SP) - 1;
1475 Jj = Jj + Ii;
1476 Col = Col + Ii;
1477 end;
1478 else do;
1479 Nch = Nch + 1;
1480 if Nch > Bead_storage_size then do;
1481 Mm = Bead_storage_size;
1482 Bead_storage_size = 2 * Bead_storage_size;
1483
1484 allocate Bead set (Temp_ptr) in (System_area);
1485
1486 Bead_storage_size = Mm;
1487 Temp_ptr -> Bead = Bead;
1488 if Bead_ptr ^= addr (Bead_storage) then free Bead;
1489
1490 Bead_ptr = Temp_ptr;
1491 Bead_storage_size = 2 * Bead_storage_size;
1492 end;
1493 Bead (Nch).char = substr (Obuf, Jj, 1);
1494 Bead (Nch).loc = Col; note
1495
1496 if (rank (substr (Obuf, Jj, 1)) >= rank (" ") & rank (substr (Obuf, Jj, 1)) <= rank ("~")) then Col = Col + 1;
1497
1498 Jj = Jj + 1;
1499 end;
1500 end;
1501
1502 call sort;
1503
1504 Next_pos = 1;
1505 do Charx = 1 to Nch;
1506 if Charx > 1 then do;
1507 if unspec (Bead (Charx)) = unspec (Bead (Charx - 1))
1508 then goto do_canon_SKIP;
1509 end;
1510
1511 Spaces_to_go = Bead (Charx).loc - Next_pos;
1512
1513 if Spaces_to_go > 0 then do;
1514 if Tab_flag & Spaces_to_go > 1 then do;
1515 if Nstops > 0 then do;
1516 do Stopx = 1 to Nstops while (Next_pos >= Stops (Stopx));
1517 end;
1518
1519 Cantab_flag = (Stopx <= Nstops);
1520 do while (Cantab_flag & (Bead (Charx).loc >= Stops (Stopx)));
1521 call output (HT);
1522 Next_pos = Stops (Stopx);
1523 Spaces_to_go = Bead (Charx).loc - Next_pos;
1524
1525 if Stopx >= Nstops then Cantab_flag = FALSE;
1526 else if Stops (Stopx + 1) > Bead (Charx).loc then Cantab_flag = FALSE;
1527 else Stopx = Stopx + 1;
1528 end;
1529 end;
1530 else do;
1531 Target_tabstop = Everytab * divide (Bead (Charx).loc - 1, Everytab, PRECISION_FIXED_BIN_17, 0) + 1;
1532
1533 do while (Next_pos < Target_tabstop);
1534 call output (HT);
1535
1536 This_tabstop = Everytab * divide (Next_pos - 1 + Everytab, Everytab, PRECISION_FIXED_BIN_17, 0) + 1;
1537 Next_pos = This_tabstop;
1538 Spaces_to_go = Bead (Charx).loc - Next_pos;
1539
1540 end;
1541 end;
1542 end;
1543
1544 do Ii = 1 to Spaces_to_go;
1545 call output (SP);
1546 end;
1547 end;
1548
1549
1550
1551
1552 if Spaces_to_go < 0 & (rank (Bead (Charx).char) >= rank (" ") & rank (Bead (Charx).char) <= rank ("~"))
1553 then call output ((BS));
1554
1555 call output (Bead (Charx).char);
1556
1557 Next_pos = Bead (Charx).loc + 1;
1558 do_canon_SKIP:
1559 end;
1560 end;
1561 else do;
1562 Nch = 1;
1563
1564 if ^Tab_flag then do;
1565 do while (Nch ^= 0);
1566 Nch = index (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), HT);
1567 if Nch = 0 then
1568 Ii = Chars_in_line - Jj;
1569 else Ii = Nch - 1;
1570 if Ii > 0 then do;
1571 Outc_len = Outc_len + Ii;
1572 substr (Outc, Ox + 1, Ii) = substr (Obuf_ptr -> Bcs, Jj, Ii);
1573
1574 do Kk = Jj to (Jj + Ii - 1);
1575 if (rank (substr (Obuf_ptr -> Bcs, Kk, 1)) >= rank (" ") & rank (substr (Obuf_ptr -> Bcs, Kk, 1)) <= rank ("~"))
1576 then Col = Col + 1;
1577 end;
1578
1579 Ox = Ox + Ii;
1580 Jj = Jj + Ii;
1581 end;
1582
1583 if Nch ^= 0 then do;
1584 Ii = verify (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), HT) - 1;
1585
1586 Next_pos = Col;
1587 if In_nstops > 0 then do;
1588 if Col >= In_stops (In_nstops) then Spaces_to_go = Ii;
1589 else do;
1590 do In_stopx = In_stopx to In_nstops + 1
1591 while (Col >= In_stops (In_stopx));
1592 end;
1593
1594 if In_stopx + Ii > In_nstops
1595 then Spaces_to_go = In_stops (min (In_stopx + Ii - 1, In_nstops)) + In_stopx + Ii - 1 - In_nstops - Col;
1596 else Spaces_to_go = In_stops (In_stopx + Ii - 1) - Next_pos;
1597 end;
1598 end;
1599 else Spaces_to_go = In_everytab * (divide (Col - 1, In_everytab, PRECISION_FIXED_BIN_17, 0) + Ii) + 1 - Next_pos;
1600
1601 Outc_len = Outc_len + Spaces_to_go;
1602 substr (Outc, Ox + 1, Spaces_to_go) = copy (SP, Spaces_to_go);
1603 Ox = Ox + Spaces_to_go;
1604 Col = Col + Spaces_to_go;
1605 Jj = Jj + Ii;
1606 end;
1607 end;
1608 end;
1609
1610 %page;
1611
1612 else do;
1613 do while (Jj <= Chars_in_line - 1);
1614
1615
1616 do while (search (substr (Obuf_ptr -> Bcs, Jj, 1), HTSP) ^= 0);
1617 if substr (Obuf_ptr -> Bcs, Jj, 1) = SP then do;
1618 Ii = verify (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), SP) - 1;
1619 Col = Col + Ii;
1620 Jj = Jj + Ii;
1621 end;
1622 else do;
1623 Ii = verify (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), HT) - 1;
1624
1625 if In_nstops > 0 then do;
1626 if Col >= In_stops (In_nstops) then
1627 Col = Col + Ii;
1628 else do;
1629 do In_stopx = In_stopx to In_nstops + 1
1630 while (Col >= In_stops (In_stopx));
1631 end;
1632 if In_stopx + Ii > In_nstops then
1633 Col = In_stops (min (In_stopx + Ii - 1, In_nstops)) + In_stopx + Ii - 1 - In_nstops;
1634 else Col = In_stops (In_stopx + Ii - 1);
1635 end;
1636 end;
1637 else Col = In_everytab * (divide (Col - 1, In_everytab, PRECISION_FIXED_BIN_17, 0) + Ii) + 1;
1638
1639 Jj = Jj + Ii;
1640 end;
1641 end;
1642
1643
1644
1645
1646 Spaces_to_go = Col - Next_pos;
1647 if Spaces_to_go > 0 then do;
1648 if (Tab_flag) & (Spaces_to_go > 1) then do;
1649 if Nstops > 0 then do;
1650 if Next_pos > Stops (Nstops)
1651 then goto omit_simple_spaces;
1652
1653 do Stopx = Stopx to Nstops + 1
1654 while (Next_pos >= Stops (Stopx));
1655 end;
1656
1657 do Ii = Stopx to Nstops + 1
1658 while (Col >= Stops (Ii));
1659 end;
1660
1661 Ii = Ii - Stopx;
1662 if Ii < 1 then goto omit_simple_spaces;
1663
1664 Spaces_to_go = Col - Stops (Ii + Stopx - 1);
1665 end;
1666 else do;
1667
1668 Target_tabstop = divide (Col - 1, Everytab, PRECISION_FIXED_BIN_17, 0);
1669
1670 Ii = Target_tabstop - divide (Next_pos - 1, Everytab, PRECISION_FIXED_BIN_17, 0);
1671 if Ii < 1 then goto omit_simple_spaces;
1672 Spaces_to_go = Col - (Target_tabstop * Everytab + 1);
1673 end;
1674
1675 if Ii > 0 then do;
1676 Outc_len = Outc_len + Ii;
1677 substr (Outc, Ox + 1, Ii) = copy (HT, Ii);
1678 Ox = Ox + Ii;
1679 end;
1680 end;
1681
1682 omit_simple_spaces:
1683 if Spaces_to_go > 0 then do;
1684 Outc_len = Outc_len + Spaces_to_go;
1685 substr (Outc, Ox + 1, Spaces_to_go) = copy (SP, Spaces_to_go);
1686 Ox = Ox + Spaces_to_go;
1687 end;
1688 end;
1689
1690
1691 Ii = search (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), HTSP) - 1;
1692 if Ii < 1 then
1693 Ii = Chars_in_line - Jj;
1694
1695 Outc_len = Outc_len + Ii;
1696 substr (Outc, Ox + 1, Ii) = substr (Obuf_ptr -> Bcs, Jj, Ii);
1697 Ox = Ox + Ii;
1698 do Kk = Jj to (Jj + Ii - 1);
1699 if (rank (substr (Obuf_ptr -> Bcs, Kk, 1)) >= rank (" ") & rank (substr (Obuf_ptr -> Bcs, Kk, 1)) <= rank ("~")) then
1700 Col = Col + 1;
1701 end;
1702
1703 Jj = Jj + Ii;
1704 Next_pos = Col;
1705 end;
1706 end;
1707 end;
1708
1709 if slew_present_flag then
1710
1711 call output (substr (Obuf, slew_index, 1));
1712
1713
1714 if (Temp_seg_len_in_chars + Outc_len) < CHARS_PER_SEGMENT then do;
1715
1716 next_char_pos = Temp_seg_len_in_chars + 1;
1717 Temp_seg_len_in_chars = Temp_seg_len_in_chars + Outc_len;
1718 substr (Temp_seg, next_char_pos, Outc_len) = Outc;
1719 end;
1720 else do;
1721
1722 available_pos_for_insertion = CHARS_PER_SEGMENT - Temp_seg_len_in_chars;
1723 next_char_pos = Temp_seg_len_in_chars + 1;
1724 Temp_seg_len_in_chars = Temp_seg_len_in_chars + available_pos_for_insertion;
1725 substr (Temp_seg, next_char_pos, available_pos_for_insertion) = substr (Outc, 1, available_pos_for_insertion);
1726
1727 if Do_not_create_temp_msf_flag then do;
1728
1729 Ec = error_table_$rqover;
1730 return;
1731 end;
1732
1733 if ^Create_temp_msf_flag then do;
1734 Create_temp_msf_flag = TRUE;
1735
1736 if ^Specified_temp_file_flag then do;
1737 Temp_dn = get_pdir_ ();
1738 Temp_en = unique_chars_ (FALSE);
1739 end;
1740 else do;
1741
1742
1743 call get_temp_segment_ (ME, Second_temp_seg_ptr, Ec);
1744 if Ec ^= 0 then do;
1745 call com_err_ (Ec, ME, "Cannot get temp segment.");
1746 return;
1747 end;
1748
1749 Second_temp_seg_ptr -> Second_temp_seg = Temp_seg_ptr -> Temp_seg;
1750
1751
1752
1753
1754
1755 Temp_seg_ptr = Second_temp_seg_ptr;
1756
1757 Second_temp_seg_ptr = null;
1758 end;
1759
1760 call msf_manager_$open (Temp_dn, Temp_en, Temp_msf_fcb_ptr, Ec);
1761 if Ec ^= 0 then do;
1762 if Ec ^= error_table_$noentry then do;
1763 call com_err_ (Ec, ME, "^a", pathname_ (Temp_dn, Temp_en));
1764 return;
1765 end;
1766 else Ec = 0;
1767 end;
1768 end;
1769
1770 if Temp_msf_total_components > 0 then do;
1771 Temp_msf_comp_index = Temp_msf_total_components;
1772 Temp_msf_total_components = Temp_msf_total_components + 1;
1773 end;
1774
1775
1776 call copy_temp_seg_into_msf (Temp_dn, Temp_en, Temp_msf_fcb_ptr, Temp_msf_comp_index,
1777 Temp_msf_comp_ptr, Temp_msf_comp_bitc, Temp_msf_total_components);
1778 if Ec ^= 0 then return;
1779
1780 Temp_seg_len_in_chars = 0;
1781
1782 remaining_pos_for_insertion = Outc_len - available_pos_for_insertion;
1783 if remaining_pos_for_insertion > 0 then do;
1784
1785 Temp_seg_len_in_chars = remaining_pos_for_insertion;
1786 substr (Temp_seg, 1, remaining_pos_for_insertion) = substr (Outc, available_pos_for_insertion + 1, remaining_pos_for_insertion);
1787 end;
1788 end;
1789 end;
1790
1791 return;
1792
1793
1794 %page;
1795 output: proc (p_slew_char);
1796
1797
1798
1799
1800 dcl p_slew_char char (1);
1801
1802
1803
1804 Outc_len, Ox = Ox + 1;
1805 substr (Outc, Ox, 1) = p_slew_char;
1806
1807 return;
1808
1809 end output;
1810
1811
1812 %page;
1813 sort: proc;
1814
1815
1816
1817
1818
1819 dcl d fixed bin;
1820 dcl i fixed bin;
1821 dcl swaps fixed bin;
1822 dcl temp bit (36) aligned;
1823
1824
1825
1826 d = Nch;
1827
1828 sort_pass:
1829 swaps = 0;
1830
1831 d = divide (d + 1, 2, 17, 0);
1832
1833 do i = 1 to Nch - d;
1834
1835 if unspec (Bead (i)) > unspec (Bead (i + d)) then do;
1836 swaps = swaps + 1;
1837 temp = unspec (Bead (i));
1838 unspec (Bead (i)) = unspec (Bead (i + d));
1839 unspec (Bead (i + d)) = temp;
1840 end;
1841 end;
1842
1843 if d > 1 then goto sort_pass;
1844
1845 if swaps > 0 then goto sort_pass;
1846
1847 return;
1848
1849 end sort;
1850
1851
1852 %page;
1853 end do_canon;
1854
1855
1856 %page;
1857 get_specified_file_type: proc (p_dn, p_en, p_fs_util_type);
1858
1859
1860
1861
1862
1863
1864 dcl (p_dn, p_en) char (*);
1865 dcl p_fs_util_type char (32);
1866
1867
1868
1869 Ec = 0;
1870
1871 call fs_util_$get_type (p_dn, p_en, p_fs_util_type, Ec);
1872 if Ec ^= 0 then do;
1873 call com_err_ (Ec, ME, "^a", pathname_ (p_dn, p_en));
1874 return;
1875 end;
1876
1877 if p_fs_util_type = FS_OBJECT_TYPE_DIRECTORY then do;
1878 Ec = error_table_$dirseg;
1879 call com_err_ (Ec, ME, "^a", pathname_ (p_dn, p_en));
1880 end;
1881
1882 if p_fs_util_type = FS_OBJECT_TYPE_DM_FILE then do;
1883 Ec = dm_error_$file_in_use;
1884 call com_err_ (Ec, ME, "^a", pathname_ (p_dn, p_en));
1885 end;
1886
1887 return;
1888
1889 end get_specified_file_type;
1890
1891
1892 %page;
1893 initialization: proc;
1894
1895
1896
1897
1898
1899
1900
1901 Access_ptr,
1902 Input_msf_comp_ptr,
1903 Input_msf_fcb_ptr,
1904 Outc_ptr,
1905 Out_seg_ptr,
1906 Second_temp_seg_ptr,
1907 Seg_ptr,
1908 Temp_msf_comp_ptr,
1909 Temp_msf_fcb_ptr,
1910 Temp_ptr,
1911 Temp_seg_ptr = null;
1912
1913 Bitc,
1914 Ec,
1915 Everytab,
1916 Input_msf_comp_index,
1917 In_msf_comp_bitc,
1918 In_msf_total_original_comps,
1919 In_nstops,
1920 In_stops (*),
1921 Mm,
1922 Nstops,
1923 Specified_infile_type,
1924 Stops (*),
1925 Temp_msf_comp_bitc,
1926 Temp_msf_comp_index,
1927 Temp_msf_total_components,
1928 Temp_seg_len,
1929 Temp_seg_len_in_chars = 0;
1930
1931 Dn,
1932 En,
1933 Fs_util_type,
1934 Out_dname,
1935 Out_ename,
1936 Temp_dn,
1937 Temp_en = " ";
1938
1939 Create_temp_msf_flag,
1940 Do_not_create_temp_msf_flag,
1941 Eof_flag,
1942 Have_infile_flag,
1943 Have_outfile_flag,
1944 Overwrite_exist_path_flag,
1945 Nonexistent_outfile_flag,
1946 Specified_temp_file_flag,
1947 Subroutine_call_flag,
1948 Tab_flag = FALSE;
1949
1950 Desired_access = (36)"0"b;
1951
1952 In_everytab = 10;
1953
1954 return;
1955
1956 end initialization;
1957
1958
1959 %page;
1960 initiate_specified_output_file: proc;
1961
1962
1963
1964
1965
1966
1967 Ec = 0;
1968
1969 call initiate_file_ (Out_dname, Out_ename, RW_ACCESS, Out_seg_ptr, Bitc, Ec);
1970 if Ec ^= 0 then do;
1971 if Ec = error_table_$noentry then do;
1972
1973 Ec = 0;
1974 Nonexistent_outfile_flag = TRUE;
1975 end;
1976
1977 else if Ec = error_table_$no_w_permission then do;
1978
1979 Fs_util_type = FS_OBJECT_TYPE_SEGMENT;
1980 call validate_access (Out_dname, Out_ename, Fs_util_type, RW_ACCESS, Overwrite_exist_path_flag);
1981 if Ec ^= 0 then return;
1982 if ^Overwrite_exist_path_flag then return;
1983
1984 call initiate_file_ (Out_dname, Out_ename, RW_ACCESS, Out_seg_ptr, Bitc, Ec);
1985 if Ec ^= 0 then do;
1986 call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
1987 return;
1988 end;
1989 end;
1990
1991 else if Ec = error_table_$dirseg then do;
1992
1993 call get_specified_file_type (Out_dname, Out_ename, Fs_util_type);
1994 if Ec ^= 0 then return;
1995
1996 call validate_access (Out_dname, Out_ename, Fs_util_type, RW_ACCESS, Overwrite_exist_path_flag);
1997 if Ec ^= 0 then return;
1998 if ^Overwrite_exist_path_flag then return;
1999 end;
2000 else do;
2001 call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
2002 return;
2003 end;
2004 end;
2005
2006 if ^Overwrite_exist_path_flag & ^Nonexistent_outfile_flag then do;
2007
2008 call command_query_$yes_no (Overwrite_exist_path_flag, (0), ME, "", "Do you want to overwrite ^a?", pathname_ (Out_dname, Out_ename));
2009 if ^Overwrite_exist_path_flag then return;
2010
2011 Fs_util_type = FS_OBJECT_TYPE_SEGMENT;
2012 end;
2013
2014 return;
2015
2016 end initiate_specified_output_file;
2017
2018
2019 %page;
2020 temp_seg_to_temp_msf: proc;
2021
2022
2023
2024
2025
2026
2027
2028
2029 if Temp_msf_total_components > 0 then do;
2030 Temp_msf_comp_index = Temp_msf_total_components;
2031 Temp_msf_total_components = Temp_msf_total_components + 1;
2032 end;
2033
2034 call copy_temp_seg_into_msf (Temp_dn, Temp_en, Temp_msf_fcb_ptr, Temp_msf_comp_index, Temp_msf_comp_ptr,
2035 Temp_msf_comp_bitc, Temp_msf_total_components);
2036 if Ec ^= 0 then do;
2037 call msf_manager_$close (Temp_msf_fcb_ptr);
2038 return;
2039 end;
2040
2041 call msf_manager_$adjust (Temp_msf_fcb_ptr, Temp_msf_comp_index, Temp_msf_comp_bitc, THREE_BIT_SWITCH, Ec);
2042 if Ec ^= 0 then do;
2043 call msf_manager_$close (Temp_msf_fcb_ptr);
2044 call com_err_ (Ec, ME, "Cannot adjust component ^d of MSF ^a", Temp_msf_comp_index, pathname_ (Temp_dn, Temp_en));
2045 return;
2046 end;
2047
2048 return;
2049
2050 end temp_seg_to_temp_msf;
2051
2052
2053 %page;
2054 temp_msf_to_infile_or_outfile: proc (p_dirname, p_enname);
2055
2056
2057
2058
2059
2060
2061
2062 dcl p_dirname char (*);
2063 dcl p_enname char (*);
2064
2065
2066
2067 Ec = 0;
2068
2069 on record_quota_overflow begin;
2070 Ec = error_table_$rqover;
2071 call msf_manager_$close (Input_msf_fcb_ptr);
2072 call msf_manager_$close (Temp_msf_fcb_ptr);
2073 revert record_quota_overflow;
2074 goto temp_msf_ERROR_RETURN;
2075 end;
2076
2077 Temp_seg_len = Temp_seg_len_in_chars;
2078
2079 Temp_seg_len_in_chars = CHARS_PER_SEGMENT;
2080
2081
2082 do Temp_msf_comp_index = COMPONENT_ZERO to (Temp_msf_total_components - 1);
2083
2084 Input_msf_comp_index = Temp_msf_comp_index;
2085
2086 call msf_manager_$msf_get_ptr (Input_msf_fcb_ptr, Input_msf_comp_index, TRUE, Input_msf_comp_ptr, In_msf_comp_bitc, Ec);
2087
2088 if Ec ^= 0 then do;
2089 call msf_manager_$close (Input_msf_fcb_ptr);
2090 call msf_manager_$close (Temp_msf_fcb_ptr);
2091 call com_err_ (Ec, ME, "Cannot get component ^d of MSF ^a", Input_msf_comp_index, pathname_ (p_dirname, p_enname));
2092 return;
2093 end;
2094
2095 call msf_manager_$msf_get_ptr (Temp_msf_fcb_ptr, Temp_msf_comp_index, FALSE, Temp_msf_comp_ptr, Temp_msf_comp_bitc, Ec);
2096 if Ec ^= 0 then do;
2097 call com_err_ (Ec, ME, "Cannot get component ^d of MSF ^a.", Input_msf_comp_index, pathname_ (Temp_dn, Temp_en));
2098 call msf_manager_$close (Input_msf_fcb_ptr);
2099 call msf_manager_$close (Temp_msf_fcb_ptr);
2100 return;
2101 end;
2102
2103 if Temp_msf_comp_index = (Temp_msf_total_components - 1) then
2104
2105 Temp_seg_len_in_chars = Temp_seg_len;
2106
2107
2108
2109 Input_msf_comp_ptr -> Temp_seg = Temp_msf_comp_ptr -> Temp_seg;
2110 end;
2111
2112 call msf_manager_$adjust (Input_msf_fcb_ptr, Input_msf_comp_index, Temp_msf_comp_bitc, THREE_BIT_SWITCH, Ec);
2113 if Ec ^= 0 then do;
2114 call msf_manager_$close (Input_msf_fcb_ptr);
2115 call msf_manager_$close (Temp_msf_fcb_ptr);
2116 call com_err_ (Ec, ME, "Cannot adjust component ^d of MSF ^a.", Input_msf_comp_index, pathname_ (p_dirname, p_enname));
2117 return;
2118 end;
2119
2120 temp_msf_ERROR_RETURN:
2121 return;
2122
2123 end temp_msf_to_infile_or_outfile;
2124
2125
2126 %page;
2127 %include access_mode_values;
2128 %page;
2129 %include object_info;
2130 %page;
2131 %include system_constants;
2132 %page;
2133 %include terminate_file;
2134 %page;
2135 %include copy_flags;
2136 %page;
2137 %include suffix_info;
2138
2139 end canonicalize;