1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1988                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 query: procedure options (variable);
 14 
 15 
 16 /*
 17    Record of Change:
 18 
 19    Created by Gary C. Dixon  on November 23, 1972
 20    Control arguments -non_null and -accept added by Txom McGary April 1977.
 21    Modified 6/81 by M.R. Jordan to add control arguments.
 22    Modified 9/81 by M.R. Jordan to get the defaults for question and answer IOCB pointers right.
 23    Modified 06/14/84 by S. Herbst to always write on specified IOCB, never on error_output.
 24    ^L
 25    Name:  query
 26 
 27    An active function which asks the user a yes-or-no question.  If the user
 28    answers "yes", then query returns "true".  If the user answers "no", query
 29    returns "false".
 30 
 31    Usage
 32 
 33    [query question-text {-control_args}]
 34 
 35    1) question-text (Input)
 36 
 37    is a character string which forms the text of the question which the
 38    user is asked.
 39 
 40    2) control_arg (Input)
 41 
 42    is one of the following:
 43 
 44    -brief, -bf
 45 
 46    supresses the newline before and spaces after the question.
 47 
 48    -disable_cp_escape, -dcpe
 49 
 50    disables the command processor escape sequence .. as a response.
 51 
 52    -enable_cp_escape, -ecpe
 53 
 54    enables the command processor escape sequence .. as a response.
 55 
 56    -input_switch STR, -isw STR
 57 
 58    specifies the I/O switch over which input is to be requested.
 59 
 60    -long, -lg
 61 
 62    adds leading newline and 3 spaces to question to be asked.
 63 
 64    -output_switch STR, -osw STR
 65 
 66    specifies the I/O switch over which the question is to be output.
 67 
 68    -repeat DT, -rp DT
 69 
 70    repeats teh question every DT is the user does not answer.
 71    ^L
 72    Name:  response
 73 
 74    An active function which asks any question of the user, and returns the
 75    user's response as the value of the active function.
 76 
 77    Usage
 78 
 79    [response question-text {-control_args}]
 80 
 81    1) question-text (Input) is as above.
 82 
 83    2) control_arg may be one of the control arguments listed above for query
 84    or one of the following:
 85 
 86    -non_null
 87 
 88    specifies that a null response is not allowed.
 89 
 90    -accept STR1 ... STRn
 91 
 92    specifies allowable responses.
 93 
 94 
 95    Example
 96 
 97    Assume that the user's start_up.ec contained the following lines:
 98 
 99    &command_line off
100    &print Beginning start_up.
101    abbrev
102    &if [query "start_up:  Do you wish to continue?"] &then &else &quit
103    mail
104    check_info_segs
105    .
106    .
107 
108    Then the following dialogue would cause the start_up.ec to terminate
109    execution after the query:
110 
111    Beginning start_up.
112    start_up.ec:  Do you wish to continue?   !no
113    r 1722  25.797  402+625
114 
115 */
116 
117 
118 /****^  HISTORY COMMENTS:
119   1) change(87-12-17,Gilcrease), approve(88-01-06,MCR7827),
120      audit(88-01-08,Parisek), install(88-01-12,MR12.2-1012):
121                Add the -trim, -no_trim control arguments.
122                                                    END HISTORY COMMENTS */
123 
124 ^L
125 /*                  CONSTANTS                     */
126 
127 dcl  NAME (2) char (8) static options (constant) init ("query", "response");
128 dcl  QUERY fixed bin static options (constant) init (1);
129 dcl  RESPONSE fixed bin static options (constant) init (2);
130 
131 /*                  AUTOMATIC                     */
132 
133 dcl  accept_null bit (1);
134 dcl  arg_len fixed bin;
135 dcl  arg_list_ptr ptr;
136 dcl  arg_ptr ptr;
137 dcl  argn fixed bin;
138 dcl  called_as_active_function bit (1);
139 dcl  code fixed bin (35);
140 dcl  entry_point fixed bin;
141 dcl  error entry options (variable) variable;
142 dcl  error_has_occured bit (1);
143 dcl  first_acceptable_arg fixed bin;
144 dcl  get_arg entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr) variable;
145 dcl  max_length fixed bin;
146 dcl  nargs fixed bin;
147 dcl  no_trim bit (1);
148 dcl  print_iocbp ptr;
149 dcl  question_len fixed bin;
150 dcl  question_ptr ptr;
151 dcl  rtn_string_ptr ptr;
152 dcl  temp_string char (512) varying;
153 
154 dcl 1 my_query_info like query_info;
155 
156 /*                  BASED                         */
157 
158 dcl  answer char (max_length) varying based (rtn_string_ptr);
159 dcl  arg char (arg_len) based (arg_ptr);
160 dcl  question char (question_len) based (question_ptr);
161 
162 dcl 1 open_descrip aligned based,
163     2 length fixed bin (17),
164     2 string char (0 refer (open_descrip.length));
165 
166 /*                  ERROR CODES                   */
167 
168 dcl  error_table_$bad_arg fixed bin (35) static ext;
169 dcl  error_table_$badopt fixed bin (35) static ext;
170 dcl  error_table_$noarg fixed bin (35) static ext;
171 dcl  error_table_$not_act_fnc fixed bin (35) static ext;
172 dcl  error_table_$not_open fixed bin (35) static ext;
173 
174 /*                  EXTERNAL ENTRIES              */
175 
176 dcl  active_fnc_err_ entry options (variable);
177 dcl  com_err_ entry options (variable);
178 dcl  command_query_ entry options (variable);
179 dcl  convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35));
180 dcl  cu_$af_arg_count entry (fixed bin, fixed bin (35));
181 dcl  cu_$af_arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
182 dcl  cu_$af_return_arg ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
183 dcl  cu_$arg_list_ptr entry (ptr);
184 dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
185 dcl  ioa_ entry options (variable);
186 dcl  ioa_$ioa_switch ext entry options (variable);
187 dcl  iox_$look_iocb entry (char (*), ptr, fixed bin (35));
188 dcl  iox_$user_io ptr ext;
189 
190 /*                  BUILTIN FUNCTIONS             */
191 
192 dcl  addr builtin;
193 dcl  clock builtin;
194 dcl  divide builtin;
195 dcl  maxlength builtin;
196 dcl  null builtin;
197 dcl  substr builtin;
198 ^L
199 %include iocb;
200 ^L
201 %include query_info;
202 ^L
203           entry_point = QUERY;
204           go to COMMON;
205 
206 
207 response: entry options (variable);
208 
209           entry_point = RESPONSE;
210 
211 
212 COMMON:
213 
214           call cu_$af_arg_count (nargs, code);
215           if code = error_table_$not_act_fnc
216           then do;
217                called_as_active_function = "0"b;
218                rtn_string_ptr = addr (temp_string);
219                max_length = maxlength (temp_string);
220                get_arg = cu_$arg_ptr_rel;
221                error = com_err_;
222           end;
223           else if code = 0
224           then do;
225                called_as_active_function = "1"b;
226                call cu_$af_return_arg (nargs, rtn_string_ptr, max_length, code);
227                if code ^= 0
228                then do;
229                     call active_fnc_err_ (code, (NAME (entry_point)));
230                     return;
231                end;
232                get_arg = cu_$af_arg_ptr_rel;
233                error = active_fnc_err_;
234           end;
235           else do;
236                error = active_fnc_err_;
237 
238 
239 USAGE:
240 
241                call error (code, (NAME (entry_point)),
242                     "^/Usage: ^[[^]^a question {-control_args}^[]^]",
243                     called_as_active_function, (NAME (entry_point)),
244                     called_as_active_function);
245                return;
246           end;
247           if nargs < 1
248           then do;
249                code = error_table_$noarg;
250                goto USAGE;
251           end;
252 
253 
254           call cu_$arg_list_ptr (arg_list_ptr);
255 
256 
257           call get_arg (1, question_ptr, question_len, code, arg_list_ptr);
258           if code ^= 0
259           then do;
260                call error (code, (NAME (entry_point)),
261                     "Referencing first argument.");
262                return;
263           end;
264 
265           accept_null = "1"b;
266           answer = "";
267           error_has_occured = "0"b;
268           first_acceptable_arg = 0;
269           no_trim = "0"b;
270 
271 
272           my_query_info.version = query_info_version_5;
273           my_query_info.switches.yes_or_no_sw = (entry_point = QUERY);
274           my_query_info.switches.suppress_name_sw = "1"b;
275           my_query_info.switches.cp_escape_control = "00"b;
276           my_query_info.switches.suppress_spacing = "0"b;
277           my_query_info.switches.padding = ""b;
278           my_query_info.status_code = 0;
279           my_query_info.query_code = 0;
280           my_query_info.question_iocbp = null ();
281           my_query_info.answer_iocbp = null ();
282           my_query_info.repeat_time = 0;
283           my_query_info.explanation_ptr = null ();
284           my_query_info.explanation_len = 0;
285 
286 
287           call Process_Control_Args (2);
288           if error_has_occured
289           then return;
290 
291           print_iocbp = my_query_info.question_iocbp;
292           if print_iocbp = null then print_iocbp = iox_$user_io;
293 
294 
295 ASK:
296 
297           if no_trim then call command_query_ (addr (my_query_info), answer, (NAME (entry_point)),
298                "^va", question_len, question);
299           else call command_query_ (addr (my_query_info), answer, (NAME (entry_point)),
300                "^a", question);
301           goto PROCESS (entry_point);
302 
303 
304 PROCESS (1):                                                /* QUERY */
305 
306           if answer = "yes"
307           then answer = "true";
308           else answer = "false";
309 
310 
311 EXIT:
312 
313           if ^called_as_active_function
314           then call ioa_ ("^a", answer);
315           return;
316 
317 
318 PROCESS (2):                                                /* RESPONSE */
319 
320           if ^accept_null & answer = ""
321           then do;
322                call ioa_$ioa_switch (print_iocbp,
323                     "^a:  Null response not allowed, please retype.",
324                     (NAME (entry_point)));
325                goto ASK;
326           end;
327 
328           if first_acceptable_arg = 0
329           then goto EXIT;
330 
331           do argn = first_acceptable_arg to nargs by 1;
332                call Get_Arg (argn, "");
333                if answer = arg
334                then goto EXIT;
335           end;
336           call ioa_$ioa_switch (print_iocbp,
337                "^a:  '^a' is not an acceptable answer.^/Acceptable answers are:",
338                (NAME (entry_point)), answer);
339           do argn = first_acceptable_arg to nargs;
340                call Get_Arg (argn, "");
341                call ioa_$ioa_switch (print_iocbp, "^-'^a'", arg);
342           end;
343           goto ASK;
344 ^L
345 Process_Control_Args: procedure (first_argn);
346 
347 
348 dcl  first_argn fixed bin;
349 dcl  argn fixed bin;
350 
351 
352                do argn = first_argn repeat argn+1 while (argn <= nargs);
353 
354                     call Get_Arg (argn, "");
355 
356                     if arg = "-accept" & entry_point = RESPONSE
357                     then do;
358                          first_acceptable_arg = argn+1;
359                          if first_acceptable_arg > nargs
360                          then do;
361                               call error (error_table_$noarg, (NAME (entry_point)),
362                                    "Missing argument(s) following -accept.");
363                               error_has_occured = "1"b;
364                          end;
365                          argn = nargs;
366                     end;
367 
368                     else if arg = "-brief" | arg = "-bf"
369                     then my_query_info.switches.suppress_spacing = "1"b;
370 
371                     else if arg = "-no_trim" then no_trim = "1"b;
372 
373                     else if arg = "-trim" then no_trim = "0"b;
374 
375                     else if arg = "-disable_cp_escape" | arg = "-dcpe"
376                     then my_query_info.switches.cp_escape_control = "10"b;
377 
378                     else if arg = "-enable_cp_escape" | arg = "-ecpe"
379                     then my_query_info.switches.cp_escape_control = "11"b;
380 
381                     else if arg = "-input_switch" | arg = "-isw"
382                     then do;
383                          call Get_Arg (argn+1,
384                               "Missing I/O switch name following " || arg);
385                          if addr (arg) ^= null ()
386                          then my_query_info.answer_iocbp = IOCBp (arg, "1"b);
387                          argn = argn+1;
388                     end;
389 
390                     else if arg = "-long" | arg = "-lg"
391                     then my_query_info.switches.suppress_spacing = "0"b;
392 
393                     else if arg = "-non_null" & entry_point = RESPONSE
394                     then accept_null = "0"b;
395 
396                     else if arg = "-output_switch" | arg = "-osw"
397                     then do;
398                          call Get_Arg (argn+1,
399                               "Missing I/O switch name following " || arg);
400                          if addr (arg) ^= null ()
401                          then my_query_info.question_iocbp = IOCBp (arg, "0"b);
402                          argn = argn+1;
403                     end;
404 
405                     else if arg = "-repeat" | arg = "-rp"
406                     then do;
407                          call Get_Arg (argn+1,
408                               "Missing repeat interval following " || arg);
409                          if addr (arg) ^= null ()
410                          then my_query_info.repeat_time = Date_Time (arg);
411                          argn = argn+1;
412                     end;
413 
414                     else do;
415                          call error (error_table_$badopt, (NAME (entry_point)),
416                               "^a", arg);
417                          error_has_occured = "1"b;
418                     end;
419 
420                end;
421 
422 
423                return;
424 ^L
425 IOCBp:         procedure (switch_name, input_flag) returns (ptr);
426 
427 
428 dcl  input_flag bit (1);
429 dcl  iocbp ptr;
430 dcl  switch_name char (*);
431 
432 
433                     call iox_$look_iocb (switch_name, iocbp, code);
434                     if code ^= 0
435                     then do;
436                          call error (code, (NAME (entry_point)), "^a", switch_name);
437                          error_has_occured = "1"b;
438                          return (null ());
439                     end;
440 
441                     if iocbp -> iocb.open_descrip_ptr = null ()
442                     then do;
443                          call error (error_table_$not_open, (NAME (entry_point)),
444                               "^a", switch_name);
445                          error_has_occured = "1"b;
446                          return (null ());
447                     end;
448 
449                     if substr (iocbp -> iocb.open_descrip_ptr -> open_descrip.string, 1, 19) = "stream_input_output"
450                     then return (iocbp);
451                     if substr (iocbp -> iocb.open_descrip_ptr -> open_descrip.string, 1, 12) = "stream_input" & input_flag
452                     then return (iocbp);
453                     if substr (iocbp -> iocb.open_descrip_ptr -> open_descrip.string, 1, 13) = "stream_output" & ^input_flag
454                     then return (iocbp);
455 
456 
457                     call error (0, (NAME (entry_point)),
458                          "I/O switch ^a not open for stream_^[input^;output^] or stream_input_output.",
459                          switch_name, input_flag);
460                     error_has_occured = "1"b;
461                     return (null ());
462 
463 
464                end IOCBp;
465 ^L
466 Date_Time:     procedure (date_time_string) returns (fixed bin (71));
467 
468 
469 dcl  current_date_time fixed bin (71);
470 dcl  date_time fixed bin (71);
471 dcl  date_time_string char (*);
472 
473 
474                     current_date_time = clock ();
475                     call convert_date_to_binary_$relative (date_time_string,
476                          date_time, current_date_time, code);
477                     date_time = divide ((date_time-current_date_time), 1000000, 71, 0);
478 
479                     if code ^= 0
480                     then do;
481                          call error (code, (NAME (entry_point)),
482                               "Converting ""^a"" to binary date/time.",
483                               date_time_string);
484                          error_has_occured = "1"b;
485                          return (0);
486                     end;
487                     else if date_time < 30                  /* 30 seconds */
488                     then do;
489                          call error (error_table_$bad_arg, (NAME (entry_point)),
490                               "Specified date/time is not ^[far enough ^]in the future.  ^a",
491                               (date_time > 0), date_time_string);
492                          error_has_occured = "1"b;
493                          return (0);
494                     end;
495 
496 
497                     return (date_time);
498 
499 
500                end Date_Time;
501 
502 
503           end Process_Control_Args;
504 ^L
505 Get_Arg:  procedure (argn, mess);
506 
507 
508 dcl  argn fixed bin;
509 dcl  mess char (*);
510 
511 
512                call get_arg (argn, arg_ptr, arg_len, code, arg_list_ptr);
513                if code = 0
514                then return;
515 
516 
517                call error (code, (NAME (entry_point)),
518                     "^[Refencing argument ^d^s^;^s^a^].",
519                     (mess = ""), argn, mess);
520 
521 
522                arg_ptr = null ();
523                arg_len = 0;
524                error_has_occured = "1"b;
525 
526 
527                return;
528 
529 
530           end Get_Arg;
531 
532 
533      end query;