1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    *********************************************************** */
  6 /* format: off */
  7 %skip(3);
  8 /*   This is the main level procedure called by ssu_ to implement the
  9      linus qedx request. Description and usage follows.
 10 
 11      Description:
 12 
 13      This request allows a user to edit the current query or a new query
 14      through the qedx editor.
 15 
 16      Usage: qedx -new | -old
 17 
 18      The control argument -new specifies that the user should start off with
 19      an empty query. The control argument -old specifies that the user should
 20      use the existing query. -old is the default.
 21 
 22      Both parameters are passed to this request by ssu_.
 23 
 24      Known Bugs:
 25 
 26      Other Problems:
 27 
 28      History:
 29 
 30      Written - Al Dupuis - August 1983
 31 
 32 */
 33 %page;
 34 linus_qedx: proc (
 35 
 36           sci_ptr_parm,   /* input: ptr to the subsystem control info structure */
 37           lcb_ptr_parm    /* input: ptr to the linus control block info structure */
 38                          );
 39 %skip(1);
 40 dcl sci_ptr_parm ptr parm;
 41 dcl lcb_ptr_parm ptr parm;
 42 %skip(1);
 43 /*
 44      Mainline Processing Overview:
 45 
 46      (1) Check to make sure a data base is open. Process control args.
 47 
 48      (2) Get the subroutine to qedx the query.
 49 */
 50 %skip(1);
 51           call initialize;
 52 %skip(1);
 53           call linus_qedx_the_query (lcb_ptr, new_or_old_query_flag);
 54 %skip(1);
 55           return;
 56 %page;
 57 initialize: proc;
 58 %skip(3);
 59           sci_ptr = sci_ptr_parm;
 60           lcb_ptr = lcb_ptr_parm;
 61 %skip(1);
 62           if lcb.db_index = 0
 63           then call ssu_$abort_line (sci_ptr, linus_error_$no_db);
 64 %skip(1);
 65           new_or_old_query_flag = OFF;
 66 %skip(1);
 67           call ssu_$arg_count (sci_ptr, number_of_args_supplied);
 68           if number_of_args_supplied = 0
 69           then return;
 70 %skip(1);
 71           do current_arg_number = 1 to number_of_args_supplied;
 72                call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length);
 73                if arg = "-new"
 74                then new_or_old_query_flag = ON;
 75                else if arg = "-old"
 76                     then new_or_old_query_flag = OFF;
 77                     else call ssu_$abort_line (sci_ptr, error_table_$badopt,
 78                          "^/Unrecognized control argument ^a.", arg);
 79           end;
 80 %skip(1);
 81           return;
 82 %skip(1);
 83      end initialize;
 84 %page;
 85 dcl OFF bit (1) aligned static internal options (constant) init ("0"b);
 86 dcl ON bit (1) aligned static internal options (constant) init ("1"b);
 87 %skip(1);
 88 dcl addr builtin;
 89 dcl arg char (arg_length) based (arg_ptr);
 90 dcl arg_length fixed bin (21);
 91 dcl arg_ptr ptr;
 92 %skip(1);
 93 dcl current_arg_number fixed bin;
 94 %skip(1);
 95 dcl error_table_$badopt fixed bin(35) ext static;
 96 %skip(1);
 97 dcl fixed builtin;
 98 %skip(1);
 99 dcl linus_error_$no_db fixed bin(35) ext static;
100 dcl linus_qedx_the_query entry (ptr, bit(1) aligned);
101 %skip(1);
102 dcl new_or_old_query_flag bit (1) aligned;
103 dcl number_of_args_supplied fixed bin;
104 %skip(1);
105 dcl rel builtin;
106 %skip(1);
107 dcl sci_ptr ptr;
108 dcl ssu_$abort_line entry() options(variable);
109 dcl ssu_$arg_count entry (ptr, fixed bin);
110 dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21));
111 dcl sys_info$max_seg_size fixed bin(35) ext static;
112 %page;
113 %include linus_lcb;
114 %skip(3);
115      end linus_qedx;