/* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ save_previous_system: sps: proc; dcl AREA char(8) init ("hardcore"), ROOT char(168) aligned, LIBRARY_DIR char(168) aligned, HOLD_DIR char(168) aligned, SYSID_STAR char(32) aligned, SYS_ID char(8) init ("0.0"), UPDATING_DIR char(168) aligned, Nargs fixed bin, acode fixed bin, area_ptr ptr, arg char(arg_len) based (arg_ptr), arg_len fixed bin, arg_ptr ptr, bitc fixed bin(24), code fixed bin(35), error bit(1) init ("0"b), found bit(1) init ("0"b), i fixed bin, k fixed bin, me char(32) init ("save_previous_system"), restart_sw bit(1) init ("0"b), rev_sw bit(1) init ("0"b), ringbr (3) fixed bin(3) init ( 7, 7, 7 ), segname char(32) aligned, segptr ptr; dcl 1 entries (entry_count) aligned based (entry_ptr), (2 type bit(2), 2 nnames fixed bin(15), 2 nindex fixed bin(17) ) unaligned; dcl entry_count fixed bin, entry_ptr ptr, name_ptr ptr, names (entry_count) char(32) based (name_ptr); dcl ( rtrim, substr, addr, null, index ) builtin; dcl cu_$arg_count entry returns (fixed bin), cu_$arg_ptr entry ( fixed bin, ptr, fixed bin, fixed bin(35)), get_group_id_$tag_star entry returns (char(32)), get_system_free_area_ entry returns (ptr), hcs_$add_inacl_entries entry ( char(*) aligned, char(*), ptr, fixed bin, fixed bin(3), fixed bin(35) ), hcs_$append_branchx entry ( char(*) aligned, char(*), fixed bin(5), (3) fixed bin(3), char(*) aligned, fixed bin(1), fixed bin(1), fixed bin(24), fixed bin(35) ), hcs_$add_dir_acl_entries entry ( char(*) aligned, char(*), ptr, fixed bin, fixed bin(35) ), hcs_$star_ entry ( char(*) aligned, char(*) aligned, fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35)), hcs_$terminate_noname entry ( ptr, fixed bin(35)), hcs_$initiate_count entry ( char(*) aligned, char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35)), com_err_ entry options (variable), archive_util_$first_disected entry ( ptr, ptr, char(*) aligned, fixed bin(24), fixed bin), archive_util_$disected_element entry ( ptr, ptr, char(*) aligned, fixed bin(24), fixed bin), lib_fetch_ entry (ptr, ptr, ptr, bit(72) aligned, bit(36) aligned, ptr, fixed bin(35)); dcl 1 dir_acl aligned, 2 access_name char(32), 2 dir_modes bit(36), 2 code fixed bin(35); dcl 1 segment_acl aligned, 2 access_name char(32), 2 modes bit(36), 2 pad bit(36), 2 code fixed bin(35); dcl error_table_$archive_fmt_err ext fixed bin(35), error_table_$bad_arg ext fixed bin(35), error_table_$namedup ext fixed bin(35), error_table_$noarg ext fixed bin(35), error_table_$argerr ext fixed bin(35), error_table_$noentry ext fixed bin(35), error_table_$no_dir ext fixed bin(35); dcl /* automatic variables */ 1 arg_struc_temp like arg_struc; /* storage for argument structure. */ dcl True bit(1) aligned init ("1"b); dcl cleanup condition; area_ptr = null; entry_ptr = null; name_ptr = null; dir_acl.access_name = get_group_id_$tag_star(); /* ME */ dir_acl.dir_modes = "111"b; /* "sma" */ dir_acl.code = 0; segment_acl.access_name = "*.*.*"; /* everyone */ segment_acl.modes = "100"b; /* "r" */ segment_acl.pad = "0"b; segment_acl.code = 0; Nargs = cu_$arg_count (); if Nargs < 1 then do; /* MUST give at least 1 argumment */ call com_err_ ((error_table_$noarg), me, "^/Usage is: ^a {-library LIBRARY} {-restart}", me ); return; end; call cu_$arg_ptr ( 1, arg_ptr, arg_len, code ); /* Get first argument. */ if code ^= 0 then do; /* This MUST be the system-id. */ call com_err_ ( code, me, "Processing argument #1." ); return; end; if substr ( arg, 1, 1 ) = "-" then do; /* control argument not allowed here */ call com_err_ (0, me, """^a"" is an invalid system id", arg); return; end; if arg_len > 8 then do; call com_err_ ( error_table_$bad_arg, me, "^/The argument must be 8 characters or less: ^a", arg ); return; end; SYS_ID = arg; i = 1; do while ( i < Nargs ); /* Process rest of arguments */ i = i + 1; call cu_$arg_ptr ( i, arg_ptr, arg_len, code ); if code ^= 0 then do; call com_err_ (code, me, "Processing argment # ^d", i); return; end; else if arg = "-restart" then restart_sw = "1"b; else if arg = "-library" then do; i = i + 1; call cu_$arg_ptr ( i, arg_ptr, arg_len, code ); if code ^= 0 then do; call com_err_ (code, me, "The ""-library"" control argument requires an argument." ); error = "1"b; go to next_arg; end; if substr ( arg, 1, 1) = "-" then do; call com_err_ (error_table_$bad_arg, me, "^/Incorrect argument following the ""-library"" control argument." ); error = "1"b; go to next_arg; end; if ^VERIFY_AREA ( arg ) then do; /* verify the area name */ call com_err_ (error_table_$bad_arg, me, "^/Incorrect area specified following the ""-library"" control argument. ^a", arg ); error = "1"b; go to next_arg; end; end; else do; call com_err_(error_table_$bad_arg, me, "^/The ""^a"" argument is not implemented.", arg ); error = "1"b; end; next_arg: end; if error /* ON if argument error. */ then return; /* Already reported, so leave gracefully. */ /* build directory pathnames given system ID */ if AREA ^= "mcs" then ROOT = ">ldd>" || AREA; /* e.g. ">ldd>hardcore" */ else ROOT = ">ldd>comm>fnp"; /* special case MCS dirs */ UPDATING_DIR = rtrim ( ROOT ) || ">" || SYS_ID; /* e.g. ">ldd>hardcore>34.21" */ LIBRARY_DIR = rtrim ( ROOT ) || ">" || "source"; /* e.g. ">ldd>hardcore>source" */ HOLD_DIR = rtrim ( ROOT ) || ">" || rtrim ( SYS_ID ) || "hold"; /* e.g. ">ldd>hardcore>34.21hold" */ area_ptr = get_system_free_area_ (); /* get list of names in updating directory */ call hcs_$star_ ( UPDATING_DIR, "**", 2, area_ptr, entry_count, entry_ptr, name_ptr, code ); if code ^= 0 then do; if code = error_table_$no_dir then call com_err_ ( code, me, "^/Updating directory ^a not found.", UPDATING_DIR ); else call com_err_ ( code, me, "^a", UPDATING_DIR ); return; /* if it ain't there, or can't get to it... */ end; if entry_count = 0 then do; /* no entries found ?? */ call com_err_ ( error_table_$noentry, me, "^a", UPDATING_DIR ); return; end; on cleanup call CLEANUP; /* set up a cleanup handler */ /* create the "HOLD" directory for previous source */ call hcs_$append_branchx ( ROOT, (rtrim (SYS_ID)) || "hold", 01011b, ringbr, dir_acl.access_name, 1, 0, 0, code ); if code ^= 0 then if code = error_table_$namedup then do; /* it's already there, make sure we're on the ACL */ call hcs_$add_dir_acl_entries ( ROOT, (rtrim(SYS_ID)) || "hold", addr(dir_acl), 1, code ); if code ^= 0 then do; if code = error_table_$argerr then code = dir_acl.code; call com_err_ ( code, me, "^/Unable to set access on ^a", HOLD_DIR ); return; end; end; else do; call com_err_ ( code, me, "^/Unable to create save directory ^a", HOLD_DIR ); return; end; call INIT; /* initialize some variables for lib_fetch_. */ /* add initial ACL for "r *.*.*" */ call hcs_$add_inacl_entries ( ROOT, (rtrim(SYS_ID) || "hold"), addr(segment_acl), 1, 4, code ); if code ^= 0 /* this is not a fatal error */ then call com_err_ ((segment_acl.code), me, "^/Warning: Unable to add initial ACL entry to ^a>^a", ROOT, (rtrim(SYS_ID) || "hold") ); STARNAME.N = 1; /* Initialize number of names. */ do i = 1 to entry_count; /* for each entry... */ k = entry_ptr -> entries(i).nindex; /* set index into names array */ call FETCH ( names(k) ); /* FETCH exercise the judgement */ end; revert cleanup; /* turn off handler */ call CLEANUP; /* make sure we cleanup anyhow */ return; /* NORMAL RETURN */ FETCH: procedure ( fetch_name ); dcl fetch_name char(*), /* entry name from UPDATING_DIR */ diff_names (1000) char(32), /* for comparison of archive entries */ diff_count fixed bin, /* and the number of "diff_names" */ i fixed bin; if index ( fetch_name, ".s.archive" ) ^= 0 /* special case source archives */ then go to source_ac; if ^STATUS ( LIBRARY_DIR, fetch_name ) /* if it's not there... */ then return; STARNAME.group(1).V = fetch_name; /* fill in info for lib_fetch_ */ STARNAME.group(1).C = 0; /* zero code */ if ^Sc.default & ^S.names & ^S.matching_names & ^S.primary_name then S.matching_names = True; /* use matching names by default. */ /* CALL LIB_FETCH_ */ call lib_fetch_ (addr(LIBRARY), addr(STARNAME), addr(EXCLUDE), Srequirements, Scontrol, addr(arg_struc), code); /* all errors reported by lib_fetch_. */ return; /* and return */ source_ac: /* SPECIAL CASE OF SOURCE ARCHIVES */ /* call subr. to get names of component changes */ /* A deletion, or a date-time-updated difference */ /* is assumed to be a change. */ call compare_archives_ ( LIBRARY_DIR, fetch_name, UPDATING_DIR, fetch_name, diff_names, diff_count ); if diff_count = 0 then do; /* 0 = there were no changes made (??) */ call com_err_ (0, me, "Warning: ^a>^a^/^5xis identical to ^a>^a.", UPDATING_DIR, fetch_name, LIBRARY_DIR, fetch_name ); return; /* warn user and continue */ end; do i = 1 to diff_count; /* and for each one of the changes... */ call FETCH ( diff_names(i) ); /* recurse... */ end; return; end FETCH; STATUS: proc ( path, entry ) returns ( bit(1) ); dcl path char(168) aligned, entry char(*), status bit(144) aligned, hcs_$status_ entry ( char(*) aligned, char(*), fixed bin(1), ptr, ptr, fixed bin(35)); call hcs_$status_ ( path, entry, 1, addr(status), null, code ); if code ^= 0 then return ("0"b); else return ("1"b); end STATUS; CLEANUP: procedure; if entry_ptr ^= null /* free up some space */ then free entries; entry_ptr = null; if name_ptr ^= null then free names; name_ptr = null; return; end CLEANUP; VERIFY_AREA: procedure ( system_name ) returns ( bit(1) ); dcl system_name char(*), /* argument given by user */ valid_names (6) char(12) init /* "legal" names */ ( "hardcore", "hard", "supervisor", "sup", "bos", "mcs" ), area_index (6) fixed bin init ( 1, 1, 1, 1, 2, 3 ), proper_name (3) char(8) init /* proper name equivalent */ ( "hardcore", "bos", "mcs" ); do i = 1 to dim ( valid_names, 1 ); /* check against "legal" names */ if system_name = valid_names(i) then do; AREA = proper_name ( area_index(i) ); /* set to proper name */ go to found_area; end; end; /* didn't find proper name */ return ("0"b); /* return FALSE */ found_area: return ("1"b); /* return TRUE */ end VERIFY_AREA; INIT: proc; Parg_struc = addr(arg_struc_temp); /* Initialize argument processing structure. */ arg_struc.version = Varg_struc_1; arg_struc.program = me; /* caller */ arg_struc.put_error = com_err_; arg_struc.descriptor = ""; /* use default library_descriptor */ arg_struc.into_path = rtrim (HOLD_DIR) || ">=="; /* where segments are to be put */ arg_struc.output_file = ""; LIBRARY.N = 1; /* only search the source library for */ LIBRARY.group(1).V = rtrim(AREA) || ".s"; /* specified area. */ LIBRARY.group(1).C = 0; /* since we filled it in... */ STARNAME.N = 1; arg_struc.Srequirements_allowed = ""b; arg_struc.Srequirements_initial = ""b; arg_struc.Scontrol_allowed = ""b; arg_struc.Scontrol_initial = ""b; Sreq_allowed.access_class = True; /* Mark Sreq bits- show which output args allowed*/ Sreq_allowed.acl = True; Sreq_allowed.aim = True; Sreq_allowed.author = True; Sreq_allowed.bit_count = True; Sreq_allowed.bit_count_author = True; Sreq_allowed.compiler_name = True; Sreq_allowed.compiler_options = True; Sreq_allowed.compiler_version = True; Sreq_allowed.copy = True; Sreq_allowed.current_length = True; Sreq_allowed.dtc = True; Sreq_allowed.dtd = True; Sreq_allowed.dtem = True; Sreq_allowed.dtm = True; Sreq_allowed.dtu = True; Sreq_allowed.entry_bound = True; Sreq_allowed.iacl = True; Sreq_allowed.kids = True; Sreq_allowed.kids_error = True; Sreq_allowed.level = True; Sreq_allowed.link_target = True; Sreq_allowed.lvid = True; Sreq_allowed.matching_names = True; Sreq_allowed.max_length = True; Sreq_allowed.mode = True; Sreq_allowed.msf_indicator = True; Sreq_allowed.names = True; Sreq_allowed.new_line = True; Sreq_allowed.not_ascii = True; Sreq_allowed.object_info = True; Sreq_allowed.offset = True; Sreq_allowed.pathname = True; Sreq_allowed.primary_name = True; Sreq_allowed.pvid = True; Sreq_allowed.quota = True; Sreq_allowed.rb = True; Sreq_allowed.records_used = True; Sreq_allowed.root_search_proc = True; Sreq_allowed.safety = True; Sreq_allowed.type = True; Sreq_allowed.unique_id = True; Sreq_allowed.user = True; Sreq_init.user = True; /* Mark bits on by default. */ Sc_allowed.acl = True; /* Mark Sc bits- show which ctl args allowed. */ Sc_allowed.all_status = True; Sc_allowed.chase = True; Sc_allowed.check_archive = True; Sc_allowed.check_ascii = True; Sc_allowed.components = True; Sc_allowed.container = True; Sc_allowed.default = True; Sc_allowed.iacl = True; Sc_allowed.object_info = True; Sc_allowed.quota = True; Sc_allowed.retain = True; Sc_allowed.descriptor = True; Sc_allowed.into_path = True; Sc_allowed.long = True; Sc_allowed.library = True; Sc_allowed.output_file = True; Sc_allowed.search_names = True; Sc_init.into_path = True; /* Mark bits for ctl args supplied by default. */ Sc_init.default = True; end INIT; compare_archives_: procedure ( first_dir, first_entry, second_dir, second_entry, return_array, return_count ); dcl first_dir char(*) aligned, second_dir char(*) aligned, first_entry char(*), second_entry char(*), return_array (1000) char(32), return_count fixed bin; dcl (i, j, x) fixed bin, head_ptr ptr, save_ptr ptr, seg_name char(32), bit_count fixed bin(24), bitc fixed bin(24), acode fixed bin, seg_ptr ptr, first_count fixed bin, second_count fixed bin, code fixed bin(35), error_table_$archive_fmt_err ext fixed bin(35), null builtin, index builtin, me char(2) init ("me"); dcl com_err_ entry options (variable), hcs_$initiate_count entry (char(*) aligned, char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35)), hcs_$terminate_noname entry ( ptr, fixed bin(35)), archive_util_$first_disected entry ( ptr, ptr, char(*), fixed bin(24), fixed bin), archive_util_$disected_element entry ( ptr, ptr, char(*), fixed bin(24), fixed bin); dcl 1 archive_item aligned based (head_ptr), (2 header_begin char(8), 2 pad1 char(4), 2 name char(32), 2 dtupd char(16), 2 mode char(4), 2 dtm char(16), 2 pad2 char(4), 2 bitct char(8), 2 header_end char(8) ) unal; dcl 1 first_array (1000) aligned, 2 name char(32), 2 date char(16), 2 bitc char(8); dcl 1 second_array (1000) aligned, 2 name char(32), 2 date char(16), 2 bitc char(8); return_count = 0; /* just in case we return abnormally */ head_ptr = null; /* initiate the first archive */ call hcs_$initiate_count ( first_dir, first_entry, "", bit_count, 1, head_ptr, code ); if head_ptr = null then do; call com_err_ ( code, me, "^/Attempting to initiate ^a>^a", first_dir, first_entry); return; end; save_ptr = head_ptr; /* save it's ptr for later termination */ acode, j, x = 0; /* get the first component info */ call archive_util_$first_disected ( head_ptr, seg_ptr, seg_name, bitc, acode ); do while ( acode = 0 ); /* process each component */ j = j + 1; first_array (j).name = seg_name; /* name... */ first_array (j).date = head_ptr -> archive_item.dtupd; /* date-time-updated... */ first_array (j).bitc = head_ptr -> archive_item.bitct; /* bit-count... */ /* is there next component ?? */ call archive_util_$disected_element ( head_ptr, seg_ptr, seg_name, bitc, acode ); /* acode = 0 means there's next */ end; first_count = j; /* number in first archive */ call hcs_$terminate_noname ( save_ptr, code ); /* terminate it */ if acode = 2 then do; /* was there a format error ?? */ call com_err_ ( error_table_$archive_fmt_err, me, "^/Referencing ^a>^a", first_dir, first_entry); return; end; head_ptr = null; /* and do the same for the second */ call hcs_$initiate_count ( second_dir, second_entry, "", bit_count, 1, head_ptr, code ); if head_ptr = null then do; call com_err_ ( code, me, "^/Attempting to initiate ^a>^a", second_dir, second_entry); return; end; save_ptr = head_ptr; acode, j = 0; /* get first component info */ call archive_util_$first_disected ( head_ptr, seg_ptr, seg_name, bitc, acode ); do while ( acode = 0 ); /* and for each component... */ j = j + 1; second_array (j).name = seg_name; /* name... */ second_array (j).date = head_ptr -> archive_item.dtupd; /* date-time-updated... */ second_array (j).bitc = head_ptr -> archive_item.bitct; /* bit-count... */ /* is there a next ?? */ call archive_util_$disected_element ( head_ptr, seg_ptr, seg_name, bitc, acode ); /* acode = 0 means yes */ end; second_count = j; /* set number in second archive */ call hcs_$terminate_noname ( save_ptr, code ); /* and terminate it */ if acode = 2 then do; /* format error occurred ?? */ call com_err_ ( error_table_$archive_fmt_err, me, "^/Referencing ^a>^a", second_dir, second_entry); return; end; /* If entry exists in the first archive, but not in the */ /* second one, put it into our return array. */ do i = 1 to first_count; /* If the date-time-updated differs between the two for */ do j = 1 to second_count; /* a component, also put it into the list. */ if first_array (i).name = second_array (j).name then do; if first_array (i).date ^= second_array (j).date then do; x = x + 1; /* DIFFERENT date-time-updated */ return_array (x) = first_array (i).name; /* ADD IT TO RETURN ARRAY */ end; go to next_first; end; end; x = x + 1; /* NAME NOT FOUND IN SECOND ARCHIVE */ return_array (x) = first_array (i).name; /* ADD TO RETURN ARRAY */ next_first: end; return_count = x; /* SET THE RETURN COUNT AND RETURN */ return; end compare_archives_; %include lib_arg_struc_; %include lib_Svalid_req_; %include lib_Scontrol_; end save_previous_system; */ ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved */