1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) BULL HN Information Systems Inc., 1990   *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   6         *                                                         *
   7         * Copyright (c) 1972 by Massachusetts Institute of        *
   8         * Technology and Honeywell Information Systems, Inc.      *
   9         *                                                         *
  10         *********************************************************** */
  11 
  12 
  13 
  14 /****^  HISTORY COMMENTS:
  15   1) change(90-04-30,Leskiw), approve(90-10-05,MCR8202),
  16      audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039):
  17      Changed calls to assign_round_ from assign_ so that data is rounded.
  18                                                    END HISTORY COMMENTS */
  19 
  20 
  21 linus_print:
  22      proc (sci_ptr, lcb_ptr);
  23 
  24 
  25 
  26 /* HISTORY:
  27 
  28    77-05-01 J. C. C. Jagernauth: Initially written.
  29 
  30    79-12-19 Rickie E.  Brinegar: Modified to output no data found message over
  31    user_output instead of over error_output.
  32 
  33    80-01-03  Rickie E.  Brinegar: Modified to truncate blanks off of the right
  34    hand end of the output line.
  35 
  36    80-01-10  Rickie  E.   Brinegar: Modified to use mdbm_util_$(binary complex
  37    fixed number string)_data_class entry points.
  38 
  39    80-02-04  Rickie  E.   Brinegar:  Modified  to add the -no_end, -ne control
  40    arguments.
  41 
  42    80-04-10  Rickie  E.  Brinegar: Modified to remove certain loops which were
  43    being  called  5,000 times for each line printed.  This increased the speed
  44    of linus_print by 30 percent.
  45 
  46    80-04-14  Rickie  E.   Brinegar:  Modified  to  use  a work area defined on
  47    lcb.i_o_area_ptr instead of getting system free area.
  48 
  49    80-06-01  Jim  Gray:  Modified to detect integer control argument args that
  50    are  too  large,  to  correct  -all, make -all and -max incompatible to fix
  51    effect  of  arg  ordering  bug, and fix error given when -col_widths had no
  52    additional argument given.
  53 
  54    80-06-02  Jim  Gray:  Modified  to  make -cw and -cwt incompatible, fix the
  55    detection  of too many/few args for -cw/-max, detect p.q column width given
  56    for  strings,  detect  when  max  buffer length exceeded, and improve error
  57    messages.
  58 
  59    80-06-24  Jim  Gray:  Modified  to  add  capabilty of printing fixed scaled
  60    numbers, where column has not been specified.
  61 
  62    80-10-21  Rickie  E.   Brinegar:  The  initialization of the buffers in the
  63    declaration  was changed to be done at the begining of the executable code,
  64    and  to  use  assignments  of one buffer to another using the string psuedo
  65    variable  and  builtin  function.  These changes were made as a performance
  66    improvement and were suggested by Matt Pierret.
  67 
  68    81-01-16  Rickie  E.   Brinegar:  Added a check of the error code after the
  69    call  to  linus_eval_set_func  to  catch  error returns rather than letting
  70    linus_print blow up ungracefully.
  71 
  72    81-07-15  Rickie E.  Brinegar: Removed the conversion and cleanup condition
  73    handlers.
  74 
  75    81-09-17  Rickie  E.   Brinegar:  Changed  the  assignment  of  num_ptrs to
  76    num_ptrs  to be an assignment of arg_list.arg_count to num_ptrs later on in
  77    the code to eliminate a size condition from occuring.
  78 
  79    81-11-12  Rickie  E.   Brinegar:  Added  timing  of  this  request  and its
  80    dsl_$retrieve call.
  81 
  82    82-02-10  Paul W. Benjamin:  ssu_ conversion
  83 
  84    82-06-15  Dave J. Schimke: added short names to the MORE? responses
  85    a = all, y = yes, n = no.
  86 
  87    82-06-18  Dave J. Schimke: Modified internal procedure overflow_check to
  88    avoid a stringsize condition when assign_ truncates. This occurred whenever
  89    the -cw control arg was used to reduce the column widths.
  90 
  91    82-10-13 Dave Schimke: Added call to linus_table$async_retrieval before the
  92    first retrieve to keep linus_table from getting lost when loading in the
  93    incremental mode. This call can be eliminated when all modules call
  94    linus_table for their retrievals.
  95 
  96    83-01-11 Dave Schimke: Replace call to iox_$get_line and associated code in
  97    the more_response internal proc with a call to linus_query. This fixes a ssu
  98    conversion bug for invoke and answers TRs 12445 & 13342 (linus 73). Also
  99    changed arg_len_bits.length to arg_len_bits.len.
 100 
 101    83-08-30  Bert Moberg:  Added call to linus_translate_query$auto if no current
 102    select expression is available
 103 */
 104 ^L
 105 %include linus_lcb;
 106 %page;
 107 %include linus_char_argl;
 108 %page;
 109 %include linus_select_info;
 110 %page;
 111 %include linus_arg_list;
 112 %page;
 113 %include mdbm_arg_list;
 114 %page;
 115 %include mdbm_descriptor;
 116 ^L
 117           dcl     sci_ptr                ptr;               /* for ssu_ */
 118 
 119           dcl     1 one_line             based (line_ptr),  /* Format for one print line */
 120                     2 num_items          fixed bin,
 121                     2 item               (select_info.n_user_items refer (one_line.num_items)),
 122                       3 len              fixed bin (35),
 123                       3 ptr              ptr;
 124 
 125           dcl     1 out_line             based (out_line_ptr), /* like one_line  */
 126                     2 num_items          fixed bin,
 127                     2 item               (select_info.n_user_items refer (out_line.num_items)),
 128                       3 len              fixed bin (35),
 129                       3 ptr              ptr;
 130 
 131           dcl     1 user_item            aligned based (user_item_ptr), /* valid when mrds item = user item */
 132                     2 arg_ptr            ptr,
 133                     2 bit_len            fixed bin (35),
 134                     2 desc               bit (36),
 135                     2 assn_type          fixed bin,
 136                     2 assn_len           fixed bin (35);
 137 
 138           dcl     1 arg_len_bits         based,             /* Pick up length for descriptor */
 139                     2 pad                bit (12) unal,
 140                     2 len                bit (24) unal;
 141 
 142           dcl     tmp_char               char (char_argl.arg.arg_len (i))
 143                                          based (char_argl.arg.arg_ptr (i));
 144 
 145           dcl     (he_flag, print_end, first_retrieve, search_for_mrds_item, cwt_flag,
 146                   cw_flag)               bit (1);
 147 
 148           dcl     (
 149                   e_ptr                  init (null),
 150                   out_line_ptr           init (null),
 151                   source_ptr             init (null),
 152                   prt_data_ptr           init (null),
 153                   target_ptr             init (null),
 154                   user_item_ptr          init (null),
 155                   expr_results_ptr       init (null),
 156                   stars_ptr              init (null),
 157                   destination_ptr        init (null),       /* Points to the scalar function init (null),
 158                                                                set function or select_info structure */
 159                   line_ptr               init (null)
 160                   )                      ptr;
 161 
 162           dcl     iox_$user_output       ptr ext;
 163 
 164           dcl     (item_length, float_dec_len, icode, code, out_code, constant_max_lines,
 165                   max_lines)             fixed bin (35);
 166 
 167           dcl     expr_results           float dec (59);
 168           dcl     char_61                char (61);
 169           dcl     char_122               char (122);
 170 
 171           dcl     out_item               char (out_line.item.len (l)) aligned
 172                                          based (out_line.item.ptr (l));
 173           dcl     picture_output         char (one_line.item.len (l)) aligned
 174                                          based (one_line.item.ptr (l));
 175 
 176           dcl     long_message           char (100);
 177           dcl     short_message          char (8);
 178 
 179           dcl     (abs, addr, after, before, ceil, char, copy, fixed, index, length, log10,
 180                   ltrim, null, rel, rtrim, search, string, substr, vclock, verify) builtin;
 181 
 182           dcl     cleanup                condition;
 183 
 184           dcl     offset                 (10) bit (1) based;
 185 
 186           dcl     (
 187                   i,
 188                   j,
 189                   output_line_buf_index,
 190                   line_buf_index,
 191                   line_count,
 192                   out_line_index,
 193                   out_data_len,
 194                   prt_data_len,
 195                   target_type,
 196                   source_type,
 197                   another_len,
 198                   caller,                                   /* 1 = from request processor,
 199                                                                2 = from scalar function,
 200                                                                3 = from set function */
 201                   mrds_item_index,
 202                   temp,
 203                   cmpx_float_dec_type,
 204                   float_dec_type,
 205                   l
 206                   )                      fixed bin;
 207 
 208           dcl     n_bytes                fixed bin (21);    /* for iox_ call */
 209           dcl     num_bytes              fixed bin (35);
 210 
 211           dcl     initial_mrds_vclock    float bin (63);
 212 
 213           dcl     (function_err, fatal_func_err) condition;
 214 
 215           dcl     float_dec_59_desc      bit (36) int static options (constant)
 216                                          init ("100101000000000000000000000000111011"b);
 217           dcl     fix_of_scale           (linus_data_$max_user_items) fixed bin
 218                                          init ((linus_data_$max_user_items) 3);
 219           dcl     ioars_string           (linus_data_$max_user_items) char (8) var
 220                                          init ((linus_data_$max_user_items) (1)"^.3f");
 221           dcl     ioars_len              fixed bin (17);
 222           dcl     STARS                  char (100) int static options (constant) init ((100)"*");
 223           dcl     DEFAULT_EXPR_SIZE      fixed bin (5) int static options (constant) init (17);
 224           dcl     expr_head              char (36) var;
 225           dcl     ANOTHER                char (8) int static options (constant) init ("-another");
 226           dcl     EXPR                   fixed bin (2) int static options (constant) init (2);
 227           dcl     stars_var              char (one_line.item.len (l)) based (stars_ptr);
 228 
 229           dcl     (
 230                   linus_data_$p_id,
 231                   linus_data_$max_user_items,
 232                   linus_data_$print_col_spaces,
 233                   linus_data_$pr_buff_len,
 234                   linus_error_$dup_ctl_args,
 235                   linus_error_$func_err,
 236                   linus_error_$incons_args,
 237                   linus_error_$integer_too_small,
 238                   linus_error_$inv_arg,
 239                   linus_error_$integer_too_large,
 240                   linus_error_$no_data,
 241                   linus_error_$no_db,
 242                   linus_error_$no_max_lines,
 243                   linus_error_$non_integer,
 244                   linus_error_$print_buf_ovfl,
 245                   linus_error_$ret_not_valid,
 246                   linus_error_$too_few_args,
 247                   linus_error_$too_many_args,
 248                   mrds_error_$tuple_not_found,
 249                   sys_info$max_seg_size
 250                   )                      fixed bin (35) ext;
 251 
 252           dcl     all_seen               bit (1);           /* on => -all control arg already given */
 253           dcl     max_seen               bit (1);           /* on => -max control alreay given */
 254           dcl     temp_int               fixed bin (35);    /* temp_int for -max 0 check */
 255           dcl     MRDS_ITEM              fixed bin int static options (constant) init (1);
 256           dcl     temp_desc_ptr          ptr;
 257           dcl     buffer_character_string char (out_line.item.len (l)) based;
 258           dcl     line_buf               (linus_data_$pr_buff_len) char (1);
 259           dcl     temp_buf               (linus_data_$pr_buff_len) char (1);
 260           dcl     out_buf                (linus_data_$pr_buff_len) char (1);
 261           dcl     output_line_buf        (linus_data_$pr_buff_len) char (1);
 262 
 263           dcl     linus_retrieve         entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35));
 264           dcl     linus_table$async_retrieval
 265                                          entry (ptr, fixed bin (35));
 266           dcl     linus_translate_query$auto       entry (ptr, ptr);
 267           dcl     linus_eval_expr
 268                                          entry (ptr, ptr, ptr, fixed bin, fixed bin, fixed bin (35));
 269           dcl     linus_eval_set_func    entry (ptr, ptr, fixed bin (35));
 270           dcl     convert_status_code_   entry (fixed bin (35), char (8), char (100));
 271           dcl     cu_$generate_call      entry (entry, ptr);
 272           dcl     ioa_                   entry options (variable);
 273           dcl     ioa_$ioa_switch        entry options (variable);
 274           dcl     ioa_$rsnnl             entry options (variable);
 275           dcl     iox_$put_chars         entry (ptr, ptr, fixed bin (21), fixed bin (35));
 276           dcl     (
 277                   mdbm_util_$binary_data_class,
 278                   mdbm_util_$complex_data_class,
 279                   mdbm_util_$fixed_data_class,
 280                   mdbm_util_$number_data_class,
 281                   mdbm_util_$string_data_class
 282                   )                      entry (ptr) returns (bit (1));
 283           dcl     dsl_$retrieve          entry options (variable);
 284           dcl     work_area              area (sys_info$max_seg_size) based (lcb.i_o_area_ptr);
 285           dcl     linus_define_area      entry (ptr, char (6), fixed bin (35));
 286           dcl     assign_round_
 287                                          entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
 288           dcl     linus_convert_code     entry (fixed bin (35), fixed bin (35), fixed bin (35));
 289           dcl     ssu_$abort_line        entry options (variable);
 290           dcl     ssu_$abort_subsystem   entry options (variable);
 291           dcl     ssu_$arg_count         entry (ptr, fixed bin);
 292           dcl     ssu_$arg_ptr           entry (ptr, fixed bin, ptr, fixed bin (21));
 293           dcl     ssu_$print_message     entry options (variable);
 294 ^L
 295           ca_ptr, char_ptr, al_ptr, out_line_ptr, line_ptr = null;
 296 
 297           on function_err go to continue;
 298           on fatal_func_err call func_err;
 299 
 300           expr_results_ptr = addr (expr_results);
 301           stars_ptr = addr (STARS);
 302           string (line_buf) = copy (" ", linus_data_$pr_buff_len);
 303           string (out_buf), string (temp_buf), string (output_line_buf) =
 304                string (line_buf);
 305           num_dims = 1;
 306           out_data_len, prt_data_len, code, line_count, icode = 0;
 307           cwt_flag, cw_flag = "0"b;
 308           first_retrieve, print_end, he_flag = "1"b;
 309           constant_max_lines, max_lines = 10;               /* Set default print lines */
 310           target_type = 43;                                 /* Char * 2  */
 311           source_type = 44;                                 /* Char_var * 2  */
 312           cmpx_float_dec_type = 24;
 313           desc_ptr = addr (float_dec_59_desc);
 314           float_dec_type = 2 * descriptor.type;
 315           float_dec_len =
 316                fixed (descriptor.size.scale || "000000"b || descriptor.size.precision)
 317                ;
 318           another_len = 8;                                  /* There are 8 characters in "-another" */
 319           caller = 1;                                       /* For linus_eval_expr */
 320           line_ptr = null;
 321           prt_data_ptr = addr (output_line_buf (1));        /* Init */
 322 ^L
 323           if lcb.db_index = 0 then
 324                call error (linus_error_$no_db, "");
 325           if lcb.si_ptr = null then call linus_translate_query$auto (sci_ptr, lcb_ptr); /* try translating it */
 326           if lcb.si_ptr = null then return; /* No good?  Oh, well */
 327           destination_ptr = lcb.si_ptr;                     /* For linus_eval_expr */
 328           si_ptr = lcb.si_ptr;
 329           if ^select_info.se_flags.val_ret then
 330                call error (linus_error_$ret_not_valid, "");
 331           call linus_define_area (lcb.i_o_area_ptr, "I_O_", code);
 332           if code ^= 0 then
 333                call error (code, "");
 334           allocate one_line in (work_area);
 335           allocate out_line in (work_area);
 336           max_seen, all_seen = "0"b;
 337           i = 1;
 338           call ssu_$arg_count (sci_ptr, nargs_init);
 339           if nargs_init ^= 0 then do;
 340                     allocate char_argl in (lcb.static_area);
 341                     on cleanup begin;
 342                               if ca_ptr ^= null
 343                               then free char_argl;
 344                          end;
 345                     do i = 1 to nargs_init;
 346                          call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i));
 347                     end;
 348                     i = 1;
 349                     do while (i <= char_argl.nargs);
 350                          if tmp_char = "-no_header" | tmp_char = "-nhe" then
 351                               he_flag = "0"b;               /* Set header flag */
 352                          else if tmp_char = "-max" then do;
 353                                    if max_seen then
 354                                         call error (linus_error_$dup_ctl_args, "-max");
 355                                    if i = char_argl.nargs then
 356                                         call error (linus_error_$no_max_lines, "");
 357                                    else if all_seen then
 358                                         call error (linus_error_$incons_args, "-max and -all");
 359                                    else do;
 360                                              i = i + 1;
 361                                              if substr (tmp_char, 1, 1) = "-" then
 362                                                   call
 363                                                        error (linus_error_$no_max_lines,
 364                                                        "before " || tmp_char);
 365                                              call integer_check ((char_argl.arg.arg_len (i)));
 366                                              temp_int = fixed (tmp_char);
 367                                              if temp_int = 0 then
 368                                                   call
 369                                                        error (linus_error_$integer_too_small,
 370                                                        "for -max LINES");
 371                                              constant_max_lines, max_lines = temp_int; /* Set if maximum print lines */
 372                                              i = i + 1;
 373                                              if i ^> char_argl.nargs then
 374                                                   if substr (tmp_char, 1, 1) ^= "-" then
 375                                                        call
 376                                                             error (linus_error_$too_many_args,
 377                                                             "for -max LINES");
 378                                              i = i - 1;
 379                                              max_seen = "1"b;
 380                                         end;
 381                               end;
 382                          else if tmp_char = "-all" | tmp_char = "-a" then do;
 383                                    if max_seen then
 384                                         call error (linus_error_$incons_args, "-all and -max");
 385                                    max_lines = 999999999;
 386                                    all_seen = "1"b;
 387                               end;
 388                          else if tmp_char = "-col_widths_trunc" | tmp_char = "-cwt" then do;
 389                                    if cwt_flag then
 390                                         call error (linus_error_$dup_ctl_args, "-col_width_trunc");
 391                                    if cw_flag then
 392                                         call
 393                                              error (linus_error_$incons_args,
 394                                              "-col_width_trunc and -col_width");
 395                                    cwt_flag = "1"b;
 396                                    call cw_specified;
 397                               end;
 398                          else if tmp_char = "-col_widths" | tmp_char = "-cw" then do;
 399                                    if cwt_flag then
 400                                         call
 401                                              error (linus_error_$incons_args,
 402                                              "-cold_width and -col_width_trunc");
 403                                    if cw_flag then
 404                                         call error (linus_error_$dup_ctl_args, "-col_width");
 405                                    cw_flag = "1"b;
 406                                    call cw_specified;
 407                               end;
 408                          else if tmp_char = "-no_end" | tmp_char = "-ne" then
 409                               print_end = "0"b;
 410                          else call error (linus_error_$inv_arg, tmp_char);
 411                                                             /* Print error */
 412                          i = i + 1;
 413                     end;
 414                end;
 415           if ^cw_flag then /* make sure ioa control string is blank */
 416                do l = 1 to select_info.n_user_items;        /* so that no scale adjustment is made */
 417                     if ^(select_info.user_item.item_type (l) = EXPR | select_info.set_fn)
 418                     then ioars_string (l) = "";
 419                end;
 420 ^L
 421           call print_layout;                                /* Fix format for print data */
 422           if select_info.prior_sf_ptr ^= null then
 423                call linus_eval_set_func (lcb_ptr, select_info.prior_sf_ptr, icode);
 424                                                             /* evaluate prior set functions */
 425           if icode ^= 0 & icode ^= mrds_error_$tuple_not_found then
 426                call error (icode, "");
 427           if select_info.set_fn then do;                    /* set function to be applied */
 428                     call
 429                          linus_eval_set_func (lcb_ptr, select_info.user_item.item_ptr (1),
 430                          icode);
 431                     if icode = 0 then
 432                          call print_line;
 433                end;
 434           else do;
 435                     call linus_table$async_retrieval (lcb_ptr, icode);
 436                     if icode ^= 0 then
 437                          call error (icode, "");
 438 
 439                     call linus_retrieve (lcb_ptr, ca_ptr, char_ptr, al_ptr, e_ptr, icode);
 440                     char_desc.arr.var (1) = addr (another_len) -> arg_len_bits.len;
 441                                                             /* Set up for additional retrievals */
 442                     num_ptrs = arg_list.arg_count;
 443                     arg_list.arg_des_ptr (2) = addr (ANOTHER);
 444                     do while (icode = 0 & max_lines > line_count);
 445                          call print_line;
 446 continue:
 447                          if lcb.timing_mode then
 448                               initial_mrds_vclock = vclock;
 449                          call cu_$generate_call (dsl_$retrieve, al_ptr); /* Retrieve "-another" */
 450                          if lcb.timing_mode then
 451                               lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock;
 452                          if constant_max_lines ^= 0 & max_lines = line_count & icode = 0 then
 453                               call more_response;
 454                     end;
 455                end;
 456           if icode ^= 0 & icode ^= mrds_error_$tuple_not_found then
 457                call error (icode, "");
 458           if first_retrieve then
 459                call no_data;
 460           if print_end then
 461                call ioa_ ("(END)^/");
 462 
 463 exit:
 464           if ca_ptr ^= null
 465           then free char_argl;
 466           return;
 467 ^L
 468 no_data:
 469      proc;
 470           call
 471                convert_status_code_ (linus_error_$no_data, short_message,
 472                long_message);
 473           call ioa_$ioa_switch (iox_$user_output, "^/^a^/", long_message);
 474           code = 0;
 475           goto exit;
 476      end no_data;
 477 ^L
 478 cw_specified:
 479      proc;
 480 
 481           dcl     dot_flag               bit (1);
 482 
 483           out_line_index, line_buf_index = 1;
 484           cw_flag = "1"b;                                   /* Turn col_widths flag ON */
 485           do l = 1 to select_info.n_user_items;             /* Initialize one_line structure */
 486                dot_flag = "0"b;                             /* init */
 487                i = i + 1;                                   /* Go to next item in char_argl structure */
 488                if i > char_argl.nargs then
 489                     call error (linus_error_$too_few_args, "column widths");
 490                                                             /* Input argument error */
 491                if substr (tmp_char, 1, 1) = "-" then
 492                     call
 493                          error (linus_error_$too_few_args,
 494                          "column widths before " || tmp_char);
 495                temp = search (tmp_char, ".");               /* search for user specified scale */
 496                if temp = 0 then do;
 497                          temp = char_argl.arg.arg_len (i);
 498                          if select_info.user_item.item_type (l) ^= EXPR & ^select_info.set_fn
 499                          then ioars_string (l) = "";
 500                     end;
 501                else do;
 502                          ioars_string (l) =
 503                               "^."
 504                               || substr (tmp_char, temp + 1, char_argl.arg.arg_len (i) - temp)
 505                               || "f";
 506                          if verify (after (tmp_char, "."), "-0123456789") ^= 0
 507                               | length (after (tmp_char, ".")) > 4
 508                               | (index (after (tmp_char, "."), "-") ^= 0
 509                               & (index (substr (after (tmp_char, "."), 2), "-") ^= 0
 510                               | substr (after (tmp_char, "."), 1, 1) ^= "-")) then
 511                               call
 512                                    error (linus_error_$non_integer,
 513                                    "scale factor in column " || ltrim (char (l)) || " width");
 514                          fix_of_scale (l) = fixed (after (tmp_char, "."));
 515                          if fix_of_scale (l) < -128 | fix_of_scale (l) > 127 then
 516                               call
 517                                    error (linus_error_$inv_arg,
 518                                    "scale > 127, or < -128 in column " || ltrim (char (l))
 519                                    || " width");
 520                          temp = temp - 1;                   /* number of column spaces or precision */
 521                          dot_flag = "1"b;                   /* period found in this column specification */
 522                     end;
 523                call integer_check (temp);
 524                out_line.item.len (l) = fixed (substr (tmp_char, 1, temp));
 525                if out_line.item.len (l) = 0 then
 526                     call
 527                          error (linus_error_$integer_too_small,
 528                          "column width argument " || ltrim (char (l)));
 529                if dot_flag then do;
 530                          if select_info.user_item.item_type (l) = MRDS_ITEM then
 531                               temp_desc_ptr =
 532                                    addr (select_info.user_item.item_ptr (l) -> user_item.desc);
 533                          else temp_desc_ptr = addr (select_info.user_item.rslt_desc (l));
 534                          if ^mdbm_util_$number_data_class (temp_desc_ptr) then
 535                               call
 536                                    error (linus_error_$inv_arg,
 537                                    "scale in column " || ltrim (char (l))
 538                                    || " width for string data");
 539                          out_line.item.len (l) = out_line.item.len (l) + 1;
 540                                                             /* for period */
 541                     end;
 542                out_line.item.ptr (l) = addr (out_buf (out_line_index));
 543                out_line_index = out_line_index + out_line.item.len (l);
 544                out_data_len =
 545                     out_data_len + out_line.item.len (l) + linus_data_$print_col_spaces;
 546                                                             /*
 547                                                                Set up for output */
 548                if out_data_len > linus_data_$pr_buff_len - 1 then
 549                     call
 550                          error (linus_error_$print_buf_ovfl,
 551                          "column widths total > max of "
 552                          || ltrim (char (linus_data_$pr_buff_len - 1)));
 553           end;
 554 
 555 /* check for too many col_widths */
 556 
 557           i = i + 1;
 558           if i ^> char_argl.nargs then
 559                if substr (tmp_char, 1, 1) ^= "-" then
 560                     call error (linus_error_$too_many_args, tmp_char);
 561           i = i - 1;
 562      end cw_specified;
 563 ^L
 564 print_layout:
 565      proc;
 566 
 567           mrds_item_index = 0;
 568           search_for_mrds_item = "0"b;
 569           line_buf_index = 1;                               /* Init index to line buffer */
 570           do l = 1 to select_info.n_user_items;             /* Find length of each item to be printed */
 571                mrds_item_index = mrds_item_index + 1;
 572                one_line.item.len (l) = 0;
 573                if select_info.user_item.item_type (l) = EXPR | select_info.set_fn
 574                then do;
 575                          one_line.item.len (l) = 3;         /* for F() */
 576                          search_for_mrds_item = "1"b;
 577                          if mdbm_util_$number_data_class (
 578                               addr (select_info.user_item.rslt_desc (l))) then do;
 579                                    if cw_flag then
 580                                         item_length = out_line.item.len (l);
 581                                    else item_length = DEFAULT_EXPR_SIZE;
 582                               end;
 583                          else item_length = select_info.user_item.rslt_assn_len (l);
 584                     end;
 585                else do;
 586                          if search_for_mrds_item then
 587                               do mrds_item_index = mrds_item_index
 588                                    to select_info.n_mrds_items
 589                                    while (select_info.user_item.item_ptr (l)
 590                                    ^= addr (select_info.mrds_item (mrds_item_index)));
 591                               end;
 592                          call
 593                               calc_len ((select_info.mrds_item.desc (mrds_item_index)),
 594                               item_length);
 595                          search_for_mrds_item = "0"b;
 596                     end;
 597 
 598                one_line.item.len (l) =
 599                     one_line.item.len (l) + length (select_info.user_item.name (l));
 600                                                             /* Get number of characters in attribute
 601                                                                or function name */
 602                if one_line.item.len (l) < item_length then
 603                     one_line.item.len (l) = item_length;    /* Set width of column
 604                                                                to larger of header or data */
 605                one_line.item.ptr (l) = addr (line_buf (line_buf_index));
 606                line_buf_index = line_buf_index + one_line.item.len (l);
 607                prt_data_len =
 608                     prt_data_len + one_line.item.len (l) + linus_data_$print_col_spaces;
 609                                                             /*
 610                                                                Init for tmp_print_data */
 611                if prt_data_len > linus_data_$pr_buff_len - 1/* subtract one for newline character */
 612                then call
 613                          error (linus_error_$print_buf_ovfl,
 614                          "print line exceeds maximum length of "
 615                          || ltrim (char (linus_data_$pr_buff_len - 1)));
 616           end;
 617      end print_layout;
 618 ^L
 619 
 620 
 621 calc_len:
 622      proc (descrip, length);
 623 
 624 /* Calculate the length of a print field given a descriptor */
 625 
 626           dcl     descrip                bit (36);
 627           dcl     length                 fixed bin (35);
 628           dcl     prec_len               fixed bin;
 629           dcl     scale_len              fixed bin (11);
 630           dcl     fixed_bin_11_ovrly     fixed bin (11) unal based;
 631 
 632 
 633           desc_ptr = addr (descrip);                        /* Point to descriptor */
 634           prec_len = fixed (descriptor.size.precision);
 635           if mdbm_util_$binary_data_class (desc_ptr) then
 636                length = prec_len / 3 + 5;                   /* binary */
 637           else if mdbm_util_$number_data_class (desc_ptr) then
 638                length = prec_len + 3;                       /* decimal */
 639           else if mdbm_util_$string_data_class (desc_ptr) then
 640                length = fixed (descriptor.size.scale || descriptor.size.precision);
 641           else length = 20;
 642           if mdbm_util_$number_data_class (desc_ptr) then do;
 643                     if mdbm_util_$fixed_data_class (desc_ptr) then do; /* fixed */
 644                               scale_len = addr (descriptor.size.scale) -> fixed_bin_11_ovrly;
 645                                                             /* get signed scale */
 646                               if scale_len = 0 | (scale_len > 0 & prec_len >= scale_len) then
 647                                    ;                        /* no scale_len factor */
 648                               else if cw_flag & ioars_string (l) ^= "" then
 649                                    ;                        /* use specified length instead */
 650                               else length = length + ceil (log10 (abs (scale_len)));
 651                                                             /* largest scale will be f-128 to f+127 */
 652                          end;
 653                     else length = length + 5;               /* float */
 654                end;
 655           if mdbm_util_$complex_data_class (desc_ptr) then
 656                length = length * 2;
 657 
 658           if cw_flag & ioars_string (l) ^= "" then /* length has been specified */
 659                if ^mdbm_util_$string_data_class (desc_ptr) then /* exclude string types */
 660                     length = out_line.item.len (l);         /* use specified length */
 661      end calc_len;
 662 ^L
 663 print_header:
 664      proc;
 665 
 666           dcl     (type, j)              fixed bin;
 667 
 668           search_for_mrds_item, he_flag = "0"b;
 669           mrds_item_index = 0;
 670           do l = 1 to select_info.n_user_items;
 671                mrds_item_index = mrds_item_index + 1;
 672                out_item = "";
 673                item_length = length (select_info.user_item.name (l));
 674                target_ptr = out_line.item.ptr (l);
 675                if select_info.user_item.item_type (l) = EXPR then do;
 676                          search_for_mrds_item = "1"b;       /* the next data base user item will need to find desc */
 677                          expr_head = "F(" || select_info.user_item.name (l) || ")";
 678                                                             /* add F to tuple attribute */
 679                          source_ptr = addr (expr_head);
 680                          item_length = item_length + 3;
 681                     end;
 682                else if select_info.set_fn then
 683                     source_ptr = addr (select_info.user_item.name (l));
 684                else do;                                     /* user item is selected from data base */
 685                          source_ptr = addr (select_info.user_item.name (l));
 686                          if search_for_mrds_item then /* the previous item was an expression */
 687                               do mrds_item_index = mrds_item_index
 688                                    to select_info.n_mrds_items
 689                                    while (select_info.user_item.item_ptr (l)
 690                                    ^= addr (select_info.mrds_item (mrds_item_index)));
 691                               end;
 692                          desc_ptr = addr (select_info.mrds_item.desc (mrds_item_index));
 693                          search_for_mrds_item = "0"b;
 694                          type = descriptor.type;
 695                          if mdbm_util_$number_data_class (desc_ptr) & ioars_string (l) = ""
 696                          then
 697                               do j = 1 to out_line.item.len (l) - item_length;
 698                                    target_ptr = addr (target_ptr -> offset (10));
 699                               end;
 700                     end;
 701                call
 702                     assign_round_ (target_ptr, target_type, item_length, source_ptr,
 703                     source_type, item_length);
 704           end;
 705           if ^cw_flag then
 706                out_buf = line_buf;
 707           call set_up_output;
 708           call ioa_ ("");
 709           call print_a_line;                                /* Print header */
 710           call ioa_ ("");
 711      end print_header;
 712 ^L
 713 print_line:
 714      proc;
 715 
 716           do l = 1 to select_info.n_user_items;
 717                if select_info.user_item.item_type (l) = EXPR | select_info.set_fn
 718                then do;                                     /* Evaluate expression */
 719                          if ^select_info.set_fn then
 720                               call
 721                                    linus_eval_expr (lcb_ptr,
 722                                    select_info.user_item.item_ptr (l), destination_ptr, caller,
 723                                    l, icode);
 724                          if icode ^= 0 then
 725                               call error (icode, "");
 726                          picture_output = stars_var;        /* init */
 727                          if mdbm_util_$number_data_class (
 728                               addr (select_info.user_item.rslt_desc (l))) then do;
 729                                                             /* this is really an expr
 730                                                                -- not char or string scalar function */
 731                                    if mdbm_util_$complex_data_class (
 732                                         addr (select_info.user_item.rslt_desc (l))) then do;
 733                                              call
 734                                                   assign_round_ (expr_results_ptr, cmpx_float_dec_type,
 735                                                   float_dec_len, select_info.user_item.rslt_assn_ptr (l),
 736                                                   select_info.user_item.rslt_assn_type (l),
 737                                                   select_info.user_item.rslt_assn_len (l));
 738                                              call
 739                                                   ioa_$rsnnl (ioars_string (l), char_122, ioars_len,
 740                                                   expr_results);
 741                                         end;
 742                                    else do;
 743                                              call
 744                                                   assign_round_ (expr_results_ptr, float_dec_type, float_dec_len,
 745                                                   select_info.user_item.rslt_assn_ptr (l),
 746                                                   select_info.user_item.rslt_assn_type (l),
 747                                                   select_info.user_item.rslt_assn_len (l));
 748                                              call
 749                                                   ioa_$rsnnl (ioars_string (l), char_61, ioars_len,
 750                                                   expr_results);
 751                                              ioars_len =
 752                                                   length (before (char_61, ".")) + fix_of_scale (l) + 1;
 753                                         end;
 754                                    if ioars_len <= one_line.item.len (l) | cwt_flag then
 755                                         call
 756                                              ioa_$rsnnl (ioars_string (l), picture_output, ioars_len,
 757                                              expr_results);
 758                                    else /* adjust output format */
 759                                         if first_retrieve & ^cw_flag then do; /* adjust output format */
 760                                              temp = ioars_len - one_line.item.len (l);
 761                                              prt_data_len = prt_data_len + temp; /* output buffer length */
 762                                              do i = l to select_info.n_user_items;
 763                                                   one_line.item.len (l) = one_line.item.len (l) + temp;
 764                                                   do j = 1 to temp while (l ^= select_info.n_user_items);
 765                                                        one_line.item.ptr (l + 1) =
 766                                                             addr (one_line.item.ptr (l + 1) -> offset (10));
 767                                                   end;
 768                                              end;
 769                                              call
 770                                                   ioa_$rsnnl (ioars_string (l), picture_output, ioars_len,
 771                                                   expr_results);
 772                                         end;
 773 
 774                                    if cw_flag then
 775                                         call overflow_check;/* check column width with data retrieved */
 776 
 777                               end;
 778                          else do;                           /* output result of non-arithmetic scalar function */
 779 
 780                                    call
 781                                         assign_round_ (one_line.item.ptr (l), target_type,
 782                                         one_line.item.len (l),
 783                                         select_info.user_item.rslt_assn_ptr (l),
 784                                         select_info.user_item.rslt_assn_type (l),
 785                                         select_info.user_item.rslt_assn_len (l));
 786 
 787                                    if cw_flag then
 788                                         call overflow_check;/* check column width with data retrieved */
 789 
 790                               end;
 791                     end;
 792                else do;
 793                          user_item_ptr = select_info.user_item.item_ptr (l);
 794                                                             /* init user item structure */
 795 
 796 /*                       temp = floor (user_item.assn_type / 2); */
 797                          if mdbm_util_$number_data_class (addr (user_item.desc))
 798                               & ioars_string (l) ^= "" then do; /* make adjustment for specified scale */
 799                                    call
 800                                         assign_round_ (expr_results_ptr, float_dec_type, float_dec_len,
 801                                         user_item.arg_ptr, user_item.assn_type, user_item.assn_len);
 802 
 803                                    call
 804                                         ioa_$rsnnl (ioars_string (l), char_61, ioars_len,
 805                                         expr_results);
 806                                    ioars_len =
 807                                         length (before (char_61, ".")) + fix_of_scale (l) + 1;
 808                                    if ioars_len > one_line.item.len (l) & ^cwt_flag
 809                                                             /* output data does not fit
 810                                                                in the space areserved */
 811                                    then picture_output = stars_var; /* print asterisks */
 812                                    else /* prepare data for output */
 813                                         call
 814                                              ioa_$rsnnl (ioars_string (l), picture_output, ioars_len,
 815                                              expr_results);
 816                               end;
 817                          else call
 818                                    assign_round_ (one_line.item.ptr (l), target_type,
 819                                    one_line.item.len (l), user_item.arg_ptr,
 820                                    user_item.assn_type, user_item.assn_len);
 821 
 822                          if cw_flag then
 823                               call overflow_check;
 824 
 825                     end;
 826           end;
 827           first_retrieve = "0"b;
 828           if ^cw_flag then do;
 829                     out_buf = line_buf;
 830                     out_line = one_line;
 831                end;
 832           else prt_data_len = out_data_len;
 833           if he_flag then do;                               /* print header */
 834                     string (temp_buf) = string (out_buf);
 835                     call print_header;
 836                     string (out_buf) = string (temp_buf);
 837                end;
 838           call set_up_output;
 839           call print_a_line;                                /* print one line of data */
 840           line_count = line_count + 1;
 841      end print_line;
 842 ^L
 843 overflow_check:
 844      proc;
 845 
 846 
 847           dcl     t1_char                char (t1_len) based (t1_ptr);
 848           dcl     t1_len                 fixed bin (35);
 849           dcl     type                   fixed bin;
 850           dcl     t1_ptr                 ptr;
 851           dcl     stringsize             condition;
 852 
 853           t1_ptr = null;
 854 
 855           if out_line.item.len (l) < one_line.item.len (l) then do;
 856                     t1_len = out_line.item.len (l) + 1;
 857                     allocate t1_char in (work_area);
 858                     t1_char = " ";
 859                     if select_info.user_item.item_type (l) = EXPR | select_info.set_fn then
 860                          call
 861                               assign_round_ (t1_ptr, target_type, t1_len,
 862                               select_info.user_item.rslt_assn_ptr (l),
 863                               select_info.user_item.rslt_assn_type (l),
 864                               select_info.user_item.rslt_assn_len (l));
 865                     else do;
 866                               on condition (stringsize) ;
 867                               call
 868                                    assign_round_ (t1_ptr, target_type, t1_len, user_item.arg_ptr,
 869                                    user_item.assn_type, user_item.assn_len);
 870                               revert stringsize;
 871                          end;
 872 
 873                     temp = one_line.item.len (l) - out_line.item.len (l);
 874                     user_item_ptr = select_info.user_item.item_ptr (l);
 875                     desc_ptr = addr (user_item.desc);
 876                     type = descriptor.type;
 877                     if mdbm_util_$string_data_class (addr (user_item.desc)) then do;
 878                               if substr (t1_char, t1_len) ^= " " then
 879                                    if ^cwt_flag then
 880                                         picture_output = stars_var;
 881                               out_item = substr (picture_output, 1, out_line.item.len (l));
 882                          end;
 883                     else do;
 884                               if substr (picture_output, temp, 1) ^= " " then
 885                                    if ^cwt_flag then
 886                                         picture_output = stars_var;
 887                               out_item = substr (picture_output, temp + 1);
 888                          end;
 889                end;
 890           else do;
 891                     temp = out_line.item.len (l) - one_line.item.len (l);
 892                     substr (out_item, temp + 1) = picture_output;
 893                end;
 894 
 895           t1_ptr = null;
 896 
 897      end overflow_check;
 898 ^L
 899 
 900 
 901 set_up_output:
 902      proc;
 903 
 904 /* Merge line_buf and output_line_buf leaving spaces between each column */
 905 
 906           out_line_index, output_line_buf_index = 1;        /* Init */
 907           do l = 1 to out_line.num_items;                   /* Move data into output buffer for printing */
 908                addr (output_line_buf (output_line_buf_index))
 909                     -> buffer_character_string =
 910                     addr (out_buf (out_line_index)) -> buffer_character_string;
 911                out_line_index = out_line_index + out_line.item.len (l);
 912                output_line_buf_index =
 913                     output_line_buf_index + out_line.item.len (l)
 914                     + linus_data_$print_col_spaces;
 915                if output_line_buf_index > linus_data_$pr_buff_len - 1
 916                                                             /* subtract 1 for new line character */
 917                then call
 918                          error (linus_error_$print_buf_ovfl,
 919                          "print line exceeds maximum length of "
 920                          || ltrim (char (linus_data_$pr_buff_len - 1)));
 921           end;
 922 
 923 
 924      end set_up_output;
 925 ^L
 926 
 927 
 928 integer_check:
 929      proc (no_of_intg);
 930 
 931           dcl     no_of_intg             fixed bin;
 932 
 933 /* Check for integer in char_argl */
 934 
 935           if verify (substr (tmp_char, 1, no_of_intg), "0123456789") ^= 0 then
 936                call error (linus_error_$non_integer, "");
 937           else if no_of_intg > 9 then
 938                call error (linus_error_$integer_too_large, "");
 939 
 940      end integer_check;
 941 
 942 
 943 
 944 
 945 print_a_line:
 946      proc;
 947 
 948           dcl     print_line_character_string char (prt_data_len)
 949                                          based (addr (output_line_buf (1)));
 950           dcl     NEWLINE                char (1) int static options (constant) init ("
 951 ");
 952 
 953           n_bytes = length (rtrim (print_line_character_string)) + 1;
 954           output_line_buf (n_bytes) = NEWLINE;              /* add newline character */
 955           call iox_$put_chars (iox_$user_output, prt_data_ptr, n_bytes, icode);
 956           if icode ^= 0 then
 957                call error (icode, "");
 958 
 959           num_bytes = n_bytes;
 960           output_line_buf (n_bytes) = " ";
 961 
 962      end print_a_line;
 963 ^L
 964 
 965 
 966 error:
 967      proc (err_code, msg);
 968 
 969           dcl     err_code               fixed bin (35);
 970           dcl     msg                    char (*);
 971 
 972           if ca_ptr ^= null
 973           then free char_argl;
 974           call linus_convert_code (err_code, out_code, linus_data_$p_id);
 975           if code = 0
 976           then call ssu_$abort_line (sci_ptr, out_code, msg);
 977           else call ssu_$abort_subsystem (sci_ptr, out_code, msg);
 978 
 979      end error;
 980 
 981 
 982 
 983 func_err:
 984      proc;
 985 
 986 
 987           call
 988                linus_convert_code (linus_error_$func_err, out_code, linus_data_$p_id);
 989           call ssu_$print_message (sci_ptr, out_code);
 990 
 991           go to continue;
 992 
 993      end func_err;
 994 ^L
 995 
 996 
 997 more_response:
 998      proc;
 999           dcl     linus_query            entry (ptr, char(*) var, char(*) var);
1000           dcl     verify_more            char (5) var;
1001           dcl     more_test              bit (1) aligned;
1002           dcl     NL                     char(1) int static options (constant) init ("
1003 ");
1004 
1005           more_test = "0"b;
1006           call linus_query (lcb_ptr, verify_more, NL||"More? ");
1007           do while (^more_test);
1008                more_test = "1"b;
1009                if verify_more = "all" | verify_more = "a" then
1010                     max_lines = 999999999;
1011                else if verify_more = "yes" | verify_more = "y" then
1012                     max_lines = max_lines + constant_max_lines;
1013                else if verify_more = "no" | verify_more = "n" then
1014                     print_end = "0"b;                       /* do not print (END) */
1015                else do;
1016                     call linus_query (lcb_ptr, verify_more, "Please answer ""yes"", ""no"" or ""all""."||NL);
1017                     more_test = "0"b;
1018                     end;
1019           end;
1020           call ioa_ ("");
1021      end more_response;
1022 
1023      end linus_print;