1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1983 *
  4    *                                                         *
  5    *********************************************************** */
  6 /* format: style2,ind3 */
  7 collmgr_display:
  8 cmds:
  9    proc ();
 10 
 11 /*
 12 DESCRIPTION:
 13 
 14      This command displays the collection_manager_ file_header, and the
 15 collection_headers for each of the collections in a DM file.
 16 */
 17 
 18 /*
 19 HISTORY:
 20 
 21 Written by Lindsey L. Spratt, 12/01/82.
 22 Modified:
 23 12/17/82 by Lindsey Spratt:  Added element displays and finer control over
 24             what is displayed.
 25 01/12/83 by Lindsey Spratt:  Fixed to initialize display_flag to "0"b.  Also
 26             fixed messages for displaying elements.
 27 03/08/83 by Lindsey Spratt:  Added special interpretation for a collection_idx
 28             of 0.  This identifies the header collection.  Added the ability
 29             to display an element formatted by an arbitrary structure (using
 30             the display_structure technology).  Changed the -element control
 31             option to only accept one element per option.
 32 12/05/84 by Lindsey L. Spratt:  Fixed to declare the undeclared builtins.
 33 */
 34 /* START OF DECLARATIONS */
 35 /* Parameter */
 36 /* Automatic */
 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 /* Based */
 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 /* Builtin */
 90 
 91       dcl     (addr, bin, char, divide, hbound, index, length, null, rtrim, substr, unspec)
 92                                      builtin;
 93 
 94 /* Constant */
 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 /* Entry */
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 /* External */
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 /* END OF DECLARATIONS */
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 /* Process arguments. */
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):                                                   /* unexpected argument */
175                call complain (error_table_$badopt, myname, "Argument is out of place: ^a.", arg);
176                return;
177 
178 ARG (1):                                                    /* -file */
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):                                                    /* -first_collection */
191 ARG (3):                                                    /* -ftc */
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):                                                    /* -number_of_collections */
198 ARG (5):                                                    /* -noc */
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):                                                    /* -display */
205 ARG (7):                                                    /* -ds */
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):                                                    /* -element */
227 ARG (9):                                                    /* -el */
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):                                            /* -file */
290                accept_control_argument = "0"b;
291                goto NEXT_ARG;
292 
293 CONTROL_ARG (2):                                            /* -first_collection */
294 CONTROL_ARG (3):                                            /* -ftc */
295                accept_control_argument = "0"b;
296                goto NEXT_ARG;
297 
298 CONTROL_ARG (4):                                            /* -number_of_collections */
299 CONTROL_ARG (5):                                            /* -noc */
300                accept_control_argument = "0"b;
301                goto NEXT_ARG;
302 
303 CONTROL_ARG (6):                                            /* -display */
304 CONTROL_ARG (7):                                            /* -ds */
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):                                            /* -element */
311 CONTROL_ARG (9):                                            /* -el */
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 /* BEGIN INCLUDE FILE control_argument_dcls.incl.pl1 */
585 
586 /* This file contains all of the commonly used declarations for commands
587 concerning control argument processing.
588 
589 Written  by  Lindsey Spratt, 08/28/79
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;    /*dcl error_table_$active_function fixed bin(35) ext; */
617 
618 /* END INCLUDE FILE control_argument_dcls.incl.pl1 */
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;