1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 archive_: proc ();
 12 
 13 /* *      ARCHIVE_ -- subroutine entriers for manipulating archives
 14    *
 15    *      archive_$get_component
 16    *         Returns a pointer to a named archive component, given a pointer to the archive
 17    *      archive_$get_component_info
 18    *         Finds a component and returns complete info about it.
 19    *      archive_$next_component
 20    *         Returns a pointer to the next component in an archive.
 21    *      archive_$next_component_info
 22    *         Returns complete info about the next component.
 23    *      archive_$list_components
 24    *         Returns a list of archive components and info.
 25    *
 26    *      01/13/81, W. Olin Sibert
 27    */
 28 /* Fixed bug detecting format error if only one, null, component (archive is just a header) 04/18/85 Steve Herbst */
 29 
 30 
 31 /* *      Note: this procedure assumes that all archives do, in fact, contain only the strings
 32    *      archive_data_$ident and archive_data_$header_end to identify their headers. The use
 33    *      of archive_data_$header_begin and archive_data_$header_end was evidently an improvement
 34    *      which was never implemented, and can therefore be ignored here. No existing code in
 35    *      the system generates archives containing either of those strings. The archive command,
 36    *      in fact, cannot deal with such archives.
 37    */
 38 
 39 dcl  P_archive_ptr pointer parameter;                       /* Input: pointer to archive */
 40 dcl  P_archive_bc fixed bin (24) parameter;                 /* Input: archive bitcount */
 41                                                             /* All entries take the same first two arguments */
 42 dcl  P_component_name char (*) parameter;                   /* Input: component to search for or update */
 43                                                             /* Output for archive_$next_component */
 44 dcl  P_component_ptr pointer parameter;                     /* Output: pointer to base of component */
 45                                                             /* Input/Output for archive_$next_component("" _info) */
 46 dcl  P_component_bc fixed bin (24) parameter;               /* Output: bitcount of component */
 47 dcl  P_archive_component_info_ptr pointer parameter;        /* Input: pointer to archive_component_info to fill in */
 48 dcl  P_info_version fixed bin parameter;                    /* Input: version number of listing structure caller wants */
 49 dcl  P_area_ptr pointer parameter;                          /* Input: pointer to area for list */
 50 dcl  P_n_components fixed bin;                              /* Output: number of components in archive */
 51 dcl  P_component_list_ptr pointer parameter;                /* Output: pointer to array of component infos */
 52 dcl  P_code fixed bin (35) parameter;
 53 
 54 dcl  archive_ptr pointer;                                   /* Pointer and size of the archive being worked on */
 55 dcl  archive_bc fixed bin (24);
 56 dcl  archive_size fixed bin (19);
 57 
 58 dcl  component_name char (32);
 59 dcl  component_ptr pointer;
 60 
 61 dcl  header_ptr pointer;                                    /* All information about the current component */
 62 dcl 1 comp_info like archive_component_info aligned automatic;
 63 
 64 dcl  comp_list_ptr pointer;
 65 dcl  n_components fixed bin;
 66 dcl  comp_idx fixed bin;
 67 dcl 1 comp_list (n_components) like archive_component_info aligned based (comp_list_ptr);
 68 dcl  output_area_ptr pointer;
 69 dcl  output_area area based (output_area_ptr);
 70 
 71 dcl  info_sw bit (1) aligned;
 72 
 73 dcl  convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
 74 
 75 dcl  error_table_$archive_fmt_err fixed bin (35) external static;
 76 dcl  error_table_$bad_arg fixed bin (35) external static;
 77 dcl  error_table_$no_component fixed bin (35) external static;
 78 dcl  error_table_$not_archive fixed bin (35) external static;
 79 dcl  error_table_$unimplemented_version fixed bin (35) external static;
 80 
 81 dcl  archive_data_$ident char (8) aligned external static;
 82 dcl  archive_data_$header_end char (8) aligned external static;
 83 
 84 dcl (addrel, baseno, binary, divide, ltrim, null, pointer, rel, rtrim, size, string, substr, unspec, verify) builtin;
 85 
 86 dcl  cleanup condition;
 87 
 88 /* ^L */
 89 
 90 archive_$get_component: entry (P_archive_ptr, P_archive_bc, P_component_name, P_component_ptr, P_component_bc, P_code);
 91 
 92           P_component_ptr = null ();
 93           P_component_bc = 0;
 94           info_sw = "0"b;
 95           goto GET_COMPONENT_COMMON;
 96 
 97 
 98 archive_$get_component_info: entry (P_archive_ptr, P_archive_bc, P_component_name, P_archive_component_info_ptr, P_code);
 99 
100           archive_component_info_ptr = P_archive_component_info_ptr;
101           if archive_component_info.version ^= ARCHIVE_COMPONENT_INFO_VERSION_1 then
102                call FINISH (error_table_$unimplemented_version);
103 
104           info_sw = "1"b;
105           goto GET_COMPONENT_COMMON;
106 
107 
108 GET_COMPONENT_COMMON:
109           call CHECK_ARCHIVE;
110 
111           component_name = P_component_name;
112 
113           do header_ptr = (NEXT_HEADER_PTR ())
114                     repeat (NEXT_HEADER_PTR ())
115                     while (header_ptr ^= null ());
116 
117                if comp_info.name = component_name then
118                     goto FOUND_COMPONENT;
119                end;
120 
121           call FINISH (error_table_$no_component);          /* never returns */
122 
123 FOUND_COMPONENT:
124           if info_sw then                                   /* only call convert_date_to_binary_ if needful, to */
125                call GET_ALL_COMPONENT_INFO;                 /* avoid unnecessary expense. */
126 
127           if ^info_sw then do;                              /* Return pointer and length */
128                P_component_ptr = comp_info.comp_ptr;
129                P_component_bc = comp_info.comp_bc;
130                end;
131           else archive_component_info = comp_info;                    /* Just fill in the structure from our copy */
132 
133           call FINISH (0);                                  /* All done, return successfully */
134 
135 /* ^L */
136 
137 archive_$next_component: entry (P_archive_ptr, P_archive_bc, P_component_ptr, P_component_bc, P_component_name, P_code);
138 
139           component_ptr = P_component_ptr;                  /* Input/Output parameter */
140 
141           P_component_ptr = null ();                        /* Initialize output arguments */
142           P_component_bc = 0;
143           P_component_name = "";
144           info_sw = "0"b;
145           goto NEXT_COMPONENT_COMMON;
146 
147 
148 archive_$next_component_info: entry (P_archive_ptr, P_archive_bc, P_component_ptr, P_archive_component_info_ptr, P_code);
149 
150           component_ptr = P_component_ptr;                  /* Input/Output parameter */
151           P_component_ptr = null ();                        /* Initialize output argument */
152           archive_component_info_ptr = P_archive_component_info_ptr;
153           if archive_component_info.version ^= ARCHIVE_COMPONENT_INFO_VERSION_1 then
154                call FINISH (error_table_$unimplemented_version);
155 
156           info_sw = "1"b;
157           goto NEXT_COMPONENT_COMMON;
158 
159 
160 NEXT_COMPONENT_COMMON:
161           call CHECK_ARCHIVE;                               /* Get set up */
162 
163           if baseno (archive_ptr) ^= baseno (component_ptr) then /* Ought to do something about this */
164                if component_ptr ^= null () then             /* But don't reject the "first" flag */
165                     call FINISH (error_table_$bad_arg);
166 
167           if component_ptr = null () then                   /* Set up for NEXT_HEADER_PTR protocol */
168                header_ptr = null ();
169           else if binary (rel (component_ptr), 18) < size (archive_header) then  /* Must be a sensible pointer */
170                call FINISH (error_table_$bad_arg);
171           else if binary (rel (component_ptr), 18) > archive_size then /* Must not be past the end */
172                call FINISH (error_table_$bad_arg);
173           else if pointer (component_ptr, rel (component_ptr)) ^= component_ptr then /* Make sure it's a word boundary */
174                call FINISH (error_table_$bad_arg);
175           else do;
176                header_ptr = addrel (component_ptr, 0 - size (archive_header)); /* Back up the header itself */
177                call GET_COMPONENT_INFO;
178                end;
179 
180           header_ptr = NEXT_HEADER_PTR ();                  /* get the next one */
181 
182           if header_ptr = null () then do;                  /* We have run out of components */
183                if info_sw then do;                          /* Clear out the comp_info as well */
184                     unspec (archive_component_info) = ""b;
185                     archive_component_info.version = ARCHIVE_COMPONENT_INFO_VERSION_1;
186                     archive_component_info.comp_ptr = null ();
187                     end;
188                else P_component_bc = 0;
189 
190                call FINISH (0);                             /* All done with this archive */
191                end;
192 
193           P_component_ptr = comp_info.comp_ptr;             /* Return the Input/Output parameter */
194 
195           if info_sw then do;                               /* only call convert_date_to_binary_ if needful, to */
196                call GET_ALL_COMPONENT_INFO;                 /* avoid unnecessary expense. */
197                archive_component_info = comp_info;
198                end;
199 
200           else do;                                          /* Otherwise, just return pointer and length */
201                P_component_bc = comp_info.comp_bc;
202                P_component_name = comp_info.name;
203                end;
204 
205           call FINISH (0);                                  /* All done, return successfully */
206 
207 /* ^L */
208 
209 archive_$list_components: entry (P_archive_ptr, P_archive_bc,
210           P_info_version, P_area_ptr, P_component_list_ptr, P_n_components, P_code);
211 
212           output_area_ptr = P_area_ptr;                     /* Locate the area we shall allocate the list in */
213           P_n_components = 0;                               /* Initialize output arguments */
214           P_component_list_ptr = null ();
215 
216           if P_info_version ^= ARCHIVE_COMPONENT_INFO_VERSION_1 then /* Make sure we agree with the caller */
217                call FINISH (error_table_$unimplemented_version); /* about the info structure version */
218 
219           call CHECK_ARCHIVE;                               /* See if it's in the least OK */
220 
221           n_components = 0;                                 /* First, count the components -- this will also validate */
222           header_ptr = null ();                             /* the entire archive */
223 
224           do header_ptr = (NEXT_HEADER_PTR ())
225                     repeat (NEXT_HEADER_PTR ())
226                     while (header_ptr ^= null ());
227 
228                n_components = n_components + 1;
229                end;
230 
231           if (n_components = 0) | (output_area_ptr = null ()) then do; /* Nothing there, or no list wanted */
232                P_n_components = n_components;
233                call FINISH (0);                             /* Return successfully */
234                end;
235 
236           on cleanup begin;
237                if comp_list_ptr ^= null () then
238                     free comp_list in (output_area);
239                P_component_list_ptr = null ();              /* Don't let user think we didn't free this */
240                end;
241 
242           allocate comp_list in (output_area) set (comp_list_ptr);
243 
244           comp_idx = 1;
245           do header_ptr = (NEXT_HEADER_PTR ())              /* Now, go through and list the components */
246                     repeat (NEXT_HEADER_PTR ())
247                     while (header_ptr ^= null ());
248 
249                call GET_ALL_COMPONENT_INFO;                 /* Fill in the whole thing */
250                comp_list (comp_idx) = comp_info;            /* and put it in the array */
251                comp_idx = comp_idx + 1;                     /* Advance to next component */
252                end;
253 
254           P_component_list_ptr = comp_list_ptr;
255           P_n_components = n_components;
256 
257           call FINISH (0);                                  /* All done for listing */
258 
259 /* ^L */
260 
261 MAIN_RETURN:                                                /* This label is the only way out of the program */
262           return;
263 
264 FORMAT_ERROR:                                               /* General-purpose format error exit */
265           if comp_list_ptr ^= null () then                  /* Clean up anything we might have allocated */
266                free comp_list;
267           comp_list_ptr = null ();
268 
269           call FINISH (error_table_$archive_fmt_err);
270 
271 
272 
273 FINISH: proc (P_return_code);
274 
275 dcl  P_return_code fixed bin (35) parameter;
276 
277 /* This is just a convenient way of exiting and returning a specific error code */
278 
279           P_code = P_return_code;                           /* Set the main procedure return code */
280           goto MAIN_RETURN;
281 
282           end FINISH;
283 
284 
285 
286 CHECK_ARCHIVE: proc ();
287 
288 /* This procedure copies the standard parameters, and verifies that the
289    segment does, indeed, seem to be an archive. */
290 
291           comp_list_ptr = null ();                          /* For cleanup handler */
292           archive_ptr = pointer (P_archive_ptr, 0);         /* Adjust to base of archive segment */
293 
294           archive_bc = P_archive_bc;
295           archive_size = divide (archive_bc, 36, 19, 0);
296 
297           if archive_bc ^= (36 * archive_size) then         /* Can't be if bitcount is not word aligned */
298                call FINISH (error_table_$not_archive);
299 
300           header_ptr = null ();                             /* Make NEXT_HEADER_PTR look for the first */
301 
302           if archive_size = 0 then                          /* No components is OK, though perhaps undesired */
303                return;
304 
305           if archive_size < size (archive_header) then      /* Must have enough to be an archive */
306                call FINISH (error_table_$not_archive);
307 
308           if (archive_ptr -> archive_header.header_begin ^= archive_data_$ident) then
309                call FINISH (error_table_$not_archive);      /* Probably not, and this is a better message than */
310                                                             /* format error if it truly isn't an archive */
311 
312           if (archive_ptr -> archive_header.header_end ^= archive_data_$header_end) then
313                call FINISH (error_table_$not_archive);
314 
315           P_code = 0;                                       /* Set standard output parameter for success, and */
316           return;                                           /* assume it's valid, and let someone else */
317           end CHECK_ARCHIVE;                                /* find out that it is not if need be. */
318 
319 /* ^L */
320 
321 NEXT_HEADER_PTR: proc () returns (pointer);
322 
323 /* This procedure advances header_ptr to point to the header for the next component,
324    validates the header, and returns the pointer to it. It assumes that header_ptr
325    already points to a validated header, unless it is null, in which case it sets
326    header_ptr to point to the first header in the archive.
327    */
328 
329           if header_ptr = null () then                      /* First component */
330                if archive_size = 0 then                     /* But, archive is empty */
331                     return (null ());
332                else header_ptr = archive_ptr;               /* really first */
333           else do;
334                if binary (rel (header_ptr), 18) + size (archive_header) + comp_info.comp_lth >= archive_size then
335                     return (null ());                       /* We have reached the last component */
336                header_ptr = addrel (header_ptr, (size (archive_header) + comp_info.comp_lth));
337                end;
338 
339           call GET_COMPONENT_INFO;                          /* make sure this header seems OK, */
340                                                             /* and extract all the information from it */
341           return (header_ptr);
342           end NEXT_HEADER_PTR;
343 
344 /* ^L */
345 
346 GET_COMPONENT_INFO: proc ();
347 
348 /* This procedure ascertains that header_ptr points to something looking
349    reasonably like an archive component header. It verifies as well as it
350    can that the times and the access are valid, although it does not actually
351    calculate them. To fill in those values, GET_ALL_COMPONENT_INFO should be
352    called.
353    */
354 
355 dcl  TIME_CHARACTERS char (13) internal static options (constant) init ("0123456789 ./");
356 dcl  MODE_CHARACTERS char (5) internal static options (constant) init ("rewa ");
357 dcl  BITCOUNT_CHARS char (10) internal static options (constant) init ("0123456789");
358 
359 
360 
361           if (header_ptr -> archive_header.header_begin ^= archive_data_$ident) then
362                goto FORMAT_ERROR;
363 
364           if (header_ptr -> archive_header.header_end ^= archive_data_$header_end) then
365                goto FORMAT_ERROR;
366 
367 /* These machinations with the bitcount are necessary because some archives in the system contain
368    the bitcount left justified in the eight character field, rather than right justified. How they
369    got that way is anybodys guess, but if archive can handle them, this should, too.
370    */
371 
372           if header_ptr -> archive_header.bit_count = "" then
373                goto FORMAT_ERROR;
374           if verify (rtrim (ltrim (header_ptr -> archive_header.bit_count)), BITCOUNT_CHARS) ^= 0 then
375                goto FORMAT_ERROR;
376 
377           if verify (header_ptr -> archive_header.timeup, TIME_CHARACTERS) ^= 0 then
378                goto FORMAT_ERROR;
379           if verify (header_ptr -> archive_header.time, TIME_CHARACTERS) ^= 0 then
380                goto FORMAT_ERROR;
381 
382           unspec (comp_info) = ""b;
383           comp_info.version = ARCHIVE_COMPONENT_INFO_VERSION_1;       /* So it's safer to just return this structure */
384           comp_info.comp_ptr = addrel (header_ptr, size (archive_header)); /* First data after header structure */
385           comp_info.comp_bc = binary (ltrim (rtrim (header_ptr -> archive_header.bit_count)), 28);
386                                                             /* Avoid size condition here by using precision 28 */
387 
388           comp_info.name = header_ptr -> archive_header.name;
389           comp_info.comp_lth = divide (comp_info.comp_bc + 35, 36, 18, 0);
390 
391           if archive_size < (binary (rel (comp_info.comp_ptr), 18) + comp_info.comp_lth) then
392                goto FORMAT_ERROR;                           /* component extends past the end, sad to say */
393                                                             /* This will also catch generally oversize bitcounts */
394           if verify (header_ptr -> archive_header.mode, MODE_CHARACTERS) ^= 0 then
395                goto FORMAT_ERROR;
396 
397           return;
398           end GET_COMPONENT_INFO;
399 
400 /* ^L */
401 
402 GET_ALL_COMPONENT_INFO: proc ();
403 
404 /* This procedure fills in all the rest of the comp_info structure, which is
405    is only needed by some entrypoints.
406    */
407 
408 dcl 1 mode_str unaligned,                                   /* For mode testing */
409     2 read char (1) unaligned,
410     2 execute char (1) unaligned,
411     2 write char (1) unaligned,
412     2 pad char (1) unaligned;
413 dcl  code fixed bin (35);
414 
415 
416           string (mode_str) = header_ptr -> archive_header.mode;
417           comp_info.access = ""b;                           /* Prepare to figure out the access modes */
418 
419           if mode_str.read = "r" then
420                substr (comp_info.access, 1, 1) = "1"b;      /* Read */
421           else if mode_str.read ^= " " then
422                goto FORMAT_ERROR;
423 
424           if mode_str.execute = "e" then
425                substr (comp_info.access, 2, 1) = "1"b;      /* Execute */
426           else if mode_str.execute ^= " " then
427                goto FORMAT_ERROR;
428 
429           if mode_str.write = "w" then
430                substr (comp_info.access, 3, 1) = "1"b;      /* Write */
431           else if mode_str.write ^= " " then
432                goto FORMAT_ERROR;
433 
434           if (mode_str.pad ^= " ") & (mode_str.pad ^= "a") then /* Obsolete -- used to mean append */
435                goto FORMAT_ERROR;                           /* Complain if it's wrong, anyway */
436 
437           call convert_date_to_binary_ (string (header_ptr -> archive_header.time), comp_info.time_modified, code);
438           if code ^= 0 then                                 /* Just complain about archive badness, rather than */
439                goto FORMAT_ERROR;                           /* whatever specific error it is */
440 
441           call convert_date_to_binary_ (string (header_ptr -> archive_header.timeup), comp_info.time_updated, code);
442           if code ^= 0 then
443                goto FORMAT_ERROR;
444 
445           return;
446           end GET_ALL_COMPONENT_INFO;
447 
448 %page;    %include archive_header;
449 %page;    %include archive_component_info;
450 
451           end archive_;