1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  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 /* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
 13 print_data:
 14      proc (p_stuff, print_data_info_ptr, p_code);
 15 
 16 /*
 17    This program is for printing p_stuff, a string produced by a "put data",
 18    in a special format.  print_data_info, based on print_data_info_ptr, is
 19    used to control the format, as well as select the output switch.
 20    Written by Lindsey L. Spratt.
 21    Modified:
 22    06/21/79  by  Lindsey Spratt; add rtrim(ltrim()) of intervals, check for
 23    correct print_data_info version, add error code reporting.
 24    02/15/85 by Chris Jones to clean up properly.
 25 */
 26 
 27 /* Automatic */
 28 
 29 dcl       start_scan_idx         fixed bin (24);
 30 dcl       code                   fixed bin (35);
 31 dcl       p_code                 fixed bin (35);
 32 dcl       more_intervals         bit (1);
 33 dcl       first_interval         bit (1);
 34 dcl       1 item,
 35             2 storage_id         char (256) varying,
 36             2 value              char (1024) varying;
 37 dcl       storage_id_pad         char (256) varying;
 38 dcl       interval_spec          char (256) varying;
 39 dcl       first_blank            fixed bin (35);
 40 dcl       temp_seg_ptrs          (2) ptr;
 41 dcl       target_ptr             ptr;
 42 dcl       source_ptr             ptr;
 43 dcl       current_period         fixed bin (35);
 44 dcl       current_quote          fixed bin (35);
 45 dcl       following_quote        fixed bin (35);
 46 dcl       following_double_quote fixed bin (35);
 47 dcl       temp_value             char (32) varying;
 48 dcl       more                   bit (1);
 49 dcl       null                   builtin;
 50 dcl       found                  bit (1);
 51 dcl       level                  fixed bin;
 52 dcl       root_of_level_list     ptr;
 53 dcl       p_stuff                char (*) varying;
 54 
 55 /* Based */
 56 
 57 dcl       1 level_id             based,
 58             2 str                char (32) varying,
 59             2 next               ptr;
 60 dcl       temp_seg               char (sys_info$max_seg_size * 4) varying based;
 61 
 62 /* External */
 63 
 64 dcl       sys_info$max_seg_size  fixed bin (35) ext;
 65 dcl       error_table_$unimplemented_version
 66                                  fixed bin (35) ext;
 67 
 68 /* Entry */
 69 
 70 dcl       ioa_$ioa_switch        entry options (variable);
 71 dcl       ioa_                   entry options (variable);
 72 dcl       ioa_$rsnnl             entry options (variable);
 73 dcl       get_temp_segments_     entry (char (*), pointer dimension (*), fixed bin (35));
 74 dcl       release_temp_segments_ entry (char (*), pointer dimension (*), fixed bin (35));
 75 
 76 /* Builtin */
 77 
 78 dcl       (bin, bit, copy, index, length, ltrim, reverse, rtrim, substr)
 79                                  builtin;
 80 
 81 /* Condition */
 82 
 83 dcl       cleanup                condition;
 84 ^L
 85 
 86           if print_data_info.version ^= print_data_info_version_1 then do;
 87                p_code = error_table_$unimplemented_version;
 88                return;
 89           end;
 90 
 91           temp_seg_ptrs (*) = null ();
 92           root_of_level_list = null ();
 93 
 94           on cleanup call clean_up;
 95 
 96           call get_temp_segments_ ("print_data", temp_seg_ptrs, code);
 97           source_ptr = temp_seg_ptrs (1);
 98           target_ptr = temp_seg_ptrs (2);
 99           source_ptr -> temp_seg = p_stuff;
100           target_ptr -> temp_seg = "";
101           more_intervals = "1"b;
102           interval_spec = rtrim (ltrim (print_data_info.intervals));
103           start_scan_idx = 1;
104           call setup_interval (start_scan_idx);
105           first_interval = "1"b;
106           do while (more_intervals | first_interval);
107                first_interval = "0"b;                       /* The following loop parses a storage_id and a value out of p_stuff.
108                                                                first_blank identifies the end of the storage_id which begins p_stuff. */
109 
110                first_blank = index (source_ptr -> temp_seg, " ");
111                root_of_level_list = null;
112                do while (first_blank > 0);
113                     item.storage_id = substr (source_ptr -> temp_seg, 1, first_blank);
114                                                             /* p_stuff is set up to begin with the storage_id. */
115                     current_period = index (item.storage_id, ".");
116                                                             /* The storage id is indented two spaces for each level in the id. */
117                     storage_id_pad = "";
118                     do level = 1 by 1 while (current_period > 0);
119                          temp_value = substr (item.storage_id, 1, current_period - 1);
120                          call check_level (temp_value, level, found);
121                          item.storage_id = substr (copy (item.storage_id, 1), current_period + 1);
122                          if ^found then do;
123                               temp_value = storage_id_pad || copy (temp_value, 1);
124                               if print_data_info.output_switch ^= null then
125                                    call ioa_$ioa_switch (print_data_info.output_switch, "^a", temp_value);
126                               else call ioa_ ("^a", temp_value);
127                          end;
128                          storage_id_pad = copy (" ", print_data_info.indentation) || storage_id_pad;
129                          current_period = index (item.storage_id, ".");
130                     end;
131                     call check_level (item.storage_id, level, found);
132                     item.storage_id = storage_id_pad || copy (item.storage_id, 1);
133                     target_ptr -> temp_seg = ltrim (substr (source_ptr -> temp_seg, first_blank + 1));
134                     call switch_source_and_target;          /*  The string is processed for quotes, and quote doubling.  */
135 
136                     if substr (source_ptr -> temp_seg, 1, 1) = """" then do;
137                          current_quote = 1;
138                          more = "1"b;
139                          do while (more);
140                               following_quote =
141                                    index (substr (source_ptr -> temp_seg, current_quote + 1), """") + current_quote;
142                               following_double_quote =
143                                    index (substr (source_ptr -> temp_seg, current_quote + 1), """""") + current_quote;
144                               if following_double_quote = current_quote | following_quote < following_double_quote then
145                                    more = "0"b;
146                               else current_quote = following_quote;
147                          end;
148                          item.value = substr (source_ptr -> temp_seg, 1, following_quote);
149                          source_ptr -> temp_seg = ltrim (substr (source_ptr -> temp_seg, following_quote + 1));
150 
151                          if substr (source_ptr -> temp_seg, 1, 1) = "b" then do;
152                                                             /*  Allow for bit strings. */
153                               item.value = copy (item.value, 1) || "b";
154                               if print_data_info.flags.octal then do;
155                                    call ioa_$rsnnl ("^oo", item.value, 0,
156                                         bin (
157                                         bit (substr (item.value, 2, length (item.value) - 3), length (item.value) - 3)));
158                               end;
159                               target_ptr -> temp_seg = ltrim (substr (source_ptr -> temp_seg, 2));
160                               call switch_source_and_target;
161                          end;
162                     end;
163                     else do;
164                          first_blank = index (source_ptr -> temp_seg, " ");
165                          if first_blank = 0 then
166                               first_blank = length (source_ptr -> temp_seg);
167                          item.value = substr (source_ptr -> temp_seg, 1, first_blank);
168                          target_ptr -> temp_seg = ltrim (substr (source_ptr -> temp_seg, first_blank));
169                          call switch_source_and_target;
170                     end;
171                     if print_data_info.output_switch ^= null then
172                          call ioa_$ioa_switch (print_data_info.output_switch, "^a^vt^a", item.storage_id,
173                               print_data_info.value_column, item.value);
174                     else call ioa_ ("^a^vt^a", item.storage_id, print_data_info.value_column, item.value);
175                     first_blank = index (source_ptr -> temp_seg, " ");
176                end;
177                call setup_interval (start_scan_idx);
178           end;
179           call clean_up;
180           return;                                           /* End of print_data main proc. */
181 
182 clean_up:
183      proc;
184 
185 dcl       current_level_ptr      ptr;
186 
187           do current_level_ptr = root_of_level_list repeat root_of_level_list while (current_level_ptr ^= null ());
188                root_of_level_list = current_level_ptr -> level_id.next;
189                free current_level_ptr -> level_id;
190           end;
191           call release_temp_segments_ ("print_data", temp_seg_ptrs, (0));
192 
193      end clean_up;
194 
195 switch_source_and_target:
196      proc;
197 dcl       temp_ptr               ptr;
198           temp_ptr = target_ptr;
199           target_ptr = source_ptr;
200           source_ptr = temp_ptr;
201      end;
202 
203 check_level:
204      proc (p_str, p_level, p_found);
205 dcl       p_str                  char (*) varying;
206 dcl       p_level                fixed bin;
207 dcl       p_found                bit (1);
208 dcl       idx                    fixed bin;
209 dcl       next_level_ptr         ptr;
210 dcl       current_level_ptr      ptr;
211 
212           current_level_ptr, next_level_ptr = root_of_level_list;
213           do idx = 1 to p_level while (next_level_ptr ^= null);
214                current_level_ptr = next_level_ptr;
215                next_level_ptr = current_level_ptr -> level_id.next;
216           end;
217           if next_level_ptr ^= null                         /* Implies p_level is less than length of level_list. */
218           then do;
219                if current_level_ptr -> level_id.str = p_str then do;
220                     p_found = "1"b;
221                     return;
222                end;
223                else do;                                     /* Already printed component at this level is different than current component,
224                                                                so the rest (higher levels) of the level_list is no longer appropriate. */
225                     current_level_ptr -> level_id.str = p_str;
226                     current_level_ptr -> level_id.next = null;
227                     current_level_ptr = next_level_ptr;
228                     do while (current_level_ptr ^= null);
229                          next_level_ptr = current_level_ptr -> level_id.next;
230                          free current_level_ptr -> level_id;
231                          current_level_ptr = next_level_ptr;
232                     end;
233                     p_found = "0"b;
234                end;
235           end;
236           else if idx = p_level then do;                    /* This implies level_list is one shorter than p_level. */
237                allocate level_id set (next_level_ptr);
238                if current_level_ptr ^= null then
239                     current_level_ptr -> level_id.next = next_level_ptr;
240                else root_of_level_list = next_level_ptr;
241                next_level_ptr -> level_id.str = p_str;
242                next_level_ptr -> level_id.next = null;
243                p_found = "0"b;
244           end;
245           else do;                                          /* idx > p_level */
246                current_level_ptr -> level_id.str = p_str;
247                p_found = "0"b;
248           end;
249      end check_level;
250 
251 setup_interval:
252      proc (p_scan_idx);
253 dcl       p_scan_idx             fixed bin (24);
254 dcl       start_scan_idx         fixed bin (24);
255 dcl       scan_length            fixed bin (24);
256 
257           start_scan_idx = p_scan_idx;
258           call get_interval (start_scan_idx, scan_length, more_intervals);
259           p_scan_idx = scan_length + start_scan_idx;
260           source_ptr -> temp_seg = rtrim (ltrim (substr (p_stuff, start_scan_idx, scan_length)));
261 
262 /* All occurences of =" are expanded to =<SP>", ("=""" -> "= """).  Since this
263    doesn't change number or ordering of quotes, this change does not alter the
264    parsing of quoted strings.  It is necessary to insure proper parsing of
265    storage id's from their values when their values are strings, bit or
266    character.  */
267 
268           start_scan_idx = 1;
269           target_ptr -> temp_seg = "";
270           scan_length = index (source_ptr -> temp_seg, "=""");
271           do while (scan_length > 0);
272                target_ptr -> temp_seg =
273                     target_ptr -> temp_seg || substr (source_ptr -> temp_seg, start_scan_idx, scan_length);
274                target_ptr -> temp_seg = target_ptr -> temp_seg || " ";
275                start_scan_idx = scan_length + start_scan_idx;
276                scan_length = index (substr (source_ptr -> temp_seg, start_scan_idx), "=""");
277           end;
278 
279           target_ptr -> temp_seg = target_ptr -> temp_seg || substr (source_ptr -> temp_seg, start_scan_idx);
280           call switch_source_and_target;
281      end;
282 
283 
284 
285 get_interval:
286      proc (p_start_scan_idx, p_scan_length, p_more_intervals);
287 dcl       p_start_scan_idx       fixed bin (24);
288 dcl       p_scan_length          fixed bin (24);
289 dcl       p_more_intervals       bit (1);
290 dcl       interval               char (256) varying;
291 dcl       interval_idx           fixed bin;
292 dcl       delimiter_idx          fixed bin;
293 dcl       start_scan_idx         fixed bin (35);
294 dcl       scan_length            fixed bin (35);
295 
296           if interval_spec = "" then do;
297                p_more_intervals = "0"b;
298                p_scan_length = length (p_stuff) - p_start_scan_idx;
299                return;
300           end;
301           interval_idx = index (interval_spec, " ") - 1;
302           if interval_idx = -1 then
303                interval_idx = length (interval_spec);
304           interval = substr (interval_spec, 1, interval_idx);
305           interval_spec = ltrim (substr (copy (interval_spec, 1), interval_idx + 1));
306           delimiter_idx = index (interval, "|");
307           if delimiter_idx = 0 then do;
308                p_start_scan_idx = index (substr (p_stuff, p_start_scan_idx), interval);
309                p_start_scan_idx = p_start_scan_idx - index (reverse (substr (p_stuff, 1, p_start_scan_idx)), " ");
310                source_ptr -> temp_seg = substr (p_stuff, p_start_scan_idx);
311                p_scan_length = length (p_stuff);
312                interval_spec = "";
313                p_more_intervals = "0"b;
314                return;
315           end;
316           else if delimiter_idx = 1 then do;
317                p_scan_length = index (substr (p_stuff, p_start_scan_idx), substr (interval, 2));
318                p_scan_length = p_scan_length - index (reverse (substr (p_stuff, p_start_scan_idx, p_scan_length)), " ");
319                source_ptr -> temp_seg = ltrim (rtrim (substr (p_stuff, p_start_scan_idx, p_scan_length)));
320                p_scan_length = p_start_scan_idx + p_scan_length - 1;
321                if interval_spec = "" then
322                     p_more_intervals = "0"b;
323                else p_more_intervals = "1"b;
324                return;
325           end;
326           else if delimiter_idx = length (interval) then do;
327                p_start_scan_idx = index (substr (p_stuff, p_start_scan_idx), interval);
328                p_start_scan_idx = p_start_scan_idx - index (reverse (substr (p_stuff, 1, p_start_scan_idx)), " ");
329                source_ptr -> temp_seg = substr (p_stuff, p_start_scan_idx);
330                p_scan_length = length (p_stuff);
331                interval_spec = "";
332                p_more_intervals = "0"b;
333                return;
334           end;
335           else do;                                          /* Both a beginning and an end are given for the interval. */
336                start_scan_idx = index (substr (p_stuff, p_start_scan_idx), substr (interval, 1, delimiter_idx - 1));
337                start_scan_idx =
338                     start_scan_idx - index (reverse (substr (p_stuff, p_start_scan_idx, start_scan_idx)), " ");
339                p_start_scan_idx = start_scan_idx;
340                scan_length = index (substr (p_stuff, p_start_scan_idx), substr (interval, delimiter_idx + 1));
341                scan_length = scan_length - index (reverse (substr (p_stuff, p_start_scan_idx, scan_length)), " ");
342                p_scan_length = scan_length;
343                if interval_spec = "" then
344                     p_more_intervals = "0"b;
345                else p_more_intervals = "1"b;
346                return;
347           end;
348      end;
349 ^L
350 %include print_data_info;
351 
352      end print_data;