


		    copy_registry.pl1               03/14/85  0844.0rew 03/13/85  1029.0       58887


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
copy_registry: proc;

/* This command copies RCP registries. */
/* Written 01/03/79 by C. D. Tavares */
/* Last modified 10/03/80 by CDT for better error message when copy fails */
/* Modified 02/12/85 by M. M. Pozzo to print out warning message when there
   are one or more missing components in the original registry. */

/* automatic */

dcl  ap pointer,
     al fixed bin,
     arg char (al) based (ap),
     code fixed bin (35),
     i fixed bin,
     from_dirname char (168),
     to_dirname char (168),
     from_ename char (32),
     to_ename char (32),
     error_msg_arg char (200),
     nargs fixed bin,
     reset_journal_sw bit (1) aligned,
     star_index fixed bin;


/* static */

dcl  system_free_ptr pointer initial (null) static;

/* external static */

dcl (error_table_$badequal,
     error_table_$noarg,
     error_table_$badopt,
     error_table_$rcp_missing_registry_component) ext fixed bin (35) static;

/* based */

dcl  system_free_area area based (system_free_ptr);

/* entries */

dcl  check_star_name_$entry ext entry (char (*), fixed bin (35)),
     com_err_ ext entry options (variable),
     cu_$arg_count ext entry (fixed bin),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)),
     get_equal_name_ ext entry (char (*), char (*), char (*), fixed bin (35)),
     hcs_$star_ ext entry (char (*), char (*), fixed bin (2), pointer, fixed bin, pointer, pointer, fixed bin (35)),
     get_system_free_area_ ext entry returns (pointer),
     get_wdir_ ext entry returns (char (168));

dcl  rcp_admin_$copy_registry ext entry
    (char (*), char (*) dimension (*), char (*), char (*) dimension (*),
     char (*), bit (1) aligned, fixed bin (35));

/* builtins and conditions */

dcl (dim, hbound, null, substr, sum) builtin,
     cleanup condition;

%include star_structures;

	reset_journal_sw = ""b;

	call cu_$arg_count (nargs);
	if nargs < 1 then do;
	     call com_err_ (error_table_$noarg, "copy_registry", "Usage:  copy_registry from_path {to_path}");
	     return;
	end;

	from_ename = "";
	to_dirname = get_wdir_ ();
	to_ename = "==";

	do i = 1 to nargs;
	     call cu_$arg_ptr (i, ap, al, code);
	     if code ^= 0 then call crump (code, "Getting argument.");

	     if substr (arg, 1, 1) = "-" then do;	/* control arg */
		if arg = "-reset" | arg = "-rs" then reset_journal_sw = "1"b;
		else call crump (error_table_$badopt, arg);
	     end;

	     else do;				/* real argument */
		if from_ename = "" then
		     call expand_pathname_$add_suffix (arg, "rcpr", from_dirname, from_ename, code);
		else call expand_pathname_$add_suffix (arg, "rcpr", to_dirname, to_ename, code);
		if code ^= 0 then call crump (code, arg);
	     end;
	end;

	call check_star_name_$entry (from_ename, code);
	if code > 2 then call crump (code, from_ename);

	if code = 0 then call process ((from_ename));	/* not a starname */

	else do;					/* starname, handle it */
	     star_entry_ptr, star_names_ptr = null;
	     if system_free_ptr = null then
		system_free_ptr = get_system_free_area_ ();

	     on cleanup call star_cleanup;

	     call hcs_$star_ (from_dirname, from_ename, star_BRANCHES_ONLY, system_free_ptr,
		star_entry_count, star_entry_ptr, star_names_ptr, code);

	     if code ^= 0 then call crump (code, "^a>^a");

	     begin;

dcl  enames char (32) dimension (star_entry_count);

		do star_index = 1 to star_entry_count;
		     enames (star_index) = star_names (star_entries (star_index).nindex);
		end;

		call process (enames (*));
	     end;

	     call star_cleanup;

/* ------------------------- */

star_cleanup:  proc;
		if star_names_ptr ^= null then free star_names in (system_free_area);
						/* remember to free names before entries! */
		if star_entry_ptr ^= null then free star_entries in (system_free_area);

	     end;

/* ------------------------- */

	end;

	return;
	
process:	proc (from_enames);

dcl  from_enames char (32) dimension (*) parameter;

dcl  sleep_times (4) fixed bin (71) static options (constant) initial (1, 1, 2, 6),
     timer_manager_$sleep ext entry (fixed bin (71), bit (2) aligned),
     error_table_$file_busy ext fixed bin (35) static,
     i fixed bin,
     target_names char (32) dimension (dim (from_enames, 1));

	     do i = 1 to hbound (from_enames, 1);
		call get_equal_name_ (from_enames (i), to_ename, target_names (i), code);
		if code = error_table_$badequal then code = 0; /* not an equal name but no sweat */
		if code ^= 0 then
		     call crump (code, to_ename);	/* fatal */
		else do;
		     call expand_pathname_$add_suffix ((target_names (i)), "rcpr", "", target_names (i), code);
		     if code ^= 0 then call crump (code, arg);
		end;
	     end;

               /*  Copy the registry and allow time for the file to be busy before giving up. */

	     do i = 1, i+1 to hbound (sleep_times, 1) + 1 while (code = error_table_$file_busy);

		call rcp_admin_$copy_registry
		     (from_dirname, from_enames (*),
		     to_dirname, target_names (*), error_msg_arg,
		     reset_journal_sw, code);

		if code = error_table_$file_busy then
		     if i ^> hbound (sleep_times, 1) then
			call timer_manager_$sleep (sleep_times (i), "11"b); /* relative seconds */
	     end;

	     if code = error_table_$rcp_missing_registry_component then
	        call com_err_ (code, "copy_registry", error_msg_arg);

	     else if code ^= 0 then call com_err_ (code, "copy_registry",
		"^[^/^-Some registries were not copied, starting with ^;^]^a.^[^/^-The journal has not been truncated.^;^]",
		(substr (error_msg_arg, 1, 1) = ">"), error_msg_arg, reset_journal_sw);

	     return;
	end process;

	
crump:	proc (code, reason) options (non_quick);

dcl  code fixed bin (35) parameter,
     reason char (*) parameter;

	     call com_err_ (code, "copy_registry", reason, from_dirname, from_ename);
	     goto returner;
	end crump;

returner:	return;

     end copy_registry;

 



		    delete_registry.pl1             11/15/82  1858.5rew 11/15/82  1522.2       41130


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


delete_registry: proc;

/* This command deletes RCP registries. */
/* Written 01/03/79 by C. D. Tavares */

/* automatic */

dcl  ap pointer,
     al fixed bin,
     arg char (al) based (ap),
     argno fixed bin,
     code fixed bin (35),
     delete_sw bit (1) aligned,
     dirname char (168),
     ename char (32),
     myname char (32),
     nargs fixed bin,
     star_index fixed bin,
     suffix char (4);

/* static */

dcl  system_free_ptr pointer initial (null) static;

/* external static */

dcl  error_table_$noarg ext fixed bin (35) static;

/* based */

dcl  system_free_area area based (system_free_ptr);

/* entries */

dcl  check_star_name_$entry ext entry (char (*), fixed bin (35)),
     com_err_ ext entry options (variable),
     cu_$arg_count entry (fixed bin),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)),
     hcs_$star_ ext entry (char (*), char (*), fixed bin (2), pointer, fixed bin, pointer, pointer, fixed bin (35)),
     get_system_free_area_ ext entry returns (pointer);

dcl (rcp_admin_$delete_registry,
     rcp_sys_$remove_registry) ext entry (char (*), char (*), fixed bin (35));

/* builtins and conditions */

dcl (hbound, null, sum) builtin,
     cleanup condition;

%include star_structures;


/* delete_registry: proc; */

	delete_sw = "1"b;
	suffix = "old";
	myname = "delete_registry";
	goto common;
	
remove_registry: entry;

	delete_sw = ""b;
	suffix = "rcpr";
	myname = "remove_registry";
	goto common;

common:
	call cu_$arg_count (nargs);
	if nargs = 0 then do;
	     call com_err_ (error_table_$noarg, myname, "Usage:  ^a paths", myname);
	     return;
	end;


	do argno = 1 to nargs;

	     call cu_$arg_ptr (argno, ap, al, code);
	     if code ^= 0 then call crump (code, "Getting arg.");

	     call expand_pathname_$add_suffix (arg, suffix, dirname, ename, code);
	     if code ^= 0 then call crump (code, arg);

	     call check_star_name_$entry (ename, code);
	     if code > 2 then call crump (code, ename);

	     if code = 0 then call process (ename);	/* not a starname */

	     else do;				/* starname, handle it */
		star_entry_ptr, star_names_ptr = null;
		if system_free_ptr = null then
		     system_free_ptr = get_system_free_area_ ();

		on cleanup call star_cleanup;

		call hcs_$star_ (dirname, ename, star_BRANCHES_ONLY, system_free_ptr,
		     star_entry_count, star_entry_ptr, star_names_ptr, code);

		if code ^= 0 then call crump (code, "^a>^a");

		do star_index = 1 to star_entry_count;
		     call process ((star_names (star_entries (star_index).nindex)));
		end;

		call star_cleanup;

/* ------------------------- */

star_cleanup:	proc;
		     if star_names_ptr ^= null then free star_names in (system_free_area);
						/* remember to free names before entries! */
		     if star_entry_ptr ^= null then free star_entries in (system_free_area);
		end;

/* ------------------------- */

	     end;

get_next_arg:
	end;

	return;
	
process:	proc (ename);

dcl  ename char (32) parameter;

dcl  sleep_times (4) fixed bin (71) static options (constant) initial (1, 1, 2, 6),
     timer_manager_$sleep ext entry (fixed bin (71), bit (2) aligned),
     error_table_$file_busy ext fixed bin (35) static,
     i fixed bin;

	     do i = 1, i+1 to hbound (sleep_times, 1) + 1 while (code = error_table_$file_busy);

		if delete_sw then
		     call rcp_admin_$delete_registry (dirname, ename, code);
		else call rcp_sys_$remove_registry (dirname, ename, code);

		if code = error_table_$file_busy then
		     if i ^> hbound (sleep_times, 1) then
			call timer_manager_$sleep (sleep_times (i), "11"b); /* relative seconds */
	     end;

	     if code ^= 0 then call com_err_ (code, myname, "^a>^a", dirname, ename);
	     return;
	end process;
	
crump:	proc (code, reason);

dcl  code fixed bin (35) parameter,
     reason char (*) parameter;

	     call com_err_ (code, myname, reason, dirname, ename);
	     goto get_next_arg;
	end crump;

     end delete_registry;

  



		    reconstruct_registry.pl1        11/15/82  1858.5rew 11/15/82  1522.3       91836


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


reconstruct_registry: proc;

/* This command brings RCP registries up to date. */
/* Written 01/03/79 by C. D. Tavares */

/* automatic */

dcl  answer char (4) varying,
     ap pointer,
     arg_array_ptr pointer,
     al fixed bin,
     code fixed bin (35),
     dtcm_string char (24),
     found bit (1) aligned,
    (i, j, k) fixed bin,
     nargs fixed bin,
     registry_data_ptr pointer,
     star_index fixed bin,
     dirname char (168),
     temp_ename char (32);

dcl  New_max fixed bin;

/* static */

dcl  system_free_ptr pointer initial (null) static;

dcl  sleep_times (4) fixed bin (71) static options (constant) initial (1, 1, 2, 6);

dcl  sys_dirname char (168) static initial (">system_control_1>rcp");

/* external static */

dcl (error_table_$bad_equal_name,
     error_table_$noarg,
     error_table_$resource_unknown,
     error_table_$badopt,
     error_table_$file_busy) ext fixed bin (35) static;

/* based */

dcl 1 registry_data aligned based (registry_data_ptr),
    2 max_entries fixed bin,
    2 used_entries fixed bin initial (0),
    2 entry (New_max refer (registry_data.max_entries)) aligned,
      3 ename char (32) unaligned,
      3 resource_type char (32) unaligned,
      3 dtcm fixed bin (71),
      3 rtde_ptr pointer,
      3 uid bit (36);

dcl 1 arg_array aligned based (arg_array_ptr),
    2 max_entries fixed bin,
    2 used_entries fixed bin initial (0),
    2 arg (nargs refer (arg_array.max_entries)) char (32) unaligned;

dcl  arg char (al) based (ap);

dcl  system_free_area area based (system_free_ptr);

/* entries */

dcl  check_star_name_$entry ext entry (char (*), fixed bin (35)),
     com_err_ ext entry options (variable),
     command_query_ ext entry options (variable),
     convert_date_to_binary_ ext entry (char (*), fixed bin (71), fixed bin (35)),
     cu_$arg_count ext entry (fixed bin),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     date_time_ ext entry (fixed bin (71), char (*)),
     absolute_pathname_ ext entry (char (*), char (*), fixed bin (35)),
     get_equal_name_ ext entry (char (*), char (*), char (*), fixed bin (35)),
     get_system_free_area_ ext entry returns (pointer),
     get_wdir_ ext entry returns (char (168)),
     hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     hcs_$star_ ext entry (char (*), char (*), fixed bin (2), pointer, fixed bin, pointer, pointer, fixed bin (35)),
     hcs_$status_long ext entry (char (*), char (*), fixed bin, pointer, pointer, fixed bin (35)),
     ioa_ ext entry options (variable),
     suffixed_name_$make entry (char (*), char (*), char (32), fixed bin (35)),
     timer_manager_$sleep ext entry (fixed bin (71), bit (2) aligned);

dcl  rcp_sys_$reconstruct_registry ext entry
    (char (*), char (*) dimension (*), pointer dimension (*), fixed bin (35));

/* builtins and conditions */

dcl (clock, hbound, null, sum) builtin,
     cleanup condition;

%include rtdt;

%include star_structures;

%include status_structures;

dcl 1 status_branch_long automatic aligned like status_branch;

%include query_info_;

	call cu_$arg_count (nargs);
	if nargs = 0 then do;
	     call com_err_ (error_table_$noarg, "reconstruct_registry", "Usage:  reconstruct_registry paths");
	     return;
	end;

	rtdtp,
	     arg_array_ptr,
	     registry_data_ptr,
	     star_entry_ptr,
	     star_names_ptr = null;

	if system_free_ptr = null then
	     system_free_ptr = get_system_free_area_ ();

	on cleanup call clean_up;

	dirname = sys_dirname;
	call hcs_$initiate (">system_control_1", "rtdt", "", 0, 0, rtdtp, code);
	if rtdtp = null then call crump (code, "Cannot initiate >sc1>rtdt.");

	New_max = max (20, nargs);
	allocate registry_data in (system_free_area);
	allocate arg_array in (system_free_area);

	do i = 1 to nargs;
	     call cu_$arg_ptr (i, ap, al, code);
	     if code ^= 0 then call crump (code, "Obtaining arguments");

	     if substr (arg, 1, 1) = "-" then do;
		if arg = "-pn" | arg = "-pathname" then do;
		     i = i + 1;
		     call cu_$arg_ptr (i, ap, al, code);
		     if code ^= 0 then call crump (code, "after -pathname.");
		     call absolute_pathname_ (arg, dirname, code);
		     if code ^= 0 then call crump (code, arg);

		     call hcs_$terminate_noname (rtdtp, 0);

		     call hcs_$initiate (dirname, "rtdt", "", 0, 0, rtdtp, code);
		     if rtdtp = null then call crump (code, rtrim (dirname) || ">rtdt");
		end;
		else call crump (error_table_$badopt, arg);
	     end;

	     else do;
		arg_array.used_entries = arg_array.used_entries + 1;
		arg_array.arg (arg_array.used_entries) = arg;
	     end;
	end;

	do i = 1 to arg_array.used_entries;
	     call suffixed_name_$make (arg_array.arg (i), "rcpr", temp_ename, code);
	     if code ^= 0 then call crump (code, arg_array.arg (i));

	     call check_star_name_$entry (temp_ename, code);
	     if code > 2 then call crump (code, temp_ename);

	     if code = 0 then call add_to_list (temp_ename); /* not a starname */

	     else do;				/* starname, handle it */
		call hcs_$star_ (dirname, temp_ename, star_BRANCHES_ONLY, system_free_ptr,
		     star_entry_count, star_entry_ptr, star_names_ptr, code);

		if code ^= 0 then call crump (code, "^a>^a");

		do star_index = 1 to star_entry_count;
		     call add_to_list ((star_names (star_entries (star_index).nindex)));
		end;

		free star_names in (system_free_area), star_entries in (system_free_area);
	     end;
	end;

	free arg_array in (system_free_area);
	

/* Now we have all the names.  Get status about them all. */

	do i = 1 to registry_data.used_entries;
	     call hcs_$status_long (dirname, ename (i), 1 /* chase */, addr (status_branch_long), null, code);
	     if code ^= 0 then call crump (code, rtrim (dirname) || ">" || ename (i));

	     registry_data.uid (i) = status_branch_long.uid;
	     registry_data.dtcm (i) = binary (status_branch_long.dtcm || (16) "0"b); /* convert fs time to clock time */

	     do j = 1 to 2 while (rtde_ptr (i) = null);	/* two chances to chase down a synonym */
		found = ""b;

		do rtdep = pointer (rtdt.first_resource, rtdt.rtdt_area)
			repeat (pointer (rtde.next_resource, rtdt.rtdt_area))
			while (rtdep ^= null);

		     if rtde.valid then
			if rtde.name = resource_type (i) then do;
			     found = "1"b;
			     if ^rtde.is_synonym then
				rtde_ptr (i) = rtdep;
			     else resource_type = rtde.syn_to;
			end;
		end;

		if ^found then
		     call crump (error_table_$resource_unknown, resource_type (i));
	     end;

	     if rtde_ptr (i) = null then
		call crump (error_table_$resource_unknown, resource_type (i));
	end;

/* Eliminate duplicates that may have arisen from fancy starnames */

	do i = 1 by 1 while (i ^> registry_data.used_entries);
	     do j = i+1 by 1 while (j ^> registry_data.used_entries);
		if registry_data.uid (i) = registry_data.uid (j) then do;
		     do k = registry_data.used_entries - 1 to j by -1;
			unspec (registry_data.entry (k)) = unspec (registry_data.entry (k+1));
		     end;
		     j = j - 1;			/* examine the "current" one again, it's new. */
		     registry_data.used_entries = registry_data.used_entries - 1;
		end;
	     end;
	end;

/* ------------------------- */

clean_up:	proc;
	     if star_names_ptr ^= null then free star_names in (system_free_area);
						/* remember to free names before entries! */
	     if star_entry_ptr ^= null then free star_entries in (system_free_area);
	     if registry_data_ptr ^= null then free registry_data in (system_free_area);
	     if arg_array_ptr ^= null then free arg_array in (system_free_area);
	     call hcs_$terminate_noname (rtdtp, 0);

	end;

/* ------------------------- */

	begin;

dcl  enames (registry_data.used_entries) char (32) automatic,
     rtde_ptrs (registry_data.used_entries) pointer automatic;

	     do i = 1 to hbound (enames, 1);
		enames (i) = registry_data.ename (i);
		rtde_ptrs (i) = registry_data.rtde_ptr (i);
	     end;

	     do i = 1, i+1 to hbound (sleep_times, 1) + 1 while (code = error_table_$file_busy);

		call rcp_sys_$reconstruct_registry (dirname, enames (*), rtde_ptrs (*), code);

		if code = error_table_$file_busy then
		     if i ^> hbound (sleep_times, 1) then
			call timer_manager_$sleep (sleep_times (i), "11"b); /* relative seconds */
	     end;
	end;

	if code ^= 0 then call com_err_ (code, "reconstruct_registry", "Reconstructing ^a>^a",
	     dirname, temp_ename);

	return;
	
add_to_list: proc (arg_ename);

dcl  arg_ename char (32) parameter;

dcl  i fixed bin,
     tp pointer;

	     if registry_data.used_entries = registry_data.max_entries then do;
		tp = null;

		on cleanup begin;
		     if tp ^= null then free tp -> registry_data in (system_free_area);
		end;

		New_max = registry_data.max_entries + 20;
		allocate registry_data in (system_free_area) set (tp);

		unspec (tp -> registry_data.entry (*)) = unspec (registry_data_ptr -> registry_data.entry (*));
		tp -> registry_data.used_entries = registry_data_ptr -> registry_data.used_entries;

		free registry_data_ptr -> registry_data in (system_free_area);


		registry_data_ptr = tp;
		tp = null;
		revert cleanup;
	     end;

	     i, registry_data.used_entries = registry_data.used_entries + 1;
	     ename (i) = arg_ename;
	     resource_type (i) = before (arg_ename, ".rcpr");
	     rtde_ptr (i) = null;

	     return;

	end add_to_list;

	
crump:	proc (code, reason);

dcl  code fixed bin (35) parameter,
     reason char (*) parameter;

	     call com_err_ (code, "reconstruct_registry", reason, dirname, temp_ename);
	     goto returner;
	end crump;

returner:	return;

     end reconstruct_registry;


		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


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