1
2
3
4
5
6
7 collmgr_display:
8 cmds:
9 proc ();
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 dcl file_dir char (168) init ("");
39 dcl file_entry char (32) init ("");
40 dcl (file_opening_id, current_collection_id)
41 bit (36) aligned init ("0"b);
42 dcl work_area_ptr ptr init (null);
43 dcl 1 local_print_data_info
44 like print_data_info;
45 dcl temp_string_ptr ptr init (null);
46 dcl collection_idx fixed bin;
47 dcl display_idx fixed bin init (0);
48 dcl first_collection_idx fixed bin init (0);
49 dcl number_of_collections fixed bin init (0);
50 dcl 1 automatic_cm_file_header
51 like cm_file_header;
52 dcl collection_id_table_length_in_bits
53 fixed bin (35);
54 dcl element_ptr ptr init (null);
55 dcl element_length fixed bin (35) init (0);
56 dcl (root_element_spec_ptr, element_spec_ptr, old_spec_ptr, next_ptr)
57 ptr init (null);
58
59 dcl display_flag (7) bit (1) aligned;
60
61 dcl display_info bit (1) aligned defined display_flag (1);
62 dcl display_header bit (1) aligned defined display_flag (2);
63 dcl display_file_header bit (1) aligned defined display_flag (3);
64 dcl display_collection_id_table
65 bit (1) aligned defined display_flag (4);
66 dcl display_element bit (1) aligned defined display_flag (5);
67 dcl display_element_in_characters
68 bit (1) aligned defined display_flag (6);
69 dcl display_header_collection
70 bit (1) aligned defined display_flag (7);
71
72 dcl true_arg char (32) varying init ("");
73
74
75
76 dcl work_area area (sys_info$max_seg_size) based (work_area_ptr);
77 dcl temp_string based (temp_string_ptr) char (sys_info$max_seg_size * 4) varying;
78
79 dcl 1 element_spec based (element_spec_ptr),
80 2 next ptr init (null),
81 2 structure_name char (32) varying init (""),
82 2 collection_idx fixed bin init (0),
83 2 position fixed bin (17),
84 2 id like element_id;
85
86 dcl element based (element_ptr) bit (element_length);
87 dcl character_element based (element_ptr) char (divide (element_length, 9, 35, 0));
88
89
90
91 dcl (addr, bin, char, divide, hbound, index, length, null, rtrim, substr, unspec)
92 builtin;
93
94
95
96 dcl BITS_PER_BYTE init (9) fixed bin (35) internal static options (constant);
97
98 dcl DISPLAY_KEYWORD (7, 2) char (32) varying
99 init ("info", "i", "header", "h", "file_header", "fh", "collection_id_table", "cit",
100 "element", "e", "element_in_characters", "eic", "header_collection", "hc")
101 internal static options (constant);
102
103 dcl myname init ("collmgr_display") char (32) varying internal static options (constant);
104 dcl argument_type (9) internal static options (constant) char (64) varying
105 init ("DM file pathname", "index into the collection_id_table",
106 "index into the collection_id_table", "number of collections",
107 "number of collections", "keyword", "keyword", "element_id", "element_id");
108 dcl control_argument (9) internal static options (constant) char (64) varying
109 init ("-file", "-first_collection", "-ftc", "-number_of_collections", "-noc",
110 "-display", "-ds", "-element", "-el");
111
112
113
114 dcl ioa_ entry () options (variable);
115 dcl ioa_$nnl entry () options (variable);
116 dcl file_manager_$open entry (char (*), char (*), bit (36) aligned, fixed bin (35));
117 dcl cm_opening_info$get entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (35));
118 dcl cm_get_element entry (bit (36) aligned, bit (36) aligned, bit (36) aligned, fixed bin, ptr,
119 fixed bin (35), ptr, bit (1) aligned, ptr, fixed bin (35), fixed bin (35));
120 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
121 dcl get_system_free_area_ entry () returns (ptr);
122 dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35));
123 dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35));
124 dcl print_data_ entry (char (*) var, ptr, fixed bin (35));
125
126
127
128 dcl sys_info$max_seg_size fixed bin (35) ext static;
129 dcl dm_error_$file_already_open
130 fixed bin (35) ext static;
131
132
133 ^L
134 display_flag = "0"b;
135 display_file_header, display_info, display_header = "1"b;
136 work_area_ptr = get_system_free_area_ ();
137
138
139
140 call cu_$af_return_arg (nargs, return_arg_ptr, return_arg_len, code);
141 if code = 0
142 then is_active_function = "1"b;
143 else if code = error_table_$not_act_fnc
144 then is_active_function = "0"b;
145 else
146 do;
147 call com_err_ (code, myname);
148 return;
149 end;
150
151 if is_active_function
152 then complain = active_fnc_err_;
153 else complain = com_err_;
154
155 if nargs = 0
156 then
157 do;
158 call complain (error_table_$noarg, myname, "^/Usage: ^a {-control_args}", myname);
159 return;
160 end;
161 accept_control_argument = "1"b;
162 control_argument_idx = 1;
163
164 ARG_PROCESSING_LOOP:
165 do arg_idx = 1 to nargs;
166 call cu_$arg_ptr (arg_idx, arg_ptr, arg_len, code);
167 if char (arg, 1) ^= "-"
168 then
169 PROCESS_ARG:
170 do;
171 goto ARG (control_argument_idx);
172
173
174 ARG (-1):
175 call complain (error_table_$badopt, myname, "Argument is out of place: ^a.", arg);
176 return;
177
178 ARG (1):
179 call expand_pathname_ (arg, file_dir, file_entry, code);
180 if code ^= 0
181 then
182 do;
183 call complain (code, myname, "^/Unable to expand the pathname ""^a"".", arg);
184 return;
185 end;
186
187 control_argument_idx = -1;
188 accept_control_argument = "1"b;
189 goto NEXT_1;
190 ARG (2):
191 ARG (3):
192 first_collection_idx = bin (arg);
193
194 control_argument_idx = -1;
195 accept_control_argument = "1"b;
196 goto NEXT_1;
197 ARG (4):
198 ARG (5):
199 number_of_collections = bin (arg);
200
201 control_argument_idx = -1;
202 accept_control_argument = "1"b;
203 goto NEXT_1;
204 ARG (6):
205 ARG (7):
206 if char (arg, 1) = "^"
207 then true_arg = substr (arg, 2);
208 else true_arg = arg;
209 do display_idx = 1 to hbound (DISPLAY_KEYWORD, 1)
210 while (DISPLAY_KEYWORD (display_idx, 1) ^= true_arg & DISPLAY_KEYWORD (display_idx, 2) ^= true_arg);
211 end;
212 if display_idx > hbound (DISPLAY_KEYWORD, 1)
213 then
214 do;
215 call complain (error_table_$badopt, myname,
216 "^/Invalid display keyword ""^a"". Valid display keywords are:
217 ^v(^a (^a), ^)and ^a (^a).", arg, hbound (DISPLAY_KEYWORD, 1) - 1, DISPLAY_KEYWORD);
218 call FINISH;
219 return;
220 end;
221 display_flag (display_idx) = (arg = true_arg);
222
223 accept_control_argument = "1"b;
224 goto NEXT_1;
225
226 ARG (8):
227 ARG (9):
228 old_spec_ptr = element_spec_ptr;
229 alloc element_spec in (work_area);
230 if root_element_spec_ptr = null
231 then root_element_spec_ptr = element_spec_ptr;
232 else old_spec_ptr -> element_spec.next = element_spec_ptr;
233 element_spec.next = null;
234 element_spec.position = 0;
235 unspec (element_spec.id) = "0"b;
236 element_spec.collection_idx = bin (arg);
237 control_argument_idx = -2;
238 accept_control_argument = "0"b;
239 goto NEXT_1;
240
241 ARG (-2):
242 element_spec.id.control_interval_id = bin (arg);
243 control_argument_idx = -3;
244 accept_control_argument = "0"b;
245 goto NEXT_1;
246
247 ARG (-3):
248 element_spec.id.index = bin (arg);
249 control_argument_idx = -4;
250 accept_control_argument = "1"b;
251 goto NEXT_1;
252
253 ARG (-4):
254 element_spec.structure_name = arg;
255 control_argument_idx = -1;
256
257 accept_control_argument = "1"b;
258 goto NEXT_1;
259 NEXT_1:
260 end PROCESS_ARG;
261 else if control_argument_idx ^= -1 & ^accept_control_argument
262 then
263 do;
264 if control_argument_idx = -2 | control_argument_idx = -3
265 then control_argument_idx = 8;
266 call complain (error_table_$noarg, myname, "^a must be followed by a^[n^] ^a.",
267 control_argument (control_argument_idx),
268 (index ("aeiouh", substr (argument_type (control_argument_idx), 1, 1)) > 0),
269 argument_type (control_argument_idx));
270 return;
271 end;
272 else
273 PROCESS_CONTROL_ARG:
274 do;
275 do control_argument_idx = 1 to hbound (control_argument, 1)
276 while (control_argument (control_argument_idx) ^= arg);
277 end;
278 if control_argument_idx > hbound (control_argument, 1)
279 then
280 do;
281 call complain (error_table_$badopt, myname, "^a", arg);
282 return;
283 end;
284
285 goto CONTROL_ARG (control_argument_idx);
286
287 CONTROL_ARG (0):
288 ;
289 CONTROL_ARG (1):
290 accept_control_argument = "0"b;
291 goto NEXT_ARG;
292
293 CONTROL_ARG (2):
294 CONTROL_ARG (3):
295 accept_control_argument = "0"b;
296 goto NEXT_ARG;
297
298 CONTROL_ARG (4):
299 CONTROL_ARG (5):
300 accept_control_argument = "0"b;
301 goto NEXT_ARG;
302
303 CONTROL_ARG (6):
304 CONTROL_ARG (7):
305 display_file_header, display_info, display_header = "1"b;
306 display_collection_id_table, display_element, display_element_in_characters = "0"b;
307
308 goto NEXT_ARG;
309
310 CONTROL_ARG (8):
311 CONTROL_ARG (9):
312 display_element = "1"b;
313
314 accept_control_argument = "0"b;
315 goto NEXT_ARG;
316
317 NEXT_ARG:
318 ;
319 end PROCESS_CONTROL_ARG;
320 end ARG_PROCESSING_LOOP;
321 if control_argument_idx ^= -1 & ^accept_control_argument
322 then
323 do;
324 if control_argument_idx = -2 | control_argument_idx = -3
325 then control_argument_idx = 8;
326 call complain (error_table_$noarg, myname, "^a must be followed by a^[n^] ^a.",
327 control_argument (control_argument_idx),
328 (index ("aeiouh", substr (argument_type (control_argument_idx), 1, 1)) > 0),
329 argument_type (control_argument_idx));
330 return;
331 end;
332 ^L
333 call get_temp_segment_ ((myname), temp_string_ptr, code);
334 if code ^= 0
335 then
336 do;
337 call complain (code, myname, "^/Unable to get a temp_segment.");
338 call FINISH;
339 return;
340 end;
341
342 if file_dir = ""
343 then
344 do;
345 call complain (error_table_$noarg, myname, "^/A DM file pathname must be specified.");
346 call FINISH;
347 return;
348 end;
349
350 call file_manager_$open (file_dir, file_entry, file_opening_id, code);
351 if code ^= 0 & code ^= dm_error_$file_already_open
352 then
353 do;
354 call complain (code, myname, "^/Unable to open the file ""^a^[>^]^a"".", file_dir, file_dir ^= ">",
355 file_entry);
356 call FINISH;
357 return;
358 end;
359
360 call cm_opening_info$get (file_opening_id, HEADER_COLLECTION_ID, cm_info_ptr, code);
361 if code ^= 0
362 then
363 do;
364 call complain (code, myname, "^/Unable to get the opening info for the header collection (id ^o), for
365 file ""^a^[>^]^a"".", HEADER_COLLECTION_ID, file_dir, file_dir ^= ">", file_entry);
366 call FINISH;
367 return;
368 end;
369
370 call cm_get_element (cm_info.file_oid, cm_info.collection_id, CM_FILE_HEADER_ELEMENT_ID, 0,
371 addr (automatic_cm_file_header), length (unspec (automatic_cm_file_header)), null, ("0"b), cm_file_header_ptr,
372 (0), code);
373 if code ^= 0
374 then
375 do;
376 call complain (code, myname, "^/Unable to get the file_header.");
377 call FINISH ();
378 return;
379 end;
380
381
382 if cm_file_header.number_of_collections = 0
383 then
384 do;
385 call complain (0, myname, "^/The file ""^a^[>^]^a"" contains no collections.", file_dir, file_dir ^= ">",
386 file_entry);
387 call FINISH;
388 return;
389 end;
390
391 print_data_info_ptr = addr (local_print_data_info);
392
393 call cm_get_element (cm_info.file_oid, HEADER_COLLECTION_ID, cm_file_header.collection_id_table_element_id, 0, null,
394 (0), work_area_ptr, "1"b, collection_id_table_ptr, collection_id_table_length_in_bits, code);
395 if code ^= 0
396 then
397 do;
398 call complain (code, myname, "^/Unable to get the collection_id_table.");
399 call FINISH ();
400 return;
401 end;
402 cit_number_of_collections = cm_file_header.number_of_collections;
403
404 print_data_info.version = print_data_info_version_1;
405 print_data_info.indentation = 2;
406 print_data_info.value_column = 30;
407 print_data_info.output_switch = null;
408 print_data_info.flags.octal = "1"b;
409 print_data_info.intervals = "";
410
411 if display_file_header
412 then
413 do;
414 put string (temp_string) data (cm_file_header);
415 call print_data_ (temp_string, print_data_info_ptr, code);
416 if code ^= 0
417 then
418 do;
419 call complain (code, myname, "^/Unable to display the cm_file_header structure.");
420 call FINISH;
421 return;
422 end;
423
424 end;
425 if display_collection_id_table
426 then
427 do;
428 put string (temp_string) data (collection_id_table);
429 call print_data_ (temp_string, print_data_info_ptr, code);
430 if code ^= 0
431 then
432 do;
433 call complain (code, myname, "^/Unable to display the collection_id_table structure.");
434 call FINISH;
435 return;
436 end;
437 end;
438
439 if display_header_collection
440 then
441 do;
442 call ioa_ ("^/The header collection, id ^o:", HEADER_COLLECTION_ID);
443 if display_info
444 then
445 do;
446 put string (temp_string) data (cm_info);
447 call print_data_ (temp_string, print_data_info_ptr, code);
448 end;
449 if display_header
450 then
451 do;
452 put string (temp_string) data (cm_info.header_ptr -> collection_header);
453 call print_data_ (temp_string, print_data_info_ptr, code);
454 end;
455 end;
456
457 if first_collection_idx = 0
458 then first_collection_idx = 1;
459 if number_of_collections = 0
460 then number_of_collections = cit_number_of_collections - first_collection_idx + 1;
461
462 if ^display_element
463 then
464 COLLECTION_LOOP:
465 do collection_idx = first_collection_idx to first_collection_idx + number_of_collections - 1;
466
467 call ioa_ ("^/Collection ^d - id ^o:", collection_idx, collection_id_table (collection_idx));
468
469 call cm_opening_info$get (file_opening_id, collection_id_table (collection_idx), cm_info_ptr, code);
470 if code ^= 0
471 then
472 do;
473 call complain (code, myname, "^/Unable to get the opening info for the header collection (id ^o), for
474 file ""^a^[>^]^a"".", collection_id_table (collection_idx), file_dir, file_dir ^= ">", file_entry);
475 call FINISH;
476 return;
477 end;
478
479 if display_info
480 then
481 do;
482 put string (temp_string) data (cm_info);
483 call print_data_ (temp_string, print_data_info_ptr, code);
484 if code ^= 0
485 then
486 do;
487 call complain (code, myname,
488 "^/Unable to display the cm_info structure for collection ^d, with id ^o.", collection_idx,
489 collection_id_table (collection_idx));
490 call FINISH;
491 return;
492 end;
493 end;
494 if display_header
495 then
496 do;
497 put string (temp_string) data (cm_info.header_ptr -> collection_header);
498 call print_data_ (temp_string, print_data_info_ptr, code);
499 if code ^= 0
500 then
501 do;
502 call complain (code, myname, "^/Unable to display the collection_header structure.");
503 call FINISH;
504 return;
505 end;
506 end;
507
508 end COLLECTION_LOOP;
509 else
510 ELEMENT_DISPLAY:
511 do;
512 do element_spec_ptr = root_element_spec_ptr repeat (element_spec.next) while (element_spec_ptr ^= null);
513 if element_spec.collection_idx > 0
514 then current_collection_id = collection_id_table (element_spec.collection_idx);
515 else current_collection_id = HEADER_COLLECTION_ID;
516 call cm_get_element (file_opening_id, current_collection_id, unspec (element_spec.id),
517 element_spec.position, null, (0), work_area_ptr, ("0"b), element_ptr, element_length, code);
518 if code ^= 0
519 then
520 do;
521 call complain (code, myname, "^/Unable to get element in slot ^d of control interval ^d
522 (in collection number ^d with id ^o).", element_spec.id.index, element_spec.id.control_interval_id,
523 element_spec.collection_idx, current_collection_id);
524 call FINISH;
525 return;
526 end;
527
528 call ioa_ ("Element for slot ^d of control interval ^d (collection ^o, number ^d):",
529 element_spec.id.index, element_spec.id.control_interval_id, current_collection_id,
530 element_spec.collection_idx);
531
532 if element_spec.structure_name ^= ""
533 then call DISPLAY_ELEMENT_BY_STRUCTURE (addr (element), (element_spec.structure_name), code);
534 else if display_element_in_characters
535 then call ioa_ ("^a", character_element);
536 else call ioa_ ("^.3b", element);
537
538 free element in (work_area);
539
540 end;
541 end ELEMENT_DISPLAY;
542
543 call FINISH;
544 return;
545 %page;
546 FINISH:
547 proc;
548 if temp_string_ptr ^= null
549 then call release_temp_segment_ ((myname), temp_string_ptr, code);
550 end FINISH;
551 %page;
552 DISPLAY_ELEMENT_BY_STRUCTURE:
553 proc (p_structure_ptr, p_structure_name, p_code);
554 dcl cu_$arg_list_ptr entry (ptr);
555 dcl cu_$generate_call entry (entry, ptr);
556 dcl hcs_$make_entry entry (ptr, char (*), char (*), entry, fixed bin (35));
557 dcl p_structure_ptr ptr parameter;
558 dcl p_structure_name char (*) parameter;
559 dcl p_code fixed bin (35);
560 dcl arg_list_ptr ptr;
561 dcl structure_entry entry variable;
562 dcl procedure_name char (32);
563
564 procedure_name = "display_" || rtrim (p_structure_name) || "_";
565
566 call hcs_$make_entry (null, procedure_name, procedure_name, structure_entry, p_code);
567 if p_code ^= 0
568 then return;
569
570 call MAKE_STRUCTURE_CALL (p_structure_ptr, temp_string);
571
572 call print_data_ (temp_string, print_data_info_ptr, p_code);
573
574 return;
575 ^L
576 MAKE_STRUCTURE_CALL:
577 proc () options (variable);
578
579 call cu_$arg_list_ptr (arg_list_ptr);
580 call cu_$generate_call (structure_entry, arg_list_ptr);
581 end MAKE_STRUCTURE_CALL;
582 end DISPLAY_ELEMENT_BY_STRUCTURE;
583 %page;
584
585
586
587
588
589
590
591 dcl cu_$arg_count entry returns (fixed bin);
592 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
593 dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
594 dcl com_err_ entry options (variable);
595 dcl active_fnc_err_ entry () options (variable);
596 dcl complain entry () variable options (variable);
597 dcl return_arg char (return_arg_len) based (return_arg_ptr) varying;
598 dcl return_arg_len fixed bin (21);
599 dcl return_arg_ptr ptr;
600 dcl arg based (arg_ptr) char (arg_len);
601 dcl arg_ptr ptr;
602 dcl arg_len fixed bin;
603 dcl arg_idx fixed bin;
604 dcl nargs fixed bin;
605
606 dcl control_argument_idx fixed bin;
607 dcl accept_control_argument
608 bit (1);
609 dcl is_active_function bit (1);
610 dcl code fixed bin (35);
611
612 dcl error_table_$noarg fixed bin (35) ext;
613 dcl error_table_$badopt fixed bin (35) ext;
614 dcl error_table_$bad_arg fixed bin (35) ext;
615 dcl error_table_$not_act_fnc
616 fixed bin (35) ext;
617
618
619 %page;
620 %page;
621 %include dm_cm_hdr_col_ids;
622 %page;
623 %include dm_hdr_collection_id;
624 %page;
625 %include dm_cm_info;
626 %page;
627 %include dm_cm_collection_header;
628 %page;
629 %include dm_cm_storage_record;
630 %page;
631 %include dm_element_id;
632 %page;
633 %include print_data_info;
634 %page;
635 %include dm_cm_file_header;
636 end collmgr_display;