1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    *********************************************************** */
  6 /* format: style4 */
  7 archive_table: act: proc;
  8 
  9 /* Returns names of archive components matching starnames, or all.
 10 
 11    Usage:     act archive_path {starnames} {-control_args}
 12    Usage:     [act archive_path {starnames} {-control_args}]
 13 
 14    where archive_path cannot contain stars, and starnames can.
 15    control_arg can be -absolute_pathname (-absp).
 16 
 17    Coded 08/29/79 S. Herbst */
 18 /* TR7460  Add -absolute_pathname 10/30/80 S. Herbst */
 19 /* TR11457 Have act use archive_ to prevent misbehavior with static storage 01/10/82 L. Baldwin */
 20 /* Added many control arguments 11/30/82 E. N. Kittlitz */
 21 /* Fixed no_star error message 06/17/83 E. N. Kittlitz */
 22 /* Change to use date_time_$format 06/19/84 J A Falksen
 23           Fix undocumented bug with -mode output */
 24 /* Fix 2 bugs introduced above. AF output needs rtrim before requote.
 25           -absp strings must include "::". 84-11-14 jaf */
 26 
 27 dcl  area area based (area_ptr);
 28 dcl  arg char (arg_len) based (arg_ptr);
 29 dcl  return_arg char (return_len) varying based (return_ptr);
 30 dcl  starname (starname_count) char (32) based (starname_ptr);
 31 
 32 dcl  archive_string char (168) varying;
 33 dcl  dn char (168);
 34 dcl  en char (32);
 35 dcl  item char (512) varying;
 36 
 37 dcl  date_format char (15) int static options (constant) init ("^<date>_^<time>");
 38 dcl  dt_len fixed bin;                                      /* length of date field              */
 39 dcl  bc_pic picture "(8)z9";
 40 dcl  REW char (3) int static options (constant) init ("rew");
 41 
 42 /* max_day is "1999-12-31  23:59:59.999999 gmt Fri"                          */
 43 /* None of the component values have leading or trailing zeroes, so no       */
 44 /*  matter what kind of space or zero suppression has been called for in a   */
 45 /*  user's default formats, this value will cause a max-length result from   */
 46 /*  date_time_$format.                                                       */
 47 dcl  max_day fixed bin (71) int static options (constant) init (3124137599999999);
 48 
 49 dcl  (absp_sw, af_sw, bc_sw, dtcm_sw, dtud_sw, got_path_sw, he_sw, mode_sw, name_sw, requote_sw) bit (1) aligned;
 50 
 51 dcl  (area_ptr, arg_ptr, return_ptr, seg_ptr, starname_ptr) ptr;
 52 
 53 dcl  (arg_count, starname_count, i) fixed bin;
 54 dcl  (arg_len, return_len) fixed bin;
 55 dcl  first_starname_index fixed bin;
 56 dcl  archive_bit_count fixed bin (24);
 57 dcl  code fixed bin (35);
 58 dcl  mode_v fixed bin;
 59 dcl  name_v fixed bin;
 60 
 61 dcl  1 l_archive_component_info aligned like archive_component_info;
 62 
 63 dcl  ME char (16) static options (constant) init ("archive_table");
 64 
 65 dcl  error_table_$badopt fixed bin (35) ext;
 66 dcl  error_table_$badstar fixed bin (35) ext;
 67 dcl  error_table_$inconsistent fixed bin (35) ext;
 68 dcl  error_table_$noarg fixed bin (35) ext static;
 69 dcl  error_table_$nostars fixed bin (35) ext;
 70 dcl  error_table_$not_act_fnc fixed bin (35) ext;
 71 dcl  complain entry variable options (variable);
 72 
 73 dcl  (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable);
 74 dcl  archive_$next_component_info entry (ptr, fixed bin (24), ptr, ptr, fixed bin (35));
 75 dcl  check_star_name_$entry entry (char (*), fixed bin (35));
 76 dcl  (com_err_, com_err_$suppress_name) entry options (variable);
 77 dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
 78 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
 79 dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*))
 80           returns (char (250) var);
 81 dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
 82 dcl  get_system_free_area_ entry returns (ptr);
 83 dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
 84 dcl  ioa_ entry options (variable);
 85 dcl  match_star_name_ entry (char (*), char (*), fixed bin (35));
 86 dcl  pathname_ entry (char (*), char (*)) returns (char (168));
 87 dcl  requote_string_ entry (char (*) aligned) returns (char (*));
 88 dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
 89 
 90 dcl  (addr, bin, char, fixed, index, length, ltrim, null, rtrim, substr
 91      ) builtin;
 92 
 93 dcl  cleanup condition;
 94 
 95           seg_ptr, starname_ptr = null;
 96           archive_component_info_ptr = addr (l_archive_component_info);
 97           l_archive_component_info.version = ARCHIVE_COMPONENT_INFO_VERSION_1;
 98 
 99           on cleanup call clean_up;
100 
101 /* Arg processing */
102 
103           call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
104           if code = error_table_$not_act_fnc then do;
105                af_sw = "0"b;
106                complain = com_err_;
107           end;
108           else do;
109                af_sw = "1"b;
110                complain = active_fnc_err_;
111                return_arg = "";
112           end;
113 
114           if arg_count = 0 then do;
115                if af_sw then call active_fnc_err_$suppress_name
116                          (0, ME, "Usage:  [act archive_path {starnames} {-control_args}]");
117                else call com_err_$suppress_name
118                          (0, ME, "Usage:  act archive_path {starnames} {-control_args}");
119                call clean_up;
120                return;
121           end;
122 
123           absp_sw, bc_sw, dtcm_sw, dtud_sw, got_path_sw, he_sw, mode_sw = "0"b;
124           name_sw = "1"b;                                   /* default attribute */
125           requote_sw = af_sw;                               /* assume requote if active function */
126 
127           if af_sw then
128                mode_v, name_v = 0;
129           else do;
130                mode_v = 4;
131                name_v = 32;
132           end;
133 
134           do i = 1 to arg_count;
135                call cu_$arg_ptr (i, arg_ptr, arg_len, code);
136                if index (arg, "-") = 1 then do;
137                     if arg = "-absolute_pathname" | arg = "-absp" then absp_sw = "1"b;
138                     else if arg = "-bit_count" | arg = "-bc" then bc_sw = "1"b;
139                     else if arg = "-component_name" | arg = "-cnm" then absp_sw = "0"b;
140                     else if arg = "-date_time_contents_modified" | arg = "-dtcm" then dtcm_sw = "1"b;
141                     else if arg = "-date_time_updated" | arg = "-dtud" then dtud_sw = "1"b;
142                     else if arg = "-header" | arg = "-he" then he_sw = "1"b;
143                     else if arg = "-mode" | arg = "-md" then mode_sw = "1"b;
144                     else if arg = "-name" | arg = "-nm" then name_sw = "1"b;
145                     else if arg = "-no_bit_count" | arg = "-nbc" then bc_sw = "0"b;
146                     else if arg = "-no_date_time_contents_modified" | arg = "-ndtcm" then dtcm_sw = "0"b;
147                     else if arg = "-no_date_time_updated" | arg = "-ndtud" then dtud_sw = "0"b;
148                     else if arg = "-no_header" | arg = "-nhe" then he_sw = "0"b;
149                     else if arg = "-no_mode" | arg = "-nmd" then mode_sw = "0"b;
150                     else if arg = "-no_name" | arg = "-nnm" then name_sw = "0"b;
151                     else if arg = "-no_requote" then requote_sw = "0"b;
152                     else if arg = "-requote" then requote_sw = af_sw; /* only turn it on for AF call */
153 
154                     else do;
155                          call complain (error_table_$badopt, ME, "^a", arg);
156                          return;
157                     end;
158                end;
159                else if ^got_path_sw then do;
160                     got_path_sw = "1"b;
161                     first_starname_index = i + 1;
162                     call expand_pathname_$add_suffix (arg, "archive", dn, en, code);
163                     if code ^= 0 then do;
164                          call complain (code, ME, "^a", arg);
165                          return;
166                     end;
167                     call check_star_name_$entry (en, code);
168                     if code = 1 | code = 2 then code = error_table_$nostars;
169                     if code ^= 0 then do;
170                          call complain (code, ME, "^a", arg);
171                          call clean_up;
172                          return;
173                     end;
174                end;
175           end;
176 
177           if ^(bc_sw | dtcm_sw | dtud_sw | mode_sw | name_sw) then do;
178                call complain (error_table_$inconsistent, ME, "No component attributes were selected.");
179                return;
180           end;
181           if af_sw then
182                if bin (bc_sw) + bin (dtcm_sw) + bin (dtud_sw) + bin (mode_sw) + bin (name_sw) < 2 then /* only one attribute */
183                     requote_sw = "0"b;                      /* so no item requoting */
184           if af_sw & he_sw then do;
185                call complain (error_table_$inconsistent, ME, "-header cannot be specified as an active function control argument.");
186                return;
187           end;
188           if ^got_path_sw then do;
189                call complain (error_table_$noarg, ME, "An archive must be specified.");
190                return;
191           end;
192 
193 /* initiate everything, checking access, etc. */
194 
195           call initiate_file_ (dn, en, R_ACCESS, seg_ptr, archive_bit_count, code);
196           if seg_ptr = null then do;
197                call complain (code, ME, "^a", pathname_ (dn, en));
198                return;
199           end;
200 
201 /* get the first component of the archive */
202 
203           l_archive_component_info.comp_ptr = null ();
204           call archive_$next_component_info (seg_ptr, archive_bit_count, (l_archive_component_info.comp_ptr), archive_component_info_ptr, code);
205           if code ^= 0 then do;
206                call complain (code, ME, "^a", pathname_ (dn, en));
207                return;
208           end;
209 
210 /* if starnames are specified, allocate storage, check for valid starnames */
211 
212           if arg_count >= first_starname_index then do;
213                starname_count = arg_count - 1;
214                area_ptr = get_system_free_area_ ();
215                allocate starname in (area) set (starname_ptr);
216                starname_count = 0;
217 
218                do i = first_starname_index to arg_count;
219                     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
220                     if index (arg, "-") ^= 1 then do;
221                          call check_star_name_$entry (arg, code);
222                          if code = error_table_$badstar then do;
223                               call complain (code, ME, "^a", arg);
224                               return;
225                          end;
226                          starname_count = starname_count + 1;
227                          starname (starname_count) = arg;
228                     end;
229                end;
230           end;
231           else starname_count = 0;
232 
233           if (dtcm_sw | dtud_sw) & ^af_sw
234           then dt_len = length (date_time_$format (date_format, max_day, "", ""));
235           else dt_len = 1;
236                                                             /* if -absp has been specified, precede each comp_nm with "dn>en.archive::" */
237 
238           if absp_sw
239           then archive_string = rtrim (pathname_ (dn, en)) || "::";
240           else archive_string = "";
241 
242 /* find components matching starnames and return them to the user */
243 
244           do while (l_archive_component_info.comp_ptr ^= null);
245                code = 1;                                    /* nonzero */
246                if starname_count ^= 0 then do;
247                     do i = 1 to starname_count while (code ^= 0);
248                          call match_star_name_ (l_archive_component_info.name, starname (i), code);
249                     end;
250                     if code ^= 0 then go to SKIP;
251                end;
252 
253                item = "";
254 
255                if name_sw
256                then call add_string (archive_string || l_archive_component_info.name, length (archive_string) + length (rtrim (l_archive_component_info.name)));
257 
258                if dtud_sw
259                then call add_string (date_time_$format (date_format, l_archive_component_info.time_updated, "", ""), dt_len);
260 
261                if mode_sw
262                then call add_string (" " ||
263                          substr (REW, 1, fixed ((l_archive_component_info.access & R_ACCESS) ^= ""b))
264                          || substr (REW, 2, fixed ((l_archive_component_info.access & E_ACCESS) ^= ""b))
265                          || substr (REW, 3, fixed ((l_archive_component_info.access & W_ACCESS) ^= ""b)), 5);
266 
267                if dtcm_sw
268                then call add_string (date_time_$format (date_format, l_archive_component_info.time_modified, "", ""), dt_len);
269 
270                if bc_sw
271                then do;
272                     if (length (item) > 0)
273                     then item = item || " ";
274                     bc_pic = l_archive_component_info.comp_bc;
275                     if af_sw
276                     then item = item || ltrim (bc_pic);
277                     else item = item || bc_pic;
278                end;
279 
280                if he_sw then do;
281                     he_sw = ""b;
282                     call ioa_ ("^/^11t^a^2/^[ name^27x^]^[ ^a^vx^;^2s^]^[ mode ^]^[ ^a^vx^;^2s^]^[    length^]^/",
283                          pathname_ (dn, en), name_sw,
284                          dtud_sw, "updated", dt_len - length ("updated"),
285                          mode_sw,
286                          dtcm_sw, "modified", dt_len - length ("modified"),
287                          bc_sw);
288                end;
289                if ^af_sw then call ioa_ ("^a", item);
290                else do;
291                     if length (return_arg) > 0 then return_arg = return_arg || " ";
292                     if requote_sw then
293                          return_arg = return_arg || requote_string_ ((item));
294                     else return_arg = return_arg || item;
295                end;
296 
297 SKIP:          call archive_$next_component_info (seg_ptr, archive_bit_count, (l_archive_component_info.comp_ptr), archive_component_info_ptr, code);
298                if code ^= 0 then do;
299                     call complain (code, ME, "^a", pathname_ (dn, en));
300                     return;
301                end;
302           end;
303 
304           call clean_up;
305 %page;
306 clean_up: proc;
307           call terminate_file_ (seg_ptr, 0, TERM_FILE_TERM, 0);
308           if starname_ptr ^= null then free starname in (area);
309      end clean_up; %skip (5);
310 add_string: proc (str, len);
311 
312 dcl  str char (*) var,
313      len fixed bin;
314 
315           if (length (item) > 0)
316           then item = item || " ";
317           if af_sw
318           then item = item || requote_string_ (rtrim (str));
319           else item = item || char (str, len);
320 
321      end add_string;
322 %page;
323 %include access_mode_values;
324 %page;
325 %include archive_component_info;
326 %page;
327 %include terminate_file;
328 
329 
330      end archive_table;