1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21 linus_print:
22 proc (sci_ptr, lcb_ptr);
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
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;
118
119 dcl 1 one_line based (line_ptr),
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),
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),
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,
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),
158
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,
199
200
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);
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);
253 dcl max_seen bit (1);
254 dcl temp_int fixed bin (35);
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;
310 target_type = 43;
311 source_type = 44;
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;
319 caller = 1;
320 line_ptr = null;
321 prt_data_ptr = addr (output_line_buf (1));
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);
326 if lcb.si_ptr = null then return;
327 destination_ptr = lcb.si_ptr;
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;
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;
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
412 i = i + 1;
413 end;
414 end;
415 if ^cw_flag then
416 do l = 1 to select_info.n_user_items;
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;
422 if select_info.prior_sf_ptr ^= null then
423 call linus_eval_set_func (lcb_ptr, select_info.prior_sf_ptr, icode);
424
425 if icode ^= 0 & icode ^= mrds_error_$tuple_not_found then
426 call error (icode, "");
427 if select_info.set_fn then do;
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
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);
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;
485 do l = 1 to select_info.n_user_items;
486 dot_flag = "0"b;
487 i = i + 1;
488 if i > char_argl.nargs then
489 call error (linus_error_$too_few_args, "column widths");
490
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, ".");
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;
521 dot_flag = "1"b;
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
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
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
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;
570 do l = 1 to select_info.n_user_items;
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;
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
601
602 if one_line.item.len (l) < item_length then
603 one_line.item.len (l) = item_length;
604
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
611 if prt_data_len > linus_data_$pr_buff_len - 1
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
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);
634 prec_len = fixed (descriptor.size.precision);
635 if mdbm_util_$binary_data_class (desc_ptr) then
636 length = prec_len / 3 + 5;
637 else if mdbm_util_$number_data_class (desc_ptr) then
638 length = prec_len + 3;
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;
644 scale_len = addr (descriptor.size.scale) -> fixed_bin_11_ovrly;
645
646 if scale_len = 0 | (scale_len > 0 & prec_len >= scale_len) then
647 ;
648 else if cw_flag & ioars_string (l) ^= "" then
649 ;
650 else length = length + ceil (log10 (abs (scale_len)));
651
652 end;
653 else length = length + 5;
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
659 if ^mdbm_util_$string_data_class (desc_ptr) then
660 length = out_line.item.len (l);
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;
677 expr_head = "F(" || select_info.user_item.name (l) || ")";
678
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;
685 source_ptr = addr (select_info.user_item.name (l));
686 if search_for_mrds_item then
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;
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;
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;
727 if mdbm_util_$number_data_class (
728 addr (select_info.user_item.rslt_desc (l))) then do;
729
730
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
759 if first_retrieve & ^cw_flag then do;
760 temp = ioars_len - one_line.item.len (l);
761 prt_data_len = prt_data_len + temp;
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;
776
777 end;
778 else do;
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;
789
790 end;
791 end;
792 else do;
793 user_item_ptr = select_info.user_item.item_ptr (l);
794
795
796
797 if mdbm_util_$number_data_class (addr (user_item.desc))
798 & ioars_string (l) ^= "" then do;
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
810
811 then picture_output = stars_var;
812 else
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;
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;
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
905
906 out_line_index, output_line_buf_index = 1;
907 do l = 1 to out_line.num_items;
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
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
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;
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;
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;