



		    acl_commands_.pl1               10/06/88  1037.0rew 10/06/88  1035.5      736182



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-10-02,TLNguyen), approve(86-10-23,MCR7555),
     audit(86-10-29,GWMay), install(86-10-29,MR12.0-1201):
     Modified  all IACL commands to correctly process a directory type
     and omit or reject non-directory types.
  2) change(87-08-21,TLNguyen), approve(87-08-21,MCR7755),
     audit(87-09-08,Lippard), install(87-12-07,MR12.2-1009):
     Change the list_accessible and list_not_accessible to work with the ROOT
     directory.
  3) change(87-08-27,TLNguyen), approve(87-08-27,MCR7757),
     audit(87-09-08,Lippard), install(87-12-07,MR12.2-1009):
     Change list_acl command to return error_table_$noentry for a non-existent
     target of a link.
  4) change(87-08-27,TLNguyen), approve(87-08-27,MCR7763),
     audit(87-09-08,Lippard), install(87-12-07,MR12.2-1009):
     Change acl_commands_.pl1 to display a correct error message when
     -directory or -segment control arguments is specified for IACL commands.
  5) change(88-03-01,Lippard), approve(88-03-28,MCR7869),
     audit(88-04-26,Parisek), install(88-05-03,MR12.2-1044):
     Modified to give more informative error message when inconsistent
     ACL modes are specified.
  6) change(88-09-20,TLNguyen), approve(88-09-20,MCR7983),
     audit(88-10-03,Parisek), install(88-10-06,MR12.2-1134):
     Change the list_acl command to print out the pathname in the error
     message when the ACL list is empty.
                                                   END HISTORY COMMENTS */


/* format: style3,linecom,ifthenstmt,ifthendo,ifthen,^indnoniterdo,indnoniterend,indcomtxt,^inditerdo,indend,idind30 */
acl_commands_:
     procedure () options (variable);

/*^*      ACL COMMANDS -- completely rewritten, 1/28/83 Jay Pattin
   *	Fixed set_acl to work on DM files (if ^xacl_allowed & si.type_name ^= "DM file") 06/06/83 S. Herbst
   *      Added lac and lnac 8/27/83 Jay Pattin
   *      Updated for fs_util_, 2 October 1983, W. Olin Sibert
   *      Modified to prevent freeing of same block twice through 2 separate pointers, 1984.01.25, MAP
   *	Modified to use Person.*.* for default mbx acls, instead of Person.Project.*, 1984.02.02, MAP
   *      Modified to check for mbx type from suffix as well as from invocation method, 1984.02.02, MAP
   *	Modified to use fs_util_ object type instead of hcs_ entry type, 1984.02.17, MAP
   *	Modified to set ACL on non-standard object only if given suffix is nt starname, 1984.03.12, MAP
   *	Modified to report "Empty ACL" when original ACL count = 0, 1984.03.12, MAP
   *	Modified to not delete *.SysDaemon.* for da foo -all, 1984.10.24, MAP
   *	Modified to delete *.SysDaemon.* when explicitly instructed to do so.
   *        Also to give error message if -sysdaemon or -no_sysdaemon is used
   *        without -replace.  Also to fix bugs with implementation of -slet;
   *	  And to use the raw acl of extended entries for reporting acls
   *	  when -inase is used.   1/14/85, M. Sharpe.
   *	Modified star name processing when more than one entry type is
   *	  requested.  3/13/85, M.Sharpe.
   */

  /*	This procedure implements all the ACL setting, changing, deleting, and listing
   *	commands for Multics. It includes the following commands, listed in the order
   *	in which they appear in the code:

   NAME		ALTERNATE NAMES		ACL TYPE		PRIVILEGE

   set_acl	setacl, sa		branch		normal
   l_set_acl	lset_acl, lsetacl, lsa	branch		library
   hp_set_acl	hpsetacl, hpsa		branch		hphcs

   delete_acl	deleteacl, da		branch		normal
   l_delete_acl	ldelete_acl, ldeleteacl, lda	branch		library
   hp_delete_acl	hpdeleteacl, hpda		branch		hphcs

   ms_set_acl		mssa		message segment	normal
   mbx_set_acl		mbsa		mailbox		normal
   ms_delete_acl		msda		message segment	normal
   mbx_delete_acl		mbda		mailbox		normal

   set_iacl_seg		sis		segment iacl	normal
   set_iacl_dir		sid		directory iacl	normal
   delete_iacl_seg		dis		segment iacl	normal
   delete_iacl_dir		did		directory iacl	normal

   list_acl		listacl, la	branch acl	normal
   list_iacl_seg		lis		segment iacl	normal
   list_iacl_dir		lid		directory iacl	normal

   ms_list_acl		msla		message segment	normal
   mbx_list_acl		mbla		mailbox		normal

   and poor, unrelated list_accessible and list_not_accessible */

/**/

/* format: off */

declare   error_table_$action_not_performed fixed bin (35) external static;
declare   error_table_$active_function  fixed bin (35) external static;
declare   error_table_$bad_conversion   fixed bin (35) external static;
declare   error_table_$bad_name         fixed bin (35) external static;
declare   error_table_$bad_ring_brackets fixed bin (35) external static;
declare   error_table_$badopt           fixed bin (35) external static;
declare   error_table_$inconsistent     fixed bin (35) external static;
declare   error_table_$noarg            fixed bin (35) external static;
declare   error_table_$noentry          fixed bin (35) external static;
declare   error_table_$nomatch          fixed bin (35) external static;
declare   error_table_$nostars          fixed bin (35) external static;
declare   error_table_$notadir          fixed bin (35) external static;
declare   error_table_$not_seg_type     fixed bin (35) external static;
declare   error_table_$root             fixed bin (35) external static;
declare   error_table_$unsupported_operation fixed bin (35) external static;
declare   error_table_$user_not_found   fixed bin (35) external static;

declare   active_fnc_err_               entry options (variable);
declare   check_star_name_$entry        entry (char (*), fixed bin (35));
declare   com_err_                      entry options (variable);
declare   convert_authorization_$to_string_short
                                        entry (bit (72) aligned, char (*), fixed bin (35));
declare   cu_$af_return_arg_rel         entry (fixed bin, pointer, fixed bin (21), fixed bin (35), pointer);
declare   cu_$arg_list_ptr              entry (pointer);
declare   cu_$arg_ptr_rel               entry (fixed bin, pointer, fixed bin (21), fixed bin (35), pointer);
declare   cu_$generate_call             entry (entry, pointer);
declare   cu_$level_get                 entry (fixed bin (3));
declare   cv_acl_type_$create           entry (pointer, fixed bin, pointer, char (32), char (32), pointer);
declare   expand_pathname_$add_suffix   entry (char (*), char (*), char (*), char (*), fixed bin (35));
declare   get_group_id_$tag_star        entry returns (char (32));
declare   get_system_free_area_         entry returns (ptr);
declare   get_wdir_                     entry returns (char (168));
declare   hcs_$get_access_class         entry (char (*), char (*), bit (72) aligned, fixed bin (35));
declare   hcs_$get_dir_ring_brackets    entry (char (*), char (*), (2) fixed bin (3), fixed bin (35));
declare   hcs_$get_ring_brackets        entry (char (*), char (*), (*) fixed bin (3), fixed bin (35));
declare   hcs_$star_                    entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
declare   hcs_$status_minf              entry (char (*), char (*), fixed bin (1),
                                        fixed bin (2), fixed bin (24), fixed bin (35));
declare   ioa_                          entry options (variable);
declare	match_star_name_		entry (char(*), char(*), fixed bin(35));
declare   msf_manager_$close            entry (ptr);
declare   msf_manager_$open             entry (char (*), char (*), ptr, fixed bin (35));
declare   pathname_                     entry (char (*), char (*)) returns (char (168));

declare   fs_util_$get_ring_brackets    entry (char (*), char (*), (*) fixed bin (3), fixed bin (35));
declare   fs_util_$make_entry_for_type  entry (char (*), char (*), entry, fixed bin (35));
declare   fs_util_$suffix_info          entry (char (*), char (*), ptr, fixed bin (35));
declare   fs_util_$suffix_info_for_type entry (char (*), ptr, fixed bin (35));

declare   hcs_$get_user_access_modes    entry (char (*), char (*), char (*), fixed bin,
                                        bit (36) aligned, bit (36) aligned, fixed bin (35));
declare   fs_util_$get_user_access_modes entry (char (*), char (*), char (*), fixed bin,
                                        bit (36) aligned, bit (36) aligned, fixed bin (35));

declare   fs_util_$list_acl             entry (char (*), char (*), char (*), pointer, pointer, fixed bin (35));

declare   hcs_$list_inacl               entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (3), fixed bin (35));
declare   hcs_$list_dir_inacl           entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (3), fixed bin (35));

declare   hcs_$replace_dir_acl          entry (char (*), char (*), pointer, fixed bin, bit (1) aligned, fixed bin (35));
declare   hcs_$replace_acl              entry (char (*), char (*), pointer, fixed bin, bit (1) aligned, fixed bin (35));
declare   hphcs_$replace_acl            entry (char (*), char (*), pointer, fixed bin, bit (1) aligned, fixed bin (35));
declare   hphcs_$replace_dir_acl        entry (char (*), char (*), pointer, fixed bin, bit (1) aligned, fixed bin (35));
declare   installation_tools_$replace_acl entry (char (*), char (*), pointer, fixed bin, bit (1) aligned, fixed bin (35));
declare   installation_tools_$replace_dir_acl
                                         entry (char (*), char (*), pointer, fixed bin, bit (1) aligned, fixed bin (35));
declare   fs_util_$replace_acl           entry (char (*), char (*), pointer, bit (1) aligned, fixed bin (35));

declare   hcs_$replace_inacl            entry (char (*), char (*),
                                        pointer, fixed bin, bit (1) aligned, fixed bin (3), fixed bin (35));
declare   hcs_$replace_dir_inacl        entry (char (*), char (*),
                                        pointer, fixed bin, bit (1) aligned, fixed bin (3), fixed bin (35));

declare  (cleanup, linkage_error)       condition;

declare  (abs, addr, after, before, char, copy, divide, index, length, max,
	null, reverse, rtrim, search, string, substr, sum, unspec, verify)
                                        builtin;

/*  */

declare   ON                            init ("1"b) bit (1) aligned internal static options (constant);
declare   OFF                           init ("0"b) bit (1) aligned internal static options (constant);

declare   DIRECTORY                     init (2) fixed bin (2) internal static options (constant);
/* Possible values for the type parameter */

declare   BRANCH_ACL                    init (101) fixed bin (10) internal static options (constant);
declare   MSEG_ACL                      init (102) fixed bin (10) internal static options (constant);
declare   MBX_ACL                       init (103) fixed bin (10) internal static options (constant);
declare   SEGMENT_IACL                  init (104) fixed bin (10) internal static options (constant);
declare   DIRECTORY_IACL                init (105) fixed bin (10) internal static options (constant);

/* Possible values for the operation parameter */

declare   LIST                          init (201) fixed bin (11) internal static options (constant);
declare   SET                           init (202) fixed bin (11) internal static options (constant);
declare   DELETE                        init (203) fixed bin (11) internal static options (constant);
declare   ACCESSIBLE                    init (204) fixed bin (11) internal static options (constant);

/* Possible values for the privilege parameter */

declare   NORMAL                        init (301) fixed bin (12) internal static options (constant);
declare   LIBRARY                       init (302) fixed bin (12) internal static options (constant);
declare   HPHCS                         init (303) fixed bin (12) internal static options (constant);

/*  */

/* Now, the entrypoints. Each one calls the common procedure to get its work done, and exits by goto ACL_COMMANDS_RETURN */

ACL_COMMANDS_RETURN:                                        /* This is the only return statement in this program. */
          return;                                           /* The "common" procedure always exits by a goto to here */


set_acl:   setacl:    sa:                                   /* Normal, unprivileged, user ACL setting command */
     entry () options (variable);
          call common ("set_acl", BRANCH_ACL, SET, NORMAL);

l_set_acl:   lset_acl:   lsetacl:   lsa:                    /* Ring 1, privileged entry for library maintenance */
     entry () options (variable);
          call common ("l_set_acl", BRANCH_ACL, SET, LIBRARY);

hp_set_acl:   hpsetacl:   hpsa:                             /* Ring 0, highly privileged entry for systems programmers */
     entry () options (variable);
          call common ("hp_set_acl", BRANCH_ACL, SET, HPHCS);

delete_acl:   deleteacl:   da:                              /* Normal, unprivileged, user ACL deletion command */
     entry () options (variable);
          call common ("delete_acl", BRANCH_ACL, DELETE, NORMAL);

l_delete_acl:   ldelete_acl:   ldeleteacl:   lda:           /* Ring 1, privileged entry for library maintenance */
     entry () options (variable);
          call common ("l_delete_acl", BRANCH_ACL, DELETE, LIBRARY);

hp_delete_acl:   hpdeleteacl:   hpda:                       /* Ring 0, highly privileged entry for systems programmers */
     entry () options (variable);
          call common ("hp_delete_acl", BRANCH_ACL, DELETE, HPHCS);

ms_set_acl:   mssa:                                         /* User command for setting message segment ACLs */
     entry () options (variable);
          call common ("ms_set_acl", MSEG_ACL, SET, NORMAL);

mbx_set_acl:   mbsa:                                        /* User command for setting mailbox ACLs */
     entry () options (variable);
          call common ("mbx_set_acl", MBX_ACL, SET, NORMAL);

ms_delete_acl:   msda:                                      /* User command for deleting message segment ACLs */
     entry () options (variable);
          call common ("ms_delete_acl", MSEG_ACL, DELETE, NORMAL);

mbx_delete_acl:   mbda:                                     /* User command for deleting mailbox ACLs */
     entry () options (variable);
          call common ("mbx_delete_acl", MBX_ACL, DELETE, NORMAL);

set_iacl_seg:   sis:                                        /* Nonprivileged user command for setting segment IACLs */
     entry () options (variable);
          call common ("set_iacl_seg", SEGMENT_IACL, SET, NORMAL);

delete_iacl_seg:   dis:                                     /* Nonprivileged user command for deleting segment IACLs */
     entry () options (variable);
          call common ("delete_iacl_seg", SEGMENT_IACL, DELETE, NORMAL);

set_iacl_dir:   sid:                                        /* Nonprivileged user command for setting directory IACLs */
     entry () options (variable);
          call common ("set_iacl_dir", DIRECTORY_IACL, SET, NORMAL);

delete_iacl_dir:   did:                                     /* Nonprivileged user command for deleting directory IACLs */
     entry () options (variable);
          call common ("delete_iacl_dir", DIRECTORY_IACL, DELETE, NORMAL);

list_acl:   listacl:   la:                                  /* User command for listing ACLs */
     entry () options (variable);
          call common ("list_acl", BRANCH_ACL, LIST, NORMAL);

list_iacl_seg:   lis:                                       /* User command for listing segment IACLs */
     entry () options (variable);
          call common ("list_iacl_seg", SEGMENT_IACL, LIST, NORMAL);

list_iacl_dir:   lid:                                       /* User command for listing directory IACLs */
     entry () options (variable);
          call common ("list_iacl_dir", DIRECTORY_IACL, LIST, NORMAL);

ms_list_acl:   msla:                                        /* User command for listing message segment ACLs */
     entry () options (variable);
          call common ("ms_list_acl", MSEG_ACL, LIST, NORMAL);

mbx_list_acl:   mbla:                                       /* User command for listing mailbox ACLs */
     entry () options (variable);
          call common ("mbx_list_acl", MBX_ACL, LIST, NORMAL);

list_accessible:   lac:                                     /* User command for locating accessable objects */
     entry options (variable);
          call common ("list_accessible", BRANCH_ACL, ACCESSIBLE, NORMAL);

list_not_accessible:   lnac:                                /* User command for locating inaccessable objects */
     entry options (variable);
          call common ("list_not_accessible", BRANCH_ACL, ACCESSIBLE, NORMAL);

/*  */

common:
     procedure (P_whoami, P_type, P_operation, P_privilege);

/* In case anyone is wondering why the peculiar precisions, it's in order to ensure that calls to "common"
   are made with the right arguments in the right places: putting a type constant in the operation slot,
   for instance, will generate a warning about incompatible datatypes. */

declare   P_whoami                      char (32) parameter;          /* Command name */
declare   P_type                        fixed bin (10) parameter;     /* Type of ACL to operate on; see constants above */
declare   P_operation                   fixed bin (11) parameter;     /* Which operation to perform */
declare   P_privilege                   fixed bin (12) parameter;     /* What level of privilege to assume */

declare   arg_list_ptr                  pointer;

/* Yes, and if anyone is wondering about this, too, it's an awkward dodge to ensure that
   the arg_list_ptr gets set properly so that the internal procedures can use it. In order
   to ensure this, though, the call to cu_$arg_list_ptr has to appear in a quick block
   immediately contained in the outer block. This is true of "common", but not of
   "nonquick_common", because it, as the procedure which really does the work, it has
   to set up a cleanup handler and do various other things that force it to be non-quick.
   So, there's this first quick procedure which is called by all the entrypoints, and
   all it does is get the argument list and call the non-quick one (which inherits all the
   type and operation parameters from this one, its parent). */

          call cu_$arg_list_ptr (arg_list_ptr);

          call nonquick_common (arg_list_ptr);

/* There is only one return statement in nonquick_common: it gets us here, and this goto gets us out completely */

          goto ACL_COMMANDS_RETURN;

/*  */

nonquick_common:
     procedure (P_arg_list_ptr);

declare   P_arg_list_ptr                pointer parameter;            /* Used to reference command-line arguments */

declare   whoami                        char (32);
declare   type                          fixed bin (10);
declare   operation                     fixed bin (11);
declare   privilege                     fixed bin (12);

declare   system_area_ptr               ptr;
declare   system_area                   area based (system_area_ptr);

declare   code                          fixed bin (35);

declare   ret_str_ptr                   ptr;
declare   ret_str_lth                   fixed bin (21);
declare   ret_str                       char (ret_str_lth) varying based (ret_str_ptr);

declare   entry_type_count		fixed bin;
declare   entry_type_ptr		ptr;
declare	1 entry_type		aligned based (entry_type_ptr),
	2 count			fixed bin,
	2 suffixes		dim (entry_type_count refer (entry_type.count)),
	3 suffix			char (32),
	3 is_std_type		bit (1);

declare	star_match_ptr		ptr;
declare   star_name_count		fixed bin;
declare   star_match		dim (star_name_count) bit (1)
				unaligned based (star_match_ptr);

declare   dname                         char (168);
declare   ename                         char (32);
declare   hcs_type			fixed bin (2);
declare   object_type                   char (32);
declare 1 si                            aligned like suffix_info;
declare 1 type_info			aligned like suffix_info;

declare   access_class                  bit (72) aligned;
declare   access_name                   char (32);
declare   acl_mask                      bit (36) aligned;
declare   buffer                        char (256);
declare   bit_count                     fixed bin (24);
declare   err_path                      char (168);
declare   iacl_ring                     fixed bin (3);
declare   pathname                      char (204);
declare   star_entry_idx                fixed bin;
declare	star_name_idx		fixed bin;
declare	do_tedious_star		bit (1) aligned;
declare   star_sw                       bit (1) aligned;
declare   xacl_allowed                  bit (1) aligned;
declare   limit_entry_types		bit (1) aligned;

/* The acl_modes and acl_names structures contain the character string modes and names specified
   on the command line. The old_acl, new_acl, and used_bits structures are used when building
   a new ACL for listing, setting, or deleting. They are declared here for ease of cleanup.
   original_count is used by build_new_acl and list_the_acl, and must be delcared external to both. */

declare   acl_names_ptr                 pointer init (null ()); /* Various things checked in the cleanup handler */
declare   acl_modes_ptr                 pointer init (null ());
declare   old_acl_ptr                   pointer init (null ());
declare   new_acl_ptr                   pointer init (null ());
declare   other_acl_ptr                 pointer init (null ()); /* Points to other-format ACL for operation (if any) */
declare   used_bits_ptr                 pointer init (null ());
declare   fcb_ptr                       pointer init (null ()); /* Used if current object is an MSF */

declare   n_acl_names                   fixed bin;
declare   max_acl_names                 fixed bin;
declare   acl_names (max_acl_names)     char (32) unaligned based (acl_names_ptr);

declare   n_acl_modes                   fixed bin;
declare   max_acl_modes                 fixed bin;
declare   acl_modes (max_acl_modes)     char (36) unaligned based (acl_modes_ptr);

declare 1 old_acl                       aligned like general_acl based (old_acl_ptr);
declare 1 new_acl                       aligned like general_acl based (new_acl_ptr);

declare	original_count		fixed bin;
declare   used_bits_count               fixed bin;
declare   used_bits (used_bits_count)   bit (1) unaligned based (used_bits_ptr);

declare   empty_acl_overlay (4)         fixed bin (71);     /* Used for easier manuipulation of empty ACLs */


declare   af_sw                         bit (1) aligned init ("0"b);
declare   chase_sw                      bit (1) aligned init ("0"b);
declare   no_chase_sw                   bit (1) aligned init ("0"b);
declare   brief_sw                      bit (1) aligned init ("0"b);
declare   replace_sw                    bit (1) aligned init ("0"b);
declare   ring_bracket_sw               bit (1) aligned init ("0"b);
declare   access_class_sw               bit (1) aligned init ("0"b);
declare   all_sw                        bit (1) aligned init ("0"b);
declare   force_no_type                 bit (1) aligned init ("0"b);
declare   iacl_sw                       bit (1) aligned init ("0"b);
declare   no_sysdaemon_sw               bit (1) aligned init ("0"b);
declare   segment_sw                    bit (1) aligned init ("0"b);
declare   directory_sw                  bit (1) aligned init ("0"b);
declare   starname_suffix	          bit (1) aligned init ("0"b);
declare   matched_sw                    bit (1) aligned init ("0"b);
declare   accessible                    bit (1) aligned init ("0"b);
declare   use_access_modes              bit (1) aligned init ("0"b);
declare	explicit_dr_arg		bit (1) aligned init ("0"b);
declare   explicit_sm_arg		bit (1) aligned init ("0"b);

/*  */

/* format: on */
	whoami = P_whoami;
	type = P_type;
	operation = P_operation;
	privilege = P_privilege;

/* flag those command interfaces that are going away soon... */

	if (type = MBX_ACL) | (type = MSEG_ACL)
	then call ioa_ ("Warning: the ^a command is obsolete and will be deleted next release.^/In the future, please use the ^a command to perform its operation.^/",
	     whoami, after (whoami, "_"));

	if (operation = ACCESSIBLE) then accessible = (whoami = "list_accessible");

	system_area_ptr = get_system_free_area_ ();
	star_names_ptr = null ();			/* Initialize variables declared in include files */
	star_entry_ptr = null ();			/* Our own have init clauses, above */
	acl_ptr = null ();

	limit_entry_types = "0"b;
	star_match_ptr = null ();

	on condition (cleanup) call cleanup_handler ();

	iacl_sw = (type = SEGMENT_IACL | type = DIRECTORY_IACL);
	err_path = "";

	call process_arguments ();

	if ^star_sw then star_entry_count = 1;
	else do;					/* star name given */
	     if af_sw then call complain (error_table_$nostars, whoami, "^a", ename);
	     if chase_sw then
		star_select_sw = star_ALL_ENTRIES;
	     else star_select_sw = star_BRANCHES_ONLY;

	     if do_tedious_star then do;
		call hcs_$star_ (dname, "**", (star_select_sw), system_area_ptr, star_entry_count, star_entry_ptr,
		     star_names_ptr, code);
		if code ^= 0 then do;
		     call complain (code, whoami, "^a", pathname_ (dname, ename));
		     goto MAIN_RETURN;
		end;

		star_name_count = sum (star_entries(*).nnames);
		call modified_star_processing ();
	     end;
	     else do;
		call hcs_$star_ (dname, ename, (star_select_sw), system_area_ptr, star_entry_count, star_entry_ptr,
		     star_names_ptr, code);
		if code ^= 0 then do;
		     call complain (code, whoami, "^a", pathname_ (dname, ename));
		     goto MAIN_RETURN;
		end;

		star_name_count = sum (star_entries(*).nnames);
		allocate star_match in (system_area);
		string (star_match) = "1"b;		/* everyone matches */
	     end;
	end;

	if privilege ^= NORMAL then
	     on linkage_error
		begin;
                         call complain (error_table_$action_not_performed, whoami,
                              "Access to ^[hphcs_^;installation_tools_^] is required.", (privilege = HPHCS));
		     goto MAIN_RETURN;
		     end;

	do star_entry_idx = 1 to star_entry_count;
	     fcb_ptr = null ();
	     if star_sw
	     then do;
		if do_tedious_star then do;
		     do star_name_idx = star_entries (star_entry_idx).nindex to star_entries (star_entry_idx).nindex  + star_entries (star_entry_idx).nnames -1;
			if star_match (star_name_idx) then do;
			     ename = star_names (star_name_idx);
			     goto FOUND_MATCH;
			end;
		     end;
		     goto SKIP_NON_MATCH;
		end;
		else ename = star_names (star_entries.nindex (star_entry_idx));
	     end;
	     
FOUND_MATCH:   err_path = pathname_ (dname, ename);	/* for error messages */

	     call get_suffix_info ();

	     object_type = si.type;
	     if limit_entry_types
		then if ^entry_type_selected (entry_type_ptr, object_type) then do;
WRONG_TYPE:
		     if ^star_sw then
			if iacl_sw
			      then call complain (error_table_$notadir, whoami, "^a", err_path);
			else call complain (0, whoami,
			"Wrong type of entry.  For ^a ^a.", si.type_name, err_path);
		     goto SKIP_MATCH;
		     end;

		else;
	     else if ^(directory_sw | segment_sw) then;	/* anything goes */
	     else if (object_type = FS_OBJECT_TYPE_DIRECTORY)
		then if ^directory_sw then goto WRONG_TYPE;
		else;
	     else if (substr (object_type, 1, 1) = "-")
		then if ^segment_sw			/* seg, msf, dmf */
		     then goto WRONG_TYPE;
		else;
	     else if (explicit_dr_arg | explicit_sm_arg) /* explicit -dir or -sm */
		then goto WRONG_TYPE;		/* extended types not selected with -sm or -dr */

	     matched_sw = "1"b;			/* found something */

	     if object_type = FS_OBJECT_TYPE_MSF then do;
		call msf_manager_$open (dname, ename, fcb_ptr, code);
		if code ^= 0 then do;
		     call complain (code, whoami, "^a", err_path);
		     goto SKIP_MATCH;
		     end;
		end;

	     call build_new_acl ();			/* Build whatever new ACL is appropriate */

	     if (operation = SET) | (operation = DELETE) then call replace_the_acl ();
	     else if (operation = LIST) then call list_the_acl ();
	     else if (operation = ACCESSIBLE) then call print_accessible ();

	     call check_for_acle_errors ();

SKIP_MATCH:
	     if object_type = FS_OBJECT_TYPE_MSF then
		if fcb_ptr ^= null () then call msf_manager_$close (fcb_ptr);
SKIP_NON_MATCH:
	     end;


	if star_sw & ^matched_sw then call complain (error_table_$nomatch, whoami, "^a", pathname);

MAIN_RETURN:
	call cleanup_handler ();
          return;                                           /* ONLY return statement in this procedure */
%page;
process_arguments:
     procedure ();

/* This procedure implements the argument processing loop. It detects all the possible
   inconsistencies among control arguments, etc.   */

dcl	(ap, ap1)			pointer;
dcl	(al, al1)			fixed bin (21);
dcl	arg			char (al) based (ap);
dcl	arg1			char (al1) based (ap1);
dcl	(argno, nargs)		fixed bin;
dcl	min_ring			fixed bin (3);
dcl	idx			fixed bin;

dcl	(
	all_val,
	chase_val,
	brief_val,
	replace_val,				/* record of specified options, used for consistency */
	raw_val,
	ring_bracket_val,
	sysdaemon_val,
	access_class_val,				/* checks later on */
	segment_val,
	directory_val
	)			fixed bin init (0); /* INITIALIZED TO ZERO, to get default */

declare   iacl_ring_arg                 fixed bin;
declare   type_name                     char (32);
declare	type_suffix		char (32);
declare   have_mode                     bit (1) aligned;
declare   want_mode                     bit (1) aligned;
declare   all_stars                     bit (1) aligned;
declare   ename_suffix                  char (32);

          call cu_$af_return_arg_rel (nargs, ret_str_ptr, ret_str_lth, code, P_arg_list_ptr);
          if (code = 0) then do;
               af_sw = "1"b;
               brief_val = 1;
               ret_str = "";
               end;
          else af_sw = "0"b;                                /* assume we're a command */

	pathname, type_name = "";
	iacl_ring = -1;
	iacl_ring_arg = 0;

	if operation = SET | operation = ACCESSIBLE then do;
						/* collect User_ids and modes -- they should come in pairs */
	     max_acl_names = divide ((nargs + 1), 2, 17, 0);
	     max_acl_modes = max_acl_names;
	     allocate acl_modes in (system_area);
	     end;

	else do;					/* other operations only collect userids */
	     max_acl_names = nargs - 1;		/* many as arg count - 1 */
	     acl_modes_ptr = null ();			/* catch errors */
	     end;

	max_acl_names = max (max_acl_names, 1);		/* make sure there's always at least one */
	allocate acl_names in (system_area);

	n_acl_names = 0;				/* collected nothing so far */
	n_acl_modes = 0;
	acl_names (*) = "";

	if operation = SET then
	     want_mode = "1"b;			/* SET wants a mode first thing after the path */
	else want_mode = "0"b;			/* Other commands never want modes */
	have_mode = "0"b;

	do argno = 1 to nargs;			/* now, collect */
               call cu_$arg_ptr_rel (argno, ap, al, (0), P_arg_list_ptr);

	     if al = 0 then do;
NULL_ARG:		call complain (0, whoami, "zero-length argument not accepted.");
		goto MAIN_RETURN;
	     end;

	     if char (arg, 1) = "-" then
		if arg = "-wd" | arg = "-working_dir" | arg = "-working_directory" then do;
		     if pathname ^= "" then do;	/* only in first position */
			call complain (0, whoami, "^a may only appear in place of the pathname argument.", arg);
			goto MAIN_RETURN;
			end;
		     pathname = get_wdir_ ();
		     end;

		else if operation = DELETE & (arg = "-all" | arg = "-a") then call SET_OPTION (all_val, ON);
		else if type = BRANCH_ACL & (arg = "-interpret_as_standard_entry" | arg = "-inase") then
		     call SET_OPTION (raw_val, ON);
		else if type = BRANCH_ACL & (arg = "-interpret_as_extended_entry" | arg = "-inaee") then
		     call SET_OPTION (raw_val, OFF);
		else if arg = "-chase" then call SET_OPTION (chase_val, ON);
		else if arg = "-no_chase" then call SET_OPTION (chase_val, OFF);
		else if type = BRANCH_ACL & (arg = "-select_entry_type" | arg = "-slet") then do;
		     if argno = nargs then do;
NOARG:
			call complain (error_table_$noarg, whoami, "Following ^a.", arg);
			goto MAIN_RETURN;
			end;
		     argno = argno + 1;
                         call cu_$arg_ptr_rel (argno, ap, al, (0), P_arg_list_ptr);
		     if al = 0 then goto NULL_ARG;

		     type_name = arg;
		     call process_entry_type_list (arg, entry_type_ptr, limit_entry_types);
		     if ^limit_entry_types then do;
			call complain (0, whoami, "One or more invalid entry types specified. ^a", arg);
			goto MAIN_RETURN;
			end;
		     end;
		else if operation = ACCESSIBLE then do; /* collect mode string to match */
		     if have_mode then do;
			call complain (0, whoami, "Only one set of modes may be given.", arg);
			goto MAIN_RETURN;
			end;

		     want_mode, have_mode = "1"b;
		     if pathname = "" then pathname = get_wdir_ ();

		     if arg = "-dir_mode" then call SET_OPTION (directory_val, ON);
		     else if arg = "-seg_mode" then call SET_OPTION (segment_val, ON);
		     else if arg ^= "-mode" then call BADOPT (argno);
		     if argno = nargs then goto NOARG;
		     end;
		else if arg = "-brief" | arg = "-bf" then call SET_OPTION (brief_val, ON);
		else if arg = "-long" | arg = "-lg" then call SET_OPTION (brief_val, OFF);
		else if arg = "-directory" | arg = "-dr" then do; 
			if type = DIRECTORY_IACL | type = SEGMENT_IACL
			then call BADOPT (argno);
			else call SET_OPTION (directory_val, ON);
			end;
		else if arg = "-segment" | arg = "-sm" then do;
			if type = DIRECTORY_IACL | type = SEGMENT_IACL
			then call BADOPT (argno);
			else call SET_OPTION (segment_val, ON);
			end;
		else if iacl_sw & (arg = "-ring" | arg = "-rg") then do;
		     iacl_ring_arg = argno;		/* remember where we saw it */
		     ap1 = null ();			/* prevent faults */
		     al1 = 0;

		     if argno = nargs then do;
			code = error_table_$noarg;
BAD_IACL_RING:
			call complain (code, whoami,	/* include the offending argument, if it exists */
			     "^a must be followed by a ring number^[.^;, not ^a^]", arg, (al1 = 0), arg1);
			goto MAIN_RETURN;
			end;

		     if iacl_ring >= 0 then do;	/* only say this once */
			call complain (0, whoami, "^a may only be specified once.", arg);
			goto MAIN_RETURN;
			end;

		     argno = argno + 1;		/* get the next argument */
                         call cu_$arg_ptr_rel (argno, ap1, al1, (0), P_arg_list_ptr);
		     if al = 0 then goto NULL_ARG;

		     iacl_ring = index ("01234567", arg1) - 1;

		     if iacl_ring < 0 | length (arg1) ^= 1 then do;
						/* not one of the digits */
			code = error_table_$bad_conversion;
			goto BAD_IACL_RING;
			end;
		     end;				/* of processing -ring */
		else if operation = LIST & ^iacl_sw then do;
		     if arg = "-ring_brackets" | arg = "-rb" then call SET_OPTION (ring_bracket_val, ON);
		     else if arg = "-no_ring_brackets" | arg = "-nrb" then call SET_OPTION (ring_bracket_val, OFF);
		     else if arg = "-access_class" | arg = "-acc" then call SET_OPTION (access_class_val, ON);
		     else if arg = "-no_access_class" | arg = "-nacc" then call SET_OPTION (access_class_val, OFF);
		     else call BADOPT (argno);
		     end;				/* of list only args */
		else if operation = SET then do;
		     if arg = "-replace" | arg = "-rp" then call SET_OPTION (replace_val, ON);
		     else if arg = "-modify" | arg = "-md" then call SET_OPTION (replace_val, OFF);
		     else if (arg = "-sysdaemon") | (arg = "-sd") then call SET_OPTION (sysdaemon_val, ON);
		     else if (arg = "-no_sysdaemon") | (arg = "-nsd") then call SET_OPTION (sysdaemon_val, OFF);
		     else call BADOPT (argno);
		     end;
		else call BADOPT (argno);		/* haven't heard of this one */

	     else if pathname = "" then		/* pathname not seen yet, this must be it */
		pathname = arg;			/* just copy it */

	     else if want_mode then do;		/* this can only happen with SET operations */
		n_acl_modes = n_acl_modes + 1;	/* get to the next entry */
		acl_modes (n_acl_modes) = arg;	/* save it in the array */
		want_mode = "0"b;			/* and ask for a name next time around */
		end;
	     else do;
		n_acl_names = n_acl_names + 1;	/* prepare to use the next entry */
		acl_names (n_acl_names) = arg;	/* save the name in the array */
		if operation = SET then want_mode = "1"b;
		end;
	     end;					/* of argument loop */

/* Now, check the various possibilities for error */

	if af_sw & operation ^= LIST then do;		/* only list can be used as an AF */
	     call complain (error_table_$active_function, whoami);
	     goto MAIN_RETURN;
	     end;

	if operation ^= LIST & operation ^= ACCESSIBLE & pathname = "" then
						/* only listing has a default */
	     call USAGE (error_table_$noarg);

	if operation = SET & n_acl_modes = 0 then	/* must have at least one mode */
	     call USAGE (error_table_$noarg);

	if pathname = "" then			/* if nothing supplied, must be the default */
	     pathname = get_wdir_ ();

	type_suffix = "";
	do_tedious_star = "0"b;			/* wishful thinking */
	if type = MBX_ACL then type_suffix = "mbx";
	else if type = MSEG_ACL then type_suffix = "ms";
	else if limit_entry_types
	     then if entry_type.count = 1
		then if ^entry_type.suffixes (1).is_std_type
		     then type_suffix = entry_type.suffixes (1).suffix;
		     else;
		else do_tedious_star = "1"b;

	dname = "";                                       /* must initialize for later reference by the "lac" and "lnac" commands */
	ename = "";
	call expand_pathname_$add_suffix (pathname, type_suffix, dname, ename, code);

	if code ^= 0 then do;			/* unacceptable pathname */

/* fix bugs for TR # phx19075 */
	     if code = error_table_$root & operation = ACCESSIBLE & pathname = ">" then do; /* accept the ROOT directory */
		code = 0;
		dname = ">";

		if type_name = "" then do;
		     if acl_names (1) ^= "" then
			ename = acl_names (1);
		     else ename = "**";
		     end;
		end;
/* end of bug fix for TR # phx19075 */

	     else do;
		call complain (code, whoami, "^a", pathname);
		goto MAIN_RETURN;
	          end;
	     end;

	if operation ^= ACCESSIBLE & dname = ">" & ename = "" then
	     code = error_table_$root;

	else call check_star_name_$entry (ename, code);
	if code > 2 then do;
	     call complain (code, whoami, "^a", pathname_ (dname, ename));
	     goto MAIN_RETURN;
	     end;
	star_sw = (code > 0);			/* remember if it was a starname */
          all_stars = (code = 2);                           /* and whether it's one of the everything names */

	if operation = ACCESSIBLE then do;
	     star_sw = "1"b;	     
	     
	     if pathname ^= ">" then
		dname = pathname_ (dname, ename);

	     if type_name ^= "" then
		ename = "**." || rtrim (type_name);
	     else ename = "**";
		
               all_stars = (type_name = "");                /* Unless we got as type, it's all entries */
	     end;

          ename_suffix = reverse (before (reverse (ename), "."));
	if search (ename_suffix, "*?") ^= 0 then starname_suffix = "1"b;

	if operation = SET & n_acl_modes > n_acl_names then do;
						/* Apply the default for the final name */
	     n_acl_names = n_acl_names + 1;
	     if ename_suffix = "mbx" then
		acl_names (n_acl_names) = before (get_group_id_$tag_star (), ".") || ".*.*";
	     else acl_names (n_acl_names) = get_group_id_$tag_star ();
	     end;

	if operation = DELETE & n_acl_names = 0 & all_val = 0 then do;
	     n_acl_names = 1;
	     if ename_suffix = "mbx" then
		acl_names (1) = before (get_group_id_$tag_star (), ".") || ".*.*";
	     else acl_names (1) = get_group_id_$tag_star ();
	     end;


          if (type = MBX_ACL) then xacl_allowed = "1"b;     /* Always extended acls */
          else if (type = MSEG_ACL) then xacl_allowed = "1"b;
          else if (privilege ^= NORMAL) then xacl_allowed = "0"b; /* No hphcs_ or ring one stuff in fs_util_, after all */
          else if (raw_val > 0) then xacl_allowed = "0"b;   /* And certainly not if we were told -inase */
          else if all_stars then xacl_allowed = "0"b;       /* Not if we got ** or equivalent, either */
          else if (index (ename, ".") = 0) then xacl_allowed = "0"b; /* Single component name */
          else if (ename_suffix = "") then xacl_allowed = "0"b; /* The ename ends in a period */
          else if starname_suffix then xacl_allowed = "0"b; 
          else if (substr (ename_suffix, 1, 1) = "-") then xacl_allowed = "0"b; /* Reserved object types begin with "-" */
          else do;
               si.version = SUFFIX_INFO_VERSION_1;
               call fs_util_$suffix_info_for_type (ename_suffix, addr (si), code);
               if (code = error_table_$unsupported_operation) then
                    xacl_allowed = "0"b;
               else if (code =0) then
                    xacl_allowed = (^si.standard_object & si.extended_acl);
               else do;
                    call complain (code, whoami, "^a", pathname_ (dname, ename));
                    goto MAIN_RETURN;
                    end;
               end;

	if type_name ^= "" | type ^= BRANCH_ACL then
	     if (directory_val ^= 0) | (segment_val ^= 0) | (raw_val ^= 0) then do;
	          call complain (error_table_$inconsistent, whoami,
		     """-type"" ^[and ""-inase"" ^]^[and ""-seg^[_mode^;ment^]"" ^;^s^]^[and ""-dir^[_mode^;ectory^]""^]"
		     , (raw_val ^= 0), (segment_val ^= 0), (operation = ACCESSIBLE),
		     (directory_val ^= 0), (operation = ACCESSIBLE));
		goto MAIN_RETURN;
		end;

	if iacl_ring >= 0 then do;			/* check if we're allowed to */
	     if operation = LIST then
		min_ring = 0;			/* can list any ring */
	     else call cu_$level_get (min_ring);	/* otherwise, we must put up with what we've got */

	     if iacl_ring < min_ring then do;		/* sorry, no dice */
		call complain (error_table_$bad_ring_brackets, whoami,
		     "IACL ring number must be between ^d and 7, not ^d.", min_ring, iacl_ring);
		goto MAIN_RETURN;
		end;
	     end;

	else call cu_$level_get (iacl_ring);		/* otherwise, set the default */

	if operation = SET & replace_val = 0 & sysdaemon_val ^= 0 then do;
	     call cu_$arg_ptr_rel (abs (sysdaemon_val), ap, al, (0), P_arg_list_ptr);
	     call complain (error_table_$badopt, whoami,
		"^/^a may only be used in conjunction with -replace", arg);
	     goto MAIN_RETURN;
	end;

	all_sw = (all_val > 0);			/* now, set the flags the main program will use */
	chase_sw = (chase_val > 0);
	no_chase_sw = (chase_val < 0);
	replace_sw = (replace_val > 0);
	no_sysdaemon_sw = (sysdaemon_val < 0);
	brief_sw = (brief_val > 0);
	force_no_type = (raw_val > 0);
	ring_bracket_sw = (ring_bracket_val > 0);
	access_class_sw = (access_class_val > 0);

	segment_sw,explicit_sm_arg = (segment_val > 0);
	directory_sw,explicit_dr_arg = (directory_val > 0);

	if (operation = SET) & (^replace_sw) then	/* Don't add *.SysDaemon if just adding stuff to the ACL */
	     no_sysdaemon_sw = "1"b;
          else if (operation = DELETE) then                 /* Similarly, if deleting, and there isn't one there now, */
               no_sysdaemon_sw = "1"b;                      /* don't add it */

	if ^(segment_sw | directory_sw) then do; /* figure out if segs or dirs */
	     if type = BRANCH_ACL & operation = SET & ^xacl_allowed & star_sw then do;
		do idx = 1 to n_acl_modes while (^segment_sw & ^directory_sw);
		     if acl_modes (idx) ^= "n" & acl_modes (idx) ^= "null" then
			if search (acl_modes (idx), "sma") > 0 then
			     directory_sw = "1"b;
			else segment_sw = "1"b;
		     end;
		if ^segment_sw & ^directory_sw then segment_sw = "1"b;
						/* default to segs, msfs, and dmfs */
		end;
	     else if operation = ACCESSIBLE & type_name = "" & n_acl_modes > 0 then
		if search (acl_modes (1), "sma") > 0 then
		     directory_sw = "1"b;
		else segment_sw = "1"b;
	     else;				/* all but SET default to everything */
	     end;

	else xacl_allowed = "0"b;

          if iacl_sw 
               then do;
                     segment_sw = "0"b;
                     directory_sw = "1"b;
                    end;

	if operation = ACCESSIBLE then do;
	     brief_sw = "1"b;			/* avoid "no match for .... " messages */

	     if n_acl_modes = 0 then
		acl_mask = copy ("1"b, 36);
	     else do;
		si.version = SUFFIX_INFO_VERSION_1;
                    if (type_name ^= "") then
                         call fs_util_$suffix_info_for_type (type_name, addr (si), (0));
                    else if directory_sw then
                         call fs_util_$suffix_info_for_type (FS_OBJECT_TYPE_DIRECTORY, addr (si), (0));
                    else call fs_util_$suffix_info_for_type (FS_OBJECT_TYPE_SEGMENT, addr (si), (0));

		acl_mask = convert_mode (acl_modes (1));
		end;

	     if n_acl_names = 0 then do;
		access_name = get_group_id_$tag_star ();
		use_access_modes = "1"b;
		end;
	     else do;
		access_name = acl_names (1);
		if index (access_name, ".") = 1 | index (access_name, "..") > 0
		     | substr (access_name, length (rtrim (access_name)), 1) = "." then
		     use_access_modes = "0"b;
		else do;
		     use_access_modes = "1"b;
                         call set_components (access_name, (""));
		     end;
		end;
	     end;

	return;					/* end of argument processing */
%page;
SET_OPTION:
     proc (P_option, P_on_off);

/* This procedure (internal to process_arguments) sets P_option to be the index of the first
   occurrence of a control argument to set the specified option. It is set negative to indicate
   that the option is to be off, and positive to indicate that it is to be on. */

dcl	(
	P_option			fixed bin,
	P_on_off			bit (1) aligned
	)			parameter;

	if P_option = 0 then			/* never specified so far. Remember argument position */
	     if P_on_off = ON then
		P_option = argno;			/* positive value indicates option ON */
	     else P_option = 0 - argno;		/* negative value indicates option OFF */

	else do;					/* Some form of option already specified */
	     if P_option < 0 then			/* Already OFF. Must we invert it? */
		if P_on_off = ON then		/* Yes, invert, but keep original arg number */
		     P_option = 0 - P_option;

	     if P_option > 0 then			/* Already ON. Must we invert it? */
		if P_on_off = OFF then		/* Yes, invert, but keep original arg number */
		     P_option = 0 - P_option;
	     end;

	return;
     end SET_OPTION;
%page;
USAGE:
     proc (P_code);

/* This procedure prints out a Usage message for each type of command */

dcl	P_code			fixed bin (35);

	if operation = SET then			/* requires at least one mode; Name always defaults */
	     call complain (P_code, whoami, "^/Usage:^-^a Path Mode1 {Name1} ... {ModeN {NameN}} {-control_args}",
		whoami);

	else if operation = DELETE then
	     call complain (P_code, whoami, "^/Usage:^-^a Path {Name1} ... {NameN} {-control_args}", whoami);

	else if operation = LIST then			/* special defaults -- sometimes is WDIR */
	     if (type = BRANCH_ACL) | iacl_sw then
		call complain (P_code, whoami, "^/Usage:^-^a {Path} {Name1} ... {NameN} {-control_args}", whoami);

	     else call complain (P_code, whoami, "^/Usage:^-^a Path {Name1} ... {NameN} {-control_args}", whoami);

	goto MAIN_RETURN;

     end USAGE;
%page;
BADOPT:
     proc (P_argno);

/* This procedure prints an error message for the control argument identified by P_argno, which
   is expected to be one of the option flags used in SET_OPTION, above. */

dcl	P_argno			fixed bin parameter;

dcl	ap			pointer;
dcl	al			fixed bin (21);
dcl	arg			char (al) based (ap);

          call cu_$arg_ptr_rel (abs (P_argno), ap, al, (0), P_arg_list_ptr); /* remember, option values may be signed */

	call complain (error_table_$badopt, whoami, "^a", arg);

	goto MAIN_RETURN;

     end BADOPT;
%page;
process_entry_type_list:	   proc(entry_type_list, entry_type_struct_ptr, limit_entry_selections);

dcl entry_type_list		char (*) parameter;
dcl entry_type_struct_ptr	pointer parameter;
dcl limit_entry_selections	bit (1) aligned;

dcl types_len	fixed bin (24);
dcl types_ptr	pointer;
dcl types		char (types_len) based (types_ptr);
dcl entry_type_no	fixed bin;
dcl this_type	char (32);

	
/* copy entry_type_list into "real" storage */

	     types_ptr = null ();
	     on cleanup
		begin;
		     if types_ptr ^= null () then free types in (system_area);
		end;

	     types_len = length (entry_type_list);
	     allocate types
		set (types_ptr) in (system_area);
	     types = entry_type_list;

/* to start off, get a count of the number of types in the string */

	     do entry_type_count = 1
		repeat (entry_type_count + 1)
		while (index (types, ",") > 0);
		types = after (types, ",");
	     end;

/* allocate the entry_type structure, to be used later in this command */

	     allocate entry_type
		set (entry_type_struct_ptr)
		in (system_area);

	     entry_type_struct_ptr -> entry_type.suffixes.suffix (*) = "";

/* for each potential entry type, validate it and add it to the structure */

	     types = entry_type_list;
	     type_info.version = SUFFIX_INFO_VERSION_1;
	     entry_type_no = 1;
	     do while (types ^= "");
		this_type = before (types, ",");
		if substr (this_type, 1, 1) ^= "-" then do;
		     entry_type.suffixes (entry_type_no).is_std_type = "1"b;  /* Presumed innocent ... */
		     if this_type = "link" then do;
			call complain (0, whoami, "This commands does not support links.");
			goto MAIN_RETURN;
		     end;

		     else if this_type = "segment" then this_type = FS_OBJECT_TYPE_SEGMENT;
		     else if this_type = "directory" then this_type = FS_OBJECT_TYPE_DIRECTORY;
		     else if this_type = "multisegment_file" then this_type = FS_OBJECT_TYPE_MSF;
		     else if this_type = "data_management_file" then this_type = FS_OBJECT_TYPE_DM_FILE;
		     else entry_type.suffixes (entry_type_no).is_std_type = "0"b;  /* ... until proven guilty */
		     entry_type_struct_ptr -> entry_type.suffixes.suffix (entry_type_no) = this_type;
		     call fs_util_$suffix_info_for_type (this_type, addr (type_info), code);
		     if code = 0 then entry_type_no = entry_type_no + 1;
		     else goto BAD_TYPE_ERROR;
		end;
		else do;
BAD_TYPE_ERROR:	     free types_ptr -> types in (system_area);
		     limit_entry_selections = "0"b;
		     return;
		end;

		types = after (types, ",");
	     end;

/* free the types variable and set the limit_entry_selections flag */

	     free types_ptr -> types
		in (system_area);

	     entry_type_struct_ptr -> entry_type.count = entry_type_no - 1;
	     if entry_type_struct_ptr -> entry_type.count = 0
		then limit_entry_selections = "0"b;
	     else limit_entry_selections = "1"b;

	     return;

	end process_entry_type_list;
%page;
     end process_arguments;
%page;

entry_type_selected:	proc (entry_type_struct_ptr, fs_type) returns (bit (1) aligned);


dcl entry_type_struct_ptr pointer parameter;
dcl fs_type char (32) parameter;
dcl entry_type_no fixed bin;

	     do entry_type_no = 1 to entry_type_struct_ptr -> entry_type.count;
		if entry_type_struct_ptr -> entry_type.suffixes.suffix (entry_type_no) = fs_type then return ("1"b);
	     end;
	     return ("0"b);

	end entry_type_selected;

%page;
modified_star_processing:
	procedure ();
/* Routine to do star processing when more than one entry type is specified
   by -slet */

dcl  star_idx		fixed bin;
dcl  type_idx		fixed bin;
dcl  temp_ename		char (32);
dcl  std_type		bit (1) aligned;


	std_type = "0"b;
	do type_idx = 1 to entry_type.count;
	     if entry_type.suffixes (type_idx).is_std_type
	     then std_type = "1"b;			/* at least one std type is specified */
	end;

	allocate star_match in (system_area);

	si.version = SUFFIX_INFO_VERSION_1;

	do star_idx = 1 to star_entry_count;
	     do type_idx = 1 to entry_type.count;
		if ^entry_type.suffixes (type_idx).is_std_type
		then do;				/* try all extended types first */
		     call expand_pathname_$add_suffix (pathname, (entry_type.suffixes(type_idx).suffix),
			dname, temp_ename, code);
 		     if code ^= 0 then goto NEXT_TYPE_NAME;
		     do star_name_idx = star_entries(star_idx).nindex to
				    star_entries(star_idx).nindex + star_entries(star_idx).nnames -1;
			call match_star_name_ (star_names (star_name_idx), temp_ename, code);
			if code = 0 then do;
/* really should check type here */
			     call fs_util_$suffix_info (dname, star_names (star_name_idx), addr (si), code);
			     if code = error_table_$not_seg_type then goto TRY_STD;
						/* All the names on an extended entry must have same suffix.
						   This entry is not of the type that this name indicates;
						   therfore, it cannot be an extended entry */
			     else if code = 0 & ^si.flags.standard_object
			     then star_match (star_name_idx) = "1"b;
			     goto NEXT_STAR_NAME;
			end;
		     end;
		end;
NEXT_TYPE_NAME:	
	     end;

TRY_STD:	     if std_type				/* The name did not fit any extended types AND the
						   user has requested a standard entry type */
	     then do star_name_idx = star_entries(star_idx).nindex to
			         star_entries(star_idx).nindex + star_entries(star_idx).nnames -1;
		call match_star_name_ (star_names (star_name_idx), ename, code);
		if code = 0 then do;
		     call fs_util_$suffix_info (dname, star_names (star_name_idx), addr (si), code);
		     if code = 0
		     then if si.flags.standard_object
			then star_match (star_name_idx) = "1"b;
		     goto NEXT_STAR_NAME;
		end;
	     end;

NEXT_STAR_NAME:
	end;
         return;
     end modified_star_processing;
%page;


build_new_acl:
     procedure ();

/* In this procedure, old_acl and new_acl are two equally large structures, each with
   enough entries to have one for each in the object's current ACL and one for each
   name specified on the command line. The old_acl entries start out by being a copy
   of the object's current ACL, and new_acl is empty. As each of the command line
   arguments is examined, all matching old_acl entries are moved to new_acl, and
   all non-matching ones without missing components are added to both old_acl and
   new_acl. */



	if (operation = SET) & replace_sw then do;	/* If doing wholesale replacement, get out early */
	     call build_replacement_acl ();
	     return;
	     end;

	if (operation = ACCESSIBLE) & use_access_modes then return;
						/* If listing things accessable just to US, */
						/* don't even bother listing the ACL */

	call get_acl ();				/* List the original object ACL */
	original_count = general_acl.count;		/* Remember how large it started */

	if (operation = LIST) & (n_acl_names = 0) then return;
						/* List the whole ACL, which is ready right now */

/* Now, allocate the old_acl and new_acl structures, with one entry for each entry from the old ACL
   plus one for each name supplied on the command line if the operation is SET. If the operation is
   LIST or ACCESSABLE, we know we won't be making the list any larger, so just use the structure
   gotten from get_acl as the old_acl.  Because of the refer extents in general_acl, we have to
   play games with acl_count here. */

	if (operation = SET) then			/* Figure out how large to make our copies */
	     acl_count = original_count + n_acl_names;
	else acl_count = original_count;

	if (operation = SET) then			/* Allocate a large enough copy if we're going to update it */
	     call enlarge_old_acl ();
	else old_acl_ptr = acl_ptr;			/* Otherwise, recycle the old one */

	call allocate_new_acl ();

	if (operation = DELETE) then			/* Keep all that don't match */
	     call build_nonmatching_acl ();
	else if (operation = SET) then		/* Keep all that does match, */
	     call build_matching_acl ("1"b);		/* and anything else from the command line, besides */
	else if (operation = LIST) then		/* Keep only things which match */
	     call build_matching_acl ("0"b);
	else if (operation = ACCESSIBLE) then call build_matching_acl ("0"b);

	call free (old_acl_ptr);			/* Free the old acl and the used bits */
	call free (used_bits_ptr);

	acl_count = new_acl.count;			/* Make it available for later uses */
	acl_ptr = new_acl_ptr;			/* copy to ones we will use to call primitives */
	new_acl_ptr = null ();			/* mark pointer as unused to avoid freeing through it */

	return;

/**/

enlarge_old_acl:
     procedure ();

declare	acle_idx			fixed bin;


	allocate old_acl in (system_area) set (old_acl_ptr);
						/* acl_count was set above */
	old_acl.version = GENERAL_ACL_VERSION_1;
	old_acl.count = general_acl.count;		/* Start with the original count of ACL entries */

	do acle_idx = 1 to old_acl.count;		/* Copy the entries from the object's ACL into this ACL */
	     old_acl.entries (acle_idx) = general_acl.entries (acle_idx);
	     end;

	call free (acl_ptr);			/* Get rid of the original one */
						/* We now have a copy in old_acl */
	return;
     end enlarge_old_acl;



allocate_new_acl:
     procedure ();

	allocate new_acl in (system_area) set (new_acl_ptr);
						/* Make a place to put the results */
	new_acl.count = 0;				/* starting out empty */
	new_acl.version = GENERAL_ACL_VERSION_1;

	used_bits_count = n_acl_names + acl_count;
	allocate used_bits in (system_area) set (used_bits_ptr);
	unspec (used_bits) = ""b;

	return;
     end allocate_new_acl;

/**/

build_replacement_acl:
     procedure ();

/* This procedure is used to build a whole replacement ACL for set_acl -replace.
   It relies on the harcore's SysDaemon switch to provide or not provide an entry
   for *.SysDaemon. */

declare	acle_idx			fixed bin;


	acl_count = n_acl_names;			/* Same size as the number of command-line arguments */
	allocate general_acl in (system_area) set (acl_ptr);
	general_acl.count = acl_count;
	general_acl.version = GENERAL_ACL_VERSION_1;

	do acle_idx = 1 to n_acl_names;		/* Fill in names from command arguments */
	     call set_components (acl_names (acle_idx), (""));
						/* "Normalize" the supplied access name */
	     general_acl.access_name (acle_idx) = acl_names (acle_idx);
	     general_acl.mode (acle_idx) = convert_mode (acl_modes (acle_idx));
	     general_acl.status_code (acle_idx) = 0;
	     end;

	return;
     end build_replacement_acl;

/**/

build_matching_acl:
     procedure (add_new_names);

/* Go through the object's ACL, and build a new one. The match_acl procedure will copy any
   names that match in the old ACL into the new_acl; the add_new_names switch determines
   whether non-matching names from the command line will be added, as well (true for SET) */


declare	add_new_names		bit (1) aligned parameter;

declare	given_name_idx		fixed bin;
declare	old_acle_idx		fixed bin;


	do given_name_idx = 1 to n_acl_names;		/* Look at each name requested on the command line */
	     if match_acl (given_name_idx, "1"b) then goto CHECK_NEXT_GIVEN_NAME;
						/* If there were matches, don't add it */

	     if add_new_names then do;
		new_acl.count = new_acl.count + 1;	/* No matches found, so make a whole new entry */
		new_acl.access_name (new_acl.count) = acl_names (given_name_idx);
		new_acl.mode (new_acl.count) = convert_mode (acl_modes (given_name_idx));

		old_acl.count = old_acl.count + 1;	/* Also add this entry to the old ACL structure, so */
		old_acl.access_name (old_acl.count) = new_acl.access_name (new_acl.count);
		end;				/* that later names will match against it */

CHECK_NEXT_GIVEN_NAME:
	     end;					/* acl_name loop */

	if ^add_new_names then return;		/* If not keeping names from original, quit now */

	do old_acle_idx = 1 to original_count;		/* Add anything that's left, BUT only from the ACL */
						/* we started with, omitting anything added above */
	     if ^used_bits (old_acle_idx) then do;	/* Didn't get matched by anything, so keep it */
		new_acl.count = new_acl.count + 1;	/* so it's still there in the new ACL */
		new_acl.status_code (new_acl.count) = 0;
		new_acl.access_name (new_acl.count) = old_acl.access_name (old_acle_idx);
		new_acl.mode (new_acl.count) = old_acl.mode (old_acle_idx);
		end;
	     end;

	return;
     end build_matching_acl;

/**/

build_nonmatching_acl:
     procedure ();

declare	given_name_idx		fixed bin;
declare	old_acle_idx		fixed bin;
declare	acle_matched		bit (1) aligned;


	do given_name_idx = 1 to n_acl_names;		/* Look at each name requested on the command line */
	     acle_matched = match_acl (given_name_idx, "0"b);
						/* Ignore the match result-- match_acl has already done */
	     end;					/* everything we need done (setting the used_bits bit) */

	if all_sw then
	     do old_acle_idx = 1 to original_count;
	     if old_acl.access_name (old_acle_idx) = "*.SysDaemon.*"
		then;				/* don't touch it! */
	     else used_bits (old_acle_idx) = "1"b;
	end;

	call free (new_acl_ptr);			/* clean up after ourselves */
	allocate new_acl in (system_area) set (new_acl_ptr);
						/* Make a place to put the results */
	new_acl.count = 0;				/* starting out empty */
	new_acl.version = GENERAL_ACL_VERSION_1;

	do old_acle_idx = 1 to original_count;		/* Add anything that's left, BUT only from the ACL */
						/* we started with, omitting anything added above */
	     if ^used_bits (old_acle_idx)		/* Didn't get matched by anything */
	     then do;
		new_acl.count = new_acl.count + 1;	/* so it's still there in the new ACL */
		new_acl.status_code (new_acl.count) = 0;
		new_acl.access_name (new_acl.count) = old_acl.access_name (old_acle_idx);
		new_acl.mode (new_acl.count) = old_acl.mode (old_acle_idx);
		end;
	     end;

	return;
     end build_nonmatching_acl;

/**/

match_acl:					/* cribbed from old find_common_acl_names_ */
     proc (name_idx, copy_matching_names) returns (bit (1) aligned);

declare	name_idx			fixed bin parameter;
declare	copy_matching_names		bit (1) aligned parameter;

declare	used			bit (1) aligned;
declare	old_acle_idx		fixed bin;
declare	missing_component		bit (1) aligned;
declare	comp_idx			fixed bin;
declare	given_comp		(3) char (32) aligned;
declare	acle_comp			(3) char (32) aligned;


	used = "0"b;
	missing_component = "0"b;			/* Missing component in name from command line */

	call set_components (acl_names (name_idx), given_comp);
	do comp_idx = 1 to 3 while (^missing_component);
	     if given_comp (comp_idx) = "" then missing_component = "1"b;
	     end;

	do old_acle_idx = 1 to old_acl.count;
	     call set_components (old_acl.access_name (old_acle_idx), acle_comp);

	     do comp_idx = 1 to 3;			/* See if the non-null components match the current */
		if given_comp (comp_idx) ^= "" then	/* entry from the old ACL */
		     if given_comp (comp_idx) ^= acle_comp (comp_idx) then goto TRY_NEXT_OLD_ACLE;
		end;

	     used = "1"b;				/* We managed to use this particular command-line ACL name */
	     if ^used_bits (old_acle_idx) then do;	/* (and this is the first time, if true) */
		used_bits (old_acle_idx) = "1"b;

		if copy_matching_names then do;	/* For set or list, copy this term into the new ACL */
		     new_acl.count = new_acl.count + 1;
		     new_acl.access_name (new_acl.count) = old_acl.access_name (old_acle_idx);
		     new_acl.status_code (new_acl.count) = 0;
		     if (operation = SET) then
			new_acl.mode (new_acl.count) = convert_mode (acl_modes (name_idx));
		     else new_acl.mode (new_acl.count) = old_acl.mode (old_acle_idx);
		     end;
		end;
TRY_NEXT_OLD_ACLE:
	     end;

/* Now, we've finished checking this particular command-line name, and we decide what to tell our caller.
   For all operations, if the name matched anywhere, quit and return "1"b.  Then, for set_acl, if the name
   was complete (no missing components, like Klensin..*), return the used bit no matter what its value,
   and the caller will add the whole name to the new ACL if it didn't match here.  If neither of those
   cases apply, there is a genuine non-match, and except in -brief mode, we complain about it. After
   complaining, "1"b is always returned, since the name has seen all the use it will ever see. */

          if used then return ("1"b);

          if (operation = SET) & (^missing_component) then return (used);

          if ^brief_sw & (original_count > 0) then
               call complain (0, whoami,
                    "No match for ^a on ^[I^]ACL of ^a", acl_names (name_idx), iacl_sw, err_path);

          return ("1"b);
     end match_acl;

     end build_new_acl;
%page;
convert_mode:
     proc (mode_string) returns (bit (36) aligned);

declare	mode_string		char (36),
	(idx, jdx)		fixed bin,
	mode			bit (36) aligned;

	if mode_string = "null" | mode_string = "n" then return (""b);

	mode = ""b;
	do idx = 1 to length (rtrim (mode_string));
	     jdx = index (rtrim (si.modes), substr (mode_string, idx, 1));
	     if jdx = 0 then do;
		call complain (0, whoami, "Invalid mode^[ for ^a^;^s^]. ^a^[ on ^a^]", si.extended_acl,
		     si.plural_name, mode_string, (err_path ^= ""), err_path);
		goto SKIP_MATCH;
		end;
	     substr (mode, jdx, 1) = "1"b;
	     end;

	return (mode);
     end convert_mode;



mode_representation:
     procedure (mode_bits) returns (char (36) varying);

declare	mode_bits			bit (36) aligned parameter;

declare	bit_idx			fixed bin;
declare	mode_string		char (36) varying;


	if (mode_bits = ""b) then return ("null");

	mode_string = "";
	do bit_idx = 1 to length (rtrim (si.modes));
	     if (substr (mode_bits, bit_idx, 1) = "1"b) then
		mode_string = mode_string || substr (si.modes, bit_idx, 1);
	     end;

	return (mode_string);
     end mode_representation;
%page;
get_suffix_info:
     proc ();


	si.version = SUFFIX_INFO_VERSION_1;

	if ^(force_no_type | iacl_sw) then do;		/* Normal case */
	     call fs_util_$suffix_info (dname, ename, addr (si), code);
	     if (code = error_table_$not_seg_type) & ((type = MBX_ACL) | (type = MSEG_ACL)) then do;
		if ^star_sw then
		     call complain (0, whoami, "^a is not a ^[mailbox^;message segment^].", err_path,
			(type = MBX_ACL));
		goto SKIP_MATCH;
		end;

	     else if code = error_table_$unsupported_operation & operation = LIST then
		code = error_table_$noentry;
		     
	     if code ^= 0 then do;
		call complain (code, whoami, "^a", err_path);
		goto SKIP_MATCH;
		end;

	     if (operation = SET) & starname_suffix & (^si.standard_object) then goto SKIP_MATCH;
	     end;

	else do;					/* No-type forcing or IACL */
	     call hcs_$status_minf (dname, ename, 1, hcs_type, bit_count, code);
	     if code ^= 0 then goto SKIP_THIS_ONE;

/*
   since we want to reference the current entry as a standard one (seg, dir,
   msf, or dmf) and we have been able to get status info, we get info on ACL
   modes by calling fs_util_ with a given type.  the algorithm to do this is:

	if ENTRY_IS_A_DIRECTORY and WE_WANT_ITS_SEG_IACL
	then GET_SUFFIX_INFO_WITH_SEG_MODES_AND_DIRECTORY_TYPE
	else if ENTRY_IS_A_DIRECTORY and WE_WANT_ITS_DIR_IACL
	     then GET_SUFFIX_INFO_WITH_DIR_MODES_AND_DIR_TYPE
	     else if ENTRY_IS_A_DIRECTORY and WE_WANT_ITS_ACL
		then GET_SUFFIX_INFO_FOR_DIRS
		else if ENTRY_IS_A_MSF
		     then GET_SUFFIX_INFO_FOR_MSFS
		     else ENTRY_IS_A_SEG so GET_SUFFIX_INFO_FOR_SEGS
*/

	     if (hcs_type = DIRECTORY) & (bit_count = 0) then
		if (type = SEGMENT_IACL) then do;
		     call fs_util_$suffix_info_for_type (FS_OBJECT_TYPE_SEGMENT, addr (si), code);
		     si.type = FS_OBJECT_TYPE_DIRECTORY;
		     end;
		else if (type = DIRECTORY_IACL) then
		     call fs_util_$suffix_info_for_type (FS_OBJECT_TYPE_DIRECTORY, addr (si), code);
		else call fs_util_$suffix_info_for_type (FS_OBJECT_TYPE_DIRECTORY, addr (si), code);
	     else if (hcs_type = DIRECTORY)
		then call fs_util_$suffix_info_for_type (FS_OBJECT_TYPE_MSF, addr (si), code);
	     else call fs_util_$suffix_info_for_type (FS_OBJECT_TYPE_SEGMENT, addr (si), code);

	     if (code ^= 0) then do;
SKIP_THIS_ONE:
		call complain (code, whoami, "^a", err_path);
		goto SKIP_MATCH;
		end;
	     end;

	return;
     end get_suffix_info;
%page;
get_acl:
     procedure ();

dcl  list_acl_entry	entry variable options (variable);


	call free (other_acl_ptr);			/* Get rid of leftovers */
	call free (acl_ptr);

	if (object_type = FS_OBJECT_TYPE_DIRECTORY) & (type = SEGMENT_IACL) then do;
	     call hcs_$list_inacl (dname, ename, system_area_ptr, other_acl_ptr, (null ()), acl_count, iacl_ring, code);
	     call make_general_acl ("segment_array");
	     end;

	else if (object_type = FS_OBJECT_TYPE_DIRECTORY) & (type = DIRECTORY_IACL) then do;
	     call hcs_$list_dir_inacl (dname, ename, system_area_ptr, other_acl_ptr, (null ()), acl_count, iacl_ring,
		code);
	     call make_general_acl ("directory_array");
	     end;


	else if force_no_type then do;
	     call fs_util_$make_entry_for_type (object_type, "list_acl", list_acl_entry, code);
	     call list_acl_entry (dname, ename, GENERAL_ACL_VERSION_1, system_area_ptr, acl_ptr, code);

	     end;

	else call fs_util_$list_acl (dname, ename, GENERAL_ACL_VERSION_1, system_area_ptr, acl_ptr, code);

	if code ^= 0 then do;
	     call complain (code, whoami, "^a", err_path);
	     goto SKIP_MATCH;
	     end;

	call free (other_acl_ptr);			/* In case we had to allocate it */

	if (acl_ptr = null ()) then do;		/* Although the primitives always return a null pointer, */
	     acl_ptr = addr (empty_acl_overlay);	/* since we loop through ACL entries, this is easier to use */
	     acl_ptr -> general_acl.version = GENERAL_ACL_VERSION_1;
	     acl_ptr -> general_acl.count = 0;
	     end;

	acl_count = general_acl.count;

	return;
     end get_acl;
%page;
replace_the_acl:
     proc ();

dcl complained_about_specific_acl bit (1) aligned;
dcl idx fixed bin;

/* This procedure handles the various special cases, converting the ACL
   between various formats as needed. */


	other_acl_ptr = null ();

	if (object_type = FS_OBJECT_TYPE_DIRECTORY) then do;
	     if (type = SEGMENT_IACL) then do;
		call make_other_acl ("segment_array");
		call hcs_$replace_inacl (dname, ename, other_acl_ptr, acl_count, no_sysdaemon_sw, iacl_ring, code);
		call copy_acle_status ("segment");
		end;

	     else if (type = DIRECTORY_IACL) then do;
		call make_other_acl ("directory_array");
		call hcs_$replace_dir_inacl (dname, ename, other_acl_ptr, acl_count, no_sysdaemon_sw, iacl_ring, code)
		     ;
		call copy_acle_status ("directory");
		end;

	     else if (privilege = HPHCS) then do;
		call make_other_acl ("directory_array");
		call hphcs_$replace_dir_acl (dname, ename, other_acl_ptr, acl_count, no_sysdaemon_sw, code);
		call copy_acle_status ("directory");
		end;

	     else if (privilege = LIBRARY) then do;
		call make_other_acl ("directory_array");
		call installation_tools_$replace_dir_acl (dname, ename, other_acl_ptr, acl_count, no_sysdaemon_sw,
		     code);
		call copy_acle_status ("directory");
		end;

               else if force_no_type then do;
                    call make_other_acl ("directory_array");
                    call hcs_$replace_dir_acl (dname, ename, other_acl_ptr, acl_count, no_sysdaemon_sw, code);
                    call copy_acle_status ("directory");
                    end;

               else call fs_util_$replace_acl (dname, ename, acl_ptr, no_sysdaemon_sw, code);
	     end;

	else if (object_type = FS_OBJECT_TYPE_SEGMENT) then do;
	     if (privilege = HPHCS) then do;
		call make_other_acl ("segment_array");
		call hphcs_$replace_acl (dname, ename, other_acl_ptr, acl_count, no_sysdaemon_sw, code);
		call copy_acle_status ("segment");
		end;

	     else if (privilege = LIBRARY) then do;
		call make_other_acl ("segment_array");
		call installation_tools_$replace_acl (dname, ename, other_acl_ptr, acl_count, no_sysdaemon_sw, code);
		call copy_acle_status ("segment");
		end;

	     else if force_no_type then do;
		call make_other_acl ("segment_array");
		call hcs_$replace_acl (dname, ename, other_acl_ptr, acl_count, no_sysdaemon_sw, code);
		call copy_acle_status ("segment");
		end;

               else call fs_util_$replace_acl (dname, ename, acl_ptr, no_sysdaemon_sw, code);
	     end;

          else call fs_util_$replace_acl (dname, ename, acl_ptr, no_sysdaemon_sw, code);

	call free (other_acl_ptr);			/* If we made one, it's useless now */

	if code ^= 0 then do;
	     complained_about_specific_acl = "0"b;
	     if acl_ptr ^= null () then
		do idx = 1 to general_acl.count;
		if general_acl.status_code (idx) ^= 0 then do;
		     complained_about_specific_acl = "1"b;
		     call complain (general_acl.status_code (idx), whoami, "^a ^a on ^a", mode_representation (general_acl.mode (idx)), general_acl.access_name (idx), err_path);
		     end;
		end;
	     if ^complained_about_specific_acl then
		call complain (code, whoami, "^a", err_path);
	     goto SKIP_MATCH;
	     end;

	return;
     end replace_the_acl;

/*  */

list_the_acl:
     proc ();

declare	acle_idx			fixed bin;
declare	real_rings		(3) fixed bin (3);
declare	dir_rings			(2) fixed bin (3) based (addr (real_rings));
declare	rings			(si.num_ring_brackets) fixed bin (3) based (addr (real_rings));


	if star_sw then call ioa_ ("  ^a", err_path);

	if ring_bracket_sw then do;
               if si.num_ring_brackets = 0 then
                    call complain (0, whoami, "The ^a object type does not support ring brackets.", si.type_name);

               else if ^force_no_type then
                    call fs_util_$get_ring_brackets (dname, ename, rings, code);

               else if (object_type = FS_OBJECT_TYPE_MSF) then do;
                    call hcs_$get_ring_brackets (err_path, "0", rings, code);
                    if (code = error_table_$noentry) then
                         call hcs_$get_dir_ring_brackets (dname, ename, dir_rings, code);
                    end;

               else if (object_type = FS_OBJECT_TYPE_DIRECTORY) then
                    call hcs_$get_dir_ring_brackets (dname, ename, dir_rings, code);

               else call hcs_$get_ring_brackets (dname, ename, rings, code);

	     if code ^= 0 then call complain (code, whoami, "Getting ring brackets for ^a", err_path);
	     else if si.num_ring_brackets > 0 then
		call ioa_ ("^v(^d, ^)^d", si.num_ring_brackets - 1, rings, rings (si.num_ring_brackets));
	     end;

	if access_class_sw then do;
	     call hcs_$get_access_class (dname, ename, access_class, code);
	     if code ^= 0 then call complain (code, whoami, "^a", err_path);
	     call convert_authorization_$to_string_short (access_class, buffer, code);
	     if code ^= 0 then call complain (code, whoami, "^a", err_path);
	     if buffer = "" then buffer = "system_low";
	     call ioa_ ("^a", buffer);
	     end;

	if (original_count = 0) | (acl_ptr = null ()) then
	     if ^brief_sw then call complain (0, whoami, "Empty ^[^[segment ^;directory ^]I^;^s^]ACL for ^a.",
                                iacl_sw, (type = SEGMENT_IACL), err_path);

	do acle_idx = 1 to general_acl.count;
	     if (general_acl.status_code (acle_idx) ^= 0) then goto SKIP_THIS_ACLE;

	     if af_sw then do;
		if (length (ret_str) > 0) then ret_str = ret_str || " ";
		ret_str = ret_str || mode_representation (general_acl.mode (acle_idx));
		ret_str = ret_str || " ";
		ret_str = ret_str || rtrim (general_acl.access_name (acle_idx));
		end;

	     else call ioa_ ("^va^2x^a", max (4, si.max_mode_len), mode_representation (general_acl.mode (acle_idx)),
		     general_acl.access_name (acle_idx));

SKIP_THIS_ACLE:
	     end;

	if ^af_sw & (general_acl.count > 0) then call ioa_ ();

	return;
     end list_the_acl;
%page;
print_accessible:
     proc ();

declare	acle_idx			fixed bin;
declare	modes			bit (36) aligned;


	if use_access_modes then do;
	     if force_no_type then
		call hcs_$get_user_access_modes (dname, ename, access_name, -1, modes, (""b), code);
	     else call fs_util_$get_user_access_modes (dname, ename, access_name, -1, modes, (""b), code);

	     if code ^= 0 then do;
		call complain (code, whoami, "Listing access for ^a.", err_path);
		return;
		end;

	     if accessible = ((modes & acl_mask) ^= ""b) then
		call ioa_ ("^va^2x^a", max (4, si.max_mode_len), mode_representation (modes), ename);
	     end;

	else if (acl_count = 0) then do;
	     if ^accessible then call ioa_ ("^vx^a", si.max_mode_len + 2, ename);
	     end;

	else do;
	     do acle_idx = 1 to general_acl.count;
		if accessible = ((general_acl.mode (acle_idx) & acl_mask) ^= ""b) then
		     call ioa_ ("^va^2x^32a^a", max (4, si.max_mode_len),
			mode_representation (general_acl.mode (acle_idx)), ename,
			general_acl.access_name (acle_idx));
		end;
	     end;
	return;

     end print_accessible;

/**/

check_for_acle_errors:
     procedure ();

declare	acle_idx			fixed bin;


	if (operation = ACCESSIBLE) then return;	/* No errors possible here */

	do acle_idx = 1 to general_acl.count;
	     if (general_acl.status_code (acle_idx) = 0) then ;
	     else if brief_sw & (general_acl.status_code (acle_idx) = error_table_$user_not_found) then ;
	     else call complain (general_acl.status_code (acle_idx), whoami, "^a for ^a.",
		     general_acl.access_name (acle_idx), err_path);
	     end;

	return;
     end check_for_acle_errors;

/**/

set_components:
     proc (sc_access_name, sc_component);

declare	sc_access_name		char (*),
	sc_component		(3) char (32) aligned;

declare	(
	sc_dot_count		init (0),
	sc_dot_loc		(2) init ((2) 0),
	sc_i,
	sc_len
	)			fixed bin;

	sc_component (*) = "";
	if sc_access_name = "." then do;
	     sc_component (3) = "*";
	     sc_access_name = "..*";
	     return;
	     end;

	sc_len = index (sc_access_name, " ") - 1;
	if sc_len = -1 then sc_len = length (sc_access_name);
	else if verify (substr (sc_access_name, sc_len + 1), " ") ^= 0 then do;
BADNAME:
	     call complain (error_table_$bad_name, whoami, "^a", sc_access_name);
	     goto MAIN_RETURN;
	     end;

	do sc_i = 1 to sc_len;
	     if substr (sc_access_name, sc_i, 1) = "." then do;
		sc_dot_count = sc_dot_count + 1;
		if sc_dot_count > 2 then go to BADNAME;
		sc_dot_loc (sc_dot_count) = sc_i;
		end;
	     end;

	if sc_dot_count = 0 then do;
	     sc_component (1) = sc_access_name;
	     sc_component (2), sc_component (3) = "*";
	     substr (sc_access_name, sc_len + 1, 4) = ".*.*";
	     end;

	else if sc_dot_count = 1 then do;
	     if sc_dot_loc (1) = 1 then do;
		sc_component (2) = substr (sc_access_name, 2, sc_len - 1);
		sc_component (3) = "*";
		end;
	     else do;
		sc_component (1) = substr (sc_access_name, 1, sc_dot_loc (1) - 1);
		if sc_dot_loc (1) < sc_len then
		     sc_component (2) = substr (sc_access_name, sc_dot_loc (1) + 1, sc_len - sc_dot_loc (1));
		sc_component (3) = "*";
		end;
	     substr (sc_access_name, sc_len + 1, 2) = ".*";
	     end;

	else do;					/* sc_dot_count = 2 */
	     if sc_dot_loc (1) ^= 1 then sc_component (1) = substr (sc_access_name, 1, sc_dot_loc (1) - 1);
	     if sc_dot_loc (1) + 1 < sc_dot_loc (2) then
		sc_component (2) = substr (sc_access_name, sc_dot_loc (1) + 1, sc_dot_loc (2) - sc_dot_loc (1) - 1);
	     if sc_dot_loc (2) < sc_len then
		sc_component (3) = substr (sc_access_name, sc_dot_loc (2) + 1, sc_len - sc_dot_loc (2));
	     end;

	return;

     end set_components;

/**/

make_general_acl:
     procedure (acl_type);

declare	acl_type			char (32) parameter;


	call cv_acl_type_$create (other_acl_ptr, acl_count, system_area_ptr, acl_type, "general", acl_ptr);

	return;



make_other_acl:
     entry (acl_type);


	acl_count = general_acl.count;
	call cv_acl_type_$create (acl_ptr, acl_count, system_area_ptr, "general", acl_type, other_acl_ptr);

	return;
     end make_general_acl;



copy_acle_status:
     procedure (acl_type);

declare	acl_type			char (32) parameter;
declare	acle_idx			fixed bin;


	do acle_idx = 1 to general_acl.count;
	     if (acl_type = "directory") then
		general_acl.status_code (acle_idx) = other_acl_ptr -> directory_acl_array (acle_idx).status_code;
	     else general_acl.status_code (acle_idx) = other_acl_ptr -> segment_acl_array (acle_idx).status_code;
	     end;

	return;
     end copy_acle_status;

/**/

complain:
     procedure () options (variable);

declare   arg_list_ptr                  pointer;


          call cu_$arg_list_ptr (arg_list_ptr);
          if af_sw then
               call cu_$generate_call (active_fnc_err_, arg_list_ptr);
          else call cu_$generate_call (com_err_, arg_list_ptr);

          return;
          end complain;

/*  */

cleanup_handler:
     proc ();

	call free (acl_ptr);
	call free (old_acl_ptr);
	call free (new_acl_ptr);
	call free (other_acl_ptr);

	call free (used_bits_ptr);

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

	call free (acl_names_ptr);
	call free (acl_modes_ptr);

	call free (star_names_ptr);
	call free (star_entry_ptr);
	if star_match_ptr ^= null () then call free (star_match_ptr);

	return;
     end cleanup_handler;



free:
     procedure (freeing_ptr);

declare	freeing_ptr		pointer parameter;
declare	based_stuff_ptr		pointer;
declare	based_stuff		fixed bin based;

/*
   we free by using based_stuff, because the freeing mechanism knows how
   much there is to free at the address to which the pointer points.
*/

	based_stuff_ptr = freeing_ptr;
	freeing_ptr = null ();

          if (based_stuff_ptr = addr (empty_acl_overlay)) then return;

	if (based_stuff_ptr ^= null ()) then free based_stuff_ptr -> based_stuff in (system_area);

	return;
     end free;

%page;
%include acl_structures;
%page;
%include star_structures;
%page;
%include suffix_info;
%page;
%include copy_flags;

     end nonquick_common;

     end common;

     end acl_commands_;




		    check_gate_access_.pl1          04/09/85  1459.1r w 04/08/85  1128.4       52749



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: style2 */

/**** CHECK_GATE_ACCESS_:  This program exists to allow programs to avoid
      referencing privileged gates when there are alternatives for 
      unprivileged users thereby preventing access violation audits.
      This program takes a gate name as a parameter as well as a pointer
      to be used for referencing directory determination and returns a
      zero error code if the gate is located using the normal search
      rules and if the user has execute access to this gate.  If the
      gate is found, but the user lacks sufficient access to call the gate,
      error_table_$moderr is returned.  If the gate is not located, then
      error_table_$noentry is returned.
*/

/* Written 1984-08-30 by E. Swenson */

check_gate_access_:
     procedure (P_gate_name, P_reference_ptr, P_code);

/* Parameter */

	dcl     P_code		 fixed bin (35) parameter;
	dcl     P_gate_name		 char (*) parameter;
	dcl     P_reference_ptr	 ptr parameter;

/* Automatic */

	dcl     code		 fixed bin (35);
	dcl     found_with_bad_access	 bit (1) aligned;
	dcl     found_with_good_access bit (1) aligned;
	dcl     i			 fixed bin (17);

/**** There is no real include file for the search rules.  So until we 
      create one and change all the programs which reference search rules
      to use the include file, this program may as well use its own
      declaration too. */

	dcl     1 search_rules	 aligned,
		2 number		 fixed bin (17),
		2 names		 (21) char (168);

/* External Entries */

	dcl     get_pdir_		 entry () returns (char (168));
	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	dcl     hcs_$fs_get_seg_ptr	 entry (char (*), ptr, fixed bin (35));
	dcl     hcs_$fs_search_get_wdir
				 entry (ptr, fixed bin);
	dcl     hcs_$get_search_rules	 entry (ptr);
	dcl     hcs_$get_user_effmode	 entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35));
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				 fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     sub_err_		 entry () options (variable);
	dcl     user_info_$homedir	 entry (char (*));

/* External Static */

	dcl     error_table_$noentry	 fixed bin (35) external static;
	dcl     error_table_$moderr	 fixed bin (35) external static;

/* Constant */

	dcl     ME		 char (32) initial ("check_gate_access_") internal static options (constant);

/* Program */

	call hcs_$get_search_rules (addr (search_rules));
	found_with_good_access = "0"b;
	found_with_bad_access = "0"b;
	do i = 1 to search_rules.number while (^found_with_good_access);
	     call TRY_TO_LOCATE_GATE ((search_rules.names (i)));
	     if code = 0
	     then found_with_good_access = "1"b;
	     else if code = error_table_$moderr
	     then found_with_bad_access = "1"b;		/* remember we found, bud didn't have access. */
	end;
	if found_with_good_access
	then P_code = 0;
	else if found_with_bad_access
	then P_code = error_table_$moderr;
	else P_code = code;
	return;
%page;
TRY_TO_LOCATE_GATE:
     procedure (search_rule_name);

	dcl     search_rule_name	 char (*) parameter;

	dcl     lth		 fixed bin;
	dcl     pathname		 char (168);

	if substr (search_rule_name, 1, 1) = ">"
	then call TRY_DIRECTORY (search_rule_name);
	else if search_rule_name = "initiated_segments"
	then call TRY_INITIATED_SEGMENTS ();
	else if search_rule_name = "referencing_dir"
	then call TRY_REFERENCING_DIR (P_reference_ptr);
	else if search_rule_name = "working_dir"
	then do;
		call hcs_$fs_search_get_wdir (addr (pathname), lth);
		if lth ^= 0
		then call TRY_DIRECTORY (substr (pathname, 1, lth));
		else code = error_table_$noentry;
	     end;
	else if search_rule_name = "home_dir"
	then do;
		call user_info_$homedir (pathname);
		call TRY_DIRECTORY (pathname);
	     end;
	else if search_rule_name = "process_dir"
	then call TRY_DIRECTORY (get_pdir_ ());
	else call sub_err_ (0, ME, ACTION_DEFAULT_RESTART, null (), 0, "Invalid search rule name ^a", search_rule_name);
	return;

     end TRY_TO_LOCATE_GATE;
%page;
TRY_DIRECTORY:
     procedure (dir_name);

	dcl     dir_name		 char (*) parameter;

	dcl     mode		 fixed bin (5);
	dcl     type		 fixed bin (2);

	call hcs_$status_minf (dir_name, P_gate_name,	/* no chase */
	     0, type, (0), code);
	if code ^= 0
	then return;

	if type ^= Segment
	then do;
		code = error_table_$noentry;
		return;
	     end;

	call hcs_$get_user_effmode (dir_name, P_gate_name, "" /* self */, -1 /* caller ring */, mode, code);
	if code ^= 0
	then return;

	if mode ^= E_ACCESS_BIN & mode ^= RE_ACCESS_BIN & mode ^= REW_ACCESS_BIN
	then code = error_table_$moderr;

	return;
     end TRY_DIRECTORY;
%page;
TRY_INITIATED_SEGMENTS:
     procedure ();

	dcl     gate_ptr		 ptr;

	call hcs_$fs_get_seg_ptr (P_gate_name, gate_ptr, code);
	if code ^= 0
	then code = error_table_$noentry;
	return;

     end TRY_INITIATED_SEGMENTS;
%page;
TRY_REFERENCING_DIR:
     procedure (ref_ptr);

	dcl     ref_ptr		 ptr parameter;
	dcl     dn		 char (168);
	dcl     ldn		 fixed bin;
	dcl     en		 char (32);

	if ref_ptr = null
	then code = error_table_$noentry;
	else do;
		call hcs_$fs_get_path_name (ref_ptr, dn, ldn, en, code);
		if code ^= 0
		then code = error_table_$noentry;

		else call TRY_DIRECTORY (substr (dn, 1, ldn));
	     end;
	return;

     end TRY_REFERENCING_DIR;

/* format: off */
%page; %include access_mode_values;
%page; %include status_structures;
%page; %include sub_err_flags;
/* format: on */

     end check_gate_access_;




		    check_iacl.pl1                  01/17/89  1447.2rew 01/17/89  1444.5      266904



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



/****^  HISTORY COMMENTS:
  1) change(88-10-11,TLNguyen), approve(88-10-11,MCR8013),
     audit(88-09-11,Barstad), install(89-01-17,MR12.3-1004):	
     Replace star convention with ACL matching convention for -exclude User_id.
                                                   END HISTORY COMMENTS */

check_iacl: proc;

/* CHECK_IACL - list any acls which do not correspond to the initial acl.
   THVV */
/* MCR 4266 Say "Directory empty" instead of error_table_$nomatch 01/07/80 S. Herbst */

dcl  DIRECTORY_TYPE fixed bin (2) static options (constant) init (2);
dcl  SEGMENT_TYPE fixed bin (2) static options (constant) init (1);
dcl  SEGMENT_TYPE_IN_BIT bit (2) static options (constant) init ("01"b);

dcl  MAX_ALLOWANCE_TO_EXCLUDE fixed bin static options (constant) init (10);

dcl  TRUE bit (1) int static options (constant) init ("1"b);
dcl  FALSE bit (1) int static options (constant) init ("0"b);

dcl  LITERAL_DOT char (1) internal static options (constant) init (".");
dcl  LITERAL_DOT_DOT char (2) internal static options (constant) init ("..");
dcl  LITERAL_DOT_DOT_STAR char (3) internal static options (constant) init ("..*");
dcl  LITERAL_STAR char (1) internal static options (constant) init ("*");

dcl  MY_NAME char (10) static options (constant) init ("check_iacl");

dcl (dn1, dn) char (168) aligned,
    (en1, en) char (32) aligned,
     ring fixed bin (3),
     allsw bit (1),
     got_path bit (1),
     headed bit (1),
     exclude_count fixed bin,                        /* count the number of -exclude control arguments */
    (nisacl, nidacl) fixed bin,
     eptr ptr,
     nptr ptr,
     ecount fixed bin,
    (isaclp, idaclp) ptr,
     nacl fixed bin,
     aclp ptr,
     areap ptr,
     (arg_index, entry_index) fixed bin,
    (arg_count, arg_len) fixed bin,
     arg_ptr ptr,
     arg char (arg_len) based (arg_ptr),
     code fixed bin (35);
                                        /* the following array of record    */
                                        /* is reserved for -exclude User_id */
                                        /* See documentation for details.   */
                                        /* It contains the name of User_id, */
                                        /* a flag which is set if User_id   */
                                        /* is a null string, the length of  */
                                        /* User_id, number of dot characters*/
                                        /* appeared in User_id, and dot     */
                                        /* character positions in User_id.  */
dcl  1 exclude (MAX_ALLOWANCE_TO_EXCLUDE),
       2 name char (32),
       2 null_string_flag bit (1),
       2 actual_length fixed bin,
       2 dot_count fixed bin,
       2 dot_location (2) fixed bin;

dcl  error_table_$entlong fixed bin (35) ext;
dcl  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$bad_name fixed bin (35) ext;
dcl  error_table_$too_many_args fixed bin (35) ext;

dcl  get_system_free_area_ entry () returns (ptr),
     cu_$arg_count entry (fixed bin, fixed bin (35)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     get_ring_ entry () returns (fixed bin),
     get_wdir_ entry () returns (char (168)),
     absolute_pathname_ entry (char (*), char (*) aligned, fixed bin (35)),
     expand_pathname_ entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35)),
     ioa_ entry options (variable),
     (com_err_, com_err_$suppress_name) entry options (variable);
dcl  hcs_$star_ entry (char (*) aligned, char (*) aligned, fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  hcs_$list_dir_inacl entry (char (*) aligned, char (*) aligned, ptr, ptr, ptr, fixed bin, fixed bin (3),
     fixed bin (35));
dcl  hcs_$list_inacl entry (char (*) aligned, char (*) aligned, ptr, ptr, ptr, fixed bin, fixed bin (3),
     fixed bin (35));
dcl  hcs_$list_dir_acl entry (char (*) aligned, char (*) aligned, ptr, ptr, ptr, fixed bin, fixed bin (35));
dcl  hcs_$list_acl entry (char (*) aligned, char (*) aligned, ptr, ptr, ptr, fixed bin, fixed bin (35));

dcl (after, before, fixed, index, length, null, rtrim, substr, verify, reverse) builtin;
dcl  cleanup condition;

dcl 1 seg_acl (10) aligned,
    2 name char (32),
    2 mode bit (36),
    2 mbz bit (36),
    2 code fixed bin (35);

dcl 1 dir_acl (nacl) based (aclp) aligned,
    2 access_name char (32),
    2 modes bit (36),
    2 statuscode fixed bin (35);

dcl 1 segment_acl (nacl) based (aclp) aligned,
    2 access_name char (32),
    2 modes bit (36),
    2 mbz bit (36),
    2 statuscode fixed bin (35);

dcl 1 entries (ecount) aligned based (eptr),
    2 type bit (2) unal,
    2 nnames bit (16) unal,
    2 nindex bit (18) unal;

dcl  names (100) char (32) based (nptr) aligned;
%page;
/* begin check_iacl main program */

	call cu_$arg_count (arg_count, code);
          if code ^= 0 then do;
	     call com_err_ (code, MY_NAME);
	     return;
	end;
                                                            /* initialized */
          ecount = 0;
          eptr = null;
	nptr = null;
	isaclp = null;
	idaclp = null;

	seg_acl (*).mbz = (36) "0"b;

	allsw, got_path = FALSE;                          /* indicate that -all and path have not specified yet */
	exclude_count = 0;				/* indicate that -exclude control argument has not specified yet */

	do arg_index = 1 to arg_count;                    /* parsing input arguments specified on the command line */
                                                            /* get an input argument specified on the command line */
	     call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
	     if code ^= 0 then do;
		call com_err_ (code, MY_NAME);
		return;
	     end;

	     if index (arg, "-") = 1 then do;             /* the first character of the input argument is a hyphen */
		if arg = "-all" | arg = "-a" then allsw = TRUE;

		else if arg = "-exclude" | arg = "-ex" then do;
		     arg_index = arg_index + 1;
		     if arg_index > arg_count then do;
			call com_err_ (0, MY_NAME, "Missing User_id for -exclude");
			return;
		     end;

		     call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
		     if code ^= 0 then do;
			call com_err_ (code, MY_NAME, "Trying to get User_id for -exclude.");
			return;
		     end;

		     exclude_count = exclude_count + 1;    /* indicate that a -exclude User_id has been found */

		     if exclude_count > MAX_ALLOWANCE_TO_EXCLUDE then do;
			call com_err_ (error_table_$too_many_args, MY_NAME, "You can only supply up to 10 -exclude User_id.");
			return;
		     end;
                                                               /* initialize a specified array of record element */
		     exclude (exclude_count).name = "";
		     exclude (exclude_count).null_string_flag = FALSE;
		     exclude (exclude_count).actual_length = 0;
		     exclude (exclude_count).dot_count = 0;
		     exclude (exclude_count).dot_location (*) = 0;
                                                               /* is null string specified in place of User_id for -exclude? */
		     if arg = "" then exclude (exclude_count).null_string_flag = TRUE;
		     if (arg_len > 0) & (index (arg, " ") > 0) then exclude (exclude_count).null_string_flag = TRUE;
                                                              /* save specified User_id for -exclude control argument into the array */
		     exclude (exclude_count).name = arg;
                                                              /* scan specified User_id and update its components whenever appropriate */
		     call set_components;
		     if code ^= 0 then return;
		end;
		else do;
		     call com_err_ (error_table_$badopt, MY_NAME, "^a", arg);
		     return;
		end;
	     end;
	     else do;                                        /* assume that the input argument is the path */
		if got_path then do;                       /* checking for the case of more than one path is specified */
USAGE:
		     call com_err_$suppress_name (0, MY_NAME, "Usage:  check_iacl {path} {-control_args}");
		     return;
		end;

		got_path = TRUE;                           /* indicate that the directory path is specified */

		call absolute_pathname_ (arg, dn1, code);
		if code ^= 0 then do;
		     call com_err_ (code, MY_NAME, "^a", arg);
		     return;
		end;
	     end;
	end;                                                /* end of parsing input arguments specified on the command line */

	if ^got_path then dn1 = get_wdir_ ();               /* case the path is omitted then get the current working directory pathname */

	call expand_pathname_ (dn1, dn, en, code);

	areap = get_system_free_area_ ();
	ring = get_ring_ ();

	on condition (cleanup) begin;
	     if isaclp ^= null then free isaclp -> segment_acl;
	     if idaclp ^= null then free idaclp -> dir_acl;
	     if nptr ^= null then free nptr -> names;
	     if eptr ^= null then free eptr -> entries;
	end;

                                                             /* get information on all segment and directory entries in the directory path */
	call hcs_$star_ (dn1, "**", 10b, areap, ecount, eptr, nptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, MY_NAME, "^a", dn1);
	     return;
	end;

                                                             /* get the entire IACL for segments in the directory path */
	call hcs_$list_inacl (dn, en, areap, isaclp, null, nisacl, ring, code);
	if code ^= 0 then do;
	     call com_err_ (code, MY_NAME);
	     return;
	end;

                                                             /* get the entire IACL for directories in the directory path */
	call hcs_$list_dir_inacl (dn, en, areap, idaclp, null, nidacl, ring, code);

	do entry_index = 1 to ecount;
	     headed = FALSE;
	     aclp = null;
	     en1 = names (fixed (entries (entry_index).nindex));

	     if entries (entry_index).type = SEGMENT_TYPE_IN_BIT then do;
                                                              /* list the entire ACL of a segment */
		call hcs_$list_acl (dn1, en1, areap, aclp, null, nacl, code);
		if code ^= 0 then call com_err_ (code, MY_NAME, "^a>^a", dn1, en1);

		call compare_seg_acl (isaclp, aclp, nisacl, nacl, (SEGMENT_TYPE));
	     end;
	     else do;
		call hcs_$list_dir_acl (dn1, en1, areap, aclp, null, nacl, code);
		if code ^= 0 then call com_err_ (code, MY_NAME, "^a>^a", dn1, en1);
	          call compare_dir_acl (idaclp, aclp, nidacl, nacl, (DIRECTORY_TYPE));
	     end;
	end;

	call ioa_ ("");

	return;

/*-----------------------------------------------------------------------*/
%page;
compare_seg_acl: proc (p1, p2, n1, n2, segment_type);

                                                   /* parameter */
dcl (p1, p2) ptr,
    (n1, n2) fixed bin,
     segment_type fixed bin;

                                                   /* local */
dcl (i, j) fixed bin,
     tcount fixed bin,
     aclbit bit (n2);

/* begin compare_seg_acl procedure */

   if p1 = null then return;
   if p2 = null then return;
                                                   /* initialized */
   aclbit = FALSE;
   tcount = n2;

   do i = 1 to n1;
      if inhibited (rtrim (p1 -> segment_acl.access_name (i))) then
         goto ACL_OK;

      do j = 1 to n2;
         if p1 -> segment_acl.access_name (i) = p2 -> segment_acl.access_name (j) then do;
            substr (aclbit, j, 1) = TRUE;
	  tcount = tcount - 1;

	  if p1 -> segment_acl.modes (i) = p2 -> segment_acl.modes (j) then
	     goto ACL_OK;

	  if allsw then do;
	     if ^headed then call head;

	     call ioa_ ("^-ACL for ^a changed from ^a  to  ^a", p2 -> segment_acl.access_name (j),
		    cmode (p1 -> segment_acl.modes (i), segment_type), cmode (p2 -> segment_acl.modes (j), segment_type));
	  end;

	  goto ACL_OK;
         end;
      end;                                      /* nested do loop */

      if allsw then do;
         if ^headed then call head;

         call ioa_ ("^-ACL deleted: ^a ^a", cmode (p1 -> segment_acl.modes (i), segment_type), p1 -> segment_acl.access_name (i));

      end;

ACL_OK:
   end;                                         /* outer do loop */

   do i = 1 to n2 while (tcount > 0);
      if ^substr (aclbit, i, 1) then do;
         tcount = tcount - 1;

         if ^inhibited (rtrim (p2 -> segment_acl.access_name (i))) then do;
	  
	  if ^headed then call head;

	  call ioa_ ("^-ACL added: ^a ^a", cmode (p2 -> segment_acl.modes (i), segment_type), p2 -> segment_acl.access_name (i));
         end;
      end;
   end;

   return;

   end compare_seg_acl;


/*-----------------------------------------------------------------------*/
%page;
compare_dir_acl: proc (p1, p2, n1, n2, directory_type);

                                                   /* parameter */
dcl (p1, p2) ptr,
    (n1, n2) fixed bin,
     directory_type fixed bin;

                                                   /* local */
dcl (i, j) fixed bin,
     tcount fixed bin,
     aclbit bit (n2);

/* begin compare_dir_acl procedure */

   if p1 = null then return;
   if p2 = null then return;
                                                   /* initialized */
   aclbit = FALSE;
   tcount = n2;

   do i = 1 to n1;
      if inhibited (rtrim (p1 -> dir_acl.access_name (i))) then
         goto ACL_OK;
 
      do j = 1 to n2;
         if p1 -> dir_acl.access_name (i) = p2 -> dir_acl.access_name (j) then do;
	  substr (aclbit, j, 1) = TRUE;
	  tcount = tcount - 1;

	  if p1 -> dir_acl.modes (i) = p2 -> dir_acl.modes (j) then
               goto ACL_OK;

	  if allsw then do;
	     if ^headed then call head;

               call ioa_ ("^-ACL for ^a changed from ^a  to  ^a", p2 -> dir_acl.access_name (j),
	          cmode (p1 -> dir_acl.modes (i), directory_type), cmode (p2 -> dir_acl.modes (j), directory_type));
	  end;

            goto ACL_OK;
         end;
      end;                                      /* nested do loop */

      if allsw then do;
         if ^headed then call head;

         call ioa_ ("^-ACL deleted: ^a ^a", cmode (p1 -> dir_acl.modes (i), directory_type), p1 -> dir_acl.access_name (i));
      end;

ACL_OK:
   end;                                         /* outer do loop */

   do i = 1 to n2 while (tcount > 0);
      if ^substr (aclbit, i, 1) then do;
         tcount = tcount - 1;

         if ^inhibited (rtrim (p2 -> dir_acl.access_name (i))) then do;
	  if ^headed then call head;

	  call ioa_ ("^-ACL added: ^a ^a", cmode (p2 -> dir_acl.modes (i), directory_type), p2 -> dir_acl.access_name (i));
         end;
      end;
   end;

   return;

   end compare_dir_acl;

/*------------------------------------------------------------------------*/
%page;
cmode:	proc (x, t) returns (char (5) aligned);

dcl  x bit (36) aligned;
dcl  t fixed bin;

dcl  ans char (5) aligned;

dcl (i, k) fixed bin;
dcl  XMODE (2, 5) char (1) int static options (constant) init ("r", "e", "w", "a", "", "s", "m", "a", "", "");

/* begin cmode internal procedure */

   k = 1;
   ans = "";

   do i = 1 to 5;
     if substr (x, i, 1) then do;
       substr (ans, k, 1) = XMODE (t, i);
       k = k + 1;
     end;
   end;

   if ans = "" then ans = "null";
   return (ans);

   end cmode;

/* ------------------------------------------------------------------------*/
%page;
inhibited: proc (p_access_identifier) returns (bit (1));

/* Since up to 10 -exclude control arguments are allowed, so inhibit will  */
/* loop until all specified User_id(s) are excluded.                       */
/* inhibit will return TRUE if the access identifier portion of ACL entry  */
/* matches the User_id for -exclude.  Otherwise, returns FALSE.            */

                                          /* input parameter */
dcl p_access_identifier char (*) aligned; /* access name portion of ACL entry */

dcl exclude_index fixed bin;              /* local */
                    
/* begin inhibit internal procedure */

   do exclude_index = 1 to exclude_count;
                                          /* User_id for -ex is a null string */
      if exclude (exclude_index).null_string_flag then do;
                                          /* for any ACL entry whose 2nd component value is literal "*" and
                                             whose 3rd component value is literal "*" then a match is found */
         if after (p_access_identifier, LITERAL_DOT) = "*.*" then
	  return (TRUE);               /* return to compare_acl internal procedure */
      end;
      else do;                           /* User_id for -ex is not a null string */
                                         /* the original User_id for -ex did not have a dot character */
         if exclude (exclude_index).dot_count = 0 then do;
                                         /* a match is found if each component value of ACL entry is the same with each
                                            component value of User_id for -ex, repectively. */
	  if p_access_identifier = exclude (exclude_index).name then
	     return (TRUE);            /* return to compare_acl internal procedure */
         end;
                                         /* the original User_id for -ex had only one dot character */	     
         else if exclude (exclude_index).dot_count = 1 then do;
                                         /* case original User_id value for -ex is a dot character */
	  if exclude (exclude_index).name = LITERAL_DOT_DOT_STAR then do;
                                         /* if the 3rd component value of ACL entry is a literal "*", a match is found */
	     if before (reverse (p_access_identifier), LITERAL_DOT) = LITERAL_STAR then
	        return (TRUE);         /* return to compare_acl internal procedure */
	  end;
                                         /* case the original User_id has a dot character in the first letter */
	  else if exclude (exclude_index).dot_location (1) = 1 then do;
                                         /* if the last two component values of ACL entry is the same as those of User_id */
                                         /* then a match is found */
	     if after (p_access_identifier, LITERAL_DOT) = after (exclude (exclude_index).name, LITERAL_DOT) then
	        return (TRUE);         /* return to compare_acl internal procedure */
	  end;
                                         /* case the original User_id has a dot character in the last letter */
	  else if exclude (exclude_index).dot_location (1) = exclude (exclude_index).actual_length then do;
                                         /* if the 1st component value and the 3rd component value of ACL entry is the same */
                                         /* as those of User_id then a match is found */
	     if (before (p_access_identifier, LITERAL_DOT) = before (exclude (exclude_index).name, LITERAL_DOT)) &
	        (before (reverse (p_access_identifier), LITERAL_DOT) = LITERAL_STAR) then
	        return (TRUE);         /* return to compare_acl internal procecudre */
	  end;

	  else do;                     /* case the original User_id has a dot character between  */
                                         /* if the entire component value of ACL entry is the same as those of User_id
                                            then a match is found */
	     if p_access_identifier = exclude (exclude_index).name then
	        return (TRUE);         /* return to compare_acl internal procedure */
	  end;
         end;                            /* The specified User_id has one dot character */
         else do;                        /* two dots are found in the specified User_id */
                                         /* if User_id value is ".." then a match is found */
	  if exclude (exclude_index).name = LITERAL_DOT_DOT then
	     return (TRUE);            /* return to compare_acl internal procedure */
                                         /* the original User_id has ".." in the first two letters */
	  else if (exclude (exclude_index).dot_location (1) = 1) & (exclude (exclude_index).dot_location (2) = 2) then do;
                                         /* if the 3rd component value of ACL entry is the same as those of User_id
                                            then a match is found */
	     if before (reverse (p_access_identifier), LITERAL_DOT) =
	        before (reverse (rtrim (exclude (exclude_index).name)), LITERAL_DOT) then
	        return (TRUE);        /* return to compare_acl internal procedure */
	  end;
                                        /* the original User_id has ".." in the last two letter */
	  else if (exclude (exclude_index).dot_location (1) = exclude (exclude_index).actual_length - 1) &
		(exclude (exclude_index).dot_location (2) = exclude (exclude_index).actual_length) then do;
                                        /* if the 1st component value and the 3rd component value of ACL entry are
                                           the same as those of User_id then a match is found */
	     if (before (p_access_identifier, LITERAL_DOT) = before (exclude (exclude_index).name, LITERAL_DOT)) &
	        (before (reverse (p_access_identifier), LITERAL_DOT) = LITERAL_STAR) then
	        return (TRUE);        /* return to compare_acl internal procedure */
	  end;
                                        /* the original User_id has dots in the first letter and the last letter */
	  else if (exclude (exclude_index).dot_location (1) = 1) &
		(exclude (exclude_index).dot_location (2) <= exclude (exclude_index).actual_length) then do;
                                        /* if the last two component values of ACL entry is the same as those of
                                           User_id then a match is found */
	     if after (p_access_identifier, LITERAL_DOT) = after (exclude (exclude_index).name, LITERAL_DOT) then
	        return (TRUE);        /* return to compare_acl internal procedure */
	  end;

            else do;
                                        /* otherwise, an exact match to each component value is required in order to return TRUE */
	     if p_access_identifier = exclude (exclude_index).name then
	        return (TRUE);        /* return to compare_acl internal procedure */
	  end;
         end;                           /* two dots are found in the specified User_id */		
      end;                              /* User_id for -ex is not a null string */
   end;                                 /* looping until all specified User_id for -ex are processed */

   return (FALSE);                      /* return to compare_acl internal procedure */

   end inhibited;                       /* end of inhibited internal procedure */

/*------------------------------------------------------------------------*/
%page;
head:	proc;

	call ioa_ ("^/^a", en1);

	headed = TRUE;
	return;
	     
	end head;

/*-----------------------------------------------------------------------*/
%page;
set_components: proc;

/* validate specified User_id for -exclude.  For cases such as its length */
/* longer than 32 characters long, then report as error.  Also, do not    */
/* allow mixing of white space characters and other characters in         */
/* specified User_id.                                                     */
/* For valid specified User_id, locate dot characters in specified        */
/* User_id.  Maximum number of dots allowed is two.  Since ACL matching   */
/* is allowed for User_id, several checks have been made to update        */
/* specified User_id value.                                               */
                                         /* local */
dcl character_index fixed bin;           /* scan User_id to locate dot character positions */
dcl user_id_name_length fixed bin;       /* length of specified User_id name */

dcl MAX_DOT fixed bin internal static options (constant) init (2);
dcl USER_ID_MAX_LENGTH fixed bin internal static options (constant) init (32);

/* begin set_component internal procedure */

   code = 0;

   if length (exclude (exclude_count).name) > USER_ID_MAX_LENGTH then do;
      code = error_table_$entlong;
      goto set_components_ERROR_RETURN;
   end;
                                        /* are there white spaces in User_id? */
   user_id_name_length = index (exclude (exclude_count).name, " ") - 1;
                                        /* no white spaces in User_id */
   if (user_id_name_length = - 1) then
      exclude (exclude_count).actual_length = length (exclude (exclude_count).name);
   else do;                             /* white space(s) are in User_id */
      exclude (exclude_count).actual_length = user_id_name_length;
                                        /* if white spaces and other non white space characters are in User_id then treats as error.
                                           Otherwise, it is ok for User_id containing only white space(s). */
      if verify (substr (exclude (exclude_count).name, exclude (exclude_count).actual_length + 1), " ") ^= 0 then do;
         code = error_table_$bad_name;
         goto set_components_ERROR_RETURN;
      end;
   end;
                                       /* locate dot characters in the specified User_id */
   do character_index = 1 to exclude (exclude_count).actual_length;
      if substr (exclude (exclude_count).name, character_index, 1) = LITERAL_DOT then do;
         exclude (exclude_count).dot_count = exclude (exclude_count).dot_count + 1;

         if exclude (exclude_count).dot_count > MAX_DOT then do;
	  code = error_table_$bad_name;
            goto set_components_ERROR_RETURN;
         end;
                                       /* save the dot position in an array of dot locations */
         exclude (exclude_count).dot_location (exclude (exclude_count).dot_count) = character_index;
      end;
   end;
                                       /* do not set component if all three components of User_id are specified.
                                          For example: check_iacl -ex Foo.Multics.a */
   if (exclude (exclude_count).dot_count = MAX_DOT) &
      (exclude (exclude_count).dot_location (1) > 1) &
      (exclude (exclude_count).dot_location (2) < exclude (exclude_count).actual_length) then
      goto set_components_NORMAL_RETURN;
                                       /* specified User_id is not a null string */
   if ^exclude (exclude_count).null_string_flag then do;
                                       /* for example: check_iacl -ex Foo */
      if exclude (exclude_count).dot_count = 0 then

                                       /* append the literal ".*.*" to the specified User_id */
         substr (exclude (exclude_count).name, exclude (exclude_count).actual_length + 1, 4) = ".*.*";

     else if exclude (exclude_count).dot_count = 1 then do;
                                       /* for the case of only one dot char is found in the specified User_id */
        if exclude (exclude_count).name = LITERAL_DOT then
                                       /* if specified User_id value is "." then update its value */
	 exclude (exclude_count).name = LITERAL_DOT_DOT_STAR;
                                       /* Othewise, for examples: -ex .Multics; -ex Foo.; -ex Foo.Multics, */
                                       /* append literal ".*" to the specified User_id */
        else substr (exclude (exclude_count).name, exclude (exclude_count).actual_length + 1, 2) = ".*";
     end;
                                       /* p_dot_count = 2 and specified User_id value is not ".."  */
     else if exclude (exclude_count).name ^= LITERAL_DOT_DOT then do;
                                       /* for examples: -ex ..a; -ex .Multics.a  */
        if (exclude (exclude_count).dot_location (1) = 1) &
	 (exclude (exclude_count).dot_location (2) = 2 |
	  exclude (exclude_count).dot_location (2) < exclude (exclude_count).actual_length) then;
                                      /* Otherwise, for examples: -ex Foo..; -ex .Multics.; -ex Foo.Multics.,
                                         append a literal "*" to the specified User_id */
        else substr (exclude (exclude_count).name, exclude (exclude_count).actual_length + 1, 1) = LITERAL_STAR;
     end;
     else;                            /* OK for -ex ..  */
  end;                                /* specified User_id is not a null string */     
  else;                               /* OK for -ex " "  */

set_components_NORMAL_RETURN:
  return;                             /* return to check_iacl main program */

set_components_ERROR_RETURN:
  call com_err_ (code, MY_NAME, "^a", exclude (exclude_count).name);
  return;                             /* for error, return to check_iacl main program */

  end set_components;                 /* end of set components internal procedure */
 
/*--------------------------------------------------------------------------*/
%page;
  end check_iacl;                     /* end of check_iacl main program */





		    check_path_name_.pl1            11/04/82  1944.9rew 11/04/82  1624.3       46737



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


check_path_name_:		proc(pp,plen,cacl,whoami,dirp,entp,npp,ecount,eptr,nptr,retc);

/* This procedure is used by the access commands to expand given path names, to check them for stars,
	and to call hcs_$star_ if appropriate. */

/* initially coded by M. Weaver 21 March 1970 */
/* last modified by M. Weaver 8 October 1970 */

	dcl arg char(plen) unaligned based(pathp);
	dcl (dirname based(dirp), pathname) char(168) aligned;
	dcl dname char(168) var int static;
	dcl entname char(32) aligned based(entp);
	dcl ename char(32) aligned based(q);
	dcl gt char(1) var int static;		/* contains ">" or " " */
	dcl whoami char(16) aligned;
	dcl new_path char(168) aligned based(npp);		/* for full path name for identification */
	dcl (pathp, dirp, entp, pp, npp, areap, q, eptr, nptr, (ep, np, mp) int static) ptr;
	dcl (cacl, csw int static) bit(1) aligned;
	dcl (plen, scode, code, retc, ecount, lng, j int static) fixed bin(17);
	dcl 1 entries(0:99) aligned based(eptr),		/* structure returned by hcs_$star_ */
		2 type bit(2) unaligned,
		2 nname bit(16) unaligned,
		2 nindex bit(18) unaligned;
	dcl names(0:499) char(32) based(nptr) aligned;

	dcl (ioa_$rsnnl, com_err_) entry options(variable);
	dcl hcs_$star_ entry(char(*) aligned, char(*) aligned, fixed bin, ptr, fixed bin, ptr, ptr, fixed bin),
	    get_wdir_ entry(char(168) aligned);
	dcl (addr, fixed, index, null, substr) builtin;
	dcl expand_path_ ext entry(ptr, fixed bin(17), ptr, ptr, fixed bin(17));
	dcl check_star_ ext entry(ptr, fixed bin(17), fixed bin(17));
	dcl freen_ ext entry(ptr);
	dcl get_system_free_area_ ext entry returns(ptr);

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

	retc = 2;				/* assume error until finish */

/* check for working directory */
	if pp->arg = "-wd" then go to wdr;
	else if pp->arg = "-wdir" then do;
wdr:		pathp = addr(pathname);
		call get_wdir_(pathname);
		plen = index(pathname, " ") - 1;
		if plen < 0 then plen = 168;
		end;
	else pathp = pp;

/* get dirname and entname */
	call expand_path_(pathp, plen, dirp, entp, code);
	if code ^= 0 then do;
err1:		call com_err_(code,whoami,arg);
		return;
		end;

	if substr(dirname, 1, 4) = ">   "		/* Check to see if pathname */
	then if substr(entname, 1, 4) = "    "		/* is the root, AFTER expansion */
	     then do;
		if cacl then do;
		     new_path = ">";
		     go to rset;
		     end;
		else do;
		     call com_err_(0, whoami, "There is no ACL on the root.");
		     return;
		     end;
		end;

	call check_star_(entp, 32, scode);		/* see if there are stars in the name */

	if dirname = "> " then gt = "";		/* don't want ">>" to appear in a pathname */
	else gt = ">";

	if scode = 0 then do;		/* no stars */
		call ioa_$rsnnl("^a^a^a",new_path,lng,dirname,gt,entname);
rset:		retc = 0;
		if cacl then dirname = new_path;
		ecount = 1;
		end;

	else if scode < 3 then do;		/* have stars */
		eptr, nptr = null;
		areap = get_system_free_area_();
		call hcs_$star_(dirname,entname,2,areap,ecount,eptr,nptr,code);
		if code ^= 0 then do;
			call com_err_(code,whoami,arg);
			if eptr ^= null then call freen_(eptr);
			if nptr ^= null then call freen_(nptr);
			return;		/* can't get pathnames to use */
			end;
		if cacl then do;
			csw = "1"b;		/* set internal static cacl switch */
			if substr(dirname,167,1) ^= " " then do;
				call com_err_(0, whoami, "Directory name too long to use with star convention. ^a",
				dirname);
				return;
				end;
			end;
		else csw = "0"b;			/* no cacl */
		dname = substr(dirname,1,index(dirname, " ")-1);     /* dname is var and is used several times */
		mp = npp;			/* store the pointer to the path name for messages */
		ep = eptr;		/* store pointers from hcs_$star_ */
		np = nptr;
		j = 0;
		retc = 1;
		end;

	else do;				/* scode > 2 */

	     code = scode;			/* Print message for check_star_ error ($badstar) */
	     go to err1;

	     end;

	if cacl then entname = " ";
	return;


indiv:	entry(dpr,epr,ssw);

/* In this entry, mp->new_path will always be set; for CACLs, dirname will be set equal to mp->new_path;
   for ACLs, epr will be set to point to the appropriate entry name. */

	dcl (dpr, epr) ptr;			/* these correspand to dirp and entp but can't have same names */
	dcl ssw bit(1) aligned;

	if ep->entries(j).type ^= "10"b then do;		/* not a directory */
		ssw = "1"b;
		if csw then go to ret;		/* want only directories for cacl commands */
		end;
	else ssw = "0"b;	/* have a directory */

	q = addr(np->names(fixed(ep->entries(j).nindex,18)-1));		/* get address of entry name */
	mp->new_path = dname || gt || ename;
	if csw then
		dpr->dirname = mp->new_path;
	else
		epr = q;
ret:	j = j + 1;		/* update entry count */

	return;
	end check_path_name_;




		    cv_acl_.pl1                     11/04/82  1944.9rew 11/04/82  1624.3       70614



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


cv_acl_:		procedure (aclp, n, line, len, asw);


/*

	This procedure accepts a standard-format access control list entry
	(one only), and formats it for printing, returning the formatted
	string to the caller.  Options allow the mode field, the user name,
	and error message corresponding to the status code to be suppressed.
	It is expected that when extended access is fully implemented, an
	additional argument will specify the acl type.

	Option bit ("asw") definitions:

		bit 1 on		add mode field
		bit 2 on		add error message
		bit 3 on		suppress user name

	Other option bit definitions may be added from time to time, in a
	transparent way, i.e. having the bit set to 0 or omitted will
	result in no change from the previous version of the program.

	P. Bos, May 1972

	Modified Apr. 1973 by Peter B. Kelley		to change acl structure to new
						hcs_ acl primitives.
	Modified Jun. 1973 by P.B. Kelley	          removed "a" bit from ACL defs.
						added cv_dir_acl_ entry and its associated
						mode representations.

*/


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


     dcl	aclp			ptr,		/* pointer to acl array */
	n			fixed bin,	/* array index of acl entry to format */
	line			char(*),		/* formatted output string */
	len			fixed bin,	/* number of significant chars in line */
	asw			bit(*);		/* option bits */

     dcl	check_fs_errcode_		entry (fixed bin(35), char(8) aligned, char(100) aligned);

     dcl (addr, fixed, length, substr)	builtin;

     dcl (e, i, l, ll, lmax)		fixed bin;

     dcl (p, sp, mp)		ptr;

     dcl	sws			bit(3) aligned;	/* fixed-length copy of "asw" */

     dcl	chars			char(i) based(p),	/* based char string */
	dummy			char(8) aligned,	/* passed to check_fs_errcode_ */
	info			char(100) aligned;	/* him too */

     dcl	1 s			based (sp),	/* overlaid on sws */
	 (2 msw			bit(1),		/* non-zero if mode field to be added */
	  2 esw			bit(1),		/* non-zero if error message to be added */
	  2 nsw			bit(1)) unal;	/* non-zero if user name to be suppressed */

     dcl  1 SEG_mode aligned int static,		/* segment mode representations */
        	  2 mode (0:7)		char(4) init (
					"null",	/* "000" */
					"w",	/* "001" */
					"e",	/* "010" */
					"ew",	/* "011" */
					"r",	/* "100" */
					"rw",	/* "101" */
					"re",	/* "110" */
					"rew");	/* "111" */

     dcl  1 DIR_mode aligned int static,		/* directory mode representations */
	  2 mode (0:7)		char(4) init (
					"null",	/* "000" */
					"a",	/* "001" */
					"m",	/* "010" */
					"ma",	/* "011" */
					"s",	/* "100" */
					"sa",	/* "101" */
					"sm",	/* "110" */
					"sma");	/* "111" */

     dcl  1 M based (mp) aligned,			/* for referencing appropriate struc. */
	  2 mode (0:7)		char(4);

     dcl	1 acl (n)			aligned based (aclp),	/* acl entry */
	  2 userid		char(32),		/* user name */
	  2 mode			bit(36),		/* 1-3 "rew", rest 0 */
	  2 pad			bit (36),		/* must be 0 */
	  2 code			fixed bin (35);	/* status code during processing */

     dcl  1 diracl (n)		aligned based (aclp),	/* dir acl entry */
	  2 userid		char(32),		/* user name */
	  2 mode			bit(36),		/* 1-3 "sma", rest 0 */
	  2 code			fixed bin (35);	/* status code during processing */

     dcl acl_code			fixed bin (35);	/* copy of status code */

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

	mp = addr(SEG_mode);			/* point to segment modes */
	e = 1;
	goto COMMON;

cv_dir_acl_:	entry (aclp, n, line, len, asw);

	mp = addr(DIR_mode);			/* point to directory modes */
	e = 2;

COMMON:	line = "";				/* initialize output string */
	l = 0;					/* no chars in it yet */
	lmax = length (line);			/* better not put more in */
	sws = asw;				/* copy option bits */
	sp = addr (sws);				/* and get pointer for overlay */
	if s.msw then do;				/* user wants mode printed */
	     if e = 1 then
		call addchr (mp->M.mode (fixed (substr (acl(n).mode,1,3))) || "      ");/* insert it (field width 10) */
	     else
		call addchr (mp->M.mode(fixed(substr(diracl(n).mode,1,3)))||"      ");/* insert it(field width 10) */
	     end;
	if ^s.nsw then do;				/* if user name not suppressed */
	     ll = l;				/* save current line length for later */
	     if e = 1 then
		p = addr (acl(n).userid);		/* get pointer to name */
	     else
		p = addr ( diracl(n).userid);
	     i = 32;				/* 32 chars long */
	     call adjust (p, i);			/* strip leading & trailing blanks */
	     call addchr (chars);			/* insert into line */
	     end;
	if s.esw then do;				/* user wants error message */
	     if e = 1 
		then acl_code = acl(n).code;		/* copy segment acl code */
	     else 
		acl_code = diracl(n).code;		/* dir acl code in different place */
	     if acl_code ^= 0 then do;		/* looks like an error */
		if ^s.nsw then do;			/* if we had user name, form neat columns */
		     if l - ll < 20 then		/* most user names ought to fit in 20 chars */
			l = ll + 20;		/* add blanks if less than that */
		     else				/* if too big, */
			l = l + 1;		/* add a blank */
		     if l > lmax then do;		/* make sure we didn't run out */
			l = ll + i;		/* reset it if we did */
			go to rtn;		/* and exit */
			end;
		     end;
		call check_fs_errcode_( acl_code, dummy, info);	/* get error message */
		p = addr (info);			/* get pointer to it */
		i = 100;				/* 100 chars long */
		call adjust (p, i);			/* strip blanks */
		call addchr (chars);		/* insert what's left */
		end;
	     end;

rtn:	len = l;					/* give caller length of string */
	return;					/* and return to him */
/**/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


addchr:		procedure (arg);			/* procedure to add arg to line */


     dcl	arg			char(*);		/* char string to insert into line */

     dcl	t			fixed bin;	/* temp */


	t = length (arg);				/* get size of string to add */
	if t > lmax - l then			/* maximum of lmax chars in message */
	     t = lmax - l;				/* make sure we don't run off end */
	if t ^= 0 then do;				/* still room, put it in */
	     substr (line, l+1, t) = arg;		/* after what's already there */
	     l = l + t;				/* line got longer */
	     end;
	return;					/* done */

	end addchr;


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


adjust:		procedure (argp, argl);		/* procedure to strip leading, trailing blanks */


     dcl	argp			ptr,		/* pointer to char string */
	argl			fixed bin;	/* length of string */

     dcl	t			fixed bin;	/* temp */

     dcl	1 c			based (argp),	/* char array overlaid on string */
	  2 char (argl)		char(1) unal;	/* makes better code than substr */


	do t = 1 to argl;				/* scan from front for first non-blank */
	     if c.char(t) ^= " " then			/* non-blank? */
		go to first;			/* yes, exit loop */
	     end;
first:	argp = addr (c.char(t));			/* adjust pointer to point to it */
	argl = argl - t + 1;			/* adjust length */
	if argl ^= 0 then do;			/* if string not all blank */
	     do t = argl to 1 by -1;			/* scan from end for last non-blank */
		if c.char(t) ^= " " then		/* found it? */
		     go to last;			/* yes, skip */
		end;
last:	     argl = t;				/* set new length */
	     end;
	return;					/* bye... */

	end adjust;


	end cv_acl_;




		    cv_acl_type_.pl1                11/19/84  1109.4rew 11/19/84  1106.5       88173



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
cv_acl_type_:
     procedure ();

/* *	CV_ACL_TYPE_ -- Procedure used by ACL commands to convert from one format
   *	   of ACL representation to another.
   *
   *	This family of procedures converts from one format of ACL structure to
   *	another, in order to accomodate the different formats used by existing
   *	hcs_ entrypoints.  The ACL structures are reallocated, copied, and 
   *	freed.  There is only one ACL structure in use at any given time in
   *	this program: it is pointed to by acl_ptr, and the number of entries is
   *	given by acl_count.  Except when actually calling the primitives, only
   *	the appropriate general ACL structure format will be used.  Now, this
   *	may look rather inefficient, and, in truth, it is, but it is only used
   *	relatively rarely: IACL manipulations, since they are not now supported
   *	by fs_util_, privileged operations, likewise unsupported, and
   *	force_no_type operations, presumably infrequent.   Also, the conversion
   *	if incoming ACL structures (that is, prior to calling the primitive) is
   *	restricted to uses in list_acl (and IACL) where specific access names
   *	were requested. The normal case, where no names were requested, will
   *	simply result in an immediate return because the pointer is null (or
   *	the count zero)
   *	
   *	2 October 1983, W. Olin Sibert
   */

declare	P_acl_ptr pointer parameter;
declare	P_new_acl_ptr pointer parameter;
declare	P_acl_count fixed bin parameter;
declare	P_area_ptr pointer parameter;
declare	P_old_type char (32) parameter;
declare	P_new_type char (32) parameter;

declare	system_area_ptr pointer;
declare	system_area area based (system_area_ptr);
declare	based_stuff fixed bin aligned based;		/* For (invalid) general-purpose freeing operations */

declare	replace_sw bit (1) aligned;
declare	old_acl_ptr pointer;
declare	new_acl_ptr pointer;
declare	old_type fixed bin;
declare	new_type fixed bin;

declare	acle_idx fixed bin;
declare	old_acle_ptr pointer;
declare	new_acle_ptr pointer;

declare	sub_err_ entry options (variable);

declare	GENERAL		init (101) fixed bin internal static options (constant);
declare	GENERAL_EXTENDED	init (102) fixed bin internal static options (constant);
declare	GENERAL_DELETE	init (103) fixed bin internal static options (constant);
declare	SEGMENT_ARRAY	init (104) fixed bin internal static options (constant);
declare	SEGMENT_STRUCTURE	init (105) fixed bin internal static options (constant);
declare	DIRECTORY_ARRAY	init (106) fixed bin internal static options (constant);
declare	DIRECTORY_STRUCTURE	init (107) fixed bin internal static options (constant);
declare	DELETE		init (108) fixed bin internal static options (constant);

declare  (addr, null) builtin;

/*  */

cv_acl_type_$create:
     entry (P_acl_ptr, P_acl_count, P_area_ptr, P_old_type, P_new_type, P_new_acl_ptr);

	replace_sw = "0"b;
	goto COMMON;



cv_acl_type_$replace:
     entry (P_acl_ptr, P_acl_count, P_area_ptr, P_old_type, P_new_type);

	replace_sw = "1"b;
	goto COMMON;


COMMON:
	acl_ptr = P_acl_ptr;
	acl_count = P_acl_count;
	system_area_ptr = P_area_ptr;

/* Either a null pointer of zero count is sufficient evidence that there is nothing
   there, and a null pointer and zero count will always be returned in that case */

	if (acl_count = 0) | (acl_ptr = null ()) then do;
	     if replace_sw then do;			/* Update the output parameters */
		P_acl_count = 0;
		P_acl_ptr = null ();
		if (acl_ptr ^= null ()) then free acl_ptr -> based_stuff in (system_area);
		end;
	     return;
	     end;

	call get_type (P_old_type, old_type);
	call get_type (P_new_type, new_type);

	old_acl_ptr = acl_ptr;

/* These procedures do their own allocation, but the old one is freed after all is done.
   There is a race here: if this procedure is interrupted during the copying, the old one
   will never be freed. This, however, hardly seems exciting, or worth the expense of 
   setting up a cleanup handler to handle. */

/* Only a few of the sensible conversion are supported in this procedure, by the way:
   those which are of interest to the standard ACL commands. */

	if (old_type = GENERAL) & (new_type = SEGMENT_ARRAY) then call general_to_segment_array ();
	else if (old_type = GENERAL) & (new_type = DIRECTORY_ARRAY) then call general_to_directory_array ();
	else if (old_type = SEGMENT_ARRAY) & (new_type = GENERAL) then call segment_array_to_general ();
	else if (old_type = DIRECTORY_ARRAY) & (new_type = GENERAL) then call directory_array_to_general ();
	else call bad_conversion ();

	if replace_sw then do;
	     P_acl_ptr = new_acl_ptr;
	     free old_acl_ptr -> based_stuff in (system_area);
	     end;
	else P_new_acl_ptr = new_acl_ptr;

	return;

/*  */

general_to_segment_array:
     procedure ();

	if (acl_ptr -> general_acl.version ^= GENERAL_ACL_VERSION_1) then call bad_type ();

	allocate segment_acl_array in (system_area) set (new_acl_ptr);

	do acle_idx = 1 to acl_count;			/* Copy relevant portions of each entry */
	     old_acle_ptr = addr (acl_ptr -> general_acl.entries (acle_idx));
	     new_acle_ptr = addr (new_acl_ptr -> segment_acl_array (acle_idx));
	     new_acle_ptr -> segment_acl_entry.access_name = old_acle_ptr -> general_acl_entry.access_name;
	     new_acle_ptr -> segment_acl_entry.mode = old_acle_ptr -> general_acl_entry.mode;
	     new_acle_ptr -> segment_acl_entry.status_code = old_acle_ptr -> general_acl_entry.status_code;
	     new_acle_ptr -> segment_acl_entry.extended_mode = ""b;
	     end;

	return;
	end general_to_segment_array;



general_to_directory_array:
     procedure ();

	if (acl_ptr -> general_acl.version ^= GENERAL_ACL_VERSION_1) then call bad_type ();

	allocate directory_acl_array in (system_area) set (new_acl_ptr);

	do acle_idx = 1 to acl_count;			/* Copy relevant portions of each entry */
	     old_acle_ptr = addr (acl_ptr -> general_acl.entries (acle_idx));
	     new_acle_ptr = addr (new_acl_ptr -> directory_acl_array (acle_idx));
	     new_acle_ptr -> directory_acl_entry.access_name = old_acle_ptr -> general_acl_entry.access_name;
	     new_acle_ptr -> directory_acl_entry.mode = old_acle_ptr -> general_acl_entry.mode;
	     new_acle_ptr -> directory_acl_entry.status_code = old_acle_ptr -> general_acl_entry.status_code;
	     end;

	return;
	end general_to_directory_array;

/*  */

segment_array_to_general:
     procedure ();

	allocate general_acl in (system_area) set (new_acl_ptr);
	new_acl_ptr -> general_acl.count = acl_count;
	new_acl_ptr -> general_acl.version = GENERAL_ACL_VERSION_1;

	do acle_idx = 1 to acl_count;			/* Copy relevant portions of each entry */
	     old_acle_ptr = addr (acl_ptr -> segment_acl_array (acle_idx));
	     new_acle_ptr = addr (new_acl_ptr -> general_acl.entries (acle_idx));
	     new_acle_ptr -> general_acl_entry.access_name = old_acle_ptr -> segment_acl_entry.access_name;
	     new_acle_ptr -> general_acl_entry.mode = old_acle_ptr -> segment_acl_entry.mode;
	     new_acle_ptr -> general_acl_entry.status_code = old_acle_ptr -> segment_acl_entry.status_code;
	     end;

	return;
	end segment_array_to_general;



directory_array_to_general:
     procedure ();

	allocate general_acl in (system_area) set (new_acl_ptr);
	new_acl_ptr -> general_acl.count = acl_count;
	new_acl_ptr -> general_acl.version = GENERAL_ACL_VERSION_1;

	do acle_idx = 1 to acl_count;			/* Copy relevant portions of each entry */
	     old_acle_ptr = addr (acl_ptr -> directory_acl_array (acle_idx));
	     new_acle_ptr = addr (new_acl_ptr -> general_acl.entries (acle_idx));
	     new_acle_ptr -> general_acl_entry.access_name = old_acle_ptr -> directory_acl_entry.access_name;
	     new_acle_ptr -> general_acl_entry.mode = old_acle_ptr -> directory_acl_entry.mode;
	     new_acle_ptr -> general_acl_entry.status_code = old_acle_ptr -> directory_acl_entry.status_code;
	     end;

	return;
	end directory_array_to_general;

/*  */

get_type:
     procedure (P_type_name, P_type);

declare	P_type_name char (*) parameter;
declare	P_type fixed bin parameter;

declare	type_name char (32);

/* This procedure is strictly used as an interface by acl_commands_; nonetheless, in order
   to avoid having to share definitions for the type constants, types are passed as
   character strings to make things more readable, and converted here to integers for
   greater efficiency. */


	type_name = P_type_name;
	if (type_name = "general") then P_type = GENERAL;
	else if (type_name = "segment_array") then P_type = SEGMENT_ARRAY;
	else if (type_name = "directory_array") then P_type = DIRECTORY_ARRAY;
	else if (type_name = "general_extended") then P_type = GENERAL_EXTENDED;
	else if (type_name = "general_delete") then P_type = GENERAL_DELETE;
	else if (type_name = "delete") then P_type = DELETE;
	else if (type_name = "segment_structure") then P_type = SEGMENT_STRUCTURE;
	else if (type_name = "directory_structure") then P_type = DIRECTORY_STRUCTURE;
	else call bad_conversion ();

	return;
	end get_type;



bad_conversion:
     procedure ();

	call sub_err_ (0, "cv_acl_type_", ACTION_CANT_RESTART, (null ()), (0),
	     "Undefined operation: cannot convert from ACL type ""^a"" to type ""^a"".",
	     P_old_type, P_new_type);

	end bad_conversion;



bad_type:
     procedure ();

	call sub_err_ (0, "cv_acl_type_", ACTION_CANT_RESTART, (null ()), (0),
	     "Input ACL is not of specified type ""^a"".", P_old_type);

	end bad_type;

%page; %include acl_structures;
%page; %include sub_err_flags;

	end cv_acl_type_;




		    cv_mode_.pl1                    11/04/82  1944.9rew 11/04/82  1624.4       30573



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


cv_mode_:		procedure (chars, bits, code);


/*

	This procedure converts standard mode characters (rew, null, n)
	into the corresponding binary attribute string as found in an acl
	entry.  Mode characters in the input string may be in any order,
	and embedded blanks are ignored.  If the string is "null" or "n",
	"0"b is returned.

	P. Bos, May 1972

	Modified by Peter B. Kelley, Apr. 26, 1973 to implement new ACL/RB primitives.
		Effect of change was to change "trewa" modes to "rewa" modes.
	Modified by P. B. Kelley, Jun. 1973 to ignore "a" _s_e_g_m_e_n_t mode representation.
			-added entry cv_dir_mode_ and associated mode representations.

*/

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


     dcl	chars			char(*),		/* input string ("rew", "null", "n") */
	bits			bit(*),		/* binary mode corresponding to chars */
	code			fixed bin(35);	/* status code for bad mode */

     dcl (addr, length, null)		builtin;

     dcl	error_table_$bad_acl_mode	ext fixed bin(35);

     dcl (bp, cp, mp)		ptr;

     dcl (i, j, l)		fixed bin;

     dcl	mode			bit(3) aligned;	/* internal temp for "bits" */

     dcl	chr			char(1) aligned;

     dcl  1 s aligned int static,
	  2 mchr (3)			char(1) init ("r", "e", "w");

     dcl  1 d aligned int static,
	  2 mchr (3)			char(1) init ("s", "m", "a");

     dcl  1 M aligned based (mp),
	  2 mchr (3)			char(1);

     dcl	1 b			based (bp),	/* bit array */
	  2 bit(3)		bit(1) unal;

     dcl	1 c			based (cp),	/* char array */
	  2 char(l)		char(1) unal;

/**/

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


	mp = addr(s);				/* point to segment modes */
	goto COMMON;

cv_dir_mode_:	entry (chars, bits, code);

	mp = addr(d);				/* point to directory modes */

COMMON:
	code = 0;					/* reset status code */
	bits,
	mode = ""b;				/* zero return string and bit temporary */
	bp = addr (mode);				/* used to reference string as bit array */
	cp = addr (chars);				/* .. char array */
	if chars ^= "null" then if chars ^= "n" then do;	/* chars is real mode specification */
	     l = length (chars);			/* get length of input string */
	     do i = 1 to l;				/* scan char by char */
		chr = c.char(i);			/* copy char for efficiency */
		if chr = " " then			/* ignore blanks */
		     go to next;			/* get next char */
		do j = 1 to 3;			/* search mode char table */
		     if chr = mp->M.mchr(j) then do;	/* found char in table? */
			b.bit(j) = "1"b;		/* yes, set corresponding bit in mode string */
			go to next;		/* go get next char */
			end;
		     end;
		code = error_table_$bad_acl_mode;	/* illegal character in mode specification */
		return;				/* return with bits = "0"b */
next:		end;
	     bits = mode;				/* give mode string to user */
	     end;
	return;					/* finis */

	end cv_mode_;




		    cv_userid_.pl1                  11/04/82  1944.9rew 11/04/82  1624.4       24327



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


cv_userid_:	procedure (arg) returns (char(32));


/*

	This procedure converts an unnormalized process group id to
	standard format.  Example:  ".SysLib" becomes "*.SysLib.*".
	Calling sequence:

		normal_id = cv_userid_(string);

	The user, project, and tag fields are limited to 20, 9, and 1
	characters in length, respectively.

	P. Bos, May 1972

*/


     dcl	arg			char(*);		/* unnormalized userid e.g. ".SysLib" */

     dcl (addr, length, substr)	builtin;

     dcl (end, start) (3)		fixed bin init ((3) 1),
	string (3)		char(20) varying;

     dcl	lmax (3)			fixed bin int static init (20, 9, 1);

     dcl	chr			char(1) aligned,
	cp			ptr,
         (i, j, l)			fixed bin;

     dcl	1 c			based (cp),	/* char array overlaid on arg */
	  2 char (l)		char(1) unal;

/**/

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


	cp = addr (arg);				/* get pointer to unnormalized id */
	l = length (arg);				/* and its size */
	i = 1;					/* starting on first name component */

	do j = 1 to l;				/* scan char by char */
	     chr = c.char(j);			/* align this char */
	     if chr = " " then do;			/* blank implies end of string */
		end(i) = j;			/* mark it */
		go to done;			/* and exit */
		end;
	     if chr = "." then do;			/* "." marks end of component */
		end(i) = j;			/* save index */
		if i = 3 then			/* userid has only three components */
		     go to done;			/* exit after third one */
		i = i + 1;			/* starting next component */
		start(i) = j + 1;			/* mark start index for new component */
		end;
	     end;
	end(i) = j;				/* fell off end, mark index */

done:	do i = 1 to 3;				/* extract name components */
	     l = end(i) - start(i);			/* optimize */
	     if l > 0 then do;			/* is this field really there? */
		if l > lmax(i) then			/* each field has maximum width */
		     l = lmax(i);			/* adjust if too big */
		string(i) = substr (arg, start(i), l);	/* extract subfield */
		end;
	     else					/* nothing there */
		string(i) = "*";			/* null component implies "*" */
	     end;

	return (string(1) || "." || string(2) || "." || string(3));	/* form normalized id and return */

	end cv_userid_;




		    encode_access_class.pl1         02/13/85  0921.3r w 02/13/85  0846.6       82278



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1985 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:

	encode_access_class & decode_access_class

	Encode_access_class is an interface to the subroutine
     convert_access_class_$encode.  It either returns or prints an encoded
     version of an access class.  At the time of this writing, its
     main use is for an administrator setting up a data management
     to run at a particular AIM classification or someone looking in
     the pool_manager_ directories.

     USAGE:  eac STR {-ctl_arg}
	or [eac STR {-ctl_arg}]
     where STR is the access class to be encoded and the allowed control
	argument is -access_class (or -acc) which takes a STR value.  Only
	STR or -acc may be used, not both, and not more than once.

	Decode_access_class takes an encoded access class string and
     returns or prints the class in a readable form.  It calls
     convert_access_class_$decode to get the binary form of the class and
     then uses convert_access_class_$to_string to get the string to return
     to the user.

     USAGE:  dac STR
	or [dac STR]
*/

/* HISTORY:

Written by Lee A. Newcomb, 01/18/85.
Modified:
01/23/85 by Lee A. Newcomb:  Fixed to use long names of commands in error
            messages and correct to call ERROR_RETURN instead of com_err_ in
            when no arg is present.
*/

/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo,^inddcls,dclind5,idind35,linecom */
encode_access_class:
eac:
   proc () options (variable);

/* START OF DECLARATIONS */
/* Automatic */
dcl  (
     access_class			bit (72) aligned init (""b),
     access_class_string		char (256) init (""),
     arg_idx			fixed bin init (0),
     arg_len			fixed bin (21) init (0),
     arg_list_ptr			ptr init (null),
     arg_ptr			ptr init (null),
     code				fixed bin (35) init (0),
     encoded_access_class		char (15) init (""),
     is_active_function		bit (1) aligned init ("0"b),
     myname			char (19) init ("*code_access_class"),
     number_of_args			fixed bin init (-1),
     return_arg_len			fixed bin (21) init (0),
     return_arg_ptr			ptr init (null),
     sci_ptr			ptr init (null)
     )				automatic;

/* Based */
dcl  arg				char (arg_len) based (arg_ptr),
     return_arg			char (return_arg_len) varying
				based (return_arg_ptr);

/* Builtin */
dcl  (null, rtrim)			builtin;

/* Condition */
dcl  cleanup			condition;

/* Constant */
dcl  (
     ACC_CTL_ARG_LONG		char (13) init ("-access_class"),
     ACC_CTL_ARG_SHORT		char (4) init ("-acc"),
     DAC_NAME			char (19) init ("decode_access_class"),
     DAC_USAGE_MSG			char (23)
				init ("decode_access_class STR"),
     EAC_NAME			char (19) init ("encode_access_class"),
     EAC_USAGE_MSG			char (34)
				init (
				"encode_access_class STR {-ctl_arg}"),
     OPTIONAL_IOA_STRING_NOT_USED	bit (1) aligned init ("0"b),
     OPTIONAL_IOA_STRING_USED		bit (1) aligned init ("1"b),
     SSU_INVOCATION_ERR_MSG		char (49)
				init (
				"Cannot establish standalone subsystem invocation."
				)
     )				internal static options (constant);

/* Entry */
dcl  (
     com_err_			entry options (variable),
     convert_access_class_$decode	entry (bit (72) aligned, char (*)),
     convert_access_class_$encode	entry (bit (72) aligned, char (*)),
     convert_access_class_$from_string	entry (bit (72) aligned, char (*),
				fixed bin (35)),
     convert_access_class_$to_string	entry (bit (72) aligned, char (*),
				fixed bin (35)),
     cu_$arg_list_ptr		entry (ptr),
     get_authorization_		entry () returns (bit (72) aligned),
     ioa_				entry () options (variable),
     requote_string_		entry (char (*)) returns (char (*)),
     ssu_$abort_line		entry () options (variable),
     ssu_$arg_ptr			entry (ptr, fixed bin, ptr,
				fixed bin (21)),
     ssu_$destroy_invocation		entry (ptr),
     ssu_$return_arg		entry (ptr, fixed bin, bit (1) aligned,
				ptr, fixed bin (21)),
     ssu_$standalone_invocation	entry (ptr, char (*), char (*), ptr,
				entry, fixed bin (35))
     )				external;

/* External */

dcl  (
     error_table_$noarg,
     error_table_$too_many_args
     )				fixed bin (35) external;

/* END OF DECLARATIONS */
%page;
/* encode_access_class:			repeat for reader	*/
/* eac:							*/
/*     proc options (variable);				*/

SETUP_EAC_INVOCATION:
   do;
      myname = EAC_NAME;
      on cleanup call FINISH ();

      call cu_$arg_list_ptr (arg_list_ptr);
      call ssu_$standalone_invocation (sci_ptr, myname, "", arg_list_ptr,
	 ABORT_ENTRY, code);
      if code ^= 0 then				/* should be very rare */
         call ERROR_RETURN_FROM_SSU_SETUP (code, myname);
   end SETUP_EAC_INVOCATION;

   call ssu_$return_arg (sci_ptr, number_of_args, is_active_function,
        return_arg_ptr, return_arg_len);

GET_ACCESS_CLASS_TO_ENCODE:
   do;
      if number_of_args = 0 then
         access_class = get_authorization_ ();		/* process' access class */
      else
INTERPRET_ARGS:
         do;
         arg_idx = 1;
         call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
         if arg = ACC_CTL_ARG_LONG | arg = ACC_CTL_ARG_SHORT then
GET_REAL_ACCESS_CLASS_ARG:
	  do;
	  arg_idx = arg_idx + 1;
	  if arg_idx > number_of_args then
	     call ERROR_RETURN (error_table_$noarg, EAC_USAGE_MSG,
		OPTIONAL_IOA_STRING_NOT_USED, "");
	  if arg_idx < number_of_args then
	     call ERROR_RETURN (error_table_$too_many_args, EAC_USAGE_MSG,
		OPTIONAL_IOA_STRING_NOT_USED, "");
	  call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
         end GET_REAL_ACCESS_CLASS_ARG;
         call convert_access_class_$from_string (access_class, arg, code);
         if code ^= 0 then
	  call ERROR_RETURN (code, "Access class string provided: ^a",
	       OPTIONAL_IOA_STRING_USED, arg);

      end INTERPRET_ARGS;
   end GET_ACCESS_CLASS_TO_ENCODE;

   call convert_access_class_$encode (access_class, encoded_access_class);

GET_EAC_RESULT_TO_USER:
   if is_active_function then
      return_arg = encoded_access_class;
   else call ioa_ ("^a", encoded_access_class);

   call RETURN ();

/* end encode_access_class; */
%page;
decode_access_class:
dac:
   entry options (variable);

SETUP_DAC_INVOCATION:
   do;
      myname = DAC_NAME;
      on cleanup call FINISH ();

      call cu_$arg_list_ptr (arg_list_ptr);
      call ssu_$standalone_invocation (sci_ptr, myname, "", arg_list_ptr,
	 ABORT_ENTRY, code);
      if code ^= 0 then				/* should be very rare */
         call ERROR_RETURN_FROM_SSU_SETUP (code, myname);
   end SETUP_DAC_INVOCATION;

GET_ENCODED_ACCESS_CLASS_STRING:
   do;
      call ssu_$return_arg (sci_ptr, number_of_args, is_active_function,
	 return_arg_ptr, return_arg_len);

      if number_of_args = 0 then
         call ERROR_RETURN (error_table_$noarg, DAC_USAGE_MSG,
	    OPTIONAL_IOA_STRING_NOT_USED, "");
      if number_of_args > 1 then
         call ERROR_RETURN (error_table_$too_many_args, DAC_USAGE_MSG,
	    OPTIONAL_IOA_STRING_NOT_USED, "");
      call ssu_$arg_ptr (sci_ptr, 1 /* only one allowed */, arg_ptr, arg_len);
   end GET_ENCODED_ACCESS_CLASS_STRING;

GET_DAC_RESULT:
   do;
      call convert_access_class_$decode (access_class, arg);
      call convert_access_class_$to_string (access_class, access_class_string,
	 code);
      if code ^= 0 then
         call ERROR_RETURN (code,
	    "Provided access class string to decode: ^a.",
	    OPTIONAL_IOA_STRING_USED, arg);
   end GET_DAC_RESULT;

GET_DAC_RESULT_TO_USER:
   if is_active_function then
      return_arg = requote_string_ (rtrim (access_class_string));
   else call ioa_ ("^a", access_class_string);

   call RETURN ();

/* end decode_access_class; */
%page;
MAIN_RETURN:
   return;




RETURN:
   proc ();
   call FINISH ();
   go to MAIN_RETURN;
   end RETURN;





ABORT_ENTRY:
   procedure ();

   call FINISH ();
   go to MAIN_RETURN;

   end ABORT_ENTRY;



FINISH:
   procedure ();

   if sci_ptr ^= null () then
      call ssu_$destroy_invocation (sci_ptr);

   return;
   end FINISH;




ERROR_RETURN:
   proc (er_p_code, er_p_ioa_string, er_p_ioa_optional_arg_given,
        er_p_ioa_optional_arg);

dcl  (
     er_p_code			fixed bin (35),
     er_p_ioa_string		char (*),
     er_p_ioa_optional_arg_given	bit (1) aligned,
     er_p_ioa_optional_arg		char (*)
     )				parameter;


   if er_p_ioa_optional_arg_given then
      call ssu_$abort_line (sci_ptr, er_p_code, er_p_ioa_string,
	 er_p_ioa_optional_arg);
   else call ssu_$abort_line (sci_ptr, er_p_code, er_p_ioa_string);

/* ssu_$abort_line does not return */

   end ERROR_RETURN;




ERROR_RETURN_FROM_SSU_SETUP:
   proc (erfss_p_code, erfss_p_myname);

dcl  (
     erfss_p_code			fixed bin (35),
     erfss_p_myname			char (*)
     )				parameter;

   call com_err_ (erfss_p_code, erfss_p_myname, SSU_INVOCATION_ERR_MSG);

   go to MAIN_RETURN;				/* FINISH skipped since nothing to destroy */

   end ERROR_RETURN_FROM_SSU_SETUP;

   end encode_access_class;




		    find_acl_names_.pl1             11/04/82  1944.9rew 11/04/82  1624.4       39276



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


find_acl_names_: proc (aptr, acln, aclp, aclcnt, flptr, num, code);

/* This procedure takes an access name as given to access commands, determines its type, and
   searches the given ACL for matches.  A flag is set for any match. */

/* initially coded by M. Weaver  17 March 1970 */
/* last modified by M. Weaver 11 April 1970  5:45 PM */

dcl  acname char (acln) based (aptr);
dcl (name, nm) char (32) var;
dcl (temp1, temp2) char (29) var;
dcl (aclp, flptr, ap, fp, aptr) ptr;
dcl (nfd, i, j, m, n, type, aclcnt, acln, num, typ) fixed bin;
dcl  code fixed bin (35);
dcl  flags (0:99) bit (1) aligned based (fp);
dcl  ft bit (1) aligned;
dcl 1 acl (0:99) aligned based (ap),
    2 userid char (32) aligned,
    2 pack_bits char (4) aligned;
dcl (index, mod, length, substr) builtin;

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

/*  copy arguments */
	ap = aclp;
	fp = flptr;
	code = 0;					/* code = 1 => all acl names are to be used */

	ft = "0"b;
	go to start;

find_type_: entry (aptr, acln, nm, typ);
	ft = "1"b;
						/* this entry is for setacl, which only needs the type, not the search */

/* determine structure of acname */

start:	type = 0;					/* initialize */
	if acname = "." then go to set_all;
	n = index (acname, ".");			/* find first . */
	if n ^= 1 then type = 4;			/* pn. or pn.. or pn.pj. or pn.pj.t */
	if n = 0 then go to set_name;
	else if n = acln then do;
set_name:	     name = acname;
	     go to check_t;
	end;
	m = index (substr (acname, n+1), ".");		/* find second . */
	if m = 1 then do;
	     if n + m = acln then do;			/* pn.. or .. */
		if type = 0 then do;		/* .. */
set_all:		     if ^ft then do;
			code = 1;
			num = 0;
		     end;
		     else typ = 8;
		     return;
		end;
		else do;				/* pn.. */
		     name = substr (acname, 1, n);
		     go to check_t;
		end;
	     end;
	     else do;				/* pn..t or ..t */
		if type = 0 then name = substr (acname, 2) || " "; /* ..t */
		else name = acname;			/* pn..t */
		type = type + 1;
		go to check_t;
	     end;
	end;					/* end of m = 1 */

	else do;					/* pn.pj.t or pn.pj. or .pj. or .pj.t or pn.pj or .pj */
	     if m ^= 0 then
		if n + m ^= acln then type = type + 1;	/* pn.pj.t or .pj.t */
	     type = type + 2;
	     go to set_name;
	end;

check_t:	if mod (type, 2) = 0 then
	     if substr (name, length (name), 1) ^= "."
	     then name = name || ".";			/* pn or pn.pj or .pj */
	if ft then do;				/* only need type and name for setacl */
	     typ = type;
	     nm = name;
	     return;
	end;
	nfd = 0;					/* initialize number found */

	if type < 4 then				/* ..t or .pj. or .pj.t */
	     do i = 0 to aclcnt;
	     if index (acl (i).userid, name) > 0 then do;
		flags (i) = "1"b;
		nfd = nfd+ 1;
	     end;
	end;

	else if type = 7 then do;			/* pn.pj.t */
	     do i = 0 to aclcnt while (acl (i).userid ^= name); end;
	     if i <= aclcnt then do;
		flags (i) = "1"b;
		nfd = 1;
	     end;
	end;

	else if type = 5 then do;			/* pn..t */
	     temp1 = substr (name, 1, n);		/* get pn. */
	     do i = 0 to aclcnt while (index (acl (i).userid, temp1) ^= 1); end;
	     if i < aclcnt then do;			/* found pn. */
		temp2 = substr (name, n+1) || " ";
		do j = i to aclcnt while (index (acl (j).userid, temp1) = 1);
		     if index (acl (j).userid, temp2) ^= 0 then do; /* look for .t */
			flags (j) = "1"b;
			nfd = nfd + 1;
		     end;
		end;
	     end;
	end;

	else do;					/* type = 4 or 6;  pn. or pn.pj. */
	     do i = 0 to aclcnt while (index (acl (i).userid, name) ^= 1); end;
	     if i <= aclcnt then
		do j = i to aclcnt while (index (acl (j).userid, name) = 1);
		flags (j) = "1"b;
		nfd = nfd + 1;
	     end;
	end;


/* The acl primitives put all the entries for a person together, and within this
   grouping they put all the entries for a particular project together. */


	num = nfd;
	if nfd = aclcnt + 1 then code = 1;
	return;
     end find_acl_names_;




		    find_common_acl_names_.pl1      11/04/82  1944.9rew 11/04/82  1624.4       61911



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


find_common_acl_names_: proc (a_access_name, a_names_ptr, a_datap,			/* input args */
			a_count, a_missing_component, a_already_used, a_code);	/* output args */


/* DECLARATIONS */


/* fixed point */

dcl (
     a_acl_count,
     a_count,
     a_ex_acl_type,
     a_type,
     count init (0),
     i,
     j
     ) fixed bin aligned;

dcl (
     a_code,
     code init (0),
     error_table_$badcall ext,
     error_table_$badstar ext,
     error_table_$out_of_sequence ext
     ) fixed bin (35) aligned;


/* pointers */

dcl (
     a_datap,
     a_names_ptr,
     a_caller_areap,
     names_ptr,
     procp int static init (null)
     ) ptr aligned;


/* bit strings */

dcl (
     a_already_used,
     a_missing_component,
     match_found,
     missing_component init ("0"b)
     ) bit (1) aligned;


/* character strings */

dcl (
     a_access_name
     ) char (*);

dcl (
     a_en,
     component (3),
     component2 (3)
     ) char (32) aligned;

dcl (
     a_dn
     ) char (168) aligned;


/* based structures */

dcl 1 acl (acl_count) aligned based (aclp),
     2 access_name char (32) aligned,
     2 modes bit (real_access_bit_length) aligned,
     2 extended_access bit (extended_access_bit_length) aligned,
     2 reterr fixed bin (35) aligned;

dcl  acl_entry_already_used (acl_count) bit (1) unaligned based (bsp);

dcl 1 data aligned based (a_datap),
     2 aclp pointer,
     2 bsp pointer,
     2 acl_count fixed bin(17),
     2 extended_access_bit_length fixed bin(17),
     2 real_access_bit_length fixed bin(17);

dcl  name_array (acl_count) char (32) aligned based (names_ptr);


/* include files */

% include extended_access_data;


/* builtin functions */

dcl (
     addr,
     index,
     length,
     null,
     substr,
     verify
     ) builtin;


/* entries */

dcl  cu_$ptr_call ext entry
     options (variable);

dcl  hcs_$make_ptr ext entry
    (ptr aligned, char (*) aligned, char (*) aligned, ptr aligned, fixed bin (35) aligned);

/*  */

	a_count = 0;
	names_ptr = a_names_ptr;
	a_already_used = "0"b;
	a_missing_component = "0"b;
	a_code = 0;

	if aclp = null
	then call return (error_table_$out_of_sequence);

	call set_components (a_access_name, component);
	do i = 1 to 3 while (^missing_component);
	     if component (i) = ""
	     then missing_component = "1"b;
	end;

	do i = 1 to acl_count;
	     call set_components (substr (acl (i).access_name, 1, 32), component2);
	     match_found = "1"b;
	     do j = 1 to 3 while (match_found);
		if component (j) ^= ""
		then if component (j) ^= component2 (j)
		then match_found = "0"b;
	     end;
	     if match_found
	     then do;
		if acl_entry_already_used (i)
		then a_already_used = "1"b;
		else
		do;
		     count = count + 1;
		     name_array (count) = acl (i).access_name;
		     acl_entry_already_used (i) = "1"b;
		end;
	     end;
	end;

	if count > 0
	then a_count = count;
	a_missing_component = missing_component;

	go to RETURN;


init:	entry (a_dn, a_en, a_type, a_ex_acl_type, a_caller_areap, a_datap, a_code);

	a_code = 0;
	acl_count = 0;
	aclp = null;
	bsp = null;

	if a_type = 5
	then do;
	     extended_access_bit_length = 36;
	     real_access_bit_length = 36;
	     if a_ex_acl_type < 1 | a_ex_acl_type > typ_count
	     then call return (error_table_$badcall);
	     call hcs_$make_ptr
	     (null, segdata (a_ex_acl_type).gate_name,
	     segdata (a_ex_acl_type).acl_prefix||"acl_list", procp, code);
	     if procp = null
	     then call return (code);
	     acl_count = -1;
	     call cu_$ptr_call (procp, a_dn, a_en, aclp, acl_count, a_caller_areap, code);
	     if code ^= 0
	     then call return (code);
	     do i = 1 to acl_count;
		if acl (i).reterr ^= 0
		then call return (acl (i).reterr);
	     end;
	end;

	else
	call return (error_table_$badcall);

	if code ^= 0
	then call return (code);

	return;


/* ------------------------------------------------------------------------- */
RETURN:	return;

/*  */

/* ------------------ */
/* LEVEL 1 PROCEDURES */
/* ------------------ */

set_components: proc (sc_access_name, sc_component);

dcl (
     sc_dot_count init (0),
     sc_dot_loc (2) init ((2) 0),
     sc_i,
     sc_len
     ) fixed bin aligned;

dcl (
     sc_access_name
     ) char (*);

dcl (
     sc_component (3)
     ) char (32) aligned;


	     do sc_i = 1 to 3;
		sc_component (sc_i) = "";
	     end;

	     if sc_access_name = "."
	     then do;
		sc_component(3) = "*";
		sc_access_name = "..*";
		return;
	     end;

	     sc_len = index (sc_access_name, " ") - 1;
	     if sc_len = -1
	     then sc_len = length (sc_access_name);
	     else if verify(substr(sc_access_name,sc_len+1)," ")^=0  /* blanks inside the name */
		then call return(error_table_$badstar);

	     do sc_i = 1 to sc_len;
		if substr (sc_access_name, sc_i, 1) = "."
		then do;
		     sc_dot_count = sc_dot_count + 1;
		     if sc_dot_count > 2
		     then call return (error_table_$badstar);
		     sc_dot_loc (sc_dot_count) = sc_i;
		end;
	     end;

	     if sc_dot_count = 0
	     then do;
		sc_component (1) = sc_access_name;
		sc_component (2), sc_component (3) = "*";
		substr(sc_access_name,sc_len+1,4) = ".*.*";
	     end;

	     else
	     if sc_dot_count = 1
	     then do;
		if sc_dot_loc (1) = 1
		then do;
		     sc_component (2) = substr (sc_access_name, 2, sc_len-1);
		     sc_component (3) = "*";
		end;
		else
		do;
		     sc_component (1) = substr (sc_access_name, 1, sc_dot_loc (1)-1);
		     if sc_dot_loc (1) < sc_len
		     then sc_component (2) = substr (sc_access_name, sc_dot_loc (1)+1, sc_len-sc_dot_loc (1));
		     sc_component (3) = "*";
		end;
		substr(sc_access_name,sc_len+1,2) = ".*";
	     end;

	     else					/* sc_dot_count = 2 */
	     do;
		if sc_dot_loc (1) ^= 1
		then sc_component (1) = substr (sc_access_name, 1, sc_dot_loc (1)-1);
		if sc_dot_loc (1)+1 < sc_dot_loc (2)
		then sc_component (2) = substr (sc_access_name, sc_dot_loc (1)+1, sc_dot_loc (2)-sc_dot_loc (1)-1);
		if sc_dot_loc (2) < sc_len
		then sc_component (3) = substr (sc_access_name, sc_dot_loc (2)+1, sc_len-sc_dot_loc (2));
	     end;

	     return;

	end set_components;

/*  */
/* ------------------ */
/* LEVEL 2 PROCEDURES */
/* ------------------ */

return:	proc (r_code);

dcl (
     r_code
     ) fixed bin (35) aligned;

	     a_code = r_code;
	     go to RETURN;

	end return;


     end find_common_acl_names_;




		    get_effective_access.pl1        04/22/86  1447.3rew 04/22/86  1443.7      101763



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */

/* format: on,style2,^inddcls,linecom,ifthendo,ifthen,^indnoniterdo,dclind5,idind35 */

/* DESCRIPTION
     This is a command/AF to return a user's effective access
to a branch without respect to AIM.
*/


/****^  HISTORY COMMENTS:
  1) change(83-09-13,Lippard), approve(86-03-10,MCR6565), audit(), install():
     Initial coding.
  2) change(84-04-26,Lippard), approve(86-03-10,MCR6899), audit(), install():
     Removed the extra linefeed from error messages and to not abort
     because of error_table_$nomatch.
  3) change(85-02-06,MSharpe), approve(86-03-10,MCR7122), audit(), install():
     replaced -fcnt with -inase/inaee; to report unsupop.
  4) change(86-03-03,Newcomb), approve(86-03-26,MCR7366), audit(86-04-15,Cox),
     install(86-04-22,MR12.0-1042):
     corrected to allow the "<" path by expanding the path before checking for a
     starname.
                                                   END HISTORY COMMENTS */

%page;
get_effective_access:
gea:
     procedure options (variable);

dcl  (						/* Automatics */
     all_modes			char (36),
     argl				fixed bin (21),
     argn				fixed bin,
     argp				ptr,
     bit_count			fixed bin (24),
     bits_ptr			ptr,
     code				fixed bin (35),
     dname			char (168),
     ename			char (32),
     (idx, jdx)			fixed bin,
     (mode, ex_mode)		bit (36) aligned,
     return_len			fixed bin (21),
     return_ptr			ptr,
     return_string			char (36) varying,
     1 si				aligned like suffix_info,
     type				fixed bin (2),
     userid			char (32),
     user_ring			fixed bin,
     (						/* Flags */
     active_function,
     userid_arg,
     path_arg,
     multiple_paths,
     star_path,
     ring_arg,
     no_type,
     printed_path
     )				bit (1) aligned
     )				automatic;

dcl						/* Based */
     arg				char (argl) based (argp),
     bits				(36) bit (1) unaligned based (bits_ptr),
     return_arg			char (return_len) varying based (return_ptr);

dcl  (						/* External Entries */
     (active_fnc_err_, com_err_)	entry options (variable),
     check_star_name_$entry		entry (char (*), fixed bin (35)),
     cu_$arg_ptr			entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     cu_$af_arg_ptr			entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     cu_$af_return_arg		entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     cv_userid_			entry (char (*)) returns (char (32)),
     expand_pathname_		entry (char (*), char (*), char (*), fixed bin (35)),
     fs_util_$get_user_access_modes	entry (char (*), char (*), char (*), fixed bin, bit (36) aligned,
				bit (36) aligned, fixed bin (35)),
     fs_util_$suffix_info		entry (char (*), char (*), ptr, fixed bin (35)),
     get_system_free_area_		entry () returns (ptr),
     hcs_$get_user_access_modes	entry (char (*), char (*), char (*), fixed bin, bit (36) aligned,
				bit (36) aligned, fixed bin (35)),
     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),
     pathname_			entry (char (*), char (*)) returns (char (168))
     )				external;

dcl  (						/* Entries:  variable */
     complain			entry variable options (variable),
     get_arg_ptr			variable entry (fixed bin, ptr, fixed bin (21), fixed bin (35))
     );

dcl  (						/* Constants */
     ME				char (20) initial ("get_effective_access"),
     TRUE				bit (1) init ("1"b),
     FALSE			bit (1) init ("0"b),
     CHASE			fixed bin (1) init (1),
     SEGMENT			fixed bin (2) init (1),
     DIRECTORY			fixed bin (2) init (2)
     )				internal static options (constant);

dcl  (						/* error codes */
     error_table_$badopt,
     error_table_$bad_conversion,
     error_table_$badstar,
     error_table_$noarg,
     error_table_$nomatch,
     error_table_$unsupported_operation
     )				fixed bin (35) ext static;

/* PL/I things */
dcl  (addr, convert, length, null, rtrim, substr, sum)
				builtin;
dcl  (cleanup, conversion, size)	condition;
%page;
/* initialize switches */
	userid_arg, path_arg, multiple_paths, ring_arg, no_type, printed_path = FALSE;

/* process arguments */
	call cu_$af_return_arg (argn, return_ptr, return_len, code);

	if code = 0 then do;			/* active function invocation */
	     active_function = TRUE;
	     get_arg_ptr = cu_$af_arg_ptr;
	     complain = active_fnc_err_;
	end;

	else do;					/* command invocation */
	     active_function = FALSE;
	     get_arg_ptr = cu_$arg_ptr;
	     complain = com_err_;
	end;

	do idx = 1 to argn;
	     call get_arg_ptr (idx, argp, argl, code);
	     if substr (arg, 1, 1) = "-" then do;
		if arg = "-interpret_as_standard_entry" | arg = "-inase" then
		     no_type = TRUE;

		else if arg = "-interpret_as_extended_entry" | arg = "-inaee" then
		     no_type = FALSE;

		else if arg = "-ring" then do;
		     ring_arg = TRUE;
		     idx = idx + 1;
		     if idx > argn then do;
			call complain (error_table_$noarg, ME, "ring");
			return;
		     end;
		     call get_arg_ptr (idx, argp, argl, code);
		     on conversion, size goto CONVERSION;
		     user_ring = convert (user_ring, arg);
		     revert conversion, size;
		     if user_ring < 1 | user_ring > 7 then do;
			call complain (0, ME, "Invalid ring.  Ring must be an integer 1-7.");
			return;
		     end;
		end;
		else if arg = "-user" then do;
		     idx = idx + 1;
		     if idx > argn then do;
			call complain (error_table_$noarg, ME, "user name");
			return;
		     end;
		     call get_arg_ptr (idx, argp, argl, code);
		     userid = cv_userid_ (arg);
		     userid_arg = TRUE;
		end;
		else do;
		     call complain (error_table_$badopt, ME, "^a", arg);
		     return;
		end;
	     end;
	     else do;
		if path_arg then
		     multiple_paths = TRUE;
		path_arg = TRUE;
	     end;
	end;					/* arg loop */

	if ^path_arg then do;
	     call complain (0, ME, "Usage: ^[[^]gea paths {-control_args}^[]^]", active_function, active_function);
	     return;
	end;

	return_string = "";

	do idx = 1 to argn;				/* process pathnames */
	     call get_arg_ptr (idx, argp, argl, (0));
	     if arg = "-interpret_as_standard_entry" | arg = "-inase" then
		;
	     else if arg = "-interpret_as_extended_entry" | arg = "-inaee" then
		;
	     else if arg = "-ring" | arg = "-user" then
		idx = idx + 1;
	     else do;				/* pathname argument, let's do our job */
		call expand_pathname_ (arg, dname, ename, code);
		if code ^= 0 then do;
		     call complain (code, ME, "^a", arg);
		     return;
		end;
		star_path = FALSE;
		call check_star_name_$entry (ename, code);
		if code = error_table_$badstar then do;
		     call complain (code, ME, "^a", arg);
		     return;
		end;
		else if code ^= 0 then
		     star_path = TRUE;

		if star_path then do;
		     star_names_ptr, star_entry_ptr = null ();
		     on cleanup call free_star_structures ();
		     call hcs_$star_ (dname, ename, star_ALL_ENTRIES, get_system_free_area_ (), star_entry_count,
			star_entry_ptr, star_names_ptr, code);

		     if code ^= 0 then do;
			call complain (code, ME, "^a", pathname_ (dname, ename));
			if code ^= error_table_$nomatch then
			     return;		/* nothing to free */
		     end;

		     do jdx = 1 to star_entry_count;
			call return_info (dname, star_names (star_entries.nindex (jdx)), return_string, code);
			if code = 0 & ^active_function then do;
			     call ioa_ ("^[^/^]^3x^a^/^a", printed_path,
				pathname_ (dname, star_names (star_entries.nindex (jdx))), return_string);
			     printed_path = TRUE;
			end;
			else if code = 0 then
			     return_arg = return_arg || return_string || " ";

			else if code = error_table_$unsupported_operation & ^active_function then
			     call complain (code, ME, "^a",
				pathname_ (dname, star_names (star_entries.nindex (jdx))));
		     end;
		     call free_star_structures ();
		     revert cleanup;
		end;

		else do;
		     call return_info (dname, ename, return_string, code);

		     if ^active_function & multiple_paths & code = 0 then do;
			call ioa_ ("^[^/^]^3x^a^/^a", printed_path, pathname_ (dname, ename), return_string);
			printed_path = TRUE;
		     end;
		     else if active_function & code ^= 0 then
			return;
		     else if active_function then
			return_arg = return_arg || return_string || " ";
		     else if code = error_table_$unsupported_operation then
			call complain (code, ME);
		end;
	     end;
	end;					/* pathname processing loop */

	if active_function then
	     return_arg = rtrim (return_arg);
	else if ^star_path & ^multiple_paths & code = 0 then
	     call ioa_ ("^a", return_string);
	return;

CONVERSION:
	call complain (error_table_$bad_conversion, ME, "^a", arg);
	return;
%page;
free_star_structures:
     procedure;
	if star_names_ptr ^= null () then do;
	     free star_names;			/* in system free area */
	     star_names_ptr = null ();
	end;
	if star_entry_ptr ^= null () then do;
	     free star_entries;			/* in system free area */
	     star_entry_ptr = null ();
	end;
     end free_star_structures;




/* get the effective access on a specific branch entry */
return_info:
     procedure (P_dname, P_ename, P_return_string, P_code);
dcl  (P_dname, P_ename)		char (*) parm;
dcl  P_return_string		char (*) varying parm;
dcl  P_code			fixed bin (35) parm;
dcl  idx				fixed bin;

	P_code = 0;

	si.version = SUFFIX_INFO_VERSION_1;

	call fs_util_$suffix_info (P_dname, P_ename, addr (si), code);

	if code ^= 0 then do;
	     call complain (code, ME, "^a", pathname_ (P_dname, P_ename));
	     P_code = code;
	     return;
	end;

	if si.type = FS_OBJECT_TYPE_SEGMENT then
	     type = SEGMENT;
	else if si.type = FS_OBJECT_TYPE_DIRECTORY then
	     type = DIRECTORY;
	else if si.type = FS_OBJECT_TYPE_MSF then
	     type = SEGMENT;

	if ^userid_arg then
	     userid = "";
	if ^ring_arg then
	     user_ring = -1;

	P_return_string = "";

	if no_type then do;
	     call hcs_$status_minf (P_dname, P_ename, CHASE, type, bit_count, code);

	     if code ^= 0 then do;
		call complain (code, ME, "^a", pathname_ (dname, ename));
		return;
	     end;

	     if type = SEGMENT then
		all_modes = "rew";
	     else if type = DIRECTORY then
		all_modes = "sma";
	end;
	else all_modes = si.modes;

	if no_type then
	     call hcs_$get_user_access_modes (P_dname, P_ename, userid, user_ring, mode, ex_mode, code);
	else call fs_util_$get_user_access_modes (P_dname, P_ename, userid, user_ring, mode, ex_mode, code);
	if ^si.extended_acl | si.standard_object | no_type then
	     bits_ptr = addr (mode);
	else bits_ptr = addr (ex_mode);

	do idx = 1 to length (rtrim (all_modes));
	     if bits (idx) then
		P_return_string = P_return_string || substr (all_modes, idx, 1);
	end;

	if length (P_return_string) = 0 then
	     P_return_string = "null";

     end return_info;
%page;
%include suffix_info;
%page;
%include copy_flags;
%page;
%include star_structures;
     end get_effective_access;




		    inter_multics_aim_.pl1          08/05/87  0819.1r   08/04/87  1538.7      103194



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* Utilities to aid in the propogation of AIM between Multics systems */

/* Created:  July 1982 by G. Palter */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */


inter_multics_aim_:
     procedure ();

	return;					/* not an entrypoint */


/* Common Parameters */

dcl  P_code fixed binary (35) parameter;


/* get_system_aim_attributes_ Parameters */

dcl  P_area_ptr pointer parameter;			/* -> area where to allocate output structure */
dcl  P_version_wanted character (8) unaligned parameter;	/* version of aim_attributes structure desired */
dcl  P_aim_attributes_ptr pointer parameter;		/* set -> aim_attributes structure we create */


/* compute_common_aim_ceiling_ Parameters */

dcl  P_aim_attributes_1_ptr pointer parameter;		/* -> first system's AIM attributes */
dcl  P_common_ceiling_1 bit (72) aligned parameter;	/* set to the common ceiling in first system's terms */
dcl  P_aim_attributes_2_ptr pointer parameter;		/* -> second system's AIM attributes */
dcl  P_common_ceiling_2 bit (72) aligned parameter;	/* set to the common ceiling in second system's terms */


/* translate_aim_attributes_ Parameters */

dcl  P_source_aim_attributes_ptr pointer parameter;	/* -> source system's AIM attributes */
dcl  P_source_aim_authorization bit (72) aligned parameter; /* the access class/authorization to translate */
dcl  P_target_aim_attributes_ptr pointer parameter;	/* -> target system's AIM attributes */
dcl  P_target_aim_authorization bit (72) aligned parameter; /* set to the translated access class/authorization */


/* Local copies of parameters */

dcl  1 aim_attributes_1 aligned based (aim_attributes_1_ptr) like aim_attributes;
dcl  1 aim_attributes_2 aligned based (aim_attributes_2_ptr) like aim_attributes;
dcl  (aim_attributes_1_ptr, aim_attributes_2_ptr) pointer;

dcl  user_area area based (user_area_ptr);
dcl  user_area_ptr pointer;


/* Remaining declarations */

dcl  1 local_aim_template_1 aligned like aim_template;
dcl  1 local_aim_template_2 aligned like aim_template;

dcl  common_max_level fixed binary;			/* maximum sensitivity in common between systems */
dcl  category_translation (18, 2) fixed binary;		/* describes how to translate the categories */

dcl  ip pointer;					/* -> installation_parms */

dcl  idx fixed binary;

dcl  SYSTEM_CONTROL_DIR character (168) static options (constant) initial (">system_control_dir");
dcl  INSTALLATION_PARMS character (32) static options (constant) initial ("installation_parms");

/* format: off */
dcl (error_table_$ai_no_common_max, error_table_$ai_outside_common_range, error_table_$noalloc,
     error_table_$unimplemented_version)
	fixed binary (35) external;
/* format: on */

dcl  get_system_free_area_ entry () returns (pointer);
dcl  initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35));
dcl  terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35));

dcl  (area, cleanup) condition;

dcl  (hbound, lbound, min, null, substr, unspec) builtin;
%page;
/* Returns the AIM attributes defined on this system */

get_system_aim_attributes_:
     entry (P_area_ptr, P_version_wanted, P_aim_attributes_ptr, P_code);

	if P_version_wanted ^= AIM_ATTRIBUTES_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;				/* that's the only version we understand */
	end;

	if P_area_ptr = null () then			/* default to system free area */
	     user_area_ptr = get_system_free_area_ ();
	else user_area_ptr = P_area_ptr;

	aim_attributes_ptr, ip = null ();		/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if aim_attributes_ptr ^= null () then free aim_attributes in (user_area);
		if ip ^= null () then call terminate_file_ (ip, 0, TERM_FILE_TERM, (0));
		aim_attributes_ptr, ip = null ();
	     end;

	call initiate_file_ (SYSTEM_CONTROL_DIR, INSTALLATION_PARMS, R_ACCESS, ip, (0), P_code);
	if P_code ^= 0 then return;			/* couldn't get to it */

	on condition (area)
	     begin;				/* in case caller's area isn't large enough */
		P_code = error_table_$noalloc;
		go to RETURN_FROM_GET_SYSTEM_AIM_ATTRIBUTES_;
	     end;

	allocate aim_attributes in (user_area) set (aim_attributes_ptr);

	revert condition (area);

	aim_attributes.version = AIM_ATTRIBUTES_VERSION_1;

	aim_attributes.access_class_ceiling = installation_parms.access_authorization_ceiling;

	do idx = lbound (aim_attributes.levels, 1) to hbound (aim_attributes.levels, 1);
	     aim_attributes.levels (idx).long_name = installation_parms.level_names (idx);
	     aim_attributes.levels (idx).short_name = installation_parms.short_level_names (idx);
	end;

	do idx = lbound (aim_attributes.categories, 1) to hbound (aim_attributes.categories, 1);
	     aim_attributes.categories (idx).long_name = installation_parms.category_names (idx);
	     aim_attributes.categories (idx).short_name = installation_parms.short_category_names (idx);
	end;

	P_aim_attributes_ptr = aim_attributes_ptr;	/* completed successfully */
	P_code = 0;

RETURN_FROM_GET_SYSTEM_AIM_ATTRIBUTES_:
	if ip ^= null () then call terminate_file_ (ip, 0, TERM_FILE_TERM, (0));

	return;
%page;
/* Compute maximum authorization or access class which is in common between two systems */

compute_common_aim_ceiling_:
     entry (P_aim_attributes_1_ptr, P_common_ceiling_1, P_aim_attributes_2_ptr, P_common_ceiling_2, P_code);

	aim_attributes_1_ptr = P_aim_attributes_1_ptr;
	aim_attributes_2_ptr = P_aim_attributes_2_ptr;

	if (aim_attributes_1.version ^= AIM_ATTRIBUTES_VERSION_1)
	     | (aim_attributes_2.version ^= AIM_ATTRIBUTES_VERSION_1) then do;
	     P_code = error_table_$unimplemented_version;
	     return;				/* one of the structures is not acceptable */
	end;

	call compute_translation ();			/* computes necessary information to compute common ceiling */

	if common_max_level = -1 then do;		/* no levels in common: no common ceiling */
	     P_code = error_table_$ai_no_common_max;
	     return;
	end;

	P_code = 0;				/* we will succeed */


	unspec (local_aim_template_1) = ""b;		/* build ceiling in terms of first system */

	local_aim_template_1.level = common_max_level;

	do idx = lbound (category_translation, 1) to hbound (category_translation, 1);
	     if category_translation (idx, 1) ^= 0 then substr (local_aim_template_1.categories, idx, 1) = "1"b;
	end;

	P_common_ceiling_1 = unspec (local_aim_template_1);


	unspec (local_aim_template_2) = ""b;		/* build ceiling in terms of second system */

	local_aim_template_2.level = common_max_level;

	do idx = lbound (category_translation, 1) to hbound (category_translation, 1);
	     if category_translation (idx, 2) ^= 0 then substr (local_aim_template_2.categories, idx, 1) = "1"b;
	end;

	P_common_ceiling_2 = unspec (local_aim_template_2);

	return;
%page;
/* Translates the AIM attributes in an authorization or access class from one system's definition to another */

translate_aim_attributes_:
     entry (P_source_aim_attributes_ptr, P_source_aim_authorization, P_target_aim_attributes_ptr,
	P_target_aim_authorization, P_code);

	aim_attributes_1_ptr = P_source_aim_attributes_ptr;
	aim_attributes_2_ptr = P_target_aim_attributes_ptr;

	if (aim_attributes_1.version ^= AIM_ATTRIBUTES_VERSION_1)
	     | (aim_attributes_2.version ^= AIM_ATTRIBUTES_VERSION_1) then do;
	     P_code = error_table_$unimplemented_version;
	     return;				/* one of the structures is not acceptable */
	end;

	call compute_translation ();			/* computes necessary information to compute common ceiling */

	if common_max_level = -1 then do;		/* no levels in common: can't translate */
	     P_code = error_table_$ai_no_common_max;
	     return;
	end;

	unspec (local_aim_template_1) = P_source_aim_authorization;
	unspec (local_aim_template_2) = ""b;

	if local_aim_template_1.level > common_max_level then do;
	     P_code = error_table_$ai_outside_common_range;
	     return;				/* source level too high: can't translate */
	end;

	local_aim_template_2.level = local_aim_template_1.level;
						/* levels stay the same when translating */

	do idx = lbound (category_translation, 1) to hbound (category_translation, 1);
	     if substr (local_aim_template_1.categories, idx, 1) then
		if category_translation (idx, 1) ^= 0 then
		     substr (local_aim_template_2.categories, category_translation (idx, 1), 1) = "1"b;
		else do;				/* can't translate this category */
		     P_code = error_table_$ai_outside_common_range;
		     return;
		end;
	end;

	P_target_aim_authorization = unspec (local_aim_template_2);

	P_code = 0;				/* can only be here on success */

	return;
%page;
/* Computes how to translate between two sets of AIM attributes */

compute_translation:
     procedure ();

dcl  highest_possible_level fixed binary;
dcl  (idx, jdx) fixed binary;

dcl  continue bit (1) aligned;


/* Only sensitivity levels from level-0 up to but no including the first level which does not have the same long and short
   names on both systems may be translated */

	unspec (local_aim_template_1) = aim_attributes_1.access_class_ceiling;
	unspec (local_aim_template_2) = aim_attributes_2.access_class_ceiling;

	common_max_level = -1;

	highest_possible_level = min (local_aim_template_1.level, local_aim_template_2.level);
	continue = "1"b;

	do while (continue);
	     idx = common_max_level + 1;
	     if idx <= highest_possible_level then
		if (aim_attributes_1.levels (idx).long_name = aim_attributes_2.levels (idx).long_name)
		     & (aim_attributes_1.levels (idx).short_name = aim_attributes_2.levels (idx).short_name) then
		     common_max_level = idx;		/* this level is OK */
		else continue = "0"b;		/* this level's names differ on the two systems */
	     else continue = "0"b;			/* this level is too high */
	end;

	if common_max_level = -1 then return;		/* no common levels: can't ever translate */


/* Setup the access category translations: if a category N on system 1 has the same long and short name as category M on
   system 2, then category_translation(N,1) will be set to M and cateogry_translation(M,2) will be set to N */

	category_translation (*, *) = 0;		/* assume nothing translates */

	do idx = lbound (category_translation, 1) to hbound (category_translation, 1);

	     if substr (local_aim_template_1.categories, idx, 1) then do;
						/* only try to translate categories within systems' ceiling */

		continue = "1"b;

		do jdx = lbound (category_translation, 1) to hbound (category_translation, 1) while (continue);
		     if substr (local_aim_template_2.categories, jdx, 1) then
			if (aim_attributes_1.categories (idx).long_name
			     = aim_attributes_2.categories (jdx).long_name)
			     & (aim_attributes_1.categories (idx).short_name
			     = aim_attributes_2.categories (jdx).short_name) then do;
			     category_translation (idx, 1) = jdx;
			     category_translation (jdx, 2) = idx;
			     continue = "0"b;	/* found it */
			end;
		end;
	     end;
	end;

	return;
     end compute_translation;
%page;
%include aim_attributes;
%page;
%include aim_template;
%page;
%include installation_parms;
%page;
%include access_mode_values;

%include terminate_file;

     end inter_multics_aim_;




		    ms_create.pl1                   08/13/87  1457.8rew 08/13/87  1456.2      147744



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




/****^  HISTORY COMMENTS:
  1) change(75-01-01,Herbst), approve(), audit(), install():
     Pre-hcom comments.
     Written 01/01/75 by Steve Herbst
     ACL commands moved to set_acl.pl1 08/27/82 S. Herbst
  2) change(86-11-18,Lippard), approve(86-11-24,MCR7578),
     audit(87-07-13,Dickson), install(87-08-06,MR12.1-1067):
     Modified to use expand_pathname_$add_suffix instead of expand_path_.
  3) change(87-08-12,Lippard), approve(86-11-24,PBF7578),
     audit(87-08-13,Dickson), install(87-08-13,MR12.1-1087):
     Modified to add the suffix "ms" for message segments rather than
     always just adding "mbx".
                                                   END HISTORY COMMENTS */


ms_create: mscr: proc;

/* This procedure implements the special create, delete, add_name, delete_name,
   rename, set_max_length and safety_switch commands for mailboxes and message segments. */


dcl ename (99) char(32) aligned based(names_ptr);		/* names from hcs_$star_ */

dcl 1 entries (ecount) aligned based(entries_ptr),	/* entry info from hcs_$star_ */
     2 etype fixed bin(1) unaligned,
     2 nnames fixed bin(15) unaligned,
     2 nindex fixed bin unaligned;

dcl area area based(area_ptr);

dcl arg char(al) based(ap);
dcl dn char(168);
dcl (command, en, equal_name, new_name) char(32);
dcl amax_length char(8);
dcl exmode_letters char(7) init("adroswu");
dcl suffix char (4) varying;

dcl ap ptr;
dcl (area_ptr, entries_ptr, names_ptr) ptr init(null);

dcl (create, delete, delete_name) bit (1) aligned;
dcl (brief, got_path, got_max_length, octal, stars) bit(1) aligned;
dcl (safety_switch, yes_sw) bit (1) aligned;

dcl (branches init(10b), lk_type init(0), seg_type init(1), dir_type init(2))
	fixed bin(2) int static options(constant);
dcl type fixed bin(2);
dcl mode fixed bin(5);
dcl (al, arg_count, arg_index, ecount, i, j, k, name_count) fixed bin;
dcl (max_length, rounded_max_length) fixed bin(19);
dcl code fixed bin(35);

dcl error_table_$action_not_performed fixed bin(35) ext;
dcl error_table_$badopt fixed bin(35) ext;
dcl error_table_$badstar fixed bin(35) ext;
dcl error_table_$incorrect_access fixed bin(35) ext;
dcl error_table_$namedup fixed bin(35) ext;
dcl error_table_$no_dir fixed bin(35) ext;
dcl error_table_$no_info fixed bin(35) ext;
dcl error_table_$noentry fixed bin(35) ext;
dcl error_table_$nostars fixed bin(35) ext;

dcl sys_info$max_seg_size fixed bin(19) ext;

dcl check_star_name_$entry entry(char(*),fixed bin(35));
dcl (com_err_, com_err_$suppress_name) entry options(variable);
dcl command_query_$yes_no entry options(variable);
dcl cu_$arg_count entry(fixed bin);
dcl cu_$arg_ptr entry(fixed bin,ptr,fixed bin,fixed bin(35));
dcl cv_dec_check_ entry(char(*),fixed bin(35)) returns(fixed bin(35));
dcl cv_oct_check_ entry(char(*),fixed bin(35)) returns(fixed bin(35));
dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35));
dcl get_equal_name_ entry(char(*),char(*),char(*),fixed bin(35));
dcl get_ring_ entry returns(fixed bin);
dcl get_system_free_area_ entry returns(ptr);
dcl hcs_$get_safety_sw entry(char(*),char(*),bit(1)aligned,fixed bin(35));
dcl hcs_$get_user_effmode entry(char(*),char(*),char(*),fixed bin,fixed bin(5),fixed bin(35));
dcl hcs_$star_ entry(char(*),char(*),fixed bin(2),ptr,fixed bin,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 nd_handler_ entry(char(*),char(*),char(*),fixed bin(35));

dcl (ev1 entry variable,
	message_segment_$create, mailbox_$create,
	message_segment_$delete, mailbox_$delete)
		entry(char(*),char(*),fixed bin(35));
dcl (ev2 entry variable,
	message_segment_$chname_file, mailbox_$chname_file)
		entry(char(*),char(*),char(*),char(*),fixed bin(35));
dcl (ev3 entry variable,
	message_segment_$set_max_length_file, mailbox_$set_max_length_file)
		entry(char(*),char(*),fixed bin(19),fixed bin(35));
dcl (ev6 entry variable,
	message_segment_$set_safety_switch, mailbox_$set_safety_switch)
		entry(char(*),char(*),bit(1)aligned,fixed bin(35));

dcl (bit, divide, mod, null, substr) builtin;

dcl cleanup condition;
/**/
	command = "ms_create";
	create = "1"b;
	delete, delete_name = "0"b;
	suffix = ".ms";
	ev1 = message_segment_$create;
	go to COMMON;

mbx_create: mbcr: entry;

	command = "mbx_create";
	create = "1"b;
	delete, delete_name = "0"b;
	suffix = ".mbx";
	ev1 = mailbox_$create;
	go to COMMON;

ms_delete: msdl: entry;

	command = "ms_delete";
	delete = "1"b;
	create, delete_name = "0"b;
	suffix = ".ms";
	ev1 = message_segment_$delete;
	ev6 = message_segment_$set_safety_switch;
	go to COMMON;

mbx_delete: mbdl: entry;

	command = "mbx_delete";
	delete = "1"b;
	create, delete_name = "0"b;
	suffix = ".mbx";
	ev1 = mailbox_$delete;
	ev6 = mailbox_$set_safety_switch;
	go to COMMON;

ms_delete_name: msdn: entry;

	command = "ms_delete_name";
	delete_name = "1"b;
	create, delete = "0"b;
	suffix = ".ms";
	ev2 = message_segment_$chname_file;
	go to COMMON;

mbx_delete_name: mbdn: entry;

	command = "mbx_delete_name";
	delete_name = "1"b;
	create, delete = "0"b;
	suffix = ".mbx";
	ev2 = mailbox_$chname_file;
/**/
  COMMON: on condition(cleanup) call clean_up;

	call cu_$arg_count(arg_count);
	if arg_count=0 then do;
	     call com_err_$suppress_name(0,command,"Usage:  ^a paths",command);
	     return;
	end;

	call verify_args;

	do arg_index = 1 to arg_count;
	     if arg_index>1 then do;			/* free last name's allocations */
		if entries_ptr^=null then free entries in(area);
		if names_ptr^=null then free ename in(area);
	     end;
	     call get_entries;
	     do j = 1 to ecount;
		if stars & delete_name then name_count = nnames(j);  /* all names */
		else name_count = 1;		/* just all entries */
		do k = 1 to name_count;
		     if stars then en = ename(nindex(j)+k-1);
		     if delete then do;
			type = seg_type;
			call hcs_$status_minf(dn,en,0,type,0,code);
			if type=lk_type then do;
			     call com_err_(0,command,"^a^[>^]^a is a link. Use unlink.",dn,dn^=">",en);
			     go to NEXT;
			end;
			else if type=dir_type then do;
			     call com_err_(0,command,"^a^[>^]^a is a directory. Use delete_dir.",dn,dn^=">",en);
			     go to NEXT;
			end;
			if code=0 then do;
			     call hcs_$get_safety_sw(dn,en,safety_switch,code);
			     if safety_switch & code=0 then do;
				call hcs_$get_user_effmode(dn,"","",get_ring_(),mode,code);
				if code^=0 | substr(bit(mode,5),4,1) then do;  /* need modify */
				     call command_query_$yes_no (yes_sw, 0, command, "",
					"^a^[>^]^a is protected. Do you want to delete it?",
					dn, dn ^= ">", en);

				     if ^yes_sw then go to NEXT;
				     call ev6 (dn, en, "0"b, code);
				end;
			     end;
			end;
		     end;
  TRY_AGAIN:	     if delete_name then call ev2(dn,en,en,"",code);
			else call ev1(dn,en,code);
		     if code^=0 then
			if code=error_table_$namedup then do;
			     new_name = en;
			     call nd_handler_(command,dn,new_name,code);
			     if code=0 then go to TRY_AGAIN;
			end;
			else call com_err_(code,command,"^a^[>^]^a",dn,dn^=">",en);
NEXT:		end;
	     end;
	end;
	go to RETURN;
/**/
ms_add_name: msan: entry;

	command = "ms_add_name";
	suffix = ".ms";
	ev2 = message_segment_$chname_file;
	go to ADD_NAME;

mbx_add_name: mban: entry;

	command = "mbx_add_name";
	suffix = ".mbx";
	ev2 = mailbox_$chname_file;

  ADD_NAME:
	on condition(cleanup) call clean_up;

	call cu_$arg_count(arg_count);
	if arg_count<2 then do;
	     call com_err_$suppress_name(0,command,"Usage:  ^a path names",command);
	     return;
	end;

	call verify_args;

	arg_index = 1;
	call get_entries;
	do i = 2 to arg_count;
	     call cu_$arg_ptr(i,ap,al,code);
	     equal_name = arg;
	     do j = 1 to ecount;
		if stars then name_count = nnames(j);
		else name_count = 1;
		do k = 1 to name_count;
		     if stars then en = ename(nindex(j)+k-1);
		     call get_equal_name_(en,equal_name,new_name,code);
		     if code^=0 then do;
			call com_err_(code,command,"^a",arg);
			go to NEXT_NAME;
		     end;
  ADD_AGAIN:	     call ev2(dn,en,"",new_name,code);
		     if code^=0 then
			if code=error_table_$namedup then do;
			     call nd_handler_(command,dn,new_name,code);
			     if code=0 then go to ADD_AGAIN;
			end;
			else if code=error_table_$noentry | code=error_table_$no_dir
			     | code=error_table_$incorrect_access then do;
				call com_err_(code,command,"^a^[>^]^a",dn,dn^=">",en);
				go to RETURN;
			end;
			else call com_err_(code,command,"^a on ^a^[>^]^a",new_name,dn,dn^=">",en);
		end;
	     end;
  NEXT_NAME:
	end;
	go to RETURN;
/**/
ms_rename: msrn: entry;

	command = "ms_rename";
	suffix = ".ms";
	ev2 = message_segment_$chname_file;
	go to RENAME;

mbx_rename: mbrn: entry;

	command = "mbx_rename";
	suffix = ".mbx";
	ev2 = mailbox_$chname_file;

 RENAME:	on condition(cleanup) call clean_up;

	call cu_$arg_count(arg_count);
	if arg_count=0 | mod(arg_count,2)^=0 then do;
	     call com_err_$suppress_name(0,command,
		"Usage:  ^a path1 name1 ... {pathj} {namej}",command);
	     return;
	end;

	call verify_args;

	do arg_index = 1 by 2 to arg_count-1;
	     call get_entries;
	     call cu_$arg_ptr(arg_index+1,ap,al,code);
	     equal_name = arg;
	     do j = 1 to ecount;
		if stars then name_count = nnames(j);
		else name_count = 1;
		do k = 1 to name_count;
		     if stars then en = ename(nindex(j)+k-1);
		     call get_equal_name_(en,equal_name,new_name,code);
		     if code^=0 then do;
			call com_err_(code,command,"^a",arg);
			go to NEXT_PAIR;
		     end;
  RENAME_AGAIN:	     call ev2(dn,en,en,new_name,code);
		     if code^=0 then
			if code=error_table_$namedup then do;
			     call nd_handler_(command,dn,new_name,code);
			     if code=0 then go to RENAME_AGAIN;
			end;
			else if code=error_table_$noentry | code=error_table_$no_dir
			     | code=error_table_$incorrect_access then do;
				call com_err_(code,command,"^a^[>^]^a",dn,dn^=">",en);
				go to NEXT_PAIR;
			end;
			else call com_err_(code,command,"^a on ^a^[>^]^a",new_name,dn,dn^=">",en);
		end;
	     end;
  NEXT_PAIR:
	end;
	go to RETURN;
/**/
ms_set_max_length: mssml: entry;

	command = "ms_set_max_length";
	suffix = ".ms";
	ev3 = message_segment_$set_max_length_file;
	go to SET_MAX_LENGTH;

mbx_set_max_length: mbsml: entry;

	command = "mbx_set_max_length";
	suffix = ".mbx";
	ev3 = mailbox_$set_max_length_file;

  SET_MAX_LENGTH:
	on condition(cleanup) call clean_up;

	call cu_$arg_count(arg_count);
	brief, got_path, got_max_length, octal = "0"b;
	do arg_index = 1 to arg_count;
	     call cu_$arg_ptr(arg_index,ap,al,code);
	     if substr(arg,1,1)="-" then		/* control argument */
		if arg="-decimal" | arg="-dc" then octal = "0"b;
		else if arg="-octal" | arg="-oc" then octal = "1"b;
		else if arg="-brief" | arg="-bf" then brief = "1"b;
		else do;
		     call com_err_(error_table_$badopt,command,"^a",arg);
		     return;
		end;
	     else if ^got_path then do;
		call get_entries;
		got_path = "1"b;
	     end;
	     else do;
		amax_length = arg;
		got_max_length = "1"b;
	     end;
	end;

	if ^got_path | ^got_max_length then do;
	     call com_err_$suppress_name(0,command,
		"Usage:  ^a path max_length {control_args}",command);
	     go to RETURN;
	end;
	if octal then max_length = cv_oct_check_(amax_length,code);
	     else max_length = cv_dec_check_(amax_length,code);
	if code^=0 then do;
	     call com_err_(0,command,"^a is not a valid number.",amax_length);
	     go to RETURN;
	end;
	if max_length>sys_info$max_seg_size then do;
	     call com_err_(0,command,"Desired max length ^a exceeds maximum segment size ^d.",
					amax_length,sys_info$max_seg_size);
	     go to RETURN;
	end;
	if mod(max_length,1024)^=0 then do;
	     rounded_max_length = divide(max_length+1023,1024,19,0)*1024;
	     if ^brief then
		if octal then call com_err_(0,command,
		     "^o is not a multiple of 2000 (1024 decimal) words.^/^o used for max length.",
		     max_length,rounded_max_length);
		else call com_err_(0,command,
		     "^d is not a multiple of 1024 words.^/^d used for max length.",
		     max_length,rounded_max_length);
	     max_length = rounded_max_length;
	end;
	else rounded_max_length = max_length;

	do j = 1 to ecount;
	     if stars then en = ename(nindex(j));
	     call ev3(dn,en,rounded_max_length,code);
	     if code^=0 then
		if code=error_table_$action_not_performed then
		     if suffix=".ms" then call com_err_(0,command,
				"Message segment must be empty. ^a^[>^]^a",dn,dn^=">",en);
		     else call com_err_(0,command,
				"Mailbox must be empty. ^a^[>^]^a",dn,dn^=">",en);
		else do;
		     call com_err_(code,command,"^a^[>^]^a",dn,dn^=">",en);
		     if code=error_table_$incorrect_access |
			code=error_table_$no_info then go to RETURN;
		end;
	end;
	go to RETURN;
/**/
ms_safety_switch_on: msssn: entry;

	command = "ms_safety_switch_on";
	safety_switch = "1"b;
MS_SSW:	suffix = ".ms";
	ev6 = message_segment_$set_safety_switch;
	go to SET_SAFETY_SWITCH;

mbx_safety_switch_on: mbssn: entry;

	command = "mbx_safety_switch_on";
	safety_switch = "1"b;
MBX_SSW:	suffix = ".mbx";
	ev6 = mailbox_$set_safety_switch;
	go to SET_SAFETY_SWITCH;

ms_safety_switch_off: msssf: entry;

	command = "ms_safety_switch_off";
	safety_switch = "0"b;
	go to MS_SSW;

mbx_safety_switch_off: mbssf: entry;

	command = "mbx_safety_switch_off";
	safety_switch = "0"b;
	go to MBX_SSW;
/**/
SET_SAFETY_SWITCH: on condition (cleanup) call clean_up;

	call cu_$arg_count(arg_count);
	if arg_count<1 then do;
	     call com_err_$suppress_name(0,command,"Usage:  ^a paths",command);
	     go to RETURN;
	end;

	call verify_args;

	do arg_index = 1 to arg_count;
	     if arg_index>1 then do;
		if entries_ptr^=null then free entries in(area);
		if names_ptr^=null then free ename in(area);
	     end;

	     call get_entries;

	     do j = 1 to ecount;
		if stars then en = ename(nindex(j));
		call ev6(dn,en,safety_switch,code);
		if code^=0 then do;
		     call com_err_(code,command,"^a^[>^]^a",dn,dn^=">",en);
		     if code=error_table_$incorrect_access |
			code=error_table_$no_info then go to NEXT_ARG;
		end;
	     end;
NEXT_ARG:
	end;
	go to RETURN;
%page;
get_entries: proc;

	/* Internal procedure to expand pathname and apply star convention. */
	/* The variable arg_index is an implicit input argument = index of a command argument. */

	call cu_$arg_ptr(arg_index,ap,al,code);
	call expand_pathname_$add_suffix (arg, substr (suffix, 2), dn, en, code);
	if code^=0 then do;
	     call com_err_(code,command,"^a",arg);
	     go to RETURN;
	end;

	call check_star_name_$entry(en,code);
	if code=0 then do;				/* not a star name */
	     stars = "0"b;
	     ecount = 1;
	     return;
	end;
	if code=error_table_$badstar then do;
	     call com_err_(code,command,"^a",en);
	     go to RETURN;
	end;

	stars = "1"b;
	if command="ms_create" | command="mbx_create" then do;
	     call com_err_(error_table_$nostars,command);
	     go to RETURN;
	end;

	if area_ptr=null then area_ptr = get_system_free_area_();

	call hcs_$star_(dn,en,(branches),area_ptr,ecount,entries_ptr,names_ptr,code);
	if code^=0 then do;
	     call com_err_(code,command,"^a>^a",dn,en);
	     go to RETURN;
	end;

end get_entries;


verify_args: proc;

	/* This internal procedure scans the arguments and aborts with an
	   error message if it finds a control argument. */

	do arg_index = 1 to arg_count;
	     call cu_$arg_ptr(arg_index,ap,al,code);
	     if substr(arg,1,1)="-" then do;
		call com_err_(error_table_$badopt,command,"^a",arg);
		go to RETURN;
	     end;
	end;

end verify_args;
/**/
  RETURN: call clean_up;
	return;

clean_up: proc;

	if entries_ptr^=null then free entries in(area);
	if names_ptr^=null then free ename in(area);

end clean_up;


end ms_create;




		    print_auth_names.pl1            11/04/82  1944.9rew 11/04/82  1624.5       53154



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


print_auth_names: pan: proc;

/* This procedure will print the names of the access categories and sensitivity
   levels of the access isolation mechanism.  There are four control arguments
   for this command:

   -level           list sensitivity levels 0 to system high level.

   -category, -cat  list access categories in system high category set.

   -brief, -bf      suppress titles.

   -all, -a         list all possible level or category names (as requested)
   .		even if they are above system high.

   If neither the -level nor the -category options are specified, both options
   are assumed as default.
*/

/* Originally coded 741218 by J. Whitmore */
/* Modified 750102 by PG to use system_info_ */
/* Modified 750417 by LJS */


dcl  long_name char (32),
    (long, brief, lev, cat) bit (1) init ("0"b),
     max_level fixed bin,
     max_cat_set bit (18) aligned,
     high ptr,
     i fixed bin,
    (level_names dim (0:7), category_names dim (18)) char (32),
    (short_level_names dim (0:7), short_category_names dim (18)) char (8),
     access_ceiling bit (72) aligned,
     ec fixed bin (35),
     sys_high char (400),
     no_print bit (1) init ("1"b),
     date char (24);

dcl (ioa_, com_err_) entry options (variable),
     cu_$arg_count entry () returns (fixed bin),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     date_time_ entry (fixed bin (71), char (*)),
     clock_ entry () returns (fixed bin (71)),
     system_info_$access_ceiling entry (bit (72) aligned),
     system_info_$level_names entry (dim (0:7) char (32), dim (0:7) char (8)),
     system_info_$category_names entry (dim (18) char (32), dim (18) char (8));

dcl  aptr ptr,
     alen fixed bin,
     arg char (alen) based (aptr),
     nargs fixed bin;

dcl (addr, substr) builtin,
     error_table_$badopt ext fixed bin (35);

%include aim_template;


	nargs = cu_$arg_count ();

	if nargs = 0 then do;			/* if no arguments, take the default */
	     lev, cat = "1"b;
	     go to start;
	end;

	do i = 1 to nargs;				/* check the arguments ... what does he want printed? */

	     call cu_$arg_ptr (i, aptr, alen, ec);
	     if ec ^= 0 then do;
err:
		call com_err_ (ec, "print_auth_names", "^/Usage: print_auth_names -brief(-bf), -level, -category(-cat), -all(-a)");
		return;
	     end;

	     if arg = "-level" then lev = "1"b;

	     else if arg = "-cat" | arg = "-category" then cat = "1"b;

	     else if arg = "-bf" | arg = "-brief" then brief = "1"b;

	     else if arg = "-a" | arg = "-all" then long = "1"b;

	     else do;
		ec = error_table_$badopt;
		go to err;
	     end;
	end;

	if ^lev & ^cat then lev, cat = "1"b;		/* default to both names if no option */


start:						/* get value of access ceiling */
	call system_info_$access_ceiling (access_ceiling);

	if ^brief then do;				/* do we print a heading? */

	     call date_time_ (clock_ (), date);		/* give the date...names change over time */
	     call ioa_ ("^/Access Isolation Attribute Names - ^a", date);

	end;

	if long then do;				/* see how much info we should print */
	     max_level = 7;				/* print 0 through 7 */
	     max_cat_set = (18)"1"b;			/* print each of the 18 categories */
	end;
	else do;					/* stay within the system high boundry */
	     high = addr (access_ceiling);		/* ptr to system high */
	     max_level = high -> aim_template.level;	/* copy system high level */
	     max_cat_set = substr (high -> aim_template.categories, 1, 18); /* only the first 18 are defined */
	end;

	if lev then do;				/* print the level names? */

	     call system_info_$level_names (level_names, short_level_names);

	     if max_level = 0 then do;		/* there may be nothing to print */
		if level_names (0) ^= " " then do;	/* name exists, so print */
		     no_print = "0"b;		/* indicate that something was printed */
		     if ^brief then call ioa_ ("^/^-Sensitivity level"); /* title? */
		     call ioa_ ("^-^11a^a", short_level_names (0), level_names (0)); /* print name */
		end;
	     end;
	     else do;				/* he wants several names */
		no_print = "0"b;			/* indicate that we printed */
		if ^brief then call ioa_ ("^/^-Sensitivity Levels^/^7xShort Name^-Long Name");
		do i = 0 to max_level;
		     long_name = level_names (i);
		     if long_name = "" then long_name = "*- NOT NAMED -*"; /* we should print something!! */
		     call ioa_ ("^-^8a^2x^a", short_level_names (i), long_name);
		end;
	     end;
	end;

	if cat then				/* print category names? */

	     if max_cat_set ^= (18)"0"b then do;	/* is there anything to print? */
		call system_info_$category_names (category_names, short_category_names);
		no_print = "0"b;			/* yes, say we did it */
		if ^brief then call ioa_ ("^/^-Access Categories^/^7xShort Name^-Long Name"); /* short title? */
		do i = 1 to 18;
		     if substr (max_cat_set, i, 1) then do;
			long_name = category_names (i);
			if long_name = "" then long_name = "*- NOT NAMED -*"; /* again...print something */
			call ioa_ ("^-^8a^2x^a", short_category_names (i), long_name);
		     end;
		end;

	     end;



	if no_print then				/* special case when no names were printed */
	     if lev & cat then
		call ioa_ ("The only acceptable access class is ""system_low"".");
	     else if lev then
		call ioa_ ("There are no sensitivity levels defined.");
	     else call ioa_ ("There are no access categories defined.");

	return;
     end print_auth_names;




		    print_proc_auth.pl1             08/10/84  1119.6rew 08/10/84  1119.0       54963



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

/* Procedure to print the access authorization of a process */
/* Usage: print_proc_auth [options]

   no options:	print process authorization using short level and category names.

   -long,-lg	print process authorization using long level and category names.

   -all,-a:	print the maximum authorization of this process also.

   If this process has any system privileges, they will also be printed */

/* Originally coded by J. Whitmore  09/21/74
   Modified 750417 by LJS
   Modified 25 September 1983 by J. Spencer Love to add "comm" privilege and fix bugs. */

ppa:
print_proc_auth:
     procedure () options (variable);

dcl  aptr pointer,					/* arg pointer */
     alen fixed bin,				/* arg length */
     bchar char (alen) based (aptr);			/* arg string */

dcl (current, max) bit (72) aligned;			/* process authorizations */

%include aim_template;

dcl  priv (18) char (8) varying static options (constant) init ("ipc", "dir", "seg", "soos", "ring1", "rcp", "comm",
     "priv_8", "priv_9", "priv_10", "priv_11", "priv_12", "priv_13", "priv_14", "priv_15", "priv_16", "priv_17",
     "priv_18");

dcl  auth_string char (512),				/* string for authorization names */
     priv_string char (168) varying,			/* string for privilege names */
     command char (24);				/* entrypoint name for com_err_ */

dcl  long_sw bit (1) aligned init ("0"b),		/* long option indicator  */
     max_sw bit (1) aligned init ("0"b),		/* -all option indicator */
     ec fixed bin (35),				/* error code  */
     i fixed bin,					/* do loop index */
     nargs fixed bin;

dcl  auth_p pointer,				/* locator for auth structure */
    (addr, index, length, reverse, rtrim, string, substr) builtin;

dcl  hcs_$get_authorization entry (bit (72) aligned, bit (72) aligned),
    (ioa_, com_err_) entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     convert_authorization_$to_string entry (bit (72) aligned, char (*), fixed bin (35)),
     cu_$arg_count entry returns (fixed bin),
     convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)),
     error_table_$badopt ext static fixed bin (35);
%page;
	command = "print_proc_auth";
	nargs = cu_$arg_count ();

	do i = 1 to nargs;
	     call cu_$arg_ptr (i, aptr, alen, ec);
	     if index (bchar, "-") ^= 1 then do;
		call com_err_ (0, command, "Usage:  ppa {-control_args}");
		return;
	     end;
	     if bchar = "-long" | bchar = "-lg" then long_sw = "1"b;
	     else if bchar = "-all" | bchar = "-a" then max_sw = "1"b;
	     else do;
		ec = error_table_$badopt;
		call com_err_ (ec, command, bchar);
		return;
	     end;

	end;


	call hcs_$get_authorization (current, max);	/* get the authorizations */

	if long_sw then
	     call convert_authorization_$to_string (current, auth_string, ec);
	else call convert_authorization_$to_string_short (current, auth_string, ec);

	if ec ^= 0 then				/* if this happens, we're in trouble */
	     call com_err_ (ec, command, "Could not convert current authorization.");

	else do;
	     if auth_string = "" then call ioa_ ("^/Current authorization is un-named.");
	     else call print_formatted ("Current auth", auth_string); /* all was well, print it */
	end;

	if max_sw then do;				/* shall we print more info? */

	     if long_sw then
		call convert_authorization_$to_string (max, auth_string, ec);
	     else call convert_authorization_$to_string_short (max, auth_string, ec);

	     if ec ^= 0 then do;			/* conversion trouble? */
		call com_err_ (ec, command, "Could not convert max authorization.");
	     end;
	     else do;
		if auth_string = "" then call ioa_ ("Maximum authorization is un-named.");
		else call print_formatted ("Maximum auth", auth_string);
	     end;
	end;


	auth_p = addr (current);			/* the privileges are in the last 18 bits of current */
	priv_string = "";				/* and null the string */
	do i = 1 to 18;				/* look at all the priv bits */

	     if substr (string (auth_p -> privileges), i, 1) then do; /* add the name */

		priv_string = priv_string || priv (i) || ",";

	     end;					/* look for other bits */
	end;

	if length (priv_string) > 1 then do;		/* Only print privileges if set. */

	     auth_string = substr (priv_string, 1, length (priv_string) - 1); /* Remove comma. */

	     call print_formatted (" System Priv", auth_string);
	end;

	call ioa_ ();

	return;
%page;
print_formatted: proc (title, string);

dcl (title, string) char (*),
     ioa_$nnl entry options (variable),
    (len, ind, max_len, max_ch, pos) fixed bin,
     ll fixed bin init (71);				/* maximum number of characters per line */

	     ind = 1;				/* initialize the string index */

	     max_len = length (rtrim (string));		/* number of good chars */

	     pos = length (title) + 4;		/* get last used print position */

	     do while ((max_len-ind + 1) >50);		/* get ready to format */

		max_ch = ll - pos;			/* max chars left for this line */
		len = index (reverse (substr (string, ind, max_ch)), ",") - 1; /* find last comma */
						/* in the string of chars that could */
						/* fit on this line */
		if len < 0 then len = 0;		/* If no comma, get it right. */
		len = max_ch - len;			/* number of chars for this line */
		call ioa_ ("^[^/^a:^;^s^]^vt^a", (ind = 1), title, pos, substr (string, ind, len));
		ind = ind + len;			/* update the index */
		if substr (string, ind, 1) = " " then ind = ind + 1; /* Skip spaces in -long string */
	     end;

	     call ioa_ ("^[^/^a:^;^s^]^vt^a", (ind = 1), title, pos, substr (string, ind));

	     return;

	end print_formatted;

     end print_proc_auth;




		    set_ring_brackets.pl1           03/10/85  1722.1rew 03/08/85  0951.5      108756



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1985 *
   *                                                         *
   *********************************************************** */

set_ring_brackets:
srb:
     procedure () options (variable);

/* sytle: version3 */

/*
   ring bracket setting program.

   Command/Interface	Function
   -----------------	--------
   set_ring_brackets	sets ring brackets via fs_util_
   l_set_ring_brackets	sets ring brackets via installation_tools_
   hp_set_ring_brackets	sets ring brackets via hphcs_
   set_dir_ring_brackets	allow only dirs
   l_set_dir_ring_brackets	allow only dirs
   hp_set_dir_ring_brackets	allow only dirs

   Usage:

	srb path r1 r2 r3

   Where:
	path is a starname indicating segment(s) to have brackets set.
	rN is a ring number from 0 to 7
		if not provided, 
			r3 = r2 (dir operation excludes r3)
			r2 = r1
			r1 = current validation level.

   Originally coded by R. J. Feiertag on March 23, 1972
   Completely recoded by M. Pandolf on January 10, 1984

*/

%page;

/* DECLARATIONS */

/* Automatic */

	dcl     argl		 fixed bin (21);	/* length of command line arg */
	dcl     argno		 fixed bin;	/* index into command line args */
	dcl     argp		 pointer;		/* pointer to command line arg */
	dcl     bc		 fixed bin (24);	/* entry's bit count */
	dcl     code		 fixed bin (35);	/* standard status code */
	dcl     dirname		 char (168);	/* path name of parent */
	dcl     ename_count		 fixed bin;	/* number of names in structure */
	dcl     ename_ix		 fixed bin;	/* index into ename structure */
	dcl     enamep		 pointer;		/* pointer to structure of entrynames */
	dcl     entryname		 char (32);	/* star name of target to be set */
	dcl     i			 fixed bin;	/* index... */
	dcl     nargs		 fixed bin;	/* number of command line args */
	dcl     ring		 dim (3) fixed bin (3); /* the ring bracket values */
	dcl     ss_type		 fixed bin (2);	/* storage system entry type */
	dcl     system_areap	 pointer;		/* pointer to system free area */

/* Based */

	dcl     arg		 char (argl) based (argp); /* command line argument */
	dcl     dir_ring		 dim (2) fixed bin (3) based (addr (ring)); /* for correct dir RB parameter */
	dcl     1 ename		 aligned based (enamep), /* entryname structure */
		2 count		 fixed bin,
		2 string		 dim (ename_count refer (ename.count)) char (32) unaligned;
	dcl     system_area		 area based (system_areap); /* is system_free_area_ */

/* Static, External */

	dcl     error_table_$bad_conversion fixed bin (35) ext static;
	dcl     error_table_$invalid_ring_brackets fixed bin (35) ext static;
	dcl     error_table_$lower_ring fixed bin (35) ext static;
	dcl     error_table_$nomatch	 fixed bin (35) ext static;
	dcl     error_table_$not_privileged fixed bin (35) ext static;
	dcl     error_table_$notadir	 fixed bin (35) ext static;
	dcl     error_table_$too_many_args fixed bin (35) ext static;

/* Entry */

	dcl     check_star_name_$entry entry (char (*), fixed bin (35));
	dcl     com_err_		 entry () options (variable);
	dcl     cu_$arg_count_rel	 entry (fixed bin, ptr, fixed bin (35));
	dcl     cu_$arg_list_ptr	 entry () returns (ptr);
	dcl     cu_$arg_ptr_rel	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
	dcl     cu_$generate_call	 entry (entry, ptr);
	dcl     cu_$level_get	 entry () returns (fixed bin);
	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     fs_util_$set_ring_brackets entry (char (*), char (*), (*) fixed bin (3), fixed bin (35));
	dcl     get_ring_		 entry () returns (fixed bin (3));
	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     hcs_$set_dir_ring_brackets entry (char (*), char (*), (2) fixed bin (3), fixed bin (35));
	dcl     hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, 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     hphcs_$set_dir_ring_brackets entry (char (*), char (*), (2) fixed bin (3), fixed bin (35));
	dcl     hphcs_$set_ring_brackets entry (char (*), char (*), (*) fixed bin (3), fixed bin (35));
	dcl     installation_tools_$set_dir_ring_brackets entry (char (*), char (*), (2) fixed bin (3), fixed bin (35));
	dcl     installation_tools_$set_ring_brackets entry (char (*), char (*), (*) fixed bin (3), fixed bin (35));
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));

/* Constant */

	dcl     CHASE		 fixed bin (1) internal static options (constant) init (1);

	dcl     IDENT		 dim (6) char (32) internal static options (constant)
				 init ("set_ring_brackets", "l_set_ring_brackets", "hp_set_ring_brackets",
				 "set_dir_ring_brackets", "l_set_dir_ring_brackets", "hp_set_dir_ring_brackets");

	dcl     (RB		 init (1),
	        L_RB		 init (2),
	        HP_RB		 init (3),
	        D_RB		 init (4),
	        L_D_RB		 init (5),
	        HP_D_RB		 init (6)) internal static options (constant);

/* Builtin */

	dcl     addr		 builtin;
	dcl     max		 builtin;
	dcl     mod		 builtin;
	dcl     null		 builtin;
	dcl     sum		 builtin;

/* Condition */

	dcl     cleanup		 condition;
	dcl     linkage_error	 condition;

%page;

/* BEGIN MAIN CODE */

/*
set_ring_brackets:
sdrb:
	entry () options (variable);
*/

	call SET (RB, fs_util_$set_ring_brackets, cu_$arg_list_ptr ());
	return;

l_set_ring_brackets:
lset_ring_brackets:
lsrb:
     entry () options (variable);

	call SET (L_RB, installation_tools_$set_ring_brackets, cu_$arg_list_ptr ());
	return;

hp_set_ring_brackets:
hpset_ring_brackets:
hpsrb:
     entry () options (variable);

	call SET (HP_RB, hphcs_$set_ring_brackets, cu_$arg_list_ptr ());
	return;

set_dir_ring_brackets:
sdrb:
     entry () options (variable);

	call SET (D_RB, hcs_$set_dir_ring_brackets, cu_$arg_list_ptr ());
	return;

l_set_dir_ring_brackets:
lset_dir_ring_brackets:
lsdrb:
     entry () options (variable);

	call SET (L_D_RB, installation_tools_$set_dir_ring_brackets, cu_$arg_list_ptr ());
	return;

hp_set_dir_ring_brackets:
hpset_dir_ring_brackets:
hpsdrb:
     entry () options (variable);

	call SET (HP_D_RB, hphcs_$set_dir_ring_brackets, cu_$arg_list_ptr ());
	return;

error_return:
	call RELEASE_STORAGE ();
	return;

%page;

/* INTERNAL PROCEDURES */

SET:
     procedure (operation, operator, command_line_argp);

	dcl     operation		 fixed bin parameter;
	dcl     operator		 entry options (variable) parameter;
	dcl     command_line_argp	 pointer parameter;

/* initialize important values */

	system_areap = get_system_free_area_ ();
	star_names_ptr,
	     star_entry_ptr,
	     enamep = null ();

	on cleanup
	     call RELEASE_STORAGE ();

/* get arg information */

	call cu_$arg_count_rel (nargs, command_line_argp, code);
	if code ^= 0
	then call ABORT (code, IDENT (operation),
		"^/Usage is: ^a path {r1 {r2^[ {r3^;^]}}", IDENT (operation), (operation < 4));

/* get starname of entries to set */

	call cu_$arg_ptr_rel (1, argp, argl, code, command_line_argp);
	if code ^= 0
	then call ABORT (code, IDENT (operation),
		"^/Usage is: ^a path {r1 {r2^[ {r3^;^]}}", IDENT (operation), (operation < 4));

	call expand_pathname_ (arg, dirname, entryname, code);
	if code ^= 0
	then call ABORT (code, IDENT (operation), """^a""", arg);

/*  get the ring brackets from the command line */

	if ((nargs > 3) & (operation > 3)) | ((nargs > 4) & (operation < 4))
	then call ABORT (error_table_$too_many_args, IDENT (operation));

	do argno = 2 to nargs;

	     call cu_$arg_ptr_rel (argno, argp, argl, code, command_line_argp);
	     if code = 0
	     then do;
		     ring (argno - 1) = cv_dec_check_ (arg, code);
		     if code ^= 0
		     then call ABORT (error_table_$bad_conversion, IDENT (operation),
			     """^a"" isn't numeric.", arg);
		end;
	end;

	if (nargs > 3) & (operation > 3)
	then call ABORT (error_table_$too_many_args, IDENT (operation));

/* validate the ring brackets */

	if nargs = 1
	then ring (1), ring (2), ring (3) = cu_$level_get (); /* if no ring brackets, assume validation level */
	if nargs = 2
	then ring (2), ring (3) = ring (1);
	if nargs = 3
	then ring (3) = ring (2);

	if ^((operation = 1) | (operation = 4))
	then on linkage_error
		call ABORT (error_table_$not_privileged, IDENT (operation),
		     "Access to ^[hphcs_^;^;installation_tools_^;^].", mod (operation, 3) + 1);
	else do;
		if ring (1) < max (cu_$level_get (), get_ring_ ())
		then call ABORT (error_table_$lower_ring, IDENT (operation),
			"^d ^d ^[^d^;^s^]", ring (1), ring (2), (operation < 4), ring (3));

		if (ring (1) > ring (2)) | (ring (2) > ring (3))
		then call ABORT (error_table_$invalid_ring_brackets, IDENT (operation),
			"^d ^d ^[^d^;^s^]", ring (1), ring (2), (operation < 4), ring (3));
	     end;

/* set the ring brackets */

	call MAKE_NAME_LIST (dirname, entryname, enamep);

	if enamep -> ename.count = 0
	then call ABORT (error_table_$nomatch, IDENT (operation),
		"^a.", pathname_ (dirname, entryname));

	do i = 1 to enamep -> ename.count;

	     if operation > 3
	     then call operator (dirname, enamep -> ename.string (i), dir_ring, code);
	     else call operator (dirname, enamep -> ename.string (i), ring, code);

	     if code ^= 0
	     then call com_err_ (code, IDENT (operation),
		     "^a.", pathname_ (dirname, enamep -> ename.string (i)));

	end;

	call RELEASE_STORAGE ();

	return;

MAKE_NAME_LIST:
     procedure (parent, starname, eptr);

	dcl     parent		 char (168) parameter;
	dcl     starname		 char (32) parameter;
	dcl     eptr		 pointer parameter;

/* see if we have a starname or not */

	call check_star_name_$entry (starname, code);
	if code > 2				/* malformed star name */
	then do;
		call com_err_ (code, IDENT (operation),
		     "^a.", starname);
		goto error_return;
	     end;

	if code = 0				/* no special characters in starname */
	then do;
		call hcs_$status_minf (parent, starname, CHASE, ss_type, bc, code);
		if code ^= 0
		then call ABORT (code, IDENT (operation), "^a.", pathname_ (parent, starname));

		if (operation > 3) & (ss_type ^= star_DIRECTORY)
		then call ABORT (error_table_$notadir, IDENT (operation), "^a.", pathname_ (parent, starname));

		ename_count = 1;
		allocate ename set (eptr) in (system_area);
		eptr -> ename.string (1) = starname;
	     end;
	else do;					/* potentially matches multiple names */
		call hcs_$star_ (parent, starname, star_BRANCHES_ONLY, system_areap,
		     star_entry_count, star_entry_ptr, star_names_ptr, code);
		if code ^= 0
		then do;
			call com_err_ (code, IDENT (operation),
			     "^a.", pathname_ (parent, starname));
			goto error_return;
		     end;

		ename_count = star_entry_count;
		allocate ename set (eptr) in (system_area);
		ename_ix = 1;
		do i = 1 to star_entry_count;
		     if operation > 3		/* DIR wanted */
		     then if star_entries (i).type = star_DIRECTORY
			then eptr -> ename.string (ename_ix) = star_names (star_entries (i).nindex);
			else ename_ix = ename_ix - 1;
		     else eptr -> ename.string (ename_ix) = star_names (star_entries (i).nindex);
		     ename_ix = ename_ix + 1;
		end;

		eptr -> ename.count = ename_ix - 1;

		free star_names_ptr -> star_names in (system_area);
		free star_entry_ptr -> star_entries in (system_area);

	     end;

	return;

     end MAKE_NAME_LIST;

ABORT:
     procedure () options (variable);

	call cu_$generate_call (com_err_, cu_$arg_list_ptr ());
	goto error_return;

     end ABORT;

     end SET;

RELEASE_STORAGE:
     procedure ();

	system_areap = get_system_free_area_ ();

	if enamep ^= null ()
	then free enamep -> ename in (system_area);

	if star_names_ptr ^= null ()
	then free star_names_ptr -> star_names in (system_area);

	if star_entry_ptr ^= null ()
	then free star_entry_ptr -> star_entries in (system_area);

	return;

     end RELEASE_STORAGE;

%page;

/* INCLUDE FILES */

%include star_structures;

     end set_ring_brackets;



		    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
