1
2
3
4
5
6
7
8
9
10
11
12 compare: proc;
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30 dcl ME char (32) int static options (constant) init ("compare");
31 dcl FORMAT (2) char (32) int static options (constant) init
32 ("^4x^6o^2x^w", "^26x^6o^2x^w");
33 dcl STRING_FORMAT (2) char (32) int static options (constant) init
34 ("^4x^a", "^26x^a");
35 dcl DOUBLE_FORMAT char (32) int static options (constant) init ("^4x^6o^2x^w^2x^6o^2x^w");
36 dcl SKIP (2) char (32) int static options (constant) init
37 ("^9x|^4x
38 dcl DOUBLE_SKIP char (32) int static options (constant) init ("^9x|^4x
39
40
41
42 dcl word (0:max_len) bit (36) based;
43 dcl area area based (area_ptr);
44
45
46
47 dcl 1 info (1:2),
48 2 path char (194),
49 2 msf_component_name char (32),
50 2 (done_sw, msf_sw, noentry_sw) bit (1),
51 2 (ptr, entries_ptr, names_ptr) ptr,
52 2 (k, len, msf_count, msf_index, offset) fixed bin;
53
54 dcl arg char (arg_len) based (arg_ptr);
55 dcl return_arg char (return_len) varying based (return_ptr);
56 dcl dn char (168);
57 dcl (cn, cn1, en, en1, xcn, xen) char (32);
58 dcl (bad_arg, bad_base) character (10) varying;
59
60 dcl mask bit (36);
61 dcl (af_sw, brief_sw, inhibit_error_sw, printed_header_sw, printed_component_header_sw, short_sw, totals_sw) bit (1);
62
63 dcl (area_ptr, arg_ptr, return_ptr) ptr;
64
65 dcl (arg_count, arg_len, block_len, col, common_len, dis_count) fixed bin;
66 dcl (given_len, i, j, max_len, path_count, return_len, word_count) fixed bin;
67 dcl max_length fixed bin (19);
68 dcl bit_count fixed bin (24);
69 dcl (code, octal_mask) fixed bin (35);
70
71
72
73 dcl error_table_$bad_conversion fixed binary (35) external static;
74 dcl error_table_$badopt fixed bin (35) ext;
75 dcl error_table_$dirseg fixed bin (35) ext;
76 dcl error_table_$item_too_big fixed bin (35) ext;
77 dcl error_table_$noentry fixed bin (35) ext;
78 dcl error_table_$nomatch fixed bin (35) ext;
79 dcl error_table_$not_act_fnc fixed bin (35) ext;
80 dcl error_table_$not_archive fixed bin (35) ext;
81
82
83
84 dcl complain entry variable options (variable);
85 dcl (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable);
86 dcl (com_err_, com_err_$suppress_name) entry options (variable);
87 dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
88 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
89 dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
90 dcl expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35));
91 dcl get_equal_name_$component entry (char (*), char (*), char (*), char (*), char (*), char (*), fixed bin (35));
92 dcl get_system_free_area_ entry returns (ptr);
93 dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (1), ptr, fixed bin (35));
94 dcl hcs_$star_ entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35));
95 dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
96 dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
97 dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
98 dcl initiate_file_$component entry (char(*), char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
99 dcl ioa_ entry options (variable);
100 dcl pathname_ entry (char(*), char(*)) returns(char(168));
101 dcl pathname_$component entry (char (*), char (*), char (*)) returns (char (168));
102 dcl terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35));
103
104 dcl (addrel, divide, index, max, min, null, substr, sum, unspec) builtin;
105
106 dcl cleanup condition;
107 %page;
108 call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
109 if code = error_table_$not_act_fnc then do;
110 af_sw = "0"b;
111 complain = com_err_;
112 end;
113 else do;
114 af_sw = "1"b;
115 complain = active_fnc_err_;
116 end;
117
118 if arg_count < 2 then do;
119 USAGE: if af_sw then call active_fnc_err_$suppress_name (0, ME,
120 "Usage: [compare pathA{|offsetA} pathB{|offsetB} {-control_args}]");
121 else call com_err_$suppress_name (0, ME,
122 "Usage: compare pathA{|offsetA} pathB{|offsetB} {-control_args}");
123 return;
124 end;
125
126 given_len, path_count = 0;
127 mask = (36) "1"b;
128 brief_sw, inhibit_error_sw, short_sw, totals_sw = "0"b;
129 unspec (info) = "0"b;
130 do i = 1 to 2;
131 ptr (i), entries_ptr (i), names_ptr (i) = null;
132 end;
133 area_ptr = null;
134
135 on condition (cleanup) call clean_up;
136
137 do i = 1 to arg_count;
138
139 call cu_$arg_ptr (i, arg_ptr, arg_len, code);
140
141 if substr (arg, 1, 1) = "-" then
142 if arg = "-brief" | arg = "-bf" then
143 if af_sw then go to BADOPT;
144 else brief_sw = "1"b;
145 else if arg = "-inhibit_error" | arg = "-ihe" then
146 if ^af_sw then go to BADOPT;
147 else inhibit_error_sw = "1"b;
148 else if arg = "-long" | arg = "-lg" then
149 if af_sw then go to BADOPT;
150 else brief_sw = "0"b;
151 else if arg = "-length" | arg = "-ln" then do;
152 i = i + 1;
153 call cu_$arg_ptr (i, arg_ptr, arg_len, code);
154 if code ^= 0 then do;
155 call complain (0, ME, "No value specified for -length");
156 return;
157 end;
158 given_len = cv_oct_check_ (arg, code);
159 bad_arg = "-length";
160 if code ^= 0 then do;
161 BAD_OCTAL_NUM:
162 bad_base = "an octal";
163 BAD_NUM: call complain (error_table_$bad_conversion, ME,
164 "^a requires ^a number, not ^a.", bad_arg, bad_base, arg);
165 return;
166 end;
167 if given_len <= 0
168 then do;
169 bad_base = "a positive";
170 go to BAD_NUM;
171 end;
172 end;
173 else if arg = "-mask" then do;
174 i = i + 1;
175 call cu_$arg_ptr (i, arg_ptr, arg_len, code);
176 if code ^= 0 then do;
177 call complain (0, ME, "No value specified for -mask");
178 return;
179 end;
180 octal_mask = cv_oct_check_ (arg, code);
181 if code ^= 0
182 then do;
183 bad_arg = "-mask";
184 go to BAD_OCTAL_NUM;
185 end;
186 mask = unspec (octal_mask);
187 end;
188 else if arg = "-no_inhibit_error" | arg = "-nihe" then
189 if ^af_sw then go to BADOPT;
190 else inhibit_error_sw = "0"b;
191 else if arg = "-short" | arg = "-sh" then
192 if af_sw then go to BADOPT;
193 else short_sw = "1"b;
194 else if arg = "-totals" | arg = "-total" | arg = "-tt" then
195 if af_sw then go to BADOPT;
196 else totals_sw = "1"b;
197 else do;
198 BADOPT: call complain (error_table_$badopt, ME, "^a", arg);
199 return;
200 end;
201 else do;
202 path_count = path_count + 1;
203 if path_count > 2 then go to USAGE;
204 call get_path (path_count);
205 end;
206 end;
207
208 if path_count ^= 2 then go to USAGE;
209
210 if noentry_sw (1) | noentry_sw (2) then do;
211 if inhibit_error_sw then do;
212 if noentry_sw (1) & noentry_sw (2) then do;
213 call complain (error_table_$noentry, ME, "^/^5x^a^/^5x^a", path (1), path (2));
214 go to RETURN;
215 end;
216 else do;
217 return_arg = "false"; note
218 go to RETURN;
219 end;
220 end;
221 else do;
222 if noentry_sw (1) then i = 1;
223 else i = 2;
224 call complain (error_table_$noentry, ME, "^a", path (i));
225 go to RETURN;
226 end;
227 end;
228
229 if ptr (1) = ptr (2) & ^msf_sw (1) & offset (1) = offset (2) then do;
230 call complain (0, ME, "Attempt to compare data with itself.");
231 call clean_up;
232 return;
233 end;
234
235 if min (len (1), len (2)) = 0 & af_sw then do;
236 if len (1) = len (2) then return_arg = "true";
237 else return_arg = "false";
238 call clean_up;
239 return;
240 end;
241
242 dis_count, word_count = 0;
243 printed_header_sw = "0"b;
244
245 if ^msf_sw (1) & ^msf_sw (2) then call print_discrepancies ();
246 else do;
247 if af_sw & msf_sw (1) ^= msf_sw (2) then do;
248 return_arg = "false";
249 go to RETURN;
250 end;
251
252 do while (^done_sw (1) & ^done_sw (2));
253 call get_next_msf_component (1);
254 call get_next_msf_component (2);
255 printed_component_header_sw = "0"b;
256 call print_discrepancies ();
257 end;
258 do i = 1 to 2;
259 if ^done_sw (i) then do;
260 dis_count = dis_count + 1;
261 if ^af_sw then call ioa_ ("Remaining components of MSF ^a", path (i));
262 do while (^done_sw (i));
263 call get_next_msf_component (i);
264 word_count = word_count + len (i);
265 if ^af_sw then call ioa_ (STRING_FORMAT (i), get_msf_component_name (i));
266 end;
267 end;
268 end;
269 end;
270
271
272
273 if af_sw then do;
274 return_arg = "true";
275 go to RETURN;
276 end;
277
278 if dis_count = 0 then call ioa_ ("No discrepancies.");
279 else call ioa_ ("^/Total ^d discrepanc^[ies^;y^], ^d word^[s^]",
280 dis_count, dis_count > 1, word_count, word_count > 1);
281
282 RETURN: call clean_up;
283 return;
284 %page;
285 clean_up: proc;
286
287 dcl i fixed bin;
288
289 do i = 1 to 2;
290 if ptr (i) ^= null then call terminate_file_ (ptr (i), 0, TERM_FILE_TERM, code);
291 if entries_ptr (i) ^= null then free entries_ptr (i) -> star_entries in (area);
292 if names_ptr (i) ^= null then free names_ptr (i) -> star_names in (area);
293 end;
294
295 end clean_up;
296 %page;
297 get_msf_component_name: proc (P_i) returns (char (64));
298
299
300
301 dcl P_i fixed bin;
302
303 if ^msf_sw (P_i) then return ("Segment");
304 else return ("Component " || msf_component_name (P_i));
305
306 end get_msf_component_name;
307 %page;
308 get_next_msf_component: proc (P_i);
309
310
311
312
313 dcl P_i fixed bin;
314
315 if ^msf_sw (P_i) then done_sw (P_i) = "1"b;
316 else do;
317 msf_index (P_i) = min (msf_index (P_i) + 1, msf_count (P_i));
318 if msf_index (P_i) = msf_count (P_i) then done_sw (P_i) = "1"b;
319 msf_component_name (P_i) =
320 names_ptr (P_i) -> star_names (entries_ptr (P_i) -> star_entries (msf_index (P_i)).nindex);
321
322 call initiate_file_ (path (P_i), msf_component_name (P_i), R_ACCESS, ptr (P_i), bit_count, code);
323 if code ^= 0 then do;
324 call complain (code, ME, "MSF component ^a", pathname_ (path (P_i), msf_component_name (P_i)));
325 go to RETURN;
326 end;
327 len (P_i) = divide (bit_count + 35, 36, 17, 0);
328 end;
329
330 end get_next_msf_component;
331 %page;
332 get_path: proc (P_i);
333
334 dcl P_i fixed bin;
335
336 j = index (arg, "|");
337 if j = arg_len then do;
338 BAD_OFFSET: call complain (code, ME, "Invalid offset in ^a", arg);
339 goto RETURN;
340 end;
341
342 if j ^= 0 then do;
343 offset (P_i) = cv_oct_check_ (substr (arg, j + 1), code);
344 if code ^= 0 then do;
345 code = error_table_$bad_conversion;
346 goto BAD_OFFSET;
347 end;
348 arg_len = j - 1;
349 end;
350
351 call expand_pathname_$component (arg, dn, en, cn, code);
352 if code ^= 0 & code ^= error_table_$not_archive then do;
353 call complain (code, ME, "^a", arg);
354 go to RETURN;
355 end;
356
357 if P_i = 2 then do;
358 call get_equal_name_$component (en1, cn1, en, cn, xen, xcn, code);
359 if code ^= 0 then do;
360 call complain (code, ME, "^a^[::^a^] applied to ^a^[::^a^]",
361 en, cn ^= "", cn, en1, cn1 ^= "", cn1);
362 go to RETURN;
363 end;
364 en = xen;
365 cn = xcn;
366 end;
367 else do;
368 en1 = en;
369 cn1 = cn;
370 end;
371
372 path (P_i) = pathname_$component (dn, en, cn);
373
374 if cn ^= "" then call initiate_file_$component (dn, en, cn, R_ACCESS, ptr (P_i), bit_count, code);
375 else call initiate_file_ (dn, en, R_ACCESS, ptr (P_i), bit_count, code);
376 if ptr (P_i) = null then do;
377 if code = error_table_$dirseg then do;
378 bit_count = 0;
379 call hcs_$status_minf (dn, en, 1, 0, bit_count, 0);
380 if bit_count ^= 0 then do;
381 if offset (P_i) ^= 0 then do;
382 call complain (0, ME, "Nonzero offset not allowed for MSF ^a",
383 pathname_ (dn, en));
384 go to RETURN;
385 end;
386
387 msf_sw (P_i) = "1"b;
388
389 if area_ptr = null then area_ptr = get_system_free_area_ ();
390 call hcs_$star_ (pathname_ (dn, en), "**", star_BRANCHES_ONLY, area_ptr,
391 star_entry_count, star_entry_ptr, star_names_ptr, code);
392 if code ^= 0 then do;
393 if code = error_table_$nomatch then call complain (0, ME, "Invalid MSF ^a",
394 pathname_ (dn, en));
395 else call complain (code, ME, "^a", pathname_ (dn, en));
396 go to RETURN;
397 end;
398 entries_ptr (P_i) = star_entry_ptr;
399 names_ptr (P_i) = star_names_ptr;
400 msf_count (P_i) = star_entry_count;
401 msf_index (P_i) = 0;
402 len (P_i) = 1;
403 return;
404 end;
405 end;
406 else if code = error_table_$noentry then do;
407 noentry_sw (P_i) = "1"b;
408 return;
409 end;
410 else call complain (code, ME, "^a", path (P_i));
411 go to RETURN;
412 end;
413
414 len (P_i) = divide (bit_count + 35, 36, 17, 0);
415
416 if offset (P_i) > len (P_i) then do;
417 call complain (error_table_$item_too_big, ME,"
418 Base-zero offset ^d greater than length ^d", offset (P_i), len (P_i));
419 go to RETURN;
420 end;
421
422 end get_path;
423 %page;
424 print_discrepancies: proc;
425
426 max_len = max (len (1), len (2));
427 common_len = min (len (1) - offset (1), len (2) - offset (2));
428 if given_len ^= 0 then do;
429 max_len = min (max_len, offset (1) + given_len, offset (2) + given_len);
430 common_len = min (common_len, given_len);
431 end;
432
433 k (1) = offset (1);
434 k (2) = offset (2);
435
436 block_len = 0;
437
438 do i = 1 to common_len;
439
440 do i = i to common_len while
441 ((mask & ptr (1) -> word (k (1) + block_len)) ^= (mask & ptr (2) -> word (k (2) + block_len)));
442 block_len = block_len + 1;
443 end;
444
445 if block_len > 0 then do;
446
447 if af_sw then do;
448 return_arg = "false";
449 go to RETURN;
450 end;
451
452 if ^printed_header_sw then call print_header;
453
454 if ^printed_component_header_sw then do;
455 printed_component_header_sw = "1"b;
456 if (msf_sw (1) | msf_sw (2)) & ^totals_sw then
457 call ioa_ ("^a / ^a:", get_msf_component_name (1), get_msf_component_name (2));
458 end;
459
460 dis_count = dis_count + 1;
461 word_count = word_count + block_len;
462
463 if short_sw | totals_sw then do;
464 if ^totals_sw then call ioa_ ("^5d word^[s^; ^] at: ^6o", block_len, block_len > 1, k (1));
465 k (1) = k (1) + block_len;
466 k (2) = k (2) + block_len;
467 end;
468 else if block_len > 3 & brief_sw then do;
469 call ioa_ (DOUBLE_FORMAT,
470 k (1), ptr (1) -> word (k (1)),
471 k (2), ptr (2) -> word (k (2)));
472 call ioa_ (DOUBLE_SKIP);
473 k (1) = k (1) + block_len;
474 k (2) = k (2) + block_len;
475 call ioa_ (DOUBLE_FORMAT,
476 k (1) - 1, ptr (1) -> word (k (1) - 1),
477 k (2) - 1, ptr (2) -> word (k (2) - 1));
478 end;
479 else do;
480 do j = 1 to block_len;
481 call ioa_ (DOUBLE_FORMAT,
482 k (1), ptr (1) -> word (k (1)),
483 k (2), ptr (2) -> word (k (2)));
484 k (1) = k (1) + 1;
485 k (2) = k (2) + 1;
486 end;
487 end;
488
489 if i <= common_len then do;
490 k (1) = k (1) + 1;
491 k (2) = k (2) + 1;
492 end;
493
494 block_len = 0;
495 end;
496
497 else do;
498 k (1) = k (1) + 1;
499 k (2) = k (2) + 1;
500 end;
501 end;
502
503 if max_len > max (k (1), k (2)) then do;
504
505 if af_sw then do;
506 return_arg = "false";
507 go to RETURN;
508 end;
509
510 if ^printed_header_sw then call print_header;
511 if min (len (1), len (2)) = 0 then dis_count = dis_count + 1;
512 else if (mask & ptr (1) -> word (k (1) - 1)) = (mask & ptr (2) -> word (k (2) - 1)) then
513 dis_count = dis_count + 1;
514 if len (1) > len (2) then col = 1;
515 else col = 2;
516 block_len = max_len - k (col);
517 word_count = word_count + block_len;
518
519 if totals_sw then;
520 else if short_sw then call ioa_ ("^5d word^[s^; ^] at: ^6o (file ^d)",
521 block_len, block_len > 1, k (col), col);
522 else if block_len > 3 & brief_sw then do;
523 call ioa_ (FORMAT (col), k (col), ptr (col) -> word (k (col)));
524 call ioa_ (SKIP (col));
525 call ioa_ (FORMAT (col), max_len - 1, ptr (col) -> word (max_len - 1));
526 end;
527 else do j = k (col) to max_len - 1;
528 call ioa_ (FORMAT (col), j, ptr (col) -> word (j));
529 end;
530 end;
531
532 end print_discrepancies;
533 %page;
534 print_header: proc;
535
536 printed_header_sw = "1"b;
537 if short_sw | totals_sw then return;
538 call ioa_ ("Discrepancies:");
539 call ioa_ ("^4xoffset^4xcontents^4xoffset^4xcontents");
540
541 end print_header;
542 %page;
543 %include access_mode_values;
544 %page;
545 %include star_structures;
546 %page;
547 %include terminate_file;
548
549
550 end compare;