1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Bull Inc., 1989                *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   6         *                                                         *
   7         * Copyright (c) 1972 by Massachusetts Institute of        *
   8         * Technology and Honeywell Information Systems, Inc.      *
   9         *                                                         *
  10         *********************************************************** */
  11 
  12 
  13 
  14 
  15 /****^  HISTORY COMMENTS:
  16   1) change(88-12-01,Parisek), approve(89-01-03,MCR8037),
  17      audit(89-01-16,Farley), install(89-01-19,MR12.3-1006):
  18      Ignore the error_table_$undefined_order_request error code when
  19      calling the control order "dump_fnp" in fnp_fetch.  If the order
  20      is undefined for a particular FNP then we simply don't need to
  21      display the data produced by the control order.
  22                                                    END HISTORY COMMENTS */
  23 
  24 
  25 display_psp:
  26      proc;
  27 
  28 
  29 
  30 
  31 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
  32 /*                                                       */
  33 /* The display_psp command will provide a means to       */
  34 /* assure that products ordered and installed at a site  */
  35 /* is at the correct revison and installed in the        */
  36 /* proper location. This tool will provide a quick       */
  37 /* means to find the status of a product as to           */
  38 /* revision, marketing identifier, copyright and title.  */
  39 /* This tool will indicate the correct version of the    */
  40 /* software running only if care is taken at the site    */
  41 /* to update the STI of installed modified software.     */
  42 /* For more information on how to update the STI see     */
  43 /* the generate_copyright command.                       */
  44 /*                                                       */
  45 /* 0) Written by R. Holmstedt 07/18/81                   */
  46 /* 1) Modified by G. Dixon 10/15/84 - handle missing     */
  47 /*                source properly.                       */
  48 /*                                                       */
  49 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
  50 
  51 dcl  Ccode fixed bin (35);
  52 dcl  MI_name char (9);
  53 dcl  NL char (1) int static options (constant) init ("
  54 ");
  55 dcl 01 Pnotice aligned,
  56     02 source_C char (1680) init (""),
  57     02 source_STI char (12) init (""),
  58     02 object_C char (1680) init (""),
  59     02 object_STI char (12) init (""),
  60     02 xecute_C char (1680) init (""),
  61     02 xecute_STI char (12) init ("");
  62 dcl  QUOTE char (1) int static options (constant) init ("""");
  63 dcl  Sptr ptr;
  64 dcl  no_acc_sw init ("0"b) bit (1);
  65 dcl  active_fnc_err_ entry options(variable);
  66 dcl  af_flag init ("0"b) bit (1);
  67 dcl  all_flag init ("0"b) bit (1);
  68 dcl  arg char (argl) based (argp);
  69 dcl  argl fixed bin (21);
  70 dcl  argp ptr;
  71 dcl  argno fixed bin;
  72 dcl  brief_flag init ("0"b) bit (1);
  73 dcl  code fixed bin (35);
  74 dcl  com_err_ entry () options (variable);
  75 dcl  copyw_flag init ("0"b) bit (1);
  76 dcl  crmod fixed bin int static;
  77 dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
  78 dcl  cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
  79 dcl  cu_$arg_count entry (fixed bin);
  80 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
  81 dcl  datanet_infop ptr internal static;
  82 dcl  ddata_sdw fixed bin (71);
  83 dcl  dn355_datap ptr int static;
  84 dcl  dn355_data_len fixed bin int static;
  85 dcl  dsegp ptr;
  86 dcl (error_table_$incorrect_access, error_table_$noentry,
  87      error_table_$no_dir, error_table_$improper_data_format,
  88      error_table_$no_component, error_table_$bad_arg,
  89      error_table_$inconsistent, error_table_$segknown,
  90      error_table_$moderr, error_table_$no_info,
  91      error_table_$noarg, error_table_$wrong_no_of_args,
  92      error_table_$undefined_order_request) fixed bin (35) ext static;
  93 dcl 01 fnp_infos aligned,                                   /* Data structure to dump fnp */
  94     02 fnp_addr fixed bin,
  95     02 fnp_len fixed bin,
  96     02 data_ptr ptr,
  97     02 prev_data_ptr ptr;
  98 dcl  fnp fixed bin;
  99 dcl  fnp_name char (1);
 100 dcl 01 fnptab aligned int static,
 101     02 per_fnp (0:8),
 102       03 init_switches,
 103         04 modtab_init bit (1) unal,
 104       03 nmodules fixed bin,
 105       03 per_module (50),
 106         04 name char (6),
 107         04 start fixed bin,
 108         04 date char (6),
 109         04 sti char (12);
 110 dcl  generic_name char (32) varying;
 111 dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
 112 dcl  i fixed bin;
 113 dcl  ioa_ entry () options (variable);
 114 dcl  long_flag init ("0"b) bit (1);
 115 dcl  match_flag init ("0"b) bit (1);
 116 dcl  name_flag init ("0"b) bit (1);
 117 dcl  nargs fixed bin;
 118 dcl  parse_pnotice_info_ entry (ptr, fixed bin (35));
 119 dcl  pathname_ entry (char(*), char(*)) returns(char(168));
 120 dcl  phcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35));
 121 dcl  phcs_$tty_control entry (char (*), char (*), ptr, fixed bin (35));
 122 dcl  print_prod fixed bin;
 123 dcl  prog_name char (12) varying;
 124 dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
 125 dcl  ret char (retl) varying based (retp);
 126 dcl  retl fixed bin(21);
 127 dcl  retp pointer;
 128 dcl  ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35));
 129 dcl  ring_zero_peek_ entry (ptr, ptr, fixed bin (17), fixed bin (35));
 130 dcl  true init ("1"b) bit (1) internal static options (constant);
 131 dcl  warn char (80) varying;
 132 dcl  xlate (0: 63) char (1) int static options (constant) init (
 133 
 134      "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "[", "#", "@", ":", ">", "?",
 135 
 136      " ", "A", "B", "C", "D", "E", "F", "G", "H", "I", "&", ".", "]", "(", "<", "^",
 137 
 138      "|", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "-", "$", "*", ")", ";", "'",
 139 
 140      "+", "/", "S", "T", "U", "V", "W", "X", "Y", "Z", "_", ",", "%", "=", """", "!");
 141 
 142 dcl (addr, baseno, before, bin, convert, divide, hbound, index, length,
 143      ltrim, min, null, size, substr, rank, rtrim, translate) builtin;
 144 
 145 
 146 dcl (linkage_error, cleanup) condition;
 147 
 148 
 149 /* ***********  S T A R T************* */
 150 
 151           Sptr = null;                                      /* prime pointers incase of error   */
 152           datanet_infop = null;
 153           dn355_datap = null;
 154           prog_name = "display_psp";
 155           on cleanup call janitor;
 156 
 157           call command_args ();
 158           call open_files ();
 159           call get_info ();
 160           call out_info ();
 161           goto fini;                    /* exit                              */
 162 
 163 /* ^L\014 */
 164 describe_psp: entry;
 165 
 166 
 167           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 168           /*                                                       */
 169           /* this entry, describe_psp Marketing_Identifier Key     */
 170           /* operates as an active function so site and developers */
 171           /* can write tools based on a psp. Information will be   */
 172           /* returned based on a key passed in as an argument.     */
 173           /*                                                       */
 174           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 175 
 176           dcl  message_out char (80) varying;
 177           prog_name = "describe_psp";
 178           call cu_$af_return_arg (nargs, retp, retl, code);
 179                                         /* check to see if invoked as an active function*/
 180           if code = 0 then af_flag = true;
 181           else call cu_$arg_count (nargs);   /* its a command                */
 182 
 183 
 184           if nargs ^= 2 then do;        /* 1st is a marketing identifier and 2nd is a key*/
 185                code = error_table_$wrong_no_of_args;
 186                warn = "Usage: describe_psp Marketing_Identifier Key.";
 187                goto bummer;
 188           end;
 189 
 190           call open_files ();           /* get space to work in              */
 191           call get_info ();             /* read the >t>psp_info_ file        */
 192 
 193                                         /* get 1st argument                  */
 194           if af_flag then call cu_$af_arg_ptr (1, argp, argl, code);
 195           else call cu_$arg_ptr (1, argp, argl, code);
 196           if code ^= 0 then do;
 197                code = error_table_$wrong_no_of_args;
 198                warn = "Error in parsing the first argument.";
 199                goto bummer;
 200           end;
 201           arg = translate(arg, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz");
 202                                         /* upper, lower case don't matter    */
 203 
 204           do i = 1 to product.prod_number while (arg ^= product.num(i).MI);
 205           end;
 206           if i > product.prod_number then do;
 207                warn = "Illegal or unknown marketing identifier used: "||arg||".";
 208                code = error_table_$bad_arg;
 209                goto bummer;
 210           end;
 211 
 212                                         /* get 2nd argument                  */
 213           if af_flag then call cu_$af_arg_ptr (2, argp, argl, code);
 214           else call cu_$arg_ptr (2, argp, argl, code);
 215           if code ^= 0 then do;
 216                code = error_table_$noarg;
 217                warn = "Error in parsing the second argument.";
 218                goto bummer;
 219           end;
 220 
 221 
 222           if arg = "title" then  message_out = product.num(i).prod_title;
 223           else if arg = "name" then  message_out = product.num(i).prod_name;
 224           else if arg = "sti" then  message_out = product.num(i).prod_STI;
 225           else if arg = "source" then message_out = rtrim(product.num(i).source_path.dirname)||">"||product.num(i).source_path.entryname;
 226           else if arg = "object" then message_out = rtrim(product.num(i).object_path.dirname)||">"||product.num(i).object_path.entryname;
 227           else if arg = "executable" then message_out = rtrim(product.num(i).x_path.dirname)||">"||product.num(i).x_path.entryname;
 228           else do;
 229                warn = "Illegal or unknown key used: "||arg||".";
 230                code = error_table_$bad_arg;
 231                goto bummer;
 232           end;
 233 
 234           if ^af_flag then call ioa_ ("^a", message_out);
 235           else ret = message_out;
 236           goto fini;
 237 
 238 
 239 /* ^L\014 */
 240 command_args: proc ();
 241 
 242 
 243 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 244 /*                                                       */
 245 /* This procedure will define the arguments used for     */
 246 /* the command to process. Some checking is done on      */
 247 /* arguments passed in as to valid characters            */
 248 /*                                                       */
 249 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 250 
 251 
 252 
 253                call cu_$arg_count (nargs);
 254 
 255                if nargs = 0 then do;                        /* no args is ok use defaults        */
 256                     all_flag = true;
 257                     brief_flag = true;
 258                     return;
 259                end;
 260 
 261 
 262                do argno = 1 to nargs;
 263 
 264 
 265                     call cu_$arg_ptr (argno, argp, argl, code);
 266                     if code ^= 0 then goto bad_arg;
 267 
 268                     if substr (arg, 1, 1) = "-" then do;
 269 
 270                          if arg = "-name" | arg = "-nm" then do;
 271                               if name_flag then goto dup_arg;
 272                               name_flag = true;
 273                               argno = argno + 1;
 274                               call cu_$arg_ptr (argno, argp, argl, code);
 275                               if code ^= 0 then goto bad_arg;
 276                               if substr (arg, 1, 1) = "-" then goto bad_arg;
 277                               generic_name = arg;           /* i.e. compose, ted       */
 278                          end;
 279 
 280                          else if arg = "-match" then do;
 281                               if match_flag then go to dup_arg;
 282                               match_flag = true;
 283                               argno = argno + 1;
 284                               call cu_$arg_ptr (argno, argp, argl, code);
 285                               if code ^= 0 then goto bad_arg;
 286                               if substr (arg, 1, 1) = "-" then goto bad_arg;
 287                               if argl ^= 7 then do;
 288                                    warn = "Using incorrect number of characters for Marketing Identifier "||arg||".";
 289                                    goto bummer;
 290                               end;
 291                               MI_name = arg;
 292                          end;
 293 
 294                          else if arg = "-brief" | arg = "-bf" then do;
 295                               if brief_flag then goto dup_arg;
 296                               brief_flag = true;
 297                          end;
 298 
 299                          else if arg = "-long" | arg = "-lg" then do;
 300                               if long_flag then goto dup_arg;
 301                               long_flag = true;
 302                          end;
 303 
 304                          else if arg = "-copyright" then do;
 305                               if copyw_flag then go to dup_arg;
 306                               copyw_flag = true;
 307                          end;
 308 
 309                          else if arg = "-all" | arg = "-a" then do;
 310                               if all_flag then goto dup_arg;
 311                               all_flag = true;
 312                          end;
 313                          else goto bad_arg;
 314                     end;
 315                     else goto bad_arg;
 316                end;
 317                if brief_flag & long_flag then do;
 318                     code = error_table_$inconsistent;
 319                     warn = "-brief and -long cannot be used together.";
 320                     goto bummer;
 321                end;
 322 
 323                if match_flag & all_flag then do;
 324                     code = error_table_$inconsistent;
 325                     warn = "-match and -all cannot be used together.";
 326                     goto bummer;
 327                end;
 328 
 329                if name_flag & all_flag then do;
 330                     code = error_table_$inconsistent;
 331                     warn = "-name and -all cannot be used together.";
 332                     goto bummer;
 333                end;
 334 
 335                if match_flag & name_flag then do;
 336                     code = error_table_$inconsistent;
 337                     warn = "-match and -name cannot be used together.";
 338                     goto bummer;
 339                end;
 340 
 341 
 342                return;
 343           end command_args;
 344                                                             /* ^L\014 */
 345 open_files: proc;
 346 
 347 
 348 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 349 /*                                                       */
 350 /* This procedure gets the working storage needed for    */
 351 /* the command to operate                                */
 352 /*                                                       */
 353 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 354 
 355 
 356 
 357                call get_temp_segment_ ((prog_name), Sptr, code);
 358                if code ^= 0 then do;
 359                     warn = " Error while getting temporary segment for Sptr.";
 360                     goto bummer;
 361                end;
 362 
 363                SI_ptr = Sptr;                               /* let the product structure point to the temp.seg */
 364 
 365                call get_temp_segment_ ((prog_name), datanet_infop, code);
 366                if code ^= 0 then do;
 367                     warn = " Error while getting temporary segment.";
 368                     goto bummer;
 369                end;
 370                return;
 371           end open_files;
 372                                                             /* ^L\014 */
 373 get_info: proc;
 374 
 375 
 376 
 377 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 378 /*                                                       */
 379 /* This procedure calls a rdc program that will read    */
 380 /* the psp_info_ segment and return information          */
 381 /* contained in the ascii segment for use by the         */
 382 /* program, see software_pnotice_info_.incl.pl1 as to    */
 383 /* the structure passed.                                 */
 384 /*                                                       */
 385 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 386 
 387 
 388                call parse_pnotice_info_ (SI_ptr, code);
 389                if code ^= 0 then do;
 390                     warn = "Error while reading psp_info_ file.";
 391                     goto bummer;
 392                end;
 393 
 394                return;
 395           end get_info;
 396 
 397 /* ^L\014 */
 398 find_lib_info:
 399           proc (dirname, entryname, prod_name);
 400 
 401 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 402 /*                                                       */
 403 /* This procedure will probe into the library segments   */
 404 /* and return information contained in them as to the    */
 405 /* STI and protection notice.                            */
 406 /*                                                       */
 407 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 408 
 409 
 410 
 411 
 412 dcl  P_ark_ptr ptr;
 413 dcl  P_ark_bc fixed bin (24);
 414 dcl  P_comp_seg char (P_comp_length) based (P_comp_ptr);
 415 dcl  P_comp_length fixed bin;
 416 dcl  P_comp_ptr ptr;
 417 dcl  P_comp_bc fixed bin (24);
 418 dcl  Tpointer fixed bin;
 419 dcl  archive_$get_component entry (ptr, fixed bin (24), char (*), ptr,
 420      fixed bin (24), fixed bin (35));
 421 dcl  cl fixed bin;
 422 dcl  dirname char (168);
 423 dcl  entryname char (32);
 424 dcl  get_fnp_name_ entry (fixed bin) returns (char (32));
 425 dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24),
 426      fixed bin (2), ptr, fixed bin (35));
 427 dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
 428 dcl  i fixed bin;
 429 dcl  num_of_pnotice fixed bin;
 430 dcl  prod_name char (24);
 431 dcl  whitesp char (4) int static options (constant) init ("
 432 
 433 ");
 434 dcl  xx fixed bin;
 435 
 436                if length (ltrim (rtrim (entryname))) > 7 then do;
 437                                                             /* do only if not an FNP module name */
 438                     call hcs_$initiate_count (dirname, entryname, "", P_ark_bc, 1, P_ark_ptr, code);
 439                     if code ^= 0 then do;
 440                          if code ^= error_table_$segknown then do;
 441                                                             /* ok if we already know             */
 442                               call hcs_$terminate_noname (P_ark_ptr, Ccode);
 443                               return;                       /* let the caller know it don't exist */
 444                          end;
 445                          code = 0;                          /* seg known is ok                   */
 446                     end;
 447                end;
 448 
 449 
 450                if index (entryname, ".s.archive") ^= 0 then do;
 451                                                             /* this is the routine to get the source info */
 452 
 453                     call archive_$get_component
 454                          (P_ark_ptr, P_ark_bc, "PNOTICE_"||rtrim (prod_name)||".alm", P_comp_ptr, P_comp_bc, code);
 455                                                             /* get a pointer to the notice component */
 456                     if code ^= 0 then return;
 457 
 458                     Pnotice.source_C = "";   /* init the copyright           */
 459 
 460                     P_comp_length = divide (P_comp_bc, 9, 17, 0);
 461                                                             /* get the length to the pnotice seg */
 462 
 463 
 464                     Tpointer = index (P_comp_seg, "dec");
 465                                                             /* points to the version line        */
 466 
 467                     Tpointer = Tpointer + 3 + index ((substr (P_comp_seg, (Tpointer + 3))), "dec");
 468                                                             /* points to the no. of pnotices     */
 469                     num_of_pnotice = convert (num_of_pnotice, (ltrim (rtrim (before ((
 470                          substr (P_comp_seg, (Tpointer + 3))), QUOTE), whitesp), whitesp)));
 471                                                             /* save it away for later            */
 472 
 473 
 474 
 475 /* next comes the words in the copyright */
 476                     do i = 1 to num_of_pnotice;
 477                          Tpointer = Tpointer + 3 + index ((substr (P_comp_seg, Tpointer)), "acc");
 478                          Tpointer = Tpointer + index ((substr (P_comp_seg, Tpointer)), QUOTE);
 479                                                             /* Tpointer points to the start of the notice */
 480                          Pnotice.source_C = rtrim (Pnotice.source_C) || substr
 481                               (P_comp_seg, Tpointer, (index ((substr (P_comp_seg, Tpointer)), QUOTE) - 1))
 482                               || NL;
 483                                                             /* stuff the words away for printing */
 484                          Tpointer = Tpointer + index ((substr (P_comp_seg, Tpointer)), QUOTE);
 485                                                             /* move pointer to end of copyright  */
 486 
 487 
 488                     end;
 489 
 490 /* this is the source STI            */
 491                     Tpointer = Tpointer + 3 + index ((substr (P_comp_seg, (Tpointer + 3))), "aci");
 492                                                             /* now suck off the STI              */
 493                     source_STI = substr ((ltrim (substr (P_comp_seg, (Tpointer + 3)), whitesp)), 2, 12);
 494                                                             /* always 12 chars                   */
 495                end;
 496 
 497 
 498                else if index (entryname, ".archive") ^= 0 then do;
 499                                                             /* this is the routine to get the object info */
 500 
 501                     call archive_$get_component
 502                          (P_ark_ptr, P_ark_bc, "PNOTICE_"||rtrim (prod_name), P_comp_ptr, P_comp_bc, code);
 503                                                             /* get a pointer to the notice component */
 504                     if code ^= 0 then return;
 505 
 506                     Pnotice.object_C = ""; /* init the area        */
 507 
 508 
 509                     P_pnotice_sti = P_comp_ptr;
 510                                                             /* make the PNOTICE_ segment look like the include file */
 511 
 512                     Pnotice.object_STI = pnotice_sti.STI (2);
 513 
 514                     Tpointer = 1;
 515 
 516                     do i = 1 to pnotice_sti.Npnotice;
 517 
 518                          cl = rank (substr (pnotice_sti.pnotice, Tpointer, 1));
 519                          Pnotice.object_C =
 520                               rtrim (Pnotice.object_C) || substr (pnotice_sti.pnotice, (Tpointer + 1), cl) || NL;
 521                          Tpointer = Tpointer + 1 + cl;
 522                     end;
 523                end;
 524 
 525                else do;                                     /* do executable segments then       */
 526                                                             /* this is an executable segment     */
 527 
 528                     if index (entryname, "bound_") ^= 0 then do;
 529 
 530 
 531                          P_pnotice_sti = P_ark_ptr;
 532                                                             /* make the PNOTICE_ segment look like the include file */
 533                          Tpointer = 1;
 534                          if pnotice_sti.Vpnotice_sti_1 ^= 1 then do;
 535                                                             /* validate that segment has a copyright that can be probed */
 536                               code = error_table_$improper_data_format;
 537                               return;
 538                          end;
 539                          if pnotice_sti.Nsti ^= 3 then do;
 540                                                             /* if not 3 better get out           */
 541                               code = error_table_$improper_data_format;
 542                               return;
 543                          end;
 544 
 545                          Pnotice.xecute_C = "";   /* initialize the field    */
 546 
 547                          do i = 1 to pnotice_sti.Npnotice;
 548                               cl = rank (substr (pnotice_sti.pnotice, Tpointer, 1));
 549                               Pnotice.xecute_C =
 550                                    rtrim (Pnotice.xecute_C) || substr (pnotice_sti.pnotice, (Tpointer + 1), cl) || NL;
 551                               Tpointer = Tpointer + 1 + cl;
 552                          end;
 553 
 554                          Pnotice.xecute_STI = pnotice_sti.STI (3);
 555                     end;
 556 
 557 
 558 /* this is a FNP module then         */
 559 
 560                     else if length (ltrim (rtrim (entryname))) <= 6 then do;
 561 
 562                                                             /* need access to the phcs_          */
 563                          call ring0_get_$segptr ("", "dseg", dsegp, code);
 564                          if code ^= 0 then do;
 565                               warn = "Error getting pointer to dseg.";
 566                               goto bummer;
 567                          end;
 568 
 569                          call get_sdw ("dn355_data", dn355_datap, addr (ddata_sdw));
 570                          if no_acc_sw =  true then return;
 571 
 572 
 573                          sdwp = addr (ddata_sdw);
 574                          dn355_data_len = (bin (sdw.bound, 14) + 1) * 16;
 575 
 576 
 577                          infop = datanet_infop;
 578                          call ring_zero_peek_ (dn355_datap, infop, dn355_data_len, code);
 579                          if code ^= 0 then do;
 580                               warn = "Error getting information from dn355_data (ring 0).";
 581                               goto bummer;
 582                          end;
 583 
 584 
 585                          do fnp = 1 to max_no_355s;         /* need to see how many FNPs */
 586                               fnpp = addr (datanet_info.per_datanet (fnp));
 587                               if fnp_info.running then do;
 588                                    fnp_name = rtrim(get_fnp_name_ (fnp));
 589 
 590                                    call setup_module_table (code);
 591                                    if code ^= 0 then do;
 592                                         if code = error_table_$moderr then no_acc_sw = true;
 593                                         return;
 594                                    end;
 595 
 596                                    do xx = 1 to fnptab.per_fnp (fnp).nmodules
 597                                         while (entryname ^= fnptab.per_fnp (fnp).per_module (xx).name);
 598                                    end;
 599                                                             /* find the module we need;          */
 600                                    if xx <= fnptab.per_fnp (fnp).nmodules then
 601 
 602                                         call ioa_ ("FNP ^a: Module ^a STI ^a", fnp_name,
 603                                         fnptab.per_fnp (fnp).per_module (xx).name,
 604                                         fnptab.per_fnp (fnp).per_module (xx).sti);
 605                               end;
 606                          end;
 607                          code = -1;                         /* avoid the print_it proc from printing */
 608 
 609                     end;
 610                end;
 611 
 612 
 613                return;
 614           end find_lib_info;
 615 
 616                                                             /* ^L\014 */
 617 
 618 /* Procedure to setup internal static fnp table */
 619 
 620 setup_module_table: proc (code);
 621 
 622 dcl (i, j) fixed bin;
 623 dcl  chainloc fixed bin;
 624 dcl  mod_name char (8);
 625 dcl  mod_sti char (12);
 626 dcl 01 chain aligned,                                       /* Entry in module chain */
 627     02 next bit (18) unal,
 628     02 name (6) bit (6) unal,
 629     02 start bit (18) unal,
 630     02 date (6) bit (6) unal,
 631     02 sti (12) bit (6) unal;
 632 dcl  code fixed bin (35);
 633 
 634                if fnptab.modtab_init (fnp) then return;     /* Table all setup */
 635 
 636 /* need to get start of module chain */
 637                symbol_tablep = addr (db_fnp_symbols_$db_fnp_symbols_);
 638 
 639                do i = 1 to symbol_table.cnt;
 640                     symp = addr (symbol_table.entry (i));
 641                     if ".crmod" = sym.name then do;
 642                          crmod = sym.value;                 /* got the starting point            */
 643                     end;
 644                end;
 645 
 646 
 647                call fnp_fetch (crmod, 1, addr (chain.next), code);
 648                                                             /* Get module chain start */
 649                if code ^= 0 then do;
 650                     if code = error_table_$moderr then
 651                          call ioa_ ("No access to phcs_ gate; unable to read FNP memory.");
 652                     return;
 653                end;
 654 
 655                chainloc = bin (chain.next);                 /* First chain is here */
 656 
 657 
 658                i = 0;
 659 
 660                do while ((chainloc ^= 0) & (i < hbound (fnptab.per_module, 2)));
 661                     call fnp_fetch (chainloc, 10, addr (chain), code);
 662 
 663                     i = i+1;
 664                     fnptab.start (fnp, i) = bin (chain.start);
 665 
 666                     mod_name = "";
 667                     do j = 1 to 6;                          /* Convert name */
 668                          substr (mod_name, j, 1) = xlate (bin (chain.name (j)));
 669                     end;
 670                     fnptab.name (fnp, i) = translate (rtrim(mod_name), "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
 671 
 672                     do j = 1 to 6;                          /* Convert date */
 673                          substr (fnptab.date (fnp, i), j, 1) = xlate (bin (chain.date (j)));
 674                     end;
 675                     chainloc = bin (chain.next);            /* Next pointer */
 676 
 677                     mod_sti = "";
 678                     do j = 1 to 12;                         /* Convert name */
 679                          substr (mod_sti, j, 1) = xlate (bin (chain.sti (j)));
 680                     end;
 681                     fnptab.sti (fnp, i) = mod_sti;
 682                end;
 683 
 684 
 685                fnptab.nmodules (fnp) = i;
 686                fnptab.modtab_init (fnp) = "1"b;
 687                return;
 688 
 689 
 690           end setup_module_table;
 691 
 692 /* ^L\014 */
 693 
 694 fnp_fetch: proc (fnp_addr, arg_fnp_len, arg_data_ptr, code);
 695 
 696 dcl  fnp_mem (fnp_len) bit (18) unal based;
 697 dcl  fnp_addr fixed bin (17);
 698 dcl  arg_fnp_len fixed bin (17);
 699 dcl  arg_data_ptr ptr;
 700 dcl  fnp_len fixed bin;
 701 dcl  call_type fixed bin;
 702 dcl  code fixed bin (35);
 703 dcl  state fixed bin;
 704 
 705                fnp_len = arg_fnp_len;
 706                call_type = 0;
 707                fnp_infos.fnp_len = arg_fnp_len;
 708                fnp_infos.data_ptr = arg_data_ptr;
 709                fnp_infos.fnp_addr = fnp_addr;
 710                fnp_infos.prev_data_ptr = null;
 711 
 712                do while (fnp_len > 0);
 713                     fnp_infos.fnp_len = min (fnp_len, 64);
 714                     if call_type = 0 then do;
 715                          on linkage_error go to call_1_failed;
 716                          call phcs_$tty_order (fnp, "dump_fnp", addr (fnp_infos), state, code);
 717                          revert linkage_error;              /* It worked */
 718                          call_type = 1;
 719                          go to check_fetch_code;
 720 call_1_failed:           on linkage_error go to call_2_failed;
 721                          call phcs_$tty_control (fnp_name, "dump_fnp", addr (fnp_infos), code);
 722                          revert linkage_error;
 723                          call_type = 2;
 724                          go to check_fetch_code;
 725 call_2_failed:           revert linkage_error;
 726                          code = error_table_$moderr;
 727                          return;
 728                     end;
 729                     else if call_type = 1 then call phcs_$tty_order (fnp, "dump_fnp", addr (fnp_infos), state, code);
 730                     else call phcs_$tty_control (fnp_name, "dump_fnp", addr (fnp_infos), code);
 731 
 732 check_fetch_code:
 733                     if code = error_table_$undefined_order_request then do;
 734                          code = 0;                          /* dump_fnp order was not defined for the FNP in question */
 735                          return;                            /* don't worry about it.  Nothing will get printed */
 736                     end;
 737                     if code ^= 0 then return;
 738 
 739                     fnp_infos.fnp_addr = fnp_infos.fnp_addr + fnp_infos.fnp_len;
 740                                                             /* Check next address */
 741                     fnp_infos.data_ptr = addr (fnp_infos.data_ptr -> fnp_mem (fnp_infos.fnp_len + 1));
 742                     fnp_len = fnp_len - fnp_infos.fnp_len;
 743                end;
 744 
 745           end fnp_fetch;
 746 
 747 
 748 /* ^L\014 */
 749 get_sdw:
 750           proc (seg_name, ring_zero_ptr, sdw_ptr);
 751 
 752 dcl  seg_name char (*);
 753 dcl  ring_zero_ptr ptr;
 754 dcl  sdw_ptr ptr;
 755 
 756 
 757                call ring0_get_$segptr ("", seg_name, ring_zero_ptr, code);
 758                                                             /* get pointer to ring 0 seg */
 759                if code ^= 0 then do;
 760                     warn = "Error trying to read sdw for dn355_data.";
 761                     no_acc_sw = true;
 762                     return;
 763                end;
 764                call ring_zero_peek_ (addr (dsegp -> sdwa (bin (baseno (ring_zero_ptr), 18))), sdw_ptr, size (sdw), code);
 765                if code ^= 0 then do;
 766                     warn = "Error trying to read sdw for dn355_data.";
 767                     no_acc_sw = true;
 768                     return;
 769                end;
 770                return;
 771           end get_sdw;
 772 
 773 
 774                                                             /* ^L\014 */
 775 out_info: proc;
 776 
 777 
 778 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 779 /*                                                       */
 780 /* This procedure will select the information for        */
 781 /* output to the user. The arguments -all, -match and    */
 782 /* -name will be acted on and the information will be    */
 783 /* passed to print_it for final formatting by the other  */
 784 /* arguments that can be used.                           */
 785 /*                                                       */
 786 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 787 dcl (ii, j) fixed bin;
 788 
 789 
 790                if ^long_flag then brief_flag = true;        /* need one but not both   */
 791 
 792                if match_flag then do;                       /* only want one product             */
 793                     do i = 1 to product.prod_number while (MI_name ^= product.num (i).MI);
 794                     end;
 795                     print_prod = i;
 796 
 797 
 798                     if i > product.prod_number then do;     /* oops!         */
 799                          warn = "Illegal or unknown marketing identifier used "|| MI_name||".";
 800                          code = error_table_$bad_arg;
 801                          goto bummer;
 802                     end;
 803 
 804 /* this product is made up of other products, so use them instead */
 805 
 806                     if product.num (i).prod_use (1) ^= "" then do;
 807                          do j = 1 to 10 while (product.num (i).prod_use (j) ^= "");
 808 
 809                               do ii = 1 to product.prod_number while (product.num (i).prod_use (j) ^= product.num (ii).MI);
 810                               end;
 811 
 812                               if ii > product.prod_number then do; /* oops!            */
 813                                    warn = "Illegal or unknown marketing identifier from psp_info_ used "|| MI_name||".";
 814                                    code = error_table_$bad_arg;
 815                                    goto bummer;
 816                               end;
 817                               print_prod = ii;
 818                               call print_it;
 819                          end;
 820                     end;
 821 
 822                     else                                    /* the product is defined use it     */
 823                     call print_it;
 824                end;
 825 
 826                else if name_flag then do;                   /* only want one product             */
 827 
 828                     do i = 1 to product.prod_number while (generic_name ^= product.num (i).prod_name);
 829                     end;
 830 
 831                     if i > product.prod_number then do;     /* oops!         */
 832                          warn = "Illegal or unknown name used "|| generic_name||".";
 833                          code = error_table_$bad_arg;
 834                          goto bummer;
 835                     end;
 836 
 837                     print_prod = i;
 838 
 839 /* this product is made up of other products, so use them instead */
 840 
 841                     if product.num (i).prod_use (1) ^= "" then do;
 842                                                             /* if many products make up this product */
 843                          do j = 1 to 10 while (product.num (i).prod_use (j) ^= "");
 844 
 845                               do ii = 1 to product.prod_number while (product.num (i).prod_use (j) ^= product.num (ii).MI);
 846                               end;                          /* check if real product in psp_info_ */
 847 
 848 
 849                               if ii > product.prod_number then do; /* oops!            */
 850                                    warn = "Illegal or unknown marketing identifier from psp_info_ used "|| MI_name||".";
 851                                    code = error_table_$bad_arg;
 852                                    goto bummer;
 853                               end;
 854                               print_prod = ii;
 855                               call print_it;
 856                          end;
 857                     end;
 858 
 859                     else                                    /* use this product no other         */
 860                     call print_it;
 861                end;
 862 
 863                else                                         /* all is the default                */
 864 
 865                do i = 1 to product.prod_number;
 866 
 867 
 868                     print_prod = i;                         /* bump the count of the product     */
 869 
 870 
 871 /* just be sure this is a real product, not made up of other products */
 872                     if product.num (i).prod_use (1) = "" then call print_it;
 873 
 874                end;
 875 
 876                return;
 877 
 878           end out_info;
 879                                                             /* ^L\014 */
 880 
 881 print_it: proc;
 882 
 883 
 884 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 885 /*                                                       */
 886 /* This procedure will output the information in a       */
 887 /* format asked for by the user. The options are -long,  */
 888 /* -brief or -copyright.                                 */
 889 /*                                                       */
 890 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 891 
 892 
 893 
 894                if long_flag then do;                        /* print all info                    */
 895 
 896 
 897                     call ioa_ ("^/^a.", rtrim (product.num (print_prod).prod_title));
 898                     call ioa_ ("Marketing identifier           ^a.", product.num (print_prod).MI);
 899 
 900                     call validate_macro                     /* now get source info               */
 901                          ((product.num (print_prod).source_path.dirname),
 902                          (product.num (print_prod).source_path.entryname),
 903                          (product.num (print_prod).prod_name));
 904 
 905                     if code = 0 then do;
 906                          call ioa_ ("STI                            ^a.", Pnotice.source_STI);
 907                          call ioa_ ("Protection notice from         ^a. ^/^a",
 908                               product.num (print_prod).source_path.entryname,
 909                               ltrim (rtrim (rtrim (Pnotice.source_C), QUOTE), QUOTE));
 910                     end;
 911 
 912 /* output object info long format    */
 913 
 914                     call validate_macro                     /* now get object info               */
 915                          ((product.num (print_prod).object_path.dirname),
 916                          (product.num (print_prod).object_path.entryname),
 917                          (product.num (print_prod).prod_name));
 918 
 919                     if code = 0 then do;                    /* can't complain if not found       */
 920 
 921                          call ioa_ ("STI                            ^a.", Pnotice.object_STI);
 922                          call ioa_ ("Protection Notice from         ^a ^/^a",
 923                               product.num (print_prod).object_path.entryname, Pnotice.object_C);
 924                     end;
 925 
 926 
 927                     call validate_macro                     /* now get executable info           */
 928                          ((product.num (print_prod).x_path.dirname),
 929                          (product.num (print_prod).x_path.entryname),
 930                          (product.num (print_prod).prod_name));
 931 
 932                     if code = 0 then do;
 933                          call ioa_ ("STI                            ^a.", Pnotice.xecute_STI);
 934                          call ioa_ ("Protection Notice from         ^a ^/^a",
 935                               product.num (print_prod).x_path.entryname, Pnotice.xecute_C);
 936 
 937                     end;
 938                end;
 939 
 940                else if copyw_flag then do;                  /* print the copyright     */
 941 
 942                     call validate_macro
 943                          ((product.num (print_prod).source_path.dirname),
 944                          (product.num (print_prod).source_path.entryname),
 945                          (product.num (print_prod).prod_name));
 946 
 947                     if code = 0 then do;
 948 
 949                          call ioa_ ("Protection notice from            ^a ^/^a",
 950                               product.num (print_prod).source_path.entryname, rtrim (Pnotice.source_C));
 951                     end;
 952 
 953 
 954                     call validate_macro                     /* now do the object info            */
 955                          ((product.num (print_prod).object_path.dirname),
 956                          (product.num (print_prod).object_path.entryname),
 957                          (product.num (print_prod).prod_name));
 958                     if code = 0 then do;
 959 
 960                          call ioa_ ("Protection notice from            ^a ^/^a",
 961                               product.num (print_prod).object_path.entryname, rtrim (Pnotice.object_C));
 962                     end;
 963 
 964                     call validate_macro                     /* now do the executable info        */
 965                          ((product.num (print_prod).x_path.dirname),
 966                          (product.num (print_prod).x_path.entryname),
 967                          (product.num (print_prod).prod_name));
 968                     if code = 0 then do;
 969 
 970                          call ioa_ ("Protection notice from            ^a ^/^a",
 971                               product.num (print_prod).x_path.entryname, rtrim (Pnotice.xecute_C));
 972 
 973                     end;
 974                end;
 975 
 976                else if brief_flag then do;                  /* print only the STI                */
 977                     call ioa_ ("^/^a.", rtrim (product.num (print_prod).prod_title));
 978                     call validate_macro
 979                          ((product.num (print_prod).source_path.dirname),
 980                          (product.num (print_prod).source_path.entryname),
 981                          (product.num (print_prod).prod_name));
 982 
 983                     if code = 0 then
 984                          call ioa_ ("^a", Pnotice.source_STI);
 985 
 986 
 987 
 988 /* now do for the object             */
 989                     call validate_macro
 990                          ((product.num (print_prod).object_path.dirname),
 991                          (product.num (print_prod).object_path.entryname),
 992                          (product.num (print_prod).prod_name));
 993 
 994                     if code = 0 then call ioa_ ("^a", Pnotice.object_STI);
 995 
 996 
 997 /* now do for the executable segment */
 998                     call validate_macro
 999                          ((product.num (print_prod).x_path.dirname),
1000                          (product.num (print_prod).x_path.entryname),
1001                          (product.num (print_prod).prod_name));
1002 
1003                     if code = 0 then call ioa_ ("^a", Pnotice.xecute_STI);
1004 
1005                end;
1006 
1007                return;
1008           end print_it;
1009                                                             /* ^L \014 */
1010 
1011 validate_macro:
1012           procedure (dirname, entryname, prod_name);
1013 
1014 dcl  dirname char (168);
1015 dcl  entryname char (32);
1016 dcl  prod_name char (24);
1017 
1018                if dirname = "" & entryname = "" then do;
1019                     code = -1;
1020                     return;
1021                end;
1022 
1023                call find_lib_info (dirname, entryname, prod_name);
1024 
1025 
1026                if code ^= 0 then do;
1027 
1028                     if code = error_table_$noentry then do;
1029                          call com_err_ (code, prog_name, "^/^a not found.",
1030                             pathname_ (dirname, entryname));
1031                          code = -1;
1032                          return;
1033                     end;
1034 
1035                     if code = error_table_$improper_data_format then do;
1036                          call com_err_ (code, prog_name,
1037                               "^/Could not get pnotice information from ^a.",
1038                               pathname_ (dirname, entryname));
1039                          code = -1;
1040                          return;
1041                     end;
1042 
1043                     if code = error_table_$no_info then do;
1044                               call com_err_ (code, prog_name, "^/You do not have access to read information from the datanet.");
1045                               code = -1;
1046                               return;
1047                     end;
1048 
1049                     if code = error_table_$no_dir then do;
1050                          call com_err_ (code, prog_name, "^/The path ^a not found installed.", dirname);
1051                          code = -1;
1052                          return;
1053                     end;
1054 
1055                     else if code = error_table_$moderr then do;
1056                          call com_err_ (code, prog_name, "^/The entry ^a", entryname);
1057                          code = -1;
1058                          return;
1059                     end;
1060                     else if code = error_table_$incorrect_access then do;
1061                          call com_err_ (code, prog_name, "^/The entry ^a", entryname);
1062                          code = -1;
1063                          return;
1064                     end;
1065 
1066                     else if code = error_table_$no_component then do;
1067                          call com_err_ (code, prog_name, "^/archive ^a",
1068                             pathname_ (dirname, entryname));
1069                          code = -1;
1070                          return;
1071                     end;
1072 
1073                     else if code = -1 then return;          /* this is an fnp module   */
1074 
1075                     warn = "Error while finding library information for "
1076                          ||rtrim (product.num (print_prod).object_path.entryname)||".";
1077 
1078                     goto bummer;
1079 
1080                end;
1081           end validate_macro;
1082 
1083 
1084 /* ^L\014 */
1085 janitor:  proc;
1086 
1087 dcl  Ccode fixed bin (35);
1088 
1089 
1090                if Sptr ^= null then
1091                     call release_temp_segment_ ((prog_name), Sptr, Ccode);
1092                                                             /* release temp segment used for product structure */
1093 
1094                if datanet_infop ^= null then
1095                     call release_temp_segment_ ((prog_name), datanet_infop, Ccode);
1096                                                             /* release temp segment used for FNP info                */
1097 
1098 
1099           end janitor;
1100 
1101 bad_arg:
1102 
1103           code = error_table_$bad_arg;
1104           warn = arg;
1105           goto bummer;
1106 
1107 
1108 dup_arg:
1109           code = error_table_$inconsistent;
1110           warn = arg || " appears twice on the command line.";
1111           goto bummer;
1112 
1113 
1114 bummer:
1115           if af_flag then call active_fnc_err_ (code, prog_name, "^/^a", warn);
1116           else call com_err_ (code, prog_name, "^/^a", warn);
1117           call janitor;
1118           return;
1119 
1120 fini:
1121           call janitor;
1122           return;
1123 
1124 %include software_pnotice_info_;
1125 %include pnotice;
1126 %include dn355_data;
1127 %include sdw;
1128 %include debug_fnp_data;
1129 
1130      end display_psp;