



		    access_audit_.pl1               11/11/89  1103.7rew 11/11/89  0806.0      682344



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



/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1056):
     Correct error message documentation.
  2) change(88-01-13,Fawcett), approve(88-05-02,MCR7881),
     audit(88-06-21,Farley), install(88-08-02,MR12.2-1074):
     Changed to support always auditing of an fs_object whose entry.audit_flag
     has been set. This DOES NOT INHIBIT any other auditing cases if the flag
     is turned off.
  3) change(88-08-08,Farley), approve(88-08-08,PBF7881),
     audit(88-08-09,Martinson), install(88-08-09,MR12.2-1084):
     Changed always audit to only look at branches (no links) and to only
     audit ring-1 objects for segment level accesses..
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,linecom,indcomtxt,^inddcls,^indnoniterdo */

access_audit_:
     procedure;

/* format: off */
/******
     Revisions:
     1985-04-08 EJ Sharpe - fix message text a bit, fix some comments
     1985-04-01 KP Loepere - removed check_entry_ptr in favor of new alm version.
     1985-03-04 EJ Sharpe - remove national chars, select proper sorting class for messages
     1985-01-22 EJ Sharpe - changes per code audit, reformat
     1985-01-13 EJ Sharpe - added message documenation and fixed some msgs
     1985-01-11 EJ Sharpe - optimization to unlock directory a bit earlier
     1985-01-07 EJ Sharpe - stack frame optimizations, fix audit check computation
			some routines removed to form access_audit_log_fault_ and access_audit_util_
			cleaned up syserr messages, etc.
     1984-12-06 EJ Sharpe - fix bug in log_fault text message, output full
			error table text for normal audit.
     1984-11-29 EJ Sharpe - fix threshold comparison, fix suppression of
			caller supplied msg when obj_name is null
     1984-11-26 EJ Sharpe - added caller_level argument for logging entries
			also added the four "obj path" entries
     1984-11-15 EJ Sharpe - fixed some alignment problems, optional message
			string is now included in our generated message
			instead of being the complete message itself
     1984-11-11 EJ Sharpe - removed a_msg_str parameters, misc fixes
     1984-11-08 EJ Sharpe - misc fixes, and respect "null entry ptr means root" convention
     1984-11-02 EJ Sharpe - added capability to deal with link entries
     1984-10-30 EJ Sharpe - a number of minor changes
     1984-10-18 EJ Sharpe - added check_* entries
     1984-10-17 EJ Sharpe - major changes for revised audit flag strategy
     1984-10-09 EJ Sharpe - created
******/
%page;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* ACCESS_AUDIT_								*/
	/*									*/
	/* This module performs most security auditing.  Trusted Computer Base (TCB) subsystems	*/
	/* call upon this module to format system audit messages or simply determine whether	*/
	/* auditing of a given event is necessary.					*/
	/*									*/
	/* See also:								*/
	/* access_audit_log_fault_ - performs auditing for fim				*/
	/* access_audit_util_ - contains utility functions				*/
	/* access_audit_check_ep_ - inspects audit flags for file system			*/
	/* fim - performs its own inspection of the process audit flags			*/
	/* page_fault - performs its own auditing of a particular covert channel while masked	*/
	/*									*/
	/* The following entries format security audit messages for insertion in the syserr log.	*/
	/*									*/
	/*       access_audit_$log_general						*/
	/*       access_audit_$log_general_user						*/
	/*		These entries log an event with no associated object.		*/
	/*									*/
	/*       access_audit_$log_obj_class_range					*/
	/*       access_audit_$log_obj_class_range_user					*/
	/*		These entries log an event where the involved object is not a storage */
	/*		system entity and whose access class is specified as a		*/
	/*		range (e.g. tape_drives).					*/
	/*									*/
	/*       access_audit_$log_obj_class						*/
	/*       access_audit_$log_obj_class_user					*/
	/*		These entries log an event where there is some arbitrary object	*/
	/*		involved.							*/
	/*									*/
	/*       access_audit_$log_obj_path						*/
	/*       access_audit_$log_obj_path_user					*/
	/*       access_audit_$log_obj_ptr						*/
	/*       access_audit_$log_obj_ptr_user						*/
	/*       access_audit_$log_entry_ptr						*/
	/*       access_audit_$log_entry_ptr_user					*/
	/*		These entries log an event where the involved object is a storage	*/
	/*		system entity.						*/
	/*									*/
	/*       access_audit_$log_no_process						*/
	/*		This is a special entry to log an event where there is no process	*/
	/*		associated with that event (e.g. preaccess).			*/
	/*									*/
	/*									*/
	/*  The following entries do not produce a log entry.  Instead they simply check the	*/
	/*  process audit flags and system audit thresholds against the given event.  A bit "1"	*/
	/*  or "0" is returned indicating that auditing is required or not, respectively.	*/
	/*									*/
	/*      access_audit_$check_general						*/
	/*      access_audit_$check_general_user					*/
	/* 	     These entries are called when there is no object associated with the	*/
	/*	     event (e.g. privilege setting, sending a wakeup, etc.).  The "user" entry	*/
	/*	     is called for proxy users.					*/
	/*									*/
	/*      access_audit_$check_obj_class_range					*/
	/*      access_audit_$check_obj_class_range_user					*/
	/* 	     These entries are called when the object associated with the event is not	*/
	/* 	     a storage system object and that object has an access class range (e.g.	*/
	/* 	     tape drives).  The "user" entry is called for proxy users.		*/
	/*									*/
	/*      access_audit_$check_obj_class						*/
	/*      access_audit_$check_obj_class_user					*/
	/* 	     These entries are called when an arbitrary object is associated with the	*/
	/* 	     event which has a single access class.  This may be a storage system	*/
	/* 	     object.  The "user" entry is called for proxy users.  (Note:  The user of	*/
	/* 	     this is preferred over the "obj_ptr" and "entry_ptr" entries for reasons	*/
	/* 	     of efficiency (when the caller "knows" the access class)).		*/
	/*									*/
	/*      access_audit_$check_obj_path						*/
	/*      access_audit_$check_obj_path_user					*/
	/*      access_audit_$check_obj_ptr						*/
	/*      access_audit_$check_obj_ptr_user					*/
	/* 	     These entries are called when the object associated with the event is a	*/
	/* 	     storage system entity.  The caller supplies either a pointer to the	*/
	/* 	     object itself.  The "user" entries					*/
	/* 	     are called for proxy users.  (Note:  When the caller already "knows" the	*/
	/* 	     access class of the object, the "obj_class" access_audit_$check_ entries	*/
	/* 	     should be used for efficiency purposes.)				*/
	/*									*/
	/*									*/
	/* The functions of each of these entries is explained in greater detail in the comment   */
	/* preceeding each entry respectively.						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */
%page;

/*	PARAMETERS	*/

dcl     a_caller		 parameter char (*);	/* name of calling routine */
dcl     a_caller_level	 parameter fixed bin;	/* level to be reflected in audit message */
dcl     a_entry_ptr		 parameter pointer;		/* ptr to storage sys obj's dir entry */
dcl     a_err_code		 parameter fixed bin (35);	/* sys error code to put in audit message */
dcl     a_event_flags	 parameter bit (36) aligned;	/* actually is the audit flag index */
dcl     a_group_id		 parameter char (*);	/* for no_process entry only */
dcl     a_info_ptr		 parameter pointer;		/* caller's binary info fo the audit message */
dcl     a_info_size		 parameter fixed bin (21);	/* size of caller's binary info */
dcl     a_obj_class		 parameter bit (72) aligned;	/* access class of arbitrary object */
dcl     a_obj_class_range	 (2) parameter bit (72) aligned;
						/* access class range of non-stoarge-sys obj */
dcl     a_obj_name		 parameter char (*);	/* name of object (usually non-storage-system) */
dcl     a_obj_path		 parameter char (*);	/* pathname of storage system object */
dcl     a_obj_ptr		 parameter pointer;		/* ptr to storage system object */
dcl     a_oper_code		 parameter bit (36) aligned;	/* unique operation code for the TCB event */
dcl     a_user_audit_flags	 parameter bit (36) aligned;	/* audit flag array for proxy user */
dcl     a_user_auth		 parameter bit (72) aligned;	/* authorization of proxy user */
dcl     a_user_info_ptr	 parameter pointer;		/* structure of proxy user process info */


/*	CONSTANTS		*/

dcl     True		 bit (1) aligned int static options (constant) init ("1"b);
dcl     False		 bit (1) aligned int static options (constant) init ("0"b);

/*   Unique identifier for each logging entrypoint */
dcl     (
						/*	Check_*			init (00), - default value - see dcl for "entrypoint" */
        Log_General		 init (01),
        Log_General_User	 init (02),
        Log_Obj_Class_Range	 init (03),
        Log_Obj_Class_Range_User
			 init (04),
        Log_Obj_Class	 init (05),
        Log_Obj_Class_User	 init (06),
        Log_Obj_Path	 init (07),
        Log_Obj_Path_User	 init (08),
        Log_Obj_Ptr		 init (09),
        Log_Obj_Ptr_User	 init (10),
        Log_Entry_Ptr	 init (11),
        Log_Entry_Ptr_User	 init (12),
        Log_No_Process	 init (13)
        )			 fixed bin static internal options (constant);

/*   use unique entry identifier as index to get textual name */
dcl     EntryNames		 (0:13) char (24) int static options (constant) init (
			 "check_*",
			 "log_general",
			 "log_general_user",
			 "log_obj_class_range",
			 "log_obj_class_range_user",
			 "log_obj_class",
			 "log_obj_class_user",
			 "log_obj_path",
			 "log_obj_path_user",
			 "log_obj_ptr",
			 "log_obj_ptr_user",
			 "log_entry_ptr",
			 "log_entry_ptr_user",
			 "log_no_process");



/*	AUTOMATIC		*/

dcl     arg_list_ptr	 pointer;			/* pointer to our args */
dcl     called_dc_find	 bit (1) aligned;		/* specifies whether we should call dc_find$finished */
dcl     caller		 char (64);		/* arg copy */
dcl     caller_level	 fixed bin;		/* arg copy */
dcl     caller_supplied_text_sw
			 bit (1) aligned;		/* indicates caller supplied optional msg str arg */
dcl     caller_text_buff	 char (256);		/* we'll format caller's ctl str and opt args here */
dcl     caller_text_len	 fixed bin (21);		/* length of the text after formline_ */
dcl     caller_text_ptr	 pointer;			/* ptr to caller_text_buff */
dcl     char528v		 char (528) var;		/* temp var */
dcl     check_result	 bit (1) aligned;		/* result of flag/threshold evaluation */
dcl     check_sw		 bit (1) aligned;		/* flag indicating we're just checking, no logging */
dcl     code		 fixed bin (35);		/* err code returned from entries we call */
dcl     control_str_arg_index	 fixed bin;		/* tells formline_ where control str is */
dcl     entry_ptr		 pointer;			/* arg copy */
dcl     entrypoint		 fixed bin init (0);	/* entry point index */
dcl     entry_type_str	 char (10);		/* "segment", "directory", or "link" */
dcl     err_code		 fixed bin (35);		/* arg copy */
dcl     1 event_flags	 aligned like audit_event_flags;
						/* arg copy */
dcl     group_id		 char (32) aligned;		/* arg copy */
dcl     have_entry_sw	 bit (1) aligned;		/* indicates we have a ptr to a dir entry */
dcl     have_obj_path_sw	 bit (1) aligned;		/* indicates we have a path argument */
dcl     i			 fixed bin;		/* utility index */
dcl     info_ptr		 pointer;			/* arg copy */
dcl     info_size		 fixed bin (21);		/* arg copy */
dcl     initial_cpu		 fixed bin (71);		/* for metering */
dcl     initial_pagefaults	 fixed bin;		/* for metering */
dcl     link_info_valid_sw	 bit (1) aligned;		/* indicates that link info may be put into log */
dcl     local_bin_data_area	 (26) bit (36) aligned;
						/* small area to build extended binary data */
dcl     1 local_audit_header	 aligned like audit_record_header_proxy;
						/* binary data header */
dcl     locked_dir		 bit (1) aligned;		/* flag indicating that we've locked the directory */
dcl     meter_index		 fixed bin;		/* indicates metering bucket to use */
dcl     n_args		 fixed bin;		/* number of arguments passed to us */
dcl     obj_class		 bit (72) aligned;		/* arg copy */
dcl     obj_class_range	 (2) bit (72) aligned;	/* arg copy */
dcl     object_info_valid_sw	 bit (1) aligned;		/* indicates that ssobj can be put in log */
dcl     obj_path		 char (168);		/* arg copy */
dcl     obj_name		 char (168) defined (obj_path);
						/* arg copy, path and name are mutually exclusive */
dcl     obj_ptr		 pointer;			/* arg copy */
dcl     1 oper_code		 aligned like encoded_access_op;
						/* arg copy */
dcl     1 process_audit_flags	 aligned like audit_flags;	/* audit flags of process being audited */
dcl     process_auth	 bit (72) aligned;		/* auth of process being audited */
dcl     msg_text_buff	 char (512) aligned;	/* ioa_$rsnpnnl assembles the text message here */
						/* 512 chars is all syserr will use... */
dcl     msg_text_len	 fixed bin (21);		/* length of text */
dcl     msg_text_ptr	 pointer;			/* ptr to msg_text_buff */
dcl     user_entry_sw	 bit (1) aligned;		/* flag indicating proxy user info available */
dcl     1 user_info		 aligned like audit_user_info;/* arg copy */


/*	BASED		*/

dcl     caller_text		 char (caller_text_len) based (caller_text_ptr);
						/* caller's text arg or caller_text_buff */
dcl     msg_text		 char (msg_text_len) based (msg_text_ptr);
						/* the part of msg_text_buff that ioa_$rsnpnnl set up */


/*	MISCELLANEOUS	*/

dcl     addr		 builtin;
dcl     hbound		 builtin;
dcl     index		 builtin;
dcl     lbound		 builtin;
dcl     length		 builtin;
dcl     max		 builtin;
dcl     null		 builtin;
dcl     pointer		 builtin;
dcl     rel		 builtin;
dcl     rtrim		 builtin;
dcl     segno		 builtin;
dcl     size		 builtin;
dcl     string		 builtin;
dcl     substr		 builtin;
dcl     unspec		 builtin;


/*	EXTERNAL		*/

dcl     (
        access_operations_$mseg_delete,
        access_operations_$mseg_open,
        access_operations_$mseg_close,
        access_operations_$mseg_attr_read,
        access_operations_$mseg_attr_mod,
        access_operations_$mseg_access_read,
        access_operations_$mseg_access_mod,
        access_operations_$mseg_accept_wakeups
        )			 bit (36) aligned ext static;

dcl     active_all_rings_data$hcscnt
			 fixed bin external;

/* Note - The next four externals hold the access audit metering data. */
/*	active_hardcore_data$access_audit_num_meters" is set to the dimension. */
/*        This value is (n_audit_objects*6) + n_audit_events + 1. */
/*	This dimension should be increased as audit objects/events are added. */
dcl     active_hardcore_data$access_audit_num_meters
			 fixed bin external;
dcl     active_hardcore_data$access_audit_count
			 (1) fixed bin (35) external;
dcl     active_hardcore_data$access_audit_check_count
			 (1) fixed bin (35) external;
dcl     active_hardcore_data$access_audit_cpu_time
			 (1) fixed bin (71) external;
dcl     active_hardcore_data$access_audit_pagefaults
			 (1) fixed bin (35) external;

dcl     error_table_$invalidsegno
			 fixed bin (35) external;
dcl     error_table_$mylock	 fixed bin (35) external;
dcl     error_table_$no_dir	 fixed bin (35) external;
dcl     error_table_$noentry	 fixed bin (35) external;
dcl     error_table_$root	 fixed bin (35) external;
dcl     pds$access_authorization
			 bit (72) aligned external;
dcl     pds$audit_flags	 bit (36) aligned external;
dcl     pds$max_access_authorization
			 bit (72) aligned external;
dcl     pds$process_group_id	 char (32) aligned external;
dcl     pds$process_id	 bit (36) aligned external;
dcl     sys_info$access_class_ceiling
			 bit (72) aligned external;
dcl     sys_info$access_class_floor
			 bit (72) aligned external;
dcl     sys_info$audit_covert_channel
			 bit (1) aligned external;
dcl     sys_info$covert_channel_threshold
			 bit (72) aligned external;
dcl     sys_info$audit_successful_access
			 bit (1) aligned external;
dcl     sys_info$successful_access_threshold
			 bit (72) aligned external;
dcl     sys_info$audit_unsuccessful_access
			 bit (1) aligned external;
dcl     sys_info$unsuccessful_access_threshold
			 bit (72) aligned external;


/*	ENTRIES		*/

dcl     access_mode$raw	 entry (pointer, bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl     arg_count_		 entry (fixed bin);
dcl     arg_list_ptr_	 entry (pointer);
dcl     dc_find$finished	 entry (pointer, bit (1) aligned);
dcl     dc_find$obj_for_audit	 entry (char (168), char (32), pointer, fixed bin (35));
dcl     display_access_class_	 entry (bit (72) aligned) returns (char (32) aligned);
dcl     display_access_class_$range
			 entry ((2) bit (72) aligned) returns (char (32) aligned);
dcl     convert_access_operation_
			 entry (bit (36) aligned) returns (char (50));
dcl     convert_status_code_	 entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl     cu_$arg_ptr_rel	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl     get_pathname_	 entry (fixed bin (17), char (*) varying, fixed bin (35));
dcl     formline_		 entry (fixed bin, fixed bin, pointer, fixed bin (21), fixed bin, pointer);
dcl     ioa_$rsnpnnl	 entry options (variable);
dcl     level$get		 entry () returns (fixed bin);
dcl     lock$dir_unlock	 entry (pointer);
dcl     sum$getbranch_root_my	 entry (pointer, bit (36) aligned, pointer, fixed bin (35));
dcl     syserr		 entry options (variable);
dcl     syserr$multiple_binary entry options (variable);
dcl     uid_path_util$get	 entry (ptr, dim (0:15) bit (36) aligned, fixed bin (35));
dcl     usage_values	 entry (fixed bin, fixed bin (71));
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* LOG_GENERAL, LOG_GENERAL_USER - Entries.					*/
	/*									*/
	/* These entries set up an audit message for an event associated with no object in	*/
	/* particular (e.g. privilege setting, wakeup sending, etc).  The "user" entry is used	*/
	/* for proxy users.								*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

log_general:
     entry (a_caller, a_caller_level, a_event_flags, a_oper_code, a_obj_name, a_err_code, a_info_ptr, a_info_size
	) options (variable);

	call meter_start;
	call arg_list_ptr_ (arg_list_ptr);
	call arg_count_ (n_args);
	call setup_log_entry (Log_General, 8);		/* copy args, etc */

	obj_name = a_obj_name;
	obj_class = sys_info$access_class_ceiling;	/* fake out check_flags... */

	if check_flags_and_thresholds ()
	then call log_audit_message;

	call meter_stop;
	return;



log_general_user:
     entry (a_caller, a_caller_level, a_event_flags, a_oper_code, a_obj_name, a_err_code, a_info_ptr, a_info_size,
	a_user_info_ptr) options (variable);

	call meter_start;
	call arg_list_ptr_ (arg_list_ptr);
	call arg_count_ (n_args);
	call setup_log_entry (Log_General_User, 9);	/* copy args, etc */

	obj_name = a_obj_name;
	obj_class = sys_info$access_class_ceiling;	/* fake out check_flags... */

	if check_flags_and_thresholds ()
	then call log_audit_message;

	call meter_stop;
	return;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* LOG_OBJ_CLASS, LOG_OBJ_CLASS_USER  - Entries.					*/
	/*									*/
	/* These entries set up the audit log message for an event associated with an arbitrary	*/
	/* object.  The "user" entry is called for proxy users.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

log_obj_class:
     entry (a_caller, a_caller_level, a_event_flags, a_oper_code, a_obj_class, a_obj_name, a_err_code, a_info_ptr,
	a_info_size) options (variable);

	call meter_start;
	call arg_list_ptr_ (arg_list_ptr);
	call arg_count_ (n_args);
	call setup_log_entry (Log_Obj_Class, 9);	/* copy args, etc */

	obj_name = a_obj_name;
	obj_class = a_obj_class;

	if check_flags_and_thresholds ()
	then call log_audit_message;

	call meter_stop;
	return;



log_obj_class_user:
     entry (a_caller, a_caller_level, a_event_flags, a_oper_code, a_obj_class, a_obj_name, a_err_code, a_info_ptr,
	a_info_size, a_user_info_ptr) options (variable);

	call meter_start;
	call arg_list_ptr_ (arg_list_ptr);
	call arg_count_ (n_args);
	call setup_log_entry (Log_Obj_Class_User, 10);	/* copy args, etc */

	obj_name = a_obj_name;
	obj_class = a_obj_class;

	if check_flags_and_thresholds ()
	then call log_audit_message;

	call meter_stop;
	return;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* LOG_OBJ_CLASS_RANGE, LOG_OBJ_CLASS_RANGE_USER  - Entries.			*/
	/*									*/
	/* This entry sets up the audit log message for an event associated with an arbitrary	*/
	/* object.  The object's access class is a range.  The "user" entry is called for proxy	*/
	/* users.									*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

log_obj_class_range:
     entry (a_caller, a_caller_level, a_event_flags, a_oper_code, a_obj_class_range, a_obj_name, a_err_code,
	a_info_ptr, a_info_size) options (variable);

	call meter_start;
	call arg_list_ptr_ (arg_list_ptr);
	call arg_count_ (n_args);
	call setup_log_entry (Log_Obj_Class_Range, 9);	/* copy args, etc */

	obj_name = a_obj_name;
	obj_class_range = a_obj_class_range;
	obj_class = obj_class_range (2);

	if check_flags_and_thresholds ()
	then call log_audit_message;

	call meter_stop;
	return;



log_obj_class_range_user:
     entry (a_caller, a_caller_level, a_event_flags, a_oper_code, a_obj_class_range, a_obj_name, a_err_code,
	a_info_ptr, a_info_size, a_user_info_ptr) options (variable);

	call meter_start;
	call arg_list_ptr_ (arg_list_ptr);
	call arg_count_ (n_args);
	call setup_log_entry (Log_Obj_Class_Range_User, 10);
						/* copy args, etc */

	obj_name = a_obj_name;
	obj_class_range = a_obj_class_range;
	obj_class = obj_class_range (2);

	if check_flags_and_thresholds ()
	then call log_audit_message;

	call meter_stop;
	return;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* LOG_OBJ_PATH, LOG_OBJ_PATH_USER - Entries.					*/
	/*									*/
	/* These entries log an event involving a storage system object.  The caller supplies a	*/
	/* pathname to that object.  This routine extracts the necessary information from the	*/
	/* directory entry of that object.  The "user" entry is called for proxy users.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

log_obj_path:
     entry (a_caller, a_caller_level, a_event_flags, a_oper_code, a_obj_path, a_err_code, a_info_ptr, a_info_size
	) options (variable);

	call meter_start;
	call arg_list_ptr_ (arg_list_ptr);
	call arg_count_ (n_args);
	call setup_log_entry (Log_Obj_Path, 8);		/* copy args, etc */

	obj_path = a_obj_path;
	have_obj_path_sw = True;

	call get_entry_ptr_and_class;

	if check_flags_and_thresholds ()
	then call log_audit_message;
	else call unlock_dir;

	call meter_stop;
	return;



log_obj_path_user:
     entry (a_caller, a_caller_level, a_event_flags, a_oper_code, a_obj_path, a_err_code, a_info_ptr, a_info_size,
	a_user_info_ptr) options (variable);

	call meter_start;
	call arg_list_ptr_ (arg_list_ptr);
	call arg_count_ (n_args);
	call setup_log_entry (Log_Obj_Path_User, 9);	/* copy args, etc */

	obj_path = a_obj_path;
	have_obj_path_sw = True;

	call get_entry_ptr_and_class;

	if check_flags_and_thresholds ()
	then call log_audit_message;
	else call unlock_dir;

	call meter_stop;
	return;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* LOG_OBJ_PTR, LOG_OBJ_PTR_USER - Entries.					*/
	/*									*/
	/* These entries log an event involving a storage system object.  The caller supplies a	*/
	/* pointer to that object.  This routine extracts the necessary information from the	*/
	/* directory entry of that object.  The "user" entry is called for proxy users.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

log_obj_ptr:
     entry (a_caller, a_caller_level, a_event_flags, a_oper_code, a_obj_ptr, a_err_code, a_info_ptr, a_info_size
	) options (variable);

	call meter_start;
	call arg_list_ptr_ (arg_list_ptr);
	call arg_count_ (n_args);
	call setup_log_entry (Log_Obj_Ptr, 8);		/* copy args, etc */

	obj_ptr = a_obj_ptr;

	call get_entry_ptr_and_class;

	if check_flags_and_thresholds ()
	then call log_audit_message;
	else call unlock_dir;

	call meter_stop;
	return;



log_obj_ptr_user:
     entry (a_caller, a_caller_level, a_event_flags, a_oper_code, a_obj_ptr, a_err_code, a_info_ptr, a_info_size,
	a_user_info_ptr) options (variable);

	call meter_start;
	call arg_list_ptr_ (arg_list_ptr);
	call arg_count_ (n_args);
	call setup_log_entry (Log_Obj_Ptr_User, 9);	/* copy args, etc */

	obj_ptr = a_obj_ptr;

	call get_entry_ptr_and_class;

	if check_flags_and_thresholds ()
	then call log_audit_message;
	else call unlock_dir;

	call meter_stop;
	return;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* LOG_ENTRY_PTR, LOG_ENTRY_PTR_USER - Entries.					*/
	/*									*/
	/* This entry logs an event involving a storage system object.  The caller supplies a	*/
	/* pointer to the directory entry of that object.  This routine extracts the necessary	*/
	/* information from the directory entry of that object.  The "user" entry is called for	*/
	/* proxy users.								*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

log_entry_ptr:
     entry (a_caller, a_caller_level, a_event_flags, a_oper_code, a_entry_ptr, a_err_code, a_info_ptr, a_info_size
	) options (variable);

	call meter_start;
	call arg_list_ptr_ (arg_list_ptr);
	call arg_count_ (n_args);
	call setup_log_entry (Log_Entry_Ptr, 8);	/* copy args, etc */

	entry_ptr = a_entry_ptr;
	have_entry_sw = True;

	call get_entry_ptr_and_class;

	call log_audit_message;			/* the caller must run check itself */

	call meter_stop;
	return;



log_entry_ptr_user:
     entry (a_caller, a_caller_level, a_event_flags, a_oper_code, a_entry_ptr, a_err_code, a_info_ptr, a_info_size,
	a_user_info_ptr) options (variable);

	call meter_start;
	call arg_list_ptr_ (arg_list_ptr);
	call arg_count_ (n_args);
	call setup_log_entry (Log_Entry_Ptr_User, 9);	/* copy args, etc */

	entry_ptr = a_entry_ptr;
	have_entry_sw = True;

	call get_entry_ptr_and_class;

	call log_audit_message;			/* the caller must call check itself */

	call meter_stop;
	return;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* LOG_NO_PROCESS - Entrypoint.						*/
	/*									*/
	/* This entry is used for logging events where there is no process involved (e.g.	*/
	/* preaccess).  Since there is no process, there can be no check on the audit flags.	*/
	/* Thus, it is assumed the event must be audited.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

log_no_process:
     entry (a_caller, a_caller_level, a_event_flags, a_oper_code, a_obj_name, a_err_code, a_info_ptr, a_info_size,
	a_group_id) options (variable);

	call meter_start;
	call arg_list_ptr_ (arg_list_ptr);
	call arg_count_ (n_args);
	call setup_log_entry (Log_No_Process, 9);	/* copy args, etc */

	obj_name = a_obj_name;
	group_id = a_group_id;

	call log_audit_message;

	call meter_stop;
	return;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* CHECK_GENERAL, CHECK_GENERAL_USER - Entries.					*/
	/*									*/
	/* These entries perform just the audit flag/threshold check for general auditing cases	*/
	/* where there is no associated object.  The "user" entry is called for proxy users.	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

check_general:
     entry (a_event_flags, a_oper_code)
	returns (bit (1) aligned);

	call meter_start;
	check_sw = True;
	user_entry_sw = False;
	have_entry_sw = False;

	unspec (event_flags) = a_event_flags;
	unspec (oper_code) = a_oper_code;
	obj_class = sys_info$access_class_ceiling;	/* make sure thresholds don't bother us */
	process_auth = pds$access_authorization;
	unspec (process_audit_flags) = pds$audit_flags;

	check_result = check_flags_and_thresholds ();

	call set_meter_index;
	call meter_stop;

	return (check_result);



check_general_user:
     entry (a_event_flags, a_oper_code, a_user_auth, a_user_audit_flags)
	returns (bit (1) aligned);

	call meter_start;
	check_sw = True;
	user_entry_sw = True;
	have_entry_sw = False;

	unspec (event_flags) = a_event_flags;
	unspec (oper_code) = a_oper_code;
	obj_class = sys_info$access_class_ceiling;
	process_auth = a_user_auth;
	unspec (process_audit_flags) = a_user_audit_flags;

	check_result = check_flags_and_thresholds ();

	call set_meter_index;
	call meter_stop;

	return (check_result);
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* CHECK_OBJ_CLASS_RANGE, CHECK_OBJ_CLASS_RANGE_USER - Entries.			*/
	/*									*/
	/* These entries just check the audit flags/thresholds in respect to the specified	*/
	/* event in cases where the associated object class is expressed as a range (not a	*/
	/* storage system entity).  The "user" entry is called for proxy users.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

check_obj_class_range:
     entry (a_event_flags, a_oper_code, a_obj_class_range)
	returns (bit (1) aligned);

	call meter_start;
	check_sw = True;
	user_entry_sw = False;
	have_entry_sw = False;

	unspec (event_flags) = a_event_flags;
	unspec (oper_code) = a_oper_code;
	obj_class = a_obj_class_range (2);		/* assume higher end for auditing purposes */
	process_auth = pds$access_authorization;
	unspec (process_audit_flags) = pds$audit_flags;

	check_result = check_flags_and_thresholds ();

	call set_meter_index;
	call meter_stop;

	return (check_result);


check_obj_class_range_user:
     entry (a_event_flags, a_oper_code, a_obj_class_range, a_user_auth, a_user_audit_flags)
	returns (bit (1) aligned);

	call meter_start;
	check_sw = True;
	user_entry_sw = True;
	have_entry_sw = False;

	unspec (event_flags) = a_event_flags;
	unspec (oper_code) = a_oper_code;
	obj_class = a_obj_class_range (2);		/* assume higher end for auditing purposes */
	process_auth = a_user_auth;
	unspec (process_audit_flags) = a_user_audit_flags;

	check_result = check_flags_and_thresholds ();

	call set_meter_index;
	call meter_stop;

	return (check_result);
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* CHECK_OBJ_CLASS, CHECK_OBJ_CLASS_USER - Entries.				*/
	/*									*/
	/* These entries just check the audit flags/thresholds in respect to an event where	*/
	/* there is an arbitrary object involved.  The object may be a storage system object.	*/
	/* The "user" entry is called for proxy users.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

check_obj_class:
     entry (a_event_flags, a_oper_code, a_obj_class)
	returns (bit (1) aligned);

	call meter_start;
	check_sw = True;
	user_entry_sw = False;
	have_entry_sw = False;

	unspec (event_flags) = a_event_flags;
	unspec (oper_code) = a_oper_code;
	obj_class = a_obj_class;
	process_auth = pds$access_authorization;
	unspec (process_audit_flags) = pds$audit_flags;

	check_result = check_flags_and_thresholds ();

	call set_meter_index;
	call meter_stop;

	return (check_result);



check_obj_class_user:
     entry (a_event_flags, a_oper_code, a_obj_class, a_user_auth, a_user_audit_flags)
	returns (bit (1) aligned);

	call meter_start;
	check_sw = True;
	user_entry_sw = True;
	have_entry_sw = False;

	unspec (event_flags) = a_event_flags;
	unspec (oper_code) = a_oper_code;
	obj_class = a_obj_class;
	process_auth = a_user_auth;
	unspec (process_audit_flags) = a_user_audit_flags;

	check_result = check_flags_and_thresholds ();

	call set_meter_index;
	call meter_stop;

	return (check_result);
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* CHECK_OBJ_PATH, CHECK_OBJ_PATH_USER - Entries.					*/
	/*									*/
	/* These entries just check the audit flags/thresholds in respect to an event associated	*/
	/* with a storage system object.  The "user" entry is called for proxy users.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

check_obj_path:
     entry (a_event_flags, a_oper_code, a_obj_path)
	returns (bit (1) aligned);

	call meter_start;
	check_sw = True;
	user_entry_sw = False;

	unspec (event_flags) = a_event_flags;
	unspec (oper_code) = a_oper_code;
	obj_path = a_obj_path;
	have_obj_path_sw = True;
	obj_ptr = null;
	entry_ptr = null;
	have_entry_sw = False;
	call get_entry_ptr_and_class;
	call unlock_dir;
	process_auth = pds$access_authorization;
	unspec (process_audit_flags) = pds$audit_flags;

	check_result = check_flags_and_thresholds ();

	call set_meter_index;
	call meter_stop;

	return (check_result);

check_obj_path_user:
     entry (a_event_flags, a_oper_code, a_obj_path, a_user_auth, a_user_audit_flags)
	returns (bit (1) aligned);

	call meter_start;
	check_sw = True;
	user_entry_sw = True;

	unspec (event_flags) = a_event_flags;
	unspec (oper_code) = a_oper_code;
	obj_path = a_obj_path;
	have_obj_path_sw = True;
	obj_ptr = null;
	entry_ptr = null;
	have_entry_sw = False;
	call get_entry_ptr_and_class;
	call unlock_dir;
	process_auth = a_user_auth;
	unspec (process_audit_flags) = a_user_audit_flags;

	check_result = check_flags_and_thresholds ();

	call set_meter_index;
	call meter_stop;

	return (check_result);
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* CHECK_OBJ_PTR, CHECK_OBJ_PTR_USER - Entries.					*/
	/*									*/
	/* These entries just check the audit flags/thresholds in respect to an event associated	*/
	/* with a storage system object.  The "user" entry is called for proxy users.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

check_obj_ptr:
     entry (a_event_flags, a_oper_code, a_obj_ptr)
	returns (bit (1) aligned);

	call meter_start;
	check_sw = True;
	user_entry_sw = False;

	unspec (event_flags) = a_event_flags;
	unspec (oper_code) = a_oper_code;
	have_obj_path_sw = False;
	obj_ptr = a_obj_ptr;
	entry_ptr = null;
	have_entry_sw = False;
	call get_entry_ptr_and_class;
	call unlock_dir;
	process_auth = pds$access_authorization;
	unspec (process_audit_flags) = pds$audit_flags;

	check_result = check_flags_and_thresholds ();

	call set_meter_index;
	call meter_stop;

	return (check_result);

check_obj_ptr_user:
     entry (a_event_flags, a_oper_code, a_obj_ptr, a_user_auth, a_user_audit_flags)
	returns (bit (1) aligned);

	call meter_start;
	check_sw = True;
	user_entry_sw = True;

	unspec (event_flags) = a_event_flags;
	unspec (oper_code) = a_oper_code;
	have_obj_path_sw = False;
	obj_ptr = a_obj_ptr;
	entry_ptr = null;
	have_entry_sw = False;
	call get_entry_ptr_and_class;
	call unlock_dir;
	process_auth = a_user_auth;
	unspec (process_audit_flags) = a_user_audit_flags;

	check_result = check_flags_and_thresholds ();

	call set_meter_index;
	call meter_stop;

	return (check_result);
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* LOG_AUDIT_MESSAGE - Internal Procedure.					*/
	/*									*/
	/* This routine performs the sequence of calls required to format data for the audit log	*/
	/* entry and actually write the entry.  It is called by all access_audit_$log_*		*/
	/* entrypoints.								*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

log_audit_message:
     procedure ();

	call build_object_info;

	call unlock_dir;				/* finished with looking at entry itself */

	if caller_supplied_text_sw
	then do;
	     call cu_$arg_ptr_rel (control_str_arg_index, caller_text_ptr, caller_text_len, code, arg_list_ptr);
	     if code ^= 0
	     then do;
		call syserr (SYSERR_PRINT_ON_CONSOLE, MSG_Text_Ptr, EntryNames (entrypoint),
		     pds$process_group_id, caller);
dcl     MSG_Text_Ptr	 char (86) int static options (constant)
			 init (
			 "access_audit_$^a: (^a) Unexpected error obtaining caller text pointer.  Caller=""^a"".");
		goto no_caller_text;
	     end;
	     else if caller_text_len = 0		/* null string? */
	     then goto no_caller_text;
	     else if caller_text = ""			/* fixed string of blanks? */
	     then goto no_caller_text;
	     else if n_args > control_str_arg_index	/* caller have optional args? */
	     then do;
		caller_text_ptr = addr (caller_text_buff);
		caller_text_len = length (caller_text_buff);
		call formline_ (control_str_arg_index, control_str_arg_index + 1,
		     caller_text_ptr, caller_text_len, 0, arg_list_ptr);
	     end;
	     else					/* leave ptr and length to caller's argument */
		;
	end;
	else do;					/* caller supplied no text */
no_caller_text:
	     caller_text_ptr = addr (caller_text_buff);	/* just so it's a valid pointer */
	     caller_text_len = 0;
	     caller_supplied_text_sw = False;
	end;

	call form_audit_message_text;

	call form_audit_record_header;

	call write_log_message;

	return;

     end log_audit_message;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* BUILD_OBJECT_INFO - Internal Procedure.					*/
	/*									*/
	/* This routine is used by the access_audit_$log_* entries which deal with storage system	*/
	/* object exclusively.  Its function is to set up the binary info structure with	*/
	/* pertinent information about the segment/directory.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

build_object_info:
     procedure;

	entry_type_str = "";

	if have_entry_sw
	then if entry_ptr ^= null ()
	     then if entry_ptr -> entry.bs
		then do;
		     if entry_ptr -> entry.dirsw
		     then entry_type_str = "directory";
		     else entry_type_str = "segment";

		     audit_ssobj_info_ptr = addr (local_bin_data_area);
		     if size (local_bin_data_area) < size (audit_ssobj_info)
		     then do;
			call syserr (SYSERR_PRINT_ON_CONSOLE, MSG_Alloc_SSObj);
dcl     MSG_Alloc_SSObj	 char (56) int static options (constant)
			 init ("access_audit_: Insufficient room to allocate ssobj data.");
			goto setup_path;
		     end;

/* build ssobj info structure for a seg or dir */
		     unspec (audit_ssobj_info) = ""b;
		     audit_ssobj_info.info_type = AAB_ss_object;
		     call uid_path_util$get (pointer (entry_ptr, 0), audit_ssobj_info.parent_uid_path, code);
		     if code ^= 0
		     then do;
			call syserr (SYSERR_LOG_OR_PRINT, MSG_Dir_UID, EntryNames (entrypoint),
			     pds$process_group_id, segno (entry_ptr), error_text (code), caller);
dcl     MSG_Dir_UID		 char (93) int static options (constant)
			 init (
			 "access_audit_$^a: (^a) Unable to get UID path for directory ^o due to ""^a"".  Caller=""^a""."
			 );
			audit_ssobj_info.parent_uid_path = "0"b;
						/* all invalid */
		     end;
		     audit_ssobj_info.entry_uid = entry_ptr -> entry.uid;
		     audit_ssobj_info.dtem = entry_ptr -> entry.dtem;
		     audit_ssobj_info.access_class = entry_ptr -> entry.access_class;
		     call access_mode$raw (entry_ptr, audit_ssobj_info.raw_mode, audit_ssobj_info.ex_mode, code);
		     if code ^= 0
		     then do;
			call syserr (SYSERR_LOG_OR_PRINT, MSG_Raw_Access, EntryNames (entrypoint),
			     pds$process_group_id, entry_ptr, error_text (code), caller);
dcl     MSG_Raw_Access	 char (97) int static options (constant)
			 init (
			 "access_audit_$^a: (^a) Unable to get raw access modes for entry ^p due to ""^a"".  Caller=""^a""."
			 );
			audit_ssobj_info.raw_mode = "0"b;
			audit_ssobj_info.ex_mode = "0"b;
		     end;
		     audit_ssobj_info.ring_brackets = entry_ptr -> entry.ring_brackets;
		     audit_ssobj_info.ex_ring_brackets = entry_ptr -> entry.ex_ring_brackets;
		     audit_ssobj_info.dirsw = entry_ptr -> entry.dirsw;
		     audit_ssobj_info.per_process_sw = entry_ptr -> entry.per_process_sw;
		     audit_ssobj_info.safety_sw = entry_ptr -> entry.safety_sw;
		     audit_ssobj_info.multiple_class = entry_ptr -> entry.multiple_class;
		     audit_ssobj_info.audit_flag = entry_ptr -> entry.audit_flag;
		     audit_ssobj_info.security_oosw = entry_ptr -> entry.security_oosw;
		     audit_ssobj_info.entrypt_sw = entry_ptr -> entry.entrypt_sw;
		     audit_ssobj_info.master_dir = entry_ptr -> entry.master_dir;
		     audit_ssobj_info.access_class = entry_ptr -> entry.access_class;

		     object_info_valid_sw = True;
		end;
		else do;
		     entry_type_str = "link";

		     audit_link_info_ptr = addr (local_bin_data_area);
		     if size (local_bin_data_area) < size (audit_link_info)
		     then do;
			call syserr (SYSERR_PRINT_ON_CONSOLE, MSG_Alloc_Link);
dcl     MSG_Alloc_Link	 char (55) int static options (constant)
			 init ("access_audit_: Insufficient room to allocate link data.");
			goto setup_path;
		     end;

/* build link info structure */
		     unspec (audit_link_info) = ""b;
		     audit_link_info.info_type = AAB_ss_link;
		     call uid_path_util$get (pointer (entry_ptr, 0), audit_link_info.parent_uid_path, code);
		     if code ^= 0
		     then do;
			call syserr (SYSERR_LOG_OR_PRINT, MSG_Dir_UID, EntryNames (entrypoint),
			     pds$process_group_id, segno (entry_ptr), error_text (code), caller);
			audit_link_info.parent_uid_path = "0"b;
						/* all invalid */
		     end;
		     audit_link_info.entry_uid = entry_ptr -> link.uid;
		     audit_link_info.dtem = entry_ptr -> link.dtem;

		     link_info_valid_sw = True;
		end;
	     else entry_type_str = "directory";		/* root */
	else entry_type_str = "";			/* don't know what it is */

/* set up the textual pathname in char528v (used by form_audit_message_text) */
setup_path:
	if ^have_entry_sw
	then char528v = ">NOENTRY";			/* no entry */
	else if entry_ptr = null
	then char528v = ">";			/* root */
	else do;
						/* first get path of directory */
	     call get_pathname_ (segno (entry_ptr), char528v, code);
	     if code ^= 0
	     then do;
		call syserr (SYSERR_LOG_OR_PRINT, MSG_Gen_Path, EntryNames (entrypoint),
		     pds$process_group_id, entry_ptr, error_text (code), caller);
dcl     MSG_Gen_Path	 char (93) int static options (constant)
			 init (
			 "access_audit_$^a: (^a) Unable to generate path for entry at ^p due to ""^a"".  Caller=""^a""."
			 );
		char528v = ">???";
	     end;
	     else do;
						/* append entry name to path */
		if char528v = ">"			/* avoid ">>foo" */
		then char528v = char528v || rtrim (pointer (entry_ptr, entry_ptr -> entry.name_frp) -> names.name);
		else do;
		     char528v = char528v || ">";
		     char528v = char528v || rtrim (pointer (entry_ptr, entry_ptr -> entry.name_frp) -> names.name);
		end;
	     end;
	end;

	return;

     end build_object_info;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* FORM_AUDIT_MESSAGE_TEXT - Internal Procedure.					*/
	/*									*/
	/* This procedure formats a text message for the audit log.  This message		*/
	/* depends upon which access_audit_$log_* entry was called.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

form_audit_message_text:
     procedure ();

dcl     Default_Ctl_Str	 char (168) static options (constant) init (
			 "Audit (^a): ^[GRANTED^;DENIED^] ^a^[ (^a)^;^s^] for ^a (^a) Level=^d^[ (on behalf of ^a (^a))^;^s^s^]^[ to^[ ^a^;^s^] ^a (^a)^;^s^s^s^s^]^[ <^a>^;^s^].^[ Code=^a^]"
			 );

dcl     class_str		 char (32);
dcl     event_flags_str	 char (100) varying;
dcl     type_str		 char (10);
dcl     user_group_id	 char (32);
dcl     user_auth_str	 char (32) aligned;

	type_str = "";

	if entrypoint = Log_Obj_Path
	     | entrypoint = Log_Obj_Path_User
	     | entrypoint = Log_Entry_Ptr
	     | entrypoint = Log_Obj_Ptr
	     | entrypoint = Log_Entry_Ptr_User
	     | entrypoint = Log_Obj_Ptr_User
	then do;
						/* in this case char528v has already been set by build_object_info */
	     type_str = entry_type_str;
	     if char528v = ">NOENTRY"
	     then class_str = "cannot get entry";
	     else if char528v = ">???"
	     then class_str = "cannot get pathname";
	     else if char528v = ">"
	     then class_str = "root";
	     else class_str = display_access_class_ (obj_class);
	     if entrypoint = Log_Obj_Path
		| entrypoint = Log_Obj_Path_User
	     then char528v = obj_path;		/* use textual path caller supplied */
	end;
	else
	     if entrypoint = Log_Obj_Class
	     | entrypoint = Log_Obj_Class_User
	then do;
	     char528v = obj_name;
	     class_str = display_access_class_ (obj_class);
	end;
	else
	     if entrypoint = Log_Obj_Class_Range
	     | entrypoint = Log_Obj_Class_Range_User
	then do;
	     char528v = obj_name;
	     class_str = display_access_class_$range (obj_class_range);
	end;
	else
	     if entrypoint = Log_General
	     | entrypoint = Log_General_User
	then do;
	     char528v = obj_name;
	     class_str = "no access class";
	end;
	else
	     if entrypoint = Log_No_Process
	then do;
	     char528v = obj_name;
	     class_str = "no access class";
	end;
						/* if entrypoint invalid */
	else do;
	     call syserr (SYSERR_PRINT_ON_CONSOLE, MSG_Illegal_Entry, pds$process_group_id, entrypoint, caller);
dcl     MSG_Illegal_Entry	 char (112) int static options (constant)
			 init (
			 "access_audit_$UNKNOWN: (^a) Illegal entrypoint index ""^d"" detected in form_audit_message_text.  Caller=""^a""."
			 );
	     char528v = "UNKNOWN";
	     class_str = "error in access_audit_";
	end;

	if user_entry_sw
	then do;
	     user_group_id = audit_user_info.user_id;
	     user_auth_str = display_access_class_ (audit_user_info.authorization);
	end;
	else do;
	     user_group_id = "";
	     user_auth_str = "";
	end;

	event_flags_str = "";			/* construct string of event flags */
	do i = 1, 3 to hbound (Short_Event_Names, 1);	/* all flags except "granted" */
	     if substr (string (event_flags), i, 1) = "1"b
	     then do;
		if event_flags_str ^= ""
		then event_flags_str = event_flags_str || ", ";
		event_flags_str = event_flags_str || rtrim (Short_Event_Names (i));
	     end;
	end;

	msg_text_ptr = addr (msg_text_buff);		/* set up based msg_text */
	msg_text_len = length (msg_text_buff);		/* ioa_ will change the length */

	call ioa_$rsnpnnl (Default_Ctl_Str, msg_text_buff, msg_text_len,
	     caller, event_flags.grant, convert_access_operation_ (unspec (oper_code)),
	     (event_flags_str ^= ""), event_flags_str,
	     pds$process_group_id, display_access_class_ (pds$access_authorization), caller_level,
	     user_entry_sw, user_group_id, user_auth_str,
	     (char528v ^= ""), (type_str ^= ""), type_str, char528v, class_str, caller_supplied_text_sw, caller_text,
	     (err_code ^= 0), error_text (err_code));

	return;

     end form_audit_message_text;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* FORM_AUDIT_RECORD_HEADER - Internal Procedure.					*/
	/*									*/
	/* This routine assembles the standard record header for the audit message.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

form_audit_record_header:
     procedure;

/* local_audit_header is the size of audit_record_header_proxy
   which will be sufficient to use as audit_record_header as well */

	unspec (local_audit_header) = ""b;
	audit_record_ptr = addr (local_audit_header);

	if user_entry_sw
	then audit_record_header_proxy.type = ARH_TYPE_PROXY;
	else audit_record_header_proxy.type = ARH_TYPE_NO_PROXY;

	audit_record_header_proxy.version = ACCESS_AUDIT_HEADER_VERSION_3;

	if user_entry_sw
	then do;
						/* copy the proxy user's info */
	     call parse_group_id (audit_user_info.user_id,
		audit_record_header_proxy.person (2), audit_record_header_proxy.project (2),
		audit_record_header_proxy.tag (2));
	     audit_record_header_proxy.ring (2) = audit_user_info.ring;
	     audit_record_header_proxy.anonymous (2) = (substr (audit_user_info.user_id, 1, 9) = "anonymous");
	     audit_record_header_proxy.process_id (2) = audit_user_info.process_id;
	     audit_record_header_proxy.authorization (2) = audit_user_info.authorization;
	     audit_record_header_proxy.subjects (2).authorization_range (*) = audit_user_info.authorization_range (*);
	end;

	if entrypoint = Log_No_Process
	then do;
	     audit_record_header_proxy.subject_is_process = False;
	     call parse_group_id (group_id,
		audit_record_header_proxy.person (1), audit_record_header_proxy.project (1),
		audit_record_header_proxy.tag (1));
	end;
	else do;
	     audit_record_header_proxy.subject_is_process = True;
	     call parse_group_id (pds$process_group_id,
		audit_record_header_proxy.person (1), audit_record_header_proxy.project (1),
		audit_record_header_proxy.tag (1));
	     audit_record_header_proxy.ring (1) = caller_level;
	     audit_record_header_proxy.anonymous (1) = (substr (pds$process_group_id, 1, 9) = "anonymous");
	     audit_record_header_proxy.process_id (1) = pds$process_id;
	     audit_record_header_proxy.authorization (1) = pds$access_authorization;
	     audit_record_header_proxy.subjects (1).authorization_range (1) = sys_info$access_class_floor;
						/* don't know this in hardcore */
	     audit_record_header_proxy.subjects (1).authorization_range (2) = pds$max_access_authorization;
	end;

	audit_record_header_proxy.operation_code = unspec (oper_code);
	audit_record_header_proxy.event_flags = unspec (event_flags);

	return;

parse_group_id:					/* procedure internal to form_audit_record_header */
     procedure (group_id, person, project, tag);

dcl     group_id		 parameter char (32) aligned;
dcl     person		 parameter char (22);
dcl     project		 parameter char (9);
dcl     tag		 parameter char (1);
dcl     l_group_id		 char (32);

	l_group_id = group_id;
	person, project, tag = "";

	i = index (l_group_id, ".");
	if i = 0
	then do;
	     person = substr (l_group_id, 1, length (person));
	     return;
	end;
	else if i > 1
	then person = substr (l_group_id, 1, i - 1);

	l_group_id = substr (l_group_id, i + 1);

	i = index (l_group_id, ".");
	if i = 0
	then do;
	     project = substr (l_group_id, 1, length (project));
	     return;
	end;
	else if i > 1
	then project = substr (l_group_id, 1, i - 1);

	tag = substr (l_group_id, i + 1);

	return;

     end parse_group_id;

     end form_audit_record_header;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* WRITE_LOG_MESSAGE - Internal Procedure.					*/
	/*									*/
	/* This procedure interfaces with the logging software to add an audit message to the	*/
	/* logs.									*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

write_log_message:
     procedure;

dcl     1 bin_info_array	 (3 /* max */) aligned,	/* argument for syserr$multiple_binary */
	2 p		 pointer,
	2 len		 fixed bin;
dcl     n_pieces		 fixed bin;
dcl     syserr_code		 fixed bin;

/* first piece is the header */
	n_pieces = 1;
	p (n_pieces) = addr (audit_record_header);
	if user_entry_sw
	then len (n_pieces) = size (audit_record_header_proxy);
	else len (n_pieces) = size (audit_record_header);

/* next piece is the ssobj or link info, if available */
	if object_info_valid_sw
	then do;
	     n_pieces = n_pieces + 1;
	     p (n_pieces) = addr (audit_ssobj_info);
	     len (n_pieces) = size (audit_ssobj_info);
	end;
	else if link_info_valid_sw
	then do;
	     n_pieces = n_pieces + 1;
	     p (n_pieces) = addr (audit_link_info);
	     len (n_pieces) = size (audit_link_info);
	end;

/* last piece is what the caller supplied, if available */
	if info_ptr ^= null ()
	then do;
	     n_pieces = n_pieces + 1;
	     p (n_pieces) = info_ptr;
	     len (n_pieces) = info_size;
	end;

	syserr_code = SYSERR_LOG_OR_PRINT;
	if event_flags.cc_1_10 | event_flags.cc_10_100
	then syserr_code = syserr_code + SYSERR_COVERT_CHANNEL;
	else if event_flags.grant
	then syserr_code = syserr_code + SYSERR_SUCCESSFUL_ACCESS;
	else syserr_code = syserr_code + SYSERR_UNSUCCESSFUL_ACCESS;

	call syserr$multiple_binary (syserr_code, addr (bin_info_array), n_pieces, SB_access_audit, msg_text);

	return;

     end write_log_message;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* CHECK_FLAGS_AND_THRESHOLDS - Internal Procedure.				*/
	/*									*/
	/* This routine does the actual checking to determine if auditing is necessary.		*/
	/*									*/
	/* The following variables must be set before invocation of this routine:		*/
	/*									*/
	/*		obj_class							*/
	/*		process_auth						*/
	/*		process_audit_flags						*/
	/*		event_flags						*/
	/*		oper_code							*/
	/*		have_entry_sw						*/
	/*		user_entry_sw						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

check_flags_and_thresholds:
     procedure () returns (bit (1) aligned);

dcl     object_index	 fixed bin;
dcl     oper_level		 fixed bin;

/* check to see if object's audit flag is on */

	if have_entry_sw
	then if entry_ptr ^= null ()
	     then if entry_ptr -> entry.bs &
		     entry_ptr -> entry.audit_flag
		then do;
		     if (^entry_ptr -> entry.dirsw &	/* ring-1 object ? */
			unspec (entry_ptr -> entry.ring_brackets (*)) = "111"b3)
		     then do;
			if unspec (oper_code) = access_operations_$mseg_delete |
			     unspec (oper_code) = access_operations_$mseg_open |
			     unspec (oper_code) = access_operations_$mseg_close |
			     unspec (oper_code) = access_operations_$mseg_attr_read |
			     unspec (oper_code) = access_operations_$mseg_attr_mod |
			     unspec (oper_code) = access_operations_$mseg_access_read |
			     unspec (oper_code) = access_operations_$mseg_access_mod |
			     unspec (oper_code) = access_operations_$mseg_accept_wakeups
			then return (True);
			else ;
		     end;
		     else return (True);
		end;

	if event_flags.special_op			/* presently we always log special events */
	then return (True);
	else do;
						/* first check if a covert channel event */

	     if event_flags.cc_1_10 | event_flags.cc_10_100
	     then if sys_info$audit_covert_channel
		then if within_threshold (process_auth, (sys_info$covert_channel_threshold)) | event_flags.receiver
		     then if (event_flags.cc_1_10 & process_audit_flags.cc_1_10)
			     | (event_flags.cc_10_100 & process_audit_flags.cc_10_100)
			then return (True);

/* next, check for admin or privileged operation */

	     if event_flags.admin_op & process_audit_flags.admin_ops
	     then return (True);
	     else ;

	     if event_flags.priv_op & process_audit_flags.priv_ops
	     then return (True);
	     else ;


/* now for the real successful/unsuccessful access type checks */

/* check system wide audit flags */

	     if event_flags.grant
	     then if ^sys_info$audit_successful_access
		then return (False);
		else ;
	     else if ^sys_info$audit_unsuccessful_access
	     then return (False);
	     else ;

/* check thresholds */

	     if event_flags.grant
	     then if ^within_threshold (obj_class, (sys_info$successful_access_threshold))
		then return (False);		/* below threshold */
		else ;
	     else if ^within_threshold (obj_class, (sys_info$unsuccessful_access_threshold))
	     then return (False);
	     else ;

/* finally check the user's audit flags */

	     object_index = oper_code.audit_type.object_type;
	     if object_index < lbound (process_audit_flags.objects, 1)
		| object_index > hbound (process_audit_flags.objects, 1)
	     then do;
						/* some events may legally be associated with no type of object */
		if (event_flags.cc_1_10 | event_flags.cc_10_100 | event_flags.priv_op | event_flags.admin_op)
		then return (False);
		else do;
		     call syserr (SYSERR_PRINT_ON_CONSOLE, MSG_Parm_Combo, EntryNames (entrypoint),
			pds$process_group_id, unspec (oper_code), string (event_flags), ^check_sw, caller);
dcl     MSG_Parm_Combo	 char (118) int static options (constant)
			 init (
			 "access_audit_$^a: (^a) Encountered illegal parameter combination.  OperCode=^w  EventFlags=^w.^[  Caller=""^a"".^;^s^]"
			 );
		     return (True);			/* audit for usefulness in debugging */
		end;
	     end;

	     oper_level = oper_code.audit_type.access_type;
						/* all 2-bit combos OK */

	     if event_flags.grant
	     then if process_audit_flags.objects (object_index).grant_level >= oper_level
		then return (True);
		else return (False);
	     else if process_audit_flags.objects (object_index).deny_level >= oper_level
	     then return (True);
	     else return (False);

	end;


within_threshold:
     proc (test, thresh) returns (bit (1) aligned);
						/* procedure internal to check_flags and thresholds
						   used to compare a test class/auth against a given threshold */
dcl     test		 bit (72) aligned parameter;
dcl     thresh		 bit (72) aligned parameter;

	if addr (test) -> aim_template.level >= addr (thresh) -> aim_template.level
	then return (True);
	else if (addr (test) -> aim_template.categories & addr (thresh) -> aim_template.categories)
	then return (True);
	else return (False);

     end within_threshold;

     end check_flags_and_thresholds;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* GET_ENTRY_PTR_AND_CLASS - Internal Procedure.					*/
	/*									*/
	/* Routine to obtain a pointer to the directory entry of a storage system object given a	*/
	/* pointer to that object and the access class of that object.  This routine will set the	*/
	/* global switch "locked_dir" if it was necessary to lock the directory.  The caller will	*/
	/* call "unlock_dir" if the switch is set and all operations are complete.  (Most callers	*/
	/* of the log_obj_ptr and log_entry_ptr entrypoints already have the directory locked).	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

get_entry_ptr_and_class:
     procedure ();

	called_dc_find = False;
	locked_dir = False;

	obj_class = sys_info$access_class_ceiling;	/* assume worst case */

	if rel (entry_ptr) = "0"b
	then do;
						/* assume entry_ptr arg was actually the obj_ptr */
	     obj_ptr = entry_ptr;
	     have_entry_sw = False;
	end;

	if have_entry_sw				/* caller supplied entry ptr? */
	then ;					/* we have nothing to do... */
	else if obj_ptr ^= null			/* caller supplied object ptr? */
	then do;
	     if segno (obj_ptr) <= active_all_rings_data$hcscnt
	     then obj_class = sys_info$access_class_floor;/* no entry */
	     else do;
						/* we'll make an entry pointer ourselves and maybe lock the dir */
		call sum$getbranch_root_my (pointer (obj_ptr, 0), "0"b, entry_ptr, code);
		if code = error_table_$mylock
		then code = 0;
		else if code = error_table_$root
		then code = 0;
		else if code = error_table_$noentry | code = error_table_$invalidsegno
		then ;				/* let these by... */
		else if code ^= 0
		then do;
		     call syserr (SYSERR_LOG_OR_PRINT, MSG_Entry_Ptr, EntryNames (entrypoint),
			pds$process_group_id, segno (obj_ptr), error_text (code));
dcl     MSG_Entry_Ptr	 char (76) int static options (constant)
			 init ("access_audit_$^a: (^a) Unable to get entry pointer for seg ^o due to ""^a"".");
		     return;
		end;
		else locked_dir = True;		/* we locked it, remember to unlock it later */

		have_entry_sw = (code = 0);
	     end;
	end;
	else if have_obj_path_sw			/* caller supplied object path? */
	then do;					/* get entry pointer from pathname */
	     call dc_find$obj_for_audit (obj_path, "", entry_ptr, code);
	     if code = error_table_$root		/* shouldn't get mylock */
	     then code = 0;
	     else if code = error_table_$noentry | code = error_table_$no_dir
	     then ;				/* let these by... */
	     else if code ^= 0
	     then do;
		call syserr (SYSERR_LOG_OR_PRINT, MSG_Entry_Ptr_Path, EntryNames (entrypoint),
		     pds$process_group_id, obj_path, error_text (code));
dcl     MSG_Entry_Ptr_Path	 char (80) int static options (constant)
			 init ("access_audit_$^a: (^a) Unable to get entry pointer for seg ""^a"" due to ""^a"".");
		return;
	     end;
	     else do;
		called_dc_find = True;
		locked_dir = True;
	     end;

	     have_entry_sw = (code = 0);
	end;
	else do;					/* caller supplied nothing? */
	     call syserr (SYSERR_PRINT_ON_CONSOLE, MSG_Improper_Call, EntryNames (entrypoint), pds$process_group_id,
		^check_sw, caller)
		;
dcl     MSG_Improper_Call	 char (108) int static options (constant)
			 init (
			 "access_audit_$^a: (^a) Improper calling sequence (from ""get_entry_ptr_and_class"").^[  Caller=""^a"".^;^s^]"
			 );
	end;

	if have_entry_sw
	then if entry_ptr ^= null ()
	     then if entry_ptr -> entry.bs
		then obj_class = entry_ptr -> entry.access_class;
		else obj_class = pointer (entry_ptr, "0"b) -> dir.access_class;
						/* it's a link */
	     else obj_class = sys_info$access_class_floor;/* it's the root directory */

	return;

     end get_entry_ptr_and_class;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* UNLOCK_DIR - Internal Procedure.						*/
	/*									*/
	/* This routine unlocks the directory if access_audit_ locked it.			*/
	/*									*/
	/* The switches "called_dc_find" and "locked_dir" are set by get_entry_ptr_and_class.	*/
	/* However, the $log_* entries may end up calling here before get_entry_ptr_and_class	*/
	/* has been executed.  Therefore, setup_log_entry sets these both to False.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

unlock_dir:
     procedure ();

	if called_dc_find
	then call dc_find$finished (pointer (entry_ptr, 0), locked_dir);
	else if locked_dir
	then call lock$dir_unlock (pointer (entry_ptr, 0));

	locked_dir = False;				/* so we don't try it again */
	called_dc_find = False;

	return;

     end unlock_dir;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* ERROR_TEXT - Internal Procedure.						*/
	/*									*/
	/* Procedure to return the short error message mnemonic associated with an error_table_	*/
	/* entry.									*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

error_text:
     procedure (ec) returns (char (100) aligned);

dcl     ec		 parameter fixed bin (35);

dcl     char8		 char (8) aligned;
dcl     char100		 char (100) aligned;

	call convert_status_code_ (ec, char8, char100);

	return (char100);

     end error_text;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* METER_START - Internal Procedure.						*/
	/*									*/
	/* Initializes the meter variables.						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

meter_start:
     procedure;

	call usage_values (initial_pagefaults, initial_cpu);

	return;

     end meter_start;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* METER_STOP - Internal Procedure.						*/
	/*									*/
	/* Compute resource usage since "meter_start" was invoked.  Add into appropriate meter	*/
	/* bucket.								*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

meter_stop:
     procedure;

dcl     final_cpu		 fixed bin (71);
dcl     final_pagefaults	 fixed bin;

	active_hardcore_data$access_audit_count (meter_index) =
	     active_hardcore_data$access_audit_count (meter_index) + 1;

	if check_sw
	then active_hardcore_data$access_audit_check_count (meter_index) =
		active_hardcore_data$access_audit_check_count (meter_index) + 1;

	call usage_values (final_pagefaults, final_cpu);

	active_hardcore_data$access_audit_cpu_time (meter_index) =
	     active_hardcore_data$access_audit_cpu_time (meter_index) + (final_cpu - initial_cpu);
	active_hardcore_data$access_audit_pagefaults (meter_index) =
	     active_hardcore_data$access_audit_pagefaults (meter_index) + (final_pagefaults - initial_pagefaults);

	return;

     end meter_stop;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* SETUP_LOG_ENTRY - Internal Procedure.	(Used by logging entries only)	*/
	/* SET_METER_INDEX - Internal Entry.	(Used check_* entries)			*/
	/*									*/
	/* 1. Set up global variables.						*/
	/* 2. Check that proper number of arguments have been supplied.			*/
	/* 3. Copy args.								*/
	/* 4. Set up metering bucket index.						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

setup_log_entry:
     proc (a_entrypoint, a_args_needed);

dcl     a_entrypoint	 fixed bin parameter;
dcl     a_args_needed	 fixed bin parameter;

/* Set up global variables */

	entrypoint = a_entrypoint;			/* set global variable */
	control_str_arg_index = a_args_needed + 1;	/* tells formline_ where the control string is */
	caller_supplied_text_sw = (control_str_arg_index <= n_args);

	check_sw = False;
	object_info_valid_sw = False;
	link_info_valid_sw = False;
	have_entry_sw = False;			/* assume no ptr to object's dir entry */
	have_obj_path_sw = False;

	locked_dir = False;
	called_dc_find = False;
	obj_ptr = null ();
	entry_ptr = null ();
	obj_class = sys_info$access_class_ceiling;

/* Check number of arguments */

	if n_args < a_args_needed
	then do;
	     if n_args > 0				/* have "caller" ? */
	     then caller = a_caller;
	     else caller = "";
	     call syserr (SYSERR_PRINT_ON_CONSOLE, MSG_Insuff_Args, EntryNames (entrypoint),
		pds$process_group_id, n_args, (n_args > 0), caller);
dcl     MSG_Insuff_Args	 char (94) int static options (constant)
			 init (
			 "access_audit_$^a: (^a) Called with insufficient arguments (#args= ^d).^[  Caller=""^a"".^;^s^]"
			 );
	     goto ERROR_EXIT;
	end;

/* Copy args */

	caller = a_caller;
	caller_level = max (a_caller_level, level$get ());
	unspec (event_flags) = a_event_flags;
	unspec (oper_code) = a_oper_code;
	err_code = a_err_code;
	info_ptr = a_info_ptr;
	info_size = a_info_size;
						/* binary info structure is copied by write_log_message */

	if entrypoint = Log_General_User
	     | entrypoint = Log_Obj_Class_Range_User
	     | entrypoint = Log_Obj_Class_User
	     | entrypoint = Log_Obj_Path_User
	     | entrypoint = Log_Obj_Ptr_User
	     | entrypoint = Log_Entry_Ptr_User
	then do;
	     user_entry_sw = True;
	     audit_user_info_ptr = a_user_info_ptr;
	     user_info = audit_user_info;		/* copy the structure */
	     audit_user_info_ptr = addr (user_info);	/* now we'll ref local copy */
	end;
	else user_entry_sw = False;

/* message text string and other optional args are copied by formline_ */

/* individual entry is responsible for copying a_group_id, a_obj_name, a_obj_class,
   a_obj_class_range, a_obj_path, a_obj_ptr, or a_entry_ptr as appropriate */


/* set up input to audit flag/threshold check, "obj_class" must
   be set up by the individual entry */
	if user_entry_sw
	then do;
	     process_auth = audit_user_info.authorization;
	     unspec (process_audit_flags) = audit_user_info.audit_flags;
	end;
	else do;
	     process_auth = pds$access_authorization;
	     unspec (process_audit_flags) = pds$audit_flags;
	end;


/* Set up meter bucket index */

set_meter_index:
     entry ();

/* first check to see if we're auditing on a specific event */
	i = n_audit_objects * 2 * n_audit_access_types;
						/* if entrypoint = Log_Fault then meter_index = i + FAULTS_AUDIT_FLAG_INDEX; (see access_audit_log_fault_) */
	if event_flags.admin_op
	then meter_index = i + ADMIN_OP_AUDIT_FLAG_INDEX;
	else if event_flags.priv_op
	then meter_index = i + PRIV_OP_AUDIT_FLAG_INDEX;
	else if event_flags.cc_1_10
	then meter_index = i + CC_1_10_AUDIT_FLAG_INDEX;
	else if event_flags.cc_10_100
	then meter_index = i + CC_10_100_AUDIT_FLAG_INDEX;

	else					/* we're auditing on object type */
	     if oper_code.audit_type.object_type < lbound (process_audit_flags.objects, 1)
	     | oper_code.audit_type.object_type > hbound (process_audit_flags.objects, 1)
	     | oper_code.audit_type.access_type < 1	/* 0 allowed only for admin, priv, and covert channel events */
						/* |  oper_code.audit_type.access_type > n_audit_access_types (can't happen) */
	then goto ILLEGAL_INDEX;
	else do;
	     meter_index = (oper_code.audit_type.object_type - 1) * 2 * n_audit_access_types
		+ oper_code.audit_type.access_type;
	     if ^event_flags.grant
	     then meter_index = meter_index + n_audit_access_types;
	end;

	if meter_index >= active_hardcore_data$access_audit_num_meters
	then do;
ILLEGAL_INDEX:
	     call syserr (SYSERR_LOG_OR_PRINT, MSG_Meter_Index, EntryNames (entrypoint),
		pds$process_group_id, unspec (oper_code), string (event_flags), ^check_sw, caller);
dcl     MSG_Meter_Index	 char (108) int static options (constant)
			 init (
			 "access_audit_$^a: (^a) Encountered illegal meter index.  OperCode=^w  EventFlags=^w.^[  Caller=""^a"".^;^s^]"
			 );
	     meter_index = active_hardcore_data$access_audit_num_meters;
	end;

     end setup_log_entry;

ERROR_EXIT:
	return;

/* format: off */
%page; %include access_audit_flags;
%page; %include access_audit_eventflags;
%page; %include access_audit_encoded_op;
%page; %include access_audit_bin_header;
%page; %include access_audit_binary_def;
%page; %include access_audit_user_info;
%page; %include access_audit_ssobj_info;
%page; %include access_audit_names;
%page; %include aim_template;
%page; %include dir_header;
%page; %include dir_entry;
%page; %include dir_link;
%page; %include dir_name;
%page; %include syserr_constants;
%page; %include syserr_binary_def;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   access_audit_$ENTRY: (USER_ID) Unexpected error obtaining caller text pointer.  Caller="CALLING_PROC".

   S:	$info

   T:	$run

   M:	$err
   An error exists in the calling sequence to access_audit_.

   A:	$notify


   Message:
   access_audit_$ENTRY: (USER_ID) Encountered illegal meter index.  OperCode=XXXXXXXXXXXX  EventFlags=YYYYYYYYYYYY.(  Caller="CALLING_PROC".)

   S:	$log

   T:	$run

   M:	$err
   The access audit meters in active_hardcore_data are inconsistant
   with the format of the process access flags or the supplied
   operation code and/or event flags.

   A:	$notify


   Message:
   access_audit_$ENTRY: (USER_ID) Unable to get entry pointer for seg [#N | PATH] due to "MESSAGE".

   S:	$log

   T:	$run

   M:	$err
   A call to sum$getbranch_root_my or dc_find$obj_for_audit returned
   an unexpected error code.

   A:	$notify


   Message:
   access_audit_$ENTRY: (USER_ID) Unable to generate path for entry at PTR due to "MESSAGE".  Caller="CALLING_PROC".

   S:	$log

   T:	$run

   M:	$err
   A call to get_pathname_ returned an unexpected error code.

   A:	$notify


   Message:
   access_audit_: Insufficient room to allocate [ssobj|link] data.

   S:	$info

   T:	$run

   M:	$err
   An automatic data area is too small to accomodate the storage
   system object or link binary info.

   A:	$notify


   Message:
   access_audit_$ENTRY: (USER_ID) Unable to get UID path for directory seg #N due to "MESSAGE".   Caller="CALLER_PROC".

   S:	$log

   T:	$run

   M:	$err
   Although  the directory is locked, a failure occurred in
   uid_path_util$get.

   A:	$notify


   Message:
   access_audit_$ENTRY: (USER_ID) Unable to get raw access modes for entry PTR due to "MESSAGE".  Caller="CALLER_PROC".

   S:	$log

   T:	$run

   M:	$err
   Although the directory is locked a failure occurred in
   access_mode$raw.

   A:	$notify


   Message:
   access_audit_$UNKNOWN: (USER_ID) Illegal entrypoint index "N" detected in form_audit_message_text.  Caller="CALLING_PROC".

   S:	$info

   T:	$run

   M:	$err
   There is a coding error in access_audit_ where the entrypoint index
   is uninitialized or set to an incorrect value.

   A:	$notify
   

   Message:
   access_audit_$ENTRY: (USER_ID) Encountered illegal parameter combination.  OperCode=XXXXXXXXXXXX  EventFlags=YYYYYYYYYYYY.(  Caller="CALLING_PROC".)

   S:	$info

   T:	$run

   M:	$err
   There is an error in the access_operations_ entry or the eventflags
   passed to access audit.  The error was detected in the code which
   decides whether the caller needs to audit its event.  Because of
   the error, the event will be audited regardless of the process
   audit flags.

   A:	$notify


   Message:
   access_audit_$ENTRY: (USER_ID) Improper calling sequence (from "get_entry_pointer_and_class").  Caller="CALLING_PROC".

   S:	$info

   T:	$run

   M:	$err
   The entry was called with an improper argument combination.
   Most likely the entry will be (log check)_obj_ptr_(user) and
   the obj_ptr supplied will be null.

   A:	$notify


   Message:
   access_audit_$ENTRY: (USER_ID) Called with insufficient arguments (#args= ^d).(  Caller=""CALLING_PROC".)

   S:	$info

   T:	$run

   M:	$err
   access_audit_ was invoked with an improper calling sequence.  There
   may have been enough arguments to display the offending caller name.

   A:	$notify


   END MESSAGE DOCUMENTATION */

end access_audit_;




		    access_audit_check_ep_.alm      11/11/89  1103.7rew 11/11/89  0806.8       68616





" HISTORY COMMENTS:
"  1) change(88-05-17,Fawcett), approve(88-05-02,MCR7881),
"     audit(88-06-21,Farley), install(88-08-02,MR12.2-1074):
"     This change implements the always audit entry changes. As soon as we see
"     that we have an entry (entry pointer non-null), the entry.audit_flag
"     switch is checked. If on, return true. This is valid for directories,
"     segments and links (if the switch could be set for links).
"  2) change(88-08-08,Farley), approve(88-08-08,PBF7881),
"     audit(88-08-09,Martinson), install(88-08-09,MR12.2-1084):
"     Changed always audit to exclude links and ring-1 objects.  The
"     entry.audit_flag is not valid for links and ring-1 objects will be
"     selectively audited by the ring-1 controlling programs..
"                                                      END HISTORY COMMENTS


	name	access_audit_check_ep_
	entry	self
	entry	user

" Hand coded version of access_audit_$check_entry_(ptr ptr_user).
" Keith Loepere, March 1985, from access_audit_, Ed Sharpe.
" Removed extra auditing for ring 1 ops by same, April 1985.
"
" call access_audit_check_ep_$self (event_flags, oper_code, entry_ptr) 
"	returns (bit (1) aligned);
"
" call access_audit_check_ep_$user (event_flags, oper_code, entry_ptr, 
"	process_auth, process_audit_flags) returns (bit (1) aligned);
"
" dcl  entry_ptr			ptr parameter;
" dcl  event_flags			bit (36) aligned parameter;
" dcl  oper_code			bit (36) aligned parameter;
" dcl  process_audit_flags		bit (36) aligned parameter;
" dcl  process_auth			bit (72) aligned parameter;
"
	include	access_audit_encoded_op
"
	include	access_audit_eventflags
"
	include	access_audit_flags
"
	include	aim_template
"
	include	dir_entry
"
	include	dir_header
"
	equ	a_event_flags,2
	equ	a_oper_code,4
	equ	a_entry_ptr,6
	equ	a_process_auth,8
	equ	a_process_audit_flags,10

	equ	entry_ptr,1		" pr1 -> entry
	equ	dir_ptr,2			" pr2 -> dir (for link only)
	equ	event_flags,1		" x1 = event_flags
	equ	work,3			" x3 - work reg
	equ	tcb_obj,4			" x4 ^= 0 => tcb object
	equ	process_audit_flags_dl,5	" x5 = special audit flags
"					  x7 = return arg offset
	tempd	obj_class
	tempd	process_auth
	temp	oper_code
	temp	process_audit_flags

	macro	within_threshold
	lda	&1+aim_template.categories
	ana	&2+aim_template.categories
	tnz	4,ic			" categories in common
	ldx	work,&2+aim_template.level
	sbx	work,&1+aim_template.level
	tmi	&3			" >= level
	&end
"
user:	push
	eax7	a_process_audit_flags+2	" place for return arg

	epp1	ap|a_process_auth,*		" process_auth
	lda	pr1|0
	ldq	pr1|1
	staq	process_auth

	lda	ap|a_process_audit_flags,*	" process_audit_flags

	tra	join

self:	push
	eax7	a_entry_ptr+2		" place for return arg

	ldaq	pds$access_authorization	" process_auth
	staq	process_auth

	lda	pds$audit_flags		" process_audit_flags

join:	sta	process_audit_flags
	eax	process_audit_flags_dl,0,al

	ldx	event_flags,ap|a_event_flags,* " event_flags

	lda	ap|a_oper_code,*		" oper_code
	sta	oper_code

	epp	entry_ptr,ap|a_entry_ptr,*	" entry_ptr
	epp	entry_ptr,entry_ptr|0,*

	eax	tcb_obj,0			" assume not TCB object
	epaq	entry_ptr|0		" find obj_class
	arl	18
	cmpa	=o77777,dl		" null ptr?
	tnz	have_entry
	ldaq	sys_info$access_class_floor	" root
	tra	have_class
have_entry:
	szn	entry_ptr|entry.bs_word	" else need to look deeper
	tmi	have_branch
	epbp	dir_ptr,entry_ptr|0		" link, get class from dir
	lda	dir_ptr|dir.access_class
	ldq	dir_ptr|dir.access_class+1
	tra	have_class
have_branch:
	szn	pds$no_audit_ring1_fs_object_ops " ring 1 - get ring brackets
	tze	get_class

	szn	entry_ptr|entry.dirsw_word
	tmi	get_class			" dirs aren't ring 1 objects

	lda	entry_ptr|entry.ring_brackets_word
	arl	entry.ring_brackets_shift-6	" rb (3)
	ana	entry.ring_brackets_mask,dl
	cmpa	1,dl			" all rbs <= 1
	tpnz	get_class
	eax	tcb_obj,1			" object is being audited by ring 1
	
get_class:
	lda	entry_ptr|entry.access_class	" get class from entry
	ldq	entry_ptr|entry.access_class+1

have_class:
	staq	obj_class
"
" With setup done, start considering the special cases.

	canx	event_flags,audit_event_flags.special_op,du
	tnz	return_true

" covert channel?

	canx	event_flags,audit_event_flags.cc_1_10+audit_event_flags.cc_10_100,du
	tze	not_covert
	szn	sys_info$audit_covert_channel
	tze	not_covert

	canx	event_flags,audit_event_flags.receiver,du
	tnz	covert			" always audit receivers
	within_threshold	sys_info$covert_channel_threshold,process_auth,not_covert

covert:	canx	event_flags,audit_event_flags.cc_1_10,du
	tze	large_cc
	canx	process_audit_flags_dl,audit_flags.cc_1_10,du
	tnz	return_true
	tra	not_covert
large_cc:
	canx	process_audit_flags_dl,audit_flags.cc_10_100,du
	tnz	return_true

" admin, priv?

not_covert:
	canx	event_flags,audit_event_flags.admin_op,du
	tze	not_admin
	canx	process_audit_flags_dl,audit_flags.admin_ops,du
	tnz	return_true

not_admin:
	canx	event_flags,audit_event_flags.priv_op,du
	tze	not_priv
	canx	process_audit_flags_dl,audit_flags.priv_ops,du
	tnz	return_true

" now we check to see if this is a ring 1 operation that needs no audit
" by virtue of the in TCB flag

not_priv:
	eax	tcb_obj,0,tcb_obj		" set indicators
	tze	not_ring_1
	canx	event_flags,audit_event_flags.priv_op+audit_event_flags.admin_op,du
	tnz	not_ring_1		" must see admin/priv ops
	tra	return_false		" else will be audited by ring 1

" now we check to see if this is an entry whose always audit flag is on,
" this does not include links..

not_ring_1:
	epaq	entry_ptr|0		" check for valid entry_ptr
	arl	18
	cmpa	=o77777,dl
	tze	not_always_audit		" skip check if null
	szn	entry_ptr|entry.bs_word	" check branch switch
	tpl	not_always_audit		" exclude links from check
          lda	entry_ptr|entry.audit_flag_word " check audit by entry flag
	cana      entry.audit_flag,du
	tze	not_always_audit		" skip if flag is off
	lda	entry_ptr|entry.ring_brackets_word
	arl	entry.ring_brackets_shift-6	" rb (3)
	cmpa	=o000111,dl		" all rbs = 1
	tnz	return_true		" audit if not ring-1 object

" now for the real successful/unsuccessful access type checks

not_always_audit:
	canx	event_flags,audit_event_flags.grant,du
	tze	check_system_deny

	szn	sys_info$audit_successful_access
	tze	return_false
	within_threshold	sys_info$successful_access_threshold,obj_class,return_false
	tra	check_op_code		" within threshold

check_system_deny:
	szn	sys_info$audit_unsuccessful_access
	tze	return_false
	within_threshold	sys_info$unsuccessful_access_threshold,obj_class,return_false

" finally check the user's audit flags */

check_op_code:
	lda	oper_code
	lrl	access_op.object_type_shift
	qrl	36-(access_op.object_type_shift-access_op.access_type_shift)
	llr	36			" swap a/q
	ana	access_op.access_type_mask,dl	" oper_level in al
	sta	oper_code			" save it
	anq	access_op.object_type_mask,dl	" object_index in ql
	tpnz	check_audit		" some cases allow no object

	canx	event_flags,audit_event_flags.cc_1_10+audit_event_flags.cc_10_100+audit_event_flags.priv_op+audit_event_flags.admin_op,du
	tnz	return_false

check_audit:
	mpy	2*audit_flags.grant_or_deny_shift,dl " size (grant_level) + size (deny_level) times
	eax	work,-2*audit_flags.grant_or_deny_shift,ql " (object_type - 1)
	canx	event_flags,audit_event_flags.grant,du
	tnz	2,ic
	eax	work,audit_flags.grant_or_deny_shift,work " extra shift to get deny level

	lda	process_audit_flags
	als	36-(audit_flags.grant_deny_shift+2*audit_flags.grant_or_deny_shift),work
	arl	36-audit_flags.grant_or_deny_shift " grant/deny level into al
	cmpa	oper_code			" process grant/deny level
	tpl	return_true		" >= oper_code.oper_level

return_false:
	stz	ap|0,x7*
	return

return_true:
	lda	=o400000,du
	sta	ap|0,x7*
	return
	end




		    access_audit_log_fault_.pl1     11/11/89  1103.7rew 11/11/89  0806.0      298926



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



/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1056):
     Correct error message documentation.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,linecom,indcomtxt,^inddcls,^indnoniterdo */

access_audit_log_fault_:
log_fault:
     procedure (a_mc_ptr);

/* format: off */
/******
     Revisions:
     1985-04-08 KP Loepere - use fs_modes at all times for effective modes.
     1985-03-04 EJ Sharpe - remove national chars, select proper sorting class for messages
     1985-01-22 EJ Sharpe - changes per code audit, reformat
     1985-01-13 EJ Sharpe - added message documentation, fixed some msgs
     1985-01-11 EJ Sharpe - fixed dir unlocking oversight
     1985-01-07 EJ Sharpe - extracted from access_audit_
******/


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* ACCESS_AUDIT_LOG_FAULT_							*/
	/*									*/
	/* This module performs auditing on behalf of fim.  fim performs inspection of the	*/
	/* audit flags.  If faults are being audited, this routine is called to log the event.	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */


/*	PARAMETERS	*/

dcl     a_mc_ptr		 parameter pointer;		/* pointer to machine conditions */


/*	CONSTANTS		*/

dcl     True		 bit (1) aligned int static options (constant) init ("1"b);
dcl     False		 bit (1) aligned int static options (constant) init ("0"b);
dcl     PROC_SEG		 fixed bin int static options (constant) init (1);
dcl     DATA_SEG		 fixed bin int static options (constant) init (2);


/*	AUTOMATIC		*/

dcl     code		 fixed bin (35);		/* err code returned from entries we call */
dcl     entry_ptr		 pointer;			/* pointer to object dir entry */
dcl     1 event_flags	 aligned like audit_event_flags;
						/* for log data */
dcl     final_cpu		 fixed bin (71);		/* for metering */
dcl     final_pagefaults	 fixed bin;		/* for metering */
dcl     have_entry_sw	 bit (1) aligned;		/* indicates we have a ptr to a dir entry */
dcl     i			 fixed bin;		/* index */
dcl     initial_cpu		 fixed bin (71);		/* for metering */
dcl     initial_pagefaults	 fixed bin;		/* for metering */
dcl     1 local_audit_header	 aligned like audit_record_header;
						/* binary data header format */
dcl     1 local_ssobj_info	 aligned like audit_ssobj_info;
						/* extended binary data format */
dcl     locked_dir		 bit (1) aligned;		/* flag indicating that we've locked the directory */
dcl     object_info_valid_sw	 bit (1) aligned;		/* indicates that ssobj can be put in log */
dcl     oper_code		 bit (36) aligned;		/* encoded operation */
dcl     msg_text_buff	 char (512) aligned;	/* ioa_$rsnpnnl assembles the text message here */
						/* 512 chars is all syserr will use... */
dcl     msg_text_len	 fixed bin (21);		/* length of text */
dcl     msg_text_ptr	 pointer;			/* ptr to msg_text_buff */


/*	BASED		*/

dcl     msg_text		 char (msg_text_len) based (msg_text_ptr);
						/* the part of msg_text_buff that ioa_$rsnpnnl set up */


/*	MISCELLANEOUS	*/

dcl     addr		 builtin;
dcl     baseptr		 builtin;
dcl     fixed		 builtin;
dcl     index		 builtin;
dcl     length		 builtin;
dcl     min		 builtin;
dcl     null		 builtin;
dcl     pointer		 builtin;
dcl     rtrim		 builtin;
dcl     segno		 builtin;
dcl     size		 builtin;
dcl     string		 builtin;
dcl     substr		 builtin;
dcl     unspec		 builtin;


/*	EXTERNAL		*/

dcl     access_operations_$fault_ipr
			 bit (36) aligned external;
dcl     access_operations_$fault_acv_mode
			 bit (36) aligned external;
dcl     access_operations_$fault_acv_ring
			 bit (36) aligned external;
dcl     active_all_rings_data$hcscnt
			 fixed bin external;

/* Note - The next four externals hold the access audit metering data. */
/*	active_hardcore_data$access_audit_num_meters" is set to the dimension. */
/*        This value is (n_audit_objects*2*n_audit_access_types) + n_audit_events + 1. */
dcl     active_hardcore_data$access_audit_num_meters
			 fixed bin external;
dcl     active_hardcore_data$access_audit_count
			 (1) fixed bin (35) external;
dcl     active_hardcore_data$access_audit_check_count
			 (1) fixed bin (35) external;
dcl     active_hardcore_data$access_audit_cpu_time
			 (1) fixed bin (71) external;
dcl     active_hardcore_data$access_audit_pagefaults
			 (1) fixed bin (35) external;

dcl     dseg$		 external;
dcl     error_table_$invalidsegno
			 fixed bin (35) external;
dcl     error_table_$mylock	 fixed bin (35) external;
dcl     error_table_$noentry	 fixed bin (35) external;
dcl     error_table_$root	 fixed bin (35) external;
dcl     pds$access_authorization
			 bit (72) aligned external;
dcl     pds$block_lock_count	 fixed bin external;
dcl     pds$max_access_authorization
			 bit (72) aligned external;
dcl     pds$process_group_id	 char (32) aligned external;
dcl     pds$process_id	 bit (36) aligned external;
dcl     slt$		 external;
dcl     sys_info$access_class_floor
			 bit (72) aligned external;


/*	ENTRIES		*/

dcl     access_mode$raw	 entry (pointer, bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl     display_access_class_	 entry (bit (72) aligned) returns (char (32) aligned);
dcl     convert_access_operation_
			 entry (bit (36) aligned) returns (char (50));
dcl     convert_status_code_	 entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl     get_pathname_	 entry (fixed bin (17), char (*) varying, fixed bin (35));
dcl     fs_modes$locked	 entry (pointer, bit (36) aligned, bit (36) aligned,
			 dim (3) fixed bin (3), fixed bin (35));
dcl     fs_get$ref_name	 entry (pointer, fixed bin, char (*), fixed bin (35));
dcl     ioa_$rsnpnnl	 entry options (variable);
dcl     level$get		 entry () returns (fixed bin);
dcl     lock$dir_unlock	 entry (pointer);
dcl     sum$getbranch_root_my	 entry (pointer, bit (36) aligned, pointer, fixed bin (35));
dcl     syserr		 entry options (variable);
dcl     syserr$binary	 entry options (variable);
dcl     syserr$multiple_binary entry options (variable);
dcl     usage_values	 entry (fixed bin, fixed bin (71));
dcl     uid_path_util$get	 entry (ptr, dim (0:15) bit (36) aligned, fixed bin (35));
%page;


/* MAIN CODE */

	call usage_values (initial_pagefaults, initial_cpu);

/* setup */
	object_info_valid_sw = False;
	msg_text_len = length (msg_text_buff);
	msg_text_ptr = addr (msg_text_buff);
	unspec (event_flags) = "0"b;
	unspec (oper_code) = "0"b;
	mcp = a_mc_ptr;				/* copy arg */
	locked_dir = False;

	call interpret_machine_conditions;

	call build_object_info;

	if locked_dir
	then do;					/* we're done with it */
	     call lock$dir_unlock (pointer (entry_ptr, 0));
	     locked_dir = False;
	end;

	call form_audit_record_header;

	call write_log_message;

/* finish meter */
	i = n_audit_objects * 2 * n_audit_access_types + FAULTS_AUDIT_FLAG_INDEX;
						/* see access_audit_ for other indexes */
	if i >= active_hardcore_data$access_audit_num_meters
	then do;
	     call syserr (SYSERR_LOG_OR_PRINT, MSG_Meter_Index, pds$process_group_id);
dcl     MSG_Meter_Index	 char (68) int static options (constant)
			 init ("access_audit_log_fault_: (^a) Encountered illegal meter index value.");
	     i = active_hardcore_data$access_audit_num_meters;
	end;

	call usage_values (final_pagefaults, final_cpu);
	active_hardcore_data$access_audit_count (i) = active_hardcore_data$access_audit_count (i) + 1;
	active_hardcore_data$access_audit_cpu_time (i) =
	     active_hardcore_data$access_audit_cpu_time (i) + (final_cpu - initial_cpu);
	active_hardcore_data$access_audit_pagefaults (i) =
	     active_hardcore_data$access_audit_pagefaults (i) + (final_pagefaults - initial_pagefaults);

	return;


LOG_FAULT_EXIT:					/* error exit */
	if locked_dir
	then do;
	     call lock$dir_unlock (pointer (entry_ptr, 0));
	     locked_dir = False;
	end;

	return;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* INTERPRET_MACHINE_CONDITIONS - Internal Procedure.				*/
	/*									*/
	/* This procedure is called only be the $log_fault entry to extract the needed		*/
	/* information out of the machine conditions structure.				*/
	/*									*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

interpret_machine_conditions:
     procedure;

dcl     proc_seg_no		 fixed bin;
dcl     proc_seg_offset	 fixed bin (18);
dcl     proc_seg_path	 char (528) var;
dcl     proc_seg_class	 char (32);
dcl     proc_is_slt_seg	 bit (1) aligned;
dcl     proc_path_ok	 bit (1) aligned;
dcl     data_seg_no		 fixed bin;
dcl     data_seg_offset	 fixed bin (18);
dcl     data_seg_path	 char (528) var;
dcl     data_seg_class	 char (32);
dcl     data_is_slt_seg	 bit (1) aligned;
dcl     data_path_ok	 bit (1) aligned;
dcl     fault_desc		 char (80) var;
dcl     n_locks		 fixed bin;
dcl     access_auth		 char (32);
dcl     ring		 fixed bin;
dcl     mode_str		 bit (36) aligned;
dcl     ex_mode_str		 bit (36) aligned;
dcl     mode_chars		 char (4);
dcl     ring_brackets	 (3) fixed bin (3);

dcl     ACV_Fault_Names	 (0:17) char (24) int static options (constant)
			 init (
			 "no fault - bad call",
			 "illegal ring order",
			 "not in execute bracket",
			 "no execute permit",
			 "not in read bracket",
			 "no read permit",
			 "not in write bracket",
			 "no write permit",
			 "not a gate",
			 "not in call bracket",
			 "outward call",
			 "bad outward call",
			 "inward return",
			 "cross-ring transfer",
			 "ring alarm",
			 "assoc. memory fault",
			 "out of segment bounds",
			 "bad acv type - bad call");

dcl     ACV_Mode_Mask	 bit (20) aligned init ("0010101"b) static options (constant);

dcl     ACV_Fault_Ctl_Str	 char (200) int static options (constant) init (
			 "Audit (fim): ^a by ^a (^a) Level=^d at^[ SLT seg^] ^o|^o ^[^a|^o ^;^s^s^](^a) referencing^[ SLT seg^] ^o|^o ^[^a|^o ^;^s^s^](^a) Mode=^a Rings=^d,^d,^d  Inst= ^w; ^w^[ (with ^d lock^[s^] set)^;^s^s^]."
			 );

dcl     IPR_Fault_Names	 (0:8) char (24) int static options (constant)
			 init (
			 "no fault - bad call",
			 "inv fault (never happen)",	/* illegal segno */
			 "illegal op code",
			 "illegal addr/modifier",
			 "illegal slave proc",
			 "illegal procedure",
			 "non-existant addr",
			 "out of bar bounds",
			 "bad ipr type - bad call");

dcl     IPR_Priv_Mask	 bit (36) aligned init ("1001101"b) static options (constant);

dcl     IPR_Fault_Ctl_Str	 char (177) int static options (constant) init (
			 "Audit (fim): ^a by ^a (^a) Level=^d at^[ SLT seg^] ^o|^o ^[^a|^o ^;^s^s^](^a) referencing^[ SLT seg^] ^o|^o ^[^a|^o ^;^s^s^](^a) Inst= ^w; ^w^[  (with ^d lock^[s^] set)^;^s^s^]."
			 );



/* dispatch on type of fault */

	scup = addr (mc.scu);
	if fixed (scu.fi_num) = FAULT_NO_IPR
	then goto interpret_ipr_conditions;
	else if fixed (scu.fi_num) = FAULT_NO_ACV
	then goto interpret_acv_conditions;
	else do;
	     call syserr$binary (SYSERR_LOG_OR_PRINT, mcp, SB_hw_fault, SBL_hw_fault, MSG_Bad_MC, pds$process_group_id);
dcl     MSG_Bad_MC		 char (65) int static options (constant)
			 init ("access_audit_log_fault_: (^a) Called with bad machine conditions.");
	     goto LOG_FAULT_EXIT;			/* return to fault handler */
	end;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* INTERPRET_IPR_CONDITIONS - Label.						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

interpret_ipr_conditions:

	if string (scux.fd) & IPR_Priv_Mask
	then event_flags.priv_op = True;

	unspec (oper_code) = access_operations_$fault_ipr;

/* scup is already set by caller */

	fault_desc = rtrim (convert_access_operation_ (unspec (oper_code))) || " - ";
	fault_desc = fault_desc || IPR_Fault_Names (min (index (string (scux.fd), "1"b), 8));

	proc_seg_no = fixed (scu.ppr.psr, 15);
	proc_seg_offset = fixed (scu.ilc, 18);
	data_seg_no = fixed (scu.tpr.tsr, 15);
	data_seg_offset = fixed (scu.ca, 18);

	n_locks = pds$block_lock_count;

	call get_entry_ptr (baseptr (data_seg_no), locked_dir, entry_ptr, have_entry_sw);

	call get_known_seg_name_and_class
	     (PROC_SEG, proc_seg_no, proc_seg_path, proc_seg_class, proc_is_slt_seg, proc_path_ok);

/* DBG	if acu.pps.prr = "000"b		/* hardcore procedure ? */
/* DBG */
/* DBG	  &  n_locks ^= 0			/* and some locks set ? */
/* DBG */
/* DBG	then do;							/*DBG */
/* DBG	     /* don't fiddle about with data seg ! */
/* DBG */
/* DBG	     data_path_ok = False;					/*DBG */
/* DBG	     data_seg_path = "";					/*DBG */
/* DBG	     data_seg_class = "class undetermined";			/*DBG */
/* DBG	     data_is_slt_seg = False;					/*DBG */
/* DBG	end;							/*DBG */
/* DBG	else							/*DBG */
	call get_known_seg_name_and_class
	     (DATA_SEG, data_seg_no, data_seg_path, data_seg_class, data_is_slt_seg, data_path_ok);

	access_auth = display_access_class_ (pds$access_authorization);
	ring = level$get ();

	call ioa_$rsnpnnl (IPR_Fault_Ctl_Str, msg_text_buff, msg_text_len,
	     fault_desc, pds$process_group_id, access_auth, ring,
	     proc_is_slt_seg, proc_seg_no, proc_seg_offset,
	     proc_path_ok, proc_seg_path, proc_seg_offset, proc_seg_class,
	     data_is_slt_seg, data_seg_no, data_seg_offset,
	     data_path_ok, data_seg_path, data_seg_offset, data_seg_class,
	     scu.even_inst, scu.odd_inst,
	     (n_locks ^= 0), n_locks, (n_locks > 1));

	return;

/* END of code "interpret_ipr_conditions" */
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* INTERPRET_ACV_CONDITIONS - Label.						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

interpret_acv_conditions:

	if string (scu.fd) & ACV_Mode_Mask
	then unspec (oper_code) = access_operations_$fault_acv_mode;
	else unspec (oper_code) = access_operations_$fault_acv_ring;

/* scup is already set by caller */

	fault_desc = rtrim (convert_access_operation_ (unspec (oper_code))) || " - ";
	fault_desc = fault_desc || ACV_Fault_Names (min (index (string (scu.fd), "1"b), 17));

	proc_seg_no = fixed (scu.ppr.psr, 15);
	proc_seg_offset = fixed (scu.ilc, 18);
	data_seg_no = fixed (scu.tpr.tsr, 15);
	data_seg_offset = fixed (scu.ca, 18);

	n_locks = pds$block_lock_count;

	call get_entry_ptr (baseptr (data_seg_no), locked_dir, entry_ptr, have_entry_sw);

/* check if this is legit fault, user may have copy-on-write
   or have voluntarily set write off */
	if (scu.fd.owb | scu.fd.w_off)
	then if have_entry_sw & entry_ptr ^= null
	     then if entry_ptr -> entry.copysw
		then do;
		     goto LOG_FAULT_EXIT;		/* no need to log this one */
		end;
		else do;
		     call fs_modes$locked (baseptr (data_seg_no), mode_str, ex_mode_str, ring_brackets, code);
		     if code = 0
		     then if (mode_str & W_ACCESS) = W_ACCESS
			then goto LOG_FAULT_EXIT;	/* no need to log this one, user has W access */
		end;

/* drop thru here if we're really going to audit this fault */

	call get_known_seg_name_and_class
	     (PROC_SEG, proc_seg_no, proc_seg_path, proc_seg_class, proc_is_slt_seg, proc_path_ok);

/* DBG	if scu.ppr.prr = "000"b		/* if ring 0 procedure */
/* DBG */
/* DBG	  & n_locks ^= 0			/* and something is locked */
/* DBG */
/* DBG	then do;							/*DBG */
/* DBG	     /* don't try to fiddle about with the data seg path */
/* DBG */
/* DBG	     data_path_ok = False;					/*DBG */
/* DBG	     data_seg_path = "";					/*DBG */
/* DBG	     data_seg_class = "class undetermined";			/*DBG */
/* DBG	     data_is_slt_seg = False;					/*DBG */
/* DBG	end;							/*DBG */
/* DBG	else							/*DBG */
	call get_known_seg_name_and_class
	     (DATA_SEG, data_seg_no, data_seg_path, data_seg_class, data_is_slt_seg, data_path_ok);

/* get access mode and ring brackets of referenced segment */

	mode_chars = "null";
	if data_is_slt_seg
	then do;
	     sdwp = addr (addr (dseg$) -> sdwa (data_seg_no));

	     mode_str = substr (string (sdw.access), 1, 3);
	     ring_brackets (1) = fixed (sdw.r1, 3);
	     ring_brackets (2) = fixed (sdw.r2, 3);
	     ring_brackets (3) = fixed (sdw.r3, 3);
	end;
	else do;
	     call fs_modes$locked (baseptr (data_seg_no), mode_str, ex_mode_str, ring_brackets, code);
	     if code ^= 0
	     then do;
		call syserr (SYSERR_LOG_OR_PRINT, MSG_Access_Mode, pds$process_group_id, data_seg_no,
		     error_text (code));
dcl     MSG_Access_Mode	 char (86) int static options (constant)
			 init (
			 "access_audit_log_fault_: (^a) Unable to get access mode for dat seg #^o due to ""^a"".");
		ring_brackets = 7;
		mode_str = "000"b;
		mode_chars = "???";
	     end;
	end;

	if mode_str ^= "0"b
	then do;
	     mode_chars = "";
	     if (mode_str & R_ACCESS) = R_ACCESS
	     then mode_chars = "r";
	     if (mode_str & E_ACCESS) = E_ACCESS
	     then mode_chars = rtrim (mode_chars) || "e";
	     if (mode_str & W_ACCESS) = W_ACCESS
	     then mode_chars = rtrim (mode_chars) || "w";
	end;

	access_auth = display_access_class_ (pds$access_authorization);
	ring = level$get ();

	call ioa_$rsnpnnl (ACV_Fault_Ctl_Str, msg_text_buff, msg_text_len,
	     fault_desc, pds$process_group_id, access_auth, ring,
	     proc_is_slt_seg, proc_seg_no, proc_seg_offset,
	     proc_path_ok, proc_seg_path, proc_seg_offset, proc_seg_class,
	     data_is_slt_seg, data_seg_no, data_seg_offset,
	     data_path_ok, data_seg_path, data_seg_offset, data_seg_class,
	     mode_chars, ring_brackets,
	     scu.even_inst, scu.odd_inst,
	     (n_locks ^= 0), n_locks, (n_locks > 1));

	return;

/* END of code "interpret_acv_conditions" */

     end interpret_machine_conditions;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*  GET_ENTRY_PTR - Internal procedure.						*/
	/*									*/
	/* Procedure to obtain an entry pointer corresponding to the current value of the object	*/
	/* pointer.								*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

get_entry_ptr:
     procedure (a_obj_ptr, a_locked_dir, a_entry_ptr, a_have_entry);

dcl     a_obj_ptr		 parameter pointer;		/* object for which caller wants entry ptr */
dcl     a_locked_dir	 parameter bit (1) aligned;	/* tell caller if we locked the dir ourselves */
dcl     a_entry_ptr		 parameter pointer;		/* caller's desire */
dcl     a_have_entry	 parameter bit (1) aligned;	/* tell caller whether entry_ptr is valid */


	a_locked_dir = False;
	a_have_entry = False;
	a_entry_ptr = null;

	if segno (a_obj_ptr) <= active_all_rings_data$hcscnt
	then do;
	     a_have_entry = False;
	     return;
	end;

	call sum$getbranch_root_my (pointer (a_obj_ptr, 0), "0"b, a_entry_ptr, code);
	if code = error_table_$mylock
	then code = 0;
	else if code = error_table_$root
	then code = 0;
	else if code = error_table_$noentry | code = error_table_$invalidsegno
	then ;					/* let these by... */
	else if code ^= 0
	then do;
	     call syserr (SYSERR_LOG_OR_PRINT, MSG_Get_Entry, pds$process_group_id, segno (a_obj_ptr),
		error_text (code));
dcl     MSG_Get_Entry	 char (84) int static options (constant)
			 init (
			 "access_audit_log_fault_: (^a) Unable to get entry pointer for seg #^o due to ""^a"".");
	     goto LOG_FAULT_EXIT;
	end;
	else a_locked_dir = True;			/* we locked it, remember to unlock it later */

	a_have_entry = (code = 0);

	return;

     end get_entry_ptr;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* GET_KNOWN_SEG_NAME_AND_CLASS - Internal Procedure.				*/
	/*									*/
	/* It attempts to obtain the pathname of the referenced segment.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

get_known_seg_name_and_class:
     procedure (type, seg_no, seg_path, seg_class, slt_sw, path_ok_sw);

dcl     type		 parameter fixed bin;
dcl     seg_no		 parameter fixed bin;
dcl     seg_path		 parameter char (528) var;
dcl     seg_class		 parameter char (32);
dcl     slt_sw		 parameter bit (1) aligned;
dcl     path_ok_sw		 parameter bit (1) aligned;

dcl     ref_name		 char (32);
dcl     code1		 fixed bin (35);
dcl     l_locked_dir	 bit (1) aligned;
dcl     l_entry_ptr		 pointer;
dcl     l_have_entry	 bit (1) aligned;

	slt_sw = False;
	path_ok_sw = False;

	if seg_no < active_all_rings_data$hcscnt
	then do;					/* it's in SLT */
	     slt_sw = True;

	     sltp = addr (slt$);
	     sltep = addr (slt.seg (seg_no));
	     namep = pointer (slt.name_seg_ptr, slte.names_ptr);
	     seg_path = namep -> segnam.names (1).name;
	     seg_class = "hardcore segment";
	     path_ok_sw = True;
	end;

	else do;
	     slt_sw = False;

	     call get_pathname_ (seg_no, seg_path, code);

	     if code = 0
	     then do;
		path_ok_sw = True;

		if type = DATA_SEG			/* we already have an entry pointer? */
		then seg_class = display_access_class_ (entry_ptr -> entry.access_class);
		else do;
		     call get_entry_ptr (baseptr (seg_no), l_locked_dir, l_entry_ptr, l_have_entry);
		     if l_have_entry
		     then if l_entry_ptr = null	/* root? */
			then seg_class = display_access_class_ (sys_info$access_class_floor);
			else seg_class = display_access_class_ (l_entry_ptr -> entry.access_class);
		     else seg_class = "unable to get entry";
		     if l_locked_dir		/* unlock immediately */
		     then call lock$dir_unlock (pointer (l_entry_ptr, 0));
		end;
	     end;
	     else if code = error_table_$invalidsegno
	     then do;
		seg_path = "";
		seg_class = "invalid seg #";
		path_ok_sw = False;
	     end;
	     else if code = error_table_$noentry
	     then do;
		call fs_get$ref_name (baseptr (seg_no), 1 /* most recent */, ref_name, code1);
		if code1 ^= 0
		then goto get_known_seg_err;
		seg_path = ref_name;
		if seg_path = ""
		then do;
		     seg_class = "deleted seg - null ref name";
		     path_ok_sw = False;
		end;
		else do;
		     seg_class = "deleted seg";
		     path_ok_sw = True;
		end;
	     end;
	     else do;				/* oops! */
get_known_seg_err:
		call syserr (SYSERR_LOG_OR_PRINT, MSG_Get_Path, pds$process_group_id, seg_no, error_text (code));
dcl     MSG_Get_Path	 char (74) int static options (constant)
			 init ("access_audit_log_fault_: (^a) Unable to get path of seg #^o due to ""^a"".");
		seg_path = "";
		seg_class = "unable to determine path";
		path_ok_sw = False;
	     end;
	end;

	return;

     end get_known_seg_name_and_class;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* BUILD_OBJECT_INFO - Internal Procedure.					*/
	/*									*/
	/* This routine to sets up the binary info structure with pertinent information about the */
	/* DATA segment/directory.							*/
	/*									*/
	/* This routine is somewhat duplicated in access_audit_.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

build_object_info:
     procedure;

	if have_entry_sw
	then if entry_ptr ^= null ()
	     then do;
		if ^entry_ptr -> entry.bs
		then do;
die:
		     call syserr (SYSERR_CRASH_SYSTEM, MSG_Expected_Branch, entry_ptr);
dcl     MSG_Expected_Branch	 char (66) int static options (constant)
			 init ("access_audit_log_fault_: Link entry where branch expected (ep=^p).");
		     goto die;
		end;

		audit_ssobj_info_ptr = addr (local_ssobj_info);

/* build ssobj info structure for a seg or dir */
		unspec (audit_ssobj_info) = ""b;
		audit_ssobj_info.info_type = AAB_ss_object;
		call uid_path_util$get (pointer (entry_ptr, 0), audit_ssobj_info.parent_uid_path, code);
		if code ^= 0
		then do;
		     call syserr (SYSERR_LOG_OR_PRINT, MSG_Dir_UID, pds$process_group_id, segno (entry_ptr));
dcl     MSG_Dir_UID		 char (75) int static options (constant)
			 init ("access_audit_log_fault_: (^a) Unable to get UID path for directory seg #^o.");
		     audit_ssobj_info.parent_uid_path = "0"b;
						/* all invalid */
		end;
		audit_ssobj_info.entry_uid = entry_ptr -> entry.uid;
		audit_ssobj_info.dtem = entry_ptr -> entry.dtem;
		audit_ssobj_info.access_class = entry_ptr -> entry.access_class;
		call access_mode$raw (entry_ptr, audit_ssobj_info.raw_mode, audit_ssobj_info.ex_mode, code);
		if code ^= 0
		then do;
		     call syserr (SYSERR_LOG_OR_PRINT, MSG_Raw_Access, pds$process_group_id, entry_ptr);
dcl     MSG_Raw_Access	 char (74) int static options (constant)
			 init ("access_audit_log_fault_: (^a) Unable to get raw access modes for entry ^p.");
		     audit_ssobj_info.raw_mode = "0"b;
		     audit_ssobj_info.ex_mode = "0"b;
		end;
		audit_ssobj_info.ring_brackets = entry_ptr -> entry.ring_brackets;
		audit_ssobj_info.ex_ring_brackets = entry_ptr -> entry.ex_ring_brackets;
		audit_ssobj_info.dirsw = entry_ptr -> entry.dirsw;
		audit_ssobj_info.per_process_sw = entry_ptr -> entry.per_process_sw;
		audit_ssobj_info.safety_sw = entry_ptr -> entry.safety_sw;
		audit_ssobj_info.multiple_class = entry_ptr -> entry.multiple_class;
		audit_ssobj_info.audit_flag = entry_ptr -> entry.audit_flag;
		audit_ssobj_info.security_oosw = entry_ptr -> entry.security_oosw;
		audit_ssobj_info.entrypt_sw = entry_ptr -> entry.entrypt_sw;
		audit_ssobj_info.master_dir = entry_ptr -> entry.master_dir;
		audit_ssobj_info.access_class = entry_ptr -> entry.access_class;

		object_info_valid_sw = True;
	     end;

	return;

     end build_object_info;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* FORM_AUDIT_RECORD_HEADER - Internal Procedure.					*/
	/*									*/
	/* This routine assembles the standard record header for the audit message.		*/
	/*									*/
	/* This routine is somewhat duplicated in access_audit_.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

form_audit_record_header:
     procedure;

	audit_record_ptr = addr (local_audit_header);

	audit_record_header.type = ARH_TYPE_NO_PROXY;

	audit_record_header.version = ACCESS_AUDIT_HEADER_VERSION_3;

	audit_record_header.subject_is_process = True;
	call parse_group_id (pds$process_group_id,
	     audit_record_header.person, audit_record_header.project, audit_record_header.tag);
	audit_record_header.ring = level$get ();
	audit_record_header.anonymous = (substr (pds$process_group_id, 1, 9) = "anonymous");
	audit_record_header.process_id = pds$process_id;
	audit_record_header.authorization = pds$access_authorization;
	audit_record_header.authorization_range (1) = sys_info$access_class_floor;
						/* don't know this in hardcore */
	audit_record_header.authorization_range (2) = pds$max_access_authorization;

	audit_record_header.object_is_valid = object_info_valid_sw;
	audit_record_header.operation_code = unspec (oper_code);
	audit_record_header.event_flags = unspec (event_flags);

	return;

parse_group_id:					/* procedure internal to form_audit_record_header */
     procedure (group_id, person, project, tag);

dcl     group_id		 parameter char (32) aligned;
dcl     person		 parameter char (22);
dcl     project		 parameter char (9);
dcl     tag		 parameter char (1);
dcl     l_group_id		 char (32);

	l_group_id = group_id;
	person, project, tag = "";

	i = index (l_group_id, ".");
	if i = 0
	then do;
	     person = l_group_id;
	     return;
	end;
	else if i > 1
	then person = substr (l_group_id, 1, i - 1);

	l_group_id = substr (l_group_id, i + 1);

	i = index (l_group_id, ".");
	if i = 0
	then do;
	     project = l_group_id;
	     return;
	end;
	else if i > 1
	then project = substr (l_group_id, 1, i - 1);

	tag = substr (l_group_id, i + 1);

	return;

     end parse_group_id;

     end form_audit_record_header;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* WRITE_LOG_MESSAGE - Internal Procedure.					*/
	/*									*/
	/* This procedure interfaces with the logging software to add an audit message to the	*/
	/* logs.									*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

write_log_message:
     procedure;

dcl     1 bin_info_array	 (2) aligned,		/* argument for syserr$multiple_binary */
	2 p		 pointer,
	2 len		 fixed bin;
dcl     n_pieces		 fixed bin;
dcl     syserr_code		 fixed bin;

	p (1) = addr (audit_record_header);
	len (1) = size (audit_record_header);

	if object_info_valid_sw
	then do;
	     p (2) = addr (audit_ssobj_info);
	     len (2) = size (audit_ssobj_info);
	     n_pieces = 2;
	end;
	else do;
	     p (2) = null ();
	     len (2) = 0;
	     n_pieces = 1;
	end;

	syserr_code = SYSERR_LOG_OR_PRINT + SYSERR_UNSUCCESSFUL_ACCESS;
	call syserr$multiple_binary (syserr_code, addr (bin_info_array), n_pieces, SB_access_audit, msg_text);

	return;

     end write_log_message;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* ERROR_TEXT - Internal Procedure.						*/
	/*									*/
	/* Procedure to return the short error message mnemonic associated with an error_table_	*/
	/* entry.									*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

error_text:
     procedure (ec) returns (char (100) aligned);

dcl     ec		 parameter fixed bin (35);

dcl     char8		 char (8) aligned;
dcl     char100		 char (100) aligned;

	call convert_status_code_ (ec, char8, char100);

	return (char100);

     end error_text;

/* format: off */
%page; %include access_audit_flags;
%page; %include access_audit_eventflags;
%page; %include access_audit_bin_header;
%page; %include access_audit_binary_def;
%page; %include access_audit_ssobj_info;
%page; %include mc;
%page; %include fault_vector;
%page; %include slt;
%page; %include slte;
%page; %include sdw;
%page; %include dir_header;
%page; %include dir_entry;
%page; %include dir_name;
%page; %include syserr_constants;
%page; %include syserr_binary_def;
%page; %include access_mode_values;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   access_audit_log_fault_: (USER_ID) Encountered illegal meter index value.

   S:	$info

   T:	$run

   M:	$err
   The access audit meters in active_hardcore_data are inconsistant
   with the format of the process access flags.

   A:	$notify


   Message:
   access_audit_log_fault_: (USER_ID) Called with bad machine conditions.

   S:	$info

   T:	$run

   M:	$err
   access_audit_log_fault_ was given machine conditions for a fault
   which was neither an illegal_procedure or an access_violation.

   A:	$notify


   Message:
   access_audit_log_fault_: (USER_ID) Unable to get access mode for data seg #N due to "MESSAGE".

   S:	$info

   T:	$run

   M:	$err
   A call to fs_modes failed unexpectedly.  The AUDIT message text
   will show the modes as "???" and ring brackets of 7,7,7.  The
   message binary will reflect null access mode and ring bracket
   of 7,7,7.

   A:	$notify


   Message:
   access_audit_log_fault_: (USER_ID) Unable to get entry pointer for seg #N due to "MESSAGE".

   S:	$info

   T:	$run

   M:	$err
   A call to sum$getbranch_root_my returned an unexpected error code.

   A:	$notify


   Message:
   access_audit_log_fault_: (USER_ID Unable to get path of seg #N due to "MESSAGE".

   S:	$info

   T:	$run

   M:	$err
   A call to get_pathname_ returned an unexpected error code.

   A:	$notify


   Message:
   access_audit_log_fault_: Link entry where branch expected (ep=PTR).

   S:	$crash

   T:	$run

   M:	$err
   After getting a directory entry for a specific segno the branch
   switch in the entry was found to be off.

   A:	$recover


   Message:
   access_audit_log_fault_: (USER_ID) Unable to get UID path for directory seg #N due to "MESSAGE".

   S:	$info

   T:	$run

   M:	$err
   Although  the directory is locked, a failure occurred in
   uid_path_util$get.

   A:	$notify


   Message:
   access_audit_log_fault_: (USER_ID) Unable to get raw access modes for entry PTR due to "MESSAGE".

   S:	$info

   T:	$run

   M:	$err
   Although the directory is locked a failure occurred in
   access_mode$raw.

   A:	$notify

   
   END MESSAGE DOCUMENTATION */


end access_audit_log_fault_;




		    access_audit_util_.pl1          11/11/89  1103.7rew 11/11/89  0809.6       80811



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



/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1056):
     Correct error message documentation.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,linecom,indcomtxt,^inddcls,^indnoniterdo */

access_audit_util_:
     procedure;

/* format: off */
/****** History:
	85-01-14 EJ Sharpe - changes per code audit, set pds$throttle_segment_state_changes
	85-01-13 EJ Sharpe - added message documentation, fixed access_audit_ call
	85-01-11 EJ Sharpe - fixed check for proper active_hardcore_data meters
	85-01-07 EJ Sharpe - extracted code from access_audit_
******/


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* ACCESS_AUDIT_UTIL_							*/
	/*									*/
	/* Collection of utility routines associated with access_audit_			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */


/*	PARAMETERS	*/

dcl     a_area_ptr		 parameter pointer;		/* user area where we can put things */
dcl     a_audit_flags	 parameter bit (36) aligned;	/* process audit flags */
dcl     a_code		 parameter fixed bin (35);	/* returned system status code */
dcl     a_audit_meter_info_num parameter fixed bin;	/* number of meter buckets returned */
dcl     a_audit_meter_info_ptr parameter pointer;		/* pointer to metering data for caller */


/*	AUTOMATIC		*/

dcl     area_ptr		 pointer;			/* arg copy */
dcl     code		 fixed bin (35);		/* arg copy */
dcl     1 event_flags	 aligned like audit_event_flags;
						/* passed to access audit */
dcl     i			 fixed bin;		/* index */
dcl     j			 fixed bin;		/* index */
dcl     old_audit_flags	 bit (36) aligned;		/* temp for process audit flags */


/*	BASED		*/

dcl     area		 area based (area_ptr);


/*	MISCELLANEOUS	*/

dcl     addr		 builtin;
dcl     any_other		 condition;
dcl     null		 builtin;
dcl     string		 builtin;


/*	EXTERNAL		*/

dcl     access_operations_$process_audit_flags_modify
			 bit (36) aligned ext;

/* Note - The next four externals hold the access audit metering data. */
/*	active_hardcore_data$access_audit_num_meters" is set to the dimension. */
/*        This value is (n_audit_objects*n_audit_access_types) + n_audit_events + 1. */
/*	This dimension should be increased as audit objects/events are added. */
dcl     active_hardcore_data$access_audit_num_meters
			 fixed bin external;
dcl     active_hardcore_data$access_audit_count
			 (1) fixed bin (35) external;
dcl     active_hardcore_data$access_audit_check_count
			 (1) fixed bin (35) external;
dcl     active_hardcore_data$access_audit_cpu_time
			 (1) fixed bin (71) external;
dcl     active_hardcore_data$access_audit_pagefaults
			 (1) fixed bin (35) external;

dcl     error_table_$unexpected_condition
			 fixed bin (35) ext;
dcl     error_table_$unimplemented_version
			 fixed bin (35) ext;

dcl     pds$audit_flags	 bit (36) aligned ext;
dcl     pds$throttle_segment_state_changes
			 bit (1) aligned ext;


/*	ENTRIES		*/

dcl     access_audit_$check_general
			 entry (bit (36) aligned, bit (36) aligned) returns (bit (1) aligned);
dcl     access_audit_$log_general
			 entry options (variable);
dcl     ioa_$rsnnl		 entry options (variable);
dcl     level$get		 entry returns (fixed bin);
%page;
/* format: off */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* GET_AUDIT_METERS - Entrypoint.						*/
	/*									*/
	/* This entry returns the current access_audit_ meters to the caller.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

get_audit_meters:
     entry (a_area_ptr, a_audit_meter_info_num, a_audit_meter_info_ptr, a_code);

	code = error_table_$unexpected_condition;

	on any_other goto GET_METERS_EXIT;

	area_ptr = a_area_ptr;

	audit_meter_info_num = (n_audit_objects * 2 * n_audit_access_types) + n_audit_flags + 1;

	if audit_meter_info_num ^= active_hardcore_data$access_audit_num_meters
	then do;
	     code = error_table_$unimplemented_version;
	     goto GET_METERS_EXIT;
	end;

	allocate audit_meter_info in (area);
	audit_meter_info.version = audit_meter_info_version_1;

/* first the object related meters */
	do i = 1 to n_audit_objects;
	     do j = 1 to n_audit_access_types;		/* for each operation grant */
		call copy_meters (Short_Object_Names (i), Short_Level_Names (j),
		     "grant", (i - 1) * n_audit_access_types * 2 + j);
	     end;
	     do j = n_audit_access_types + 1 to n_audit_access_types * 2;
						/* for each operation denial */
		call copy_meters (Short_Object_Names (i), Short_Level_Names (j - n_audit_access_types),
		     "deny", (i - 1) * n_audit_access_types * 2 + j);
	     end;
	end;

/* and then the event related meters */
	do i = (n_audit_objects * n_audit_access_types * 2) + 1
	     to (n_audit_objects * n_audit_access_types * 2) + n_audit_flags;
	     call copy_meters (Long_Flag_Names (i - (n_audit_objects * 2 * n_audit_access_types)), "", "", i);
	end;

/* and finally the catch-all meter */
	call copy_meters ("All Others (should be zero)", "", "", audit_meter_info_num);

	a_audit_meter_info_num = audit_meter_info_num;
	a_audit_meter_info_ptr = addr (audit_meter_info);
	code = 0;

GET_METERS_EXIT:
	a_code = code;
	return;

copy_meters:					/* internal proc used by get_meters entrypoint exclusively */
     procedure (a_str1, a_str2, a_str3, a_index);

dcl     (a_str1, a_str2, a_str3)
			 char (*) parameter;
dcl     a_index		 fixed bin parameter;


	call ioa_$rsnnl ("^a ^a ^a", audit_meter_info.name (a_index), (0), a_str1, a_str2, a_str3);

	audit_meter_info.count (a_index) = active_hardcore_data$access_audit_count (a_index);
	audit_meter_info.check_count (a_index) = active_hardcore_data$access_audit_check_count (a_index);
	audit_meter_info.cpu_time (a_index) = active_hardcore_data$access_audit_cpu_time (a_index);
	audit_meter_info.pagefaults (a_index) = active_hardcore_data$access_audit_pagefaults (a_index);

     end copy_meters;
%page;
/* format: off */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* GET_AUDIT_FLAGS - Entrypoint.						*/
	/*									*/
	/* This entry returns the process's audit flags.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

get_audit_flags:
     entry (a_audit_flags);

	a_audit_flags = pds$audit_flags;

	return;
%page;
/* format: off */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* SET_AUDIT_FLAGS - Entrypoint.						*/
	/*									*/
	/* This entry sets the process's audit flags.  It is available only through hphcs_.	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */

set_audit_flags:
     entry (a_audit_flags);

	old_audit_flags = pds$audit_flags;
	pds$audit_flags = a_audit_flags;

/* audit this event! */
	string (event_flags) = ""b;
	event_flags.special_op = "1"b;
	event_flags.priv_op = "1"b;
	event_flags.grant = "1"b;
	call access_audit_$log_general ("access_audit_util_", level$get (), string (event_flags),
	     access_operations_$process_audit_flags_modify, "", 0, null (), 0,
	     "Changed from ^w to ^w", old_audit_flags, pds$audit_flags);

/* since audit behaviour has changed, we must recalulate pds$throttle_segment_state_changes */
/* as is done during process creation in act_proc */

	string (event_flags) = ""b;
	event_flags.grant = "1"b;
	event_flags.cc_10_100 = "1"b;
	pds$throttle_segment_state_changes =
	     access_audit_$check_general (string (event_flags), "0"b /* null oper code */);

	return;

/* format: off */
%page; %include access_audit_flags;
%page; %include access_audit_eventflags;
%page; %include access_audit_names;
%page; %include access_audit_meter_info;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   AUDIT (access_audit_util_): GRANTED modification of process audit flags ADDED_INFO

   S:	$access_audit

   T:	$run

   M:	The specified user has invoked a privileged operation to change
   the process audit flags.  This may result in more or less audit
   messages for that user.

   A:	$notify_ssa

   END MESSAGE DOCUMENTATION */


     end access_audit_util_;




		    access_mode.pl1                 11/11/89  1103.7rew 11/11/89  0809.6       98406



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */

access_mode: proc;					/* This computes any of three modes to a segment: */
						/* raw, access_authorization factored, and effective
						   (authorization and ring bracket factored) */

/* modified by Kobziar on 11-12-73 to skip CACLs */
/* modification to original access_mode for the 3 entry version by Kobziar July 74 */
/* modified by DRV 8/76  to add entry user_effmode */
/* Modified by MJG 8/79  to fix root dir special case */
/* Modified by Keith Loepere 10/84 to return non-extended modes for dirs for 
   which the process is not on the ACL */


/****^  HISTORY COMMENTS:
  1) change(87-01-16,Farley), approve(87-02-25,MCR7613),
     audit(87-03-03,Lippard), install(87-03-30,MR12.1-1018):
     Changed to make Initializer go through entry checks like everybody else
     when the entry is a directory.  This will stop the Initializer from
     thinking that it is ok to treat directories like segments in some
     respects.
                                                   END HISTORY COMMENTS */


dcl (pds$processid,
     tc_data$initializer_id) ext fixed bin (35);

dcl  pds$access_name aligned ext,
     pds$access_authorization bit (72) aligned ext;

dcl  acc_name_$elements entry (ptr, ptr, fixed bin (35)),
     usage_values entry (fixed bin, fixed bin (71)),
     level$get entry returns (fixed bin),
    (read_allowed_, read_write_allowed_, write_allowed_) entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);

dcl (addr, max, null, ptr, rel, fixed) builtin;
dcl  bad_dir_ condition;

dcl (a_ep,
     authp,
     np) ptr;

dcl (a_auth,
     auth) bit (72) aligned;

dcl 1 uname aligned,
    2 person char (32),
    2 project char (32),
    2 tag char (1) unaligned;

dcl (cpu1,
     cpu2) fixed bin (71);

dcl (a_code,
     code) fixed bin (35);

dcl (esw,
     i,
     nacls,
     a_val,
     val,
     pf1,
     pf2) fixed bin;

dcl  a_user_name char (32) aligned;

dcl (a_exmode,
     exmode, mode,
     a_mode) bit (36) aligned;

dcl (persrp,
     projrp) bit (18) aligned;

dcl  sys_control bit (1) aligned;

dcl 1 name aligned based,
    2 person char (32),
    2 project char (32),
    2 tag char (1) unaligned;

dcl (raw init (0),
     authorization init (1),
     effective init (2)) fixed bin static;

dcl  error_table_$obsolete_function ext fixed bin (35);

dcl (active_hardcore_data$total_cpu_ac,
     active_hardcore_data$max_cpu_ac) ext fixed bin (71);

dcl (active_hardcore_data$total_ac,
     active_hardcore_data$total_pf_ac,
     active_hardcore_data$pf_long_ac,
     active_hardcore_data$nacls_long_ac,
     active_hardcore_data$max_pf_ac,
     active_hardcore_data$max_acls_ac,
     active_hardcore_data$acls_ac (13)) ext fixed bin;

	% include fs_types;
	% include aim_template;
	% include dir_header;
	% include dir_entry;
	% include dir_acl;

/*  */
raw:	entry (a_ep, a_mode, a_exmode, a_code);		/* want raw mode */
	esw = raw;
	go to initializer_check;

authorization: entry (a_ep, a_mode, a_exmode, a_code);	/* factor in access_authorization */
	esw = authorization;
	go to initializer_check;

effective: entry (a_ep, a_mode, a_exmode, a_code);	/* factor ring brackets also */
	esw = effective;
	val = level$get ();
						/* initializer_check next */
initializer_check:
	if pds$processid = tc_data$initializer_id then sys_control = "1"b; /* this is the initializer process */
	else sys_control = "0"b;			/* not the initializer */

	np = addr (pds$access_name);			/* get ptr to name */

	if esw ^= raw then do;
	     authp = addr (auth);
	     auth = pds$access_authorization;
	end;
	go to common;

user_effmode: entry (a_ep, a_user_name, a_auth, a_val, a_mode, a_exmode, a_code);

	val = a_val;
	auth = a_auth;
	authp = addr (auth);
	esw = effective;
	goto split_user_name;

user:	entry (a_ep, a_user_name, a_mode, a_exmode, a_code); /* entry to compute mode for another user */

	esw = raw;				/* skip authorization checks, as caller is responsible for this */

split_user_name:
	sys_control = "0"b;				/* don't allow access to be calculated for system control */
	np = addr (uname);				/* get ptr to name */
	call acc_name_$elements (addr (a_user_name), np, code); /* break up user name into 3 part access name */
	if code ^= 0 then go to invalid_name;


common:	ep = a_ep;
	code = 0;					/* clear error code */

	if rel (ep) = "0"b then do;			/* no more cacls */
	     code = error_table_$obsolete_function;
	     a_mode, a_exmode = "0"b;
	     goto st_ret;
	end;

	if ep = null then do;			/* special case the root */
	     if sys_control then a_exmode = "111"b;	/* if initializer calling on its own behalf */
						/* give it SMA access to the root */
	     else a_exmode = "100"b;			/* give everyone S access to the root */
	     if esw = effective then do;		/* if we must factor ring brackets */
		if val = 0 then			/* Ring 0, */
		     a_mode = "101"b;		/*  give RW access */
		else a_mode = "000"b;		/* otherwise, no access at all */
	     end;
	     else a_mode = "101"b;			/* raw check, say RW */
	     goto st_ret;
	end;


	call usage_values (pf1, cpu1);		/* start metering time */

	nacls = 0;				/* set number of acl entries examined to zero */

	if sys_control & entry.dirsw then do;		/* give initializer access to all directories */
	     mode = "101"b;
	     exmode = "111"b;
	     goto entry_check;
	end;


	i = 0;
	do aclep = ptr (ep, entry.acl_frp) repeat ptr (ep, acl_entry.frp) while (rel (aclep));
	     i = i + 1;
	     if i > entry.acle_count
	     | acl_entry.owner ^= entry.uid
	     | acl_entry.type ^= ACLE_TYPE then signal bad_dir_;
	     nacls = nacls + 1;			/* count number of ACL entries examined */
	     persrp = acl_entry.name.pers_rp;		/* get rp to person name */
	     if persrp ^= "0"b then do;		/* if person name ^= "*" */
		if ptr (ep, persrp) -> access_name.name ^= np -> name.person then go to skip;
	     end;

	     projrp = acl_entry.name.proj_rp;		/* get rp to project name */
	     if projrp ^= "0"b then do;		/* if project ^= "*" */
		if ptr (ep, projrp) -> access_name.name ^= np -> name.project then go to skip;
	     end;

	     if acl_entry.name.tag ^= "*" then		/* compare tags */
		if np -> name.tag ^= "*" then		/* allow access name to contain tag of "*" */
		     if acl_entry.name.tag ^= np -> name.tag then
			go to skip;

	     mode = acl_entry.mode;			/* names match - return mode */
	     exmode = acl_entry.ex_mode;		/* and extended mode */
	     go to entry_check;			/* see if finished */

skip:	end;

	if entry.dirsw then do;			/* not on ACL but everyone can read dirs */
	     mode = "101"b;
	     exmode = "0"b;
	     go to entry_check;
	end;

err:
	mode,					/* return null modes if no match */
	     exmode = "0"b;
	go to meter;				/* gather numbers */

entry_check:
	if esw = raw then go to meter;

	if entry.dirsw then do;			/* see what access left */
	     if authp -> aim_template.privileges.dir then go to factor_rb;
	     if (exmode & "011"b) = "000"b then go to check_read; /* if cannot modify or append
						   * then skip read/write check */
	end;

	else do;					/* a segment */
	     if authp -> aim_template.privileges.seg then go to factor_rb;
	     if (mode & "001"b) = "000"b then go to check_read; /* if cannot write, skip read-write check */
						/* w only mode must also clear security read-write check */
	end;

	if read_write_allowed_ (auth, entry.access_class) then go to factor_rb;

check_read:
	if read_allowed_ (auth, entry.access_class) then do;
	     if entry.dirsw then exmode = exmode & "100"b;
	     else mode = mode & "110"b;		/* must zero w because previous test could have failed */
	     go to factor_rb;
	end;

/* write up only on special system segments */
	if ^entry.dirsw then
	     if entry.multiple_class then		/* system segment */
		if fixed (entry.ring_brackets (3), 3) <= 1 then /* only valid if in security permiter */
		     if write_allowed_ (auth, entry.access_class) then go to factor_rb;
						/* allow full access */

	go to err;				/* otherwise return null access */

factor_rb:
	if esw = authorization then go to meter;	/* skip rb part */

	if entry.dirsw then do;
	     if val <= fixed (entry.ex_ring_brackets (1), 3) then go to seg_rb_check;
	     if val > fixed (entry.ex_ring_brackets (2), 3) then exmode = "0"b;
	     else exmode = exmode & "100"b;		/* s only  */
	end;
seg_rb_check:					/* do this factoring in dir case also */
	if val = fixed (entry.ring_brackets (1), 3) then go to meter;
	if val < fixed (entry.ring_brackets (1), 3) then mode = mode & "101"b;
	else if val <= fixed (entry.ring_brackets (2), 3) then mode = mode & "110"b;
	else if val <= fixed (entry.ring_brackets (3), 3) then mode = mode & "010"b;
	else mode = "0"b;				/* return null */

meter:						/* update access computation statistics */
	call usage_values (pf2, cpu2);
	pf2 = pf2 - pf1;				/* get number of page faults */
	cpu2 = cpu2 - cpu1;				/* get cpu time */

	active_hardcore_data$total_ac =		/* update total number of access computations */
	     active_hardcore_data$total_ac + 1;

	active_hardcore_data$total_pf_ac =		/* update total page faults taken in access computation */
	     active_hardcore_data$total_pf_ac + pf2;

	active_hardcore_data$total_cpu_ac =		/* update total cpu time */
	     active_hardcore_data$total_cpu_ac + cpu2;

	if active_hardcore_data$max_cpu_ac < cpu2 then do; /* update data on longest access computation */
	     active_hardcore_data$max_cpu_ac = cpu2;
	     active_hardcore_data$pf_long_ac = pf2;
	     active_hardcore_data$nacls_long_ac = nacls;	/* update number of acl entries searched */
	end;

	if nacls > 15 then i = 13;			/* calc index for histogram of number of acl entries */
	else if nacls > 10 then i = 12;		/* searched in an access computation */
	else i = nacls + 1;
	active_hardcore_data$acls_ac (i) =		/* update histogram */
	     active_hardcore_data$acls_ac (i) + 1;

	active_hardcore_data$max_pf_ac =		/* update max page faults taken in access computation */
	     max (active_hardcore_data$max_pf_ac, pf2);

	active_hardcore_data$max_acls_ac =		/* update max number of acls searched */
	     max (active_hardcore_data$max_acls_ac, nacls);

return:
	a_mode = mode;
	a_exmode = exmode;
st_ret:
	a_code = code;
	return;

invalid_name:
	a_mode, a_exmode = "0"b;			/* you loose */
	go to st_ret;

     end access_mode;




		    dc_find.pl1                     10/14/90  1045.2rew 10/14/90  1042.1      793548



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



/****^  HISTORY COMMENTS:
  1) change(85-05-31,EJSharpe), approve(86-02-20,MCR7301),
     audit(86-04-07,Swenson), install(86-04-23,MR12.0-1044):
     fix bug where get_link_target would not update dir argument
  2) change(90-09-28,Schroth), approve(90-09-28,MCR8205),
     audit(90-10-04,WAAnderson), install(90-10-14,MR12.4-1042):
     Corrected dir_salvage entry to lock parent of dir to salvage after locking
     the dir itself.  This is in keeping with the documented protocol and
     corrects a potential dir locking deadly embrace.
                                                   END HISTORY COMMENTS */


/* The master module within directory control that finds directories or 
directory entries, checks access, audits successful accesses and attempted
access violations and produces correct user visible error codes.

Produced out of what once was find_, find_entry, find_dirsegno,
dir_control_error and parts of uid_path_util by Keith Loepere, June 1984.

Modified throughout 1984 by Keith Loepere for successful access auditing,
centralization of access decisions, etc.
Modified 84-11-27 by EJ Sharpe to change access_audit_ arg list
Modified 85-01-07 by Keith Loepere for obj_for_audit.
Modified 85-02-19 by Keith Loepere so that append through links returns the
   target path.
Modified 85-02-25 by Keith Loepere to bring back existence entrypoint.
Modified 85-04-01 by Keith Loepere for new access_audit_check_ep_ and fix
     to truncating MSFs.
Modified 85-04-08 by Keith Loepere to use fs_modes whenever possible,
     which has the advantage of understanding priv init objects.
Modified 85-05-08 by EJ Sharpe to add obj_delete_uid (non-privileged) and to
     make uid path searches obey AIM rules for making dir names known
Modified 85-05-15 by EJ Sharpe to change dir_write_raw_uid to mdir_set_quota_uid
*/

/* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */

dc_find: proc;
	return;

/* External */

dcl  active_all_rings_data$maxlinks	fixed bin ext;
dcl  dseg$			(0:4095) fixed bin (71) ext static;
dcl  error_table_$bad_uidpath		fixed bin (35) ext;
dcl  error_table_$badpath		fixed bin (35) ext;
dcl  error_table_$dirseg		fixed bin (35) ext;
dcl  error_table_$entlong		fixed bin (35) ext;
dcl  error_table_$incorrect_access	fixed bin (35) ext;
dcl  error_table_$link		fixed bin (35) ext;
dcl  error_table_$moderr		fixed bin (35) ext;
dcl  error_table_$mylock		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_$no_s_permission	fixed bin (35) ext;
dcl  error_table_$namedup		fixed bin (35) ext;
dcl  error_table_$noentry		fixed bin (35) ext;
dcl  error_table_$not_link		fixed bin (35) ext;
dcl  error_table_$notadir		fixed bin (35) ext;
dcl  error_table_$oosw		fixed bin (35) ext;
dcl  error_table_$root		fixed bin (35) ext;
dcl  error_table_$seg_deleted		fixed bin (35) ext;
dcl  error_table_$segknown		fixed bin (35) ext;
dcl  error_table_$toomanylinks	fixed bin (35) ext;
dcl  pds$access_authorization		bit (72) aligned ext;

/* Entries */

dcl  access_audit_check_ep_$self	entry (bit (36) aligned, bit (36) aligned, ptr) returns (bit (1));
dcl  access_audit_check_ep_$user	entry (bit (36) aligned, bit (36) aligned, ptr, bit (72) aligned, bit (36) aligned) returns (bit (1));
dcl  access_audit_$log_entry_ptr	entry (char (*), fixed bin, bit (36) aligned, bit (36) aligned, ptr, fixed bin (35), ptr, fixed bin (18), char (*));
dcl  access_audit_$log_entry_ptr_user	entry (char (*), fixed bin, bit (36) aligned, bit (36) aligned, ptr, fixed bin (35), ptr, fixed bin (18), ptr, char (*));
dcl  access_mode$effective		entry (ptr, bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl  access_mode$raw		entry (ptr, bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl  access_mode$user_effmode		entry (ptr, char (32) aligned, bit (72) aligned, fixed bin (3), bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl  aim_check_$greater_or_equal	entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  fs_modes$locked		entry (ptr, bit (36) aligned, bit (36) aligned, (3) fixed bin (3), fixed bin (35));
dcl  get_kstep			entry (fixed bin, ptr, fixed bin (35));
dcl  hash$search			entry (ptr, ptr, ptr, fixed bin (35));
dcl  level$get			entry () returns (fixed bin);
dcl  lock$dir_lock_read		entry (ptr, fixed bin (35));
dcl  lock$dir_lock_salvage		entry (ptr, bit (36) aligned, fixed bin (35));
dcl  lock$dir_lock_write		entry (ptr, fixed bin (35));
dcl  lock$dir_unlock		entry (ptr);
dcl  makeknown_			entry (ptr, fixed bin (17), fixed bin (17), fixed bin (35));
dcl  mlr_				entry (ptr, fixed bin (21), ptr, fixed bin (21));
dcl  mrl_				entry (ptr, fixed bin (21), ptr, fixed bin (21));
dcl  pathname_am$get_segno		entry (char (*) varying, fixed bin (17));
dcl  pathname_am$set		entry (char (*) varying, fixed bin (17));
dcl  read_allowed_			entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  sdw_util_$construct		entry (ptr, ptr);
dcl  sdw_util_$dissect		entry (ptr, ptr);
dcl  segno_usage$decrement		entry (fixed bin (17), fixed bin (35));
dcl  sum$getbranch			entry (ptr, bit (36) aligned, ptr, fixed bin (35));
dcl  sum$getbranch_root_my		entry (ptr, bit (36) aligned, ptr, fixed bin (35));
dcl  update_kste_access		entry (ptr, ptr, bit (36) aligned);
dcl  wired_utility_$grow_stack_frame	entry (fixed bin) returns (ptr);

/* Misc */

dcl  addcharno			builtin;
dcl  addr				builtin;
dcl  baseptr			builtin;
dcl  binary			builtin;
dcl  index			builtin;
dcl  length			builtin;
dcl  max				builtin;
dcl  min				builtin;
dcl  null				builtin;
dcl  ptr				builtin;
dcl  rel				builtin;
dcl  reverse			builtin;
dcl  rtrim			builtin;
dcl  segno			builtin;
dcl  size				builtin;
dcl  string			builtin;
dcl  substr			builtin;
dcl  unspec			builtin;

dcl  bad_dir_			condition;

/* Parameters */

dcl  a_audit_user_info_ptr		ptr parameter;
dcl  a_bc				fixed bin (24) parameter;
dcl  a_bc_delta			fixed bin (24) parameter;
dcl  a_chase_sw			fixed bin (1) parameter;
dcl  a_code			fixed bin (35) parameter;
dcl  a_detailed_operation		fixed bin (18) uns parameter;
dcl  a_dir_uid			bit (36) aligned parameter;
dcl  a_dirname			char (168) unal parameter;
dcl  a_dp				ptr parameter;
dcl  a_entryname			char (32) unal parameter;
dcl  a_ep				ptr parameter;
dcl  a_exmode			bit (36) aligned parameter;
dcl  a_kstep			ptr parameter;
dcl  a_mode			bit (36) aligned parameter;
dcl  a_pep			ptr parameter;
dcl  a_ppep			ptr parameter;
dcl  a_ringbr			(3) fixed bin (3) parameter;
dcl  a_segptr			ptr parameter;
dcl  a_unlocksw			bit (1) aligned parameter;
dcl  a_uidpath			(0:15) bit (36) aligned parameter;

/* Constants */

dcl  FIND_ALL			bit (4) aligned init ("1111"b) static options (constant);
dcl  FIND_DIR			bit (4) aligned init ("1000"b) static options (constant);
dcl  FIND_DIR_OR_LINK		bit (4) aligned init ("1100"b) static options (constant);
dcl  FIND_LINK			bit (4) aligned init ("0100"b) static options (constant);
dcl  FIND_LINK_OR_NOTHING		bit (4) aligned init ("0110"b) static options (constant);
dcl  FIND_NOTHING			bit (4) aligned init ("0010"b) static options (constant);
dcl  FIND_OBJECT_OR_LINK		bit (4) aligned init ("1101"b) static options (constant);
dcl  FIND_SEG			bit (4) aligned init ("0001"b) static options (constant);
dcl  ME				char (7) init ("dc_find") static options (constant);
dcl  READ_LOCK			bit (36) aligned init ("0"b) static options (constant);
dcl  WRITE_LOCK			bit (36) aligned init ("1"b) static options (constant);

/* Variables */

dcl  access_checker			variable entry (ptr, bit (36) aligned, bit (36) aligned, fixed bin (35)); /* one of the access_mode$foo gets put here */
dcl  change_bc			bit (1) aligned;
dcl  chase_sw			fixed bin (1);
dcl  code				fixed bin (35);
dcl  dir_uid			bit (36) aligned;
dcl  dirmode			bit (36) aligned;
dcl  dirmode_raw			bit (1) aligned;
dcl  dirname			char (168) var;
dcl  entryname			char (32) aligned;
dcl  exmode			bit (36) aligned;
dcl  linkage_ring			fixed bin (3);
dcl  lock_for_writing		bit (36) aligned;
dcl  mode				bit (36) aligned;
dcl  1 my_makeknown_info		aligned like makeknown_info;
dcl  objmode			bit (36) aligned;
dcl  pdp				ptr;
dcl  pep				ptr;
dcl  ppdp				ptr;
dcl  ppep				ptr;
dcl  ringbr			(3) fixed bin (3);
dcl  1 sdwi			aligned like sdw_info;
dcl  segptr			ptr;
dcl  1 state			aligned,
       2 allow_searching_aim_isolated_dirs bit (1) aligned,
       2 allow_aim_isolated_final_dir	bit (1) aligned,
       2 dir_held			bit (1) aligned,
       2 dir_locked			bit (1) aligned,
       2 for_user			bit (1) aligned,	/* this is being done for someone else */
       2 parent_locked		bit (1) aligned,
       2 parent_parent_locked		bit (1) aligned,
       2 find_dir_has_work_area	bit (1) aligned,
       2 work_pathname_ptr		ptr,
       2 operation			bit (36) aligned,
       2 event_flags		bit (36) aligned,
       2 user			aligned like audit_user_info; /* user this is done for */
dcl  uidpath			(0:15) bit (36) aligned;
%page;
dir_for_append: entry (a_dirname, a_entryname, a_chase_sw, a_pep, a_dp, a_code);

/* Used by append to find a pointer into a directory into which to append.  
The dirname and entryname variables are updated to the target of the link if
chase is specified.  The directory is returned locked. */

	dirmode_raw = "0"b;
	go to dir_for_append_join;

dir_for_append_raw: entry (a_dirname, a_entryname, a_chase_sw, a_pep, a_dp, a_code);

	dirmode_raw = "1"b;				/* admin_gate_ */

dir_for_append_join:
	call dir_name_setup;
	dirmode = A_ACCESS;
	state.operation = access_operations_$fs_obj_contents_mod; /* obj creation is audited by append */
	addr (state.operation) -> encoded_access_op.detailed_operation = FS_OBJ_CREATE_BRANCH;

	entryname = a_entryname;
	lock_for_writing = "1"b;
	chase_sw = a_chase_sw;
	a_pep, pep = null;

	call find_$append;
	if code ^= 0 then go to RETURN;

	call sum$getbranch_root_my (dp, READ_LOCK, pep, code);
	if code = 0 then state.parent_locked = "1"b;
	else if code = error_table_$root then code = 0;
	else call fatal_error;
	pdp = ptr (pep, 0);

	if dirmode_raw then call access_mode$raw (pep, mode, exmode, code);
	else call get_dir_mode$locked (dp, exmode, code);
	if code ^= 0 then call fatal_error;
	if (exmode & dirmode) ^= dirmode then do;
	     call dir_control_error$append (pep, code);
	     call fatal_error;
	end;

	call audit_success$msg (pep, entryname);

	a_dirname = dirname;
	a_entryname = entryname;
	a_pep = pep;
	a_dp = dp;
	a_code = code;
	return;
%page;
dir_for_retrieve_append: entry (a_dirname, a_entryname, a_chase_sw, a_audit_user_info_ptr, a_pep, a_dp, a_code);

/* Used by append to find a pointer into a directory into which to append.  
The dirname and entryname variables are updated to the target of the link if
chase is specified.  The directory is returned locked. */

	call dir_name_setup;
	state.operation = access_operations_$fs_obj_contents_mod; /* obj creation audited by append */
	addr (state.operation) -> encoded_access_op.detailed_operation = FS_OBJ_CREATE_BRANCH;

	state.for_user = "1"b;
	state.user = a_audit_user_info_ptr -> audit_user_info;

	a_pep, pep = null;
	entryname = a_entryname;
	lock_for_writing = "1"b;
	chase_sw = a_chase_sw;

	call find_$append;
	if code ^= 0 then go to RETURN;

	call sum$getbranch_root_my (dp, READ_LOCK, pep, code);
	if code = 0 then state.parent_locked = "1"b;
	else if code = error_table_$root then code = 0;
	else call fatal_error;
	pdp = ptr (pep, 0);

	call access_mode$user_effmode (pep, state.user_id, state.authorization, (state.ring), mode, exmode, code);
	if code ^= 0 then call fatal_error;
	if (exmode & A_ACCESS) ^= A_ACCESS then do;
	     call dir_control_error$append (pep, code);
	     call fatal_error;
	end;

	call audit_success$msg (pep, entryname);

	a_dirname = dirname;
	a_entryname = entryname;
	a_pep = pep;
	a_dp = dp;
	a_code = code;
	return;
%page;
dir_initiate: entry (a_dirname, a_dp, a_code);

/* Make the dir known (set_wdir, etc.). */

	call dir_name_setup;
	state.operation = access_operations_$fs_obj_initiate;
	lock_for_writing = "0"b;

	call find_locked_dir;
	if code ^= 0 then go to RETURN;

	call sum$getbranch_root_my (dp, READ_LOCK, pep, code); /* needed for auditing */
	if code = 0 then state.parent_locked = "1"b;
	else if code = error_table_$root then code = 0;
	else call fatal_error;
	pdp = ptr (pep, 0);

	call get_dir_mode$locked (dp, exmode, code);	/* must have access to dir or parent */
	if code ^= 0 then call fatal_error;
	if exmode = "0"b then do;			/* check parent */
	     if pdp ^= null then do;
		call get_dir_mode (pdp, exmode, code);
		if code ^= 0 then call fatal_error;
	     end;
	     if exmode = "0"b then do;
		call dir_control_error$attributes (pep, code);
		call fatal_error;
	     end;
	end;

	call audit_success (pep);

	if state.parent_locked then call lock$dir_unlock (pdp); /* done with parent */

	a_dp = dp;
	a_code = code;
	return;
%page;
dir_move_quota: entry (a_dirname, a_pep, a_dp, a_code);

/* Used by quota moving.  Access checks are M on the target dir and M on the
parent.  NOTE also that the final target is allowed to be upgraded. */

	call dir_name_setup;
	state.operation = access_operations_$fs_obj_contents_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = FS_OBJ_MOVE_QUOTA;

	a_pep, pep = null;
	state.allow_aim_isolated_final_dir = "1"b;	/* This is the only known case where this is true. */
	lock_for_writing = "1"b;

	if dirname = ">" then do;
	     code = error_table_$root;
	     go to RETURN;
	end;

	call find_locked_dir;
	if code ^= 0 then go to RETURN;

	call sum$getbranch (dp, WRITE_LOCK, pep, code);
	if code ^= 0 then call fatal_error;
	pdp = ptr (pep, 0);
	state.parent_locked = "1"b;

	call get_dir_mode (pdp, exmode, code);
	if code ^= 0 then call fatal_error;
	if (exmode & M_ACCESS) ^= M_ACCESS | ^aim_check_$greater_or_equal (pep -> entry.access_class, dp -> dir.access_class) then do;
						/* user not allowed to see dir for access or aim isolated */
	     call dir_control_error$contents (pep, code);
	     call fatal_error;
	end;

	call access_mode$raw (pep, mode, exmode, code);
	if code ^= 0 then call fatal_error;
	if (exmode & M_ACCESS) ^= M_ACCESS then do;
	     call dir_control_error$contents (pep, code);
	     call fatal_error;
	end;

	call audit_success (pep);

	a_pep = pep;
	a_dp = dp;
	a_code = code;
	return;
%page;
dir_read: entry (a_dirname, a_dp, a_code);

/* These return a pointer to a locked directory.  The use of these are for 
cases in which the contents (name space, iacls) of a directory are desired.  
The access requirements are effective s access on the dir for read, m for 
write. */

	lock_for_writing = "0"b;
	dirmode = S_ACCESS;
	call dir_name_setup;
	state.operation = access_operations_$fs_obj_contents_read;
	go to dir_join;

dir_write: entry (a_dirname, a_detailed_operation, a_dp, a_code);

	lock_for_writing = "1"b;
	dirmode = M_ACCESS;
	call dir_name_setup;
	state.operation = access_operations_$fs_obj_contents_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = a_detailed_operation;
	go to dir_join;

dir_read_priv: entry (a_dirname, a_dp, a_code);

	lock_for_writing = "0"b;
	dirmode = "0"b;
	call dir_name_setup;
	state.operation = access_operations_$fs_obj_contents_read;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;
	go to dir_join;

dir_write_priv: entry (a_dirname, a_detailed_operation, a_dp, a_code);

	lock_for_writing = "1"b;
	dirmode = "0"b;
	call dir_name_setup;
	state.operation = access_operations_$fs_obj_contents_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = a_detailed_operation;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;

dir_join:
	call find_locked_dir;
	if code ^= 0 then go to RETURN;

	call sum$getbranch_root_my (dp, READ_LOCK, pep, code); /* needed for auditing */
	if code = 0 then state.parent_locked = "1"b;
	else if code = error_table_$root then code = 0;
	else call fatal_error;
	pdp = ptr (pep, 0);

	if dirmode ^= "0"b then do;
	     call get_dir_mode$locked (dp, exmode, code);
	     if code ^= 0 then call fatal_error;
	     if (exmode & dirmode) ^= dirmode then do;
		call dir_control_error$contents (pep, code);
		call fatal_error;
	     end;
	end;

	call audit_success (pep);

	if state.parent_locked then call lock$dir_unlock (pdp);

	a_dp = dp;				/* Success! */
	a_code = code;
	return;
%page;
dir_reclassify: entry (a_dirname, a_ppep, a_pep, a_dp, a_code);

/* Return a pointer to a dir, its entry and its parent's parent's entry for the
reclassify_node operation. */

	call dir_name_setup;
	state.operation = access_operations_$fs_obj_access_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = FS_OBJ_RECLASSIFY_NODE;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;
	a_pep, a_ppep, pep, ppep = null;
	lock_for_writing = "1"b;

	if dirname = ">" then do;
	     code = error_table_$root;
	     go to RETURN;
	end;

	call find_locked_dir;
	if code ^= 0 then go to RETURN;

	call sum$getbranch (dp, WRITE_LOCK, pep, code);
	if code ^= 0 then call fatal_error;
	pdp = ptr (pep, 0);
	state.parent_locked = "1"b;

	call access_mode$raw (pep, mode, exmode, code);	/* check raw mode on parent for reclassify */
	if code ^= 0 then call fatal_error;
	if (exmode & SM_ACCESS) ^= SM_ACCESS then do;
	     call dir_control_error$contents (pep, code);
	     call fatal_error;
	end;

	call sum$getbranch_root_my (pdp, READ_LOCK, ppep, code);
	if code = 0 then state.parent_parent_locked = "1"b;
	else if code = error_table_$root then code = 0;
	else call fatal_error;
	ppdp = ptr (ppep, 0);

	call access_mode$raw (ppep, mode, exmode, code);
	if code ^= 0 then call fatal_error;
	if (exmode & M_ACCESS) ^= M_ACCESS then do;
	     call dir_control_error$contents (pep, code);
	     call fatal_error;
	end;

	call audit_success (pep);

	a_ppep = ppep;
	a_pep = pep;
	a_dp = dp;
	a_code = code;
	return;
%page;
dir_salvage: entry (a_dirname, a_dir_uid, a_dp, a_code);

/* Entry used by the directory salvager.  It is like dir_write_priv except that
it uses a special locking primitive. */

	call dir_name_setup;
	state.operation = access_operations_$fs_obj_contents_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = FS_OBJ_DIR_SALVAGE;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;
	a_dir_uid = "0"b;

	call find_dir;
	if code ^= 0 then go to RETURN;

	dir.modify = "0"b;

	call lock$dir_lock_salvage (dp, dir_uid, code);
	if code ^= 0 then call fatal_error;

	call sum$getbranch_root_my (dp, READ_LOCK, pep, code); /* needed for auditing */
	if code = 0 then state.parent_locked = "1"b;
	else if code = error_table_$root then code = 0;
	else call fatal_error;
	pdp = ptr (pep, 0);

	call audit_success (pep);

	if state.parent_locked then call lock$dir_unlock (pdp);

	a_dir_uid = dir_uid;
	a_dp = dp;				/* Success! */
	a_code = code;
	return;
%page;
mdir_set_quota_uid: entry (a_uidpath, a_dirname, a_detailed_operation, a_pep, a_dp, a_code);

/* Returns a pointer to a directory when given a uid path.  Access requirements
are M on the dir. It is used by quota$mdir_set. */

	unspec (state) = "0"b;
	state.operation = access_operations_$fs_obj_contents_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = a_detailed_operation;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;
	state.allow_aim_isolated_final_dir = "1"b;

	dirmode = M_ACCESS;
	a_pep, pdp, pep, ep, a_dp, dp = null;
	code = 0;
	uidpath = a_uidpath;
	lock_for_writing = "0"b;			/* parent dir is not beign modified */

	call uid_path_util$find_dir;
	if code = error_table_$root then a_dirname = dirname; /* Return name so far */
	if code ^= 0 then go to RETURN;

	call lock$dir_lock_write (dp, code);
	if code ^= 0 then call fatal_error;
	state.dir_locked = "1"b;

	call sum$getbranch (dp, lock_for_writing, pep, code);
	if code ^= 0 then call fatal_error;
	pdp = ptr (pep, 0);
	state.parent_locked = "1"b;

	call access_mode$raw (pep, mode, exmode, code);
	if code ^= 0 then call fatal_error;
	if (exmode & dirmode) ^= dirmode then do;
	     call dir_control_error$contents (pep, code);
	     call fatal_error;
	end;

	call audit_success (pep);

	a_dirname = dirname;
	a_pep = pep;
	a_dp = dp;
	a_code = 0;
	return;
%page;
finished: entry (a_ep, a_unlocksw);

/* Undoes the result of a previous dc_find (non-ptr) call.  It unlocks the dir 
specified (if unlocksw is set) and dereferences the dir.  The proper 
termination for a directory found through a _ptr entry is to call 
lock$dir_unlock on it. */

	ep = a_ep;
	if ep ^= null then do;
	     if a_unlocksw then call lock$dir_unlock (ptr (ep, 0));
	     call segno_usage$decrement (segno (ep), (0));
	end;
	return;
%page;
link_target: entry (a_dirname, a_entryname, a_code);

/* Returns the path of the target of the (possible) link.  The user must have 
non-null access to the target dir or non-null access to the target (if it 
exists). */

	unspec (state) = "0"b;
	state.operation = access_operations_$fs_obj_prop_read;

	code = 0;
	dirname = rtrim (a_dirname);
	entryname = a_entryname;
	lock_for_writing = "0"b;

	call find_$link_target;
	if code ^= 0 then go to RETURN;

	if ep ^= null then do;			/* a target exists */
	     call get_dir_mode (dp, exmode, code);
	     if code ^= 0 then call fatal_error;
	     if exmode = N_ACCESS then do;		/* no dir access, check entry */
		call access_mode$effective (ep, mode, exmode, code);
		if code ^= 0 then call fatal_error;
		if ep -> entry.dirsw then mode = exmode;
		if mode = N_ACCESS then do;		/* null on both target dir and target */
		     call dir_control_error$attributes (ep, code);
		     call fatal_error;
		end;
	     end;

	     call audit_success (ep);
	end;
	else do;
	     state.operation = access_operations_$fs_obj_contents_read; /* reading names in dir */

	     call sum$getbranch_root_my (dp, READ_LOCK, pep, code); /* needed for auditing */
	     if code = 0 then state.parent_locked = "1"b;
	     else if code = error_table_$root then code = 0;
	     else call fatal_error;
	     pdp = ptr (pep, 0);

	     call get_dir_mode$locked (dp, exmode, code);
	     if code ^= 0 then call fatal_error;
	     if exmode = N_ACCESS then do;
		code = error_table_$no_info;
		call dir_control_error$name_non_existant (dp, code);
		call fatal_error;
	     end;

	     call audit_success (pep);

	     if state.parent_locked then call lock$dir_unlock (pdp);

	     code = error_table_$noentry;		/* tell of non-existance */
	end;

	call lock$dir_unlock (dp);
	call segno_usage$decrement (segno (dp), (0));	/* done with dir */

	a_dirname = dirname;
	a_entryname = entryname;
	a_code = code;
	return;
%page;
obj_attributes_read: entry (a_dirname, a_entryname, a_chase_sw, a_ep, a_code);

/* Return a pointer to an entry in a locked directory.  These entries are used 
when the attributes of an object (such as ring brackets) are desired that are
accessible for either effective s access on the parent dir or non-null access 
on the object (for read) or for m access on the parent dir or w/m access on 
the object (for write). */

	lock_for_writing = "0"b;
	dirmode = S_ACCESS;
	call obj_name_setup;
	state.operation = access_operations_$fs_obj_prop_read;
	go to obj_attributes_name_join;

obj_attributes_write: entry (a_dirname, a_entryname, a_chase_sw, a_detailed_operation, a_ep, a_code);

	lock_for_writing = "1"b;
	dirmode = M_ACCESS;
	call obj_name_setup;
	state.operation = access_operations_$fs_obj_attr_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = a_detailed_operation;
	go to obj_attributes_name_join;

obj_terminate: entry (a_dirname, a_entryname, a_chase_sw, a_ep, a_code);

	lock_for_writing = "0"b;
	dirmode = N_ACCESS;
	call obj_name_setup;
	state.operation = access_operations_$fs_obj_terminate;

obj_attributes_name_join:
	chase_sw = a_chase_sw;

	call find_;
	if code ^= 0 then go to RETURN;
	go to obj_attributes_join;

obj_existence_ptr: entry (a_segptr, a_ep, a_code);

	lock_for_writing = "0"b;
	dirmode = N_ACCESS;
	call obj_ptr_setup;
	state.operation = access_operations_$fs_obj_prop_read;
	go to obj_attributes_ptr_join;

obj_terminate_ptr: entry (a_segptr, a_ep, a_code);

	lock_for_writing = "0"b;
	dirmode = N_ACCESS;
	call obj_ptr_setup;
	state.operation = access_operations_$fs_obj_terminate;
	go to obj_attributes_ptr_join;

obj_attributes_read_ptr: entry (a_segptr, a_ep, a_code);

	lock_for_writing = "0"b;
	dirmode = S_ACCESS;
	call obj_ptr_setup;
	state.operation = access_operations_$fs_obj_prop_read;
	go to obj_attributes_ptr_join;

obj_attributes_write_ptr: entry (a_segptr, a_detailed_operation, a_ep, a_code);

	lock_for_writing = "1"b;
	dirmode = M_ACCESS;
	call obj_ptr_setup;
	state.operation = access_operations_$fs_obj_attr_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = a_detailed_operation;

obj_attributes_ptr_join:
	call find_segptr_branch;
	if code ^= 0 then
	     if code = error_table_$root & state.operation = access_operations_$fs_obj_terminate then go to obj_attribute_success;
	     else go to SEGPTR_FAILURE;

obj_attributes_join:
	call get_dir_mode (dp, exmode, code);
	if code ^= 0 then call fatal_error;
	if (exmode & dirmode) = dirmode then
	     if exmode = N_ACCESS then go to obj_attributes_check_target; /* dirmode of N_ACCESS can also bring us here */
	     else ;
	else do;					/* wrong parent access, check for access on target */
obj_attributes_check_target:
	     if ^ep -> entry.bs then go to obj_attributes_error; /* link */
	     if state.dir_held then			/* path entry */
		call access_mode$effective (ep, mode, exmode, code);
	     else call fs_modes$locked (segptr, mode, exmode, ringbr, code);
	     if code ^= 0 then call fatal_error;
	     if dirmode = M_ACCESS then do;		/* we need m/w if we do not have m on parent */
		if ep -> entry.dirsw then
		     if (exmode & M_ACCESS) ^= M_ACCESS then go to obj_attributes_error;
		     else ;
		else if (mode & W_ACCESS) ^= W_ACCESS then go to obj_attributes_error;
		else ;
	     end;
	     else do;				/* we'll allow since user has non-null on object */
		if ep -> entry.dirsw then mode = exmode;
		if mode = N_ACCESS then do;
obj_attributes_error:    call dir_control_error$attributes (ep, code);
		     call fatal_error;
		end;
		else ;
	     end;
	end;

obj_attribute_success:
	call audit_success (ep);

	a_ep = ep;				/* Success! */
	a_code = code;
	return;
%page;
obj_bc_delta_write: entry (a_dirname, a_entryname, a_bc_delta, a_ep, a_code);

/* Return a pointer to a directory entry.  These entries are called when the
caller wishes to change the bit_coount for an object.  The delta entries are 
called when the bit_count is to added to/subtracted from; the non-delta when
bc is to be set.  These entries have strange access requirements; w if a 
segment; for a directory, m if lowering the bc, a if increasing. */

	change_bc = "1"b;
	go to obj_bc_name_join;

obj_bc_write: entry (a_dirname, a_entryname, a_bc, a_ep, a_code);

	change_bc = "0"b;

obj_bc_name_join:
	call obj_name_setup;
	state.operation = access_operations_$fs_obj_contents_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = FS_OBJ_BC_MOD;
	lock_for_writing = "1"b;
	chase_sw = DC_FIND_CHASE;

	call find_;
	if code ^= 0 then go to RETURN;

	call access_mode$effective (ep, mode, exmode, code);
	if code ^= 0 then call fatal_error;
	go to obj_bc_join;

obj_bc_delta_write_ptr: entry (a_segptr, a_bc_delta, a_ep, a_code);

	change_bc = "1"b;
	go to obj_bc_ptr_join;

obj_bc_write_ptr: entry (a_segptr, a_bc, a_ep, a_code);

	change_bc = "0"b;

obj_bc_ptr_join:
	lock_for_writing = "1"b;

	call obj_ptr_setup;
	state.operation = access_operations_$fs_obj_contents_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = FS_OBJ_BC_MOD;

	call find_segptr_branch;
	if code ^= 0 then go to SEGPTR_FAILURE;

	call fs_modes$locked (segptr, mode, exmode, ringbr, code);
	if code ^= 0 then call fatal_error;

obj_bc_join:
	if ep -> entry.dirsw then do;
	     mode = exmode;
	     if change_bc then
		if a_bc_delta <= 0 then objmode = M_ACCESS; /* viewed as deleting components of msf */
		else objmode = A_ACCESS;		/* adding components */
	     else if ep -> entry.bc >= a_bc then objmode = M_ACCESS;
	     else objmode = A_ACCESS;
	end;
	else objmode = W_ACCESS;
	if (mode & objmode) ^= objmode then do;
	     call dir_control_error$contents (ep, code);
	     call fatal_error;
	end;

	call audit_success (ep);

	a_ep = ep;
	a_code = code;
	return;
%page;
obj_for_audit: entry (a_dirname, a_entryname, a_ep, a_code);

/* Returns a pointer to an entry in a locked directory.  No access check or
auditing are done, in as much as access_audit_ is calling us so that it can
audit somthing about the path supplied. */

	lock_for_writing = "0"b;
	call obj_name_setup;
	state.operation = access_operations_$fs_obj_prop_read; /* in case something goes wrong */
	chase_sw = DC_FIND_NO_CHASE;

	call find_;
	if code ^= 0 then go to RETURN;

	a_ep = ep;
	a_code = code;
	return;
%page;
obj_initiate: entry (a_dirname, a_entryname, a_ep, a_code);

/* Returns the entry pointer for the initiate function.  The access check is
non-null on the object.  The _dp versions take a directory pointer instead
of a directory name.  For these (used by fs_search), a simple dir look-up is
done.  If the object found is a link, though, we must perform a normal
branch lookup.  In this case, a_dp is set to null, warning the user that
his dp is no longer good and that finished must be called.  The raw version
only checks raw access on the target;  it also simulates dir priv by ignoring
the upgradedness of directories when searching them.  The auth version uses 
authorization access. */

	call obj_name_setup;
	state.operation = access_operations_$fs_obj_initiate;

	access_checker = access_mode$effective;
	go to initiate_name_join;

obj_initiate_raw: entry (a_dirname, a_entryname, a_ep, a_code);

	call obj_name_setup;
	state.operation = access_operations_$fs_obj_initiate;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;

	state.allow_searching_aim_isolated_dirs = "1"b;
	access_checker = access_mode$raw;

initiate_name_join:
	lock_for_writing = "0"b;
	chase_sw = DC_FIND_CHASE;

	call find_;
	if code = 0 then ;
	else if code = error_table_$root then do;
	     dp, ep = null;
	     code = 0;
	end;
	else go to RETURN;
	go to initiate_join;

obj_initiate_for_linker_dp: entry (a_dp, a_entryname, a_ep, a_code);

/* NOTE: we have a contract that the only caller of this is initiate_seg_count,
which in turn is only called by fs_search.  Since this is the case, we perform
an optimization that throws away information (providing no security 
violation).  For this entry, we merge the non-existance of the target with
no_info access to the target and call the result no_info in both cases. */

	unspec (state) = "0"b;
	state.operation = access_operations_$fs_obj_initiate;

	access_checker = access_mode$effective;

	lock_for_writing = "0"b;
	a_ep, ep = null;
	dp = a_dp;
	entryname = a_entryname;
	code = 0;

	call lock$dir_lock_read (dp, code);
	if code ^= 0 then go to RETURN;
	state.dir_locked = "1"b;

	call find_entry (dp, entryname, FIND_ALL, ep, code);
	if code ^= 0 then call fatal_error;
	if ep = null then do;			/* no such name */
	     code = error_table_$no_info;		/* don't bother distinguishing this from no_entry, fs_search doesn't care */
	     call fatal_error;
	end;

	if ^ep -> entry.bs then do;			/* link */
	     dirname = rtrim (substr (ep -> link.pathname, 1, ep -> link.pathname_size));
	     entryname = "";
	     call lock$dir_unlock (dp);
	     state.dir_locked = "0"b;
	     a_dp = null;				/* tell user his dp isn't good anymore; finished must be called */
	     call find_$link_target;
	     if code = 0 then do;
		if ep = null then do;		/* no such target */
		     code = error_table_$no_info;	/* don't bother distinguishing this from no_entry, fs_search doesn't care */
		     call fatal_error;
		end;
	     end;
	     else if code = error_table_$root then do;
		dp, ep = null;
		code = 0;
	     end;
	     else go to RETURN;
	end;

initiate_join:
	call access_checker (ep, mode, exmode, code);
	if code ^= 0 then call fatal_error;

/* We allow initiating dirs only if the mode and exmode are non_null. */

	if ep = null then				/* root */
	     if exmode = "0"b then go to obj_initiate_error;
	     else ;
	else if ep -> entry.dirsw then
	     if exmode = "0"b then go to obj_initiate_error;

	if mode = "0"b then do;
obj_initiate_error:
	     if ep = null then code = error_table_$dirseg;/* not nice to ask for root */
	     else if ep -> entry.dirsw then do;
		call dir_control_error$contents_info (ep, code); /* asking for dir is not considered a real violation */
		if code = error_table_$moderr then code = error_table_$dirseg;
	     end;
	     else call dir_control_error$contents (ep, code);
	     call fatal_error;
	end;

	call audit_success (ep);

	a_ep = ep;
	a_code = code;
	return;
%page;
obj_linkage_ring_ptr: entry (a_segptr, a_code);

/* Allows a user process to read the definitions for a lower ring gate by
lowering the ring number in the supplied pointer from within the call bracket 
into the read bracket. */

	unspec (state) = "0"b;
	state.operation = access_operations_$fs_obj_contents_read;

	ep = null;
	code = 0;
	segptr = a_segptr;

	lock_for_writing = "0"b;

	call find_segptr_branch;
	if code ^= 0 then go to SEGPTR_FAILURE;

	call fs_modes$locked (segptr, mode, exmode, ringbr, code);
	if code ^= 0 then call fatal_error;

	if (mode & E_ACCESS) ^= E_ACCESS then do;
	     call dir_control_error$attributes (ep, code);
	     call fatal_error;
	end;

	call audit_success (ep);

	call lock$dir_unlock (dp);

	linkage_ring = min (level$get (), ringbr (2));	/* let read through call bracket */

	addr (a_segptr) -> its_unsigned.ringno = linkage_ring;
	a_code = code;
	return;
%page;
obj_modes_ptr: entry (a_segptr, a_mode, a_exmode, a_ringbr, a_code);

/* Return the access modes the process has to the object, assuming it has some
access. */

	unspec (state) = "0"b;
	state.operation = access_operations_$fs_obj_prop_read;
	ep = null;
	code = 0;
	segptr = a_segptr;

	lock_for_writing = "0"b;

	call sum$getbranch_root_my (segptr, lock_for_writing, ep, code);
	if code ^= 0 then
	     if code = error_table_$root then do;
		code = 0;
		ep = null;
	     end;
	     else go to SEGPTR_FAILURE;
	else do;
	     dp = ptr (ep, 0);
	     state.dir_locked = "1"b;
	end;

	call fs_modes$locked (segptr, mode, exmode, ringbr, code);
	if code ^= 0 then call fatal_error;

	if ep = null then do;
	     mode = exmode;				/* root */
	     exmode = "0"b;
	end;
	else if ep -> entry.dirsw then do;
	     mode = exmode;				/* dir */
	     exmode = "0"b;
	end;

	if mode = "0"b then do;			/* make sure user is allowed to see no access */
	     if ep = null then dirmode = "0"b;		/* root */
	     else do;
		call get_dir_mode (dp, dirmode, code);
		if code ^= 0 then call fatal_error;
	     end;
	     if (dirmode & S_ACCESS) ^= S_ACCESS then do;
		call dir_control_error$attributes (ep, code);
		call fatal_error;
	     end;
	end;

	call audit_success (ep);

	if ep -> entry.dirsw then code = error_table_$dirseg;
	if state.dir_locked then call lock$dir_unlock (dp);

	a_mode = mode;
	a_exmode = exmode;
	a_ringbr = ringbr;
	a_code = code;
	return;
%page;
obj_reclassify: entry (a_dirname, a_entryname, a_pep, a_ep, a_code);

/* Return a pointer to a directory entry and its parent entry for the 
reclassify operation. */

	call obj_name_setup;
	state.operation = access_operations_$fs_obj_access_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = FS_OBJ_RECLASSIFY;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;

	lock_for_writing = "1"b;
	a_pep, pep = null;
	chase_sw = DC_FIND_NO_CHASE;

	call find_;
	if code ^= 0 then go to RETURN;

	call sum$getbranch_root_my (dp, READ_LOCK, pep, code);
	if code = 0 then state.parent_locked = "1"b;
	else if code = error_table_$root then code = 0;	/* dep is null but access_mode understands this */
	else call fatal_error;
	pdp = ptr (pep, 0);

	call access_mode$raw (pep, mode, exmode, code);	/* check raw mode on parent for reclassify */
	if code ^= 0 then call fatal_error;
	if (exmode & M_ACCESS) ^= M_ACCESS then do;
	     call dir_control_error$attributes (pep, code);
	     call fatal_error;
	end;

	call audit_success (ep);

	a_pep = pep;
	a_ep = ep;
	a_code = code;
	return;
%page;
obj_status_attributes_read: entry (a_dirname, a_entryname, a_chase_sw, a_ep, a_code);

/* Same as obj_attributes_read except that it returns the code no_s_permission 
if this is the case.  It is used by the status_ and status_long functions. */

	call obj_name_setup;
	state.operation = access_operations_$fs_obj_prop_read;

	lock_for_writing = "0"b;
	dirmode = S_ACCESS;
	chase_sw = a_chase_sw;

	call find_;
	if code ^= 0 then go to RETURN;

	call get_dir_mode (dp, exmode, code);
	if code ^= 0 then call fatal_error;
	if (exmode & dirmode) ^= dirmode then do;
	     if ep -> entry.bs then do;
		call access_mode$effective (ep, mode, exmode, code); /* look for non-null on object */
		if code ^= 0 then call fatal_error;
		if ep -> entry.dirsw then mode = exmode;
		if mode = N_ACCESS then do;
		     call dir_control_error$attributes (ep, code); /* We have no access on object; check access on parent dir for error code. */
		     call fatal_error;
		end;
		else call dir_control_error$status (ep, code); /* audit partial lack of access, return ep anyway */
	     end;
	     else do;
		call dir_control_error$attributes (ep, code); /* link */
		call fatal_error;
	     end;
	end;

	call audit_success (ep);

	a_ep = ep;				/* Success! */
	a_code = code;
	return;
%page;
obj_status_read: entry (a_dirname, a_entryname, a_chase_sw, a_ep, a_code);

/* Returns a pointer to an entry in a locked directory.  These entries are used
when the attributes of an object that are considered as belonging to the 
parent dir (acls, names) are desired.  The access requirements are effective s 
access on the dir for read, m for write. */

	lock_for_writing = "0"b;
	dirmode = S_ACCESS;
	call obj_name_setup;
	state.operation = access_operations_$fs_obj_prop_read;
	go to obj_status_name_join;

obj_status_read_priv: entry (a_dirname, a_entryname, a_chase_sw, a_ep, a_code);

	lock_for_writing = "0"b;
	dirmode = "0"b;
	call obj_name_setup;
	state.operation = access_operations_$fs_obj_prop_read;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;
	go to obj_status_name_join;

obj_access_write: entry (a_dirname, a_entryname, a_chase_sw, a_detailed_operation, a_ep, a_code);

	lock_for_writing = "1"b;
	dirmode = M_ACCESS;
	call obj_name_setup;
	state.operation = access_operations_$fs_obj_access_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = a_detailed_operation;
	go to obj_status_name_join;

obj_access_write_priv: entry (a_dirname, a_entryname, a_chase_sw, a_detailed_operation, a_ep, a_code);

	lock_for_writing = "1"b;
	dirmode = "0"b;
	call obj_name_setup;
	state.operation = access_operations_$fs_obj_access_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = a_detailed_operation;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;
	go to obj_status_name_join;

obj_delete: entry (a_dirname, a_entryname, a_chase_sw, a_ep, a_code);

	lock_for_writing = "1"b;
	dirmode = M_ACCESS;
	call obj_name_setup;
	state.operation = access_operations_$fs_obj_delete;
	go to obj_status_name_join;

obj_status_write: entry (a_dirname, a_entryname, a_chase_sw, a_detailed_operation, a_ep, a_code);

	lock_for_writing = "1"b;
	dirmode = M_ACCESS;
	call obj_name_setup;
	state.operation = access_operations_$fs_obj_status_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = a_detailed_operation;
	go to obj_status_name_join;

obj_delete_priv: entry (a_dirname, a_entryname, a_chase_sw, a_ep, a_code);

	lock_for_writing = "1"b;
	dirmode = "0"b;
	call obj_name_setup;
	state.operation = access_operations_$fs_obj_delete;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;
	go to obj_status_name_join;

obj_status_write_priv: entry (a_dirname, a_entryname, a_chase_sw, a_detailed_operation, a_ep, a_code);

	lock_for_writing = "1"b;
	dirmode = "0"b;
	call obj_name_setup;
	state.operation = access_operations_$fs_obj_status_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = a_detailed_operation;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;

obj_status_name_join:
	chase_sw = a_chase_sw;

	call find_;
	if code ^= 0 then go to RETURN;
	go to obj_status_join;

obj_status_read_ptr: entry (a_segptr, a_ep, a_code);

	lock_for_writing = "0"b;
	dirmode = S_ACCESS;
	call obj_ptr_setup;
	state.operation = access_operations_$fs_obj_prop_read;
	go to obj_status_ptr_join;

obj_status_read_priv_ptr: entry (a_segptr, a_ep, a_code);

	lock_for_writing = "0"b;
	dirmode = "0"b;
	call obj_ptr_setup;
	state.operation = access_operations_$fs_obj_prop_read;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;
	go to obj_status_ptr_join;

obj_delete_ptr: entry (a_segptr, a_ep, a_code);

	lock_for_writing = "1"b;
	dirmode = M_ACCESS;
	call obj_ptr_setup;
	state.operation = access_operations_$fs_obj_delete;
	go to obj_status_ptr_join;

obj_status_write_ptr: entry (a_segptr, a_detailed_operation, a_ep, a_code);

	lock_for_writing = "1"b;
	dirmode = M_ACCESS;
	call obj_ptr_setup;
	state.operation = access_operations_$fs_obj_status_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = a_detailed_operation;
	go to obj_status_ptr_join;

obj_status_write_priv_ptr: entry (a_segptr, a_detailed_operation, a_ep, a_code);

	lock_for_writing = "1"b;
	dirmode = "0"b;
	call obj_ptr_setup;
	state.operation = access_operations_$fs_obj_status_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = a_detailed_operation;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;

obj_status_ptr_join:
	call find_segptr_branch;
	if code ^= 0 then go to SEGPTR_FAILURE;

obj_status_join:
	if dirmode ^= "0"b then do;
	     call get_dir_mode (dp, exmode, code);
	     if code ^= 0 then call fatal_error;
	     if (exmode & dirmode) ^= dirmode then do;
		call dir_control_error$attributes (ep, code);
		call fatal_error;
	     end;
	end;

	call audit_success (ep);

	a_ep = ep;				/* Success! */
	a_code = code;
	return;
%page;
obj_status_read_uid: entry (a_uidpath, a_dirname, a_entryname, a_ep, a_code);

/* Like obj_status_read/write but are given a uid path. */


	lock_for_writing = "0"b;
	dirmode = S_ACCESS;
	unspec (state) = "0"b;
	state.operation = access_operations_$fs_obj_prop_read;
	go to obj_status_uid_join;

obj_status_read_priv_uid: entry (a_uidpath, a_dirname, a_entryname, a_ep, a_code);

	lock_for_writing = "0"b;
	dirmode = "0"b;
	unspec (state) = "0"b;
	state.operation = access_operations_$fs_obj_prop_read;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;
	go to obj_status_uid_join;

obj_status_read_raw_uid: entry (a_uidpath, a_dirname, a_entryname, a_ep, a_code);

	lock_for_writing = "0"b;
	dirmode = "0"b;
	unspec (state) = "0"b;
	state.operation = access_operations_$fs_obj_prop_read;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;
	state.allow_searching_aim_isolated_dirs = "1"b;


obj_status_uid_join:
	a_ep, ep = null;
	code = 0;
	uidpath = a_uidpath;

	call uid_path_util$find_entry;
	if code = error_table_$root then do;
	     a_dirname = dirname;			/* Return name so far */
	     go to RETURN;
	end;
	if code = error_table_$bad_uidpath then do;
	     if addr (state.event_flags) -> audit_event_flags.priv_op then
		a_dirname = dirname;		/* Return name so far if allowed */
	     go to RETURN;
	end;
	if code ^= 0 then go to RETURN;

	if dirmode ^= "0"b then do;			/* access required? */
	     /*** need to check access to object's parent */
	     call get_dir_mode (dp, exmode, code);
	     if code ^= 0 then call fatal_error;
	     if (exmode & dirmode) ^= dirmode then do;
		/*** not enough on parent, check entry (a dir itself) */
		call access_mode$effective (ep, mode, exmode, code);
		if code ^= 0 then call fatal_error;
		if exmode = "0"b then do;		/* any access would've been OK */
		     call dir_control_error$attributes (ep, code);
		     call fatal_error;
		end;
	     end;
	end;

	call audit_success (ep);

	a_dirname = dirname;
	a_entryname = entryname;
	a_ep = ep;
	a_code = code;
	return;
%page;
obj_delete_uid: entry (a_uidpath, a_dirname, a_entryname, a_ep, a_code);

	lock_for_writing = "1"b;
	dirmode = M_ACCESS;
	unspec (state) = "0"b;
	state.operation = access_operations_$fs_obj_delete;
	goto obj_delete_uid_join;

obj_delete_priv_uid: entry (a_uidpath, a_dirname, a_entryname, a_ep, a_code);

	lock_for_writing = "1"b;
	dirmode = "0"b;
	unspec (state) = "0"b;
	state.operation = access_operations_$fs_obj_delete;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;


obj_delete_uid_join:
	a_ep, ep = null;
	code = 0;
	uidpath = a_uidpath;

	call uid_path_util$find_entry;
	if code = error_table_$root then do;
	     a_dirname = dirname;			/* Return name so far */
	     go to RETURN;
	end;
	if code = error_table_$bad_uidpath then do;
	     if addr (state.event_flags) -> audit_event_flags.priv_op then
		a_dirname = dirname;		/* Return name so far if allowed */
	     go to RETURN;
	end;
	if code ^= 0 then go to RETURN;

	if dirmode ^= "0"b then do;
	     /*** need to check access to object's parent */
	     call get_dir_mode (dp, exmode, code);
	     if code ^= 0 then call fatal_error;
	     if (exmode & dirmode) ^= dirmode then do;
		call dir_control_error$attributes (ep, code);
		call fatal_error;
	     end;
	end;

	call audit_success (ep);

	a_dirname = dirname;
	a_entryname = entryname;
	a_ep = ep;
	a_code = code;
	return;
%page;
obj_truncate: entry (a_dirname, a_entryname, a_ep, a_code);

/* Returns a ptr to a directory entry when we want to truncate the object at 
hand.  Truncate has its own peculiarities in auditing.  The main access check 
is "w" on the target.  The raw entries ask for raw "w" on the target, as 
opposed to no requirement at all. */

	call obj_name_setup;
	state.operation = access_operations_$fs_obj_contents_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = FS_OBJ_TRUNCATE;

	lock_for_writing = "1"b;
	chase_sw = DC_FIND_CHASE;

	call find_;
	if code ^= 0 then go to RETURN;

	call access_mode$effective (ep, mode, exmode, code);
	if code ^= 0 then call fatal_error;
	go to obj_truncate_join;

obj_truncate_ptr: entry (a_segptr, a_ep, a_code);

	call obj_ptr_setup;
	state.operation = access_operations_$fs_obj_contents_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = FS_OBJ_TRUNCATE;

	lock_for_writing = "1"b;
	call find_segptr_branch;
	if code ^= 0 then go to SEGPTR_FAILURE;

	call fs_modes$locked (segptr, mode, exmode, ringbr, code);
	if code ^= 0 then call fatal_error;
	go to obj_truncate_join;

obj_truncate_raw_ptr: entry (a_segptr, a_ep, a_code);

	call obj_ptr_setup;
	state.operation = access_operations_$fs_obj_contents_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = FS_OBJ_TRUNCATE;
	addr (state.event_flags) -> audit_event_flags.priv_op = "1"b;

	lock_for_writing = "1"b;
	call find_segptr_branch;
	if code ^= 0 then go to SEGPTR_FAILURE;

	call access_mode$raw (ep, mode, exmode, code);
	if code ^= 0 then call fatal_error;

obj_truncate_join:
	objmode = W_ACCESS;
	if (mode & objmode) ^= objmode then do;
	     if ep -> entry.copysw then call dir_control_error$contents_info (ep, code); /* don't audit; user can make a copy to truncate */
	     else call dir_control_error$contents (ep, code);
	     if ep -> entry.dirsw then		/* MSF? */
		if code = error_table_$moderr then code = error_table_$dirseg;
	     call fatal_error;
	end;

	call audit_success (ep);

	a_ep = ep;
	a_code = code;
	return;
%page;
obj_volume_retrieve: entry (a_dirname, a_entryname, a_audit_user_info_ptr, a_ep, a_code);

/* Follows the unique access checks pertenant to the volume retriever. */

	call obj_name_setup;
	state.operation = access_operations_$fs_obj_contents_mod;
	addr (state.operation) -> encoded_access_op.detailed_operation = FS_OBJ_VOLUME_RETRIEVE;

	state.for_user = "1"b;
	state.user = a_audit_user_info_ptr -> audit_user_info;

	lock_for_writing = "0"b;
	chase_sw = DC_FIND_NO_CHASE;

	call find_;				/* modifying object contents, not entry */
	if code ^= 0 then go to RETURN;

	call access_mode$user_effmode (ep, state.user_id, state.authorization, (state.ring), mode, exmode, code);
	if code ^= 0 then call fatal_error;
	if ep -> entry.dirsw then do;
	     mode = exmode;
	     objmode = SM_ACCESS;
	end;
	else objmode = RW_ACCESS;
	if (mode & objmode) ^= objmode then do;		/* look at parent's mode */
	     call sum$getbranch (dp, READ_LOCK, pep, code);
	     if code ^= 0 then call fatal_error;
	     pdp = ptr (pep, 0);
	     state.parent_locked = "1"b;

	     call access_mode$user_effmode (pep, state.user_id, state.authorization, (state.ring), mode, exmode, code);
	     call lock$dir_unlock (pdp);		/* done with parent */
	     state.parent_locked = "0"b;
	     if code ^= 0 then call fatal_error;
	     if (exmode & SM_ACCESS) ^= SM_ACCESS then do;
		call dir_control_error$contents (ep, code);
		call fatal_error;
	     end;
	end;

	call audit_success (ep);

	a_ep = ep;
	a_code = code;
	return;
%page;
seg_fault: entry (a_kstep, a_ep, a_code);

/* Compute the sdw access fields and generate an error if the process has
null authorization access to the segment.  This is used by seg_fault.
The finding of the directory entry pointer is done in seg_fault so as to 
minimize the number of stack frames pushed when recursive seg faults are 
taken referencing the parent dir. */

	unspec (state) = "0"b;
	state.operation = access_operations_$fs_obj_contents_read;

	code = 0;
	kstep = a_kstep;
	ep = a_ep;

	if ep = null then do;
	     code = error_table_$seg_deleted;
	     call dir_control_error$name_non_existant (ptr (kstep -> kste.entryp, 0), code);
	     go to RETURN;
	end;

	if ep -> entry.dirsw then go to RETURN;		/* dir access is special cased in seg_fault */

	if kstep -> kste.dtbm ^= ep -> entry.dtem then	/* entry change, recompute access */
	     call update_kste_access (kstep, ep, mode);
	else mode = kstep -> kste.access;		/* else kste mode is good (possibly from a previous fs_modes call) */

	if mode = "0"b then do;
	     call dir_control_error$contents (ep, code);
	     go to RETURN;
	end;

	call sdw_util_$dissect (addr (dseg$ (kstep -> kste.segno)), addr (sdwi)); /* Take it apart to set access */

	if (mode & W_ACCESS) then do;
	     state.operation = access_operations_$fs_obj_contents_mod;
	     addr (state.operation) -> encoded_access_op.detailed_operation = FS_OBJ_CONNECT;
	end;

	if mode ^= string (sdwi.access) |
	     sdwi.r1 ^= ep -> entry.ring_brackets (1) |
	     sdwi.r2 ^= ep -> entry.ring_brackets (2) |
	     sdwi.r3 ^= ep -> entry.ring_brackets (3) then call audit_success (ep);

	sdwi.r1 = ep -> entry.ring_brackets (1);	/* Rings and access mode from the branch */
	sdwi.r2 = ep -> entry.ring_brackets (2);
	sdwi.r3 = ep -> entry.ring_brackets (3);

	string (sdwi.access) = substr (mode, 1, 4);
	if ^kstep -> kste.allow_write then sdwi.write = "0"b; /* Don't allow write access, no way */

	call sdw_util_$construct (addr (dseg$ (kstep -> kste.segno)), addr (sdwi)); /* Put it back together */

	a_code = code;
	return;
%page;
dir_name_setup: proc;

	unspec (state) = "0"b;
	a_dp, dp = null;
	code = 0;
	dirname = rtrim (a_dirname);
	return;
     end;

fatal_error: proc;

	if state.parent_parent_locked then call lock$dir_unlock (ppdp);
	if state.parent_locked then call lock$dir_unlock (pdp);
	if state.dir_locked then call lock$dir_unlock (dp);
	if state.dir_held then call segno_usage$decrement (segno (dp), (0));
	go to RETURN;
     end fatal_error;

obj_name_setup: proc;

	unspec (state) = "0"b;
	a_ep, ep = null;
	code = 0;
	dirname = rtrim (a_dirname);
	entryname = a_entryname;
	return;
     end;

obj_ptr_setup: proc;

	unspec (state) = "0"b;
	a_ep, ep = null;
	code = 0;
	segptr = a_segptr;
	return;
     end;
%page;
SEGPTR_FAILURE:
	if code = error_table_$seg_deleted then do;
	     call get_kstep (segno (segptr), kstep, code);
	     if code = 0 then do;
		state.operation = access_operations_$fs_obj_contents_read; /* audit failure as attempt to read names */
		code = error_table_$seg_deleted;
		call dir_control_error$name_non_existant (ptr (kstep -> kste.entryp, 0), code);
	     end;
	end;

RETURN:	a_code = code;
	return;
%page;
audit_success$msg: proc (a_ep, a_message);

dcl  a_ep				ptr parameter;
dcl  a_message			char (32) aligned parameter;

dcl  audit			bit (1) aligned;
dcl  ep				ptr;
dcl  message			char (32);

	addr (state.event_flags) -> audit_event_flags.grant = "1"b;
	message = a_message;
	go to check_audit;

audit_success: entry (a_ep);

	addr (state.event_flags) -> audit_event_flags.grant = "1"b;

audit_failure: entry (a_ep);

	message = "";
check_audit:
	ep = a_ep;
	if state.for_user then audit =
		access_audit_check_ep_$user (state.event_flags, state.operation, ep, state.user.authorization, state.user.audit_flags);
	else audit =
		access_audit_check_ep_$self (state.event_flags, state.operation, ep);
	if audit then
	     if state.for_user then
		call access_audit_$log_entry_ptr_user (ME, (state.ring), state.event_flags, state.operation, ep, code, null, 0, addr (state.user), message);
	     else call access_audit_$log_entry_ptr (ME, level$get (), state.event_flags, state.operation, ep, code, null, 0, message);
	return;
     end;
%page;
dir_control_error: proc;

/* Original version written by Kobziar (July 74) */

dcl  a_dp				ptr parameter;
dcl  a_ep				ptr parameter;
dcl  a_code			fixed bin (35) parameter;

dcl  code				fixed bin (35);
dcl  dp				ptr;
dcl  ep				ptr;
dcl  exmode			bit (36) aligned;
dcl  info_only			bit (1) aligned;	/* TRUE iff info entry called */
dcl  locked			bit (1) aligned;
dcl  mode				bit (36) aligned;
dcl  original_code			fixed bin (35);
dcl  pep				ptr;
%page;
dir_control_error$append: entry (a_ep, a_code);

/* Used for appending into a dir.  The only access consideration is on the dir
itself, since asking to append inside a dir is like asking for the names of
objects in the dir; we can not let the user know of the existance of objects
in a dir to which he has no access. */

	info_only = "0"b;

	ep = a_ep;				/* entry for dir being appended into */
	if ep = null then code = error_table_$incorrect_access; /* something wrong here */
	else do;
	     call get_mode_on_entry (ep);
	     if (exmode ^= N_ACCESS) then code = error_table_$incorrect_access; /* user has some access on dir, 
						hence can know of no access (=> not namedup) */
	     else code = error_table_$no_info;		/* no access on dir */
	end;
	go to return_error_code;
%page;
dir_control_error$attributes_info: entry (a_ep, a_code);
	info_only = "1"b;
	go to attributes_entry;

dir_control_error$attributes: entry (a_ep, a_code);
	info_only = "0"b;

/* These entries are called when we had insufficient access to examine/change 
the attributes of an object. */

attributes_entry:
	ep = a_ep;				/* copy entry pointer */
	if ep = null then code = error_table_$incorrect_access; /* if entry is the root */
	else do;

/* Check access on parent */

	     dp = ptr (ep, 0);			/* get ptr to directory */
	     call get_mode_on_dir (dp);
	     if (exmode ^= N_ACCESS) then code = error_table_$incorrect_access; /* user has some access on parent but apparently not enough */
	     else do;
		if ep -> entry.bs = "1"b then do;
		     call get_mode_on_entry (ep);	/* access on entry allows user to see entry */
		     if code ^= 0 then go to return_error_code_no_audit;

		     if ep -> entry.dirsw then mode = exmode; /* if a directory, look at the extended access */

		     if mode ^= N_ACCESS then code = error_table_$incorrect_access; /* user has some access on object but not enough */
		     else code = error_table_$no_info;
		end;
		else code = error_table_$no_info;	/* link */
	     end;
	end;
	go to return_error_code;
%page;
dir_control_error$contents_info: entry (a_ep, a_code);	/* Entry does not result in an auditing message */
	info_only = "1"b;
	go to contents_entry;

dir_control_error$contents: entry (a_ep, a_code);
	info_only = "0"b;

/* Entries called with an ep for an object whose contents in which we were
interested. */

contents_entry:
	ep = a_ep;				/* copy entry pointer */
	if rel (ep) = "0"b then code = error_table_$no_info; /* argument should always point to a directory entry */
	else if ep = null then code = error_table_$moderr;/* if entry represents the root */
	else if ep -> entry.bs = "0"b then code = error_table_$no_info; /* if passed a pointer to a link entry */
	else do;

/* check access of entry */

	     call get_mode_on_entry (ep);
	     if code ^= 0 then go to return_error_code_no_audit;

	     if ep -> entry.dirsw then mode = exmode;	/* if a directory, look at the extended access */

	     if mode ^= N_ACCESS then code = error_table_$moderr; /* user has some access but not apparently what was needed */
	     else do;

/* otherwise look at access on parent */

		dp = ptr (ep, 0);			/* get ptr to directory */
		call get_mode_on_dir (dp);
		if (exmode ^= N_ACCESS) then code = error_table_$moderr; /* return moderr if user has non-null access on parent */
		else code = error_table_$no_info;	/* return no_info if user has null access on parent */
	     end;
	end;
	go to return_error_code;
%page;
dir_control_error$name_existant: entry (a_ep, a_code);

/* This entry is called when a user tries to look up a name which isn't what's
desired.  We have to see if the user is allowed to know this.  The argument is
an entry ptr to the entry of the wrong type.  If the user is allowed to see 
the name non-existance, we return the input code.  Otherwise, we return 
no_info.

Audit when user couldn't see object.  One reason for this is because we
can't keep dirs from entering the address space and we want to audit attempts
to try directory names.  */

	original_code = a_code;
	code = 0;					/* clear error code */
	ep = a_ep;
	dp = ptr (ep, 0);
	if ep = null then code = original_code;		/* root? */
	else do;
	     call get_mode_on_dir (dp);
	     if (exmode ^= N_ACCESS) then code = original_code; /* user has some access on dir */
	     else do;
		if ep -> entry.bs then do;		/* see if user has access (can see) object */
		     call get_mode_on_entry (ep);
		     if code ^= 0 then go to return_error_code_no_audit;

		     if ep -> entry.dirsw then mode = exmode;
		     if (mode ^= N_ACCESS) then code = original_code;
		     else code = error_table_$no_info;
		end;
		else code = error_table_$no_info;
	     end;
	end;
	if code = error_table_$no_info then call audit_failure (ep);
	go to return_error_code_no_audit;
%page;
dir_control_error$name_non_existant: entry (a_dp, a_code);

/* This entry is called when a user tries to look up a name which isn't found.
We have to see if the user is allowed to know this.  The argument is a ptr
to a directory in which the name wasn't found.  If the user is allowed to see 
the name non-existance, we return the input code.  Otherwise, we return 
no_info.

Audit when user couldn't see object.  One reason for this is because we
can't keep dirs from entering the address space and we want to audit attempts
to try directory names.  */

	original_code = a_code;
	code = 0;					/* clear error code */
	dp = a_dp;

	locked = "0"b;
	pep = null;
	call sum$getbranch_root_my (dp, READ_LOCK, pep, code); /* needed for auditing */
	if code = 0 then locked = "1"b;
	else if code = error_table_$root | code = error_table_$mylock then ;
	else go to return_error_code_no_audit;

	call get_mode_on_entry (pep);
	if (exmode ^= N_ACCESS) then code = original_code;/* user has some access on dir */
	else code = error_table_$no_info;

	if code = error_table_$no_info then call audit_failure (pep);

	if locked then call lock$dir_unlock (ptr (pep, 0));
	go to return_error_code_no_audit;
%page;
dir_control_error$status: entry (a_ep, a_code);

/* This entry is called when the user had non-null access on an object but did
not have s permission on the parent.  It is only called when this circumstance
causes us to return some, but not all, information the user requested.  In this
case, we know what error to flag.  We simply audit and return 
no_s_permission. */

	info_only = "0"b;				/* For real */
	ep = a_ep;				/* copy argument */
	if ep = null then code = error_table_$incorrect_access; /* if entry is the root */
	else code = error_table_$no_s_permission;	/* branch - caller knows we have some access but not access on dir */
	go to return_error_code;
%page;
return_error_code:
	if ^info_only then				/* If a real violation */
	     call audit_failure (ep);

return_error_code_no_audit:
	a_code = code;
	return;
%page;
get_mode_on_dir: proc (a_dp);

dcl  a_dp				ptr parameter;

dcl  dp				ptr;
dcl  locked			bit (1) aligned;
dcl  pdp				ptr;
dcl  pep				ptr;

	     dp = a_dp;
	     if state.for_user then do;		/* need to get pep to figure out access */
		locked = "1"b;			/* set lock indicator on */
		call sum$getbranch_root_my (dp, READ_LOCK, pep, code); /* get pointer to parent directory */
		if code ^= 0 then			/* turn off lock indicator */
		     if code = error_table_$root | code = error_table_$mylock then do;
			locked = "0"b;		/* if already locked by us */
			code = 0;
		     end;
		     else go to return_error_code_no_audit;

		pdp = ptr (pep, 0);			/* get pointer to parent of parent */
		call get_mode_on_entry (pep);		/* look at the access on parent directory */
		if locked then call lock$dir_unlock (pdp);
		if code ^= 0 then go to return_error_code_no_audit;
	     end;
	     else call get_dir_mode (dp, exmode, code);	/* easier to get mode for caller than someone else */
	     return;
	end get_mode_on_dir;

get_mode_on_entry: proc (a_ep);

dcl  a_ep				ptr parameter;

dcl  ep				ptr;

	     ep = a_ep;
	     if state.for_user then call access_mode$user_effmode (ep, state.user_id, state.authorization, (state.ring), mode, exmode, code);
	     else call access_mode$effective (ep, mode, exmode, code); /* get mode and extended mode of entry */
	     return;
	end get_mode_on_entry;
     end dir_control_error;
%page;
find_: proc;

/* Original version written by R. Bratt (October 1974). */

/* This program returns a pointer to a directory entry in a specified 
directory.  It returns with the directory locked.  a_ep is non-null only for 
success; the code will be zero in this case.

The append entries return a pointer to a locked directory in which and entry
is to be appended.  These entries basically just ensure that the named object
doesn't exist.
*/

dcl  find_type			bit (4) aligned;	/* type of object (or nothing) acceptable to find */
dcl  links			fixed bin;

	code = 0;
	ep, dp = null ();
	call setup ();

	if chase_sw = DC_FIND_NO_CHASE then do;
	     call find_locked_dir;
	     if code ^= 0 then call abort;

	     call find_entry (dp, entryname, FIND_OBJECT_OR_LINK, ep, code);
	     if code ^= 0 then call abort;
	     return;
	end;
	else do;
	     find_type = FIND_OBJECT_OR_LINK;
	     call find_chasing_link;
	     do links = 1 to active_all_rings_data$maxlinks while (code = error_table_$link);
		call split_pathname ();
		call find_chasing_link;
	     end;

	     if code = error_table_$link then code = error_table_$toomanylinks;
	     if code ^= 0 then call abort;
	     return;
	end;
%page;
find_$append: entry;

/* This entry checks that the pathname supplied does not exist. */

	code = 0;
	dp = null ();
	call setup ();

	if chase_sw = DC_FIND_NO_CHASE then do;
	     call find_locked_dir;
	     if code ^= 0 then call abort;

	     call find_entry (dp, entryname, FIND_NOTHING, ep, code);
	     if code ^= 0 then call abort;
	     return;
	end;
	else do;

/* This entry makes sure that the final target doesn't exist.  It returns
a pointer to the final target dir and the updated pathname of the link
target. */

	     find_type = FIND_LINK_OR_NOTHING;
	     call find_chasing_link;
	     do links = 1 to active_all_rings_data$maxlinks while (code = error_table_$link);
		call split_pathname ();
		call find_chasing_link;
	     end;

	     if code = error_table_$link then code = error_table_$toomanylinks;
	     if code ^= 0 then call abort;
	     return;
	end;
%page;
find_$link_target: entry;

/* This entry finds the target of the specified link, whether existant or not.
It returns this final path. */

	code = 0;
	ep, dp = null ();
	call setup ();

	find_type = FIND_ALL;
	call find_chasing_link;
	do links = 1 to active_all_rings_data$maxlinks while (code = error_table_$link);
	     call split_pathname ();
	     call find_chasing_link;
	end;

	if code = error_table_$link then code = error_table_$toomanylinks;
	if code ^= 0 then call abort;
	return;
%page;
find_chasing_link: proc;

	     call find_locked_dir;
	     if code ^= 0 then call abort;

	     call find_entry (dp, entryname, find_type, ep, code);
	     if code ^= 0 then call abort;

	     if ep ^= null then
		if ^ep -> entry.bs then do;		/* link */
		     dirname = substr (ep -> link.pathname, 1, ep -> link.pathname_size);
		     code = error_table_$link;
		     call lock$dir_unlock (dp);
		     state.dir_locked = "0"b;
		     call segno_usage$decrement (segno (dp), (0));
		     state.dir_held = "0"b;
		end;
	     return;
	end find_chasing_link;
%page;
setup:	proc;
	     if entryname = "" then call split_pathname ();
	     return;
	end setup;

split_pathname: proc;

dcl  ename_len			fixed bin (17);
dcl  path_len			fixed bin (17);

	     if dirname = ">" then do;
		code = error_table_$root;
		call abort;
	     end;
	     ename_len = index (reverse (dirname), ">") - 1;
	     if ename_len < 1 then do;
		code = error_table_$badpath;
		call abort;
	     end;
	     if ename_len > 32 then do;
		code = error_table_$entlong;
		call abort;
	     end;
	     path_len = length (dirname) - ename_len - 1;
	     entryname = substr (dirname, path_len + 2, ename_len);
	     dirname = substr (dirname, 1, max (path_len, 1));
	     return;
	end split_pathname;

abort:	proc;

	     if state.dir_locked then do;
		call lock$dir_unlock (dp);
		state.dir_locked = "0"b;
	     end;
	     if state.dir_held then do;
		call segno_usage$decrement (segno (dp), (0));
		state.dir_held = "0"b;
	     end;
	     go to non_local_return;
	end abort;

non_local_return:
	return;
     end find_;
%page;
find_dir: proc;

/* Original version (find_dirsegno) written by R. Bratt (September 1974) */

/* find_dir resolves a directory pathname into a directory pointer.
   It initiates any directories which are in the path but unknown to the 
   process.  On exit only the target directory is marked as in use.

The operation of this program is as follows:

We maintain the pathname of the directory we want to find (and initiate) in
substr (work_pathname.string, 1, work_pathname.parent_len + work_pathname.son_len).

We start by walking up the hierarchy from the last directory in the path 
looking for one whose segno is known.  This will either be because we find it 
in the PAM, or because we hit the root (which can be implicitly made known).
The amount of the original pathname that we examing in this walk up is
substr (work_pathname.string, 1, work_pathname.parent_len).

When we find this segno, we can walk back down the hierarchy, making each
subordinate directory known.  As we make a subordinate directory known, we free
up its parent.  Eventually we find what we want.

If we encounter a link, we substitute the portion of the pathname that this 
link is with the target path of the link.  We then restart the search given
this new "expanded" pathname. */

/* Based */

dcl  parent_path			char (work_pathname.parent_len) aligned based (addr (work_pathname.string)); /* based form of working path */
dcl  parent_path_var		char (work_pathname.parent_len) aligned var based (addr (work_pathname.parent_len));
dcl  son_path			char (work_pathname.son_len) based (addcharno (addr (work_pathname.string), work_pathname.parent_len));
						/* This describes the characters after the parent path
					(path that has been found).  This describes ">" || entryname of the next
					dir (and any chars that follows). */
dcl  1 work_pathname		aligned based (state.work_pathname_ptr), /* work area for path expansion and name stripping (concealing) */
       2 parent_len			fixed bin (21),	/* this field makes the characters that follow look like a var string 
- this is how many chars we are currently examining */
       2 string			char (2048),	/* more than enough for... */
       2 son_len			fixed bin (21);	/* number of chars in string following parent chars */

/* Variables */

dcl  authorization			bit (72) aligned;
dcl  entry			char (32) aligned;
dcl  entry_len			fixed bin (21);
dcl  ep				ptr;
dcl  new_son_ptr			ptr;		/* after relocation after link */
dcl  numlinks			fixed bin;
dcl  old_son_ptr			ptr;		/* to str of son */
dcl  segnum			fixed bin (17);	/* segno of directory currently held */
dcl  son_segnum			fixed bin (17);	/* new dir being made active */
dcl  sub_path_len			fixed bin (21);	/* after stripping an entryname */
%page;
	code = 0;

/* work_pathname is not kept as an automatic area to minimize stack frame
size during certain ptr based calls.  We grow the stack frame big 
enough for work_pathname only when we need to. */

	if ^state.find_dir_has_work_area then do;
	     state.work_pathname_ptr = wired_utility_$grow_stack_frame (size (work_pathname));
	     state.find_dir_has_work_area = "1"b;
	end;

	if state.for_user then authorization = state.user.authorization;
	else authorization = pds$access_authorization;

	work_pathname.son_len = 0;
	work_pathname.parent_len = length (dirname);
	substr (work_pathname.string, 1, work_pathname.parent_len) = dirname;

	unspec (my_makeknown_info) = "0"b;
	my_makeknown_info.activate, my_makeknown_info.dirsw, my_makeknown_info.allow_write = "1"b;
	numlinks = 0;

Find_dir: call pathname_am$get_segno (parent_path_var, segnum);
	if segnum > -1 then do;			/* found in PAM */

/* See if this dir (=> any dir in path) aim isolated.  Normally, we would say
that it couldn't be to have made it into the PAM on a previous pass.  But,
real or simulated dir priv in the past could have brought it into our space.
We don't want to allow accessing it any more unless privs are still on. */

	     dp = baseptr (segnum);
	     state.dir_held = "1"b;
	     if /* tree */ ^read_allowed_ (authorization, dp -> dir.access_class) then
		if ^addr (authorization) -> aim_template.privileges.dir then /* user lacks dir priv */
		     if ^(state.allow_searching_aim_isolated_dirs | state.allow_aim_isolated_final_dir) then do;
			state.operation = access_operations_$fs_obj_contents_read;
			call sum$getbranch (dp, READ_LOCK, pep, code);
			if code ^= 0 then go to abort;
			pdp = ptr (pep, 0);
			call dir_control_error$attributes (pep, code);
			call lock$dir_unlock (pdp);
			go to abort;
		     end;

	     go to find_dir_return;
	end;

	if parent_path_var = ">" then do;
	     call activate_root;
	     dp = baseptr (segnum);
	     state.dir_held = "1"b;
	     go to find_dir_return;			/* Everyone can see root */
	end;

/* We must split the pathname and start walking up the hierarchy, until we
find a PAM match or hit the root. */

	do while (segnum < 0);			/* walk down until we find the segno for some dir in path */

/* Adjust working_length to split off entryname */

	     sub_path_len = work_pathname.parent_len - index (reverse (parent_path), ">");
	     if sub_path_len = 0 then ;		/* directory right off root */
	     else if sub_path_len >= work_pathname.parent_len - 1 then do;
		code = error_table_$badpath;		/* no ">" or last char is ">" */
		go to abort;
	     end;
	     work_pathname.son_len = work_pathname.son_len + (work_pathname.parent_len - sub_path_len); /* add last entryname found to son half of string */
	     work_pathname.parent_len = sub_path_len;

/* Try to find dir */

	     if work_pathname.parent_len = 0 then call activate_root; /* root */
	     else call pathname_am$get_segno (parent_path_var, segnum); /* marks segno as held if segno returned */
	end;
	dp = baseptr (segnum);
	state.dir_held = "1"b;

/* Now we walk back down the hierarchy, finding the sub-ordinate dirs to the 
one found above. */

	do while (work_pathname.son_len > 0);
	     entry_len = index (substr (son_path, 2), ">"); /* add the next entry back to the parent half of string */
	     if entry_len = 0 then entry_len = work_pathname.son_len - 1; /* last entryname in path */
	     else entry_len = entry_len - 1;		/* remove ">" */
	     if entry_len > 32 then do;
		code = error_table_$entlong;
		go to abort;
	     end;
	     entry = substr (son_path, 2, entry_len);
	     work_pathname.son_len = work_pathname.son_len - (entry_len + 1);
	     work_pathname.parent_len = work_pathname.parent_len + (entry_len + 1); /* add in entryname we're about to find */

	     call lock$dir_lock_read (dp, code);
	     if code ^= 0 then go to abort;
	     state.dir_locked = "1"b;

	     call find_entry (dp, entry, FIND_DIR_OR_LINK, ep, code);
	     if code ^= 0 then go to abort;

	     if ^ep -> entry.bs then do;		/* link */

/* We substitute the pathname resolved so far with the link pathname and start
all over. */

		numlinks = numlinks + 1;
		if ep -> link.pathname_size + work_pathname.son_len > length (work_pathname.string) |
		     numlinks > active_all_rings_data$maxlinks then do;
		     code = error_table_$toomanylinks;
		     go to abort;
		end;
		old_son_ptr = addcharno (addr (work_pathname.string), work_pathname.parent_len); /* move son portion down */
		new_son_ptr = addr (work_pathname.string); /* avoid compiler bug */
		new_son_ptr = addcharno (new_son_ptr, ep -> link.pathname_size);
		if work_pathname.parent_len < ep -> link.pathname_size then
		     call mrl_ (old_son_ptr, work_pathname.son_len, new_son_ptr, work_pathname.son_len); /* moving to the right */
		else call mlr_ (old_son_ptr, work_pathname.son_len, new_son_ptr, work_pathname.son_len); /* moving to the left */
		substr (work_pathname.string, 1, ep -> link.pathname_size) = substr (ep -> link.pathname, 1, ep -> link.pathname_size); /* insert link as new parent */
		work_pathname.parent_len = work_pathname.son_len + ep -> link.pathname_size; /* make whole string parent, start over */
		work_pathname.son_len = 0;
		dirname = parent_path;		/* update dirname, disregard truncation */
		call lock$dir_unlock (dp);		/* release dir holding link */
		state.dir_locked = "0"b;
		call segno_usage$decrement (segnum, (0));
		state.dir_held = "0"b;
		go to Find_dir;			/* must start from scratch */
	     end;

	     if /* tree */ ^read_allowed_ (authorization, ep -> entry.access_class) then /* dir aim protected */
		if ^addr (authorization) -> aim_template.privileges.dir then /* user lacks dir priv */
		     if ^state.allow_searching_aim_isolated_dirs then
			if ^(work_pathname.son_len = 0 & state.allow_aim_isolated_final_dir) then do;
			     state.operation = access_operations_$fs_obj_contents_read;
			     call dir_control_error$attributes (ep, code);
			     go to abort;
			end;

	     my_makeknown_info.entryp = ep;
	     my_makeknown_info.uid = ep -> entry.uid;
	     call makeknown_ (addr (my_makeknown_info), son_segnum, (0), code);
	     if code ^= 0 then
		if code ^= error_table_$segknown then go to abort;
	     call lock$dir_unlock (dp);		/* dir is locked during makeknown_ activate call */
	     state.dir_locked = "0"b;
	     call segno_usage$decrement (segnum, (0));	/* parent will be held by son */
	     segnum = son_segnum;			/* makeknown made dir held */
	     dp = baseptr (segnum);
	     call pathname_am$set (parent_path_var, segnum); /* remember this after all we had to do to find it */
	end;

find_dir_return:
	code = 0;
	return;

abort:	if state.dir_locked then do;
	     call lock$dir_unlock (dp);
	     state.dir_locked = "0"b;
	end;
	if state.dir_held then do;
	     call segno_usage$decrement (segnum, (0));
	     state.dir_held = "0"b;
	end;
	return;

activate_root: proc;

	     my_makeknown_info.uid = "777777777777"b3;
	     my_makeknown_info.entryp = null;
	     call makeknown_ (addr (my_makeknown_info), segnum, (0), code); /* marks segno as held */
	     if code ^= 0 then
		if code ^= error_table_$segknown then go to abort;
	     return;
	end activate_root;
     end find_dir;
%page;
find_entry: proc (a_dp, a_ename, a_type, a_ep, a_code);

/* Original version written by R. Bratt (September 1974) */

/* find_entry provides entries for finding a directory entry of
   a certain type given the segment number of the parent directory and
   the name of the desired entry (and its desired type).  Code will be zero
   only if an object of the desired type was found.  ep will be non-null
   only if the found object is existant. */

dcl  a_code			fixed bin (35) parameter;
dcl  a_dp				ptr parameter;
dcl  a_ename			char (32) aligned parameter;
dcl  a_ep				ptr parameter;
dcl  a_type			bit (4) aligned parameter;

dcl  authorization			bit (72) aligned;
dcl  code				fixed bin (35);
dcl  dp				ptr;
dcl  ep				ptr;
dcl  type				bit (4) aligned;
%page;
	a_code = 0;
	a_ep = null;
	dp = a_dp;
	type = a_type;

	if state.for_user then authorization = state.user.authorization;
	else authorization = pds$access_authorization;

	call hash$search (dp, addr (a_ename), ep, code);
	if code ^= 0 then do;
	     if code ^= error_table_$noentry then go to abort;
	     if (type & FIND_NOTHING) then do;
		code = 0;				/* user got what he wanted */
		return;
	     end;
	     if (type & FIND_SEG) then code = error_table_$noentry; /* if we'd accept a seg, we'd accept anything */
	     else if (type & FIND_DIR) then code = error_table_$no_dir; /* only a dir or link will do */
	     else code = error_table_$not_link;		/* only link would do */
	     state.operation = access_operations_$fs_obj_contents_read; /* audit failure as attempt to read names */
	     call dir_control_error$name_non_existant (dp, code);
	     go to abort;
	end;

/* Found name; make some checks on what's found */

	if ep -> entry.bs then do;
	     if (ep -> entry.dirsw & (ep -> entry.type ^= DIR_TYPE))
		| (^ep -> entry.dirsw & (ep -> entry.type ^= SEG_TYPE))
		| ep -> entry.owner ^= dp -> dir.uid then signal bad_dir_;
	     if ep -> entry.security_oosw & ^addr (authorization) -> privileges.soos then do;
		state.operation = access_operations_$fs_obj_prop_read;
		call dir_control_error$attributes_info (ep, code);
		if code = error_table_$incorrect_access then code = error_table_$oosw;
		go to abort;
	     end;
	     if /* tree */ ep -> entry.dirsw then
		if (type & FIND_DIR) = "0"b then
		     if (type & FIND_NOTHING) then code = error_table_$namedup;
		     else if (type & FIND_SEG) then code = error_table_$dirseg;
			else code = error_table_$not_link; /* only choice left */
		else ;
	     else if (type & FIND_SEG) = "0"b then
		     if (type & FIND_NOTHING) then code = error_table_$namedup;
		     else if (type & FIND_DIR) then code = error_table_$notadir;
			else code = error_table_$not_link; /* only choice left */
		else ;
	end;
	else do;					/* link */
	     if ep -> link.type ^= LINK_TYPE | ep -> link.owner ^= dp -> dir.uid then signal bad_dir_;
	     if (type & FIND_LINK) = "0"b then
		if (type & FIND_NOTHING) then code = error_table_$namedup;
		else code = error_table_$link;
	end;
	if code ^= 0 then do;
	     state.operation = access_operations_$fs_obj_prop_read; /* audit failure as attempt to read names */
	     call dir_control_error$name_existant (ep, code);
	     go to abort;
	end;

	a_ep = ep;
	return;

abort:	a_code = code;
	return;
     end find_entry;
%page;
find_locked_dir: proc;

	call find_dir;				/* this makes dir_held */
	if code ^= 0 then return;

	if lock_for_writing then call lock$dir_lock_write (dp, code);
	else call lock$dir_lock_read (dp, code);
	if code ^= 0 then do;
	     call segno_usage$decrement (segno (dp), (0));
	     state.dir_held = "0"b;
	     return;
	end;
	state.dir_locked = "1"b;
	return;
     end;
%page;
find_segptr_branch: proc;

	call sum$getbranch (segptr, lock_for_writing, ep, code);
	if code ^= 0 then return;
	dp = ptr (ep, 0);
	state.dir_locked = "1"b;
	return;
     end;
%page;
get_dir_mode: proc (a_segptr, a_mode, a_code);

/* Find the effective access to the dir, ignoring everything else. */

dcl  a_code			fixed bin (35) parameter;
dcl  a_mode			bit (36) aligned parameter;
dcl  a_segptr			ptr parameter;

dcl  code				fixed bin (35);
dcl  dp				ptr;
dcl  ep				ptr;
dcl  kstep			ptr;
dcl  lock_sw			bit (1) aligned;
dcl  mode				bit (36) aligned;
dcl  need_to_lock			bit (1) aligned;
dcl  rb				(3) fixed bin (3);
dcl  ring				fixed bin (3);
dcl  segptr			ptr;

	need_to_lock = "1"b;
	go to join;

get_dir_mode$locked: entry (a_segptr, a_mode, a_code);

/* Entry to use when parent directory of object that segptr indicates is 
locked. */

	need_to_lock = "0"b;

join:	a_mode = "0"b;
	segptr = a_segptr;

	mode = N_ACCESS;
	call get_kstep (segno (segptr), kstep, code);	/* get kst entry ptr for this seg */
	if code ^= 0 then go to abort;

	if kstep -> kste.uid = (36)"1"b then do;	/* special case the root */
	     lock_sw = "0"b;
	     dp, ep = null;				/* get access to root */
	     if kstep -> kste.dtbm = (36)"1"b then call update_kste_access (kstep, ep, mode);
	     mode = kstep -> kste.extended_access;	/* pick up directory access */
	     rb (1), rb (2), rb (3) = 7;
	end;
	else do;
	     lock_sw = "0"b;

/* lock parent and  get pointer to entry */
	     if need_to_lock then do;
		call sum$getbranch_root_my (segptr, READ_LOCK, ep, code);
		if code = 0 then lock_sw = "1"b;
		else if code = error_table_$mylock then code = 0;
		else go to abort;
	     end;
	     else ep = kstep -> kste.entryp;		/* kste entryp good if dir locked */

	     dp = ptr (ep, 0);			/* get pointer to parent directory */
	     if kstep -> kste.dtbm ^= ep -> entry.dtem then call update_kste_access (kstep, ep, mode);
	     mode = kstep -> kste.extended_access;
	     rb (*) = binary (kstep -> kste.ex_rb (*), 3);/* factor in extended ring brackets */
	     ring = level$get ();
	     if ring <= rb (1) then ;
	     else if ring <= rb (2) then mode = mode & S_ACCESS;
	     else mode = N_ACCESS;
	end;

	if lock_sw then call lock$dir_unlock (dp);
	a_mode = mode;

abort:	a_code = code;
	return;
     end get_dir_mode;
%page;
uid_path_util: proc;

/* Original version written March 1975 by Larry Johnson */

/* Variables */

dcl  authorization			bit (72) aligned;
dcl  current_depth			fixed bin;
dcl  entrysw			bit (1) aligned;
dcl  max_depth			fixed bin;
dcl  segnum			fixed bin;
dcl  son_segnum			fixed bin;

uid_path_util$find_entry: entry;
	entrysw = "1"b;
	go to join;

uid_path_util$find_dir: entry;
	entrysw = "0"b;

join:	ep, dp = null;
	dirname = "";
	entryname = "";
	code = 0;

	if state.for_user then authorization = state.user.authorization;
	else authorization = pds$access_authorization;

	if uidpath (0) ^= "777777777777"b3 then do;	/* All paths must start with root */
	     code = error_table_$bad_uidpath;
	     go to RETURN;
	end;
	do max_depth = 1 to 15 while (uidpath (max_depth));
	end;
	max_depth = max_depth - 1;
	if max_depth = 0 then do;
	     code = error_table_$root;
	     dirname = ">";
	     go to RETURN;
	end;

	unspec (my_makeknown_info) = "0"b;
	my_makeknown_info.dirsw, my_makeknown_info.allow_write,
	     my_makeknown_info.priv_init, my_makeknown_info.activate = "1"b;

	my_makeknown_info.entryp = null;		/* Start with root */
	my_makeknown_info.uid = "777777777777"b3;
	call makeknown_ (addr (my_makeknown_info), segnum, (0), code);
	if code ^= 0 then
	     if code ^= error_table_$segknown then go to abort;
	state.dir_held = "1"b;
	dp = baseptr (segnum);

	if entrysw then max_depth = max_depth - 1;
	if max_depth = 0 then dirname = ">";
	else dirname = "";
	do current_depth = 1 to max_depth;		/* Step down path */
	     call find_uid (uidpath (current_depth), READ_LOCK);

	     dirname = dirname || ">";
	     dirname = dirname || rtrim (entryname);

	     if /* tree */ ^read_allowed_ (authorization, ep -> entry.access_class) then /* dir aim protected */
		if ^addr (authorization) -> aim_template.privileges.dir then /* user lacks dir priv */
		     if ^state.allow_searching_aim_isolated_dirs then
			if ^(current_depth = max_depth & state.allow_aim_isolated_final_dir) then do;
			     state.operation = access_operations_$fs_obj_contents_read;
			     call dir_control_error$attributes (ep, code);
			     go to abort;
			end;

	     my_makeknown_info.uid = uidpath (current_depth);
	     my_makeknown_info.entryp = ep;
	     call makeknown_ (addr (my_makeknown_info), son_segnum, (0), code);
	     if code ^= 0 then
		if code ^= error_table_$segknown then go to abort;
	     call lock$dir_unlock (dp);		/* dir is kept locked during makeknown_ activate call */
	     state.dir_locked = "0"b;
	     call segno_usage$decrement (segnum, (0));	/* son will hold parent */
	     segnum = son_segnum;
	     dp = baseptr (segnum);
	end;

	if entrysw then call find_uid (uidpath (max_depth + 1), lock_for_writing);

	code = 0;
	return;

abort:	if state.dir_locked then do;
	     call lock$dir_unlock (dp);
	     state.dir_locked = "0"b;
	end;
	if state.dir_held then do;
	     call segno_usage$decrement (segno (dp), (0));
	     state.dir_held = "0"b;
	end;
RETURN:	return;
%page;
find_uid: proc (a_uid, a_typelock);

dcl  a_typelock			bit (36) aligned parameter;
dcl  a_uid			bit (36) aligned parameter;

dcl  ecount			fixed bin;
dcl  nnp				ptr;
dcl  num_entries_in_dir		fixed bin;
dcl  uid				bit (36) aligned;

	     uid = a_uid;

	     if a_typelock then call lock$dir_lock_write (dp, code);
	     else call lock$dir_lock_read (dp, code);
	     if code ^= 0 then go to abort;
	     state.dir_locked = "1"b;

	     num_entries_in_dir = dp -> dir.seg_count + dp -> dir.dir_count + dp -> dir.lcount;
	     ecount = 0;
	     do ep = ptr (dp, dp -> dir.entryfrp) repeat (ptr (dp, ep -> entry.efrp)) while (rel (ep));
		ecount = ecount + 1;
		if ecount > num_entries_in_dir then signal bad_dir_;
		if ep -> entry.bs then
		     if ep -> entry.owner ^= dp -> dir.uid then signal bad_dir_;
		     else if ep -> entry.type ^= SEG_TYPE & ep -> entry.type ^= DIR_TYPE then signal bad_dir_;
		     else ;
		else if ep -> link.owner ^= dp -> dir.uid then signal bad_dir_;
		else if ep -> link.type ^= LINK_TYPE then signal bad_dir_;
		if ep -> entry.uid = uid then
		     if ep -> entry.bs & ep -> entry.dirsw then do; /* Must be dir branch */
			nnp = addr (ep -> entry.primary_name);
			if nnp -> names.owner ^= ep -> entry.uid
			     | nnp -> names.type ^= NAME_TYPE
			     | nnp -> names.entry_rp ^= rel (ep) then signal bad_dir_;
			entryname = nnp -> names.name;
			return;
		     end;
		     else go to not_found;
	     end;

not_found:     code = error_table_$bad_uidpath;
	     go to abort;
	end find_uid;
     end uid_path_util;
%page; %include access_audit_encoded_op;
%page; %include access_audit_eventflags;
%page; %include access_audit_user_info;
%page; %include access_mode_values;
%page; %include aim_template;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include dir_link;
%page; %include dir_name;
%page; %include fs_obj_access_codes;
%page; %include fs_types;
%page; %include its;
%page; %include kst;
%page; %include makeknown_info;
%page; %include sdw_info;
     end dc_find;




		    fs_modes.pl1                    11/11/89  1103.7rew 11/11/89  0809.9       59679



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

/* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */

fs_modes: proc (a_segptr, a_mode, a_ex_mode, a_rings, a_code);

/*	Created 10/11/84 from fs_get by Keith Loepere.
	Modified 4/9/85 to keep mode/ex_mode straight by Keith Loepere.
*/


/****^  HISTORY COMMENTS:
  1) change(86-08-08,GDixon), approve(86-08-08,MCR7388),
     audit(86-09-02,Farley), install(86-09-08,MR12.0-1150):
     Add warning to fs_modes$locked entrypoint on requirements for properly
     calling the entry.
                                                   END HISTORY COMMENTS */


/* This program is used by internal interfaces to look-up access modes
on objects.  It makes no access checks.  Also, it is optimized to examine
kst and sdw fields for access. */

/* Parameters */

dcl  a_code			fixed bin (35) parameter;
dcl  a_ex_mode			bit (36) aligned parameter; /* extended access  bits EX ACC */
dcl  a_mode			bit (36) aligned parameter;
dcl  a_rings			(3) fixed bin (3) parameter;
dcl  a_segptr			ptr parameter;

/* Constants */

dcl  read_lock			bit (36) aligned static options (constant) init ("0"b);

/* Variables */

dcl  code				fixed bin (35);
dcl  dirsw			bit (1) aligned;
dcl  dp				ptr;
dcl  ex_mode			bit (36) aligned;
dcl  have_ep			bit (1) aligned;
dcl  lock_sw			bit (1) aligned;
dcl  mode				bit (36) aligned;
dcl  rb				(3) fixed bin (3);
dcl  ring				fixed bin;
dcl  segno			fixed bin (17);
dcl  segptr			ptr;

/* External */

dcl  dseg$			(0:1) fixed bin (71) external;
dcl  error_table_$mylock		fixed bin (35) external;

/* Entries */

dcl  get_kstep			entry (fixed bin, ptr, fixed bin (35));
dcl  level$get			entry returns (fixed bin);
dcl  lock$dir_unlock		entry (ptr);
dcl  sum$getbranch_root_my		entry (ptr, bit (36) aligned, ptr, fixed bin (35));
dcl  update_kste_access		entry (ptr, ptr, bit (36) aligned);

/* Misc */

dcl  (addr, baseno, binary, fixed, null, ptr) builtin;
%page;
	have_ep = "0"b;
	go to join;

locked: entry (a_segptr, a_mode, a_ex_mode, a_rings, a_code);

	have_ep = "1"b;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* WARNING:  When calling fs_modes$locked, sum$getbranch or		       */
/* sum$getbranch_root_my must have been called to obtain a pointer to the    */
/* directory entry corresponding to a_segptr.  This call to sum will lock    */
/* the directory and validate kste.entryp (the pointer to the dir entry      */
/* which is stored within the segment's KST entry).  The directory must      */
/* remain locked until after fs_modes$locked returns, since fs_modes$locked  */
/* uses kste.entryp to obtain a pointer to the dir entry.  Otherwise, the    */
/* dir entry could be moved within the directory by another processor,       */
/* causing fs_modes to reference a garbage location within the directory.    */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


join:	segptr = a_segptr;				/* copy arg */

	call get_kstep (fixed (baseno (segptr), 17), kstep, code); /* get kst entry ptr for this seg */
	if code ^= 0 then go to RETURN;

	if have_ep then ep = kste.entryp;		/* dir locked => entryp valid */
	else ep = null;

	dirsw = kstep -> kste.dirsw;			/* pick up directory flag from kst */

	if kstep -> kste.uid = (36)"1"b then do;	/* special case the root */
	     lock_sw = "0"b;
	     dp = null;				/* get access to root */
	     if kstep -> kste.dtbm = (36)"1"b then call update_kste_access (kstep, ep, mode);
	     mode = RW_ACCESS;			/* raw mode */
	     ex_mode = kstep -> kste.extended_access;	/* pick up directory access */
	     rb (1), rb (2), rb (3) = 7;
	end;

	else do;					/* if a non directory try to get access from sdw */
	     if dirsw = "0"b then do;			/* before locking the parent */
		dp = null;
		lock_sw = "0"b;
		segno = fixed (baseno (segptr), 17);
		sdwp = addr (dseg$ (segno));
		if sdwp -> sdw.df = "1"b then call get_sdw_access; /* access in sdw is ok, since no setfaults done */
		else do;				/* lock parent to validate the dtbm in kste */
		     call lock_dir;
						/* must update access in kste and change sdw access */
		     if kstep -> kste.dtbm ^= ep -> entry.dtem then
			call update_kste_access (kstep, ep, mode);
		     else mode = kstep -> kste.access;	/* access in kste okay */
		     rb (*) = binary (ep -> entry.ring_brackets (*), 3);
		end;
		ex_mode = kstep -> kste.extended_access;
	     end;
	     else do;
		call lock_dir;
		if kstep -> kste.dtbm ^= ep -> entry.dtem then call update_kste_access (kstep, ep, mode);
		mode = RW_ACCESS;
		ex_mode = kstep -> kste.extended_access;
		rb (*) = binary (kstep -> kste.ex_rb (*), 3); /* factor in extended ring brackets */
	     end;
	end;

	call compute_effective_mode;
	if dirsw then call compute_effective_dir_mode;

	if lock_sw then call lock$dir_unlock (dp);

	a_rings = rb;
	a_mode = mode;
	a_ex_mode = ex_mode;

RETURN:	a_code = code;
	return;
%page;
get_sdw_access: proc;
	mode = kstep -> kste.access;
	rb (1) = fixed (sdwp -> sdw.r1, 3);
	rb (2) = fixed (sdwp -> sdw.r2, 3);
	rb (3) = fixed (sdwp -> sdw.r3, 3);
     end get_sdw_access;

lock_dir: proc;

	lock_sw = "0"b;
	if ^have_ep then do;
	     call sum$getbranch_root_my (segptr, (read_lock), ep, code); /* lock parent and get pointer to entry */
	     if code ^= 0 then
		if code ^= error_table_$mylock then go to RETURN;
		else code = 0;			/* allow parent to be locked by us */
	     else lock_sw = "1"b;
	end;
	dp = ptr (ep, 0);				/* get pointer to parent directory */

     end lock_dir;

compute_effective_mode: proc;

	ring = level$get ();
	if ring = rb (1) then ;
	else if ring < rb (1) then mode = mode & "101"b;
	else if ring <= rb (2) then mode = mode & "110"b;
	else if ring <= rb (3) then mode = mode & "010"b;
	else mode = "0"b;

     end compute_effective_mode;

compute_effective_dir_mode: proc;

	ring = level$get ();
	if ring <= rb (1) then ;
	else if ring <= rb (2) then ex_mode = ex_mode & "100"b;
	else ex_mode = "0"b;

     end compute_effective_dir_mode;
%page; %include access_mode_values;
%page; %include dir_entry;
%page; %include fs_types;
%page; %include kst;
%page; %include sdw;
     end fs_modes;




		    level.alm                       11/11/89  1103.7rew 11/11/89  0809.9       50049



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

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	LEVEL
"
"	This procedure is called to get and set the validation level
"	for the process.
"	the get entrypoint is both a ring zero utility and an fgate.
"	the set entrypoint is called only from ring zero.
"	the seg_gate entrypoint can be called through hcs_ as
"	an fgate.
"
"	Modified 5/19/80 by J. A. Bush to not call ring_alarm if no change in validation level
"         Modified 830518 BIM for level$gate_set, various cleanup, 
"		no stack frame.
"         Modified 1985-05-08, BIM: new entrypoint level$admin_gate_set
"	sets no_audit_ring1_fs_object_ops.
"
"	This procedure maintains the array in pds$ring_alarm_val.
"	pds$ring_alarm_val (r) ^= 0 iff a ring alarm should be
"	signalled upon leaving ring r for the purpose of fixing
"	the validation level. On other reasons for ring alarms 
"	pds$ring_alarm_val should NOT be set.
"
"	Furthermore pds$ring_alarm_val (r) is equal to the value
"	of the validation level on entry to this ring. This is
"	guaranteed by setting it nonzero iff it is zero.
"

	name	level
	entry	get
	entry	set
	entry	set_gate
	entry	set_admin_gate

" The *_gate entries are called as FGATES. Therefore, there is no
" stack frame for the gate itself. Therefore, sp
" is a pointer to the outer ring's stack frame, and
" we can use that ring number to validate that
" call hcs_$level_set (v) -- v >= ring of execution.

" CODING CONVENTION
"
" A contains the new (or putative new) validation level
" Q contains the ring on behalf of whom we are acting
" X1 is stored into pds$no_audit_ring1_fs_object_ops

set_gate:
	lda	ap|2,*			Get argument 
	tmi	error_big_ring		Unsigned number, after all
	cmpa	=7,dl
	tpnz	error_big_ring		No more ring 64
	eax0	0,al			Copy to X0 

	epaq	sp|0			Get ringno
	ana	=7,dl			ringno only

" The following gets around the lack of inter-register compare instructions.
" Since there are only 8 different values for the argument, this maneuver
" uses x0 to find its own value in storage. Ycch.

	cmpa	ring_table,x0		is execution ring (A) <= requested ring (X0)?
	tpnz	error_small_ring		no, go bitch.

	llr	36			A -> Q
	eaa	0,x0			X0 -> AU
	arl	18			AU -> AL

	cmpa	1,dl			Ring 1?
	tpl	reset_no_audit		greater
	ldx1	pds$no_audit_ring1_fs_object_ops  " value remains
	tra	set_common
reset_no_audit:
	eax1	0			greater than 1, zero flag
	tra	set_common

set_admin_gate:
	lda	pds$validation_level
	sta	ap|2,*			return old value

	lda	1,dl			We are setting 1

	ldq	1,dl			Called from ring 1

	ldx1	pds$no_audit_ring1_fs_object_ops  " may be zeroed
	tnz	no_audit_already_set	
	lxl2	pds$initial_ring		Initial ring must not be 1
	cmpx2	1,du
	tze	dont_suppress_audit
	szn	active_hardcore_data$audit_ring1_fs_object_ops
	tnz	dont_suppress_audit
	ldx1	=o400000,du		turn on the bit
no_audit_already_set:			
dont_suppress_audit:
	tra	set_common

" This is called only in ring 0

set:	
	lda	ap|2,*			fetch argument
	tmi	error_r0_big_ring
	cmpa	=7,dl			Reasonable?
	tpnz	error_r0_big_ring

	ldq	0,dl			we are ring 0.

	ldx1	pds$no_audit_ring1_fs_object_ops  retain value

set_common:
	cmpa	pds$validation_level	Trivial case?
					" For access audit, the ring 
					" alarm for the validation
				          " level is already set.
	tnz	set_non_trivial		nope.
	short_return			No change.

set_non_trivial:
	stx1	pds$no_audit_ring1_fs_object_ops " set new value
	szn	pds$ring_alarm_val,ql
	tnz	set_not_first

	eax1	0,al			store new level in X1
	lda	pds$validation_level	we need to save this
	sta	pds$ring_alarm_val,ql	if this is first save
	sxl1	pds$validation_level	set new level
	tra	call_ring_alarm		and recalculate RAR

set_not_first:
	sta	pds$validation_level	new level
	cmpa	pds$ring_alarm_val,ql	if back, no more alarm
	tnz	call_ring_alarm		not back to where it was
	stz	pds$ring_alarm_val,ql

call_ring_alarm:
	eppap	null_arglist
	tra	ring_alarm$reset		its return is ours

"
	tempd	arg_list_error(2)
	temp	bad_ring_arg	

error_big_ring:
	tsx2	make_error_arglist	" PUSHES
	short_call	level_error$ring_bigger_than_7
	return

error_small_ring:
	eaa	0,x0
	arl	18		" move arg back to A
	tsx2	make_error_arglist	" PUSHES
	short_call	level_error$ring_too_small
	return

error_r0_big_ring:
	tsx2	make_error_arglist	" PUSHES
	short_call	level_error$r0_invalid_ring
	return


make_error_arglist:		"Called with tsx2
	push
	sta	bad_ring_arg
	ldaq	one_arg_arglist
	staq	arg_list_error
	epp1	bad_ring_arg
	spri1	arg_list_error+2
	eppap	arg_list_error	set AP appropriately
	tra	0,x2	

	even
null_arglist:
	vfd	18/0,18/4			External call
	vfd	18/0,18/0
one_arg_arglist:
	vfd	17/1,1/0,18/4		One arg, Ext call
	vfd	18/0,18/0

" This table is indexed by requested ring number. Each slot contains the
" smallest legal setting from that level.

ring_table:
	dec	0
	dec	1
	dec	2
	dec	3
	dec	4
	dec	5
	dec	6
	dec	7

" 
"	This is both an FGATE and a normal entry

get:	lda	pds$validation_level	return the current value
	sta	ap|2,*			..
	short_return

	end




		    level_error.pl1                 11/11/89  1103.7rew 11/11/89  0809.9       23202



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
/* level_error.pl1 produces syserr/condition signals for invalid calls */
/* to level$set. */
/* BIM 830518 */
/* format: style2 */

level_error:
     procedure;

	declare signal_		 entry (char (*), pointer, pointer);
	declare syserr		 entry options (variable);
	declare ioa_$rsnnl		 entry options (variable);
	declare caller		 entry returns (pointer);
	declare error_table_$badringno fixed bin (35) ext static;
	declare currentsize		 builtin;

%include condition_info_header;
%include val_level_error;
%include syserr_constants;

	declare 1 VLE		 aligned like val_level_error_info;

	declare A_ring		 fixed bin (3) aligned parameter;
	declare ERROR_NAME		 char (32) init ("validation_level_error") int static options (constant);


/* This is called from the gate. Just crawlout. */

ring_bigger_than_7:
     entry (A_ring);

	call SETUP_HEADER;

	call ioa_$rsnnl ("Validation level of ^d is bigger than 7.", VLE.header.info_string, (0), A_ring);
	VLE.header.status_code = error_table_$badringno;
	do while ("1"b);
	     call signal_ (ERROR_NAME, null (), addr (VLE));
	end;

ring_too_small:
     entry (A_ring);


	call SETUP_HEADER;

	call ioa_$rsnnl ("Validation level of ^d is less than the ring of execution.", VLE.header.info_string, (0),
	     A_ring);
	VLE.header.status_code = error_table_$badringno;
	do while ("1"b);
	     call signal_ (ERROR_NAME, null (), addr (VLE));
	end;

r0_invalid_ring:
     entry (A_ring);

	call syserr (BEEP, "level: call to level$set with arg (^d) > 7; caller  ^p.", A_ring, caller ());

	call SETUP_HEADER;

	call ioa_$rsnnl ("Validation level of ^d is bigger than 7.", VLE.header.info_string, (0), A_ring);
	VLE.header.status_code = error_table_$badringno;
	do while ("1"b);
	     call signal_ (ERROR_NAME, null (), addr (VLE));
	end;


SETUP_HEADER:
     procedure;

	VLE.header.length = currentsize (VLE);
	VLE.header.version = 0;
	VLE.header.action_flags = "0"b;
	VLE.header.action_flags.cant_restart = "1"b;
	VLE.header.info_string = "";
	VLE.header.status_code = 0;
	VLE.invalid_ring = A_ring;

	return;
     end SETUP_HEADER;

     end level_error;




		    set_sys_audit_thresholds_.pl1   11/11/89  1103.7rew 11/11/89  0809.9       55908



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



/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1056):
     Correct error message documentation.
                                                   END HISTORY COMMENTS */


/* format: style1,^inddcls,^indnoniterdo,insnl,linecom,indcomtxt */

set_sys_audit_thresholds_:
     procedure (a_covert_channel_sw, a_covert_channel_threshold,
	a_successful_access_sw, a_successful_access_threshold,
	a_unsuccessful_access_sw, a_unsuccessful_access_threshold,
	a_ec);

/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* SET_SYS_AUDIT_THRESHOLDS							*/
	/*									*/
	/* Routine to set the system security access audit enable flags and thresholds in	*/
	/* sys_info.  This routine is called from as_init with values extracted from the system	*/
	/* installation parms.  This routine can be called only through hphcs_.		*/
	/*									*/
	/* History:								*/
	/* 84-12-03 EJ Sharpe - minor cosmetic fix
	/* 84-11-28 EJ Sharpe - created						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: on */


/* PARMETERS */

dcl     a_covert_channel_sw	 parameter bit (1) aligned;
dcl     a_covert_channel_threshold
			 parameter bit (72) aligned;
dcl     a_successful_access_sw parameter bit (1) aligned;
dcl     a_successful_access_threshold
			 parameter bit (72) aligned;
dcl     a_unsuccessful_access_sw
			 parameter bit (1) aligned;
dcl     a_unsuccessful_access_threshold
			 parameter bit (72) aligned;
dcl     a_ec		 parameter fixed bin (35);


/* AUTOMATIC ARG COPIES */

dcl     covert_channel_sw	 bit (1) aligned;
dcl     covert_channel_threshold
			 bit (72) aligned;
dcl     successful_access_sw	 bit (1) aligned;
dcl     successful_access_threshold
			 bit (72) aligned;
dcl     unsuccessful_access_sw bit (1) aligned;
dcl     unsuccessful_access_threshold
			 bit (72) aligned;
dcl     ec		 fixed bin (35);


/* AUTOMATIC */

dcl     1 event_flags	 aligned like audit_event_flags;
dcl     allowed_range	 (2) bit (72) aligned init (
			 sys_info$access_class_floor,
			 sys_info$access_class_ceiling);


/* EXTERNAL CONSTANT */

dcl     error_table_$ai_out_range
			 fixed bin (35) external;
dcl     access_operations_$system_audit_thresh_modify
			 bit (36) aligned external;
dcl     sys_info$access_class_ceiling
			 bit (72) aligned external;
dcl     sys_info$access_class_floor
			 bit (72) aligned external;


/* EXTERNAL THAT WE MODIFY */

dcl     sys_info$audit_covert_channel
			 bit (1) aligned external;
dcl     sys_info$covert_channel_threshold
			 bit (72) aligned external;
dcl     sys_info$audit_successful_access
			 bit (1) aligned external;
dcl     sys_info$successful_access_threshold
			 bit (72) aligned external;
dcl     sys_info$audit_unsuccessful_access
			 bit (1) aligned external;
dcl     sys_info$unsuccessful_access_threshold
			 bit (72) aligned external;


/* ENTRIES */

dcl     access_audit_$log_general
			 entry options (variable);
dcl     aim_check_$in_range	 entry (bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned);
dcl     display_access_class_	 entry (bit (72) aligned) returns (char (32) aligned);
dcl     level$get		 entry () returns (fixed bin);


/* MISC */

dcl     null		 builtin;
dcl     string		 builtin;
%page;
/* copy args */

	covert_channel_sw = a_covert_channel_sw;
	covert_channel_threshold = a_covert_channel_threshold;
	successful_access_sw = a_successful_access_sw;
	successful_access_threshold = a_successful_access_threshold;
	unsuccessful_access_sw = a_unsuccessful_access_sw;
	unsuccessful_access_threshold = a_unsuccessful_access_threshold;

	ec = 0;					/* will be copied to arg on output */

	if ^aim_check_$in_range (covert_channel_threshold, allowed_range)
	     | ^aim_check_$in_range (successful_access_threshold, allowed_range)
	     | ^aim_check_$in_range (unsuccessful_access_threshold, allowed_range)
	then ec = error_table_$ai_out_range;
	else do;
						/* need to audit only if args were legal */
	     string (event_flags) = ""b;
	     event_flags.special_op = "1"b;
	     event_flags.priv_op = "1"b;
	     event_flags.grant = "1"b;
	     call access_audit_$log_general ("set_sys_audit_thresholds_", level$get (),
		string (event_flags), access_operations_$system_audit_thresh_modify, "", 0, null (), 0,
		"Covert channel audit ^[enable^;disable^], threshold=^a.  Successful access audit ^[enable^;disable^], threshold=^a.  Unsuccessful access audit ^[enable^;disable^], threshold=^a."
		,
		covert_channel_sw, display_access_class_ (covert_channel_threshold),
		successful_access_sw, display_access_class_ (successful_access_threshold),
		unsuccessful_access_sw, display_access_class_ (unsuccessful_access_threshold));

	     sys_info$audit_covert_channel = covert_channel_sw;
	     sys_info$covert_channel_threshold = covert_channel_threshold;
	     sys_info$audit_successful_access = successful_access_sw;
	     sys_info$successful_access_threshold = successful_access_threshold;
	     sys_info$audit_unsuccessful_access = unsuccessful_access_sw;
	     sys_info$unsuccessful_access_threshold = unsuccessful_access_threshold;
	end;

	a_ec = ec;

	return;
%page;
%include access_audit_eventflags;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   AUDIT (set_sys_audit_thresholds_): GRANTED|DENIED modification of system audit flags and thresholds ADDED_INFO

   S:	$access_audit

   T:	$run

   M:	Indicates that the system wide audit enable flags and the
   thresholds have been changed as indicated.

   A:	$ignore

   END MESSAGE DOCUMENTATION */

     end set_sys_audit_thresholds_;




		    update_kste_access.pl1          11/11/89  1103.7rew 11/11/89  0809.9       19737



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


update_kste_access: proc (a_kstep, a_ep, a_mode);

/*

   Modified March 29, 1976 by R. Bratt for initiated mode
   Modified 01/15/79 by C. D. Tavares to fix problem with dir extended ring brackets.

*/

dcl  a_kstep ptr,
     a_ep ptr,
     a_mode bit (36) aligned;
dcl (mode, ex_mode) bit (36) aligned;
dcl  ignore fixed bin (35);

dcl  access_mode$authorization entry (ptr, bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl  access_mode$effective entry (ptr, bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl  access_mode$raw entry (ptr, bit (36) aligned, bit (36) aligned, fixed bin (35));

dcl  null builtin;

/*  */
% include kst;

% include dir_entry;

/*  */
	kstep = a_kstep;
	ep = a_ep;

	if kstep -> kste.dirsw then do;
	     call access_mode$authorization (ep, mode, ex_mode, ignore);
	     if ep ^= null
	     then do;
		kstep -> kste.ex_rb (1) = ep -> entry.ex_ring_brackets (1);
		kstep -> kste.ex_rb (2), kstep -> kste.ex_rb (3) = ep -> entry.ex_ring_brackets (2);
		kstep -> kste.dtbm = ep -> entry.dtem;
	     end;
	     else do;
		kstep -> kste.ex_rb = "111"b;		/* 7 */
		kstep -> kste.dtbm = (36)"0"b;
	     end;
	end;
	else do;
	     if kstep -> kste.priv_init
	     then call access_mode$raw (ep, mode, ex_mode, ignore);
	     else call access_mode$authorization (ep, mode, ex_mode, ignore);
	     kstep -> kste.dtbm = ep -> entry.dtem;
	end;
	kstep -> kste.access = mode;
	kstep -> kste.extended_access = ex_mode;
	a_mode = mode;
	return;

     end update_kste_access;






		    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
