1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1990   *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1981 *
  6         *                                                         *
  7         *********************************************************** */
  8 
  9 
 10 
 11 /****^  HISTORY COMMENTS:
 12   1) change(90-04-30,Leskiw), approve(90-10-05,MCR8202),
 13      audit(90-10-11,Bubric), install(90-10-14,MR12.4-1039):
 14      Changed calls to assign_round_ from assign_ so that data is rounded.
 15                                                    END HISTORY COMMENTS */
 16 
 17 
 18 linus_output:
 19      proc;
 20           return;                                           /* This entry point should never be called */
 21 
 22 /* DESCRIPTION:
 23 
 24    The  porpose  of  this  module  is  to  permit  the  common  code  used  by
 25    linus_create_list,  linus_report,  and  linus_write  to  be maintained in a
 26    central  location.  Thus corrections that have to be made need only be made
 27    in one location, not in three.
 28 
 29 
 30    HISTORY:
 31 
 32    81-04-29  Rickie  E.   Brinegar:  This  module  was created after hackin on
 33    linus_create_list, linus_report, and linus_write.  Presumably, it will ease
 34    maintenance of the three routines.
 35 
 36 */
 37 ^L
 38 %include linus_lcb;
 39 %page;
 40 %include linus_select_info;
 41 %page;
 42 %include mdbm_descriptor;
 43 ^L
 44           dcl     (
 45                   caller,
 46                   l,
 47                   len,
 48                   ob_len,                                   /* OUTPUT: output buffer length */
 49                   target_type
 50                   )                      fixed bin;
 51 
 52           dcl     n_bytes                fixed bin (21);
 53 
 54           dcl     (
 55                   called_by,                                /* INPUT: The linus_data_ id of my caller */
 56                   code,                                     /* INPUT: standard code */
 57                   icode                  init (0)
 58                   )                      fixed bin (35);
 59 
 60           dcl     EXPR                   fixed bin (2) int static options (constant) init (2);
 61           dcl     NEWLINE                char (1) options (constant) int static init ("
 62 ");                                                         /* New line character */
 63           dcl     wcb_dm                 char (1);          /* INPUT: delimiter character for write request */
 64 
 65           dcl     (
 66                   dec_3_ptr              init (null),
 67                   destination_ptr        init (null),
 68                   file_info_ptr,                            /* INPUT: pointer to the file information for the create_list request */
 69                   iocb_ptr,                                 /* INPUT: iocb_ptr for the report and write requests */
 70                   out_buf_ptr,                              /* INPUT/OUTPUT: if null then allocate and return the value */
 71                   rec_info_ptr,                             /* INPUT: pointer to the record information for the create_list request */
 72                   ti_ptr,                                   /* INPUT: target item pointer */
 73                   user_item_ptr          init (null)
 74                   )                      ptr;
 75 
 76           dcl     (addr, fixed, length, ltrim, null, rel, rtrim, substr) builtin;
 77 
 78           dcl     1 user_item            aligned based (user_item_ptr), /* Valid when mrds_item = user_item */
 79                     2 arg_ptr            ptr,
 80                     2 bit_len            fixed bin (35),
 81                     2 desc               bit (36),
 82                     2 assn_type          fixed bin,
 83                     2 assn_len           fixed bin (35);
 84 
 85           dcl     1 ti                   (select_info.n_user_items) aligned based (ti_ptr),
 86                     2 ptr                ptr,
 87                     2 len                fixed bin (35);
 88 
 89 
 90           dcl     1 record_info          aligned based (rec_info_ptr),
 91                     2 version            fixed bin,         /* (INPUT) =1 */
 92                     2 n_fields           fixed bin,         /* (INPUT) number of fields in this record */
 93                     2 field              (n refer (record_info.n_fields)) aligned,
 94                       3 field_ptr        ptr,               /* (INPUT) ptr to first char of Nth record */
 95                       3 field_len        fixed bin (21);    /* (INPUT) len in chars of Nth record */
 96 
 97 /*  NOTE:
 98 
 99    This  entry  adds a new record to a lister file.  The order of the fields is
100    the   same   as   the   order   in   the   fieldname_info   structure   (see
101    lister_$open_file, or lister_$get_fieldnames).  The number of fields in each
102    record  must  match  the number of fields in every other record in the file.
103    If  the  file  is  full  a non-zero code will be returned.  If the number of
104    fields  is  incorrect  a non-zero code will be returned.  Zero-length fields
105    are OK.
106 
107 */
108 
109           dcl     (
110                   linus_data_$buff_len,
111                   linus_data_$create_list_id,
112                   linus_data_$report_id,
113                   linus_data_$w_id,
114                   sys_info$max_seg_size
115                   )                      ext fixed bin (35);
116 
117           dcl     dec_3                  pic "+999" based (dec_3_ptr);
118           dcl     output_buffer          (ob_len) char (1) unal based (out_buf_ptr);
119           dcl     out_buffer             char (ob_len) unal based (out_buf_ptr);
120           dcl     target_item            char (ti.len (l)) var aligned based;
121           dcl     work_area              area (sys_info$max_seg_size) based (lcb.i_o_area_ptr);
122 
123           dcl     assign_round_
124                                          entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
125           dcl     linus_eval_expr
126                                          entry (ptr, ptr, ptr, fixed bin, fixed bin, fixed bin (35));
127           dcl     lister_$add_record     entry (ptr, ptr, fixed bin (35));
128           dcl     mdbm_util_$string_data_class entry (ptr) returns (bit (1));
129           dcl     iox_$put_chars         entry (ptr, ptr, fixed bin (21), fixed bin (35));
130 ^L
131 create_list:
132      entry (lcb_ptr, called_by, file_info_ptr, rec_info_ptr, si_ptr, ti_ptr,
133           target_type, out_buf_ptr, ob_len, code);
134           call main_routine;
135           return;
136 ^L
137 report:
138      entry (lcb_ptr, called_by, iocb_ptr, si_ptr, ti_ptr, target_type,
139           out_buf_ptr, ob_len, code);
140           allocate dec_3 in (work_area);
141           call main_routine;
142           return;
143 ^L
144 write:
145      entry (lcb_ptr, called_by, iocb_ptr, si_ptr, wcb_dm, ti_ptr, target_type,
146           out_buf_ptr, ob_len, code);
147           call main_routine;
148           return;
149 ^L
150 main_routine:
151      proc;
152           n_bytes = 0;
153           code = 0;
154           caller = 1;
155           destination_ptr = lcb.si_ptr;
156           do l = 1 to select_info.n_user_items;
157 
158                if ti.ptr (l) = null then do;
159                          if select_info.user_item.item_type (l) = EXPR | select_info.set_fn
160                          then desc_ptr = addr (select_info.user_item.rslt_desc (l));
161                          else do;
162                                    user_item_ptr = select_info.user_item.item_ptr (l);
163                                    desc_ptr = addr (user_item.desc);
164                               end;
165 
166                          if ^mdbm_util_$string_data_class (desc_ptr) then
167                               ti.len (l) = linus_data_$buff_len;
168                          else ti.len (l) =
169                                    fixed (descriptor.size.scale || descriptor.size.precision);
170                          allocate target_item in (work_area) set (ti.ptr (l));
171                          ti.ptr (l) -> target_item = "";
172                     end;
173 
174                if select_info.user_item.item_type (l) = EXPR | select_info.set_fn
175                then do;                                     /* Evaluate expression */
176                          if ^select_info.set_fn then
177                               call
178                                    linus_eval_expr (lcb_ptr,
179                                    select_info.user_item.item_ptr (l), destination_ptr, caller,
180                                    l, icode);
181                          if icode ^= 0 then do;
182                                    code = icode;
183                                    return;
184                               end;
185                          call
186                               assign_round_ (ti.ptr (l), target_type, ti.len (l),
187                               select_info.user_item.rslt_assn_ptr (l),
188                               select_info.user_item.rslt_assn_type (l),
189                               select_info.user_item.rslt_assn_len (l));
190                     end;
191                else do;
192                          user_item_ptr = select_info.user_item.item_ptr (l);
193                                                             /* Init user_item structure */
194                          call
195                               assign_round_ (ti.ptr (l), target_type, ti.len (l), user_item.arg_ptr,
196                               user_item.assn_type, user_item.assn_len);
197                     end;
198           end;
199 
200 /* get length of output buffer. allocate and fill it with target items */
201 
202           if out_buf_ptr = null then do;
203                     ob_len = 0;
204                     do l = 1 to select_info.n_user_items;
205                          ob_len = ob_len + ti.len (l) + 2;
206                     end;
207 
208                     allocate output_buffer in (work_area);
209                end;
210 
211           do l = 1 to select_info.n_user_items;
212                if called_by = linus_data_$create_list_id then
213                     ti.ptr (l) -> target_item =
214                          ltrim (rtrim (ti.ptr (l) -> target_item));
215                len = length (ti.ptr (l) -> target_item);
216                if called_by = linus_data_$create_list_id then do;
217                          record_info.field.field_len (l) = len;
218                          record_info.field.field_ptr (l) =
219                               addr (output_buffer (n_bytes + 1));
220                     end;
221                else if called_by = linus_data_$report_id then do;
222                          dec_3_ptr = addr (output_buffer (n_bytes + 1));
223                          dec_3 = len;
224                          n_bytes = n_bytes + 4;
225                     end;
226                n_bytes = n_bytes + 1;
227                substr (out_buffer, n_bytes, len) = ti.ptr (l) -> target_item;
228                n_bytes = n_bytes + len - 1;
229                if called_by = linus_data_$w_id then do;
230                          n_bytes = n_bytes + 1;
231                          output_buffer (n_bytes) = wcb_dm;
232                     end;
233           end;
234 
235           if called_by = linus_data_$create_list_id then
236                call lister_$add_record (file_info_ptr, rec_info_ptr, code);
237           else do;
238                     if called_by = linus_data_$w_id then do;
239                               n_bytes = n_bytes + 1;
240                               output_buffer (n_bytes) = NEWLINE;
241                          end;
242                     call iox_$put_chars (iocb_ptr, out_buf_ptr, n_bytes, code);
243                end;
244      end main_routine;
245 
246      end linus_output;
247