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-06,Leskiw), approve(90-10-05,MCR8202),
 16      audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039):
 17      Changes calls to assign_round_ from assign_ so that rounding is performed
 18      on input values from user.
 19                                                    END HISTORY COMMENTS */
 20 
 21 
 22 linus_modify:
 23      proc (sci_ptr, lcb_ptr);
 24 
 25 /*  DESCRIPTION:
 26 
 27    This  request  modifies selected data in the data base.  Data to be modified
 28    must be contained within one table, and key columns cannot be modified.
 29 
 30 
 31 
 32    HISTORY:
 33 
 34    77-05-01 J. C. C. Jagernauth: Initially written.
 35 
 36    78-11-01  J.   C.   C.   Jagernauth: Modified to improve expression parsing.
 37    This  request  now does all quote stripping and all expressions are required
 38    to be parenthesized.
 39 
 40    80-02-05  Rickie  E.  Brinegar: Modified to permit null strings as arguments
 41    for character and varying bit string modifies.
 42 
 43    80-02-06  Rickie  E.   Brinegar:  Modified to initialize sel_info.se_vals so
 44    that .V.  arguments would be passed to mrds.
 45 
 46    80-03-14  Rickie  E.   Brinegar:  Modified  to  use  a  work area defined on
 47    lcb.linus_area_ptr instead of getting system free area.
 48 
 49    80-08-15  Rickie E.  Brinegar: Modified to fix some varying character string
 50    code to permit modifies of varying character strings.
 51 
 52    81-02-02  Rickie  E.   Brinegar:  The  declaration  for  the internal static
 53    debug_switch was moved from db_on entry to the main entry.
 54 
 55    81-02-20  Rickie E.  Brinegar: Changed the calls to mdb_display_value_ to be
 56    calls  to  mdb_display_data_value$ptr.   The  latter  allows  more  than 256
 57    characters to be displayed.
 58 
 59    81-06-25 Rickie E.  Brinegar: Changed to not attempt to use linus_variables
 60    when  the  linus  variable list pointer is null.  This is in response to TR
 61    10194.
 62 
 63    81-07-10   Rickie   E.    Brinegar:   Modified  to  not  assign  values  to
 64    sel_info.mrds_items  until after all expressions have been evaluated.  This
 65    permits  the  use  of  multiple  column specs in a expression, and avoids a
 66    Halloween effect.
 67 
 68    81-07-13 Rickie E.  Brinegar: Removed trapping of the conversion condition.
 69    This is done in the linus module.
 70 
 71    81-07-14  Rickie  E.   Brinegar:  Removed  the  useless cleanup handler and
 72    unreferenced variables.
 73 
 74    81-09-28 Davids: Changed the check for "!" from a substr to an index in the
 75    not_expr proc.
 76 
 77    81-11-16 Rickie E.  Brinegar: changed the call to cu_$gen_call to a call to
 78    cu_$generate_call  and  added  the  timing  of the calls to dsl_$modify and
 79    dsl_$retrieve.
 80 
 81    82-02-10 Paul W. Benjamin: ssu_ conversion.  This program ranks with the
 82    invoke request in the magnitude of the headaches that it caused in the
 83    conversion.  It allows its input to contain parens.  This convention caused
 84    the creation of the 'iteration mode'.  Further, it expected a parenthesized
 85    list to be a single argument.  With iteration on (not the default at this
 86    time) there is no problem, as the user had to quote the argument to get the
 87    parens in anyway, but with iteration off, the parenthesized list may well
 88    be several arguments.  Some rather clumsy code was implemented herein to
 89    get around that particular problem.
 90 
 91    82-06-23 Dave J. Schimke: cleaned up the code associated with the above
 92    mentioned conversion (from a parenthesized list to a single argument).
 93    This was done to clarify the code and remove standards violations.
 94 
 95    82-07-02 Dave J. Schimke: Added simple_arg to fix a stringrange_error.
 96 
 97    82-09-03 Dave Schimke: Added a call to dsl_$get_pn to get the opening
 98    mode and report an error if user tries to modify with a retrieval opening.
 99    Declared mode, db_path, dsl_$get_path, and linus_error_$update_not_valid.
100    This is in response to phx 13742.
101 
102    82-10-13 Dave Schimke: Added call to linus_table$async_retrieval before the
103    first retrieve to keep linus_table from getting lost when loading in the
104    incremental mode.
105 
106    83-01-11 Dave Schimke: Replaced calls to linus_ok_response with calls to
107    linus_query. Deleted references to error_table_$long_record, out_code,
108    nread, buff_len, and linus_data_$m_id. Declared input, linus_query, prompt,
109    prompt_len, linus_query$yes_no, and length. This is an fix for the ssu
110    conversion which broke input from the terminal during a linus macro and
111    answers TRs 12445 &  13342 (linus 73). Also changed arg_len_bits.length to
112    arg_len_bits.len.
113 
114    83-08-30  Bert Moberg:  Added call to linus_translate_query$auto if no current
115    select expression is available
116 */
117 ^L
118 %include linus_lcb;
119 %page;
120 %include linus_char_argl;
121 %page;
122 %include linus_variables;
123 %page;
124 %include linus_select_info;
125 %page;
126 %include mdbm_arg_list;
127 %page;
128 %include linus_arg_list;
129 %page;
130 %include linus_token_data;
131 %page;
132 %include linus_expression;
133 ^L
134           dcl     sci_ptr                ptr;               /* for ssu_ */
135 
136           dcl     1 sel_info             aligned based (sel_ptr) like select_info;
137           dcl     C_R                    char (1) int static options (constant) init ("
138 ");
139           dcl     DATA_BASE              fixed bin (3) int static options (constant) init (6);
140           dcl     EXPR                   fixed bin (2) int static options (constant) init (2);
141           dcl     debug_switch           bit (1) int static init ("0"b);
142 
143           dcl     1 arg_len_bits         based,
144                     2 pad                bit (12) unal,
145                     2 len                bit (24) unal;     /* Length of argument to be passed in system standard arg list */
146 
147           dcl     combined_arg_idx       (linus_data_$max_req_args) bit (1)
148                                          based (combined_arg_idx_ptr); /* map of allocated combined_args */
149           dcl     combined_arg           char
150                                          (mod_ch_argl.arg.arg_len (mod_ch_argl.nargs)) based; /* parenthesized list */
151 
152           dcl     input_arg              char (char_argl.arg.arg_len (input_arg_num))
153                                          based (char_argl.arg.arg_ptr (input_arg_num)); /* template for arg in char_argl */
154           dcl     input_buffer           (linus_data_$buff_len) char (1) based (in_buf_ptr);
155                                                             /* Max length of input buffer */
156           dcl     input                  char(linus_data_$buff_len) var;
157           dcl     prompt char(40) var;
158           dcl     prompt_len fixed bin;
159 
160           dcl     mod_buf                char (mb_len) based (mb_ptr);
161           dcl     mod_curr               char (linus_data_$buff_len);
162           dcl     sel_expr               char (sel_info.se_len) based (sel_info.se_ptr);
163           dcl     tmp_buf                char (tb_len) based (tb_ptr);
164           dcl     tmp_char               char (mod_ch_argl.arg.arg_len (i))
165                                          based (mod_ch_argl.arg.arg_ptr (i));
166 
167           dcl     (interactive, expr_found, bf_flag, yes_no_flag, found_end_paren, simple_arg) bit (1);
168 
169           dcl     offset                 (10) bit (1) based;
170 
171           dcl     (ano_curr_len, caller, desc, i, in_buf_index, input_arg_num, k, l, m,
172                   mb_len, source_type, tb_len, temp) fixed bin;
173 
174           dcl     initial_mrds_vclock    float bin (63);
175           dcl     db_path                char (168) var;
176           dcl     mode                   char (20);
177 
178           dcl     ANOTHER                char (8) init ("-another");
179           dcl     CURRENT                char (8) init ("-current");
180           dcl     NL                     char(1) int static options (constant) init ("
181 ");
182 
183           dcl     (code, icode, mod_lit_offset, source_len) fixed bin (35);
184 
185           dcl     cleanup                condition;
186 
187           dcl     (addr, addrel, after, before, fixed, index, length, null, rel, rtrim, string, substr, unspec, vclock)
188                                          builtin;
189 
190           dcl     (
191                   interactive_ptr        init (null),
192                   in_buf_ptr             init (null),
193                   mb_ptr                 init (null),
194                   tb_ptr                 init (null),
195                   mod_ch_ptr             init (null),
196                   destination_ptr        init (null),
197                   start_ptr              init (null),
198                   mod_lit_ptr            init (null),
199                   arg_l_ptr              init (null),
200                   re_ptr                 init (null),
201                   sel_ptr                init (null),
202                   renv_ptr               init (null),
203                   e_ptr                  init (null),
204                   env_ptr                init (null),
205                   combined_arg_idx_ptr   init (null)
206                   )                      ptr;
207 
208           dcl     1 arg_l                like arg_list based (arg_l_ptr);
209 
210           dcl     (
211                   linus_data_$buff_len,
212                   linus_data_$max_req_args,
213                   linus_error_$bad_num_args,
214                   linus_error_$linus_var_not_defined,
215                   linus_error_$mod_not_valid,
216                   linus_error_$no_db,
217                   linus_error_$null_input,
218                   linus_error_$unbal_parens,
219                   linus_error_$update_not_allowed,
220                   mrds_error_$tuple_not_found,
221                   sys_info$max_seg_size
222                   )                      fixed bin (35) ext;
223 
224           dcl     1 mod_ch_argl          aligned based (mod_ch_ptr), /* like char_argl */
225                     2 nargs              fixed bin,
226                     2 arg                (nargs_init refer (mod_ch_argl.nargs)),
227                       3 arg_ptr          ptr,
228                       3 arg_len          fixed bin;
229 
230           dcl     work_area              area (sys_info$max_seg_size) based (lcb.linus_area_ptr);
231 
232           dcl     assign_round_
233                                          entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
234           dcl     cu_$generate_call      entry (entry, ptr);
235           dcl     dsl_$get_pn            entry (fixed bin (35), char (168) var, char (20), fixed bin (35));
236           dcl     dsl_$modify            entry options (variable);
237           dcl     dsl_$retrieve          entry options (variable);
238           dcl     ioa_                   entry options (variable);
239           dcl     ioa_$nnl               entry options (variable);
240           dcl     ioa_$rsnnl             entry() options(variable);
241           dcl     linus_eval_expr
242                                          entry (ptr, ptr, ptr, fixed bin, fixed bin, fixed bin (35));
243           dcl     linus_modify_build_expr_tab
244                                          entry (ptr, ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35), ptr,
245                                          fixed bin (35));
246           dcl     linus_query            entry (ptr, char(*) var, char(*) var);     /* Linus subroutines */
247           dcl     linus_query$yes_no     entry (ptr,bit(1), char(*) var);
248           dcl     linus_table$async_retrieval
249                                          entry (ptr, fixed bin (35));
250           dcl     linus_translate_query$auto       entry (ptr, ptr);
251           dcl     mdb_display_data_value$ptr entry (ptr, ptr);
252 
253           dcl     (
254                   mdbm_util_$character_data_class,
255                   mdbm_util_$varying_data_class
256                   )                      entry (ptr) returns (bit (1));
257           dcl     ssu_$abort_line        entry options (variable);
258           dcl     ssu_$arg_count         entry (ptr, fixed bin);
259           dcl     ssu_$arg_ptr           entry (ptr, fixed bin, ptr, fixed bin (21));
260 ^L
261           mod_lit_ptr, sel_ptr, mod_ch_ptr, arg_l_ptr, ex_ptr, char_ptr, mb_ptr,
262                in_buf_ptr, ca_ptr, al_ptr = null;
263 
264           mb_len, icode, code = 0;
265           ano_curr_len = 8;
266           in_buf_index = 1;
267           yes_no_flag = "1"b;
268           interactive, expr_found, bf_flag = "0"b;
269           source_type = 42;
270           caller = 1;
271           nargs_init = linus_data_$max_req_args;
272           allocate mod_ch_argl in (work_area);
273           allocate token_data in (work_area);
274           token_data.mvar, token_data.lvar = "";
275           mod_ch_argl.nargs = 0;
276 
277           if lcb.db_index = 0 then
278                call error (linus_error_$no_db);
279           call dsl_$get_pn (lcb.db_index, db_path, mode, code);
280           if substr (mode, 1, 9) = "retrieval" | substr (mode, 11, 9) = "retrieval" then
281                call error (linus_error_$update_not_allowed);
282           if lcb.si_ptr = null then call linus_translate_query$auto (sci_ptr, lcb_ptr); /* try translating it */
283           if lcb.si_ptr = null then return; /* No good?  Oh, well */
284 
285           si_ptr = lcb.si_ptr;
286           nsv_init = select_info.nsevals;
287           nmi_init = select_info.n_mrds_items;
288           nui_init = select_info.n_user_items;
289           allocate sel_info in (work_area);
290           destination_ptr = sel_ptr;
291 
292           sel_info.se_flags.val_mod = select_info.se_flags.val_mod;
293                                                             /* init sel_info */
294           sel_info.se_ptr = select_info.se_ptr;
295           sel_info.se_len = select_info.se_len;
296           sel_info.nsevals = select_info.nsevals;
297           sel_info.n_mrds_items = select_info.n_mrds_items;
298           sel_info.n_user_items = select_info.n_user_items;
299           do i = 1 to sel_info.nsevals;
300                sel_info.se_vals.arg_ptr (i) = select_info.se_vals.arg_ptr (i);
301                sel_info.se_vals.desc_ptr (i) = select_info.se_vals.desc_ptr (i);
302           end;
303           do i = 1 to sel_info.n_mrds_items;
304                sel_info.mrds_item.arg_ptr (i) = select_info.mrds_item.arg_ptr (i);
305                sel_info.mrds_item.bit_len (i) = select_info.mrds_item.bit_len (i);
306                sel_info.mrds_item.desc (i) = select_info.mrds_item.desc (i);
307                sel_info.mrds_item.assn_type (i) = select_info.mrds_item.assn_type (i);
308                sel_info.mrds_item.assn_len (i) = select_info.mrds_item.assn_len (i);
309           end;
310           do i = 1 to sel_info.n_user_items;
311                sel_info.user_item.name (i) = select_info.user_item.name (i);
312                sel_info.user_item.item_type (i) = select_info.user_item.item_type (i);
313                sel_info.user_item.rslt_desc (i) = select_info.mrds_item.desc (i);
314                sel_info.user_item.item_ptr (i) = select_info.user_item.item_ptr (i);
315           end;
316           lv_ptr = lcb.lv_ptr;                              /* Init linus_variables pointer */
317           if ^sel_info.se_flags.val_mod then
318                call error (linus_error_$mod_not_valid);
319           in_buf_ptr = null;
320           call ssu_$arg_count (sci_ptr, nargs_init);
321           if nargs_init = 0 then /* No arguments passed */
322                call interactive_modify;                     /* Data must be obtained interactively */
323           else do;
324                     allocate char_argl in (lcb.static_area);
325                     on cleanup begin;
326                               if ca_ptr ^= null
327                               then free char_argl;
328                               if combined_arg_idx_ptr ^= null
329                               then do i = 1 to linus_data_$max_req_args;
330                                         if combined_arg_idx (i)
331                                         then free mod_ch_argl.arg.arg_ptr (i) -> combined_arg;
332                                    end;
333                          end;
334                     do i = 1 to nargs_init;
335                          call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i));
336                     end;
337 
338 /* The following do-group exists solely for the purpose of putting multiple args
339    that comprise a parenthesized list into a new, single argument.  It is only
340    a problem when the user has iteration-mode off.  If it is on, the user has to
341    quote a parenthesized list in which case it is a single argument anyway.  The
342    programmer was suffering from a singular lack of creativity when this was
343    done.  Works, though.
344 */
345                     if ^lcb.iteration
346                     then do;
347                               mod_ch_argl.nargs = 0;
348                               do i = 1 to nargs_init;
349                                    simple_arg = "0"b;
350                                    input_arg_num = i;
351                                    if (char_argl.arg.arg_len (i) = 0)
352                                    then simple_arg = "1"b;
353                                    else if (substr (input_arg, 1, 1) = "(") & (substr (input_arg, char_argl.arg.arg_len (i), 1) ^= ")")
354                                    then do;                 /* beginning of parenthesized list */
355                                              found_end_paren = "0"b;
356                                              do k = i to nargs_init while (^found_end_paren);
357                                                   input_arg_num = k;
358                                                   if substr (input_arg, char_argl.arg.arg_len (k), 1) = ")"
359                                                   then do;  /* when ending paren found */
360                                                             found_end_paren = "1"b;
361                                                             mod_ch_argl.nargs = mod_ch_argl.nargs + 1;
362                                                             mod_ch_argl.arg.arg_len (mod_ch_argl.nargs) = 0;
363                                                             do l = i to k; /* accumulate lengths */
364                                                                  mod_ch_argl.arg.arg_len (mod_ch_argl.nargs)
365                                                                       = mod_ch_argl.arg.arg_len (mod_ch_argl.nargs)
366                                                                       + char_argl.arg.arg_len (l) + 1;
367                                                             end;
368                                                             mod_ch_argl.arg.arg_len (mod_ch_argl.nargs)
369                                                                  = mod_ch_argl.arg.arg_len (mod_ch_argl.nargs) - 1;
370                                                             if combined_arg_idx_ptr = null
371                                                             then do;
372                                                                       allocate combined_arg_idx in (lcb.static_area);
373                                                                       unspec (combined_arg_idx) = "0"b;
374                                                                  end;
375                                                             allocate combined_arg set (mod_ch_argl.arg.arg_ptr (mod_ch_argl.nargs)) in (lcb.static_area);
376                                                             combined_arg_idx (mod_ch_argl.nargs) = "1"b;
377                                                             mod_ch_argl.arg.arg_ptr (mod_ch_argl.nargs) -> combined_arg = "";
378                                                             do l = i to k; /* create new arg_list */
379                                                                  input_arg_num = l;
380                                                                  if l = i
381                                                                  then mod_ch_argl.arg.arg_ptr (mod_ch_argl.nargs) -> combined_arg
382                                                                            = input_arg;
383                                                                  else mod_ch_argl.arg.arg_ptr (mod_ch_argl.nargs) -> combined_arg =
384                                                                            rtrim (mod_ch_argl.arg.arg_ptr (mod_ch_argl.nargs) -> combined_arg) || " " || input_arg;
385                                                             end;
386                                                        end;
387                                              end;
388 
389                                              if found_end_paren = "0"b
390                                              then call error (linus_error_$unbal_parens);
391                                              else i = k;
392                                         end;                /* end parenthesized list */
393                                    else simple_arg = "1"b;
394                                    if (simple_arg) then do; /* vanilla argument */
395                                              mod_ch_argl.nargs = mod_ch_argl.nargs + 1;
396                                              mod_ch_argl.arg.arg_len (mod_ch_argl.nargs) = char_argl.arg.arg_len (i);
397                                              mod_ch_argl.arg.arg_ptr (mod_ch_argl.nargs) = char_argl.arg.arg_ptr (i);
398                                         end;
399                               end;
400                          end;
401                     else mod_ch_argl = char_argl;           /* iteration on */
402 
403                     i = mod_ch_argl.nargs;                  /* is last input arg "-bf" ? */
404                     if tmp_char = "-brief" | tmp_char = "-bf" then do;
405                               bf_flag = "1"b;               /* brief mode */
406                               mod_ch_argl.nargs = mod_ch_argl.nargs - 1; /* Remove "-brief" or "-bf" from char argl */
407                          end;
408                     if mod_ch_argl.nargs = 0 then
409                          call interactive_modify;
410                     else do;
411 
412 /* place input arguments in buffer to be used by this request only */
413                               do i = 1 to mod_ch_argl.nargs;
414                                    mb_len = mb_len + mod_ch_argl.arg_len (i) + 1;
415                               end;
416                               mb_len = mb_len + 1;          /* for carriage return */
417                               allocate mod_buf in (work_area);
418                               mod_buf = "";
419                               tb_ptr = mb_ptr;
420                               do i = 1 to mod_ch_argl.nargs;
421                                    tb_len = mod_ch_argl.arg_len (i);
422                                    tmp_buf = tmp_char;
423                                    mod_ch_argl.arg_ptr (i) = tb_ptr;
424                                    do k = 1 to tb_len + 1;  /* bump ptr into the output buffer */
425                                         tb_ptr = addr (tb_ptr -> offset (10));
426                                    end;
427                               end;
428                               tb_len = 1;
429                               tmp_buf = C_R;                /* place carriage return at end of line */
430 
431                               call bf_modify;
432                          end;
433                end;
434 
435           if ca_ptr ^= null
436           then free char_argl;
437           if combined_arg_idx_ptr ^= null
438           then do i = 1 to linus_data_$max_req_args;
439                     if combined_arg_idx (i)
440                     then free mod_ch_argl.arg.arg_ptr (i) -> combined_arg;
441                end;
442           return;
443 ^L
444 db_on:
445      entry;
446 
447 /* Usage:
448    linus_modify$db_on
449 
450    Turns on a switch which causes the value of the current
451    selection expression to be displayed at the terminal.
452 */
453 
454           debug_switch = "1"b;
455           return;
456 %skip (10);
457 db_off:
458      entry;
459 
460 /* Usage:
461    linus_modify$db_off
462 
463    Turns off the switch which causes the value of the current
464    selection expression to be displayed at the terminal.
465 */
466 
467           debug_switch = "0"b;
468           return;
469 ^L
470 interactive_modify:
471      proc;
472 
473           call ioa_ ("");
474           interactive = "1"b;
475           allocate input_buffer in (work_area);
476           do l = 1 to sel_info.n_user_items;
477                interactive_ptr = addr (input_buffer (in_buf_index));
478                call ioa_$rsnnl (" ^a?   ", prompt, prompt_len, sel_info.user_item.name (l));
479                call linus_query (lcb_ptr, input, prompt);
480                substr (string(input_buffer), in_buf_index, length (input)) = input;
481                mod_ch_argl.nargs = mod_ch_argl.nargs + 1;   /* Increment number of arguments */
482                mod_ch_argl.arg.arg_len (mod_ch_argl.nargs) = length (input);
483                                                             /* Set attribute length */
484                mod_ch_argl.arg.arg_ptr (mod_ch_argl.nargs) = interactive_ptr;
485                                                             /* Set pointer of attribute value or
486                                                                expression */
487                i = mod_ch_argl.nargs;
488                in_buf_index = in_buf_index + mod_ch_argl.arg.arg_len (i) + 1;   /* Set up for next input */
489                substr (input_buffer (in_buf_index - 1), 1, 1) = " ";
490           end;
491           substr (input_buffer (in_buf_index - 1), 1, 1) = C_R;
492           call bf_modify;
493 
494      end interactive_modify;
495 
496 
497 
498 verbose_modify:
499      proc;
500 
501           do i = 1 to sel_info.n_user_items;
502                call ioa_$nnl ("^/^a = ^a", sel_info.user_item.name (i), tmp_char);
503           end;
504 
505      end verbose_modify;
506 ^L
507 bf_modify:
508      proc;                                                  /* modify data base */
509 
510           dcl     var_expr               bit (1);
511 
512           if mod_ch_argl.nargs ^= sel_info.n_user_items     /* must be one mod arg for every user item */
513           then call error (linus_error_$bad_num_args);
514 
515           call parse_expr;
516 
517           if ^bf_flag then do;
518                     call verbose_modify;
519                     call linus_query$yes_no (lcb_ptr, yes_no_flag, NL||" OK? ");
520                end;
521 
522           if yes_no_flag then do;
523                     if ^expr_found then
524                          call const_mod;
525 
526                     else do;                                /* expression found */
527                               var_expr = "0"b;
528                               do l = 1 to sel_info.n_user_items;
529                                    if sel_info.user_item.item_type (l) = EXPR then do;
530                                              ex_ptr = sel_info.user_item.item_ptr (l);
531                                              do i = 1 to expression.nelems; /* find number of database items */
532                                                   if expression.elem.type (i) = DATA_BASE then
533                                                        var_expr = "1"b;
534                                              end;
535                                              if ^var_expr then /* expression has constant result */
536                                                   call
537                                                        linus_eval_expr (lcb_ptr,
538                                                        sel_info.user_item.item_ptr (l), destination_ptr,
539                                                        caller, l, icode);
540                                         end;
541                               end;
542                               if ^var_expr then /* expression has constant result */
543                                    call const_mod;
544                               else do;                      /* expression result varies with each tuple */
545                                         call set_up;
546                                         call expr_set_up;
547                                         do while (icode = 0);
548                                              do l = 1 to sel_info.n_user_items;
549                                                   if sel_info.user_item.item_type (l) = EXPR then
550                                                        call
551                                                             linus_eval_expr (lcb_ptr,
552                                                             sel_info.user_item.item_ptr (l), destination_ptr,
553                                                             caller, l, icode);
554                                              end;
555                                              do l = 1 to sel_info.n_user_items;
556                                                   if sel_info.user_item.item_type (l) = EXPR then
557                                                        call
558                                                             assign_round_ (sel_info.mrds_item.arg_ptr (l),
559                                                             sel_info.mrds_item.assn_type (l),
560                                                             sel_info.mrds_item.assn_len (l),
561                                                             sel_info.user_item.rslt_assn_ptr (l),
562                                                             sel_info.user_item.rslt_assn_type (l),
563                                                             sel_info.user_item.rslt_assn_len (l));
564                                                   else call not_expr;
565                                              end;
566                                              if icode = 0 then do;
567                                                        call bump_var_ptrs; /* increment (by 1) varying argument descriptor pointers */
568                                                        if lcb.timing_mode then
569                                                             initial_mrds_vclock = vclock;
570                                                        call cu_$generate_call (dsl_$modify, al_ptr);
571                                                             /* modify current */
572                                                        if lcb.timing_mode then
573                                                             lcb.mrds_time =
574                                                                  lcb.mrds_time + (vclock - initial_mrds_vclock);
575                                                        if icode = 0 then do;
576                                                                  call reset_var_ptrs; /* decrement (by 1) varying argument descriptor pointers */
577                                                                  call linus_table$async_retrieval (lcb_ptr, code);
578                                                                  if icode ^= 0 then
579                                                                       call error (icode);
580                                                                  if lcb.timing_mode then
581                                                                       initial_mrds_vclock = vclock;
582                                                                  call cu_$generate_call (dsl_$retrieve, arg_l_ptr);
583                                                             /* retrieve another */
584                                                                  if lcb.timing_mode then
585                                                                       lcb.mrds_time =
586                                                                            lcb.mrds_time + (vclock - initial_mrds_vclock);
587                                                             end;
588                                                   end;
589                                         end;
590                                         if icode ^= mrds_error_$tuple_not_found then
591                                              call error (icode);
592                                    end;
593                          end;
594                end;
595 ^L
596 const_mod:
597      proc;
598 
599           call set_up;
600           do l = 1 to sel_info.n_user_items;
601                if sel_info.user_item.item_type (l) = EXPR then
602                     call
603                          assign_round_ (sel_info.mrds_item.arg_ptr (l),
604                          sel_info.mrds_item.assn_type (l),
605                          sel_info.mrds_item.assn_len (l),
606                          sel_info.user_item.rslt_assn_ptr (l),
607                          sel_info.user_item.rslt_assn_type (l),
608                          sel_info.user_item.rslt_assn_len (l));
609                else call not_expr;
610           end;
611           call bump_var_ptrs;                               /* increment (by 1) varying argument descriptor pointers */
612           if lcb.timing_mode then
613                initial_mrds_vclock = vclock;
614           call cu_$generate_call (dsl_$modify, al_ptr);     /* Call to MRDS modify */
615           if lcb.timing_mode then
616                lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock);
617           call reset_var_ptrs;                              /* decrement (by 1) varying argument descriptor pointers */
618           if icode ^= 0 then
619                call error (icode);
620 
621      end const_mod;
622 ^L
623 bump_var_ptrs:
624      proc;
625 
626 /* increment (by 1) the varying argument descriptor pointers in arg_list */
627 
628           dcl     (i, k)                 fixed bin;
629 
630           desc = arg_list.arg_count / 2;                    /* number of descriptors */
631           do i = 1 to desc;
632                k = desc + i;                                /* point to descriptor */
633                if mdbm_util_$varying_data_class (arg_list.arg_des_ptr (k)) then
634                     arg_list.arg_des_ptr (i) = addrel (arg_list.arg_des_ptr (i), +1);
635           end;
636 
637      end bump_var_ptrs;
638 
639 
640 reset_var_ptrs:
641      proc;
642 
643 /* increment (by 1) the varying argument descriptor pointers in arg_list */
644 
645           dcl     (i, k)                 fixed bin;
646 
647           desc = arg_list.arg_count / 2;                    /* number of descriptors */
648           do i = 1 to desc;
649                k = desc + i;                                /* point to descriptor */
650                if mdbm_util_$varying_data_class (arg_list.arg_des_ptr (k)) then
651                     arg_list.arg_des_ptr (i) = addrel (arg_list.arg_des_ptr (i), -1);
652           end;
653 
654      end reset_var_ptrs;
655 ^L
656 not_expr:
657      proc;                                                  /* set items that are not expressions */
658 
659           dcl     tmp_char               char (mod_ch_argl.arg.arg_len (l))
660                                          based (mod_ch_argl.arg.arg_ptr (l));
661 
662           if sel_info.user_item.item_type (l) ^= EXPR then do;
663                     if tmp_char = ""
664                          &
665                          ^
666                          mdbm_util_$character_data_class (addr (sel_info.mrds_item.desc (l)))
667                          &
668                          ^mdbm_util_$varying_data_class (addr (sel_info.mrds_item.desc (l)))
669                     then call error (linus_error_$null_input); /* check for null items */
670                     if index (tmp_char, "!") = 1 then do;   /* Process LINUS VARIABLES? */
671                               if lv_ptr = null then
672                                    call error (linus_error_$linus_var_not_defined);
673                               do m = 1 to variables.nvars
674                                    while (variables.var_info.name (m) ^= substr (tmp_char, 2));
675                               end;
676                               if m > variables.nvars then
677                                    call error (linus_error_$linus_var_not_defined);
678                               else call
679                                         assign_round_ (sel_info.mrds_item.arg_ptr (l),
680                                         sel_info.mrds_item.assn_type (l),
681                                         sel_info.mrds_item.assn_len (l),
682                                         variables.var_info.var_ptr (m),
683                                         variables.var_info.assn_type (m),
684                                         variables.var_info.assn_len (m));
685                          end;
686                     else do;
687                               if tmp_char ^= sel_info.user_item.name (l) then do;
688                                         source_len = mod_ch_argl.arg.arg_len (l); /* Used in call to assign_round_ */
689                                         call
690                                              assign_round_ (sel_info.mrds_item.arg_ptr (l),
691                                              sel_info.mrds_item.assn_type (l),
692                                              sel_info.mrds_item.assn_len (l), mod_ch_argl.arg.arg_ptr (l),
693                                              source_type, source_len);
694                                    end;
695                          end;
696                end;
697 
698      end not_expr;
699 ^L
700 set_up:
701      proc;                                                  /* common for all types of modify */
702 
703           n_chars_init = 2;                                 /* Number for allocate */
704           allocate char_desc in (work_area);                /* Character descriptor */
705           char_desc.arr.const (2) = char_desc.arr.const (1);
706           desc = sel_info.n_mrds_items + sel_info.nsevals + 3; /* Offset for descriptors */
707           num_ptrs = desc * 2;                              /* Number of pointers to be passed in arg_list */
708           allocate arg_list in (work_area);                 /* System standard argument list */
709           allocate arg_l in (work_area);
710           arg_list.arg_des_ptr (desc) = addr (icode);       /* Pointer to icode */
711 
712           arg_list.arg_des_ptr (num_ptrs) = addr (char_desc.fb_desc);
713                                                             /* Return code descriptor */
714           arg_list.arg_des_ptr (1) = addr (lcb.db_index);   /* Data base index */
715           arg_list.arg_des_ptr (desc + 1) = addr (char_desc.fb_desc);
716                                                             /* Data base index descriptor */
717           arg_list.arg_count, arg_list.desc_count = num_ptrs; /* Initialize argument list header */
718           arg_list.code = 4;
719           arg_list.pad = 0;
720 
721           char_desc.arr.var (1), char_desc.arr.var (2) =
722                addr (sel_info.se_len) -> arg_len_bits.len;
723           arg_list.arg_des_ptr (2) = sel_info.se_ptr;
724           arg_list.arg_des_ptr (desc + 2) = addr (char_desc.arr (2));
725           if debug_switch then do;
726                     call ioa_ ("Selection expression:");
727 
728 /* 81-02-20 Rickie E. Brinegar: Start changes ****************************** */
729 
730                     call
731                          mdb_display_data_value$ptr (select_info.se_ptr,
732                          addr (char_desc.arr (1)));
733 
734 /* 81-02-20 Rickie E. Brinegar: End changes ******************************** */
735 
736                end;                                         /* if debug_switch */
737           if sel_info.nsevals ^= 0 then
738                do l = 1 to sel_info.nsevals;
739                     arg_list.arg_des_ptr (2 + l) = sel_info.se_vals.arg_ptr (l);
740                     arg_list.arg_des_ptr (2 + l + desc) = sel_info.se_vals.desc_ptr (l);
741                end;
742           i = 1;                                            /* mrds items index */
743           do l = 3 + sel_info.nsevals
744                to 2 + sel_info.n_mrds_items + sel_info.nsevals; /* use sel_info.data */
745                arg_list.arg_des_ptr (l) = sel_info.mrds_item.arg_ptr (i);
746                arg_list.arg_des_ptr (l + desc) = addr (sel_info.mrds_item.desc (i));
747                i = i + 1;
748           end;
749           arg_l = arg_list;
750           arg_l.arg_des_ptr (desc + 2) = addr (char_desc.arr (1));
751 
752      end set_up;
753 ^L
754 
755 expr_set_up:
756      proc;                                                  /* called if expression was found */
757 
758           sel_expr =
759                before (sel_expr, "-select") || "-select -dup"
760                || substr (after (sel_expr, "-select"), 6);  /* must modify duplicates */
761           call linus_table$async_retrieval (lcb_ptr, code);
762           if icode ^= 0 then
763                call error (icode);
764           if lcb.timing_mode then
765                initial_mrds_vclock = vclock;
766           call cu_$generate_call (dsl_$retrieve, arg_l_ptr);
767           if lcb.timing_mode then
768                lcb.mrds_time = lcb.mrds_time + (vclock - initial_mrds_vclock);
769           sel_expr =
770                before (sel_expr, "-dup") || "    " || after (sel_expr, "-dup");
771                                                             /* remove "-dup" for modify "-current" */
772           if icode ^= 0 then
773                call error (icode);
774           char_desc.arr.var (1) = addr (ano_curr_len) -> arg_len_bits.len;
775           arg_l.arg_des_ptr (2) = addr (ANOTHER);           /* for another retrieve */
776           l = index (sel_expr, "-select");
777           i = index (sel_expr, "-where") - 1;
778           if i <= 0 then
779                i = sel_info.se_len;                         /* no where clause exists */
780           temp = i - l + 1;
781           mod_curr = CURRENT || substr (sel_expr, l + 7, temp - 7);
782           temp = temp + 1;
783           char_desc.arr.var (2) = addr (temp) -> arg_len_bits.len;
784           arg_list.arg_des_ptr (2) = addr (mod_curr);       /* for current modify */
785 
786      end expr_set_up;
787 
788      end bf_modify;
789 ^L
790 parse_expr:
791      proc;                                                  /* parse expression and build the modify expression table */
792 
793           expr_found = "0"b;
794           do i = 1 to mod_ch_argl.nargs;
795                if index (tmp_char, "(") = 1 then do;        /* process expression */
796                          expr_found = "1"b;
797                          call
798                               linus_modify_build_expr_tab (lcb_ptr,
799                               mod_ch_argl.arg.arg_ptr (i), mod_ch_argl.arg.arg_len (i), i,
800                               td_ptr, mod_lit_ptr, mod_lit_offset, sel_ptr, icode);
801                          if icode ^= 0 then
802                               call error (icode);
803                          sel_info.user_item.item_type (i) = EXPR;
804                     end;
805           end;
806 
807      end parse_expr;
808 ^L
809 error:
810      proc (err_code);
811 
812           dcl     err_code               fixed bin (35);
813 
814           if ca_ptr ^= null
815           then free char_argl;
816           if combined_arg_idx_ptr ^= null
817           then do i = 1 to linus_data_$max_req_args;
818                     if combined_arg_idx (i)
819                     then free mod_ch_argl.arg.arg_ptr (i) -> combined_arg;
820                end;
821           call ssu_$abort_line (sci_ptr, err_code);
822 
823      end error;
824      end linus_modify;