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 save_previous_system: sps:    proc;
 12 
 13 
 14 dcl
 15      AREA                     char(8) init ("hardcore"),
 16      ROOT                     char(168) aligned,
 17      LIBRARY_DIR              char(168) aligned,
 18      HOLD_DIR                 char(168) aligned,
 19      SYSID_STAR               char(32) aligned,
 20      SYS_ID                   char(8) init ("0.0"),
 21      UPDATING_DIR             char(168) aligned,
 22      Nargs                    fixed bin,
 23      acode                    fixed bin,
 24      area_ptr                 ptr,
 25      arg                      char(arg_len) based (arg_ptr),
 26      arg_len                  fixed bin,
 27      arg_ptr                  ptr,
 28      bitc                     fixed bin(24),
 29      code                     fixed bin(35),
 30      error                    bit(1) init ("0"b),
 31      found                    bit(1) init ("0"b),
 32      i                        fixed bin,
 33      k                        fixed bin,
 34      me                       char(32) init ("save_previous_system"),
 35      restart_sw               bit(1) init ("0"b),
 36      rev_sw                   bit(1) init ("0"b),
 37      ringbr (3)               fixed bin(3) init ( 7, 7, 7 ),
 38      segname                  char(32) aligned,
 39      segptr                   ptr;
 40 
 41 dcl  1  entries (entry_count) aligned based (entry_ptr),
 42        (2  type               bit(2),
 43         2  nnames             fixed bin(15),
 44         2  nindex             fixed bin(17) ) unaligned;
 45 
 46 dcl
 47      entry_count              fixed bin,
 48      entry_ptr                ptr,
 49      name_ptr                 ptr,
 50      names (entry_count)      char(32) based (name_ptr);
 51 
 52 dcl ( rtrim, substr, addr, null, index )          builtin;
 53 ^L
 54 dcl
 55      cu_$arg_count                      entry returns (fixed bin),
 56      cu_$arg_ptr                        entry ( fixed bin, ptr, fixed bin, fixed bin(35)),
 57      get_group_id_$tag_star             entry returns (char(32)),
 58      get_system_free_area_              entry returns (ptr),
 59      hcs_$add_inacl_entries             entry ( char(*) aligned, char(*), ptr, fixed bin, fixed bin(3), fixed bin(35) ),
 60      hcs_$append_branchx                entry ( char(*) aligned, char(*), fixed bin(5), (3) fixed bin(3),
 61                                              char(*) aligned, fixed bin(1), fixed bin(1), fixed bin(24), fixed bin(35) ),
 62      hcs_$add_dir_acl_entries           entry ( char(*) aligned, char(*), ptr, fixed bin, fixed bin(35) ),
 63      hcs_$star_                         entry ( char(*) aligned, char(*) aligned, fixed bin(2), ptr, fixed bin, ptr, ptr,
 64                                          fixed bin(35)),
 65      hcs_$terminate_noname              entry ( ptr, fixed bin(35)),
 66      hcs_$initiate_count                entry ( char(*) aligned, char(*), char(*), fixed bin(24),
 67                                              fixed bin(2), ptr, fixed bin(35)),
 68      com_err_                           entry options (variable),
 69      archive_util_$first_disected
 70                                         entry ( ptr, ptr, char(*) aligned, fixed bin(24), fixed bin),
 71      archive_util_$disected_element
 72                                         entry ( ptr, ptr, char(*) aligned, fixed bin(24), fixed bin),
 73           lib_fetch_                    entry (ptr, ptr, ptr, bit(72) aligned, bit(36) aligned, ptr, fixed bin(35));
 74 
 75 
 76 
 77 dcl  1  dir_acl               aligned,
 78         2  access_name        char(32),
 79         2  dir_modes          bit(36),
 80         2  code               fixed bin(35);
 81 dcl  1  segment_acl           aligned,
 82         2  access_name        char(32),
 83         2  modes              bit(36),
 84         2  pad                bit(36),
 85         2  code               fixed bin(35);
 86 
 87 
 88 dcl  error_table_$archive_fmt_err       ext fixed bin(35),
 89      error_table_$bad_arg               ext fixed bin(35),
 90      error_table_$namedup               ext fixed bin(35),
 91      error_table_$noarg                 ext fixed bin(35),
 92      error_table_$argerr                ext fixed bin(35),
 93      error_table_$noentry               ext fixed bin(35),
 94      error_table_$no_dir                ext fixed bin(35);
 95 
 96      dcl                                                    /*        automatic variables                     */
 97           1 arg_struc_temp              like arg_struc;     /* storage for argument structure.                */
 98 
 99 dcl  True                     bit(1) aligned init ("1"b);
100 
101 dcl  cleanup                  condition;
102 ^L
103           area_ptr = null;
104           entry_ptr = null;
105           name_ptr = null;
106           dir_acl.access_name = get_group_id_$tag_star();             /* ME */
107           dir_acl.dir_modes = "111"b;                                 /*  "sma"  */
108           dir_acl.code = 0;
109           segment_acl.access_name = "*.*.*";                          /*  everyone  */
110           segment_acl.modes = "100"b;                                 /*  "r"  */
111           segment_acl.pad = "0"b;
112           segment_acl.code = 0;
113 
114           Nargs = cu_$arg_count ();
115           if Nargs < 1 then do;                                       /* MUST give at least 1 argumment */
116                call com_err_ ((error_table_$noarg), me,
117                     "^/Usage is: ^a <system-id> {-library LIBRARY} {-restart}", me );
118                return;
119           end;
120 
121           call cu_$arg_ptr ( 1, arg_ptr, arg_len, code );             /* Get first argument. */
122           if code ^= 0 then do;                                       /* This MUST be the system-id. */
123                call com_err_ ( code, me, "Processing argument #1." );
124                return;
125           end;
126           if substr ( arg, 1, 1 ) = "-" then do;                      /* control argument not allowed here */
127                call com_err_ (0, me, """^a"" is an invalid system id", arg);
128                return;
129           end;
130           if arg_len > 8 then do;
131                call com_err_ ( error_table_$bad_arg, me,
132                     "^/The <system-id> argument must be 8 characters or less:  ^a", arg );
133                return;
134           end;
135           SYS_ID = arg;
136 
137           i = 1;
138           do while ( i < Nargs );                                     /* Process rest of arguments */
139                i = i + 1;
140                call cu_$arg_ptr ( i, arg_ptr, arg_len, code );
141                if code ^= 0 then do;
142                     call com_err_ (code, me, "Processing argment # ^d", i);
143                     return;
144                end;
145 
146                else if arg = "-restart"
147                     then restart_sw = "1"b;
148 
149                else if arg = "-library" then do;
150                     i = i + 1;
151                     call cu_$arg_ptr ( i, arg_ptr, arg_len, code );
152                     if code ^= 0 then do;
153                          call com_err_ (code, me, "The ""-library"" control argument requires an argument." );
154                          error = "1"b;
155                          go to next_arg;
156                     end;
157                     if substr ( arg, 1, 1) = "-" then do;
158                          call com_err_ (error_table_$bad_arg, me,
159                               "^/Incorrect argument following the ""-library"" control argument." );
160                          error = "1"b;
161                          go to next_arg;
162                     end;
163                     if ^VERIFY_AREA ( arg ) then do;                  /* verify the area name                 */
164                          call com_err_ (error_table_$bad_arg, me,
165                               "^/Incorrect area specified following the ""-library"" control argument.  ^a", arg  );
166                          error = "1"b;
167                          go to next_arg;
168                     end;
169                end;
170 
171                else do;
172                     call com_err_(error_table_$bad_arg, me, "^/The ""^a"" argument is not implemented.", arg );
173                     error = "1"b;
174                end;
175 
176 next_arg:
177           end;
178 
179           if error                                                    /* ON if argument error.   */
180                then return;                                           /* Already reported, so leave gracefully. */
181 
182                                                                       /* build directory pathnames given system ID */
183           if AREA ^= "mcs"
184                then ROOT = ">ldd>" || AREA;                           /* e.g.  ">ldd>hardcore"                */
185                else ROOT = ">ldd>comm>fnp";                           /* special case MCS dirs                */
186 
187           UPDATING_DIR = rtrim ( ROOT ) || ">" || SYS_ID;                       /* e.g.  ">ldd>hardcore>34.21"          */
188           LIBRARY_DIR  = rtrim ( ROOT ) || ">" || "source";                     /* e.g.  ">ldd>hardcore>source"         */
189           HOLD_DIR     = rtrim ( ROOT ) || ">" || rtrim ( SYS_ID ) || "hold";   /* e.g.  ">ldd>hardcore>34.21hold"      */
190 
191           area_ptr = get_system_free_area_ ();
192                                                                       /* get list of names in updating directory */
193           call hcs_$star_ ( UPDATING_DIR, "**", 2, area_ptr, entry_count, entry_ptr, name_ptr, code );
194           if code ^= 0 then do;
195                     if code = error_table_$no_dir
196                          then call com_err_ ( code, me, "^/Updating directory ^a not found.", UPDATING_DIR );
197                          else call com_err_ ( code, me, "^a", UPDATING_DIR  );
198                return;                                                /* if it ain't there, or can't get to it... */
199           end;
200           if entry_count = 0 then do;                                 /* no entries found ?? */
201                call com_err_ ( error_table_$noentry, me, "^a", UPDATING_DIR );
202                return;
203           end;
204 
205           on cleanup call CLEANUP;                                    /* set up a cleanup handler   */
206                                                                       /* create the "HOLD" directory for previous source */
207           call hcs_$append_branchx ( ROOT, (rtrim (SYS_ID)) || "hold", 01011b, ringbr, dir_acl.access_name, 1, 0, 0, code );
208           if code ^= 0
209                then if code = error_table_$namedup then do;           /* it's already there, make sure we're on the ACL */
210                     call hcs_$add_dir_acl_entries ( ROOT, (rtrim(SYS_ID)) || "hold", addr(dir_acl), 1, code );
211                     if code ^= 0 then do;
212                          if code = error_table_$argerr
213                               then code = dir_acl.code;
214                          call com_err_ ( code, me, "^/Unable to set access on ^a", HOLD_DIR );
215                          return;
216                     end;
217                end;
218                else do;
219                     call com_err_ ( code, me, "^/Unable to create save directory ^a", HOLD_DIR );
220                     return;
221                end;
222 
223           call INIT;                                                  /* initialize some variables for lib_fetch_. */
224                                                                       /* add initial ACL for "r *.*.*" */
225           call hcs_$add_inacl_entries ( ROOT, (rtrim(SYS_ID) || "hold"), addr(segment_acl), 1, 4, code );
226           if code ^= 0                                                /* this is not a fatal error */
227                then call com_err_ ((segment_acl.code), me, "^/Warning: Unable to add initial ACL entry to ^a>^a",
228                     ROOT, (rtrim(SYS_ID) || "hold") );
229 
230           STARNAME.N = 1;                                             /* Initialize number of names. */
231 
232           do i = 1 to entry_count;                                    /* for each entry... */
233 
234                k = entry_ptr -> entries(i).nindex;                    /* set index into names array */
235 
236                call FETCH ( names(k) );                               /* FETCH exercise the judgement */
237 
238           end;
239 
240           revert cleanup;                                             /* turn off handler */
241           call CLEANUP;                                               /* make sure we cleanup anyhow */
242           return;                                                     /* NORMAL RETURN */
243 ^L
244 FETCH:  procedure ( fetch_name );
245 
246 dcl
247      fetch_name               char(*),                                /* entry name from UPDATING_DIR */
248      diff_names (1000)        char(32),                               /* for comparison of archive entries */
249      diff_count               fixed bin,                              /* and the number of "diff_names" */
250      i                        fixed bin;
251 
252 
253           if index ( fetch_name, ".s.archive" ) ^= 0                  /* special case source archives */
254                then go to source_ac;
255 
256           if ^STATUS ( LIBRARY_DIR, fetch_name )                      /* if it's not there...       */
257                then return;
258 
259           STARNAME.group(1).V = fetch_name;                           /* fill in info for lib_fetch_ */
260           STARNAME.group(1).C = 0;                                    /* zero code */
261 
262           if ^Sc.default & ^S.names & ^S.matching_names & ^S.primary_name then
263                S.matching_names = True;                               /* use matching names by default.                 */
264 
265                                                                       /* CALL LIB_FETCH_                                */
266           call lib_fetch_ (addr(LIBRARY), addr(STARNAME), addr(EXCLUDE), Srequirements, Scontrol, addr(arg_struc), code);
267                                                                       /* all errors reported by lib_fetch_.             */
268           return;                                                     /* and return                                     */
269 
270 source_ac:                                                            /* SPECIAL CASE OF SOURCE ARCHIVES                */
271                                                                       /* call subr. to get names of component changes   */
272                                                                       /* A deletion, or a date-time-updated difference  */
273                                                                       /* is assumed to be a change.                     */
274           call compare_archives_ ( LIBRARY_DIR, fetch_name, UPDATING_DIR, fetch_name, diff_names, diff_count );
275 
276           if diff_count = 0 then do;                                  /* 0 = there were no changes made (??)            */
277                call com_err_ (0, me, "Warning: ^a>^a^/^5xis identical to ^a>^a.",
278                     UPDATING_DIR, fetch_name, LIBRARY_DIR, fetch_name );
279                     return;                                           /* warn user and continue                         */
280           end;
281 
282           do i = 1 to diff_count;                                     /* and for each one of the changes... */
283                call FETCH ( diff_names(i) );                          /* recurse... */
284           end;
285           return;
286           end FETCH;
287 
288 
289 STATUS:  proc ( path, entry ) returns ( bit(1) );
290 
291 dcl  path  char(168) aligned,
292      entry char(*),
293      status bit(144) aligned,
294      hcs_$status_ entry ( char(*) aligned, char(*), fixed bin(1), ptr, ptr, fixed bin(35));
295 
296           call hcs_$status_ ( path, entry, 1, addr(status), null, code );
297           if code ^= 0
298                then return ("0"b);
299                else return ("1"b);
300 
301           end STATUS;
302 
303 
304 ^L
305 CLEANUP:  procedure;
306 
307           if entry_ptr ^= null                                                  /* free up some space         */
308                then free entries;
309           entry_ptr = null;
310 
311           if name_ptr ^= null
312                then free names;
313           name_ptr = null;
314 
315           return;
316 end CLEANUP;
317 
318 VERIFY_AREA:  procedure ( system_name ) returns ( bit(1) );
319 
320 dcl
321      system_name              char(*),                                          /* argument given by user               */
322      valid_names (6)          char(12) init                                     /* "legal" names                        */
323           ( "hardcore", "hard", "supervisor", "sup", "bos", "mcs" ),
324      area_index  (6)          fixed bin init
325           ( 1, 1, 1, 1, 2, 3 ),
326      proper_name (3)          char(8) init                                      /* proper name equivalent               */
327           ( "hardcore", "bos", "mcs" );
328 
329           do i = 1 to dim ( valid_names, 1 );                                   /* check against "legal" names          */
330               if system_name = valid_names(i) then do;
331                     AREA = proper_name ( area_index(i) );                       /* set to proper name                   */
332                     go to found_area;
333                end;
334           end;
335                                                                                 /* didn't find proper name              */
336           return ("0"b);                                                        /* return FALSE                         */
337 
338 found_area:
339           return ("1"b);                                                        /* return TRUE                          */
340 
341 end VERIFY_AREA;
342 ^L
343 INIT: proc;
344 
345           Parg_struc = addr(arg_struc_temp);                /* Initialize argument processing structure.      */
346           arg_struc.version = Varg_struc_1;
347           arg_struc.program = me;                           /*  caller  */
348           arg_struc.put_error = com_err_;
349           arg_struc.descriptor = "";                        /* use default library_descriptor */
350           arg_struc.into_path = rtrim (HOLD_DIR) || ">==";  /* where segments are to be put */
351           arg_struc.output_file = "";
352           LIBRARY.N = 1;                                    /* only search the source library for */
353           LIBRARY.group(1).V = rtrim(AREA) || ".s";         /* specified area.     */
354           LIBRARY.group(1).C = 0;                           /* since we filled it in... */
355 
356           STARNAME.N = 1;
357           arg_struc.Srequirements_allowed = ""b;
358           arg_struc.Srequirements_initial = ""b;
359           arg_struc.Scontrol_allowed = ""b;
360           arg_struc.Scontrol_initial = ""b;
361 
362           Sreq_allowed.access_class        = True;          /* Mark Sreq bits-  show which output args allowed*/
363           Sreq_allowed.acl                 = True;
364           Sreq_allowed.aim                 = True;
365           Sreq_allowed.author              = True;
366           Sreq_allowed.bit_count           = True;
367           Sreq_allowed.bit_count_author    = True;
368           Sreq_allowed.compiler_name       = True;
369           Sreq_allowed.compiler_options    = True;
370           Sreq_allowed.compiler_version    = True;
371           Sreq_allowed.copy                = True;
372           Sreq_allowed.current_length      = True;
373           Sreq_allowed.dtc                 = True;
374           Sreq_allowed.dtd                 = True;
375           Sreq_allowed.dtem                = True;
376           Sreq_allowed.dtm                 = True;
377           Sreq_allowed.dtu                 = True;
378           Sreq_allowed.entry_bound         = True;
379           Sreq_allowed.iacl                = True;
380           Sreq_allowed.kids                = True;
381           Sreq_allowed.kids_error          = True;
382           Sreq_allowed.level               = True;
383           Sreq_allowed.link_target         = True;
384           Sreq_allowed.lvid                = True;
385           Sreq_allowed.matching_names      = True;
386           Sreq_allowed.max_length          = True;
387           Sreq_allowed.mode                = True;
388           Sreq_allowed.msf_indicator       = True;
389           Sreq_allowed.names               = True;
390           Sreq_allowed.new_line            = True;
391           Sreq_allowed.not_ascii           = True;
392           Sreq_allowed.object_info         = True;
393           Sreq_allowed.offset              = True;
394           Sreq_allowed.pathname            = True;
395           Sreq_allowed.primary_name        = True;
396           Sreq_allowed.pvid                = True;
397           Sreq_allowed.quota               = True;
398           Sreq_allowed.rb                  = True;
399           Sreq_allowed.records_used        = True;
400           Sreq_allowed.root_search_proc    = True;
401           Sreq_allowed.safety              = True;
402           Sreq_allowed.type                = True;
403           Sreq_allowed.unique_id           = True;
404           Sreq_allowed.user                = True;
405 
406 
407 
408           Sreq_init.user                   = True;          /* Mark bits on by default.                       */
409 
410           Sc_allowed.acl            = True;                 /* Mark Sc bits- show which ctl args allowed.     */
411           Sc_allowed.all_status     = True;
412           Sc_allowed.chase          = True;
413           Sc_allowed.check_archive  = True;
414           Sc_allowed.check_ascii    = True;
415           Sc_allowed.components     = True;
416           Sc_allowed.container      = True;
417           Sc_allowed.default        = True;
418           Sc_allowed.iacl           = True;
419           Sc_allowed.object_info    = True;
420           Sc_allowed.quota          = True;
421           Sc_allowed.retain         = True;
422           Sc_allowed.descriptor     = True;
423           Sc_allowed.into_path      = True;
424           Sc_allowed.long           = True;
425           Sc_allowed.library        = True;
426           Sc_allowed.output_file    = True;
427           Sc_allowed.search_names   = True;
428 
429           Sc_init.into_path         = True;                 /* Mark bits for ctl args supplied by default.    */
430           Sc_init.default           = True;
431 
432           end INIT;
433 ^L
434 
435 compare_archives_:  procedure ( first_dir, first_entry, second_dir, second_entry, return_array, return_count );
436 
437 dcl
438      first_dir                char(*) aligned,
439      second_dir               char(*) aligned,
440      first_entry              char(*),
441      second_entry             char(*),
442      return_array (1000)      char(32),
443      return_count             fixed bin;
444 
445 dcl
446     (i, j, x)                 fixed bin,
447      head_ptr                 ptr,
448      save_ptr                 ptr,
449      seg_name                 char(32),
450      bit_count                fixed bin(24),
451      bitc                     fixed bin(24),
452      acode                    fixed bin,
453      seg_ptr                  ptr,
454      first_count              fixed bin,
455      second_count             fixed bin,
456      code                     fixed bin(35),
457      error_table_$archive_fmt_err
458                               ext fixed bin(35),
459      null                     builtin,
460      index                    builtin,
461      me                       char(2) init ("me");
462 
463 dcl
464      com_err_                           entry options (variable),
465      hcs_$initiate_count                entry (char(*) aligned, char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35)),
466      hcs_$terminate_noname              entry ( ptr, fixed bin(35)),
467      archive_util_$first_disected       entry ( ptr, ptr, char(*), fixed bin(24), fixed bin),
468      archive_util_$disected_element     entry ( ptr, ptr, char(*), fixed bin(24), fixed bin);
469 
470 dcl  1  archive_item aligned based (head_ptr),
471       (2  header_begin        char(8),
472        2  pad1                char(4),
473        2  name                char(32),
474        2  dtupd               char(16),
475        2  mode                char(4),
476        2  dtm                 char(16),
477        2  pad2                char(4),
478        2  bitct               char(8),
479        2  header_end          char(8) ) unal;
480 
481 
482 dcl  1    first_array (1000)  aligned,
483           2  name             char(32),
484           2  date             char(16),
485           2  bitc             char(8);
486 
487 dcl  1    second_array (1000) aligned,
488           2  name             char(32),
489           2  date             char(16),
490           2  bitc             char(8);
491 
492           return_count = 0;                                                     /* just in case we return abnormally    */
493 
494           head_ptr = null;                                                      /* initiate the first archive           */
495           call hcs_$initiate_count ( first_dir, first_entry, "", bit_count, 1, head_ptr, code );
496           if head_ptr = null then do;
497                call com_err_ ( code, me, "^/Attempting to initiate ^a>^a", first_dir, first_entry);
498                return;
499           end;
500 
501           save_ptr = head_ptr;                                                  /* save it's ptr for later termination  */
502           acode, j, x = 0;
503                                                                                 /* get the first component info         */
504           call archive_util_$first_disected ( head_ptr, seg_ptr, seg_name, bitc, acode );
505 
506           do while ( acode = 0 );                                               /* process each component               */
507                j = j + 1;
508                first_array (j).name = seg_name;                                 /* name...                              */
509                first_array (j).date = head_ptr -> archive_item.dtupd;           /* date-time-updated...                 */
510                first_array (j).bitc = head_ptr -> archive_item.bitct;           /* bit-count...                         */
511 
512                                                                                 /* is there next component ??           */
513                call archive_util_$disected_element ( head_ptr, seg_ptr, seg_name, bitc, acode );
514                                                                                 /* acode = 0 means there's next         */
515           end;
516 
517           first_count = j;                                                      /* number in first archive              */
518           call hcs_$terminate_noname ( save_ptr, code );                        /* terminate it                         */
519           if acode = 2 then do;                                                 /* was there a format error ??          */
520                call com_err_ ( error_table_$archive_fmt_err, me, "^/Referencing ^a>^a", first_dir, first_entry);
521                return;
522           end;
523 
524           head_ptr = null;                                                      /* and do the same for the second       */
525           call hcs_$initiate_count ( second_dir, second_entry, "", bit_count, 1, head_ptr, code );
526           if head_ptr = null then do;
527                call com_err_ ( code, me, "^/Attempting to initiate ^a>^a", second_dir, second_entry);
528                return;
529           end;
530 
531           save_ptr = head_ptr;
532           acode, j = 0;
533                                                                                 /* get first component info             */
534           call archive_util_$first_disected ( head_ptr, seg_ptr, seg_name, bitc, acode );
535 
536           do while ( acode = 0 );                                               /* and for each component...            */
537                j = j + 1;
538                second_array (j).name = seg_name;                                /* name...                              */
539                second_array (j).date = head_ptr -> archive_item.dtupd;          /* date-time-updated...                 */
540                second_array (j).bitc = head_ptr -> archive_item.bitct;          /* bit-count...                         */
541 
542                                                                                 /* is there a next ??                   */
543                call archive_util_$disected_element ( head_ptr, seg_ptr, seg_name, bitc, acode );
544                                                                                 /* acode = 0 means yes                  */
545           end;
546 
547           second_count = j;                                                     /* set number in second archive         */
548           call hcs_$terminate_noname ( save_ptr, code );                        /* and terminate it                     */
549           if acode = 2 then do;                                                 /* format error occurred ??             */
550                call com_err_ ( error_table_$archive_fmt_err, me, "^/Referencing ^a>^a", second_dir, second_entry);
551                return;
552           end;
553                                                             /* If entry exists in the first archive, but not in the     */
554                                                             /* second one, put it into our return array.                */
555           do i = 1 to first_count;                          /* If the date-time-updated differs between the two for     */
556                do j = 1 to second_count;                    /* a component, also put it into the list.                  */
557                     if first_array (i).name = second_array (j).name then do;
558                          if first_array (i).date ^= second_array (j).date then do;
559                               x = x + 1;                                        /* DIFFERENT date-time-updated          */
560                               return_array (x) = first_array (i).name;          /* ADD IT TO RETURN ARRAY               */
561                          end;
562                          go to next_first;
563                     end;
564                end;
565                x = x + 1;                                                       /* NAME NOT FOUND IN SECOND ARCHIVE     */
566                return_array (x) = first_array (i).name;                         /* ADD TO RETURN ARRAY                  */
567 next_first:
568           end;
569 
570           return_count = x;                                                     /* SET THE RETURN COUNT AND RETURN      */
571           return;
572 end compare_archives_;
573 ^L
574 %include lib_arg_struc_;
575 ^L
576 %include lib_Svalid_req_;
577 ^L
578 %include lib_Scontrol_;
579 
580           end save_previous_system;