describe_entry_type.pl1         05/31/88  1418.9rew 05/31/88  1405.8      168192



/****^  **************************************************************
        *                                                            *
        * Copyright, (C) Honeywell Bull Inc., 1988                   *
        *                                                            *
        * Copyright, (C) Honeywell Information Systems Inc., 1984    *
        *                                                            *
        * Copyright, (C) Massachusetts Institute of Technology, 1983 *
        *                                                            *
        ************************************************************** */

/* format: style3 */

describe_entry_type:
dset:
     procedure () options (variable);

/* describe_entry_type: Command/AF to show information about an entry type.
   list_entry_type: Command/AF to list all suffix_XXX_ that can be found by search rules.

   Jay Pattin 7/2/83 as describe_object_type
   1984.03.20 MAP to use fs_util_
   1984.07.23 MAP to become "entry " instead of "object"
   1984.11.08 MAP general cleanup to prepare for installation
*/


/****^  HISTORY COMMENTS:
  1) change(88-01-01,Gilcrease), approve(88-05-05,MCR7835),
     audit(88-05-05,Dupuis), install(88-05-31,MR12.2-1049):
               Correct to allow dm_file, and improve output.
                                                   END HISTORY COMMENTS */


declare	active_function	bit (1) aligned,
	(all, attributes, brief, default, info_path, info_path_given, name,
	 plural, modes, xacl, switches, explicit_switches)
			bit (1) aligned,
	area_ptr		ptr,
	arg_count		fixed bin,
	arg_idx		fixed bin,
	arg_len		fixed bin (21),
	arg_ptr		ptr,
	arg		char (arg_len) based (arg_ptr),
	buffer		char (128) varying,
	code		fixed bin (35),
	complain		entry options (variable) variable,
	dir		char (168),
	display_name	char (32),
	(high, low)	fixed bin,
	looking_for_types	bit (1) aligned,
	(idx, name_idx, rule)
			fixed bin,
	entry		char (32),
	ref_name		char (32),
	ret_len		fixed bin (21),
	ret_ptr		ptr,
	ret_str		char (ret_len) varying based (ret_ptr),
	switch_name	char (32) aligned,
	type		char (32),
	type_count	fixed bin,
	type_name		(100) char (32),
	type_no		fixed bin,
	whoami		char (32);

declare	1 si		aligned like suffix_info;
declare	1 search_rules	aligned,
	  2 number	fixed bin,
	  2 names		(20) char (168) aligned;

declare	ATTRIBUTE_NAMES	(8) char (32) varying internal static options (constant)
			init ("names", "ACL", "ring brackets", "max length", "copy switch", "safety switch",
			"dumper switches", "entry bound");
declare  THIRTY_TWO_SPACES    char (32) internal static options (constant)
			init ((32)" ");

declare	(addr, baseptr, hbound, length, ltrim, max, null, reverse, rtrim, search, string, substr, sum)
			builtin,
	cleanup		condition;

declare	(
	error_table_$bad_arg,
	error_table_$badopt,
	error_table_$inconsistent,
	error_table_$noarg,
	error_table_$nomatch,
	error_table_$not_act_fnc
	)		fixed bin (35) external;

declare	(
	active_fnc_err_,
	active_fnc_err_$suppress_name,
	com_err_,
	com_err_$suppress_name
	)		entry options (variable),
	cu_$af_return_arg	entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
	expand_pathname_	entry (char (*), char (*), char (*), fixed bin (35)),
	get_system_free_area_
			entry returns (ptr),
	get_wdir_		entry returns (char (168)),
	hcs_$fs_get_ref_name
			entry (ptr, fixed bin, char (*), fixed bin (35)),
	hcs_$get_search_rules
			entry (ptr),
	hcs_$high_low_seg_count
			entry (fixed bin, fixed bin),
	hcs_$star_	entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)),
	hcs_$status_minf	entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)),
	ioa_		entry options (variable),
	fs_util_$list_switches_for_type
			entry (char (*), char (*), ptr, ptr, fixed bin (35)),
	fs_util_$suffix_info_for_type
			entry (char (*), ptr, fixed bin (35)),
	fs_util_$make_entry_for_type
			entry (char (*), char (*), entry, fixed bin (35)),
	requote_string_	entry (char (*) aligned) returns (char (*)),
	search_paths_$find_dir
			entry (char (*), ptr, char (*), char (*), char (*), fixed bin (35));
%page;
%include suffix_info;
%page;
%include copy_flags;
%page;
%include star_structures;
%page;

	whoami = "describe_entry_type";

	call cu_$af_return_arg (arg_count, ret_ptr, ret_len, code);
	call setup (code, DSET_EXIT);

	if arg_count = 0 | (arg_count = 1 & active_function)
	then do;
		if active_function
		then call active_fnc_err_$suppress_name (0, whoami, "Usage:  [dset suffix -control_args]");
		else call com_err_$suppress_name (0, whoami, "Usage:  dset suffix {-control_args}");
		return;
	     end;

	all, attributes, brief, default, info_path, info_path_given, name,
	     plural, modes, xacl, switches, explicit_switches = "0"b;

/* process the arguments */

	type_count = 0;
	looking_for_types = "1"b;

	do arg_idx = 1 to arg_count;

	     call cu_$arg_ptr (arg_idx, arg_ptr, arg_len, code);
	     if (code ^= 0) | (arg_len < 1)
	     then do;
BADARG:
		if code = 0
		then code = error_table_$bad_arg;
		     call complain (code, whoami, "Argument number ^d.", arg_idx);
		     return;
		end;

	     if (substr (arg, 1, 1) = "-") & looking_for_types
	     then looking_for_types = "0"b;

	     if looking_for_types
	     then do;
		     type_count = type_count + 1;
		     if arg = "segment"
		     then type_name (type_count) = FS_OBJECT_TYPE_SEGMENT;
		     else if arg = "directory"
		     then type_name (type_count) = FS_OBJECT_TYPE_DIRECTORY;
		     else if arg = "msf"
		     then type_name (type_count) = FS_OBJECT_TYPE_MSF;
		     else if arg = "dm_file"
		     then type_name (type_count) = FS_OBJECT_TYPE_DM_FILE;
		     else if arg = "link"
		     then type_name (type_count) = FS_OBJECT_TYPE_LINK;
		     else type_name (type_count) = arg;
		end;
	     else do;

		     if ^active_function & (arg = "-all" | arg = "-a")
		     then all = "1"b;
		     else if arg = "-attributes" | arg = "-attr"
		     then attributes = "1"b;
		     else if arg = "-info_pathname" | arg = "-ipn"
		     then info_path, info_path_given = "1"b;
		     else if arg = "-modes"
		     then modes = "1"b;
		     else if arg = "-name" | arg = "-nm"
		     then name = "1"b;
		     else if arg = "-plural_name" | arg = "-plnm"
		     then plural = "1"b;
		     else if arg = "-switches"
		     then switches, explicit_switches = "1"b;
		     else if active_function & (arg = "-extended_acl" | arg = "-xacl")
		     then xacl = "1"b;
		     else if arg = "-default"
		     then do;
			     if arg_count = arg_idx
			     then do;
				     call complain (error_table_$noarg, whoami, "Following ^a.", arg);
				     return;
				end;
			     if default
			     then do;
				     call complain (0, whoami, "Only one -default may be given.");
				     return;
				end;
			     arg_idx = arg_idx + 1;
			     call cu_$arg_ptr (arg_idx, arg_ptr, arg_len, code);
			     if code ^= 0
			     then goto BADARG;

			     switch_name = arg;
			     default = "1"b;
			end;
		     else do;
BADOPT:
			     call complain (error_table_$badopt, whoami, "^a", arg);
			     return;
			end;
		end;

	end;

	if type_count = 0
	then do;
		call complain (error_table_$noarg, whoami, "^/A type name must be specified.");
		return;
	     end;

	if default & (all | switches)
	then do;
		call complain (error_table_$inconsistent, whoami, "-default may not be used with -all or -switches");
		return;
	     end;

	if active_function &
	     (arg_count - type_count > 2) &
	     ^((arg_count - type_count = 2) & default)
	then do;
		call complain (0, whoami, "Only one attribute may be returned.");
		return;
	     end;

	do type_no = 1 to type_count;

	     type = type_name (type_no);

	     si.version = SUFFIX_INFO_VERSION_1;
	     call fs_util_$suffix_info_for_type (type, addr (si), code);
	     if code ^= 0
	     then do;
		     call complain (0, whoami, "There is no extended entry type with the suffix ""^a"".", type);
		     return;
		end;

	     if si.standard_object
	     then if ^(active_function | brief)
		then call ioa_ ("""^a"" is a standard entry type.", substr (type, 2));

	     switch_list_ptr = null ();
	     on cleanup
		begin;
		     if switch_list_ptr ^= null ()
		     then free switch_list;
		end;

	     if all | (arg_count - type_count = 0)	/* defaults */
	     then attributes, switches, name, info_path, plural, modes = "1"b;
	     else if (arg_count - type_count = 1)
		then brief = "1"b;

	     if switches | switch_name ^= ""
	     then do;
		     area_ptr = get_system_free_area_ ();
		     call fs_util_$list_switches_for_type (type, SWITCH_LIST_VERSION_1, area_ptr, switch_list_ptr,
			(0));
		end;

	     if default
	     then if ^si.has_switches
		then do;
		     if ^active_function
			& ^all & (arg_count > 1)  /* by explicit request for switches */
		     then call ioa_ ("The ^a entry type does not support any switches.", si.type_name);
		     else if active_function
		     then ret_str = "";
		end;

	     else do;
		     idx = 0;
		     do arg_idx = 1 to switch_list.switch_count while (idx = 0);
			do name_idx = 0 to switch_list.name_count (arg_idx) - 1 while (idx = 0);
			     if switch_list.names (arg_idx + name_idx) = switch_name
			     then idx = arg_idx;
			end;
		     end;
		     if name_idx = 0
		     then do;
			     call complain (0, whoami, "The ^a type does not support the ^a switch.", si.type_name,
				switch_name);
			     free switch_list;
			     return;
			end;
		end;

	     if name then do;
		display_name = si.type_name;
		if display_name = "multi-segment file" then display_name = "multisegment file";
		if display_name = "DM file" then display_name = "data management file";
	          if active_function
		then ret_str = requote_string_ ((display_name));
		else call ioa_ ("^[Name:^24t^]^a", ^brief, display_name);
	     end;

	     if plural then do;
		display_name = si.plural_name;
		if display_name = "multi-segment files" then display_name = "multisegment files";
		if display_name = "DM files" then display_name = "data management files";
	          if active_function
		then ret_str = requote_string_ ((display_name));
		else call ioa_ ("^[Plural name:^24t^]^a", ^brief, display_name);
	     end;

	     if modes
	     then do;
		     if active_function
		     then ret_str = requote_string_ (si.modes);
		     else call ioa_ ("^[Access modes:^24t^]^a", ^brief, si.modes);
		end;

	     if xacl
	     then if si.extended_acl
		then ret_str = "true";
		else ret_str = "false";

	     if attributes
	     then do;
		     if active_function
		     then ret_str = "";
		     else buffer = "";
		     do idx = 1 to hbound (ATTRIBUTE_NAMES, 1);
			if substr (string (si.copy_flags), idx, 1)
			then if active_function
			     then ret_str = ret_str || requote_string_ ((ATTRIBUTE_NAMES (idx))) || " ";
			     else if buffer = ""
			     then buffer = ATTRIBUTE_NAMES (idx);
			     else buffer = buffer || ", " || ATTRIBUTE_NAMES (idx);
		     end;
		     if ^active_function
		     then do;
			     if buffer ^= ""
			     then call ioa_ ("^[Supported attributes:^24t^]^a", ^brief, buffer);
			     if si.extend | si.update
			     then call ioa_ ("^a may be ^[updated^]^[ and ^]^[extended^] by the copy command",
				     si.plural_name, si.update, (si.update & si.extend), si.extend);
			end;
		end;

	     if default & si.has_switches
		then if active_function
		     then if switch_list.default_value (idx)
		          then ret_str = "on";
		          else ret_str = "off";
		else call ioa_ ("^[^s^;^a defaults to ^]^[on^;off^]", brief, switch_name, switch_list.default_value (idx));

	     if switches
	     then if ^si.has_switches
		then do;
		     if ^active_function & explicit_switches
		     then call ioa_ ("The ^a entry type does not support any switches.", si.type_name);
		     else if active_function
		     then ret_str = "";
		end;
		else do;
		     arg_idx = 18;
		     if ^active_function
		     then do;
			call ioa_ ("Switches:");
			do idx = 1 to switch_list.switch_name_count;
			     arg_idx = max (arg_idx, length (rtrim (switch_list.names (idx))));
			end;
		     end;
		     arg_idx = arg_idx + 6;

		     do idx = 1 to switch_list.switch_count;
			switch_name = switch_list.names (switch_list.name_index (idx));
			if active_function
			then ret_str = ret_str || requote_string_ (switch_name) || " ";
			else do;
				call ioa_ ("^3x^a:^vt^[on^;off^]", switch_name, arg_idx,
				     switch_list.default_value (idx));
				if all
				then do name_idx = 1 to switch_list.name_count (idx) - 1;
					call ioa_ ("^6x^a",
					     switch_list.names (switch_list.name_index (idx) + name_idx));
				     end;
			     end;
		     end;
		end;

	     if switch_list_ptr ^= null ()
	     then free switch_list;

	     if info_path
	     then do;
		     if si.info_pathname = ""
		     then do;
NO_INFO:
			     if active_function | info_path_given
			     then call complain (0, whoami, "No info segment available for ^a.", si.plural_name);
			end;
		     else do;
			     if search (si.info_pathname, "<>") > 0
			     then do;		/* pathname given */
				     call expand_pathname_ (si.info_pathname, dir, entry, code);
				     if code ^= 0
				     then goto NO_INFO;

				     call hcs_$status_minf (dir, entry, 1, (0), (0), code);
				     if code ^= 0
				     then goto NO_INFO;
				end;
			     else do;		/* entryname only, use search list */
				     call search_paths_$find_dir ("info", null (), si.info_pathname, "", dir,
					code);
				     if code ^= 0
				     then goto NO_INFO;
				end;
			     if active_function
			     then ret_str = si.info_pathname;
			     else call ioa_ ("Type ""help ^a"" for more information on ^a.", si.info_pathname,
				     si.plural_name);
			end;
		end;

	     if type_count > 1
	     then if ^active_function
		then call ioa_ ("");

	end;

DSET_EXIT:
	return;

%page;

list_entry_types:
lset:
     entry () options (variable);

	whoami = "list_entry_types";
	call cu_$af_return_arg (arg_count, ret_ptr, ret_len, code);
	call setup (code, LSET_EXIT);
	area_ptr = get_system_free_area_ ();

	if arg_count ^= 0
	then do;
		if active_function
		then call active_fnc_err_$suppress_name (0, whoami, "Usage:  [lset]");
		else call com_err_$suppress_name (0, whoami, "Usage:  lset");
		return;
	     end;

	call hcs_$high_low_seg_count (high, low);
	high = high + low;
	call hcs_$get_search_rules (addr (search_rules));

	type_count = 0;
	star_entry_ptr, star_names_ptr = null ();
	on cleanup
	     begin;
		if star_entry_ptr ^= null ()
		then free star_entries;
		if star_names_ptr ^= null ()
		then free star_names;
	     end;

	do rule = 1 to search_rules.number;
	     if search_rules.names (rule) = "initiated_segments"
	     then do;
		     do idx = low to high;
			code = 0;
			do name_idx = 1 repeat name_idx + 1 while (code = 0);
			     call hcs_$fs_get_ref_name (baseptr (idx), name_idx, ref_name, code);
			     if code = 0
			     then if substr (ref_name, 1, 7) = "suffix_"
				then call check_name (ref_name);
			end;
		     end;
		end;
	     else if search_rules.names (rule) = "referencing_dir"
	     then ;				/* IGNORE */
	     else if search_rules.names (rule) = "working_dir"
	     then do;
		     dir = get_wdir_ ();
		     goto STAR_JOIN;
		end;
	     else if substr (search_rules.names (rule), 1, 1) ^= ">"
	     then call complain (0, whoami, "Unknown search rule ^a.", search_rules.names (rule));
	     else do;
		     dir = search_rules.names (rule);
STAR_JOIN:
		     call hcs_$star_ (dir, "suffix_*", star_ALL_ENTRIES, area_ptr, star_entry_count, star_entry_ptr,
			star_names_ptr, code);
		     if code ^= 0
		     then if code ^= error_table_$nomatch
			then call complain (code, whoami, "Listing ^a.", search_rules.names (rule));
			else ;
		     else do;
			     do idx = 1 to hbound (star_names, 1);
				call check_name (star_names (idx));
			     end;
			     free star_names;
			     free star_entries;
			end;
		end;
	end;

/* The standard names are few, relatively stable, and therefore hardcoded */

	call check_name (FS_OBJECT_TYPE_SEGMENT);
	call check_name (FS_OBJECT_TYPE_DIRECTORY);
	call check_name (FS_OBJECT_TYPE_MSF);
	call check_name (FS_OBJECT_TYPE_DM_FILE);
	call check_name (FS_OBJECT_TYPE_LINK);

LSET_EXIT:
	return;

%page;

check_name:
     proc (name);

declare	name		char (*),
	a_type_name	char (32),
	display_type	char (32),
	display_select	char (32),
	idx		fixed bin,
	info_entry	entry variable options (variable);

	if substr (name, 1, 1) ^= "-"
	then if substr (name, length (rtrim (name)), 1) ^= "_"
	     then return;

	do idx = 1 to type_count;
	     if type_name (idx) = name
	     then return;
	end;

	if substr (name, 1, 1) = "-"
	then a_type_name = name;
	else do;
	     a_type_name = reverse (rtrim (substr (name, 8)));
	     a_type_name = reverse (ltrim (a_type_name, "_"));
	end;
	call fs_util_$make_entry_for_type (ltrim (a_type_name), "suffix_info", info_entry, code);
	if code ^= 0
	then return;

	si.version = SUFFIX_INFO_VERSION_1;
	call info_entry (addr (si));
	display_type = si.type_name;
	if display_type = "DM file" then display_type = "data management file";
	if display_type = "multi-segment file" then display_type = "multisegment file";
	if active_function
	then ret_str = ret_str || requote_string_ ((display_type)) || " ";
	else if si.standard_object
	     then do;
		     if si.type = FS_OBJECT_TYPE_LINK
		     then a_type_name = "link";
		     else if si.type = FS_OBJECT_TYPE_SEGMENT
		     then a_type_name = "segment";
		     else if si.type = FS_OBJECT_TYPE_DIRECTORY
		     then a_type_name = "directory";
		     else if si.type = FS_OBJECT_TYPE_MSF
		     then a_type_name = "msf";
		     else if si.type = FS_OBJECT_TYPE_DM_FILE
		     then a_type_name = "dm_file";

		     call ioa_ ("The standard type ""^a"", which doesn't require a suffix,^/^5xis selected by using the string ""^a"".",
			display_type, a_type_name);
		end;
	     else call ioa_ ("The extended type ""^a"", which uses the ""^a"" suffix,^/^5xis selected by using the string ""^a"".",
		si.type_name, si.type, si.type);

	type_count = type_count + 1;
	type_name (type_count) = name;

	return;
     end check_name;
%page;
setup:
     proc (status, error_exit);

dcl	status		fixed bin (35) parameter;
dcl  error_exit label parameter;

	if status = 0
	then do;
		active_function = "1"b;
		complain = active_fnc_err_;
		ret_str = "";
	     end;
	else if status = error_table_$not_act_fnc
	then do;
		active_function = "0"b;
		complain = com_err_;
	     end;
	else do;
		call com_err_ (status, whoami);
		goto error_exit;
	     end;

	return;
     end setup;

     end describe_entry_type;




		    fs_acl_util_.pl1                10/08/84  1401.6rew 10/08/84  1358.2      268245



/* **************************************************************
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1983 *
   *                                                            *
   * Copyright, (C) Honeywell Information Systems Inc., 1983    *
   *                                                            *
   ************************************************************** */


/* BIM 830919 */
/* MAP 831229 - fixed references to based arrays having zero elements */
/* MAP 840127 - changed same references to accomodate ring 0 bug */
/*            - free storage allocated by hcs_$list_acl when acl_count = 0 */
/*	    - set version in allocated structures */

/* format: style2,indcomtxt */

fs_acl_util_:
     procedure;
/****
      fs_acl_util_: This procedure converts calling sequences from the old
      acl listing sequence to the new one. As new-style calling sequences are
      made available for the primitive objects here, the calls here can be
      changed, and the callers of this changed to call the underlying
      interfaces directly. This program handles segments, directories,
      and MSF's. Other objects are hacked in suffix_XXX_. ****/

/****
      All arguments are as in hcs_, msf_manager_. */

	declare Dir_name		 char (*) parameter;
	declare Entryname		 char (*) parameter;
	declare Area_ptr		 pointer parameter;
	declare Acl_ptr		 pointer parameter;
	declare Code		 fixed bin (35);
	declare Desired_version	 char (8) aligned;
	declare No_SysDaemon	 bit (1);

%include acl_structures;
%page;

	declare old_acl_ptr		 pointer;
	declare system_free_area	 area based (get_system_free_area_ ());
	declare area_ptr		 pointer;
	declare user_area		 area based (area_ptr);
	declare code		 fixed bin (35);
	declare MSF_fcb		 pointer;
	declare null_acl		 bit (1) aligned;
	declare 1 null_segment_acl_array
				 dim (0:0) aligned like segment_acl_entry based (old_acl_ptr);
	declare 1 null_general_acl_entry
				aligned automatic dim (0:0) aligned like general_acl_entry;
	declare 1 null_general_delete_acl_entry
				 aligned automatic dim (0:0) aligned like delete_acl_entry;
	declare 1 null_general_extended_acl_entry
				 aligned automatic dim (0:0) aligned like general_extended_acl_entry;

	declare get_system_free_area_	 entry () returns (ptr);
	declare get_user_free_area_	 entry () returns (ptr);

	declare (
	        hcs_$list_acl,
	        hcs_$list_dir_acl,
	        file_manager_$list_acl
	        )			 entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35));

	declare msf_manager_$acl_list	 entry (ptr, ptr, ptr, ptr, fixed bin, fixed bin (35));

	declare (
	        hcs_$add_acl_entries,
	        hcs_$add_dir_acl_entries,
	        file_manager_$add_acl_entries
	        )			 entry (char (*), char (*), ptr, fixed bin, fixed bin (35));

	declare msf_manager_$acl_add	 entry (ptr, ptr, fixed bin, fixed bin (35));

	declare (
	        hcs_$delete_acl_entries,
	        hcs_$delete_dir_acl_entries,
	        file_manager_$delete_acl_entries
	        )			 entry (char (*), char (*), ptr, fixed bin, fixed bin (35));

	declare msf_manager_$acl_delete
				 entry (ptr, ptr, fixed bin, fixed bin (35));

	declare (
	        hcs_$replace_acl,
	        hcs_$replace_dir_acl,
	        file_manager_$replace_acl
	        )			 entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (35));

	declare msf_manager_$acl_replace
				 entry (ptr, ptr, fixed bin, bit (1), fixed bin (35));

	declare msf_manager_$open	 entry (char (*), char (*), ptr, fixed bin (35));
	declare msf_manager_$close	 entry (ptr);

	declare cleanup		 condition;

%page;

/****
      Entrypoint -- list_segment: Lists seg acls with only REW bits. */

list_segment:
     entry (Dir_name, Entryname, Desired_version, Area_ptr, Acl_ptr, Code);

	acl_ptr = null ();
	Code = 0;

	old_acl_ptr = null ();
	on cleanup
	     begin;
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		old_acl_ptr = null ();
	     end;

	if Desired_version ^= GENERAL_ACL_VERSION_1 & Acl_ptr = null ()
	then call BAD_VERSION;

	if Acl_ptr ^= null ()
	then do;
		acl_ptr = Acl_ptr;
		if general_acl.version ^= GENERAL_ACL_VERSION_1
		then call BAD_VERSION;
	     end;

	call AREA_SETUP;

/**** * strategy: allocate old acl list in system_free_area_,
      then allocate appropriately sized new structure, copy, and
      free. */

	if acl_ptr = null ()
	then call FULL_LIST_SEG_ACL_CENSORED;
	else call SPECIFIC_LIST_SEG_ACL_CENSORED;

	return;

%page;

FULL_LIST_SEG_ACL_CENSORED:
     procedure;

	old_acl_ptr = null ();
	call hcs_$list_acl (Dir_name, Entryname, get_system_free_area_ (), old_acl_ptr, null (), acl_count, code);
	if code ^= 0
	then do;
		Code = code;
		return;
	     end;
	if acl_count = 0
	then do;
		Acl_ptr = null ();
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		return;
	     end;
	allocate general_acl in (user_area);
	general_acl.version = GENERAL_ACL_VERSION_1;
	call CONVERT_OLD_XACL_LIST;			/* does the free */
	Acl_ptr = acl_ptr;
	return;

     end FULL_LIST_SEG_ACL_CENSORED;


SPECIFIC_LIST_SEG_ACL_CENSORED:
     procedure;

	acl_count = general_acl.count;
	if acl_count > 0
	then allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
	else allocate null_segment_acl_array in (system_free_area) set (old_acl_ptr);

	old_acl_ptr -> segment_acl_array (*).access_name = general_acl.entries (*).access_name;
	call hcs_$list_acl (Dir_name, Entryname, null (), null (), old_acl_ptr, acl_count, code);
	Code = code;				/* may be problem with specific entry */
	call CONVERT_OLD_XACL_LIST;
	return;

     end SPECIFIC_LIST_SEG_ACL_CENSORED;

%page;

/**** *
      add_segment: sets only raw acl bits for segments. */

add_segment:
     entry (Dir_name, Entryname, Acl_ptr, Code);

	Code = 0;
	acl_ptr = Acl_ptr;
	old_acl_ptr = null ();
	on cleanup
	     begin;
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		old_acl_ptr = null ();
	     end;

	if acl_ptr = null ()
	then call NULL_INPUT_PTR;

	if general_acl.version ^= GENERAL_ACL_VERSION_1
	then call BAD_VERSION;


	acl_count = general_acl.count;
	if acl_count > 0
	then allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
	else allocate null_segment_acl_array in (system_free_area) set (old_acl_ptr);

	old_acl_ptr -> segment_acl_array (*) = general_acl.entries (*), by name;
	old_acl_ptr -> segment_acl_array (*).extended_mode = ""b;
	call hcs_$add_acl_entries (Dir_name, Entryname, old_acl_ptr, acl_count, code);

	if acl_count > 0
	then general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code;
	free old_acl_ptr -> segment_acl_array;
	Code = code;
	return;

%page;

/****
      list_segment_extended_acl: This entrypoint supports the inner ring programs
      that implement extended objects, by allowing them to list the acl
      with xacl bits. */

list_segment_extended:
     entry (Dir_name, Entryname, Desired_version, Area_ptr, Acl_ptr, Code);

	acl_ptr = null ();
	Code = 0;

	old_acl_ptr = null ();
	on cleanup
	     begin;
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		old_acl_ptr = null ();
	     end;

	if Desired_version ^= GENERAL_EXTENDED_ACL_VERSION_1 & Acl_ptr = null ()
	then call BAD_VERSION;

	if Acl_ptr ^= null ()
	then do;
		acl_ptr = Acl_ptr;
		if general_extended_acl.version ^= GENERAL_EXTENDED_ACL_VERSION_1
		then call BAD_VERSION;
	     end;

	call AREA_SETUP;

	if acl_ptr = null ()
	then call FULL_LIST_SEG_ACL;
	else call SPECIFIC_LIST_SEG_ACL;

	return;

%page;

FULL_LIST_SEG_ACL:
     procedure;

/****
      Here all we have to do is copy data from array to refer extent. */

	call hcs_$list_acl (Dir_name, Entryname, get_system_free_area_ (), old_acl_ptr, null (), acl_count, code);
	if code ^= 0
	then do;
		Code = code;
		return;
	     end;

	if acl_count = 0
	then do;
		Acl_ptr = null ();
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		return;
	     end;

	allocate general_extended_acl in (user_area);
	general_extended_acl.version = GENERAL_EXTENDED_ACL_VERSION_1;
	general_extended_acl.entries (*) = old_acl_ptr -> segment_acl_array (*);
	free old_acl_ptr -> segment_acl_array;
	Acl_ptr = acl_ptr;
	return;
     end FULL_LIST_SEG_ACL;


SPECIFIC_LIST_SEG_ACL:
     procedure;

	acl_count = general_extended_acl.count;
	if acl_count > 0
	then call hcs_$list_acl (Dir_name, Entryname, null (), null (), addr (general_extended_acl.entries),
	     acl_count, Code);
	else call hcs_$list_acl (Dir_name, Entryname, null (), null (), addr (null_general_extended_acl_entry),
	     0, Code);

	return;
     end SPECIFIC_LIST_SEG_ACL;

%page;

/****
      add_segment_extended: adds entries allowing specification of the xacl bits. */

add_segment_extended:
     entry (Dir_name, Entryname, Acl_ptr, Code);

	Code = 0;
	if Acl_ptr = null ()
	then call NULL_INPUT_PTR;

	acl_ptr = Acl_ptr;
	if general_extended_acl.version ^= GENERAL_EXTENDED_ACL_VERSION_1
	then call BAD_VERSION;

	if general_extended_acl.count > 0
	then call hcs_$add_acl_entries (Dir_name, Entryname, addr (general_extended_acl.entries),
	     general_extended_acl.count, Code);
	else call hcs_$add_acl_entries (Dir_name, Entryname, addr (null_general_extended_acl_entry),
	     0, Code);
	return;

%page;

replace_segment:
     entry (Dir_name, Entryname, Acl_ptr, No_SysDaemon, Code);

	Code = 0;
	old_acl_ptr = null ();
	on cleanup
	     begin;
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		old_acl_ptr = null ();
	     end;
	if Acl_ptr = null ()
	then
REPLACE_NULL_SEGMENT:
	     do;
		call hcs_$replace_acl (Dir_name, Entryname, null (), (0), No_SysDaemon, Code);
		return;
	     end;

	acl_ptr = Acl_ptr;
	if general_acl.version ^= GENERAL_ACL_VERSION_1
	then call BAD_VERSION;

	acl_count = general_acl.count;

	if acl_count > 0
	then allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
	else allocate null_segment_acl_array in (system_free_area) set (old_acl_ptr);

	old_acl_ptr -> segment_acl_array (*).extended_mode = ""b;
	old_acl_ptr -> segment_acl_array (*) = general_acl.entries (*), by name;

	call hcs_$replace_acl (Dir_name, Entryname, old_acl_ptr, acl_count, No_SysDaemon, Code);

	if acl_count > 0
	then general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code;
	free old_acl_ptr -> segment_acl_array;
	return;

%page;

/****
      replace_segment_extended: like add_segment_extended */

replace_segment_extended:
     entry (Dir_name, Entryname, Acl_ptr, No_SysDaemon, Code);

	Code = 0;
	if Acl_ptr = null ()
	then go to REPLACE_NULL_SEGMENT;

	acl_ptr = Acl_ptr;
	if general_extended_acl.version ^= GENERAL_EXTENDED_ACL_VERSION_1
	then call BAD_VERSION;

	if general_extended_acl.count > 0
	then call hcs_$replace_acl (Dir_name, Entryname, addr (general_extended_acl.entries), general_extended_acl.count,
	     No_SysDaemon, Code);
	else call hcs_$replace_acl (Dir_name, Entryname, addr (null_general_extended_acl_entry), 0,
	     No_SysDaemon, Code);

	return;

%page;

/****
      delete_segment: deletes segment acl's */

delete_segment:
     entry (Dir_name, Entryname, Acl_ptr, Code);

	Code = 0;

	if Acl_ptr = null ()
	then call NULL_INPUT_PTR;
	acl_ptr = Acl_ptr;
	if general_delete_acl.version ^= GENERAL_DELETE_ACL_VERSION_1
	then call BAD_VERSION;

	if general_delete_acl.count > 0
	then call hcs_$delete_acl_entries (Dir_name, Entryname, addr (general_delete_acl.entries), general_delete_acl.count,
	     Code);
	else call hcs_$delete_acl_entries (Dir_name, Entryname, addr (null_general_delete_acl_entry), 0,
	     Code);

	return;

%page;

/****

      list_directory: list the directory acl. This is just a matter of an
      array. */

list_directory:
     entry (Dir_name, Entryname, Desired_version, Area_ptr, Acl_ptr, Code);

	acl_ptr = null ();
	old_acl_ptr = null ();
	on cleanup
	     begin;
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> directory_acl_array;
		old_acl_ptr = null ();
	     end;

	if Area_ptr = null () & Acl_ptr = null ()
	then call NULL_INPUT_PTR;

	Code = 0;
	if Acl_ptr ^= null ()
	then do;
		acl_ptr = Acl_ptr;
		if general_acl.version ^= GENERAL_ACL_VERSION_1
		then call BAD_VERSION;
	     end;
	else if Desired_version ^= GENERAL_ACL_VERSION_1
	then call BAD_VERSION;

	call AREA_SETUP;

	if acl_ptr = null ()
	then call FULL_LIST_DIR_ACL;
	else call SPECIFIC_LIST_DIR_ACL;

	return;

%page;

FULL_LIST_DIR_ACL:
     procedure;

	old_acl_ptr = null ();
	call hcs_$list_dir_acl (Dir_name, Entryname, get_system_free_area_ (), old_acl_ptr, null (), acl_count, code);
	if code ^= 0
	then do;
		Code = code;
		return;
	     end;

	if acl_count = 0
	then do;
		Acl_ptr = null ();
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> directory_acl_array;
		return;
	     end;

	allocate general_acl in (user_area);
	general_acl.version = GENERAL_ACL_VERSION_1;
	general_acl.entries (*) = old_acl_ptr -> directory_acl_array (*);
	free old_acl_ptr -> directory_acl_array;
	Acl_ptr = acl_ptr;
	return;
     end FULL_LIST_DIR_ACL;

%page;

SPECIFIC_LIST_DIR_ACL:
     procedure;

	acl_count = general_acl.count;
	if acl_count > 0
	then call hcs_$list_dir_acl (Dir_name, Entryname, null (), null (), addr (general_acl.entries), acl_count, Code);
	else call hcs_$list_dir_acl (Dir_name, Entryname, null (), null (), addr (null_general_acl_entry), 0, Code);

	return;
     end SPECIFIC_LIST_DIR_ACL;

%page;

/****
      add_directory: adds dir entries */

add_directory:
     entry (Dir_name, Entryname, Acl_ptr, Code);

	if Acl_ptr = null ()
	then call NULL_INPUT_PTR;
	acl_ptr = Acl_ptr;
	if general_acl.version ^= GENERAL_ACL_VERSION_1
	then call BAD_VERSION;

	if general_acl.count > 0
	then call hcs_$add_dir_acl_entries (Dir_name, Entryname, addr (general_acl.entries), general_acl.count, Code);
	else call hcs_$add_dir_acl_entries (Dir_name, Entryname, addr (null_general_acl_entry), 0, Code);

	return;

%page;

/****
      delete_directory: deletes directory entries */

delete_directory:
     entry (Dir_name, Entryname, Acl_ptr, Code);

	if Acl_ptr = null ()
	then call NULL_INPUT_PTR;
 	acl_ptr = Acl_ptr;
	if general_delete_acl.version ^= GENERAL_DELETE_ACL_VERSION_1
	then call BAD_VERSION;

	if general_delete_acl.count > 0
	then call hcs_$delete_dir_acl_entries (Dir_name, Entryname, addr (general_delete_acl.entries),
	     general_delete_acl.count, Code);
	else call hcs_$delete_dir_acl_entries (Dir_name, Entryname, addr (null_general_delete_acl_entry),
	     0, Code);

	return;

%page;

/****
      replace_directory:  replaces directory acl. */

replace_directory:
     entry (Dir_name, Entryname, Acl_ptr, No_SysDaemon, Code);

	acl_ptr = Acl_ptr;
	if acl_ptr = null ()
	then do;
		call hcs_$replace_dir_acl (Dir_name, Entryname, null (), 0, No_SysDaemon, Code);
		return;
	     end;

	if general_acl.version ^= GENERAL_ACL_VERSION_1
	then call BAD_VERSION;

	if general_acl.count > 0
	then call hcs_$replace_dir_acl (Dir_name, Entryname, addr (general_acl.entries), general_acl.count, No_SysDaemon,
	     Code);
	else call hcs_$replace_dir_acl (Dir_name, Entryname, addr (null_general_acl_entry), 0, No_SysDaemon,
	     Code);

	return;

%page;

/**** *
      list_dm_file: data management (file_manager_) files */

list_dm_file:
     entry (Dir_name, Entryname, Desired_version, Area_ptr, Acl_ptr, Code);

	acl_ptr = null ();
	old_acl_ptr = null ();
	on cleanup
	     begin;
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		old_acl_ptr = null ();
	     end;
	if Area_ptr = null () & Acl_ptr = null ()
	then call NULL_INPUT_PTR;

	Code = 0;
	if Acl_ptr ^= null ()
	then do;
		acl_ptr = Acl_ptr;
		if general_acl.version ^= GENERAL_ACL_VERSION_1
		then call BAD_VERSION;
	     end;
	else if Desired_version ^= GENERAL_ACL_VERSION_1
	then call BAD_VERSION;

	call AREA_SETUP;

	if acl_ptr = null ()
	then call FULL_LIST_DM_ACL;
	else call SPECIFIC_LIST_DM_ACL;

	return;

%page;

FULL_LIST_DM_ACL:
     procedure;

	old_acl_ptr = null ();
	call file_manager_$list_acl (Dir_name, Entryname, get_system_free_area_ (), old_acl_ptr, null (), acl_count,
	     code);
	if code ^= 0
	then do;
		Code = code;
		return;
	     end;

	if acl_count = 0
	then do;
		Acl_ptr = null ();
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		return;
	     end;


	allocate general_acl in (user_area);
	general_acl.version = GENERAL_ACL_VERSION_1;
	call CONVERT_OLD_XACL_LIST;
	Acl_ptr = acl_ptr;
	return;
     end FULL_LIST_DM_ACL;

%page;

SPECIFIC_LIST_DM_ACL:
     procedure;

	acl_count = general_acl.count;
	if acl_count > 0
	then allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
	else allocate null_segment_acl_array in (system_free_area) set (old_acl_ptr);

	old_acl_ptr -> segment_acl_array (*).access_name = general_acl.entries (*).access_name;
	call file_manager_$list_acl (Dir_name, Entryname, null (), null (), old_acl_ptr, acl_count, code);
	call CONVERT_OLD_XACL_LIST;
	Code = code;
	return;
     end SPECIFIC_LIST_DM_ACL;

%page;

/****
      No extended entrypoints for files yet, since there is no hurry. */

/****
      add_dm_file: adds dm entries */

add_dm_file:
     entry (Dir_name, Entryname, Acl_ptr, Code);

	old_acl_ptr = null ();
	on cleanup
	     begin;
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		old_acl_ptr = null ();
	     end;
	Code = 0;
	if Acl_ptr = null ()
	then call NULL_INPUT_PTR;
	acl_ptr = Acl_ptr;
	if general_acl.version ^= GENERAL_ACL_VERSION_1
	then call BAD_VERSION;

	acl_count = general_acl.count;
	if acl_count > 0
	then allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
	else allocate null_segment_acl_array in (system_free_area) set (old_acl_ptr);

	old_acl_ptr -> segment_acl_array (*) = general_acl.entries (*), by name;
	old_acl_ptr -> segment_acl_array (*).extended_mode = ""b;
	call file_manager_$add_acl_entries (Dir_name, Entryname, old_acl_ptr, acl_count, Code);

	if acl_count > 0
	then general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code;
	free old_acl_ptr -> segment_acl_array;

	return;

%page;

/****
      delete_dm_file: deletes file entries */

delete_dm_file:
     entry (Dir_name, Entryname, Acl_ptr, Code);

	if Acl_ptr = null ()
	then call NULL_INPUT_PTR;
 	acl_ptr = Acl_ptr;
	if general_delete_acl.version ^= GENERAL_DELETE_ACL_VERSION_1
	then call BAD_VERSION;

	if general_acl.count > 0
	then call file_manager_$delete_acl_entries (Dir_name, Entryname, addr (general_delete_acl.entries),
	     general_delete_acl.count, Code);
	else call file_manager_$delete_acl_entries (Dir_name, Entryname, addr (null_general_delete_acl_entry),
	     0, Code);

	return;

%page;

/****
      replace_dm_file:  replaces file acl. */

replace_dm_file:
     entry (Dir_name, Entryname, Acl_ptr, No_SysDaemon, Code);

	old_acl_ptr = null ();
	on cleanup
	     begin;
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		old_acl_ptr = null ();
	     end;
	acl_ptr = Acl_ptr;
	Code = 0;
	if acl_ptr = null ()
	then do;
		call file_manager_$replace_acl (Dir_name, Entryname, null (), 0, No_SysDaemon, Code);
		return;
	     end;

	if general_acl.version ^= GENERAL_ACL_VERSION_1
	then call BAD_VERSION;

	acl_count = general_acl.count;

	if acl_count > 0
	then allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
	else allocate null_segment_acl_array in (system_free_area) set (old_acl_ptr);
	old_acl_ptr -> segment_acl_array (*) = general_acl.entries (*), by name;

	call file_manager_$replace_acl (Dir_name, Entryname, old_acl_ptr, acl_count, No_SysDaemon, Code);

	if acl_count > 0
	then general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code;
	free old_acl_ptr -> segment_acl_array;

	return;

%page;

/****
      The next group of entrypoints are for MSF_manager,
      that has all the problems hcs_ has plus having to open the MSF. */

list_msf:
     entry (Dir_name, Entryname, Desired_version, Area_ptr, Acl_ptr, Code);

	old_acl_ptr = null ();
	on cleanup
	     begin;
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		old_acl_ptr = null ();
	     end;

	Code = 0;
	acl_ptr = null ();
	if Area_ptr = null () & Acl_ptr = null ()
	then call NULL_INPUT_PTR;

	if Acl_ptr ^= null ()
	then do;
		acl_ptr = Acl_ptr;
		if general_acl.version ^= GENERAL_ACL_VERSION_1
		then call BAD_VERSION;
	     end;
	else if Desired_version ^= GENERAL_ACL_VERSION_1
	then call BAD_VERSION;


	call AREA_SETUP;

	call msf_manager_$open (Dir_name, Entryname, MSF_fcb, Code);
	if Code ^= 0
	then return;

	if acl_ptr = null ()
	then call FULL_LIST_MSF_ACL_CENSORED;
	else call SPECIFIC_LIST_MSF_ACL_CENSORED;

	call msf_manager_$close (MSF_fcb);
	return;

%page;

FULL_LIST_MSF_ACL_CENSORED:
     procedure;

	call msf_manager_$acl_list (MSF_fcb, get_system_free_area_ (), old_acl_ptr, null (), acl_count, Code);
	if Code ^= 0
	then return;
	if acl_count = 0
	then do;
		Acl_ptr = null ();
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		return;
	     end;
	allocate general_acl in (user_area);
	general_acl.version = GENERAL_ACL_VERSION_1;
	call CONVERT_OLD_XACL_LIST;			/* does the free, as well */
	Acl_ptr = acl_ptr;
	return;
     end FULL_LIST_MSF_ACL_CENSORED;

SPECIFIC_LIST_MSF_ACL_CENSORED:
     procedure;

	acl_count = general_acl.count;
	if acl_count > 0
	then allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
	else allocate null_segment_acl_array in (system_free_area) set (old_acl_ptr);

	old_acl_ptr -> segment_acl_array (*).access_name = general_acl.entries (*).access_name;
	call msf_manager_$acl_list (MSF_fcb, null (), null (), old_acl_ptr, acl_count, Code);
	call CONVERT_OLD_XACL_LIST;
	return;
     end SPECIFIC_LIST_MSF_ACL_CENSORED;

%page;

/****
      list_msf_extended:  lists extended acls of MSF acls. */

list_msf_extended:
     entry (Dir_name, Entryname, Desired_version, Area_ptr, Acl_ptr, Code);

	acl_ptr = null ();
	Code = 0;

	old_acl_ptr = null ();
	on cleanup
	     begin;
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		old_acl_ptr = null ();
	     end;

	if Desired_version ^= GENERAL_EXTENDED_ACL_VERSION_1 & Acl_ptr = null ()
	then call BAD_VERSION;

	if Acl_ptr ^= null ()
	then do;
		acl_ptr = Acl_ptr;
		if general_extended_acl.version ^= GENERAL_EXTENDED_ACL_VERSION_1
		then call BAD_VERSION;
	     end;

	call AREA_SETUP;

	call msf_manager_$open (Dir_name, Entryname, MSF_fcb, Code);
	if Code ^= 0
	then return;

	if acl_ptr = null ()
	then call FULL_LIST_MSF_ACL;
	else call SPECIFIC_LIST_MSF_ACL;

	call msf_manager_$close (MSF_fcb);
	return;

%page;

FULL_LIST_MSF_ACL:
     procedure;

	call msf_manager_$acl_list (MSF_fcb, get_system_free_area_ (), old_acl_ptr, null (), acl_count, code);
	if code ^= 0
	then do;
		Code = code;
		return;
	     end;

	if acl_count = 0
	then do;
		Acl_ptr = null ();
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		return;
	     end;

	allocate general_extended_acl in (user_area);
	general_extended_acl.version = GENERAL_EXTENDED_ACL_VERSION_1;
	general_extended_acl.entries (*) = old_acl_ptr -> segment_acl_array (*);
	free old_acl_ptr -> segment_acl_array;
	Acl_ptr = acl_ptr;
	return;
     end FULL_LIST_MSF_ACL;

SPECIFIC_LIST_MSF_ACL:
     procedure;

	if general_extended_acl.count > 0
	then call msf_manager_$acl_list (MSF_fcb, null (), null (), addr (general_extended_acl.entries),
	     general_extended_acl.count, Code);
	else call msf_manager_$acl_list (MSF_fcb, null (), null (), addr (null_general_extended_acl_entry),
	     0, Code);

	return;
     end SPECIFIC_LIST_MSF_ACL;

%page;

/****
      add_msf: adds entries for MSF */

add_msf:
     entry (Dir_name, Entryname, Acl_ptr, Code);

	acl_ptr = Acl_ptr;
	Code = 0;
	old_acl_ptr = null ();
	on cleanup
	     begin;
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		old_acl_ptr = null ();
	     end;
	if acl_ptr = null ()
	then call NULL_INPUT_PTR;
	if general_acl.version ^= GENERAL_ACL_VERSION_1
	then call BAD_VERSION;

	call msf_manager_$open (Dir_name, Entryname, MSF_fcb, Code);
	if Code ^= 0
	then return;

	acl_count = general_acl.count;
	if acl_count > 0
	then allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
	else allocate null_segment_acl_array in (system_free_area) set (old_acl_ptr);

	old_acl_ptr -> segment_acl_array (*) = general_acl.entries (*), by name;
	call msf_manager_$acl_add (MSF_fcb, old_acl_ptr, general_acl.count, Code);

	call msf_manager_$close (MSF_fcb);

	if acl_count > 0
	then general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code;
	free old_acl_ptr -> segment_acl_array;

	return;

%page;

/****
      add_msf_extended: adds entries for MSF */

add_msf_extended:
     entry (Dir_name, Entryname, Acl_ptr, Code);

	acl_ptr = Acl_ptr;
	Code = 0;
	old_acl_ptr = null ();
	on cleanup
	     begin;
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		old_acl_ptr = null ();
	     end;

	if acl_ptr = null ()
	then call NULL_INPUT_PTR;
	if general_acl.version ^= GENERAL_EXTENDED_ACL_VERSION_1
	then call BAD_VERSION;

	call msf_manager_$open (Dir_name, Entryname, MSF_fcb, Code);
	if Code ^= 0
	then return;

	if general_extended_acl.count > 0
	then call msf_manager_$acl_add (MSF_fcb, addr (general_extended_acl.entries), general_extended_acl.count, Code);
	else call msf_manager_$acl_add (MSF_fcb, addr (null_general_extended_acl_entry), 0, Code);

	call msf_manager_$close (MSF_fcb);
	return;

%page;

/****
      delete_msf: deletes msf acl entries */

delete_msf:
     entry (Dir_name, Entryname, Acl_ptr, Code);

	if Acl_ptr = null ()
	then call NULL_INPUT_PTR;
	acl_ptr = Acl_ptr;
	if general_delete_acl.version ^= GENERAL_DELETE_ACL_VERSION_1
	then call BAD_VERSION;

	call msf_manager_$open (Dir_name, Entryname, MSF_fcb, Code);
	if Code ^= 0
	then return;

	if general_delete_acl.count > 0
	then call msf_manager_$acl_delete (MSF_fcb, addr (general_delete_acl.entries), general_delete_acl.count, Code);
	else call msf_manager_$acl_delete (MSF_fcb, addr (null_general_delete_acl_entry), 0, Code);

	call msf_manager_$close (MSF_fcb);
	return;

%page;

/****
      replace_msf: replaces msf acls. */

replace_msf:
     entry (Dir_name, Entryname, Acl_ptr, No_SysDaemon, Code);


	acl_ptr = Acl_ptr;
	Code = 0;
	old_acl_ptr = null ();
	on cleanup
	     begin;
		if old_acl_ptr ^= null ()
		then free old_acl_ptr -> segment_acl_array;
		old_acl_ptr = null ();
	     end;
	if acl_ptr = null ()
	then null_acl = "1"b;
	else null_acl = "0"b;

	if ^null_acl
	then if general_acl.version ^= GENERAL_ACL_VERSION_1
	     then call BAD_VERSION;

	call msf_manager_$open (Dir_name, Entryname, MSF_fcb, Code);
	if Code ^= 0
	then return;

	if null_acl
	then
MSF_REPLACE_NULL:
	     do;
		call msf_manager_$acl_replace (MSF_fcb, null (), 0, No_SysDaemon, Code);
		call msf_manager_$close (MSF_fcb);
		return;
	     end;

	acl_count = general_acl.count;

	if acl_count > 0
	then allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
	else allocate null_segment_acl_array in (system_free_area) set (old_acl_ptr);
	old_acl_ptr -> segment_acl_array (*) = general_acl.entries (*), by name;
	call msf_manager_$acl_replace (MSF_fcb, old_acl_ptr, acl_count, No_SysDaemon, Code);
	if acl_count > 0
	then general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code;
	free old_acl_ptr -> segment_acl_array;

	call msf_manager_$close (MSF_fcb);
	return;

%page;

/****
      replace_msf_extended -- allows xacl replacement for MSF'S */

replace_msf_extended:
     entry (Dir_name, Entryname, Acl_ptr, No_SysDaemon, Code);


	acl_ptr = Acl_ptr;
	if acl_ptr = null ()
	then null_acl = "1"b;
	else null_acl = "0"b;

	if ^null_acl
	then if general_extended_acl.version ^= GENERAL_EXTENDED_ACL_VERSION_1
	     then call BAD_VERSION;

	call msf_manager_$open (Dir_name, Entryname, MSF_fcb, Code);
	if Code ^= 0
	then return;

	if null_acl
	then go to MSF_REPLACE_NULL;

	if general_extended_acl.count > 0
	then call msf_manager_$acl_replace (MSF_fcb, addr (general_extended_acl.entries), general_extended_acl.count,
	     No_SysDaemon, Code);
	else call msf_manager_$acl_replace (MSF_fcb, addr (null_general_extended_acl_entry), 0,
	     No_SysDaemon, Code);

	call msf_manager_$close (MSF_fcb);
	return;

%page;

CONVERT_OLD_XACL_LIST:
     procedure;

/****
      This procedure assumes that there is a segment_acl_array based (old_acl_ptr)
      to be copied into a general_acl, and freed. */

	if general_acl.count > 0
	then general_acl.entries (*) = old_acl_ptr -> segment_acl_array (*), by name;
	free old_acl_ptr -> segment_acl_array;
	return;
     end CONVERT_OLD_XACL_LIST;

%page;

AREA_SETUP:
     procedure;

	if Area_ptr = null ()
	then area_ptr = get_user_free_area_ ();		/* may not be used if we are listing specifically */
	else area_ptr = Area_ptr;
	return;

     end AREA_SETUP;

BAD_VERSION:
     procedure;

%include sub_err_flags;
	declare sub_err_		 entry () options (variable);
	declare error_table_$unimplemented_version
				 fixed bin (35) ext static;
	declare error_table_$null_info_ptr
				 fixed bin (35) ext static;

/**** *
      file_system_ is supposed to check these version, but we signal here
      just in case. */

	call sub_err_ (error_table_$unimplemented_version, "Invalid ACL structure version", ACTION_CANT_RESTART,
	     null (), (0), "");

	return;

NULL_INPUT_PTR:
     entry;

	call sub_err_ (error_table_$null_info_ptr, "Null ACL structure pointer", ACTION_CANT_RESTART, null (), (0), "");
	return;
     end BAD_VERSION;

     end fs_acl_util_;




		    fs_copy_util_.pl1               01/29/86  1418.7rew 01/29/86  1353.4      190206



/****^  **************************************************************
        *                                                            *
        * Copyright, (C) Honeywell Information Systems Inc., 1983    *
        *                                                            *
        * Copyright, (C) Massachusetts Institute of Technology, 1983 *
        *                                                            *
        ************************************************************** */



/****^  HISTORY COMMENTS:
  1) change(85-10-29,MSharpe), approve(86-01-24,MCR7296),
     audit(86-01-24,CLJones), install(86-01-29,MR12.0-1009):
     History comments before hcom:
      fs_util_$copy for segments and MSF's
     - BIM 831022
     - MAP 840206 to properly close SSF when copying SSF -> MSF -update
     - MSharpe 850212 to force_access in case of "-fc (-update -extend)";
      to return et_$inconsistent_msf instead of et_$noentry if msf>0 is
      not found; to delete the forced acl entry if none existed before and
      replace the forced acl with the original mode otherwise; to compare
      the max length of target with bit_count/36 instead of bit_count/4.
     - MSharpe 850307 to check the contents of target past the bitcount
      up to the last bit of current length whenever there is a discrepency.
      If there are only zeroes, we copy; otherwise, give "bit count is
      inconsistent with current length" error message.
     
     and the reason for the first use of history_comment is...
     
     Fixed bug that caused components of msfs to be terminated twice.
                                                   END HISTORY COMMENTS */


/* format: style2,indcomtxt,idind30 */

fs_copy_util_:
     procedure;

	declare P_copy_options_ptr	        ptr parameter;
	declare P_status		        fixed bin (35) parameter;

	declare attach_desc		        char (200);
	declare (bit_count, bc2)	        fixed bin (24);
	declare char_count		        fixed bin (21);
	declare code		        fixed bin (35);
	declare component_ptr	        ptr;
	declare curlen		        fixed bin;
	declare dir		        char (168);
	declare ename		        char (32);
	declare (forced_access, delete_forced_acle)
				        bit (1) aligned;
	declare (fcb_ptr, new_fcb_ptr)        ptr;
	declare increment		        fixed bin;
	declare iocb_name		        char (32);
	declare iocb_ptr		        ptr;
	declare max_length		        fixed bin (19);
	declare modes		        bit (36) aligned;
	declare (msf, target_msf)	        bit (1) aligned;
	declare (new_seg_ptr, old_seg_ptr)    ptr;
	declare saved_mode		        bit (36) aligned;
	declare source_dir		        char (168);
	declare source_name		        char (32);
	declare source_type		        char (32);
	declare target_dir		        char (168);
	declare target_name		        char (32);
	declare type		        fixed bin;
	declare word_count		        fixed bin (19);

	declare 1 sb		        aligned like status_branch;
	declare 1 sb2		        aligned like status_branch;
	declare 1 cei		        aligned like copy_error_info;
	declare 1 oi		        aligned like object_info;
	declare 1 one_acl		        aligned,
		2 version		        char (8) aligned,
		2 count		        fixed bin,
		2 entries		        (1) aligned like general_acl_entry;
	declare 1 one_del_acl	        aligned,
		2 version		        char (8) aligned,
		2 count		        fixed bin,
		2 entries		        (1) aligned like general_acl_entry;
	declare 1 info		        aligned like indx_info;



	declare (addbitno, addr, clock, divide, fixed, index, min, null, rtrim)
				        builtin,
	        (cleanup, no_write_permission)
				        condition;

	declare (
	        error_table_$inconsistent_msf,
	        error_table_$lower_ring,
	        error_table_$moderr,
	        error_table_$namedup,
	        error_table_$noentry,
	        error_table_$no_e_permission,
	        error_table_$no_s_permission,
	        error_table_$unimplemented_version,
	        error_table_$user_not_found
	        )			        fixed bin (35) external;

	declare add_acl_entries_entry	        entry (char (*), char (*), pointer, fixed bin (35)) variable;
	declare delete_acl_entries_entry      entry (char (*), char (*), pointer, fixed bin (35)) variable;
	declare get_group_id_	        entry returns (char (32));
	declare get_ring_		        entry returns (fixed bin (3));
	declare fs_util_$make_entry_for_type  entry (char (*), char (*), entry, fixed bin (35));
	declare hcs_$fs_get_path_name	        entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	declare hcs_$status_long	        entry (char (*), char (*), fixed bin, ptr, ptr, fixed bin (35));
	declare hcs_$status_minf	        entry (char (*), char (*), fixed bin, fixed bin, fixed bin (24),
				        fixed bin (35));
	declare hcs_$get_max_length_seg       entry (ptr, fixed bin (19), fixed bin (35));
	declare hcs_$get_max_length	        entry (char (*), char (*), fixed bin (19), fixed bin (35));
	declare hcs_$set_bc		        entry (char (*), char (*), fixed bin (24), fixed bin (35));
	declare hcs_$set_bc_seg	        entry (ptr, fixed bin (24), fixed bin (35));
	declare initiate_file_	        entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
	declare initiate_file_$create	        entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24),
				        fixed bin (35));
	declare hcs_$terminate_noname	        entry (ptr, fixed bin (35));
	declare hcs_$truncate_seg	        entry (ptr, fixed bin (19), fixed bin (35));
	declare msf_manager_$adjust	        entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35));
	declare msf_manager_$close	        entry (ptr);
	declare msf_manager_$msf_get_ptr      entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
	declare msf_manager_$get_ptr	        entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
	declare msf_manager_$open	        entry (char (*), char (*), ptr, fixed bin (35));
	declare object_info_$brief	        entry (ptr, fixed bin (24), ptr, fixed bin (35));
	declare pathname_		        entry (char (*), char (*)) returns (char (168));
	declare request_id_		        entry (fixed bin (71)) returns (char (19));
	declare requote_string_	        entry (char (*)) returns (char (*));
	declare sub_err_		        entry options (variable);
	declare vfile_status_	        entry (char (*), char (*), ptr, fixed bin (35));

%include iox_entries;
%include iox_modes;
%include file_system_operations;
%include suffix_info;


/* format: off */

%page; %include status_structures;
%page; %include copy_options;
%page; %include copy_flags;
%page; %include access_mode_values;
%page; %include sub_error_info;
%include sub_err_flags;
%page; %include condition_info_header;
%include copy_error_info;
%page; %include object_info;
%page; %include vfs_info;
%page; %include acl_structures;
/* format: on */


segment:
     entry (P_copy_options_ptr, P_status);

	source_type = FS_OBJECT_TYPE_SEGMENT;
	msf = "0"b;
	go to Entry_Common;

msf:
     entry (P_copy_options_ptr, P_status);
	source_type = FS_OBJECT_TYPE_MSF;
	msf = "1"b;

Entry_Common:
	copy_options_ptr = P_copy_options_ptr;
	if copy_options.version ^= COPY_OPTIONS_VERSION_1
	then call copy_error (error_table_$unimplemented_version, "0"b);

	if copy_options.extend & copy_options.update
	then call fatal (0, "contents", "0"b, "The extend and update switches may not both be specified.");

	source_dir = copy_options.source_dir;
	source_name = copy_options.source_name;
	target_dir = copy_options.target_dir;
	target_name = copy_options.target_name;


	fcb_ptr, new_fcb_ptr, new_seg_ptr, old_seg_ptr = null ();
	forced_access = "0"b;

	on cleanup call cleanup_copy ();
	on no_write_permission call copy_error (error_table_$moderr, "1"b);

	call hcs_$status_long (source_dir, source_name, 1, addr (sb), null (), code);
	if code ^= 0
	then if code ^= error_table_$no_s_permission
	     then call copy_error (code, "0"b);

	if msf
	then do;
		increment = 0;
		call msf_manager_$open (source_dir, source_name, fcb_ptr, code);
		if code ^= 0
		then call copy_error (code, "0"b);
	     end;

	if sb.ring_brackets (1) < get_ring_ ()
	then call copy_error (error_table_$lower_ring, "0"b);
	if sb.mode & R_ACCESS = ""b
	then call copy_error (error_table_$moderr, "0"b);

	if ^msf & ^copy_options.extend
	then do;
		if sb.bit_count = 0
		then bc2 = 0;
		else bc2 = divide (sb.bit_count - 1, (36 * 1024), 12, 0) + 1;
		if bc2 ^= sb.current_length
		then call warning (0, "contents", "0"b, "Bit count is inconsistent with current length for ^a.");
	     end;

/* caller is responsible for namedup */
	call hcs_$status_minf (target_dir, target_name, 1, type, bit_count, code);
	if copy_options.extend | copy_options.update
	then if code ^= 0
	     then call copy_error (code, "1"b);
	     else target_msf = (type = Directory & bit_count > 0);
	else if code ^= error_table_$noentry
	then call copy_error (error_table_$namedup, "1"b);
	else target_msf = "0"b;

/* initiate old segment */
	if msf
	then do;
		call msf_manager_$get_ptr (fcb_ptr, 0, "0"b, old_seg_ptr, bit_count, code);
		if code ^= 0
		then code = error_table_$inconsistent_msf;
	     end;
	else do;
		call initiate_file_ (source_dir, source_name, R_ACCESS, old_seg_ptr, (0), code);
		bit_count = sb.bit_count;
	     end;
	if code ^= 0
	then call copy_error (code, "0"b);

	if copy_options.extend
	then call extend;
	else if ^msf & ^target_msf
	then do;
		call initiate_file_$create (target_dir, target_name, REW_ACCESS, new_seg_ptr, ("0"b), (0), code);
						/* The only problem would be access */
		if copy_options.update
		then do;				/* truncate old contents */
			if copy_options.force & code ^= 0
			then call ensure_access ();	/* force access */
						/* does not affect code */

			if code ^= 0		/* the last call to initiate_file_ was not successful */
			then call initiate_file_ (target_dir, target_name, RW_ACCESS, new_seg_ptr, (0), code);

			if code = 0
			then call hcs_$truncate_seg (new_seg_ptr, 0, code);
			if code ^= 0
			then call copy_error (code, "1"b);
		     end;

		else if code = error_table_$no_e_permission
		then do;
			call initiate_file_ (target_dir, target_name, RW_ACCESS, new_seg_ptr, (0), code);
			if code ^= 0
			then call copy_error (code, "1"b);
		     end;

		if new_seg_ptr = null
		then call copy_error (code, "1"b);

		curlen = sb.current_length;
		word_count = curlen * 1024;

		call copy_a_segment ();

		call hcs_$terminate_noname (old_seg_ptr, (0));
		call hcs_$terminate_noname (new_seg_ptr, (0));
	     end;

	else do;					/* Create target */
		call msf_manager_$open (target_dir, target_name, new_fcb_ptr, code);
		if new_fcb_ptr = null ()
		then call copy_error (code, "1"b);

		if copy_options.update
		then do;				/* truncate the target */
			if copy_options.force
			then call ensure_access ();
			call msf_manager_$adjust (new_fcb_ptr, 0, 0, "010"b, code);
			if code ^= 0
			then call copy_error (code, "1"b);
		     end;

		call msf_manager_$msf_get_ptr (new_fcb_ptr, 0, "1"b, new_seg_ptr, 0, code);

		if code ^= 0
		then call copy_error (code, "1"b);

		do while ("1"b);
		     call hcs_$fs_get_path_name (old_seg_ptr, dir, 0, ename, (0));
		     call hcs_$status_long (dir, ename, 1, addr (sb), null (), code);
		     if code ^= 0
		     then call copy_error (code, "0"b);

		     curlen = fixed (sb.current_length, 12);
		     call hcs_$get_max_length (dir, ename, max_length, code);
		     if code ^= 0
		     then call copy_error (code, "0"b);

		     word_count = min (curlen * 1024, max_length);
		     call copy_a_segment ();

		     if ^msf
		     then goto SSF_UD_FINISH;		/* -update from ssf to msf */
		     increment = increment + 1;

		     call msf_manager_$get_ptr (fcb_ptr, increment, "0"b, old_seg_ptr, bit_count, code);
		     if code ^= 0
		     then goto MSF_FINISH;

		     call msf_manager_$get_ptr (new_fcb_ptr, increment, "1"b, new_seg_ptr, (0), code);
		     if code ^= 0
		     then call copy_error (code, "1"b);
		end;

MSF_FINISH:
		call hcs_$set_bc (target_dir, target_name, (increment), code);
		if code ^= 0
		then call copy_error (code, "1"b);

SSF_UD_FINISH:
		if msf
		then call msf_manager_$close (fcb_ptr);
		else call hcs_$terminate_noname (old_seg_ptr, (0));

		call msf_manager_$close (new_fcb_ptr);
	     end;

	P_status = 0;				/* we exit via subr on errors */
	if forced_access
	then call delete_access ();			/* in case we forcd it earlier */
	return;


copy_a_segment:
     procedure;

	declare segment		        (word_count) fixed bin (35) based;

	new_seg_ptr -> segment = old_seg_ptr -> segment;

	call hcs_$set_bc_seg (new_seg_ptr, bit_count, code);
	if code ^= 0
	then call copy_error (code, "1"b);

	return;
     end copy_a_segment;


extend:
     procedure;

declare  rest_of_seg	bit (extra_bits) based;
declare  extra_bits		fixed bin (24);

	if ^msf
	then do;
		call object_info_$brief (old_seg_ptr, (sb.bit_count), addr (oi), code);
		if code = 0
		then call unstruct ("0"b);

		if sb.bit_count = 0
		then bc2 = 0;
		else bc2 = divide (sb.bit_count - 1, (36 * 1024), 12, 0) + 1;
		if bc2 ^= sb.current_length
		then call fatal (0, "contents", "0"b,
			"Bit count is inconsistent with current length for ^a. Cannot copy it.");
	     end;

	info.info_version = vfs_version_1;
	call vfile_status_ (source_dir, source_name, addr (info), code);
	if code ^= 0
	then call copy_error (code, "0"b);
	if info.type ^= 1 | (info.type = 1 & uns_info.flags.header_present)
	then call unstruct ("0"b);

	if copy_options.force
	then call ensure_access ();

	call vfile_status_ (target_dir, target_name, addr (info), code);
	if code ^= 0
	then call copy_error (code, "1"b);
	if info.type ^= 1 | (info.type = 1 & uns_info.flags.header_present)
	then call unstruct ("1"b);

	if ^target_msf
	then do;
		call initiate_file_ (target_dir, target_name, RW_ACCESS, new_seg_ptr, (0), code);
		if code ^= 0
		then call copy_error (code, "1"b);

		call hcs_$status_long (target_dir, target_name, 1, addr (sb2), null (), code);
		if code ^= 0
		then call copy_error (code, "1"b);

		if sb2.bit_count = 0
		then bc2 = 0;
		else bc2 = divide (sb2.bit_count - 1, (36 * 1024), 12, 0) + 1;
		if bc2 ^= sb2.current_length
		then do;
		     extra_bits = sb2.current_length * 1024 * 36 - sb2.bit_count;
						/* bits past bit_count */
		     if index (addbitno (new_seg_ptr, sb2.bit_count) -> rest_of_seg, "1"b) > 0
		     then call fatal (0, "contents", "1"b,
			"Bit count is inconsistent with current length for ^s^a. Cannot append to it.");
		end;

		call object_info_$brief (new_seg_ptr, (sb2.bit_count), addr (oi), code);
		if code = 0
		then call unstruct ("1"b);

		if ^msf
		then do;				/* check for easy case */
			call hcs_$get_max_length_seg (new_seg_ptr, max_length, code);
			if code ^= 0
			then call copy_error (code, "1"b);

			if divide ((sb.bit_count + sb2.bit_count), 36, 19, 0) > max_length
			then goto USE_IOX;

			bit_count = sb.bit_count + sb2.bit_count;
			new_seg_ptr = addbitno (new_seg_ptr, sb2.bit_count);
						/* point to end of target */
			word_count = divide (sb.bit_count - 1, 36, 19, 0) + 1;

			call copy_a_segment ();

			call hcs_$terminate_noname (old_seg_ptr, (0));
			call hcs_$terminate_noname (new_seg_ptr, (0));

			return;
		     end;
	     end;

USE_IOX:
	iocb_ptr = null ();
	on cleanup call close_and_destroy_iocb ();

	if ^target_msf
	then call hcs_$terminate_noname (new_seg_ptr, (0));

	iocb_name = "copy_." || request_id_ (clock ());
	attach_desc = "vfile_ " || requote_string_ (rtrim (pathname_ (target_dir, target_name))) || " -extend";

	call iox_$attach_name (iocb_name, iocb_ptr, attach_desc, null (), code);
	if code ^= 0
	then call copy_error (code, "1"b);

	call iox_$open (iocb_ptr, Stream_output, "0"b, code);
	if code ^= 0
	then call copy_error (code, "1"b);

	if ^msf
	then do;
		char_count = divide (bit_count - 1, 9, 21, 0) + 1;
		call iox_$put_chars (iocb_ptr, old_seg_ptr, char_count, code);
		if code ^= 0
		then call copy_error (code, "1"b);
	     end;
	else do increment = 0 repeat increment + 1;
		call msf_manager_$get_ptr (fcb_ptr, increment, "0"b, component_ptr, bit_count, code);
		if component_ptr = null ()
		then goto DONE;

		char_count = divide (bit_count - 1, 9, 21, 0) + 1;
		call iox_$put_chars (iocb_ptr, component_ptr, char_count, code);
		if code ^= 0
		then call copy_error (code, "1"b);
	     end;

DONE:
	call close_and_destroy_iocb ();

	if msf
	then call msf_manager_$close (fcb_ptr);
	else call hcs_$terminate_noname (old_seg_ptr, (0));

	return;
%page;
unstruct:
     proc (errsw);

	declare errsw		        bit (1) aligned;

	call fatal (0, "contents", errsw, "Only unstructured files without headers may be used with -extend.");

     end unstruct;


close_and_destroy_iocb:
     proc ();

	if iocb_ptr = null ()
	then return;

	call iox_$close (iocb_ptr, (0));
	call iox_$detach_iocb (iocb_ptr, (0));
	call iox_$destroy_iocb (iocb_ptr, (0));

	return;
     end close_and_destroy_iocb;

     end extend;
%page;

copy_error:
     proc (status, switch);

	declare status		        fixed bin (35),
	        switch		        bit (1) aligned;

	cei.copy_options_ptr = copy_options_ptr;
	cei.operation = "contents";
	cei.target_err_switch = switch;

	do while ("1"b);
	     call sub_err_ (status, "copy_", ACTION_CANT_RESTART, addr (cei), (0), "^[^a^;^s^a^]", switch,
		pathname_ (target_dir, target_name), pathname_ (source_dir, source_name));

	end;

     end copy_error;

error:
     proc (status, op, switch, message);

	declare flags		        bit (36) aligned,
	        status		        fixed bin (35),
	        op		        char (*),
	        switch		        bit (1) aligned,
	        message		        char (*);

	flags = ACTION_CAN_RESTART;
	goto COMMON;

fatal:
     entry (status, op, switch, message);

	flags = ACTION_CANT_RESTART;
	goto COMMON;

warning:
     entry (status, op, switch, message);

	flags = ACTION_DEFAULT_RESTART;
COMMON:
	cei.copy_options_ptr = copy_options_ptr;
	cei.operation = op;
	cei.target_err_switch = switch;

	call sub_err_ (status, "copy_", flags, addr (cei), (0), message, pathname_ (source_dir, source_name),
	     pathname_ (target_dir, target_name));

	return;
     end error;
%page;
/**** This procedure may call an fs_util_ entry for an MSF with

      a segment for an operand. This is okay, since a segment
      will be corrcectly trreated as an SSF MSF. */

ensure_access:
     procedure;

	declare code		        fixed bin (35);
	declare get_user_access_modes_entry   entry (char (*), char (*), char (*), fixed bin, bit (36) aligned,
				        bit (36) aligned, fixed bin (35)) variable;
	declare list_acl_entry	        entry (char (*), char (*), char (*), pointer, pointer, fixed bin (35))
				        variable;

	call fs_util_$make_entry_for_type (source_type, FS_GET_USER_ACCESS_MODES, get_user_access_modes_entry, (0));

	call get_user_access_modes_entry (target_dir, target_name, "", -1, modes, ""b, code);
	if code ^= 0
	then call copy_error (code, "1"b);

	if (modes & RW_ACCESS) = RW_ACCESS
	then return;				/* Don't have to force access */

	call fs_util_$make_entry_for_type (source_type, FS_LIST_ACL, list_acl_entry, (0));
	call fs_util_$make_entry_for_type (source_type, FS_ADD_ACL_ENTRIES, add_acl_entries_entry, (0));
	call fs_util_$make_entry_for_type (source_type, FS_DELETE_ACL_ENTRIES, delete_acl_entries_entry, (0));


	one_acl.version = GENERAL_ACL_VERSION_1;
	one_acl.count = 1;
	one_acl.access_name = get_group_id_ ();
	one_acl.mode = RW_ACCESS;

	call list_acl_entry (target_dir, target_name, GENERAL_ACL_VERSION_1, null (), addr (one_acl), code);

	if code ^= 0
	then call copy_error (code, "1"b);
	saved_mode = one_acl.mode (1);
	delete_forced_acle = (one_acl.entries (1).status_code = error_table_$user_not_found);
						/* If there were no entry for user, delete the forced one
						   when we're done;else put the old one back */
	forced_access = "1"b;

	one_acl.mode (1) = one_acl.mode (1) | RW_ACCESS;

	call add_acl_entries_entry (target_dir, target_name, addr (one_acl), code);
	if code ^= 0
	then call copy_error (code, "1"b);

	return;

delete_access:
     entry;

	if ^forced_access				/* just in case the caller didn't check */
	then return;

	one_acl.mode (1) = saved_mode;
	if delete_forced_acle
	then do;
		one_del_acl = one_acl, by name;
		one_del_acl.version = GENERAL_DELETE_ACL_VERSION_1;
		call delete_acl_entries_entry (target_dir, target_name, addr (one_del_acl), (0));
	     end;
	else call add_acl_entries_entry (target_dir, target_name, addr (one_acl), (0));
	return;
     end ensure_access;

cleanup_copy:
     procedure;

	if forced_access
	then call delete_access ();			/* in case we forced it earlier */

	if ^msf					/* MSF pointers are terminated by msf_manager_$close */
	then if old_seg_ptr ^= null ()
	     then call hcs_$terminate_noname (old_seg_ptr, (0));

	if ^target_msf
	then if new_seg_ptr ^= null ()
	     then call hcs_$terminate_noname (new_seg_ptr, (0));


	if fcb_ptr ^= null ()
	then call msf_manager_$close (fcb_ptr);
	if new_fcb_ptr ^= null ()
	then call msf_manager_$close (new_fcb_ptr);

	return;
     end cleanup_copy;

     end fs_copy_util_;




		    fs_get_type_.pl1                03/05/85  1701.6r w 03/05/85  1053.4       85572



/* **************************************************************
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1983 *
   *                                                            *
   * Copyright, (C) Honeywell Information Systems Inc., 1983    *
   *                                                            *
   ************************************************************** */


/* fs_get_type_ -- for extended object support, determines type of object */
/* BIM 830921 */
/* format: style2,indcomtxt,idind30 */

     /*** * Modified 831022 BIM to return a link type instead of error_table_$link */
     /*** * Modified 831025 BIM to not chase links for delentry and chname.
	Those entries call the $no_chase entrypoint here, as should
	anything else that works on links. */
     /*** * Modified 840112 MAP for better member algorithm */
     /*** * Modified 840206 MAP to classify DM files when access to containing
	dir is null. */

fs_get_type_:
     procedure (Dir_name, Entryname, Type, Code);

	declare (Dir_name, Entryname, Type)   char (*) parameter;
	declare Code		        fixed bin (35) parameter;

	declare suffix		        char (32) aligned;
	declare (after, before, reverse)      builtin;

/****
      First, check to see if the suffix is that of a reserved
      "straight segment" or "straight directory".

      Then, try to find a suffix_XXX_$suffix_info for the suffix,
      if any.

      Then, validate that.

      If it misses, classify as seg, dir, MSF, or DM file. */

	declare reserved_for_segments	        (60) char (32) aligned int static options (constant) init (
						/** */
				        "absin",	/** */
				        "algol68",	/** */
				        "alm",	/** */
				        "apl",	/** */
				        "archive",	/** */
				        "basic",	/** */
				        "bcpl",	/** */
				        "bind",	/** */
				        "breaks",	/** */
				        "cds",	/** */
				        "cdt",	/** */
				        "chars",	/** */
				        "cmdb",	/** */
				        "cmdsm",	/** */
				        "cmf",	/** */
				        "cobol",	/** */
				        "code",	/** */
				        "dir_info", /** */
				        "dsm",	/** */
				        "ec",	/** */
				        "fdocin",	/** */
				        "fdocout",	/** */
				        "fortran",	/** */
				        "gcos",	/** */
				        "gct",	/** */
				        "gdt",	/** */
				        "graphics", /** */
				        "info",	/** */
				        "linus",	/** */
				        "lister",	/** */
				        "listform", /** */
				        "listin",	/** */
				        "mail",	/** */
				        "map355",	/** */
				        "memo",	/** */
				        "pascal",	/** */
				        "pdt",	/** */
				        "pfd",	/** */
				        "pfl",	/** */
				        "pl1",	/** */
				        "pmf",	/** */
				        "probe",	/** */
				        "profile",	/** */
				        "qedx",	/** */
				        "rd",	/** */
				        "rdmec",	/** */
				        "rtdt",	/** */
				        "rtmf",	/** */
				        "runoff",	/** */
				        "runout",	/** */
				        "sat",	/** */
				        "sdmec",	/** */
				        "smf",	/** */
				        "symbols",	/** */
				        "table",	/** */
				        "ttf",	/** */
				        "ttt",	/** */
				        "value",	/** */
				        "volumes",	/** */
				        "wl"	/** */
				        );

	declare reserved_for_segments_and_msfs
				        (3) char (32) aligned int static options (constant) init (
						/** */
				        "absout",	/** */
				        "compout",	/** */
				        "list"	/** */
				        );

	declare reserved_for_msfs	        (1) char (32) aligned int static options (constant) init (
						/** */
				        "dict"	/** */
				        );

	declare reserved_for_directories      (1) char (32) int aligned static options (constant) init (
						/** */
				        "db"	/** */
				        );

	declare file_manager_$validate        entry (char (*), char (*), fixed bin (35));
	declare hcs_$status_minf	        entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				        fixed bin (35));
	declare status_minf_type	        fixed bin (2);
	declare status_minf_bc	        fixed bin (24);



	go to ENTRY_COMMON;

no_chase:
     entry (Dir_name, Entryname, Type, Code);

	call hcs_$status_minf (Dir_name, Entryname, (0), status_minf_type, (0), Code);
	if Code ^= 0
	then return;				/* nothing else to say */
	if status_minf_type = 0			/** Link */
	then do;					/* otherwise, fall through to ordinary stuff */
		Type = FS_OBJECT_TYPE_LINK;
		Code = 0;
		return;
	     end;


ENTRY_COMMON:
	if index (Entryname, ".") > 0
	then suffix = reverse (before (reverse (Entryname), "."));
	else suffix = "";
	Code = 0;

	if suffix = ""
	then call CLASSIFY_STANDARD_OBJECT;
	else if member (suffix, reserved_for_segments)
	then call CLASSIFY_AS_SEGMENT;
	else if member (suffix, reserved_for_segments_and_msfs)
	then call CLASSIFY_AS_SEGMENT_OR_MSF;
	else if member (suffix, reserved_for_msfs)
	then call CLASSIFY_AS_MSF;
	else if member (suffix, reserved_for_directories)
	then call CLASSIFY_AS_DIRECTORY;
	else call CLASSIFY_HARD;

	return;

%page;

CLASSIFY_STANDARD_OBJECT:
     procedure;
	declare error_table_$noentry	        fixed bin (35) ext static;
	declare error_table_$incorrect_access fixed bin (35) ext static;
	declare error_table_$no_info	        fixed bin (35) ext static;
	declare t_code		        fixed bin (35);

	call hcs_$status_minf (Dir_name, Entryname, (1 /* chase */), status_minf_type, status_minf_bc, Code);

	if Code = error_table_$noentry
	then do;	/*** legitimize null links by turning off the chase switch */
		call hcs_$status_minf (Dir_name, Entryname, (0 /* no chase */), status_minf_type, status_minf_bc,
		     t_code);
		if t_code = 0
		then Code = 0;
	     end;

	if Code = error_table_$incorrect_access | Code = error_table_$no_info
	then do;

/**** This do group will be executed if the parent of an inner ring file
      had null access for the caller; however, the inner ring file could
      be a DM file and the caller could have access to it.  Only file_manager_
      knows for sure... */

		call file_manager_$validate (Dir_name, Entryname, t_code);
		if t_code = 0
		then do;
			Type = FS_OBJECT_TYPE_DM_FILE;
			Code = 0;
			return;
		     end;
	     end;

	if Code ^= 0
	then return;				/* too bad */

	if status_minf_type = 0			/* null link. */
	then do;
		Type = FS_OBJECT_TYPE_LINK;
		return;
	     end;

/**** Segment or Dir/MSF */

	if status_minf_type = 1			/* seg */
	then do;
		Type = FS_OBJECT_TYPE_SEGMENT;
		return;
	     end;

/**** Dir or msf */

	if status_minf_bc = 0
	then do;
		Type = FS_OBJECT_TYPE_DIRECTORY;
		return;
	     end;

	call file_manager_$validate (Dir_name, Entryname, Code);
	if Code = 0
	then Type = FS_OBJECT_TYPE_DM_FILE;
	else do;
		Type = FS_OBJECT_TYPE_MSF;
		Code = 0;
	     end;
	return;

     end CLASSIFY_STANDARD_OBJECT;

%page;

CLASSIFY_AS_SEGMENT:
     procedure;

/**** This one has a suffix that should only be found on a segment.
      If we were strict constructionists, we would only allow segments.
      But we aren't, yet. */

/**** Ditto for all of these. */

CLASSIFY_AS_SEGMENT_OR_MSF:
CLASSIFY_AS_DIRECTORY:
CLASSIFY_AS_MSF:
     entry;

	call CLASSIFY_STANDARD_OBJECT;
	return;
     end CLASSIFY_AS_SEGMENT;

CLASSIFY_HARD:
     procedure;

/**** Here for something with a suffix that was not filtered out.
      We have no choice but to make_entry. */

	declare hcs_$make_entry	        entry (ptr, char (*), char (*), entry, fixed bin (35));
	declare si_entry_to_call	        entry (ptr) variable;
	declare validate_entry_to_call        entry (char (*), char (*), fixed bin (35)) variable;
	declare code		        fixed bin (35);
	declare 1 si		        aligned like suffix_info;
	declare reference_name	        char (32);

	reference_name = "suffix_" || rtrim (suffix) || "_";
	call hcs_$make_entry (codeptr (fs_get_type_), reference_name, "suffix_info", si_entry_to_call, code);

	if code ^= 0
	then do;
		call CLASSIFY_STANDARD_OBJECT;	/* nobody home */
		return;
	     end;

	call hcs_$make_entry (codeptr (si_entry_to_call), reference_name, "validate", validate_entry_to_call, code);
	if code = 0
	then do;
		call validate_entry_to_call (Dir_name, Entryname, code);
		if code ^= 0
		then do;
			call CLASSIFY_STANDARD_OBJECT;
			return;
		     end;
	     end;


/**** We found a suffix_info! */

	si.version = SUFFIX_INFO_VERSION_1;
	call si_entry_to_call (addr (si));
	Type = si.type;
	return;
     end CLASSIFY_HARD;

%page;

member:
     procedure (a_is_this_in, a_list) returns (bit (1) aligned);

	declare a_is_this_in	        char (32) aligned;
	declare a_list		        (*) char (32) aligned;
	declare hx		        fixed bin unsigned;
	declare is_this_in		        char (32) aligned;
	declare lx		        fixed bin unsigned;
	declare mx		        fixed bin unsigned;
	declare list_size		        fixed bin;
	declare listp		        ptr;
	declare list		        (list_size) char (32) aligned based (listp);
	declare hbound		        builtin;

	list_size = dim (a_list, 1);
	listp = addr (a_list);
	is_this_in = a_is_this_in;

	lx = lbound (list, 1);
	hx = hbound (list, 1);
	do while (lx <= hx);
	     mx = divide (lx + hx, 2, 17, 0);
	     if is_this_in = list (mx)
	     then return ("1"b);
	     else if is_this_in < list (mx)
		then hx = mx - 1;
		else lx = mx + 1;
	end;
	return ("0"b);

     end member;

%page;%include suffix_info;
%page;%include copy_flags;
     end fs_get_type_;




		    fs_msf_rb_util_.pl1             04/09/85  1700.4r w 04/08/85  1128.5       38709



/* **************************************************************
   *                                                            *
   * Copyright, (C) Honeywell Information Systems Inc., 1983    *
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1983 *
   *                                                            *
   ************************************************************** */

/* fs_msf_rb_util_.pl1 -- set and get ring brackets for MSF's */
/* format: style2,idind30,indcomtxt */
/* BIM 831022 */

fs_msf_rb_util_:
     procedure;

	declare (Dir_name, Entryname)	        character (*);
	declare Brackets		        (*) fixed bin (3);
	declare Code		        fixed bin (35);

%include access_mode_values;
%include star_structures;

	declare get_system_free_area_	        entry returns (pointer);
	declare hcs_$star_		        entry (character (*), character (*), fixed bin (2), pointer, fixed bin,
				        pointer, pointer, fixed bin (35));
	declare pathname_		        entry (character (*), character (*)) returns (character (168));
	declare fs_standard_object_$set_segment_ring_brackets
				        entry (character (*), character (*), (*) fixed bin (3), fixed bin (35));
	declare fs_standard_object_$set_directory_ring_brackets
				        entry (character (*), character (*), (*) fixed bin (3), fixed bin (35));
	declare fs_standard_object_$get_directory_ring_brackets
				        entry (character (*), character (*), (*) fixed bin (3), fixed bin (35));
	declare hcs_$get_user_access_modes    entry (character (*), character (*), character (*), fixed bin,
				        bit (36) aligned, bit (36) aligned, fixed bin (35));

	declare error_table_$moderr	        external static fixed bin (35);

	declare segment_brackets	        (3) fixed bin (3);
	declare directory_brackets	        (2) fixed bin (3);
	declare bx		        fixed bin;
	declare code		        fixed bin (35);
	declare cleanup		        condition;
	declare dir_mode		        bit (36) aligned;
	declare msf_directory	        character (168);


set:
     entry (Dir_name, Entryname, Brackets, Code);

	Code = 0;
	msf_directory = pathname_ (Dir_name, Entryname);

/**** * This program has a basic design flaw. It is not capable of */
/**** * backing out if it encounters an error partway through,
      since that would require us to remember all the original
      ring brackets of the original MSF. To make things reasonable,
      it just ignores null links and dirs in the MSF dir,
      rather than reporting error_table_$inconsistent_msf.
      Failure to set the MSF dir brackets, though, is reported
      as an error. */


	call hcs_$get_user_access_modes (Dir_name, Entryname, "", -1, dir_mode, (""b), Code);
	if Code ^= 0
	then return;				/* Cant possibly have enough access */
	if (dir_mode & SM_ACCESS) = ""b
	then do;
		Code = error_table_$moderr;
		return;
	     end;
/**** * First to the dir, to get a lack of access to containing dir */

	directory_brackets (1) = Brackets (1);
	directory_brackets (2) = Brackets (2);
	call fs_standard_object_$set_directory_ring_brackets (Dir_name, Entryname, directory_brackets, Code);
	if Code ^= 0
	then return;
	star_names_ptr, star_entry_ptr = null ();
	on cleanup
	     begin;
		if star_names_ptr ^= null ()
		then free star_names;
		if star_entry_ptr ^= null ()
		then free star_entries;
		star_names_ptr, star_entry_ptr = null ();
	     end;

	call hcs_$star_ (msf_directory, "**", star_BRANCHES_ONLY, get_system_free_area_ (), star_entry_count,
	     star_entry_ptr, star_names_ptr, Code);

	if Code ^= 0
	then return;				/* We must lack access, neh? */

	segment_brackets (1) = Brackets (1);
	segment_brackets (2), segment_brackets (3) = Brackets (2);
	do bx = 1 to star_entry_count;
	     if star_entries (bx).type = star_SEGMENT
	     then do;
		     call fs_standard_object_$set_segment_ring_brackets (msf_directory,
			star_names (star_entries (bx).nindex), segment_brackets, code);
		     if Code = 0
		     then Code = code;
		end;
	end;

	free star_names;
	free star_entries;
	return;


get:
     entry (Dir_name, Entryname, Brackets, Code);

	Code = 0;
	call fs_standard_object_$get_directory_ring_brackets (Dir_name, Entryname, Brackets, Code);
	return;
     end fs_msf_rb_util_;




		    fs_standard_object_.pl1.pmac    10/17/90  0822.8rew 10/17/90  0819.3      311994



/****^  **************************************************************
        *                                                            *
        * Copyright, (C) BULL HN Information Systems Inc., 1990      *
        *                                                            *
        * Copyright, (C) Honeywell Bull Inc., 1988                   *
        *                                                            *
        * Copyright, (C) Honeywell Information Systems Inc., 1983    *
        *                                                            *
        * Copyright, (C) Massachusetts Institute of Technology, 1983 *
        *                                                            *
        ************************************************************** */




/****^  HISTORY COMMENTS:
  1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
     audit(86-11-06,GDixon), install(86-11-20,MR12.0-1222):
     Modified to allow setting "e" access on multisegment files.
  2) change(86-08-05,Houck), approve(86-08-11,MCR7501), audit(86-08-15,Wong),
     install(86-08-29,MR12.0-1140):
     Changed program so that a copy switch can be set for a directory.
  3) change(88-05-05,Lippard), approve(88-05-02,MCR7881),
     audit(88-06-16,Fawcett), install(88-08-02,MR12.2-1074):
     Added audit_switch.
  4) change(90-09-20,Bubric), approve(90-10-01,MCR8211), audit(90-10-01,Itani),
     install(90-10-17,MR12.4-1044):
     Have the calls to the routine 'nothing' changed to calls to the routine
     'null_entry_'.
                                                   END HISTORY COMMENTS */


/* format: style2,indcomtxt */
/* BIM 820921 */
/****
      fs_standard_object_ -- entrypoints that the extended object code can return
      to do work on segments, directories, MSF's and dm_files. Sometimes, hcs_
      suffices. Other times, fs_acl_util_ is the ticket. */

/**** make_entry has the knowledge of what entries belong to what.
      since fs_util_$make_entry makes no expensive calls to hcs_$make_entry,
      object_type_/file_system_ (whatever its name turns out to be)
      can call it all the time once it determines that some object
      is a standard object. */

/**** * Modified 831022 BIM for FS_OBJECT_TYPE_LINK */
/**** * Modified 840229 MAP to make these types standard with no extended ACL except for segs */
/**** * Modified 841107 MAP to fix list_switch entrypoints */
/**** * Modified 841129 Pierret to always return an entry for dm_files */
/**** * Modified 850114 Pierret to return file_manager_$list_switches  */
/**** * Modified 850206 MSharpe to use (ncvd nivd) < 0 instead of = 0  for determining the state of the swtiches. */
/**** * Modified 850226 MSharpe to report inconsistent msf if MSF>0 is not found */

fs_standard_object_:
     procedure;

make_entry:
     entry (Type, Operation, Code) returns (entry);

	declare Type		 fixed bin;	/* index into FS_STANDARD_TYPES in file_system_operations_.incl.pl1 */
	declare Operation		 fixed bin;	/* index into FS_OPERATIONS in file_system_operations_.incl.pl1 */
	declare Code		 fixed bin (35) parameter;

	declare make_entry_jumpx	 fixed bin;



/**** Assume that the two fixed bins are within their respective bounds.
      Now, wish that we had 2 dimensional label arrays! */

	make_entry_jumpx = ((Operation - 1) * HIGHEST_FS_STANDARD_TYPE_INDEX) + Type;
						/* index goes through types rapidly, operations slowly */

	Code = 0;
	go to MAKE_ENTRY_LABEL (make_entry_jumpx);	/* cant just have an array of entry constants that is any use at all */


/**** *
      NOTE NOTE
      These entries must be in the same order as the array of names
      in file_system_operation_.incl.pl1! */


	%set OPx to 1;

/**** ADD_ACL_ENTRIES */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	return (fs_acl_util_$add_directory);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$add_acl_entries);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (fs_acl_util_$add_msf);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (fs_acl_util_$add_segment);

/**** ADD_EXTENDED_ACL_ENTRIES */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$add_extended_acl_entries);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (fs_acl_util_$add_msf_extended);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (fs_acl_util_$add_segment_extended);

/**** CHNAME_FILE */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	return (hcs_$chname_file);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$chname_file);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	return (hcs_$chname_file);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (hcs_$chname_file);			/* happens to work! */
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (hcs_$chname_file);

/**** COPY */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$copy);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (fs_copy_util_$msf);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (fs_copy_util_$segment);

/**** DELENTRY_FILE  -- this is a primitive interface for delete_ */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;	/* use delete_ */
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$delentry_file);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	return (hcs_$delentry_file);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (hcs_$delentry_file);

/**** DELETE_ACL_ENTRIES */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	return (fs_acl_util_$delete_directory);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$delete_acl_entries);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (fs_acl_util_$delete_msf);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (fs_acl_util_$delete_segment);

/**** * GET_BIT_COUNT */

MAKE_ENTRY_LABEL (OPx):				/** dir */
	%set OPx to OPx + 1;
	return (get_bc_seg_or_dir);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$get_bit_count);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (get_bc_seg_or_dir);
/**** GET_MAX_LENGTH_FILE */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$get_max_length);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (hcs_$get_max_length);

/**** GET_RING_BRACKETS */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	return (get_directory_ring_brackets);

MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$get_ring_brackets);

MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (fs_msf_rb_util_$get);

MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (get_segment_ring_brackets);


/**** GET_SWITCH */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	return (get_directory_switch);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$get_switch);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (get_msf_switch);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (get_segment_switch);


/**** GET_USER_ACCESS_MODES */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	return (hcs_$get_user_access_modes);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$get_user_access_modes);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (msf_get_user_access_modes);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (hcs_$get_user_access_modes);

/**** LIST_ACL */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	return (fs_acl_util_$list_directory);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$list_acl);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (fs_acl_util_$list_msf);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (fs_acl_util_$list_segment);

/**** LIST_EXTENDED_ACL */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$list_extended_acl);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (fs_acl_util_$list_msf_extended);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (fs_acl_util_$list_segment_extended);

/**** LIST_SWITCHES */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	return (list_directory_switches);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$list_switches);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (list_msf_switches);
MAKE_ENTRY_LABEL (OPx):				/** segments */
	%set OPx to OPx + 1;
	return (list_segment_switches);

/**** REPLACE_ACL */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	return (fs_acl_util_$replace_directory);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$replace_acl);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (fs_acl_util_$replace_msf);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (fs_acl_util_$replace_segment);

/**** REPLACE_EXTENDED_ACL */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$replace_extended_acl);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (fs_acl_util_$replace_msf_extended);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (fs_acl_util_$replace_segment_extended);

/**** SET_BIT_COUNT */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	return (hcs_$set_bc);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$set_bit_count);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (hcs_$set_bc);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (hcs_$set_bc);

/**** SET_MAX_LENGTH */

MAKE_ENTRY_LABEL (OPx):				/* directory */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$set_max_length);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (hcs_$set_max_length);

/**** SET_RING_BRACKETS */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	return (set_directory_ring_brackets);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$set_ring_brackets);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (fs_msf_rb_util_$set);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (set_segment_ring_brackets);

/**** SET_SWITCH */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	return (set_directory_switch);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$set_switch);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (set_msf_switch);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (set_segment_switch);

/**** SUFFIX_INFO */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	return (directory_suffix_info);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (file_manager_$suffix_info);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	Code = error_table_$unsupported_operation;
	return (null_entry_);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (msf_suffix_info);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (segment_suffix_info);


/**** VALIDATE */

MAKE_ENTRY_LABEL (OPx):				/** directory */
	%set OPx to OPx + 1;
	return (directory_validate);
MAKE_ENTRY_LABEL (OPx):				/** dm_file */
	%set OPx to OPx + 1;
	return (dm_file_validate);
MAKE_ENTRY_LABEL (OPx):				/** link */
	%set OPx to OPx + 1;
	return (link_validate);
MAKE_ENTRY_LABEL (OPx):				/** msf */
	%set OPx to OPx + 1;
	return (msf_validate);
MAKE_ENTRY_LABEL (OPx):				/** segment */
	%set OPx to OPx + 1;
	return (segment_validate);


/****
      What follows here are the entrypoints that translate from
      hcs_ to the standard object_type_ interfaces for things except for acls. */

get_directory_ring_brackets:
     entry (Dir_name, Entryname, Rings, Code);

	declare Rings		 (*) fixed bin (3);
	Rings = 0;
	begin;
	     declare dir_rings	      (2) fixed bin (3) based (addr (Rings));
	     declare hcs_$get_dir_ring_brackets
				      entry (char (*), char (*), (2) fixed bin (3), fixed bin (35));
	     call hcs_$get_dir_ring_brackets (Dir_name, Entryname, dir_rings, Code);
	end;
	return;


get_segment_ring_brackets:
     entry (Dir_name, Entryname, Rings, Code);

	declare Dir_name		 char (*) parameter;
	declare Entryname		 char (*) parameter;

	begin;
	     declare seg_rings	      (3) fixed bin (3) based (addr (Rings));
	     declare hcs_$get_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35));

	     call hcs_$get_ring_brackets (Dir_name, Entryname, seg_rings, Code);
	end;
	return;


get_directory_switch:
     entry (Dir_name, Entryname, Switch_name, Switch_value, Code);

	declare Switch_name		 char (*) parameter;
	declare Switch_value	 bit (1) aligned;
	declare switch_name		 char (100);
	declare switch_value	 bit (1);

	switch_name = Switch_name;

	Code = 0;
	call GET_DIR_SWITCH;

	return;

get_segment_switch:
     entry (Dir_name, Entryname, Switch_name, Switch_value, Code);

	Code = 0;
	switch_name = Switch_name;
	call GET_SEG_SWITCH;
	return;

set_directory_switch:
     entry (Dir_name, Entryname, Switch_name, Switch_value, Code);

	switch_name = Switch_name;
	Code = 0;

	call SET_DIR_SWITCH;
	return;

set_segment_switch:
     entry (Dir_name, Entryname, Switch_name, Switch_value, Code);

	switch_name = Switch_name;
	Code = 0;

	call SET_SEG_SWITCH;
	return;

set_msf_switch:
     entry (Dir_name, Entryname, Switch_name, Switch_value, Code);

	switch_name = Switch_name;
	Code = 0;

	call SET_MSF_SWITCH;
	return;

get_msf_switch:
     entry (Dir_name, Entryname, Switch_name, Switch_value, Code);

	switch_name = Switch_name;
	Code = 0;

	call GET_MSF_SWITCH;
	return;



GET_DIR_SWITCH:
     procedure;

	declare type		 fixed bin;
	declare hcs_type		 fixed bin (2);
	declare (
	        SEG		 init (1),
	        DIR		 init (2),
	        MSF		 init (3)
	        )			 fixed bin int static options (constant);
	declare 1 sfb		 aligned like status_for_backup;
	declare 1 sb		 aligned like status_branch;
	declare (nivd, ncvd)	 fixed bin;

	type = DIR;
	go to Join;

GET_SEG_SWITCH:
     entry;

	type = SEG;
	go to Join;

GET_MSF_SWITCH:
     entry;

	type = MSF;

Join:
	if switch_name = "safety"
	then do;
		call hcs_$get_safety_sw (Dir_name, Entryname, switch_value, Code);
		Switch_value = switch_value;
	     end;

	else if switch_name = "audit"
	then do;
		sfb.version = status_for_backup_version_2;
		call hcs_$status_for_backup (Dir_name, Entryname, addr (sfb), Code);
		if Code = 0
		then Switch_value = sfb.audit_flag;
	     end;

	else if switch_name = "complete_volume_dump" | switch_name = "incremental_volume_dump"
	then do;
		if type = MSF
		then do;
			call hcs_$get_volume_dump_switches (pathname_ (Dir_name, Entryname), "0", nivd, ncvd, Code);
			if Code = error_table_$noentry
			then Code = error_table_$inconsistent_msf;
		     end;
		else call hcs_$get_volume_dump_switches (Dir_name, Entryname, nivd, ncvd, Code);
		if Code = 0
		then do;
			if switch_name = "complete_volume_dump"
			then Switch_value = (ncvd < 0);
						/* on if no_complete_vd is off */
			else Switch_value = (nivd < 0);
		     end;
	     end;

	else if ((type = SEG) & (switch_name = "copy" | switch_name = "synchronized")) | switch_name = "damaged"
	then do;
		call hcs_$status_long (Dir_name, Entryname, 1, addr (sb), null (), Code);
		if Code = 0
		then do;
			if switch_name = "copy"
			then Switch_value = sb.copy_switch;
			else if switch_name = "damaged"
			then Switch_value = sb.damaged_switch;
			else Switch_value = sb.synchronized_switch;
		     end;
	     end;
	else Code = error_table_$argerr;		/* We don't know this one. */

	return;

SET_DIR_SWITCH:
     entry;

	type = DIR;
	go to Join_set;

SET_SEG_SWITCH:
     entry;

	type = SEG;
	go to Join_set;

SET_MSF_SWITCH:
     entry;

	call hcs_$status_minf (Dir_name, Entryname, (1), hcs_type, (0), Code);
	if Code ^= 0
	then return;
	if hcs_type = 2
	/*** Dir */
	then type = MSF;
	else type = SEG;
	/*** treat SSF MSF as Segment */

Join_set:
	if switch_name = "safety"
	then call hcs_$set_safety_sw (Dir_name, Entryname, (Switch_value), Code);

	else if switch_name = "complete_volume_dump" & (type = MSF)
	then ;					/* do not try to set the switch on the MSF dir, but set it on the components */
	else if switch_name = "complete_volume_dump"
	then do;	/*** Note that the volume dumper entrypoint works like this:
		     a value of zero means, "don't change switch."
		     A value of 1 means "Set the switch," and a value of -1 means
		     "reset the switch." However, we are translating from a switch named
		     complete_volume_dump to no_complete_volume_dump, so we reverse the
		     values from the Switch_value to the flags. */
		if Switch_value
		then ncvd = -1;
		else ncvd = 1;
		call hcs_$set_volume_dump_switches (Dir_name, Entryname, 0, ncvd, Code);
	     end;
	else if switch_name = "incremental_volume_dump" & (type = MSF)
	then ;					/* ditto */
	else if switch_name = "incremental_volume_dump"
	then do;
		nivd, ncvd = 0;
		if Switch_value
		then nivd = -1;
		else nivd = 1;
		call hcs_$set_volume_dump_switches (Dir_name, Entryname, nivd, 0, Code);
	     end;

	else if switch_name = "copy" & (type = SEG | type = DIR)
	then call hcs_$set_copysw (Dir_name, Entryname, fixed (Switch_value, 1), Code);
	else if switch_name = "damaged"
	then call hcs_$set_damaged_sw (Dir_name, Entryname, (Switch_value), Code);
	else if switch_name = "synchronized" & (type = SEG)
	then call hcs_$set_synchronized_sw (Dir_name, Entryname, (Switch_value), Code);

	else Code = error_table_$argerr;		/* We don't know this one. */

	if type = MSF & Code = 0
	then call MAP_OVER_MSF_COMPONENTS (pathname_ (Dir_name, Entryname), switch_name, Switch_value, Code);
	return;


MAP_OVER_MSF_COMPONENTS:
     procedure (dir_name, switch_name, switch_value, code);

	declare dir_name		 char (*);
	declare switch_name		 char (*);
	declare switch_value	 bit (1) aligned;
	declare code		 fixed bin (35);
	declare entry_index		 fixed bin;
	declare get_system_free_area_	 entry () returns (ptr);
	declare hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr,
				 fixed bin (35));

	declare cleanup		 condition;
%include star_structures;

	star_entry_ptr, star_names_ptr = null ();
	on cleanup
	     begin;
		if star_names_ptr ^= null ()
		then do;
			free star_names;
			star_names_ptr = null ();
		     end;
		if star_entry_ptr ^= null ()
		then do;
			free star_entries;
			star_entry_ptr = null ();
		     end;
	     end;

	call hcs_$star_ (dir_name, "**", star_BRANCHES_ONLY, get_system_free_area_ (), star_entry_count, star_entry_ptr,
	     star_names_ptr, code);
	if code ^= 0
	then return;

	do entry_index = 1 to star_entry_count;
	     if star_entries (entry_index).type = star_SEGMENT
	     then call set_segment_switch (dir_name, star_names (star_entries (entry_index).nindex), switch_name,
		     switch_value, (0));		/* ignore errors */
						/* recurse ! */
	end;
	free star_names;
	free star_entries;
	return;
     end MAP_OVER_MSF_COMPONENTS;
     end GET_DIR_SWITCH;



list_directory_switches:
     entry (Desired_version, Area_ptr, Switch_list_ptr, Code);

	declare (Area_ptr, Switch_list_ptr)
				 pointer parameter;
	declare Desired_version	 char (*);
	declare area_ptr		 pointer;
	declare user_area		 area based (area_ptr);
	declare switch_list_type	 fixed bin;
	declare (
	        SEG		 init (1),
	        DIR		 init (2),
	        MSF		 init (3)
	        )			 fixed bin int static options (constant);

	switch_list_type = DIR;
	go to SWITCH_LIST_JOIN;

list_segment_switches:
     entry (Desired_version, Area_ptr, Switch_list_ptr, Code);

	switch_list_type = SEG;
	go to SWITCH_LIST_JOIN;

list_msf_switches:
     entry (Desired_version, Area_ptr, Switch_list_ptr, Code);

	switch_list_type = MSF;

SWITCH_LIST_JOIN:
	area_ptr = Area_ptr;
	if Desired_version ^= SWITCH_LIST_VERSION_1
	then do;
		Code = error_table_$unimplemented_version;
		return;
	     end;

	if (switch_list_type = DIR) | (switch_list_type = MSF)
	then do;
		alloc_switch_count = 4;
		alloc_switch_name_count = 6;
	     end;
	else do;
		alloc_switch_count = 6;
		alloc_switch_name_count = 8;
	     end;

	allocate switch_list in (user_area);

	switch_list.version = SWITCH_LIST_VERSION_1;
	switch_list.switches (1).name_index = 1;
	switch_list.switches (1).name_count = 1;
	switch_list.switches (1).default_value = "0"b;

	switch_list.switches (2).name_index = 2;
	switch_list.switches (2).name_count = 1;
	switch_list.switches (2).default_value = "0"b;

	switch_list.switches (3).name_index = 3;
	switch_list.switches (3).name_count = 2;
	switch_list.switches (3).default_value = "0"b;

	switch_list.switches (4).name_index = 5;
	switch_list.switches (4).name_count = 2;
	switch_list.switches (4).default_value = "0"b;

	if switch_list_type = SEG
	then do;
		switch_list.switches (5).name_index = 7;
		switch_list.switches (5).name_count = 1;
		switch_list.switches (5).default_value = "0"b;

		switch_list.switches (6).name_index = 8;
		switch_list.switches (6).name_count = 1;
		switch_list.switches (6).default_value = "0"b;
	     end;

	switch_list.names (1) = "damaged";
	switch_list.names (2) = "safety";
	switch_list.names (3) = "complete_volume_dump";
	switch_list.names (4) = "cvd";
	switch_list.names (5) = "incremental_volume_dump";
	switch_list.names (6) = "ivd";
	if switch_list_type = SEG
	then do;
		switch_list.names (7) = "copy";
		switch_list.names (8) = "synchronized";
	     end;

	Switch_list_ptr = switch_list_ptr;
	return;




set_directory_ring_brackets:
     entry (Dir_name, Entryname, Rings, Code);

	begin;
	     declare dir_rings	      (2) fixed bin (3) based (addr (Rings));
	     declare hcs_$set_dir_ring_brackets
				      entry (char (*), char (*), (2) fixed bin (3), fixed bin (35));
	     call hcs_$set_dir_ring_brackets (Dir_name, Entryname, dir_rings, Code);
	end;
	return;

set_segment_ring_brackets:
     entry (Dir_name, Entryname, Rings, Code);

	begin;
	     declare seg_rings	      (3) fixed bin (3) based (addr (Rings));
	     declare hcs_$set_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35));

	     call hcs_$set_ring_brackets (Dir_name, Entryname, seg_rings, Code);
	end;
	return;


directory_suffix_info:
     entry (Suffix_info_ptr);

	declare Suffix_info_ptr	 pointer;

	suffix_info_ptr = Suffix_info_ptr;
	suffix_info.type = FS_OBJECT_TYPE_DIRECTORY;
	suffix_info.type_name = "directory";
	suffix_info.plural_name = "directories";
	suffix_info.flags = "0"b;
	suffix_info.standard_object = "1"b;
	suffix_info.has_switches = "1"b;
	suffix_info.modes = "sma";
	suffix_info.copy_flags = "0"b;
	suffix_info.copy_flags.names, suffix_info.copy_flags.acl, suffix_info.copy_flags.safety_switch,
	     suffix_info.copy_flags.dumper_switches = "1"b;
	suffix_info.max_mode_len = 3;
	suffix_info.num_ring_brackets = 2;
	suffix_info.info_pathname = "";		/* for now, at least */
	return;

msf_suffix_info:
     entry (Suffix_info_ptr);

	suffix_info_ptr = Suffix_info_ptr;

	suffix_info.type = FS_OBJECT_TYPE_MSF;
	suffix_info.type_name = "multi-segment file";
	suffix_info.plural_name = "multi-segment files";
	suffix_info.flags = "0"b;
	suffix_info.standard_object = "1"b;
	suffix_info.extended_acl = "1"b;
	suffix_info.modes = "rew";

	suffix_info.max_mode_len = 3;
	suffix_info.num_ring_brackets = 2;		/* who needs an msf gate? */
	suffix_info.copy_flags = "1"b;
	suffix_info.max_length, suffix_info.entry_bound, suffix_info.copy_switch, suffix_info.copy_flags.mbz = ""b;
	suffix_info.info_pathname = "";
	return;

segment_suffix_info:
     entry (Suffix_info_ptr);

	suffix_info_ptr = Suffix_info_ptr;
	suffix_info.type = FS_OBJECT_TYPE_SEGMENT;
	suffix_info.type_name = "segment";
	suffix_info.plural_name = "segments";
	suffix_info.flags = "0"b;
	suffix_info.standard_object = "1"b;
	suffix_info.has_switches = "1"b;
	suffix_info.extended_acl = "1"b;
	suffix_info.modes = "rew";
	suffix_info.copy_flags = "1"b;
	suffix_info.copy_flags.mbz = "0"b;
	suffix_info.max_mode_len = 3;
	suffix_info.num_ring_brackets = 3;
	suffix_info.info_pathname = "";		/* for now, at least */
	return;



directory_validate:
     entry (Dir_name, Entryname, Code);
	declare type		 char (32);

	call fs_get_type_ (Dir_name, Entryname, type, Code);
	if Code ^= 0
	then return;
	if type ^= FS_OBJECT_TYPE_DIRECTORY
	then Code = error_table_$not_seg_type;
	return;

segment_validate:
     entry (Dir_name, Entryname, Code);

	call fs_get_type_ (Dir_name, Entryname, type, Code);
	if Code ^= 0
	then return;
	if type ^= FS_OBJECT_TYPE_SEGMENT
	then Code = error_table_$not_seg_type;
	return;

link_validate:
     entry (Dir_name, Entryname, Code);

	call fs_get_type_ (Dir_name, Entryname, type, Code);
	if Code ^= 0
	then return;
	if type ^= FS_OBJECT_TYPE_LINK
	then Code = error_table_$not_seg_type;
	return;

msf_validate:
     entry (Dir_name, Entryname, Code);

	call fs_get_type_ (Dir_name, Entryname, type, Code);
	if Code ^= 0
	then return;

	if type ^= FS_OBJECT_TYPE_MSF
	then Code = error_table_$not_seg_type;

	return;

dm_file_validate:
     entry (Dir_name, Entryname, Code);

	call fs_get_type_ (Dir_name, Entryname, type, Code);
	if Code ^= 0
	then return;

	if type ^= FS_OBJECT_TYPE_DM_FILE
	then Code = error_table_$not_seg_type;
	return;

msf_get_user_access_modes:
     entry (Dir_name, Entryname, Username, Ring, Modes, Exmodes, Code);

	declare Username		 char (*);
	declare Ring		 fixed bin (3);
	declare (Modes, Exmodes)	 bit (36) aligned;

	call hcs_$get_user_access_modes (pathname_ (Dir_name, Entryname), "0", Username, Ring, Modes, Exmodes, Code);

	if Code = error_table_$noentry
	then Code = error_table_$inconsistent_msf;
	else do;
	     if Code = error_table_$notadir		/* special-case SSF's */
	     then call hcs_$get_user_access_modes (Dir_name, Entryname, Username, Ring, Modes, Exmodes, Code);
	     if Code = error_table_$incorrect_access	/* null to the dir */
		then do;
		Modes, Exmodes = ""b;
		Code = 0;
		return;
		end;
	     end;

	return;


get_bc_seg_or_dir:
     entry (Dir_name, Entryname, Bit_count, Code);

	declare Bit_count		 fixed bin (24);

	call hcs_$status_minf (Dir_name, Entryname, (1), (0), Bit_count, Code);
	return;


%include suffix_info;
%include copy_flags;

	declare (
	        addr,
	        fixed,
	        null,
	        sum
	        )			 builtin;
	declare (
	        error_table_$argerr,
	        error_table_$unsupported_operation,
	        error_table_$notadir,
	        error_table_$not_seg_type,
	        error_table_$incorrect_access,
	        error_table_$noentry,
	        error_table_$inconsistent_msf,
	        error_table_$unimplemented_version
	        )			 fixed bin (35) external;

	declare null_entry_		 entry;

	declare hcs_$delentry_file	 entry external;

	declare (
                  file_manager_$add_acl_entries,
	        file_manager_$add_extended_acl_entries,
	        file_manager_$chname_file,
	        file_manager_$copy,
	        file_manager_$delentry_file,
	        file_manager_$delete_acl_entries,
	        file_manager_$get_bit_count,
	        file_manager_$get_max_length,
	        file_manager_$get_ring_brackets,
	        file_manager_$get_switch,
	        file_manager_$get_user_access_modes,
	        file_manager_$list_acl,
	        file_manager_$list_extended_acl,
	        file_manager_$replace_acl,
	        file_manager_$replace_extended_acl,
	        file_manager_$set_bit_count,
	        file_manager_$set_max_length,
	        file_manager_$set_ring_brackets,
	        file_manager_$set_switch,
	        file_manager_$suffix_info
	        )			 entry external;
	declare (
	        fs_msf_rb_util_$set,
	        fs_msf_rb_util_$get
	        )			 entry external;
	declare file_manager_$list_switches
				 entry (pointer, pointer);

	declare (
	        fs_acl_util_$add_segment,
	        fs_acl_util_$add_directory,
	        fs_acl_util_$add_msf,
	        fs_acl_util_$delete_segment,
	        fs_acl_util_$delete_directory,
	        fs_acl_util_$delete_msf,
	        fs_acl_util_$list_segment,
	        fs_acl_util_$list_directory,
	        fs_acl_util_$list_msf,
	        fs_acl_util_$replace_segment,
	        fs_acl_util_$replace_directory,
	        fs_acl_util_$replace_msf,
	        fs_acl_util_$list_segment_extended,
	        fs_acl_util_$add_segment_extended,
	        fs_acl_util_$replace_segment_extended,
	        fs_acl_util_$list_msf_extended,
	        fs_acl_util_$add_msf_extended,
	        fs_acl_util_$replace_msf_extended
	        )			 entry external;

	declare (
	        fs_copy_util_$msf,
	        fs_copy_util_$segment
	        )			 external entry;

	declare (
	        hcs_$chname_file,
	        hcs_$set_bc,
	        hcs_$set_max_length,
	        hcs_$get_max_length
	        )			 entry external;
	declare hcs_$get_user_access_modes
				 entry (char (*), char (*), char (*), fixed bin (3), bit (36) aligned,
				 bit (36) aligned, fixed bin (35));
	declare pathname_		 entry (char (*), char (*)) returns (char (168));

	declare fs_get_type_	 entry (char (*), char (*), char (*), fixed bin (35));
	declare hcs_$get_safety_sw	 entry (char (*), char (*), bit (1), fixed bin (35));
	declare hcs_$get_volume_dump_switches
				 entry (char (*), char (*), fixed bin, fixed bin, fixed bin (35));
	declare hcs_$set_safety_sw	 entry (char (*), char (*), bit (1), fixed bin (35));
	declare hcs_$set_volume_dump_switches
				 entry (char (*), char (*), fixed bin, fixed bin, fixed bin (35));
	declare hcs_$set_synchronized_sw
				 entry (char (*), char (*), bit (1), fixed bin (35));
	declare hcs_$set_copysw	 entry (char (*), char (*), fixed bin (1), fixed bin (35));
	declare hcs_$status_long	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	declare hcs_$set_damaged_sw	 entry (char (*), char (*), bit (1), fixed bin (35));
	declare hcs_$status_for_backup entry (char (*), char (*), ptr, fixed bin (35));
	declare hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),

				 fixed bin (35));
%include status_for_backup;
%include status_structures;
%include file_system_operations_;
     end fs_standard_object_;




		    fs_util_.pl1                    03/10/85  1722.2rew 03/08/85  0946.1      103176



/* **************************************************************
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1983 *
   *                                                            *
   * Copyright, (C) Honeywell Information Systems Inc., 1983    *
   *                                                            *
   ************************************************************** */

/* format: style2,indcomtxt,idind30 */


/**** fs_util_ -- outer set of interfaces for typed object support. */

fs_util_:
     procedure;

/****   Jay Pattin 1/26/83 */
/****   modified 1984.03.05 by M. Pandolf to fix get_bit_count parameter */
/****   modified 1984.03.12 by M. Pandolf to initialize P_status correctly */
/****   modified 1984.04.04 by M. Pandolf to fix GET_TYPE usage of parameters */

	declare P_acl_ptr		        ptr;
	declare P_area_ptr		        ptr;
	declare P_bit_count		        fixed bin (24);
	declare P_copy_options_ptr	        ptr;
	declare P_desired_version	        char (*);
	declare P_directory		        char (*);
	declare P_entryname		        char (*);
	declare P_entrypoint_name	        char (*);
	declare P_entry_to_call	        entry variable options (variable);
	declare P_max_length	        fixed bin (19);
	declare (P_modes, P_exmodes)	        bit (36) aligned;
	declare P_new_name		        char (*);
	declare P_no_sysdaemon	        bit (1);
	declare P_old_name		        char (*);
	declare P_ring		        fixed bin;
	declare P_ring_brackets	        (*) fixed bin (3);
	declare P_status		        fixed bin (35);
	declare P_suffix_info_ptr	        ptr;
	declare P_switch_list_ptr	        ptr;
	declare P_switch_name	        char (*);
	declare P_type		        char (*);
	declare P_user_name		        char (*);
	declare P_value		        bit (1) aligned;

	declare entry_to_call	        entry variable options (variable);
	declare idx		        fixed bin;
	declare type		        char (32);
	declare fixed_type		        fixed bin;
	declare arg_list_ptr	        pointer;
	declare user_area_ptr	        pointer;

	declare cleanup		        condition;

	declare cu_$arg_list_ptr	        entry () returns (ptr);
	declare cu_$generate_call	        entry (entry, ptr);
	declare sub_err_		        entry options (variable);

	declare get_user_free_area_	        entry returns (pointer);
	declare hcs_$make_entry	        entry (ptr, char (*), char (*), entry, fixed bin (35));
	declare pathname_		        entry (char (*), char (*)) returns (char (168));

	declare error_table_$null_info_ptr    fixed bin (35) ext static;
	declare error_table_$unsupported_operation
				        fixed bin (35) ext static;
	declare error_table_$unimplemented_version
				        fixed bin (35) ext static;


/**** * NOTE: operations that are defined to operate on links are
      special-cased, to avoid chasing the link. At this time,
      the only such operations are chname and delentry. */

chname_file:
     entry (P_directory, P_entryname, P_old_name, P_new_name, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO_NO_CHASE (FS_CHNAME_FILE);

delentry_file:
     entry (P_directory, P_entryname, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO_NO_CHASE (FS_DELENTRY_FILE);

copy:
     entry (P_copy_options_ptr, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO_DN_EN (FS_COPY, P_copy_options_ptr -> copy_options.source_dir,
	     P_copy_options_ptr -> copy_options.source_name);

get_max_length:
     entry (P_directory, P_entryname, P_max_length, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_GET_MAX_LENGTH);

set_max_length:
     entry (P_directory, P_entryname, P_max_length, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_SET_MAX_LENGTH);

get_bit_count:
     entry (P_directory, P_entryname, P_bit_count, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_GET_BIT_COUNT);

set_bit_count:
     entry (P_directory, P_entryname, P_bit_count, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_SET_BIT_COUNT);

get_user_access_modes:
     entry (P_directory, P_entryname, P_user_name, P_ring, P_modes, P_exmodes, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_GET_USER_ACCESS_MODES);


get_ring_brackets:
     entry (P_directory, P_entryname, P_ring_brackets, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_GET_RING_BRACKETS);


set_ring_brackets:
     entry (P_directory, P_entryname, P_ring_brackets, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_SET_RING_BRACKETS);

get_switch:
     entry (P_directory, P_entryname, P_switch_name, P_value, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_GET_SWITCH);

set_switch:
     entry (P_directory, P_entryname, P_switch_name, P_value, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_SET_SWITCH);


add_acl_entries:
     entry (P_directory, P_entryname, P_acl_ptr, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_ADD_ACL_ENTRIES);

add_extended_acl_entries:
     entry (P_directory, P_entryname, P_acl_ptr, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_ADD_EXTENDED_ACL_ENTRIES);

delete_acl_entries:
     entry (P_directory, P_entryname, P_acl_ptr, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_DELETE_ACL_ENTRIES);

list_acl:
     entry (P_directory, P_entryname, P_desired_version, P_area_ptr, P_acl_ptr, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_LIST_ACL);

list_extended_acl:
     entry (P_directory, P_entryname, P_desired_version, P_area_ptr, P_acl_ptr, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_LIST_EXTENDED_ACL);

replace_acl:
     entry (P_directory, P_entryname, P_acl_ptr, P_no_sysdaemon, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_REPLACE_ACL);

replace_extended_acl:
     entry (P_directory, P_entryname, P_acl_ptr, P_no_sysdaemon, P_status);

	arg_list_ptr = cu_$arg_list_ptr ();
	call GO (FS_REPLACE_EXTENDED_ACL);


suffix_info:
     entry (P_directory, P_entryname, P_suffix_info_ptr, P_status);

	if P_suffix_info_ptr = null ()
	then do;
		P_status = error_table_$null_info_ptr;
		return;
	     end;
	if P_suffix_info_ptr -> suffix_info.version ^= SUFFIX_INFO_VERSION_1
	then do;

		P_status = error_table_$unimplemented_version;
		return;
	     end;

	P_status = 0;
	call GET_TYPE_GET_ENTRY (FS_SUFFIX_INFO);
	go to SUFFIX_INFO_COMMON;

suffix_info_for_type:
     entry (P_type, P_suffix_info_ptr, P_status);

	P_status = 0;
	suffix_info_ptr = P_suffix_info_ptr;
	if suffix_info.version ^= SUFFIX_INFO_VERSION_1
	then do;
		P_status = error_table_$unimplemented_version;
		return;
	     end;
	call GET_ENTRY_GIVEN_TYPE (P_type, FS_SUFFIX_INFO);

SUFFIX_INFO_COMMON:
	call entry_to_call (P_suffix_info_ptr);
	return;



list_switches:
     entry (P_directory, P_entryname, P_desired_version, P_area_ptr, P_switch_list_ptr, P_status);

	user_area_ptr = P_area_ptr;
	if user_area_ptr = null ()
	then user_area_ptr = get_user_free_area_ ();

	call GET_TYPE_GET_ENTRY (FS_LIST_SWITCHES);
	go to LIST_SWITCHES_COMMON;

list_switches_for_type:
     entry (P_type, P_desired_version, P_area_ptr, P_switch_list_ptr, P_status);
	call GET_ENTRY_GIVEN_TYPE (P_type, FS_LIST_SWITCHES);

LIST_SWITCHES_COMMON:
	call entry_to_call (P_desired_version, P_area_ptr, P_switch_list_ptr, P_status);
	return;



make_entry:
     entry (P_directory, P_entryname, P_entrypoint_name, P_entry_to_call, P_status);

	P_status = 0;
	call GET_TYPE_GET_ENTRY (P_entrypoint_name);
	P_entry_to_call = entry_to_call;
	return;

make_entry_for_type:
     entry (P_type, P_entrypoint_name, P_entry_to_call, P_status);

	P_status = 0;
	call GET_ENTRY_GIVEN_TYPE (P_type, P_entrypoint_name);
	P_entry_to_call = entry_to_call;
	return;

get_type:
     entry (P_directory, P_entryname, P_type, P_status);

	P_status = 0;
	P_type = "";
	call GET_TYPE (P_directory, P_entryname);
	if P_status = 0
	then P_type = type;
	return;



GO:
     procedure (operation);

	declare operation		        char (*);
	declare directory		        char (*) parameter;
	declare entryname		        char (*) parameter;

	call GET_TYPE (P_directory, P_entryname);	/* get the type of the thing */
	go to GO_common;

GO_NO_CHASE:
     entry (operation);

	call GET_TYPE_NO_CHASE (P_directory, P_entryname);
	go to GO_common;

GO_DN_EN:
     entry (operation, directory, entryname);

	call GET_TYPE (directory, entryname);

GO_common:
	call GET_ENTRY (operation);			/* find the entrypoint */
	call cu_$generate_call (entry_to_call, arg_list_ptr);
	go to MAIN_RETURN;

     end GO;

GET_TYPE_GET_ENTRY:
     procedure (operation);

	declare operation		        char (*);

	call GET_TYPE (P_directory, P_entryname);
	call GET_ENTRY (operation);
	return;
     end GET_TYPE_GET_ENTRY;

GET_ENTRY_GIVEN_TYPE:
     procedure (a_type, operation);

	declare (a_type, operation)	        char (*);

	type = a_type;
	call FIX_TYPE;

	call GET_ENTRY (operation);
	return;
     end GET_ENTRY_GIVEN_TYPE;

GET_ENTRY:
     procedure (operation);

	declare operation		        char (*);
	declare ox		        fixed bin;
	declare reference_name	        char (32);
	declare code		        fixed bin (35);

	declare fs_standard_object_$make_entry
				        entry (fixed bin, fixed bin, fixed bin (35)) returns (entry);

	if fixed_type > 0				/* this is a standard_object */
	then do;
		do ox = 1 to HIGHEST_FS_OPERATION_INDEX;
		     if operation = FS_OPERATIONS (ox)
		     then go to HAVE_OPERATION;
		     if operation < FS_OPERATIONS (ox)
		     then go to ERROR_NO_OPERATION;
		end;
ERROR_NO_OPERATION:
		P_status = error_table_$unsupported_operation;
		go to MAIN_RETURN;

HAVE_OPERATION:
		entry_to_call = fs_standard_object_$make_entry (fixed_type, ox, P_status);
		if P_status ^= 0
		then go to MAIN_RETURN;
	     end;

	else do;
		reference_name = "suffix_" || rtrim (type) || "_";
		call hcs_$make_entry (codeptr (fs_util_), reference_name, operation, entry_to_call, code);
		if code ^= 0
		then do;
			P_status = error_table_$unsupported_operation;
			go to MAIN_RETURN;
		     end;
	     end;

	return;
     end GET_ENTRY;

/**** call fs_get_type_, translate type to fixed bin if appropriate */

GET_TYPE:
     procedure (directory, entryname);

	declare (directory, entryname)        char (*);


	declare fs_get_type_	        entry (char (*), char (*), char (*), fixed bin (35));
	declare fs_get_type_$no_chase	        entry (character (*), character (*), character (*), fixed binary (35));


	call fs_get_type_ (directory, entryname, type, P_status);
	go to GET_TYPE_common;

GET_TYPE_NO_CHASE:
     entry (directory, entryname);

	call fs_get_type_$no_chase (directory, entryname, type, P_status);
GET_TYPE_common:
	if P_status ^= 0
	then go to MAIN_RETURN;

FIX_TYPE:
     entry;
	if substr (type, 1, 1) = "-"
	then do;
		do idx = 1 to HIGHEST_FS_STANDARD_TYPE_INDEX;
		     if type = FS_STANDARD_TYPES (idx)
		     then go to HAVE_STD_TYPE;
		end;
		call sub_err_ (0, "fs_util_", ACTION_CANT_RESTART, null (), (0),
		     "Unsupported reserved object type referenced: ""^a"".", type);

HAVE_STD_TYPE:
		fixed_type = idx;
	     end;
	else fixed_type = -1;			/* Implies that this is not a std type */

	return;

     end GET_TYPE;

MAIN_RETURN:
	return;

%include copy_options;
%include file_system_operations_;
%include file_system_operations;

%include suffix_info;
%include copy_flags;
%include sub_err_flags;
     end fs_util_;




		    fs_star_.pl1                    10/06/88  1424.6rew 10/06/88  1420.6      881892



/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1988 *
        *                                          *
        ******************************************** */

/****^  HISTORY COMMENTS:
  1) change(88-09-17,GDixon), approve(88-09-17,MCR7987),
     audit(88-10-03,Beattie), install(88-10-06,MR12.2-1139):
      A) Implement fs_star_, phases 1, as described in MTB781-01.
  2) change(88-09-19,GDixon), approve(88-09-20,MCR8007),
     audit(88-10-03,Beattie), install(88-10-06,MR12.2-1139):
      A) Implement remainder of phase 1, and implement phase 2, as described
         in MTB781-02.
                                                   END HISTORY COMMENTS */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* fs_star_:									 */
/*    The fs_star_ subroutine provides for uniform selection of file system entries, using star	 */
/* names to select and exclude entries with additional selection by entry type.  Multisegment files	 */
/* and archives can be expanded to allow component-by-component processing; directories can be	 */
/* expanded to allow processing of a directory subtree.  Selected entries can be sorted in several	 */
/* different ways, and then passed to a caller-provided handler routine for processing (subtree	 */
/* listing or file initiation, etc).							 */
/*										 */
/* Implementation Notes:								 */
/*    fs_star_ is being implemented in several phases.  For MR12.2, directory star names, and	 */
/* sorting of entries are not yet implemented.  .data_desired = DATA_INITIATE and .entry_type =	 */
/* ENTRY_DONT_SELECT_NULL, ENTRY_DONT_SELECT_NONNULL, ENTRY_DONT_SELECT_OBJECTS,		 */
/* ENTRY_DONT_SELECT_NONOBJECTS, ENTRY_DONT_SELECT_MDIRS, and ENTRY_DONT_SELECT_NONMDIRS are not	 */
/* implemented either.								 */
/*										 */
/*    A decision was made not to document this subroutine for external use by customers until all	 */
/* features were complete.  As a result, the only documentation for the subroutine exists in	 */
/* MTB781-02.  Refer to that MTB for complete details.					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

fs_star_: 
    procedure();
    return;
	
 						/* PARAMETERS			 */
dcl  Pcaller_name			char(*) parm;	/* caller's name, if we create ssu_.	 */
						/*  (In)				 */
dcl  Pcaller_version		char(*) parm;	/* caller's version, if we create ssu_.	 */
						/*  (In)				 */
dcl  Pcode			fixed bin(35) parm; /* status code. (Out)		 */
dcl  Pssu_sciP			ptr parm;		/* ptr to ssu sci_ptr for this group	 */
						/*  of fs_star_ activations.  If null,	 */
						/*  we will create standalone ssu_	 */
						/*  for the caller. (In)		 */
dcl  Pstar_dataP			ptr parm;		/* ptr to star_data structure. 	 */
						/*  (Out points to star_data.matched)	 */
dcl  Pstar_optionsP			ptr parm;		/* ptr to star_options structure.	 */
						/*  (Out from $init, In to all other eps)*/
dcl  Pstar_options_version		char(8) parm;	/* version of star_options the caller	 */
						/*  is prepared to handle. (In)	 */
dcl  Pstructure_name		char(*) parm;	/* name of structure whose size is to be */
						/*  adjusted. (In)			 */
dcl  Pstructure_version		char(8) parm;	/* name/version of structure for which	 */
						/*  $adjust_structure_size must get	 */
						/*  space.  (In)			 */
dcl  Pnew_size			fixed bin parm;	/* number of elements desired in adjusted*/
						/*  structure.array. (In) 		 */
						/*  =0 ==> make structure array as large */
						/*	 as possible.		 */

						/* AUTOMATIC SCALARS		 */
dcl  code				fixed bin(35) auto;
dcl  ssu_sciP			ptr auto;		/* ssu sci_ptr for our use.		 */
dcl  standalone_invocationS		bit(1) auto;	/* true => fs_star_ had to create a	 */
						/*  standalone invocation of ssu_	 */

dcl  1 struct_header		aligned auto,	/* standard header beginning all structs */
       2 version			char(8),		/*  in fs_star_.incl.pl1, except for	 */
       2 max_count			fixed bin,	/*  star_options.			 */
       2 count			fixed bin;

						/* BASED				 */
dcl  1 epath			aligned based (epathP),
       2 version			char(8),
       2 max_count			fixed bin,
       2 count			fixed bin,
       2 value			(epath_size refer (epath.max_count)),
         3 dir			char(168) unal,
         3 dir_type			fixed bin(2),
         3 dir_uid			bit(36) aligned,
         3 ent			(1) char(32) unal,
         3 ent_type			fixed bin(2),
         3 comp			char(32) unal,
         3 comp_type		fixed bin(2),
     epathP			ptr auto,
     epath_size			fixed bin auto,
     EPATH_VERSION_1		init("EPATH_V1") char(8) int static options(constant);

dcl  1 exn			aligned based (fsd.exnP),
       2 version			char(8),
       2 count			fixed bin,	/* copy of exclude_names structure with	 */
       2 array			(exclude_names.count refer (exn.count)),
         3 value			char(32) unal,	/*  star_type added.		 */
         3 type			fixed bin(2),
     EXN_VERSION_1			init("EXN_VER1") char(8) int static options(constant);

dcl  1 fsd			aligned based(fsdP),/* fs_star_data			 */
       2 version			char(8),		/* = FSD_VERSION_1			 */
       2 next_spaceP		ptr,		/* next free space in star_options seg.	 */
						/*  Used by $select and		 */
						/*  $adjust_structure_size to determine  */
						/*  where to get space for next allocate.*/
       2 we_created_ssuS		bit(1),		/* $init called			 */
						/*  ssu_$standalone_invocation.	 */
       2 fsd_pad			fixed bin,	/* pad to even word boundary.		 */
       2 star_dataP			ptr,		/* ptr to working star_data structure.	 */
       2 archP			ptr,		/* ptr to an archive being read.	 */
       2 epathP			ptr,		/* ptr to epath structure.		 */
       2 mnP			ptr,		/* ptr to mn structure.		 */
       2 exnP			ptr,		/* ptr to exn structure.		 */
       2 temp_segsP			(10) ptr,		/* ptrs to temp segs obtained from ssu_	 */
						/*  that must be released.		 */
       2 areasP			(1) ptr;		/* ptrs to areas obtained from ssu_	 */
						/*  that must be released.		 */
dcl  fsdP				ptr;
dcl  FSD_VERSION_1			init("FSD_VER1") char(8) int static options(constant);

dcl  1 mn				aligned based (fsd.mnP),
       2 version			char(8),
       2 count			fixed bin,	/* copy of match_names structure with	 */
       2 array			(match_names.count refer (mn.count)),
         3 value			char(32) unal,	/*  star_type added for each value.	 */
         3 type			fixed bin(2),
     MN_VERSION_1			init("MN_VER1") char(8) int static options(constant);

dcl  1 sd				aligned like star_data based(star_dataP);

dcl  1 so				aligned like star_options based(star_optionsP);

						/* BUILTINS and CONDITIONS		 */
dcl (addr, addwordno, currentsize, dimension, divide, hbound, lbound, length, ltrim, max, mod, null, 
     pointer, rtrim, search, size, substr, sum, wordno)	
				builtin;
dcl  cleanup			condition;

						/* ENTRIES			 */
dcl  archive_$next_component		entry (ptr, fixed bin(24), ptr, fixed bin(24), char(*),
				     fixed bin(35));
dcl  check_star_name_		entry (char(*), bit(36), fixed bin(2), fixed bin(35));
dcl  cu_$arg_count			entry (fixed bin, fixed bin(35));
dcl  cu_$arg_list_ptr		entry returns(ptr); 
dcl  cu_$arg_ptr			entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl  cu_$generate_call		entry (entry, ptr);
dcl  expand_pathname_$component	entry (char(*), char(*), char(*), char(*), fixed bin(35));
dcl  fs_util_$get_type		entry (char(*), char(*), char(*), fixed bin(35));
dcl  hcs_$get_uid_file		entry (char(*), char(*), bit(36) aligned, fixed bin(35));
dcl  hcs_$star_			entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr,
				     ptr, fixed bin(35));
dcl  hcs_$status_			entry (char(*), char(*), fixed bin(1), ptr, ptr,
				     fixed bin(35));
dcl  hcs_$status_minf		entry (char(*), char(*), fixed bin(1), fixed bin(2),
				     fixed bin(24), fixed bin(35));
dcl  hcs_$truncate_seg		entry (ptr, fixed bin(19), fixed bin(35));
dcl  initiate_file_			entry (char(*), char(*), bit(*), ptr, fixed bin(24),
				     fixed bin(35));
dcl  ioa_$general_rs		entry (ptr, fixed bin, fixed bin, char(*), fixed bin(21),
				     bit(1) aligned, bit(1) aligned);
dcl  ioa_$rsnpnnl			entry() options(variable);
dcl  match_star_name_		entry (char(*), char(*), fixed bin(35));
dcl  pathname_			entry (char(*), char(*)) returns(char(168));
dcl  pathname_$component		entry (char(*), char(*), char(*)) returns(char(194));
dcl  ssu_$destroy_invocation		entry (ptr);
dcl  ssu_$get_area			entry (ptr, ptr, char(*), ptr);
dcl  ssu_$get_temp_segment		entry (ptr, char(*), ptr);
dcl  ssu_$null_entry		entry ();
dcl  ssu_$print_message		entry() options(variable);
dcl  ssu_$release_area		entry (ptr, ptr);
dcl  ssu_$release_temp_segment	entry (ptr, ptr);
dcl  ssu_$standalone_invocation	entry (ptr, char(*), char(*), ptr, entry, fixed bin(35));
dcl  sub_err_			entry() options(variable);
dcl  terminate_file_		entry (ptr, fixed bin(24), bit(*), fixed bin(35));

						/* NAMED CONSTANTS			 */
dcl (EP_ADJUST			init(1),
     EP_INIT			init(2),
     EP_REINIT			init(3),
     EP_SELECT			init(4),
     EP_TERM			init(5)) fixed bin int static options(constant);
dcl  EP_NAME			(5) char(32) int static options(constant) init(
				"fs_star_$adjust_structure_size",
				"fs_star_$init",
				"fs_star_$reinit",
				"fs_star_$select",
				"fs_star_$term");
dcl (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1) int static options(constant);
dcl  NO_CHASE			init(0) fixed bin(1) int static options(constant);
dcl  NO_NAMES			init(-1) fixed bin(2) int static options(constant);
dcl (NOT_MSF			init("0"b),
     IS_MSF			init("1"b)) bit(1) int static options(constant);

						/* EXTERNAL STATIC			 */
dcl (error_table_$archive_pathname,
     error_table_$argerr,
     error_table_$fatal_error,
     error_table_$improper_data_format,
     error_table_$inconsistent,
     error_table_$noalloc,
     error_table_$noentry,
     error_table_$nomatch,
     error_table_$nostars,
     error_table_$null_name_component,
     error_table_$root,
     error_table_$smallarg,
     error_table_$too_many_names,
     error_table_$unimplemented_version,
     error_table_$unsupported_operation)
				fixed bin(35) ext static;
dcl  sys_info$max_seg_size		fixed bin(35) ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* check_star_name.incl.pl1								 */
/*   must appear before ARCHIVE_PATH_expand, which uses its constants in label array references.	 */
/*   It is being placed at the beginning of the program for this reason, rather than with the other	 */
/*   include files at the end of the program.						 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

%include check_star_name;

dcl  STAR_TYPE_UNSET		init(-1) fixed bin int static options(constant);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ENTRY POINT: adjust_structure_size							 */
/*   $init allocates space only for the star_paths structure.  This entrypoint allocates space for	 */
/*   the exclude_names, extended_entry_types, and match_names structures.  It can also enlarge any	 */
/*   of these structures beyond their current extents.					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

adjust_structure_size:
    entry (Pstar_optionsP, Pstructure_name, Pstructure_version, Pnew_size, Pcode);

    Pcode = 0;					/* initialize output parm.		 */

    call ENTRY_POINT_setup (EP_ADJUST);			/* access fsd structure.		 */

    call STRUCT_name_version_size_check (Pstructure_name, Pstructure_version, Pnew_size);
						/* make sure structure name and version	 */
						/*  parms match up correctly.		 */

    call STRUCT_allocate (Pstructure_name, Pstructure_version, Pnew_size, EP_ADJUST);
						/* allocate starting location for	 */
						/*  structure we are getting.		 */

ADJUST_EXIT:
    return;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */
/*										 */
/* SUPPORT PROCEDURES for $adjust_structure_size entrypoint					 */
/*										 */
/* SUPPORT PROCEDURE: ADJUST_error							 */
/*   Set Pcode parm and do nonlocal transfer to exit immediately from fs_star_.			 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */

ADJUST_error:
    procedure (Pcode_in);
    
dcl  Pcode_in			fixed bin(35) parm;
    
    if Pcode_in = 0 then return;
    if Pcode = 0 then
       Pcode = Pcode_in;
    go to ADJUST_EXIT;
    end ADJUST_error;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE: STRUCT_name_version_size_check					 */
/*   Validates that Pstructure_name and Pstructure_version parms correspond with one another.	 */
/*   Checks for a negative structure size.  $adjust_structure_size returns with error codes if	 */
/*   either check fails its criteria.							 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

STRUCT_name_version_size_check:
    procedure (Pstruct_name, Pstruct_version, Pstruct_size);

dcl  Pstruct_name			char(*) parm,
     Pstruct_version		char(8) parm,
     Pstruct_size			fixed bin parm;

    if      Pstruct_name = "exclude_names"	& Pstruct_version = STAR_EXCLUDE_NAMES_VERSION_1 then;
    else if Pstruct_name = "extended_entry_types" & Pstruct_version = STAR_EXTENDED_ENTRY_VERSION_1 then;
    else if Pstruct_name = "match_names"	& Pstruct_version = STAR_MATCH_NAMES_VERSION_1 then;
    else if Pstruct_name = "star_paths"           & Pstruct_version = STAR_PATHS_VERSION_1 then;
    else call ADJUST_error (error_table_$argerr);

    if Pstruct_size < 0 then
       call ADJUST_error (error_table_$smallarg);

    if Pstruct_version = STAR_EXCLUDE_NAMES_VERSION_1 then do;
       if star_options.exclude_namesP ^= null then
	if exclude_names.count > Pstruct_size then
	   call ADJUST_error (error_table_$inconsistent);
       end;
    else if Pstruct_version = STAR_EXTENDED_ENTRY_VERSION_1 then do;
       if star_options.extended_entry_typesP ^= null then
	if extended_entry_types.count > Pstruct_size then
	   call ADJUST_error (error_table_$inconsistent);
       end;
    else if Pstruct_version = STAR_MATCH_NAMES_VERSION_1 then do;
       if star_options.match_namesP ^= null then
	if match_names.count > Pstruct_size then
	   call ADJUST_error (error_table_$inconsistent);
       end;
    else if Pstruct_version = STAR_PATHS_VERSION_1 then do;
       if star_options.star_pathsP ^= null then
	if star_paths.count > Pstruct_size then
	   call ADJUST_error (error_table_$inconsistent);
       end;

    end STRUCT_name_version_size_check;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ENTRY POINT: init								 */
/*   Initializes storage and functions needed to use fs_star_.  This includes the following steps:	 */
/*										 */
/* 1) Validate the caller-requested version ID.						 */
/* 2) If the caller did not already have an ssu_ invocation, then create one on his behalf for use	 */
/*    by fs_star_.									 */
/* 3) Get the first temporary segment used by fs_star_.  This one will hold the star_options, fsd,	 */
/*    and star_paths structures.							 */
/* 4) Initialize these structures and return them to the caller.				 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

init:
    entry (Pssu_sciP, Pcaller_name, Pcaller_version, Pstar_options_version, Pstar_optionsP, Pcode);

    Pstar_optionsP = null;				/* set output arguments		 */
    Pcode = 0;

    call INIT_cleanup_setup();
    on cleanup call INIT_cleanup();			/* establish cleanup handler.		 */

    if Pstar_options_version = STAR_OPTIONS_VERSION_1 then; /* check for known star_options version	 */
    else call INIT_error (error_table_$unimplemented_version);

    if ssu_sciP = null then do;			/* caller doesn't have its own ssu_	 */
       standalone_invocationS = TRUE;			/*  invocation?  We'll create one.	 */
       call ssu_$standalone_invocation (ssu_sciP, Pcaller_name, Pcaller_version, null, ERROR_unexpected,
	code);
       call INIT_error (code);
       end;

    call ssu_$get_temp_segment (ssu_sciP, "star_options", star_optionsP);
    so.version = STAR_OPTIONS_VERSION_1;		/* create, initialize star_options	 */
    so.caller.ssu_sciP = ssu_sciP;

    call FSD_init();

    so.star_pathsP = null;
    call STRUCT_allocate ("star_paths", STAR_PATHS_VERSION_1, 10, EP_INIT);

    so.selection.path_allow = PATH_ALLOW_ENTRY_STAR_NAMES;	/* continue initialization of		 */
    so.selection.entry_type = ENTRY_RETURN;		/*  star_options structure.		 */
    so.selection.extended_entry_typesP = null;
    so.selection.match_namesP = null;
    so.selection.exclude_namesP = null;

    so.per_entry.sorting = SORT_OFF;
    so.per_entry.handler = ssu_$null_entry;
    so.per_entry.error = ssu_$null_entry;
    so.per_entry.handler_dataP = null;
    so.per_entry.data_desired = DATA_TYPE;
    so.per_entry.data_version = STAR_DATA_VERSION_1;
    so.mbz = ""b;

    Pstar_optionsP = star_optionsP;
    return;

INIT_EXIT:
    call INIT_cleanup();
    Pstar_optionsP = null;
    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */
/*										 */
/* SUPPORT PROCEDURES for the $init entrypoint:						 */
/*										 */
/* SUPPORT PROCEDURE: INIT_cleanup							 */
/*   cleans up changes which $init made to the runtime environment, in case when $init failed or	 */
/*   was aborted (its activation was released by a nonlocal goto).				 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */

INIT_cleanup:
    procedure;
    if standalone_invocationS then
       call ssu_$destroy_invocation (ssu_sciP);
    else if star_optionsP ^= null then
       call ssu_$release_temp_segment (ssu_sciP, star_optionsP);
    end INIT_cleanup;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE: INIT_cleanup_setup						 */
/*   initializes variables referenced by the INIT_cleanup routine.				 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

INIT_cleanup_setup:
    procedure;
    standalone_invocationS = FALSE;
    ssu_sciP = Pssu_sciP;
    star_optionsP = null;
    end INIT_cleanup_setup;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE: INIT_error							 */
/*   routine to check error codes.  If zero, the routine returns.  If nonzero, it sets $init's	 */
/*   Pcode output parm and exits from $init.						 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */

INIT_error:
    procedure (Pcode_in);

dcl  Pcode_in			fixed bin(35) parm;

    if Pcode_in = 0 then return;
    if Pcode = 0 then
       Pcode = Pcode_in;
    go to INIT_EXIT;
    end INIT_error;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ENTRY POINT: reinit								 */
/*   Frees all allocated space, plus structures associated with star_options (eg, star_paths,	 */
/*   match_names, exclude_names and extended_entry_types structures).  A new star_paths structure	 */
/*   (with 10-element array) is allocated.  All other elements of star_options remain as they were	 */
/*   set prior to the call to $reinit.							 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

reinit:
    entry (Pstar_optionsP);
    
    call ENTRY_POINT_setup (EP_REINIT);

    call FSD_reinit();				/* Reinitialize fs_star_ data.	 */

    star_options.star_pathsP = null;
    call STRUCT_allocate ("star_paths", STAR_PATHS_VERSION_1, 10, EP_REINIT);
    so.selection.extended_entry_typesP = null;		/* Reinitialize star_paths, and get rid	 */
    so.selection.match_namesP = null;			/*  of any other structures associated	 */
    so.selection.exclude_namesP = null;			/*  with the previous selection.	 */
    so.mbz = ""b;

    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ENTRY POINT: select								 */
/*   Does the actual section of entries matching the star_options selection criteria.		 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

select:
    entry (Pstar_optionsP, Pstar_dataP, Pcode);

    call ENTRY_POINT_setup (EP_SELECT);			/* access data from input parms.	 */
    Pstar_dataP = null;
    Pcode = 0;					/* set output parms.		 */

    if so.data_version ^= STAR_DATA_VERSION_1 then	/* validate star_options.		 */
       call SELECT_error (error_table_$unimplemented_version,
       "star_options.data_version (=""^a"") must be set to the constant STAR_DATA_VERSION_1 (=""^a"").",
       so.data_version, STAR_DATA_VERSION_1);
    if so.data_desired ^= DATA_TYPE then
       call SELECT_error (error_table_$unsupported_operation,
       "star_options.data_desired (=^d) must be set to the constant DATA_TYPE (=^d).",
       so.data_desired, DATA_TYPE);

    call STRUCT_allocate ("star_data", so.per_entry.data_version, so.per_entry.data_desired, EP_SELECT);
    Pstar_dataP = addr(star_data);			/* allocate space for output structure.	 */

    call STAR_PATHS_evaluate();			/* divide caller-supplied paths into	 */
						/*  dir/ent/arch_comp parts.		 */
						/*  Eliminate duplicate paths too.	 */

    call SELECT_further_init();			/* check out match_names and 		 */
						/*  exclude_names structures.		 */

    call EVAL_PATHS_sort();				/* do an initial sort of the evaluated	 */
						/*  input paths.			 */
    call EVAL_PATHS_expand();				/* expand stars in pathnames and invoke	 */
						/*  caller's handler routine for each 	 */
						/*  entry.			 */

SELECT_EXIT:
    sd.matched.total = sd.matched.current;
    sd.entry_data.type = "";
    sd.entry_data.length = 0;
    sd.entry_data.count = 0;
    sd.entry_data.entryP = null;
    if sd.matched.total = 0 then
       if Pcode = 0 then
	Pcode = error_table_$nomatch;

    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURES for $select entrypoint:						 */
/*										 */
/* SUPPORT PROCEDURE:  ARCHIVE_PATH_expand						 */
/*   This procedure expands archive segments into components.  The procedure must:		 */
/* 1) Initiate the archive segment.  If the user does not have access to the archive, the caller's	 */
/*    error routine is called to report the error, and expansion stops.			 */
/* 2) Uses archive_$next_component to scan through all components of the archive.		 */
/* 3) For each component, the component name is compared with the user's archive component starname, */
/*    using match_star_name_ when necessary.  Matching components are counted and passed to the	 */
/*    caller's handler routine.  Nonmatching components are skipped.				 */
/* 4) Finally, the archive is terminate.  Note that this procedure does not need its own cleanup on	 */
/*    unit, because fs_star_$term acts as a cleanup on unit (established by the caller), and it will */
/*    terminate the segment if it finds fsd.archP nonnull.					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

ARCHIVE_PATH_expand:
    procedure (Pdepth, Pfree_areaP, Ppath, Pent, Psort_order);
    
dcl  Pdepth			fixed bin parm;	/* INPUT PARAMETERS			 */
dcl  Pfree_areaP			ptr parm;
dcl  1 Ppath			aligned like epath.value parm;
dcl  Pent				(*) char(32) unal parm;
dcl  Psort_order			fixed bin parm;

						/* AUTOMATIC			 */
dcl  archL			fixed bin(24) auto; /* length of an archive.		 */
dcl  code				fixed bin(35) auto;
dcl  compL			fixed bin(24) auto; /* length of a component		 */
dcl  compP			ptr auto;		/* ptr to a component.		 */
dcl  comp_name			char(32) auto;	/* name of a component.		 */
dcl  snN				fixed bin auto;
dcl  snP				ptr auto;
dcl  sn				(snN) char(32) based (snP);

    fsd.archP = null;
    if Ppath.ent_type ^= STAR_TYPE_MATCHES_EVERYTHING then do;
       status_area_ptr = TEMP_AREA_get();		/* hcs_$star_ returns only entry names 	 */
       status_ptr = addr(auto_status);			/*  which match the star name.  We must	 */
       call hcs_$status_ (Ppath.dir, Pent(1), NO_CHASE,	/*  return all names, so get them now.	 */
	status_ptr, status_area_ptr, code);
       if code = 0 then do;
	snP = addr(status_names);
	snN = dimension(status_names,1);
	end;
       else do;
	snP = addr(Pent);
	snN = dimension(Pent,1);
	end;
       end;
    else do;
       snP = addr(Pent);
       snN = dimension(Pent,1);
       end;

    sd.entry_data.type = ENTRY_TYPE_ARCHIVE;
    call initiate_file_ (Ppath.dir, Pent(1), R_ACCESS, fsd.archP, archL, code);
    call ARCHIVE_PATH_error (Pdepth-1, code, Ppath.dir, sn, "", "initiating archive");
    compP = null;

    if archL = 0 then;
    else do while (TRUE);
       call archive_$next_component (fsd.archP, archL, compP, compL, comp_name, code);
       call ARCHIVE_PATH_error (Pdepth, code, Ppath.dir, sn, "", "reading archive");
       if compP = null then
	go to FINAL_ARCH_ENTRY;
       go to ARCH_NAME (Ppath.comp_type);

ARCH_NAME (STAR_TYPE_USE_PL1_COMPARE):
       if comp_name = Ppath.comp then
	go to MATCHING_ARCH_ENTRY;
       else
	go to NEXT_ARCH_ENTRY;
    
ARCH_NAME (STAR_TYPE_USE_MATCH_PROCEDURE):
       call match_star_name_ (comp_name, Ppath.comp, code);
       if code = 0 then
	go to MATCHING_ARCH_ENTRY;
       else
	go to NEXT_ARCH_ENTRY;

ARCH_NAME (STAR_TYPE_MATCHES_EVERYTHING):
MATCHING_ARCH_ENTRY:
       if ((so.entry_type.arch_comps & ENTRY_DONT_RETURN) = ENTRY_DONT_RETURN) then;
       else do;
	call PATH_MATCH_ENTRY_add (ENTRY_TYPE_ARCHIVE_COMP, Pdepth);
	call ARCHIVE_PATH_handler (Ppath.dir, sn, comp_name);
	end;
       go to NEXT_ARCH_ENTRY;

REMOVE_ARCH_ENTRY:
       call PATH_MATCH_ENTRY_remove();
       go to NEXT_ARCH_ENTRY;

NEXT_ARCH_ENTRY:
       end;

FINAL_ARCH_ENTRY:
    if snP ^= addr(Pent) then
       free status_entry_names in (status_area);
    if fsd.archP ^= null then
       call terminate_file_ (fsd.archP, archL, TERM_FILE_TERM, code);
    return;

REMOVE_ARCH_ENTRY_AND_EXIT:
    call PATH_MATCH_ENTRY_remove();
    go to SELECT_EXIT;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */
/*										 */
/* SUPPORT PROCEDURE: ARCHIVE_PATH_error						 */
/*   If Pcode_in = 0, then return.							 */
/*   Otherwise, expand error message and invoke caller's error handler.			 */
/*   If caller did not provide an error handler, then print error ourselves.			 */
/*   If caller's action code is ERROR_OK or ERROR_REJECT, then continue by processing the next	 */
/*     pathname.									 */
/*   If his action code is ERROR_STOP or ERROR_ABORT, then set Pcode parm of $select and do nonlocal */
/*     transfer to exit immediately from fs_star_.					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */

ARCHIVE_PATH_error:
    procedure (Pdepth, Pcode_in, Pdir, Pent, Pcomp, Pmessage);

dcl  Pdepth			fixed bin parm;
dcl  Pcode_in			fixed bin(35) parm;
dcl  Pdir				char(*) parm;
dcl  Pent				(*) char(32) unal parm;
dcl  Pcomp			char(32) parm;
dcl  Pmessage			char(*) parm;

dcl  action			fixed bin auto;

    if Pcode_in = 0 then return;

    star_data.entry_data.depth = Pdepth;
    if so.error = ssu_$null_entry then do;		/* caller did NOT provide an error	 */
       call ssu_$print_message (ssu_sciP, Pcode_in, "^[ in ^a ^;^s^]^[^a^s^;^s^a^]^[^/(^a)^;^s^]",
	sd.entry_data.type ^= ENTRY_TYPE_UNKNOWN, ltrim(sd.entry_data.type,"-"),
	Pent(lbound(Pent,1))="", Pdir, pathname_$component (Pdir, Pent(lbound(Pent,1)), Pcomp),
	Pmessage^="", Pmessage);
       action = ERROR_REJECT;
       end;
    else
       call so.error (addr(star_data), Pdir, Pent, Pcomp, Pcode_in, Pmessage, action);

    if sd.entry_data.type = ENTRY_TYPE_ARCHIVE then do;	/* Caller has not begun processing	 */
						/*   archive components.		 */
       if action = ERROR_STOP | action = ERROR_ABORT then	/* Only honor STOP/ABORT action, by 	 */
	go to SELECT_EXIT;				/*  existing fs_star_$select; otherwise	 */
       else go to FINAL_ARCH_ENTRY;			/*  just return to caller, who will 	 */
       end;					/*  continue with next input path.	 */
    
    else do;					/* Caller has begun processing comps.	 */
       if action = ERROR_OK then			/*  Count errant entry.		 */
	go to NEXT_ARCH_ENTRY;
       else if action = ERROR_REJECT then		/*  Remove errant entry from count.	 */
	go to REMOVE_ARCH_ENTRY;
       else if action = ERROR_STOP then			/*  Exit fs_star_$select immediately.	 */
	go to SELECT_EXIT;
       else if action = ERROR_ABORT then		/*  Remove errant entry from count, then */
	go to REMOVE_ARCH_ENTRY_AND_EXIT;		/*   exit fs_star_$select.		 */
       else do;					/*  Unknown action code value.	 */
	call ssu_$print_message (ssu_sciP, error_table_$unsupported_operation,
	   "fs_star_ error routine returned unknown action code (=^d).", action);
	if Pcode = 0 then
	   Pcode = error_table_$unsupported_operation;
	go to SELECT_EXIT;
	end;
       end;
    end ARCHIVE_PATH_error;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE: ARCHIVE_PATH_handler						 */
/*   This procedure calls the caller-supplied star_options.handler procedure for each selected	 */
/*   entry.  The caller's handler may return an action code which controls how fs_star_ continues	 */
/*   in its processing of the entry.  							 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

ARCHIVE_PATH_handler:
    procedure (Pdir, Pents, Pcomp);

dcl  Pdir				char(168) parm;
dcl  Pents			(*) char(32) unal parm;
dcl  Pcomp			char(32) parm;

dcl  action			fixed bin auto;

    if ^SELECT_further (star_data.entry_data.type, (Pcomp)) then
       go to REMOVE_ARCH_ENTRY;

    call so.handler (addr(star_data), Pdir, Pents, Pcomp, action);

    if action = HANDLER_OK then;
    else if action = HANDLER_REJECT then
       go to REMOVE_ARCH_ENTRY;
    else if action = HANDLER_DONT_EXPAND then;
    else if action = HANDLER_EXPAND then;	
    else if action = HANDLER_EXPAND_DONT_COUNT then
       go to REMOVE_ARCH_ENTRY;
    else if action = HANDLER_DONT_COUNT then
       go to REMOVE_ARCH_ENTRY;
    else if action = HANDLER_STOP then
       go to SELECT_EXIT;
    else if action = HANDLER_ABORT then
       go to REMOVE_ARCH_ENTRY_AND_EXIT;
    else
       call SELECT_error (error_table_$unsupported_operation,
       "fs_star_ handler routine returned unknown action code (=^d).", action);

    end ARCHIVE_PATH_handler;

    end ARCHIVE_PATH_expand;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */
/*										 */
/* SUPPORT PROCEDURE: EVAL_PATHS_expand							 */
/*   For each evaluated, sorted input path, this procedure calls PATH_expand to expand the entry.	 */
/*   It first gets an area pointer from ssu_ for use in calls to hcs_$star_ and			 */
/*   archive_$list_components.							 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */

EVAL_PATHS_expand:
    procedure();

dcl  code				fixed bin(35) auto;
dcl  free_areaP			ptr auto;
dcl  matched_before			fixed bin auto;
dcl  pathX			fixed bin auto;

    free_areaP = TEMP_AREA_get();

    do pathX = lbound (epath.value,1) to epath.count;
       matched_before = sd.matched.current;
       call PATH_expand (1, NOT_MSF, free_areaP, epath.value(pathX), so.sorting.dir_ents(1));
       if sd.matched.current - matched_before = 0 then do;	/* Report nomatch errors only for paths	 */
						/*  caller specified.		 */
	if epath.ent_type(pathX) = STAR_TYPE_USE_PL1_COMPARE then do;
	   call hcs_$status_minf (epath.dir(pathX), epath.ent(pathX,1), NO_CHASE, 0, 0, code);
	   if code = 0 | code = error_table_$root then
	      call PATH_expand_error (1, error_table_$nomatch, epath.value(pathX), NO_NAMES, "", 0);
	   else
	      call PATH_expand_error (1, error_table_$noentry, epath.value(pathX), NO_NAMES, "", 0);
	   end;
	else
	   call PATH_expand_error (1, error_table_$nomatch, epath.value(pathX), NO_NAMES, "", 0);
	end;					/* Only use error_table_$nomatch if	 */
       end;					/*  entry really exists.		 */

    end EVAL_PATHS_expand;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE: EVAL_PATHS_sort							 */
/*   Sort the input paths, which have been broken in directory/entry/component parts.		 */
/*										 */
/*   This procedure is NOT implemented in phase 1 fs_star_.					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

EVAL_PATHS_sort:
    procedure();

    end EVAL_PATHS_sort;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE: PATH_expand							 */
/* 1) expands starnames in the final entry name of a path.  Note that it leaves archive component	 */
/*    starname expansion to ARCHIVE_PATH_expand.						 */
/* 2) For each directory entry selected by the starname, it determines its true type.  For phase 1,	 */
/*    this is usually the standard entry type; if the standard type is a directory, it calls	 */
/*    fs_util_$get_type to determine if the dir is really an MSF or a DM file.			 */
/* 3) It further determines whether that type of entry should be passed along to our caller's	 */
/*    handler routine, should be expanded, etc, based upon star_options, match_names, etc.	 */
/* 4) It calls PATH_handler to pass it to the caller, ARCHIVE_PATH_expand to deal with		 */
/*    archive expansion, and PATH_expand (recursively) to expand directories.			 */
/* 5) Along the way, it counts selected entries.						 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

PATH_expand:
    procedure (Pdepth, Pparent_is_msf, Pfree_areaP, Ppath, Psort_order);
    
dcl  Pdepth			fixed bin parm;	/* INPUT PARAMETERS			 */
dcl  Pparent_is_msf			bit(1) parm;
dcl  Pfree_areaP			ptr parm;
dcl  1 Ppath			aligned like epath.value parm;
dcl  Psort_order			fixed bin parm;

dcl  action			fixed bin auto,	/* AUTOMATIC			 */
     bc				fixed bin(24) auto,
     code				fixed bin(35) auto,
     fs_util_type			char(32),
     nameX			fixed bin auto,
     1 path			aligned like epath.value auto,
     seP				ptr auto,
     snN				fixed bin auto,
     snP				ptr auto,
     starX			fixed bin auto,
     type				fixed bin(2) auto;

						/* BASED				 */
dcl  free_area			area based (Pfree_areaP);
dcl  1 se				aligned like star_entries based(seP);
dcl  sn				(snN) char(32) unal based (snP);

						/* NAMED CONSTANTS			 */
dcl  CHASE			init(1) fixed bin(1) int static options(constant);
dcl  NO_CHASE			init(0) fixed bin(1) int static options(constant);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* star_structures.incl.pl1								 */
/*   must be included in PATH_expand because PATH_expand is called recursively, and each recursion	 */
/*   needs copies of automatic variables declared in this include file.  It must be included before	 */
/*   the TYPE labels so those label array constants can include named constants declared in this	 */
/*   include file.  For example,  TYPE(star_SEGMENT):					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

%include star_structures;

dcl (fs_star_ARCHIVE		init(3),		/* NAMED CONSTANTS which add to the dir	 */
     fs_star_MSF			init(4),		/*  entry types defined in the above	 */
     fs_star_MSF_COMP		init(5),		/*  star_structures.incl.pl1, used in 	 */
     fs_star_DM_FILE		init(6),		/*  TYPE label array constants below.	 */
     fs_star_EXTENDED_ENTRY		init(7)
     )				fixed bin int static options(constant);

dcl  1 ROOT_ENTRY			aligned int static options(constant),
       2 type			fixed bin(2) uns unal init(star_DIRECTORY),
       2 nnames			fixed bin(16) uns unal init(1),
       2 nindex			fixed bin(18) uns unal init(1),
     ROOT_NAME			char(32) int static options(constant) init("");
						/* This is information that hcs_$star_   */
						/*  should return about the root (>).    */

    sd.entry_data.type = ENTRY_TYPE_DIRECTORY;		/* Set for use by PATH_error for errors	 */
						/*  reported prior to entering do-group. */

    call hcs_$star_ (Ppath.dir, Ppath.ent(1), star_ALL_ENTRIES, addr(free_area), star_entry_count,
       star_entry_ptr, star_names_ptr, code);		/* Expansion of starname.		 */


    if code = error_table_$nomatch then do;		/* Don't report no_match errors but check*/
       if (Ppath.dir = ">") & (Ppath.ent(1) = "") then do;	/*  for searching the root dir (>)	 */
	star_entry_count = 1;			/* Must fake root dir (>); hcs_$star_	 */
	star_entry_ptr = addr(ROOT_ENTRY);		/*  doesn't understand it as a directory.*/
	star_names_ptr = addr(ROOT_NAME);
	code = 0;
	go to PROCESS_STAR_ENTRIES;
	end;
       end;

    else if code ^= 0 then				/* Report other errors against dir itself*/
       call PATH_error (Pdepth, code, Ppath.dir, "", NO_NAMES, "", "", 0);

    else do;					/* Process entries selected by starname. */
PROCESS_STAR_ENTRIES:
       do starX = 1 to star_entry_count while (Psort_order = SORT_REVERSE),
	  	   star_entry_count to 1 by -1 while (Psort_order ^= SORT_REVERSE);
	seP = addr(star_entries(starX));		/* Overlay entry names MATCHING starname,*/
	snP = addr(star_names(se.nindex));		/*  and data returned by hcs_$star_.	 */
	snN = se.nnames;
	if star_LINK <= se.type | se.type <= star_DIRECTORY then;
	else call PATH_error (Pdepth, error_table_$improper_data_format, Ppath.dir, sn,
	   Ppath.ent_type, "", "hcs_$star_ returned unknown dir entry type (=^d)", (se.type));
	go to TYPE (se.type);			/* Process entries by standard entry type*/
						/*  returned by hcs_$star_, and by	 */
						/*  extended entry types...		 */

TYPE (star_LINK):
	if (so.entry_type.links & ENTRY_DONT_RETURN) = ENTRY_DONT_RETURN then;
	else do;
	   call PATH_MATCH_ENTRY_add (ENTRY_TYPE_LINK, Pdepth);
	   if ((so.entry_type.links & ENTRY_CHASE_ALL_LINKS) = ENTRY_CHASE_ALL_LINKS) then do;
CHASE_LINKS:    call hcs_$status_minf (Ppath.dir, sn(1), CHASE, type, bc, code);
	      call PATH_error (Pdepth, code, Ppath.dir, sn, Ppath.ent_type, "",
	         "calling hcs_$status_minf", 0);
	      if (type = star_LINK) &
	         ((so.entry_type.links & ENTRY_DONT_SELECT_NULL) = ENTRY_DONT_SELECT_NULL) then
	         go to REMOVE_ENTRY;
	      else if (type ^= star_LINK) &
		    ((so.links & ENTRY_DONT_SELECT_NONNULL) = ENTRY_DONT_SELECT_NONNULL) then
	         go to REMOVE_ENTRY;
	      call PATH_MATCH_ENTRY_remove();
	      if star_LINK <= type | type <= star_DIRECTORY then;
	      else call PATH_error (Pdepth, error_table_$improper_data_format, Ppath.dir, sn,
	         Ppath.ent_type, "", "hcs_$status_minf returned unknown dir entry type (=^d)", type);
	      go to TYPE (type);
	      end;
	   else if ((so.entry_type.links & ENTRY_CHASE_NONSTAR_LINKS) = ENTRY_CHASE_NONSTAR_LINKS) &
		 (Ppath.ent_type = STAR_TYPE_USE_PL1_COMPARE) then
	      go to CHASE_LINKS;
	   else do;
	      call PATH_handler (Ppath.dir, sn, Ppath.ent_type, "", action);
	      if action = HANDLER_EXPAND_DONT_COUNT | action = HANDLER_DONT_COUNT then
	         call PATH_MATCH_ENTRY_remove();
	      end;
	   end;
	go to NEXT_ENTRY;
       
TYPE (star_SEGMENT):
	do nameX = lbound(sn,1) to hbound(sn, 1);	/* Is segment an archive?		 */
	   if PATH_suffix (sn(nameX), ".archive") then
	      go to TYPE (fs_star_ARCHIVE);
	   end;
	if Pparent_is_msf then			/* Is is an MSF component?		 */
	   go to TYPE (fs_star_MSF_COMP);
	if ((so.entry_type.segs & ENTRY_INAEE) = ENTRY_INAEE) then do;
	   call fs_util_$get_type (Ppath.dir, sn(1), fs_util_type, code);
	   if code = 0 then
	      if fs_util_type ^= ENTRY_TYPE_SEGMENT then
	         go to TYPE (fs_star_EXTENDED_ENTRY);	/* Only report extended entries if caller*/
	   end;					/*  asked for these.		 */
	if ((so.entry_type.segs & ENTRY_DONT_RETURN) = ENTRY_DONT_RETURN) then;
	else do;
	   call PATH_MATCH_ENTRY_add (ENTRY_TYPE_SEGMENT, Pdepth);
	   call PATH_handler (Ppath.dir, sn, Ppath.ent_type, "", action);
	   if action = HANDLER_EXPAND_DONT_COUNT | action = HANDLER_DONT_COUNT then
	      call PATH_MATCH_ENTRY_remove();
	   end;
	go to NEXT_ENTRY;

TYPE (fs_star_MSF_COMP):
	if ((so.entry_type.msf_comps & ENTRY_DONT_RETURN) = ENTRY_DONT_RETURN) then;
	else do;
	   call PATH_MATCH_ENTRY_add (ENTRY_TYPE_MSF_COMP, Pdepth);
	   call PATH_handler (Ppath.dir, sn, Ppath.ent_type, "", action);
	   if action = HANDLER_EXPAND_DONT_COUNT | action = HANDLER_DONT_COUNT then
	      call PATH_MATCH_ENTRY_remove();
	   end;
	go to NEXT_ENTRY;

TYPE (fs_star_ARCHIVE):
	if ((so.entry_type.archives & ENTRY_DONT_RETURN) = ENTRY_DONT_RETURN) then
	   action = HANDLER_OK;
	else do;
	   call PATH_MATCH_ENTRY_add (ENTRY_TYPE_ARCHIVE, Pdepth);
	   call PATH_handler (Ppath.dir, sn, Ppath.ent_type, "", action);
	   if action = HANDLER_EXPAND_DONT_COUNT | action = HANDLER_DONT_COUNT then
	      call PATH_MATCH_ENTRY_remove();
	   end;
	if (((so.entry_type.archives & ENTRY_LIST_SUBENTRIES) = ENTRY_LIST_SUBENTRIES) &
	   (action ^= HANDLER_DONT_EXPAND)) |
	   (action = HANDLER_EXPAND) | (action = HANDLER_EXPAND_DONT_COUNT) then do;
	   path = Ppath;
	   path.ent(1) = sn(nameX);
	   path.ent_type = STAR_TYPE_USE_PL1_COMPARE;
	   if path.comp = "" then do;
	      path.comp = "**";
	      path.comp_type = STAR_TYPE_MATCHES_EVERYTHING;
	      end;
	   call ARCHIVE_PATH_expand (Pdepth+1, addr(free_area), path, sn, Psort_order);
	   end;
	go to NEXT_ENTRY;

TYPE (star_DIRECTORY):
	call fs_util_$get_type (Ppath.dir, sn(1), fs_util_type, code);
	if code = 0 then do;			/* We could determine if a dir is really */
	   if fs_util_type = ENTRY_TYPE_MSF then	/*  an MSF or DM file, but fs_util_ does */
	      go to TYPE (fs_star_MSF);		/*  it better.  Don't reinvent the wheel.*/
	   if fs_util_type = ENTRY_TYPE_DM_FILE then
	      go to TYPE (fs_star_DM_FILE);
	   if ((so.entry_type.dirs & ENTRY_INAEE) = ENTRY_INAEE) then
	      if fs_util_type ^= ENTRY_TYPE_DIRECTORY then
	         go to TYPE (fs_star_EXTENDED_ENTRY);	/* Only report extended entries if caller*/
	   end;					/*  asked for these.		 */
	if ((so.entry_type.dirs & ENTRY_DONT_RETURN) = ENTRY_DONT_RETURN) then
	   action = HANDLER_OK;			/* Report directory to caller.	 */
	else do;
	   call PATH_MATCH_ENTRY_add (ENTRY_TYPE_DIRECTORY, Pdepth);
	   call PATH_handler (Ppath.dir, sn, Ppath.ent_type, "", action);
	   if action = HANDLER_EXPAND_DONT_COUNT | action = HANDLER_DONT_COUNT then
	      call PATH_MATCH_ENTRY_remove();
	   end;
	if (((so.entry_type.dirs & ENTRY_LIST_SUBENTRIES) = ENTRY_LIST_SUBENTRIES) &
	   (action ^= HANDLER_DONT_EXPAND)) |		/* Expand, if caller asked us to.	 */
	   (action = HANDLER_EXPAND) | (action = HANDLER_EXPAND_DONT_COUNT) then do;
	   path.dir =  rtrim(pathname_(Ppath.dir, sn(1)));
	   path.dir_type = STAR_TYPE_USE_PL1_COMPARE;
	   path.dir_uid = ""b;
	   path.ent(1) = "**";
	   path.ent_type = STAR_TYPE_MATCHES_EVERYTHING;
	   path.comp = "";
	   path.comp_type = STAR_TYPE_USE_PL1_COMPARE;
	   call PATH_expand (Pdepth+1, NOT_MSF, Pfree_areaP, path, Psort_order);
	   end;
	go to NEXT_ENTRY;

TYPE (fs_star_MSF):
	if ((so.entry_type.msfs & ENTRY_DONT_RETURN) = ENTRY_DONT_RETURN) then 
	   action = HANDLER_OK;
	else do;
	   call PATH_MATCH_ENTRY_add (ENTRY_TYPE_MSF, Pdepth);
	   call PATH_handler (Ppath.dir, sn, Ppath.ent_type, "", action);
	   if action = HANDLER_EXPAND_DONT_COUNT | action = HANDLER_DONT_COUNT then
	      call PATH_MATCH_ENTRY_remove();
	   end;
	if (((so.entry_type.msfs & ENTRY_LIST_SUBENTRIES) = ENTRY_LIST_SUBENTRIES) &
	   (action ^= HANDLER_DONT_EXPAND)) |
	   (action = HANDLER_EXPAND) | (action = HANDLER_EXPAND_DONT_COUNT) then do;
	   path.dir =  rtrim(pathname_(Ppath.dir, sn(1)));
	   path.dir_type = STAR_TYPE_USE_PL1_COMPARE;
	   path.dir_uid = ""b;
	   path.ent(1) = "**";
	   path.ent_type = STAR_TYPE_MATCHES_EVERYTHING;
	   path.comp = "";
	   path.comp_type = STAR_TYPE_USE_PL1_COMPARE;
	   call PATH_expand (Pdepth+1, IS_MSF, Pfree_areaP, path, Psort_order);
	   end;
	go to NEXT_ENTRY;

TYPE (fs_star_DM_FILE):
	if ((so.entry_type.dm_files & ENTRY_DONT_RETURN) = ENTRY_DONT_RETURN) then 
	   go to NEXT_ENTRY;
	call PATH_MATCH_ENTRY_add (ENTRY_TYPE_DM_FILE, Pdepth);
	call PATH_handler (Ppath.dir, sn, Ppath.ent_type, "", action);
	if action = HANDLER_EXPAND_DONT_COUNT | action = HANDLER_DONT_COUNT then
	   call PATH_MATCH_ENTRY_remove();
	go to NEXT_ENTRY;

TYPE (fs_star_EXTENDED_ENTRY):
	if ((so.entry_type.extended_entries & ENTRY_DONT_RETURN) = ENTRY_DONT_RETURN) then 
	   go to NEXT_ENTRY;
	call PATH_MATCH_ENTRY_add (fs_util_type, Pdepth);
	call PATH_handler (Ppath.dir, sn, Ppath.ent_type, "", action);
	if action = HANDLER_EXPAND_DONT_COUNT | action = HANDLER_DONT_COUNT then
	   call PATH_MATCH_ENTRY_remove();
	go to NEXT_ENTRY;	

REMOVE_ENTRY:
	call PATH_MATCH_ENTRY_remove();

NEXT_ENTRY:
	end;

       if star_names_ptr ^= addr(ROOT_NAME) then do;
	if star_names_ptr ^= null then
	   free star_names in (free_area);
	if star_entry_ptr ^= null then
	   free star_entries in (free_area);
	end;
       end;
    return;

REMOVE_ENTRY_AND_EXIT:
    call PATH_MATCH_ENTRY_remove();
    go to SELECT_EXIT;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

PATH_expand_error:
    entry (Pdepth, Pcode_in, Ppath, Pent_type, Pmessage, Pioa_arg);

dcl  Pcode_in			fixed bin(35) parm;
dcl  Pent_type			fixed bin(2) parm;
dcl  Pmessage			char(*) parm;
dcl  Pioa_arg			fixed bin(2) parm;

    call PATH_error (Pdepth, Pcode_in, Ppath.dir, Ppath.ent, Pent_type, Ppath.comp, Pmessage, Pioa_arg);
    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */
/*										 */
/* SUPPORT PROCEDURE: PATH_error							 */
/*   If Pcode_in = 0, then return.							 */
/*   Otherwise, expand error message and invoke caller's error handler.			 */
/*   If caller did not provide an error handler, then print error ourselves.			 */
/*   If caller's action code is ERROR_OK or ERROR_REJECT, then continue by processing the next	 */
/*     pathname.									 */
/*   If his action code is ERROR_STOP or ERROR_ABORT, then set Pcode parm of $select and do nonlocal */
/*     transfer to exit immediately from fs_star_.					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */

PATH_error:
    procedure (Pdepth, Pcode_in, Pdir, Pent, Pent_type, Pcomp, Pmessage, Pioa_arg);

dcl  Pdepth			fixed bin parm;
dcl  Pcode_in			fixed bin(35) parm;
dcl  Pdir				char(*) parm;
dcl  Pent				(*) char(32) unal parm;
dcl  Pent_type			fixed bin(2) parm;
dcl  Pcomp			char(32) parm;
dcl  Pmessage			char(*) parm;
dcl  Pioa_arg			fixed bin(2) parm;

dcl  action			fixed bin auto;
dcl  code				fixed bin(35) auto;
dcl  expanded_message		char(200) varying;

    if Pcode_in = 0 then return;

    star_data.entry_data.depth = Pdepth;
    call ioa_$rsnpnnl (Pmessage, expanded_message, 0, Pioa_arg);

    if so.error = ssu_$null_entry then do;		/* caller did NOT provide an error	 */
       call ssu_$print_message (ssu_sciP, Pcode_in, "^[ in ^a ^;^s^]^[^a^s^;^s^a^]^[^/(^a)^;^s^]",
	sd.entry_data.type ^= ENTRY_TYPE_UNKNOWN, ltrim(sd.entry_data.type,"-"),
	Pent(lbound(Pent,1))="", Pdir, pathname_$component (Pdir, Pent(lbound(Pent,1)), Pcomp),
	expanded_message^="", expanded_message);
       action = ERROR_REJECT;
       end;
    else do; 
       if Pent_type = NO_NAMES | Pent_type = STAR_TYPE_MATCHES_EVERYTHING then do;
	call so.error (addr(star_data), Pdir, Pent, Pcomp, Pcode_in, (expanded_message), action);
	end;
       else do;					/* hcs_$star_ returns only entry names 	 */
	status_area_ptr = TEMP_AREA_get();		/*  which match the star name.  We must	 */
	status_ptr = addr(auto_status);		/*  return all names, so get them now.	 */
	call hcs_$status_ (Pdir, Pent(1), NO_CHASE, status_ptr, status_area_ptr, code);
	if code = 0 then do;
	   call so.error (addr(star_data), Pdir, status_names, Pcomp, Pcode_in,
	      (expanded_message), action);
	   free status_entry_names in (status_area);
	   end;
	else
	   call so.error (addr(star_data), Pdir, Pent, Pcomp, Pcode_in, (expanded_message), action);
	end;
       end;

    if Pent_type = NO_NAMES then do;			/* Caller has not entered do-group to	 */
						/*  process entries from hcs_$star_.	 */
       if action = ERROR_STOP | action = ERROR_ABORT then	/* Only honor STOP/ABORT action, by 	 */
	go to SELECT_EXIT;				/*  exiting fs_star_$select; otherwise	 */
       else return;					/*  just return to caller, who will 	 */
       end;					/*  continue with next input path.	 */
    
    else do;					/* Caller has entered do-group.	 */
       if action = ERROR_OK then			/*  Count errant entry.		 */
	go to NEXT_ENTRY;
       else if action = ERROR_REJECT then		/*  Remove errant entry from count.	 */
	go to REMOVE_ENTRY;
       else if action = ERROR_STOP then			/*  Exit fs_star_$select immediately.	 */
	go to SELECT_EXIT;
       else if action = ERROR_ABORT then		/*  Remove errant entry from count, then */
	go to REMOVE_ENTRY_AND_EXIT;			/*   exit fs_star_$select.		 */
       else do;					/*  Unknown action code value.	 */
	call ssu_$print_message (ssu_sciP, error_table_$unsupported_operation,
	   "fs_star_ error routine returned unknown action code (=^d).", action);
	if Pcode = 0 then
	   Pcode = error_table_$unsupported_operation;
	go to SELECT_EXIT;
	end;
       end;
    end PATH_error;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE: PATH_handler							 */
/*   This procedure calls the caller-supplied star_options.handler procedure for each selected	 */
/*   entry.  The caller's handler may return an action code which controls how fs_star_ continues	 */
/*   in its processing of the entry.  Every PATH_handler caller must handle the following actions	 */
/*   in a manner appropriate to the type of entry:					 */
/*      HANDLER_DONT_EXPAND								 */
/*        no error, but handler does not want dir/archive/msf expanded.			 */
/*      HANDLER_EXPAND								 */
/*        no error, but expand dir/archive/msf even if this is contrary to what			 */
/*	star_options.entry_type says for this type of entry.				 */
/*      HANDLER_EXPAND_DONT_COUNT							 */
/*        no error, but handler does not accept the entry.  It should not be counted but should be	 */
/*	expanded.									 */
/*      HANDLER_DONT_COUNT								 */
/*        no error, but handler does not want entry counted.  Expansion depends upon what		 */
/*	star_options.entry_type says for this type of entry.				 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

PATH_handler:
    procedure (Pdir, Pents, Pent_type, Pcomp, Paction);

dcl  Pdir				char(168) parm;
dcl  Pents			(*) char(32) unal parm;
dcl  Pent_type			fixed bin(2) parm;
dcl  Pcomp			char(32) parm;
dcl  Paction			fixed bin parm;
dcl  code				fixed bin(35) auto;

    if Pent_type = NO_NAMES | Pent_type = STAR_TYPE_MATCHES_EVERYTHING then do;
       if ^SELECT_further (star_data.entry_data.type, Pents) then
	Paction = HANDLER_DONT_COUNT;
       else
	call so.handler (addr(star_data), Pdir, Pents, Pcomp, Paction);
       end;
    else do;					/* hcs_$star_ returns only names which	 */
       status_area_ptr = TEMP_AREA_get();		/*  match the star name.  We must return */
       status_ptr = addr(auto_status);			/*  all names, so get them now.	 */
       call hcs_$status_ (Pdir, Pents(1), NO_CHASE, status_ptr, status_area_ptr, code);
       if code = 0 then do;
	if ^SELECT_further (star_data.entry_data.type, status_names) then
	   Paction = HANDLER_DONT_COUNT;
	else 
	   call so.handler (addr(star_data), Pdir, status_names, Pcomp, Paction);
	free status_entry_names in (status_area);
	end;
       else do;
	if ^SELECT_further (star_data.entry_data.type, Pents) then
	   Paction = HANDLER_DONT_COUNT;
	else
	   call so.handler (addr(star_data), Pdir, Pents, Pcomp, Paction);
	end;
       end;

    if Paction = HANDLER_OK then
       return;
    else if Paction = HANDLER_REJECT then
       go to REMOVE_ENTRY;
    else if Paction = HANDLER_DONT_EXPAND then;		/* These 4 action codes must be 	 */
    else if Paction = HANDLER_EXPAND then;		/*  handled by			 */
    else if Paction = HANDLER_EXPAND_DONT_COUNT then;	/*  each caller of			 */
    else if Paction = HANDLER_DONT_COUNT then;		/*  PATH_handler.			 */
    else if Paction = HANDLER_STOP then
       go to SELECT_EXIT;
    else if Paction = HANDLER_ABORT then
       go to REMOVE_ENTRY_AND_EXIT;
    else
       call SELECT_error (error_table_$unsupported_operation,
       "fs_star_ handler routine returned unknown action code (=^d).", Paction);

    end PATH_handler;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE:  PATH_suffix							 */
/*   This procedure determines whether a given entry name ends in a given suffix (eg, .archive).	 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

PATH_suffix:
    procedure (Pname, Psuffix) returns (bit(1) aligned);

dcl  Pname			char(32) unal parm;
dcl  Psuffix			char(*) parm;
    
dcl  nameL			fixed bin auto;
dcl  suffixL			fixed bin auto;
dcl  suffixI			fixed bin auto;

    nameL = length (rtrim (Pname));
    suffixL = length (rtrim (Psuffix));
    suffixI = max(1, nameL - suffixL + 1);
    if substr(Pname, suffixI) = substr(Psuffix, 1, suffixL) then
       return (TRUE);
    else
       return (FALSE);
    end PATH_suffix;

    end PATH_expand;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURES:  PATH_MATCH_ENTRY_add, PATH_MATCH_ENTRY_remove				 */
/*   These procedure entry points add/remove the current entry to the entry counts in		 */
/* star_data.matched.  _add takes an Pentry_type parameter, stores it in star_data.entry_data.type,	 */
/* and then increments the corresponding element of star_data.matched.  _remove uses		 */
/* star_data.entry_data.type to decrement the corresponding element of star_data.matched.		 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

PATH_MATCH_ENTRY_add:
    procedure (Pentry_type, Pdepth);
    
dcl  Pentry_type			char(32) unal parm;
dcl  Pdepth			fixed bin parm;

dcl  addend			fixed bin auto;
dcl  entry_type			char(32) auto;

    entry_type, sd.entry_data.type = Pentry_type;
    sd.entry_data.depth = Pdepth;
    addend = +1;
    go to SET_MATCHED;
    
PATH_MATCH_ENTRY_remove:
    entry;
    
    entry_type = sd.entry_data.type;
    sd.entry_data.type = ENTRY_TYPE_UNSET;
    addend = -1;
    go to SET_MATCHED;

SET_MATCHED:
    sd.matched.current = sd.matched.current + addend;
    if entry_type = ENTRY_TYPE_LINK then
       sd.matched.links = sd.matched.links + addend;
    else if entry_type = ENTRY_TYPE_SEGMENT then
       sd.matched.segs = sd.matched.segs + addend;
    else if entry_type = ENTRY_TYPE_DIRECTORY then
       sd.matched.dirs = sd.matched.dirs + addend;
    else if entry_type = ENTRY_TYPE_MSF then
       sd.matched.msfs = sd.matched.msfs + addend;
    else if entry_type = ENTRY_TYPE_MSF_COMP then
       sd.matched.msf_comps = sd.matched.msf_comps + addend;
    else if entry_type = ENTRY_TYPE_DM_FILE then
       sd.matched.dm_files = sd.matched.dm_files + addend;
    else if entry_type = ENTRY_TYPE_ARCHIVE then
       sd.matched.archives = sd.matched.archives + addend;
    else if entry_type = ENTRY_TYPE_ARCHIVE_COMP then
       sd.matched.arch_comps = sd.matched.arch_comps + addend;
    else
       sd.matched.extended_entries = sd.matched.extended_entries + addend;

    end PATH_MATCH_ENTRY_add;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE: SELECT_error							 */
/*   If Pcode_in = 0, then return.							 */
/*   Otherwise, expand error message and invoke caller's error handler.  Ignore his action code,	 */
/*     since calls to SELECT_error are always immediately fatal.				 */
/*   If caller did not provide an error handler, then print error ourselves.			 */
/*   Set Pcode parm of $select and do nonlocal transfer to exit immediately from fs_star_.	 */
/*										 */
/* Syntax:  call SELECT_error (code, IOA_CTL_STR, args);					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

SELECT_error:
    procedure options(variable);

dcl  Pcode_inP			ptr auto;		/* AUTOMATIC			 */
dcl  action			fixed bin auto;
dcl  code				fixed bin(35) auto;
dcl  message_space			char(500);
dcl  message_len			fixed bin(21);

						/* BASED				 */
dcl  Pcode_in			fixed bin(35) based (Pcode_inP);
dcl  message			char (message_len) based (addr(message_space));

						/* NAMED CONSTANTS			 */
dcl (DONT_PAD, DONT_NL)		init ("0"b) bit(1) aligned int static options(constant);

    call cu_$arg_ptr (1, Pcode_inP, 0, code);
    if Pcode_in = 0 then return;

    call ioa_$general_rs (cu_$arg_list_ptr(), 2, 3, message_space, message_len, DONT_PAD, DONT_NL);

    if so.error = ssu_$null_entry then 
       call ssu_$print_message (ssu_sciP, Pcode_in, message);
    else
       call so.error (addr(star_data), "", "", "", Pcode_in, message, action);
						/* Ignore action here, since all calls	 */
						/* to this procedure are fatal if 	 */
						/* Pcode_in is nonzero.		 */
   if Pcode = 0 then
       Pcode = Pcode_in;
    go to SELECT_EXIT;
    end SELECT_error;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE: SELECT_further							 */
/*   This function makes further checks on selected entries to determine whether they are selected	 */
/* by values in the match_names structure, excluded by values in the exclude_names structure, and	 */
/* selected by values in the extended_entry_types structure.				 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

SELECT_further:
    procedure (Pentry_type, Pnames) returns(bit(1) aligned);

dcl  Pentry_type			char(32) unal parm;
dcl  Pnames			(*) char(32) unal parm;

dcl (nameX, matchX)			fixed bin auto;

    if fsd.mnP ^= null then do;
       do nameX = lbound(Pnames,1) to hbound(Pnames,1);
	do matchX = lbound(mn.value,1) to hbound(mn.value,1);
	   go to MATCH(mn.type(matchX));
	   
MATCH (STAR_TYPE_USE_PL1_COMPARE):
	   if Pnames(nameX) = mn.value(matchX) then
	      go to MATCH_FOUND;
	   go to MATCH_NEXT;

MATCH (STAR_TYPE_USE_MATCH_PROCEDURE):
	   call match_star_name_ (Pnames(nameX), mn.value(matchX), code);
	   if code = 0 then
	      go to MATCH_FOUND;
	   go to MATCH_NEXT;
	   
MATCH_NEXT:  end;
	end;
       return (FALSE);
       end;
MATCH_FOUND:
MATCH (STAR_TYPE_MATCHES_EVERYTHING):

    if fsd.exnP ^= null then do;
       do nameX = lbound(Pnames,1) to hbound(Pnames,1);
	do matchX = lbound(exn.value,1) to hbound(exn.value,1);
	   go to EXCL(exn.type(matchX));
	   
EXCL (STAR_TYPE_USE_PL1_COMPARE):
	   if Pnames(nameX) = exn.value(matchX) then
	      go to EXCL_FOUND;
	   go to EXCL_NEXT;

EXCL (STAR_TYPE_USE_MATCH_PROCEDURE):
	   call match_star_name_ (Pnames(nameX), exn.value(matchX), code);
	   if code = 0 then
	      go to EXCL_FOUND;
	   go to EXCL_NEXT;
	   
EXCL_NEXT:   end;
	end;
       go to EXCL_NOT_FOUND;
EXCL_FOUND:
EXCL (STAR_TYPE_MATCHES_EVERYTHING):
       return (FALSE);
       end;
EXCL_NOT_FOUND:

    if so.extended_entry_typesP ^= null then do;
       if extended_entry_types.count > 0 then do;
	do matchX = lbound(extended_entry_types.value,1) to extended_entry_types.count;
	   if Pentry_type = extended_entry_types.value(matchX) then
	      go to ET_OK;
	   end;
	return (FALSE);
	end;
       end;
ET_OK:
    return (TRUE);

    end SELECT_further;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SELECT_further_init:								 */
/*   This procedure copies match_names.value and exclude_names.value arrays into mn and exn	 */
/* structures, in order to associate a starname type with each array element.  Any errors in format	 */
/* of the star names are reported via SELECT_error.					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

SELECT_further_init:
    procedure();

dcl  code				fixed bin(35) auto;
dcl  matchX			fixed bin auto;

    if so.exclude_namesP ^= null then do;
       if exclude_names.version ^= STAR_EXCLUDE_NAMES_VERSION_1 then
	call SELECT_error (error_table_$unimplemented_version,
	   "exclude_names.version (=""^a"") must be STAR_EXCLUDE_NAMES_VERSION_1 (=""^a"").",
	   exclude_names.version, STAR_EXCLUDE_NAMES_VERSION_1);
       if exclude_names.count > 0 then do;
	call STRUCT_allocate ("exn", EXN_VERSION_1, exclude_names.count, EP_SELECT);
	do matchX = lbound(exn.array,1) to hbound(exn.array,1);
	   exn.value(matchX) = exclude_names.value(matchX);
	   call check_star_name_ (exn.value(matchX), CHECK_STAR_ENTRY_DEFAULT, exn.type(matchX),code);
	   call SELECT_error (code, "Invalid exclude_names.value ^a", exn.value(matchX));
	   end;
	end;
       end;

    if so.match_namesP ^= null then do;
       if match_names.version ^= STAR_MATCH_NAMES_VERSION_1 then
	call SELECT_error (error_table_$unimplemented_version,
	   "match_names.version (=""^a"") must be STAR_MATCH_NAMES_VERSION_1 (=""^a"").",
	   match_names.version, STAR_MATCH_NAMES_VERSION_1);
       if match_names.count > 0 then do;
	call STRUCT_allocate ("mn", MN_VERSION_1, match_names.count, EP_SELECT);
	do matchX = lbound(mn.array,1) to hbound(mn.array,1);
	   mn.value(matchX) = match_names.value(matchX);
	   call check_star_name_ (mn.value(matchX), CHECK_STAR_ENTRY_DEFAULT, mn.type(matchX), code);
	   call SELECT_error (code, "Invalid match_names.value ^a", mn.value(matchX));
	   end;
	end;
       end;

    if so.extended_entry_typesP ^= null then do;
       if extended_entry_types.version ^= STAR_EXTENDED_ENTRY_VERSION_1 then
	call SELECT_error (error_table_$unimplemented_version,
	   "extended_entry_types.version (=""^a"") must be STAR_EXTENDED_ENTRY_VERSION_1(=""^a"").",
	   extended_entry_types.version, STAR_EXTENDED_ENTRY_VERSION_1);
       end;

    end SELECT_further_init;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE: STAR_PATHS_evaluate						 */
/*   Procedure which analyzes incoming star_paths.value array, expanding each pathname, breaking it	 */
/*   down into dir/ent/arch_comp parts, determining the star-type of each part, etc.  Directory star */
/*   names are not fully supported; archive component names are rejected, though full analysis	 */
/*   support for archive component names IS provided below.  (It is missing in other internal	 */
/*   procedures, however.)  Duplicate pathnames are eliminated, as final step in the evaluation.	 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

STAR_PATHS_evaluate:
    procedure();

dcl  code				fixed bin(35) auto,
    (pathX, prevX, star_pathX)	fixed bin auto;

    if ((so.path_allow & PATH_ALLOW_DIR_STAR_NAMES) = PATH_ALLOW_DIR_STAR_NAMES) then
						/* diagnose path support not implemented */
						/* in phase 1.			 */
       call SELECT_error (error_table_$unsupported_operation,
	"star_options.path_allow does not support directory star names.");

    if so.star_pathsP = null then			/* diagnose input pathname errors	 */
       call SELECT_error (error_table_$argerr, "star_options.star_pathsP is a null pointer.");
    if star_paths.count > star_paths.max_count then
       call SELECT_error (error_table_$inconsistent,
         "star_paths.count (=^d) > star_paths.max_count (=^d)", star_paths.count, star_paths.max_count);
    if star_paths.count <= 0 then
       call SELECT_error (error_table_$argerr,
         "star_paths.count (=^d) must be positive.", star_paths.count);

    call STRUCT_allocate ("evaluated_paths", EPATH_VERSION_1, star_paths.count, EP_SELECT);

    call STAR_PATHS_error_init();
    
    pathX = 0;
    do star_pathX = lbound(star_paths.value,1) to star_paths.count;
       epath.count, pathX = pathX + 1;
       call expand_pathname_$component (star_paths.value(star_pathX), epath.dir(pathX),
	epath.ent(pathX,1), epath.comp(pathX), code);
       call STAR_PATHS_error (code, ENTRY_TYPE_UNKNOWN, star_paths.value(star_pathX), "", "", "");


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* Directory star names (ie, stars in any directory entry name except the last) are not fully	 */
/* implemented in phase 1 of fs_star_.  When implemented, dir stars should probably be expanded	 */
/* here.  This would mean the epath.value array could be larger than star_path.value.  Its size will */
/* have to be increased (to full seg) above, epath.count will have to be compared to		 */
/* epath.max_count, and structure size will have to be adjusted downward once all epath entries are	 */
/* set.										 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

       if (search(epath.dir(pathX), "*?") > 0) &
	^((so.path_allow & PATH_ALLOW_DIR_STAR_NAMES) = PATH_ALLOW_DIR_STAR_NAMES) then do;
	epath.dir_type(pathX) = STAR_TYPE_USE_MATCH_PROCEDURE;
	call STAR_PATHS_error (error_table_$nostars, ENTRY_TYPE_UNKNOWN,
	   epath.dir(pathX), epath.ent(pathX,*), epath.comp(pathX), "invalid directory star name");
	end;
       else
	epath.dir_type(pathX) = STAR_TYPE_USE_PL1_COMPARE;
       call hcs_$get_uid_file (epath.dir(pathX), "", epath.dir_uid(pathX), code);
       if code = error_table_$root then
	epath.dir_uid(pathX) = "777777777777"b3;
       else 
	call STAR_PATHS_error (code, ENTRY_TYPE_UNKNOWN, epath.dir(pathX), "", "", "");

       call check_star_name_ (epath.ent(pathX,1), CHECK_STAR_ENTRY_DEFAULT, epath.ent_type(pathX),
	code);
       if (code = error_table_$null_name_component) & (epath.dir(pathX) = ">") then
	epath.ent_type(pathX) = STAR_TYPE_USE_PL1_COMPARE;
       else
	call STAR_PATHS_error (code, ENTRY_TYPE_UNKNOWN, epath.dir(pathX), epath.ent(pathX,*),
	   epath.comp(pathX), "invalid entryname");
       if (epath.ent_type(pathX) ^= STAR_TYPE_USE_PL1_COMPARE) &
	^((so.path_allow & PATH_ALLOW_ENTRY_STAR_NAMES) = PATH_ALLOW_ENTRY_STAR_NAMES) then
	   call STAR_PATHS_error (error_table_$nostars, ENTRY_TYPE_UNKNOWN,
	      epath.dir(pathX), epath.ent(pathX,*), epath.comp(pathX), "invalid entryname");

       if epath.comp(pathX) ^= "" then do;
	if ^((so.path_allow & PATH_ALLOW_ARCHIVE_COMPONENTS) = PATH_ALLOW_ARCHIVE_COMPONENTS) then
	   call STAR_PATHS_error (error_table_$archive_pathname, ENTRY_TYPE_UNKNOWN,
	      epath.dir(pathX), epath.ent(pathX,*), epath.comp(pathX), "");
	call check_star_name_ (epath.comp(pathX), CHECK_STAR_ENTRY_DEFAULT,
	   epath.comp_type(pathX), code);
	call STAR_PATHS_error (code, ENTRY_TYPE_UNKNOWN, epath.dir(pathX),
	   epath.ent(pathX,*), epath.comp(pathX), "invalid archive component name");
	if (epath.comp_type(pathX) ^= STAR_TYPE_USE_PL1_COMPARE) &
	   ^((so.path_allow & PATH_ALLOW_ARCHIVE_COMP_STAR_NAMES) = PATH_ALLOW_ARCHIVE_COMP_STAR_NAMES) then
	   call STAR_PATHS_error (code, ENTRY_TYPE_UNKNOWN, epath.dir(pathX), epath.ent(pathX,*),
	      epath.comp(pathX), "invalid archive star name");
	end;
       else
	epath.comp_type(pathX) = STAR_TYPE_USE_PL1_COMPARE;

       do prevX = lbound(epath.value,1) to pathX-1;	/* eliminate dup dir/ent/comp names	 */
	if epath.dir_uid(prevX) = epath.dir_uid(pathX) then do;
	   if epath.ent(prevX,1)  = epath.ent(pathX,1) |
	     (epath.ent_type(prevX) = STAR_TYPE_MATCHES_EVERYTHING &
	      epath.ent_type(pathX) = STAR_TYPE_MATCHES_EVERYTHING) then do;
	      if epath.comp(prevX) = epath.comp(pathX) |
	        (epath.comp_type(prevX) = STAR_TYPE_MATCHES_EVERYTHING &
	         epath.comp_type(pathX) = STAR_TYPE_MATCHES_EVERYTHING) then do;
	         epath.count, pathX = pathX - 1;
	         end;
	      end;
	   end;
	end;

NEXT_PATH:
       end;

    call STAR_PATHS_error_conditional_exit();
    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */
/*										 */
/* SUPPORT PROCEDURE: STAR_PATHS_error							 */
/*   If Pcode_in = 0, then return.							 */
/*   Otherwise, expand error message and invoke caller's error handler.			 */
/*   If caller did not provide an error handler, then print error ourselves.			 */
/*   If caller's action code is ERROR_OK or ERROR_REJECT, then continue by processing the next	 */
/*     pathname.									 */
/*   If his action code is ERROR_STOP or ERROR_ABORT, then set Pcode parm of $select and do nonlocal */
/*     transfer to exit immediately from fs_star_.					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */

dcl  star_paths_error		bit(1);

STAR_PATHS_error:
    procedure (Pcode_in, Pentry_type, Pdir, Pent, Pcomp, Pmessage);

dcl  Pcode_in			fixed bin(35) parm;
dcl  Pentry_type			char(32) parm;
dcl  Pdir				char(*) parm;
dcl  Pent				(1) char(32) unal parm;
dcl  Pcomp			char(32) parm;
dcl  Pmessage			char(*) parm;

dcl  action			fixed bin auto;
dcl  saved_entry_type		char(32) auto;

    if Pcode_in = 0 then return;
    if Pcode = 0 then
       Pcode = Pcode_in;

    star_paths_error = TRUE;
    if so.error = ssu_$null_entry then do;		/* caller did NOT provide an error	 */
       call ssu_$print_message (ssu_sciP, Pcode_in, "^[^a^s^;^s^a^]^[^/(^a)^]",
	Pent(1)="", Pdir, pathname_$component (Pdir, Pent(1), Pcomp), Pmessage^="", Pmessage);
       go to NEXT_PATH;       			/* routine. We will report all errors	 */
       end;					/* before exiting.			 */

    saved_entry_type = sd.entry_data.type;
    sd.entry_data.type = Pentry_type;
    call so.error (addr(star_data), Pdir, Pent, Pcomp, Pcode_in, Pmessage, action);
    sd.entry_data.type = saved_entry_type;

    if action = ERROR_OK | action = ERROR_REJECT then
       go to NEXT_PATH;
    go to SELECT_EXIT;
    end STAR_PATHS_error;

STAR_PATHS_error_init:
    procedure();
    star_paths_error = FALSE;
    return;
    
STAR_PATHS_error_conditional_exit:
    entry();
    if star_paths_error then
       go to SELECT_EXIT;
    return;
    end STAR_PATHS_error_init;

    end STAR_PATHS_evaluate;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ENTRY POINT: term								 */
/*   Cleans up from the fs_star_ operations by releasing all associated storage created by ssu_, and */
/*   by destroying the ssu_ invocation use by fs_star_ (if fs_star_ created it on the caller's	 */
/*   behalf).									 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

term:
    entry (Pstar_optionsP);
    
    if Pstar_optionsP = null then return;

    call ENTRY_POINT_setup (EP_TERM);
    
    call FSD_reinit();
    if fsd.we_created_ssuS then
       call ssu_$destroy_invocation (ssu_sciP);
    else 
       call ssu_$release_temp_segment (ssu_sciP, star_optionsP);
    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */
/*										 */
/* SUPPORT PROCEDURES for all entrypoints:						 */
/*										 */
/* SUPPORT PROCEDURE: ENTRY_POINT_setup							 */
/*   initialize pointers to all important structures.					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */

ENTRY_POINT_setup:
    procedure (Pcalling_ep);

dcl  Pcalling_ep			fixed bin parm;

    star_optionsP = Pstar_optionsP;			/* access fixed structures		 */
    if star_optionsP = null then do;
       if Pcalling_ep = EP_ADJUST then
	call ADJUST_error (error_table_$argerr);
       else if Pcalling_ep = EP_SELECT then
	call SELECT_error (error_table_$argerr, "star_optionsP parameter is a null pointer.");
       else
	call ERROR_unexpected (error_table_$argerr, EP_NAME(Pcalling_ep), ACTION_CANT_RESTART,
	   null, 0, "star_optionsP parameter is a null pointer.");
       end;
    else if star_options.version ^= STAR_OPTIONS_VERSION_1 then do;
       if Pcalling_ep = EP_ADJUST then
	call ADJUST_error (error_table_$unimplemented_version);
       else if Pcalling_ep = EP_SELECT then
	call SELECT_error (error_table_$unimplemented_version,
	   "star_options.version (=^a) must be STAR_OPTIONS_VERSION_1 (=^a).",
	   star_options.version, STAR_OPTIONS_VERSION_1);
       else
	call ERROR_unexpected (error_table_$unimplemented_version, EP_NAME(Pcalling_ep),
	   ACTION_CANT_RESTART, null, 0,
	   "star_options.version (=^a) must be STAR_OPTIONS_VERSION_1 (=^a).",
	   star_options.version, STAR_OPTIONS_VERSION_1);	   
       end;

    ssu_sciP = so.ssu_sciP;
    fsdP = so.fs_star_dataP;

    end ENTRY_POINT_setup;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE:  ERROR_unexpected							 */
/*   This procedure makes a final effort to abort in a meaningful way, when all else fails.  It	 */
/*   calls sub_err_ to report an unexpected condition to the user.  Its calling sequence is the same */
/*   as sub_err_.									 */
/*										 */
/* Syntax: call ERROR_unexpected (code, name, sub_err_flag, info_ptr, retal, ioa_ctl_str, ioa_args); */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

ERROR_unexpected:
    procedure options (variable);
    
dcl  argsN			fixed bin auto;
dcl  code				fixed bin(35) auto;

    call cu_$arg_count (argsN, code);
    if argsN = 0 then				/* ssu_$standalone_invocation abort.	 */
       call sub_err_ (error_table_$fatal_error, "fs_star_", ACTION_CANT_RESTART, null, 0,
          "fs_star_'s ssu_ standalone invocation aborted.");
    else
       call cu_$generate_call (sub_err_, cu_$arg_list_ptr());
    end ERROR_unexpected;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE:  FSD_init							 */
/*   This procedure initializes the fs_star_ internal data structure, fsd.			 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

FSD_init:
    procedure();

    so.caller.fs_star_dataP,
    fsdP = STRUCT_get_space ("fsd", size(fsd), EP_INIT);	/* create fs_star_ data structure in	 */
    fsd.version = FSD_VERSION_1;			/*  temp seg following star_options.	 */
    call STRUCT_get_next_space (addr(fsd), currentsize(fsd));
    fsd.we_created_ssuS = standalone_invocationS;		/* initialize the structure so	 */
    fsd.fsd_pad = 0;				/*  $adjust_structure_size will work.	 */
    fsd.star_dataP = null;
    fsd.archP = null;
    fsd.epathP = null;
    fsd.mnP = null;
    fsd.exnP = null;
    fsd.temp_segsP(*) = null;
    fsd.areasP(*) = null;
    return;
    

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE:  FSD_reinit							 */
/*   This support procedure entry point resets the fs_star_ internal data structure, fsd, to the	 */
/*   state it was set to by fs_star_$init.						 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

FSD_reinit:
    entry();

    fsd.version = FSD_VERSION_1;
    call STRUCT_get_next_space (addr(fsd), currentsize(fsd));
/*  fsd.we_created_ssuS 				   remains unchanged by $reinit.	 */
    fsd.fsd_pad = 0;
    fsd.star_dataP = null;
    if fsd.archP ^= null then				/* if an archive segment was initiated	 */
       call terminate_file_ (fsd.archP, 0,		/*  and not terminated (due to nonlocal	 */
	TERM_FILE_TERM, code);			/*  goto, then terminate it now.	 */
    fsd.epathP = null;
    fsd.mnP = null;
    fsd.exnP = null;
    call TEMP_SEGS_AREAS_term();			/* reset .temp_segsP and .areasP	 */
    call hcs_$truncate_seg (fsd.next_spaceP, wordno(fsd.next_spaceP), code);
						/* get rid of extra pages at end of temp */
    return;					/*  seg containing star_options structure*/
    end FSD_init;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE: STRUCT_allocate							 */
/*   Initializes space for a given structure, setting structure refer extents to maximum size if the */
/*   caller gives an array_size of 0.							 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

STRUCT_allocate:
    procedure (Pstruct_name, Pstruct_version, Pstruct_array_size, Pcalling_ep);

dcl  Pstruct_name			char(*) parm,
     Pstruct_version		char(8) parm,
     Pstruct_array_size		fixed bin parm,
     Pcalling_ep			fixed bin parm;

dcl  Pnew_struct			ptr auto,
     struct_elem_size		fixed bin auto;

    if Pstruct_version = EPATH_VERSION_1 then do;
       epath_size = Pstruct_array_size;
       if epath_size = 0 then do;
	epath_size = 1;
	struct_elem_size = size(epath) - size(struct_header);
	epath_size =
	   divide (sys_info$max_seg_size - currentsize(struct_header), struct_elem_size, 17, 0);
	end;
       if fsd.epathP = null then do;
	fsd.epathP, epathP = STRUCT_get_space (Pstruct_name, size(epath), Pcalling_ep);
	epath.version = Pstruct_version;
	epath.max_count = epath_size;
	epath.count = 0;
	call STRUCT_get_next_space (addr(epath), currentsize(epath));
	end;
       else do;
	epathP = fsd.epathP;
	Pnew_struct = STRUCT_get_space (Pstruct_name, size(epath), Pcalling_ep);
	Pnew_struct -> epath.version = Pstruct_version;
	Pnew_struct -> epath.max_count = epath.max_count;
	Pnew_struct -> epath.count = epath.count;
	if epath.count > 0 then
	   Pnew_struct -> epath.value = epath.value;
	Pnew_struct -> epath.max_count = epath_size;
	fsd.epathP, epathP = Pnew_struct;
	call STRUCT_get_next_space (addr(epath), currentsize(epath));
	end;
       end;

    else if Pstruct_version = STAR_EXCLUDE_NAMES_VERSION_1 then do;
       exclude_names_size = Pstruct_array_size;
       if exclude_names_size = 0 then do;
	exclude_names_size = 1;
	struct_elem_size = size(exclude_names) - size(struct_header);
	exclude_names_size =
	   divide (sys_info$max_seg_size - currentsize(struct_header), struct_elem_size, 17, 0);
	end;
       if so.exclude_namesP = null then do;
	so.exclude_namesP = STRUCT_get_space (Pstruct_name, size(exclude_names), Pcalling_ep);
	exclude_names.version = Pstruct_version;
	exclude_names.max_count = exclude_names_size;
	exclude_names.count = 0;
	call STRUCT_get_next_space (addr(exclude_names), currentsize(exclude_names));
	end;
       else do;
	Pnew_struct = STRUCT_get_space (Pstruct_name, size(exclude_names), Pcalling_ep);
	Pnew_struct -> exclude_names.version = Pstruct_version;
	Pnew_struct -> exclude_names.max_count = exclude_names.max_count;
	Pnew_struct -> exclude_names.count = exclude_names.count;
	if exclude_names.count > 0 then
	   Pnew_struct -> exclude_names.value = exclude_names.value;
	Pnew_struct -> exclude_names.max_count = exclude_names_size;
	so.exclude_namesP = Pnew_struct;
	call STRUCT_get_next_space (addr(exclude_names), currentsize(exclude_names));
	end;
       end;

    else if Pstruct_version = EXN_VERSION_1 then do;
       fsd.exnP = STRUCT_get_space (Pstruct_name, size(exn), Pcalling_ep);
       exn.version = Pstruct_version;
       exn.count = Pstruct_array_size;
       call STRUCT_get_next_space (addr(exn), currentsize(exn));
       exn.value(*) = "";
       exn.type(*) = STAR_TYPE_UNSET;
       end;

    else if Pstruct_version = STAR_EXTENDED_ENTRY_VERSION_1 then do;
       extended_entry_types_size = Pstruct_array_size;
       if extended_entry_types_size = 0 then do;
	extended_entry_types_size = 1;
	struct_elem_size = size(extended_entry_types) - size(struct_header);
	extended_entry_types_size =
	   divide (sys_info$max_seg_size - currentsize(struct_header), struct_elem_size, 17, 0);
	end;
       if so.extended_entry_typesP = null then do;
	so.extended_entry_typesP =
	   STRUCT_get_space (Pstruct_name, size(extended_entry_types), Pcalling_ep);
	extended_entry_types.version = Pstruct_version;
	extended_entry_types.max_count = extended_entry_types_size;
	extended_entry_types.count = 0;
	call STRUCT_get_next_space (addr(extended_entry_types), currentsize(extended_entry_types));
	end;
       else do;
	Pnew_struct =
	   STRUCT_get_space (Pstruct_name, size(extended_entry_types), Pcalling_ep);
	Pnew_struct -> extended_entry_types.version = Pstruct_version;
	Pnew_struct -> extended_entry_types.max_count = extended_entry_types.max_count;
	Pnew_struct -> extended_entry_types.count = extended_entry_types.count;
	if extended_entry_types.count > 0 then
	   Pnew_struct -> extended_entry_types.value = extended_entry_types.value;
	Pnew_struct -> extended_entry_types.max_count = extended_entry_types_size;
	so.extended_entry_typesP = Pnew_struct;
	call STRUCT_get_next_space (addr(extended_entry_types), currentsize(extended_entry_types));
	end;
       end;

    else if Pstruct_version = STAR_MATCH_NAMES_VERSION_1 then do;
       match_names_size = Pstruct_array_size;
       if match_names_size = 0 then do;
	match_names_size = 1;
	struct_elem_size = size(match_names) - size(struct_header);
	match_names_size =
	   divide (sys_info$max_seg_size - currentsize(struct_header), struct_elem_size, 17, 0);
	end;
       if so.match_namesP = null then do;
	so.match_namesP = STRUCT_get_space (Pstruct_name, size(match_names), Pcalling_ep);
	match_names.version = Pstruct_version;
	match_names.max_count = match_names_size;
	match_names.count = 0;
	call STRUCT_get_next_space (addr(match_names), currentsize(match_names));
	end;
       else do;
	Pnew_struct = STRUCT_get_space (Pstruct_name, size(match_names), Pcalling_ep);
	Pnew_struct -> match_names.version = Pstruct_version;
	Pnew_struct -> match_names.max_count = match_names.max_count;
	Pnew_struct -> match_names.count = match_names.count;
	if match_names.count > 0 then
	   Pnew_struct -> match_names.value = match_names.value;
	Pnew_struct -> match_names.max_count = match_names_size;
	so.match_namesP = Pnew_struct;
	call STRUCT_get_next_space (addr(match_names), currentsize(match_names));
	end;
       end;

    else if Pstruct_version = MN_VERSION_1 then do;
       fsd.mnP = STRUCT_get_space (Pstruct_name, size(mn), Pcalling_ep);
       mn.version = Pstruct_version;
       mn.count = Pstruct_array_size;
       call STRUCT_get_next_space (addr(mn), currentsize(mn));
       mn.value(*) = "";
       mn.type(*) = STAR_TYPE_UNSET;
       end;

    else if Pstruct_version = STAR_DATA_VERSION_1 then do;
       if fsd.star_dataP = null then do;
	fsd.star_dataP = STRUCT_get_space (Pstruct_name, size(star_data), Pcalling_ep);
	star_dataP = fsd.star_dataP;
	call STRUCT_get_next_space (addr(star_data), currentsize(star_data));
	end;
       else do;
	star_dataP = fsd.star_dataP;
	end;
       star_data.version = Pstruct_version;
       star_data.star_optionsP = addr(so);
       star_data.matched = 0;
       star_data.mbz_matched = 0;
       star_data.entry_data.data_desired = Pstruct_array_size;
						/* This is a slight misuse of the parm	 */
						/* but is close enough to make some sense*/
       star_data.entry_data.depth = 0;
       star_data.entry_data.type = ENTRY_TYPE_UNSET;
       star_data.entry_data.length = 0;
       star_data.entry_data.count = 0;
       star_data.entry_data.entryP = null;
       end;

    else if Pstruct_version = STAR_PATHS_VERSION_1 then do;
       star_paths_size = Pstruct_array_size;
       if star_paths_size = 0 then do;
	star_paths_size = 1;
	struct_elem_size = size(star_paths) - size(struct_header);
	star_paths_size =
	   divide (sys_info$max_seg_size - currentsize(struct_header), struct_elem_size, 17, 0);
	end;
       if so.star_pathsP = null then do;
	so.star_pathsP = STRUCT_get_space (Pstruct_name, size(star_paths), Pcalling_ep);
	star_paths.version = Pstruct_version;
	star_paths.max_count = star_paths_size;
	star_paths.count = 0;
	call STRUCT_get_next_space (addr(star_paths), currentsize(star_paths));
	end;
       else do;
	Pnew_struct = STRUCT_get_space (Pstruct_name, size(star_paths), Pcalling_ep);
	Pnew_struct -> star_paths.version = Pstruct_version;
	Pnew_struct -> star_paths.max_count = star_paths.max_count;
	Pnew_struct -> star_paths.count = star_paths.count;
	if star_paths.count > 0 then
	   Pnew_struct -> star_paths.value = star_paths.value;
	Pnew_struct -> star_paths.max_count = star_paths_size;
	so.star_pathsP = Pnew_struct;
	call STRUCT_get_next_space (addr(star_paths), currentsize(star_paths));
	end;
       end;

    else do;
       if Pcalling_ep = EP_SELECT then
	call SELECT_error (error_table_$fatal_error, 
	   "Attempt to allocate an unknown structure ^a.", Pstruct_name);
       else if Pcalling_ep = EP_REINIT | Pcalling_ep = EP_TERM then
	call ERROR_unexpected (error_table_$fatal_error, EP_NAME(Pcalling_ep), ACTION_CANT_RESTART,
	   null, 0, "Attempt to allocate an unknown structure ^a.", Pstruct_name);
       else do;
	call ERROR_unexpected (error_table_$fatal_error, EP_NAME(Pcalling_ep), ACTION_CAN_RESTART,
	   null, 0, "Attempt to allocate an unknown structure ^a.", Pstruct_name);
	if Pcalling_ep = EP_ADJUST then
	   call ADJUST_error (error_table_$fatal_error);
	else if Pcalling_ep = EP_INIT then
	   call INIT_error (error_table_$fatal_error);
	end;
       end;

    end STRUCT_allocate;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE: STRUCT_get_space							 */
/*   Returns a pointer to a space large enough to hold a structure of a given size.  Normally, the	 */
/*   structure is allocated at fsd.next_spaceP.  But the space remaining in the temp seg it points	 */
/*   to may be insufficient to hold the new structure.  Or the last allocation in that temp seg may	 */
/*   have used all remaining space, causing fsd.next_spaceP to have been set to null.  These cases	 */
/*   are handled by getting a new temp seg.  If the new structure won't fit in its own segment,	 */
/*   then $adjust_structure_size returns an error code.  Finally, space for the fsd structure itself */
/*   always goes in the star_options temp seg, immediately following that structure.		 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

STRUCT_get_space:
    procedure (Pstruct_name, Pstruct_size, Pcalling_ep) returns (ptr);
    
dcl  Pstruct_name			char(*) parm,	/* name of structure being allocated.(In)*/
     Pstruct_size			fixed bin(18) parm, /* structure size in words. (In)	 */
     Pcalling_ep			fixed bin parm;	/* entrypoint ID for error handling. (In)*/
dcl  structP			ptr auto;

    if Pstruct_name = "fsd" then			/* Special-case the fsd structure itself.*/
       structP = addwordno(addr(star_options), size(star_options));
    else						/* Otherwise, look in fsd to see where 	 */
       structP = fsd.next_spaceP;			/*  to put other structures.		 */

    if structP = null then				/* prev temp seg was full, get a new one */
       structP = TEMP_SEG_get (Pstruct_name, Pcalling_ep);

    if wordno (structP) + Pstruct_size <= sys_info$max_seg_size then
       return (structP);				/* space fits in current temp segment.	 */

    structP = TEMP_SEG_get (Pstruct_name, Pcalling_ep);
    if wordno (structP) + Pstruct_size <= sys_info$max_seg_size then
       return (structP);				/* space fits in a new temp segment.	 */

    else do;					/* space won't fit in ANY segment. Error */
       if Pcalling_ep = EP_SELECT then
	call SELECT_error (error_table_$too_many_names, 
	   "^a structure is too large to be allocated (^d) words).", Pstruct_name, Pstruct_size);
       else if Pcalling_ep = EP_REINIT | Pcalling_ep = EP_TERM then
	call ERROR_unexpected (error_table_$too_many_names, EP_NAME(Pcalling_ep), ACTION_CANT_RESTART,
	   null, 0, "^a structure is too large to be allocated (^d) words).", Pstruct_name, 
	   Pstruct_size);
       else do;
	call ERROR_unexpected (error_table_$too_many_names, EP_NAME(Pcalling_ep), ACTION_CAN_RESTART,
	   null, 0, "^a structure is too large to be allocated (^d) words).", Pstruct_name, 
	   Pstruct_size);
	if Pcalling_ep = EP_ADJUST then
	   call ADJUST_error (error_table_$too_many_names);
	else if Pcalling_ep = EP_INIT then
	   call INIT_error (error_table_$too_many_names);
	end;
       end;

    end STRUCT_get_space;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE: STRUCT_get_next_space						 */
/*   adjusts fsd.next_spaceP beyond the current structure being allocated or adjusted.  If there is	 */
/*   no more room in the current temp segment, the pointer is null.				 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

STRUCT_get_next_space:
    procedure (PstructP, Pstruct_size);

dcl  PstructP			ptr parm,
     Pstruct_size			fixed bin(18) parm;

dcl  space_size			fixed bin(18) auto;

    space_size = Pstruct_size + mod(Pstruct_size, 2);
    if wordno (PstructP) + space_size > sys_info$max_seg_size then
       fsd.next_spaceP = null;
    else
       fsd.next_spaceP = addwordno(PstructP, space_size);
    end STRUCT_get_next_space;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */
/*										 */
/* SUPPORT PROCEDURE: TEMP_AREA_get							 */
/*   get an extensible area from ssu_ and store a pointer to it in fs_star_data for later release.	 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */

TEMP_AREA_get:
    procedure () returns (ptr);

    if fsd.areasP(1) = null then 
       call ssu_$get_area (ssu_sciP, null, "star expand area", fsd.areasP(1));
    return (fsd.areasP(1));
    end TEMP_AREA_get;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */
/*										 */
/* SUPPORT PROCEDURE: TEMP_SEG_get							 */
/*   get a temporary segment from ssu_ and store pointer to it in fs_star_data for later release.	 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *	 */

TEMP_SEG_get:
    procedure (Pstruct_name, Pcalling_ep) returns(ptr);
    
dcl  Pstruct_name			char(*) parm,
     Pcalling_ep			fixed bin parm;

dcl  temp_segX			fixed bin auto;

    do temp_segX = lbound(fsd.temp_segsP,1) to hbound(fsd.temp_segsP,1)
       while (fsd.temp_segsP(temp_segX) ^= null);
       end;

    if temp_segX > hbound(fsd.temp_segsP,1) then do;
       if Pcalling_ep = EP_SELECT then
	call SELECT_error (error_table_$noalloc, 
	   "Cannot use more than ^d temporary segments.", hbound(fsd.temp_segsP,1));
       else if Pcalling_ep = EP_REINIT | Pcalling_ep = EP_TERM then
	call ERROR_unexpected (error_table_$noalloc, EP_NAME(Pcalling_ep), ACTION_CANT_RESTART,
	   null, 0, "Cannot use more than ^d temporary segments.", hbound(fsd.temp_segsP,1));
       else do;
	call ERROR_unexpected (error_table_$noalloc, EP_NAME(Pcalling_ep), ACTION_CAN_RESTART,
	   null, 0, "Cannot use more than ^d temporary segments.", hbound(fsd.temp_segsP,1));
	if Pcalling_ep = EP_ADJUST then
	   call ADJUST_error (error_table_$noalloc);
	else if Pcalling_ep = EP_INIT then
	   call INIT_error (error_table_$noalloc);
	end;
       return (null);
       end;

    call ssu_$get_temp_segment (ssu_sciP, Pstruct_name, fsd.temp_segsP(temp_segX));

    return (fsd.temp_segsP(temp_segX));
    end TEMP_SEG_get;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* SUPPORT PROCEDURE: TEMP_SEGS_AREAS_term						 */
/*   Releases any temp segments and areas acquired by fs_star_, other than the temp segment holding	 */
/*   the star_options and fsd structures.						 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

TEMP_SEGS_AREAS_term:
    procedure();

dcl  Itemp			fixed bin;

    do Itemp = lbound(fsd.temp_segsP,1) to hbound(fsd.temp_segsP,1);
       if fsd.temp_segsP(Itemp) ^= null then do;
	call ssu_$release_temp_segment (ssu_sciP, fsd.temp_segsP(Itemp));
	fsd.temp_segsP(Itemp) = null;
	end;
       end;
    do Itemp = lbound(fsd.areasP,1) to hbound(fsd.areasP,1);
       if fsd.areasP(Itemp) ^= null then do;
	call ssu_$release_area (ssu_sciP, fsd.areasP(Itemp));
	fsd.areasP(Itemp) = null;
	end;
       end;
    end TEMP_SEGS_AREAS_term;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

%include access_mode_values;

%include fs_star_;

%include status_structures;

dcl  1 auto_status			aligned like status_branch.short;
dcl  status_area			area based (status_area_ptr);
dcl  status_names			(status_branch.nnames) character (32)
				based (pointer (status_area_ptr, status_branch.names_relp));
						/* status_entry_names array in include	 */
						/*  file is aligned.  That is a mistake	 */
						/*  but it is too late to correct now.	 */

%include sub_err_flags;

%include terminate_file;

    end fs_star_;




		    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