1 /* ***********************************************************
  2    *                                                         *
  3    *                                                         *
  4    * Copyright, (C) Honeywell Information Systems Inc., 1981 *
  5    *                                                         *
  6    *                                                         *
  7    *********************************************************** */
  8 
  9 /* ******************************************************
 10    *                                                    *
 11    *                                                    *
 12    * Copyright (c) 1972 by Massachusetts Institute of   *
 13    * Technology and Honeywell Information Systems, Inc. *
 14    *                                                    *
 15    *                                                    *
 16    ****************************************************** */
 17 
 18 linus_delete:
 19      proc (sci_ptr, lcb_ptr);
 20 
 21 /* DESCRIPTION:
 22 
 23    Selected rows are deleted from a single table in the data base.
 24 
 25 
 26 
 27    HISTORY:
 28 
 29    77-05-14 J. C. C. Jagernauth: Intially written.
 30 
 31    80-03-14  Rickie  E.   Brinegar:  Modified  to  use  a work area defined on
 32    lcb.linus_area_ptr instead of getting system free area.
 33 
 34    81-06-04  Rickie  E.   Brinegar:  Modified to not pass arguments for return
 35    values to dsl_$delete.
 36 
 37    81-07-15 Rickie E. Brinegar: Removed useless cleanup condition handler.
 38 
 39    81-11-13  Rickie  E.  Brinegar: Added timing of dsl_$delete and changed the
 40    cu_$gen_call to cu_$generate_call.
 41 
 42    82-02-10 Paul W. Benjamin: ssu_ conversion
 43 
 44    82-09-03 Dave J. Schimke: Added a call to dsl_$get_pn to get the opening
 45    mode and report an error if user tries to delete with a retrieval opening.
 46    Declared mode, db_path, dsl_$get_path, and linus_error_$update_not_valid.
 47    This is in response to phx 13742.
 48 
 49    82-11-15 Dave Schimke: Declared fixed and rel builtins.
 50 
 51    83-08-30  Bert Moberg:  Added call to linus_translate_query$auto if no current
 52    select expression is available
 53 */
 54 ^L
 55 %include linus_lcb;
 56 %page;
 57 %include linus_select_info;
 58 %page;
 59 %include mdbm_arg_list;
 60 %page;
 61 %include linus_arg_list;
 62 ^L
 63           dcl     sci_ptr                ptr;               /* for ssu_ */
 64 
 65           dcl     nargs                  fixed;
 66 
 67           dcl     (addr, fixed, null, rel, substr, vclock) builtin;
 68 
 69           dcl     (desc, l)              fixed bin;
 70 
 71           dcl     (icode, out_code)      fixed bin (35);
 72 
 73           dcl     initial_mrds_vclock    float bin (63);
 74 
 75           dcl     1 arg_len_bits         based,
 76                     2 pad                bit (12) unal,
 77                     2 length             bit (24) unal;
 78 
 79           dcl     db_path                char (168) var;
 80           dcl     mode                   char (20);
 81           dcl     sel_expr               char (select_info.se_len) based (select_info.se_ptr);
 82 
 83           dcl     (
 84                   linus_data_$d_id,
 85                   linus_error_$inv_for_delete,
 86                   linus_error_$no_db,
 87                   linus_error_$no_input_arg_reqd,
 88                   linus_error_$update_not_allowed,
 89                   sys_info$max_seg_size
 90                   )                      fixed bin (35) ext;
 91 
 92           dcl     cu_$generate_call      entry (entry, ptr);
 93           dcl     dsl_$delete            entry options (variable);
 94           dcl     dsl_$get_pn            entry (fixed bin (35), char (168) var, char (20), fixed bin (35));
 95           dcl     linus_convert_code     entry (fixed bin (35), fixed bin (35), fixed bin (35));
 96           dcl     linus_translate_query$auto       entry (ptr, ptr);
 97           dcl     ssu_$abort_line        entry options (variable);
 98           dcl     ssu_$arg_count         entry (ptr, fixed bin);
 99           dcl     work_area              area (sys_info$max_seg_size) based (lcb.linus_area_ptr);
100 ^L
101           al_ptr, char_ptr = null;
102           icode = 0;
103 
104           if lcb.db_index = 0 then
105                call error (linus_error_$no_db, "");
106           call dsl_$get_pn (lcb.db_index, db_path, mode, icode);
107           if substr (mode, 1, 9) = "retrieval" | substr (mode, 11, 9) = "retrieval" then
108                call error (linus_error_$update_not_allowed, "");
109 
110           call ssu_$arg_count (sci_ptr, nargs);
111           if nargs ^= 0 then
112                call error (linus_error_$no_input_arg_reqd, "");
113           if lcb.si_ptr = null then call linus_translate_query$auto (sci_ptr, lcb_ptr); /* try translating it */
114           if lcb.si_ptr = null then return; /* No good?  Oh, well */
115           si_ptr = lcb.si_ptr;
116           if ^select_info.se_flags.val_del then
117                call error (linus_error_$inv_for_delete, "");
118           if select_info.nsevals = 0 then do;
119                     if lcb.timing_mode then
120                          initial_mrds_vclock = vclock;
121                     call dsl_$delete (lcb.db_index, sel_expr, icode);
122                     if lcb.timing_mode then
123                          lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock;
124                end;
125           else do;
126                     n_chars_init = 1;
127                     allocate char_desc in (work_area);
128 
129 /* 81-06-04 Rickie E. Brinegar: Start changed code ************************* */
130 
131                     desc = select_info.nsevals + 3;
132 
133 /* 81-06-04 Rickie E. Brinegar: End changed code *************************** */
134 
135                     num_ptrs = desc * 2;
136                     allocate arg_list in (work_area);
137 
138                     arg_list.arg_des_ptr (num_ptrs) = addr (char_desc.fb_desc);
139                                                             /* Return code descriptor */
140                     arg_list.arg_des_ptr (1) = addr (lcb.db_index); /* Data base index */
141                     arg_list.arg_des_ptr (desc + 1) = addr (char_desc.fb_desc);
142                                                             /* Data base index descriptor */
143                     arg_list.arg_count, arg_list.desc_count = num_ptrs; /* Initialize argument list header */
144                     arg_list.code = 4;
145                     arg_list.pad = 0;
146 
147                     arg_list.arg_des_ptr (desc) = addr (icode);
148                     char_desc.arr.var (1) =
149                          addr (select_info.se_len) -> arg_len_bits.length;
150                     arg_list.arg_des_ptr (2) = select_info.se_ptr;
151                     arg_list.arg_des_ptr (desc + 2) = addr (char_desc.arr (1));
152                     do l = 1 to select_info.nsevals;
153                          arg_list.arg_des_ptr (2 + l) = select_info.se_vals.arg_ptr (l);
154                          arg_list.arg_des_ptr (2 + l + desc) =
155                               select_info.se_vals.desc_ptr (l);
156                     end;
157 
158                     if lcb.timing_mode then
159                          initial_mrds_vclock = vclock;
160                     call cu_$generate_call (dsl_$delete, al_ptr);
161                     if lcb.timing_mode then
162                          lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock;
163 
164                end;
165           if icode ^= 0 then
166                call error (icode, "");
167 
168           return;
169 ^L
170 error:
171      proc (err_code, string);
172 
173           dcl     err_code               fixed bin (35);
174           dcl     string                 char (*);
175 
176           call linus_convert_code (err_code, out_code, linus_data_$d_id);
177           call ssu_$abort_line (sci_ptr, out_code);
178 
179      end error;
180 
181      end linus_delete;