1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23 wdc:
24 window_call:
25 procedure options (variable);
26
27 declare cu_$arg_list_ptr entry returns (ptr);
28 declare arg_list_ptr pointer;
29
30 arg_list_ptr = cu_$arg_list_ptr ();
31
32 begin;
33
34 declare 1 irep (window_call_data_$n_ctl_args) aligned,
35 2 allowed bit (1) aligned,
36 2 required bit (1) aligned,
37 2 found bit (1) aligned,
38 2 argument fixed bin,
39 2 arg aligned,
40 3 value fixed bin,
41 3 ptr pointer unaligned,
42 3 length fixed bin (21);
43
44
45 declare key character (32);
46 declare keyx fixed bin (21);
47
48 declare 1 this_f aligned like function based (this_f_ptr);
49 declare this_f_ptr pointer;
50
51
52 declare argument_ptr pointer;
53 declare argument_length fixed bin (21);
54 declare argument character (argument_length) based (argument_ptr);
55
56 declare rs_ptr pointer;
57 declare rs_length fixed bin (21);
58 declare return_string character (rs_length) varying based (rs_ptr);
59
60 declare save_argument character (32);
61
62 declare this_is_an_af bit (1) aligned;
63 declare error_reporter entry options (variable) variable;
64 declare n_arguments fixed bin;
65 declare iocb_ptr pointer;
66 declare code fixed bin (35);
67 declare (ctlx, argx) fixed bin;
68
69 declare ME character (32) init ("window_call") internal static options (constant);
70
71 declare com_err_ entry () options (variable);
72 declare active_fnc_err_ entry () options (variable);
73 declare requote_string_ entry (character (*)) returns (character (*));
74
75 declare cu_$af_return_arg_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
76 declare cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
77 declare cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35));
78 declare ioa_ entry () options (variable);
79
80 declare video_utils_$turn_on_login_channel
81 entry (fixed binary (35), character (*));
82 declare video_utils_$turn_off_login_channel
83 entry (fixed binary (35));
84
85 declare (
86 error_table_$nodescr,
87 error_table_$not_act_fnc,
88 error_table_$noarg,
89 error_table_$bad_arg,
90 error_table_$badopt,
91 error_table_$active_function,
92 error_table_$bad_conversion,
93 video_et_$wsys_invoked,
94 video_et_$wsys_not_invoked
95 ) ext static fixed bin (35);
96
97 declare video_data_$terminal_iocb
98 pointer external;
99
100 declare (addr, character, length, ltrim, null, substr, translate)
101 builtin;
102 %page;
103 %include window_dcls;
104 %include window_control_info;
105 %include iox_dcls;
106 %include iox_modes;
107 %page;
108
109 ^L
110
111 call cu_$af_return_arg_rel (n_arguments, rs_ptr, rs_length, code, arg_list_ptr);
112
113 if n_arguments = 0 | code = error_table_$nodescr then do;
114
115 if code = 0 then
116 call active_fnc_err_ (0, ME, "Usage: window_call call KEY ARGUMENTS.");
117 else call com_err_ (0, ME, "Usage: window_call KEY ARGUMENTS.");
118 go to RETURN;
119 end;
120
121 if code = error_table_$not_act_fnc then do;
122 this_is_an_af = "0"b;
123 error_reporter = com_err_;
124 end;
125
126 else do;
127 this_is_an_af = "1"b;
128 error_reporter = active_fnc_err_;
129 end;
130
131 wcd_functions_ptr = addr (window_call_data_$functions);
132 wcd_names_ptr = addr (window_call_data_$names);
133 wcd_string_ptr = addr (window_call_data_$string);
134 wcd_ctl_args_ptr = addr (window_call_data_$ctl_args);
135
136 call cu_$arg_ptr_rel (1, argument_ptr, argument_length, (0), arg_list_ptr);
137
138 if character (argument, 1) = "-" then do;
139 call error_reporter (error_table_$noarg, ME, "The function keyword must be the first argument.");
140 go to RETURN;
141 end;
142
143 do keyx = 1 to window_call_data_$n_keys while (argument ^= "");
144 if argument = window_call_data_names (keyx).long | argument = window_call_data_names (keyx).short
145 | argument = window_call_data_names (keyx).undocumented_long
146 | argument = window_call_data_names (keyx).undocumented_short then
147 go to HAVE_KEYX;
148 end;
149
150 call ERROR_REPORTER (error_table_$badopt, ME, "Unrecognized key ""^a"".", argument);
151 go to RETURN;
152
153 HAVE_KEYX:
154 key = window_call_data_names (keyx).long;
155 this_f_ptr = addr (window_call_data_functions (keyx));
156
157 if this_is_an_af & ^this_f.af_allowed then do;
158 call active_fnc_err_ (error_table_$active_function, ME);
159 go to RETURN;
160 end;
161
162
163
164 irep.found (*) = "0"b;
165 irep.arg (*).ptr = null;
166 irep.arg (*).length = 0;
167 irep = this_f.args, by name;
168 irep = window_call_data_ctl_args, by name;
169
170 main_argument_loop:
171 do argx = 2 to n_arguments;
172 call cu_$arg_ptr_rel (argx, argument_ptr, argument_length, (0), arg_list_ptr);
173
174
175
176
177 if character (argument, 1) ^= "-" | length (argument) < 2 then do;
178 call ERROR_REPORTER (error_table_$badopt, ME, "The argument ^a is out of place.", argument);
179 go to RETURN;
180 end;
181
182
183
184
185
186 do ctlx = 1 to window_call_data_$n_ctl_args;
187 if (substr (argument, 2) = window_call_data_ctl_args (ctlx).name.long
188 | substr (argument, 2) = window_call_data_ctl_args (ctlx).name.undocumented_long
189 | substr (argument, 2) = window_call_data_ctl_args (ctlx).name.short
190 | substr (argument, 2) = window_call_data_ctl_args (ctlx).name.undocumented_short)
191 & irep (ctlx).allowed then
192 go to HAVE_CTLX;
193 end;
194
195
196
197 call ERROR_REPORTER (error_table_$badopt, ME, "^a.", argument);
198 go to RETURN;
199
200 HAVE_CTLX:
201 irep (ctlx).found = "1"b;
202
203 if irep (ctlx).argument ^= A_NONE then do;
204
205 argx = argx + 1;
206 save_argument = argument;
207 if argx > n_arguments then do;
208 NOARG:
209 call ERROR_REPORTER (error_table_$noarg, ME,
210 "Control argument ^a requires a ^[^s^;numeric^;string^] parameter.", save_argument,
211 irep (ctlx).argument);
212 go to RETURN;
213 end;
214
215 call cu_$arg_ptr_rel (argx, argument_ptr, argument_length, (0), arg_list_ptr);
216
217 if irep (ctlx).argument = A_NUMBER then do;
218 irep (ctlx).value = cv_dec_check_ (argument, code);
219 if code ^= 0 then do;
220
221 if character (argument, 1) = "-" then
222 go to NOARG;
223
224 if code <= length (argument) then
225 call ERROR_REPORTER (error_table_$bad_conversion, ME,
226 "Converting ^a to an integer.", argument);
227 else call ERROR_REPORTER (code, ME, "Converting ^a to an integer.", argument);
228 go to RETURN;
229 end;
230 end;
231 else do;
232 irep (ctlx).ptr = argument_ptr;
233 irep (ctlx).length = argument_length;
234 end;
235 end;
236 end main_argument_loop;
237
238
239
240
241 do ctlx = 1 to window_call_data_$n_ctl_args;
242 if irep (ctlx).required & ^irep (ctlx).found then do;
243 USAGE:
244 call ERROR_REPORTER (error_table_$noarg, ME, "Usage: window_call ^a ^a.", key,
245 substr (window_call_data_string, this_f.usage.index, this_f.usage.length));
246 go to RETURN;
247 end;
248 end;
249
250
251 ^L
252
253
254
255 go to DO_IT (keyx);
256
257
258
259
260
261
262 DO_IT (1):
263 call get_iocb;
264 call window_$clear_window (iocb_ptr, code);
265 go to CHECK_RETURN;
266
267 DO_IT (2):
268 call get_iocb;
269 call window_$bell (iocb_ptr, code);
270 go to CHECK_RETURN;
271
272 DO_IT (3):
273 call get_iocb;
274
275 if ^irep (C_COLUMN).found then
276 irep (C_COLUMN).value = 1;
277 if ^irep (C_N_COLUMNS).found then do;
278 call get_window_info;
279 irep (C_N_COLUMNS).value = window_info.width - irep (C_COLUMN).value + 1;
280 end;
281 call window_$clear_region (iocb_ptr, irep (C_LINE).value, irep (C_COLUMN).value, irep (C_N_LINES).value,
282 irep (C_N_COLUMNS).value, code);
283 go to CHECK_RETURN;
284
285 DO_IT (4):
286 call get_iocb;
287 call window_$clear_to_end_of_line (iocb_ptr, code);
288 go to CHECK_RETURN;
289
290 DO_IT (5):
291 call get_iocb;
292 call window_$clear_to_end_of_window (iocb_ptr, code);
293 go to CHECK_RETURN;
294
295 DO_IT (6):
296 call get_iocb;
297 call window_$delete_chars (iocb_ptr, irep (C_COUNT).value, code);
298 go to CHECK_RETURN;
299
300 DO_IT (7):
301 begin;
302 declare (l, c) fixed bin;
303
304 call get_iocb;
305 call window_$get_cursor_position (iocb_ptr, l, c, code);
306 if code ^= 0 then
307 go to CHECK_RETURN;
308
309 if this_is_an_af then
310 return_string = ltrim (character (l)) || " " || ltrim (character (c));
311 else call ioa_ ("Line = ^d; Column = ^d.", l, c);
312 go to RETURN;
313 end;
314 ^L
315
316 DO_IT (8):
317 call get ("1"b);
318
319 DO_IT (9):
320 call get ("0"b);
321
322 DO_IT (10):
323 call get_iocb;
324 declare text character (irep (C_STRING).length) based (irep (C_STRING).ptr);
325
326
327 call window_$insert_text (iocb_ptr, text, code);
328 go to CHECK_RETURN;
329
330 DO_IT (11):
331 call get_iocb;
332 call window_$overwrite_text (iocb_ptr, text, code);
333 go to CHECK_RETURN;
334
335 DO_IT (12):
336 call get_iocb;
337 call window_$position_cursor (iocb_ptr, irep (C_LINE).value, irep (C_COLUMN).value, code);
338 go to CHECK_RETURN;
339
340
341 DO_IT (13):
342 call get_iocb;
343 call window_$position_cursor_rel (iocb_ptr, irep (C_LINE).value, irep (C_COLUMN).value, code);
344 go to CHECK_RETURN;
345
346
347 DO_IT (14):
348 call get_iocb;
349 if ^irep (C_LINE).found then
350 irep (C_LINE).value = 1;
351
352 if ^irep (C_N_LINES).found then do;
353 call get_window_info;
354 irep (C_N_LINES).value = window_info.height - irep (C_LINE).value + 1;
355 end;
356
357 call window_$scroll_region (iocb_ptr, irep (C_LINE).value, irep (C_N_LINES).value, irep (C_COUNT).value,
358 code);
359 go to CHECK_RETURN;
360
361 DO_IT (15):
362 call get_iocb;
363 call window_$sync (iocb_ptr, code);
364 go to CHECK_RETURN;
365
366 DO_IT (16):
367 begin;
368 declare buffer character (irep (C_COUNT).value);
369 declare break character (1) varying;
370 declare n_read fixed bin (21);
371 declare prompt character (irep (C_STRING).length) based (irep (C_STRING).ptr);
372
373 call get_iocb;
374 call window_$write_sync_read (iocb_ptr, prompt, length (buffer), buffer, n_read, break, code);
375 if code ^= 0 then
376 go to CHECK_RETURN;
377
378 begin;
379 declare read character (n_read) defined (buffer) position (1);
380 if this_is_an_af then
381 return_string = requote_string_ (read) || " " || requote_string_ ((break));
382 else call ioa_ ("Read = ^a; Break = ^a.", requote_string_ (read), requote_string_ ((break)));
383 end;
384 end;
385 go to RETURN;
386
387
388
389 DO_IT (17):
390 if video_data_$terminal_iocb ^= null () then do;
391 call ERROR_REPORTER (video_et_$wsys_invoked, ME);
392 go to RETURN;
393 end;
394
395 begin options (non_quick);
396 declare reason character (512);
397 declare line_speed fixed bin;
398
399 if irep (C_LINE_SPEED).found then do;
400 line_speed = irep (C_LINE_SPEED).value;
401 if line_speed < 0 then do;
402 call ERROR_REPORTER (error_table_$bad_arg, ME, "^a", "Negative value not allowed for line speed.");
403 go to RETURN;
404 end;
405 end;
406
407 call video_utils_$turn_on_login_channel (code, reason);
408 if code ^= 0 then do;
409 call ERROR_REPORTER (code, ME, "^a", reason);
410 go to RETURN;
411 end;
412
413 if irep (C_LINE_SPEED).found then do;
414 call iox_$control (video_data_$terminal_iocb, "set_line_speed", addr (line_speed), code);
415 if code ^= 0 then
416 go to CHECK_RETURN;
417 end;
418
419 go to RETURN;
420 end;
421
422
423
424 DO_IT (18):
425 call video_utils_$turn_off_login_channel ((0));
426 go to RETURN;
427
428
429
430 DO_IT (19):
431 begin options (non_quick);
432 declare wiocbp pointer;
433 declare 1 wpi aligned like window_position_info;
434 declare switch_name character (irep (C_SWITCH).length) based (irep (C_SWITCH).ptr);
435
436 call iox_$find_iocb (switch_name, wiocbp, code);
437 if code ^= 0 then
438 go to CHECK_RETURN;
439
440 wpi.version = window_position_info_version_1;
441 if irep (C_LINE).found then
442 wpi.origin.line = irep (C_LINE).value;
443 else wpi.origin.line = 1;
444
445 if irep (C_N_LINES).found then
446 wpi.extent.height = irep (C_N_LINES).value;
447 else wpi.extent.height = 0;
448
449 if irep (C_COLUMN).found then
450 wpi.origin.column = irep (C_COLUMN).value;
451 else wpi.origin.column = 0;
452
453 if irep (C_N_COLUMNS).found then
454 wpi.extent.width = irep (C_N_COLUMNS).value;
455 else wpi.extent.width = 0;
456
457 call window_$create (video_data_$terminal_iocb, addr (wpi), wiocbp, code);
458 if code ^= 0 then
459 go to CHECK_RETURN;
460 return;
461
462 end;
463
464 DO_IT (20):
465 call get_iocb;
466
467 call window_$destroy (iocb_ptr, code);
468 if code ^= 0 then
469 go to CHECK_RETURN;
470 return;
471
472 DO_IT (21):
473 call get_iocb;
474 call get_window_info;
475
476
477
478
479
480
481 if ^(irep (C_LINE).found | irep (C_N_LINES).found |
482 irep (C_COLUMN).found | irep (C_N_COLUMNS).found)
483 then go to USAGE;
484
485 if irep (C_LINE).found then
486 window_info.origin.line = irep (C_LINE).value;
487
488 if irep (C_N_LINES).found then
489 window_info.height = irep (C_N_LINES).value;
490 else do;
491 call get_capabilities (video_data_$terminal_iocb);
492 if window_info.origin.line + window_info.height - 1 > ci.rows then
493 window_info.height = ci.rows - window_info.origin.line + 1;
494 end;
495
496 if irep (C_COLUMN).found then
497 window_info.origin.column = irep (C_COLUMN).value;
498
499 if irep (C_N_COLUMNS).found then
500 window_info.width = irep (C_N_COLUMNS).value;
501 else do;
502 call get_capabilities (video_data_$terminal_iocb);
503 if window_info.origin.column + window_info.width - 1 > ci.columns then
504 window_info.width = ci.columns - window_info.origin.column + 1;
505 end;
506
507 call iox_$control (iocb_ptr, "set_window_info", addr (window_info), code);
508 go to CHECK_RETURN;
509
510 DO_IT (22):
511 call get_iocb;
512 call get_window_info;
513 if this_is_an_af then
514 return_string = ltrim (character (window_info.origin.line));
515 else call ioa_ ("First line = ^d.", window_info.origin.line);
516 go to RETURN;
517
518 DO_IT (23):
519 call get_iocb;
520 call get_window_info;
521
522 if this_is_an_af then
523 return_string = ltrim (character (window_info.height));
524 else call ioa_ ("Height = ^d.", window_info.height);
525 go to RETURN;
526
527 DO_IT (24):
528 call get_iocb;
529 call get_window_info;
530
531 if this_is_an_af then
532 return_string = ltrim (character (window_info.width));
533 else call ioa_ ("Width = ^d.", window_info.width);
534 go to RETURN;
535 ^L
536 %include terminal_capabilities;
537 declare 1 ci aligned like capabilities_info;
538
539 DO_IT (25):
540 call get_capabilities (video_data_$terminal_iocb);
541 if this_is_an_af then
542 return_string = ltrim (character (ci.screensize.rows));
543 else call ioa_ ("Terminal Height = ^d rows.", ci.screensize.rows);
544 go to RETURN;
545
546 DO_IT (26):
547 call get_capabilities (video_data_$terminal_iocb);
548 if this_is_an_af then
549 return_string = ltrim (character (ci.screensize.columns));
550 else call ioa_ ("Terminal Width = ^d columns.", ci.screensize.columns);
551 go to RETURN;
552
553 DO_IT (27):
554 call get_iocb;
555 begin;
556 declare one character (1) varying;
557
558 call window_$get_one_unechoed_char (iocb_ptr, one, "1"b, code);
559 if code ^= 0 then
560 go to CHECK_RETURN;
561
562 if this_is_an_af then
563 return_string = requote_string_ ((one));
564 else call ioa_ ("Char = ""^a""", one);
565 return;
566 end;
567
568 DO_IT(28):
569
570 %include terminal_info;
571
572 dcl 1 ti like terminal_info;
573
574 dcl supported_ttp bit(1);
575 dcl ttp_length fixed binary,
576 ttp_ptr pointer;
577 dcl ttp char (ttp_length) based (ttp_ptr);
578
579 dcl ttt_info_$video_info entry (char(*), fixed bin, ptr, ptr, fixed bin(35));
580 dcl error_table_$no_table fixed bin(35) ext static;
581
582 dcl uppercase char (26) static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
583 dcl lowercase char (26) static options (constant) init ("abcdefghijklmnopqrstuvwxyz");
584
585 if irep(C_TERMINAL_TYPE).found then
586 do;
587 ttp_length = irep(C_TERMINAL_TYPE).length;
588 ttp_ptr = irep(C_TERMINAL_TYPE).ptr;
589 end;
590 else
591 do;
592 ti.version = 1;
593 call iox_$control(iox_$user_io, "terminal_info", addr(ti), code);
594 if code ^= 0 then goto CHECK_RETURN;
595 ttp_length = length(ti.term_type);
596 ttp_ptr = addr(ti.term_type);
597 end;
598
599 ttp = translate(ttp, uppercase, lowercase);
600 call ttt_info_$video_info (ttp, (0), null(), null(), code);
601
602 if code ^= 0 & code ^= error_table_$no_table then goto CHECK_RETURN;
603 if code = error_table_$no_table then supported_ttp = "0"b;
604 else supported_ttp = "1"b;
605
606 if this_is_an_af then
607 if supported_ttp then return_string = "true"; else return_string = "false";
608 else
609 call ioa_ ("The ^a terminal type is ^[not ^]supported by the video system.", ttp, ^supported_ttp);
610 goto RETURN;
611
612 DO_IT(29):
613
614 dcl video_invoked bit(1);
615
616 video_invoked = video_data_$terminal_iocb ^= null();
617
618 if this_is_an_af then
619 if video_invoked then return_string = "true"; else return_string = "false";
620 else
621 call ioa_ ("The video system has ^[not ^]been invoked.", ^video_invoked);
622 goto RETURN;
623 ^L
624 get_capabilities:
625 procedure (iocb_ptr);
626
627 declare iocb_ptr ptr;
628
629 ci.version = capabilities_info_version_1;
630 call iox_$control (iocb_ptr, "get_capabilities", addr (ci), code);
631 if code ^= 0 then
632 go to CHECK_RETURN;
633 end get_capabilities;
634
635 get:
636 procedure (echo_flag);
637 declare break character (1) varying;
638 declare buffer character (irep (C_COUNT).value);
639 declare echo_flag bit (1) aligned;
640 declare n_read fixed bin (21);
641
642 call get_iocb;
643
644 if echo_flag then
645 call window_$get_echoed_chars (iocb_ptr, length (buffer), buffer, n_read, break, code);
646 else call window_$get_unechoed_chars (iocb_ptr, length (buffer), buffer, n_read, break, code);
647 if code ^= 0 then
648 go to CHECK_RETURN;
649
650 begin;
651 declare read character (n_read) defined (buffer) pos (1);
652
653 if this_is_an_af then
654 return_string = requote_string_ (read) || " " || requote_string_ ((break));
655 else call ioa_ ("Read = ^a, Break = ^a.", requote_string_ (read), requote_string_ ((break)));
656 end;
657 go to RETURN;
658 end get;
659
660 get_iocb:
661 procedure;
662
663 if ^irep (C_SWITCH).found then
664 iocb_ptr = iox_$user_io;
665 else begin;
666 declare switch_name character (irep (C_SWITCH).length) based (irep (C_SWITCH).ptr);
667
668 call iox_$look_iocb (switch_name, iocb_ptr, code);
669 if code ^= 0 then
670 go to CHECK_RETURN;
671 end;
672 end get_iocb;
673 ^L
674
675 declare 1 window_info aligned like window_position_info;
676
677 get_window_info:
678 procedure;
679
680 window_info.version = window_position_info_version_1;
681 call iox_$control (iocb_ptr, "get_window_info", addr (window_info), code);
682 if code ^= 0 then
683 go to CHECK_RETURN;
684 end get_window_info;
685
686 CHECK_RETURN:
687 if code ^= 0 then
688 call ERROR_REPORTER (code, ME, "(^a)", key);
689 go to RETURN;
690
691 ERROR_REPORTER:
692 procedure options (variable, support);
693
694 declare code fixed bin (35) based (code_ptr);
695 declare code_ptr pointer;
696 declare error_table_$undefined_order_request
697 fixed bin (35) ext static;
698 declare cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
699 declare cu_$generate_call entry (entry, ptr);
700
701 call cu_$arg_ptr (1, code_ptr, (0), (0));
702 if code = error_table_$undefined_order_request then
703 cu_$arg_list_ptr () -> arg_list.arg_ptrs (1) = addr (video_et_$wsys_not_invoked);
704 call cu_$generate_call (error_reporter, cu_$arg_list_ptr ());
705
706 %include arg_list;
707
708 end ERROR_REPORTER;
709
710 end;
711 RETURN:
712 return;
713
714 %page;
715 %include window_call_info_;
716
717 end window_call;